packages feed

ghc 9.4.2 → 9.14.1

raw patch · 876 files changed

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

Files

Bytecodes.h view
@@ -34,7 +34,6 @@ #define bci_PUSH16_W                    9 #define bci_PUSH32_W                    10 #define bci_PUSH_G                      11-#define bci_PUSH_ALTS                   12 #define bci_PUSH_ALTS_P                 13 #define bci_PUSH_ALTS_N                 14 #define bci_PUSH_ALTS_F                 15@@ -81,7 +80,6 @@ #define bci_CCALL                       56 #define bci_SWIZZLE                     57 #define bci_ENTER                       58-#define bci_RETURN                      59 #define bci_RETURN_P                    60 #define bci_RETURN_N                    61 #define bci_RETURN_F                    62@@ -94,6 +92,129 @@  #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 */
ClosureTypes.h view
@@ -16,6 +16,7 @@  *   - 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@@ -87,4 +88,6 @@ #define SMALL_MUT_ARR_PTRS_FROZEN_DIRTY 61 #define SMALL_MUT_ARR_PTRS_FROZEN_CLEAN 62 #define COMPACT_NFDATA                63-#define N_CLOSURE_TYPES               64+#define CONTINUATION                  64+#define ANN_FRAME                     65+#define N_CLOSURE_TYPES               66
CodeGen.Platform.h view
@@ -1,7 +1,8 @@  import GHC.Cmm.Expr #if !(defined(MACHREGS_i386) || defined(MACHREGS_x86_64) \-    || defined(MACHREGS_powerpc) || defined(MACHREGS_aarch64))+    || defined(MACHREGS_powerpc) || defined(MACHREGS_aarch64) \+    || defined(MACHREGS_riscv64) || defined(MACHREGS_loongarch64)) import GHC.Utils.Panic.Plain #endif import GHC.Platform.Reg@@ -203,6 +204,39 @@ # 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)@@ -377,41 +411,110 @@ # 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+callerSaves (VanillaReg 1)    = True #endif #if defined(CALLER_SAVES_R2)-callerSaves (VanillaReg 2 _)  = True+callerSaves (VanillaReg 2)    = True #endif #if defined(CALLER_SAVES_R3)-callerSaves (VanillaReg 3 _)  = True+callerSaves (VanillaReg 3)    = True #endif #if defined(CALLER_SAVES_R4)-callerSaves (VanillaReg 4 _)  = True+callerSaves (VanillaReg 4)    = True #endif #if defined(CALLER_SAVES_R5)-callerSaves (VanillaReg 5 _)  = True+callerSaves (VanillaReg 5)    = True #endif #if defined(CALLER_SAVES_R6)-callerSaves (VanillaReg 6 _)  = True+callerSaves (VanillaReg 6)    = True #endif #if defined(CALLER_SAVES_R7)-callerSaves (VanillaReg 7 _)  = True+callerSaves (VanillaReg 7)    = True #endif #if defined(CALLER_SAVES_R8)-callerSaves (VanillaReg 8 _)  = True+callerSaves (VanillaReg 8)    = True #endif #if defined(CALLER_SAVES_R9)-callerSaves (VanillaReg 9 _)  = True+callerSaves (VanillaReg 9)    = True #endif #if defined(CALLER_SAVES_R10)-callerSaves (VanillaReg 10 _) = True+callerSaves (VanillaReg 10)   = True #endif #if defined(CALLER_SAVES_F1) callerSaves (FloatReg 1)      = True@@ -487,34 +590,34 @@     ,Hp #endif #if defined(REG_R1)-    ,VanillaReg 1 VGcPtr+    ,VanillaReg 1 #endif #if defined(REG_R2)-    ,VanillaReg 2 VGcPtr+    ,VanillaReg 2 #endif #if defined(REG_R3)-    ,VanillaReg 3 VGcPtr+    ,VanillaReg 3 #endif #if defined(REG_R4)-    ,VanillaReg 4 VGcPtr+    ,VanillaReg 4 #endif #if defined(REG_R5)-    ,VanillaReg 5 VGcPtr+    ,VanillaReg 5 #endif #if defined(REG_R6)-    ,VanillaReg 6 VGcPtr+    ,VanillaReg 6 #endif #if defined(REG_R7)-    ,VanillaReg 7 VGcPtr+    ,VanillaReg 7 #endif #if defined(REG_R8)-    ,VanillaReg 8 VGcPtr+    ,VanillaReg 8 #endif #if defined(REG_R9)-    ,VanillaReg 9 VGcPtr+    ,VanillaReg 9 #endif #if defined(REG_R10)-    ,VanillaReg 10 VGcPtr+    ,VanillaReg 10 #endif #if defined(REG_SpLim)     ,SpLim@@ -664,39 +767,42 @@ #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_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)+globalRegMaybe (VanillaReg 1)           = Just (RealRegSingle REG_R1) # endif # if defined(REG_R2)-globalRegMaybe (VanillaReg 2 _)         = Just (RealRegSingle REG_R2)+globalRegMaybe (VanillaReg 2)           = Just (RealRegSingle REG_R2) # endif # if defined(REG_R3)-globalRegMaybe (VanillaReg 3 _)         = Just (RealRegSingle REG_R3)+globalRegMaybe (VanillaReg 3)           = Just (RealRegSingle REG_R3) # endif # if defined(REG_R4)-globalRegMaybe (VanillaReg 4 _)         = Just (RealRegSingle REG_R4)+globalRegMaybe (VanillaReg 4)           = Just (RealRegSingle REG_R4) # endif # if defined(REG_R5)-globalRegMaybe (VanillaReg 5 _)         = Just (RealRegSingle REG_R5)+globalRegMaybe (VanillaReg 5)           = Just (RealRegSingle REG_R5) # endif # if defined(REG_R6)-globalRegMaybe (VanillaReg 6 _)         = Just (RealRegSingle REG_R6)+globalRegMaybe (VanillaReg 6)           = Just (RealRegSingle REG_R6) # endif # if defined(REG_R7)-globalRegMaybe (VanillaReg 7 _)         = Just (RealRegSingle REG_R7)+globalRegMaybe (VanillaReg 7)           = Just (RealRegSingle REG_R7) # endif # if defined(REG_R8)-globalRegMaybe (VanillaReg 8 _)         = Just (RealRegSingle REG_R8)+globalRegMaybe (VanillaReg 8)           = Just (RealRegSingle REG_R8) # endif # if defined(REG_R9)-globalRegMaybe (VanillaReg 9 _)         = Just (RealRegSingle REG_R9)+globalRegMaybe (VanillaReg 9)           = Just (RealRegSingle REG_R9) # endif # if defined(REG_R10)-globalRegMaybe (VanillaReg 10 _)        = Just (RealRegSingle REG_R10)+globalRegMaybe (VanillaReg 10)          = Just (RealRegSingle REG_R10) # endif # if defined(REG_F1) globalRegMaybe (FloatReg 1)             = Just (RealRegSingle REG_F1)@@ -926,13 +1032,214 @@ -- ip0 -- used for spill offset computations freeReg 16 = False -#if defined(darwin_HOST_OS) || defined(ios_HOST_OS)+-- 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
GHC.hs view
@@ -1,8 +1,10 @@+{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE CPP #-} {-# LANGUAGE NondecreasingIndentation, ScopedTypeVariables #-} {-# LANGUAGE TupleSections, NamedFieldPuns #-}-{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE LambdaCase #-}  -- ----------------------------------------------------------------------------- --@@ -27,7 +29,8 @@         handleSourceError,          -- * Flags and settings-        DynFlags(..), GeneralFlag(..), Severity(..), Backend(..), gopt,+        DynFlags(..), GeneralFlag(..), Severity(..), Backend, gopt,+        ncgBackend, llvmBackend, viaCBackend, interpreterBackend, noBackend,         GhcMode(..), GhcLink(..),         parseDynamicFlags, parseTargetFiles,         getSessionDynFlags,@@ -35,7 +38,9 @@         setSessionDynFlags,         setUnitDynFlags,         getProgramDynFlags, setProgramDynFlags,+        setProgramHUG, setProgramHUG_,         getInteractiveDynFlags, setInteractiveDynFlags,+        normaliseInteractiveDynFlags, initialiseInteractiveDynFlags,         interpretPackageEnv,          -- * Logging@@ -52,6 +57,7 @@         addTarget,         removeTarget,         guessTarget,+        guessTargetId,          -- * Loading\/compiling the program         depanal, depanalE,@@ -75,33 +81,65 @@         ModuleGraph, emptyMG, mapMG, mkModuleGraph, mgModSummaries,         mgLookupModule,         ModSummary(..), ms_mod_name, ModLocation(..),+        pattern ModLocation,         getModSummary,         getModuleGraph,         isLoaded,         isLoadedModule,+        isLoadedHomeModule,         topSortModuleGraph,          -- * Inspecting modules         ModuleInfo,         getModuleInfo,         modInfoTyThings,-        modInfoTopLevelScope,         modInfoExports,         modInfoExportsWithSelectors,         modInfoInstances,         modInfoIsExportedName,         modInfoLookupName,         modInfoIface,-        modInfoRdrEnv,         modInfoSafe,         lookupGlobalName,         findGlobalAnns,-        mkPrintUnqualifiedForModule,-        ModIface, ModIface_(..),+        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-        PrintUnqualified, alwaysQualify,+        NamePprCtx, alwaysQualify,          -- * Interactive evaluation @@ -118,9 +156,10 @@         setGHCiMonad, getGHCiMonad,          -- ** Inspecting the current context-        getBindings, getInsts, getPrintUnqual,+        getBindings, getInsts, getNamePprCtx,         findModule, lookupModule,         findQualifiedModule, lookupQualifiedModule,+        lookupLoadedHomeModuleByModuleName, lookupAllQualifiedModuleNames,         renamePkgQualM, renameRawPkgQualM,         isModuleTrusted, moduleTrustReqs,         getNamesInScope,@@ -156,14 +195,14 @@         -- ** The debugger         SingleStep(..),         Resume(..),-        History(historyBreakInfo, historyEnclosingDecls),+        History(historyBreakpointId, historyEnclosingDecls),         GHC.getHistorySpan, getHistoryModule,         abandon, abandonAll,         getResumeContext,         GHC.obtainTermFromId, GHC.obtainTermFromVal, reconstructType,         modInfoModBreaks,-        ModBreaks(..), BreakIndex,-        BreakInfo(..),+        ModBreaks(..), BreakTickIndex,+        BreakpointId(..), InternalBreakpointId(..),         GHC.Runtime.Eval.back,         GHC.Runtime.Eval.forward,         GHC.Runtime.Eval.setupBreakpoint,@@ -175,7 +214,6 @@          -- ** Modules         Module, mkModule, pprModule, moduleName, moduleUnit,-        ModuleName, mkModuleName, moduleNameString,          -- ** Names         Name,@@ -197,7 +235,7 @@         TyCon,         tyConTyVars, tyConDataCons, tyConArity,         isClassTyCon, isTypeSynonymTyCon, isTypeFamilyTyCon, isNewTyCon,-        isPrimTyCon, isFunTyCon,+        isPrimTyCon,         isFamilyTyCon, isOpenFamilyTyCon, isOpenTypeFamilyTyCon,         tyConClass_maybe,         synTyConRhs_maybe, synTyConDefn_maybe, tyConKind,@@ -287,11 +325,7 @@         parser,          -- * API Annotations-        AnnKeywordId(..),EpaComment(..),--        -- * Miscellaneous-        --sessionHscEnv,-        cyclicModuleErr,+        EpaComment(..)   ) where  {-@@ -312,10 +346,12 @@ 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@@ -336,6 +372,7 @@ 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 )@@ -352,10 +389,8 @@ import GHC.Tc.Instance.Family  import GHC.Utils.TmpFs-import GHC.SysTools-import GHC.SysTools.BaseDir- import GHC.Utils.Error+import GHC.Utils.Exception import GHC.Utils.Monad import GHC.Utils.Misc import GHC.Utils.Outputable@@ -369,11 +404,12 @@ import GHC.Core.TyCo.Ppr   ( pprForAll ) import GHC.Core.Class import GHC.Core.DataCon-import GHC.Core.FVs        ( orphNamesOfFamInst )-import GHC.Core.FamInstEnv ( FamInst, famInstEnvElts )+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@@ -390,14 +426,11 @@ import GHC.Types.Basic import GHC.Types.TyThing import GHC.Types.Name.Env-import GHC.Types.Name.Ppr import GHC.Types.TypeEnv-import GHC.Types.BreakInfo import GHC.Types.PkgQual  import GHC.Unit-import GHC.Unit.Env-import GHC.Unit.External+import GHC.Unit.Env as UnitEnv import GHC.Unit.Finder import GHC.Unit.Module.ModIface import GHC.Unit.Module.ModGuts@@ -405,29 +438,30 @@ 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 Data.Maybe-import Data.Typeable    ( Typeable )-import Data.Word        ( Word8 )-import Control.Monad++import System.Directory+import System.Environment ( getEnv, getProgName ) import System.Exit      ( exitWith, ExitCode(..) )-import GHC.Utils.Exception-import Data.IORef import System.FilePath-import Control.Concurrent-import Control.Applicative ((<|>))-import Control.Monad.Catch as MC--import GHC.Data.Maybe import System.IO.Error  ( isDoesNotExistError )-import System.Environment ( getEnv, getProgName )-import System.Directory-import Data.List (isPrefixOf)-import qualified Data.Set as S   -- %************************************************************************@@ -458,6 +492,8 @@                          liftIO $ throwIO UserInterrupt                      Just StackOverflow ->                          fm "stack overflow: use +RTS -K<size> to increase it"+                     Just HeapOverflow ->+                         fm "heap overflow: use +RTS -M<size> to increase maximum heap size"                      _ -> case fromException exception of                           Just (ex :: ExitCode) -> liftIO $ throwIO ex                           _ ->@@ -560,53 +596,16 @@ -- <http://hackage.haskell.org/package/ghc-paths>.  initGhcMonad :: GhcMonad m => Maybe FilePath -> m ()-initGhcMonad mb_top_dir-  = do { env <- liftIO $-                do { top_dir <- findTopDir mb_top_dir-                   ; mySettings <- initSysTools top_dir-                   ; myLlvmConfig <- lazyInitLlvmConfig top_dir-                   ; dflags <- initDynFlags (defaultDynFlags mySettings myLlvmConfig)-                   ; hsc_env <- newHscEnv dflags-                   ; checkBrokenTablesNextToCode (hsc_logger hsc_env) dflags-                   ; setUnsafeGlobalDynFlags dflags-                      -- c.f. DynFlags.parseDynamicFlagsFull, which-                      -- creates DynFlags and sets the UnsafeGlobalDynFlags-                   ; return hsc_env }-       ; 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://gitlab.haskell.org/ghc/ghc/issues/4210#note_78333-checkBrokenTablesNextToCode :: MonadIO m => Logger -> DynFlags -> m ()-checkBrokenTablesNextToCode logger dflags-  = do { broken <- checkBrokenTablesNextToCode' logger dflags-       ; when broken-         $ do { _ <- liftIO $ throwIO $ mkApiErr dflags invalidLdErr-              ; liftIO $ 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 => Logger -> DynFlags -> m Bool-checkBrokenTablesNextToCode' logger dflags-  | not (isARM arch)               = return False-  | ways dflags `hasNotWay` WayDyn = return False-  | not tablesNextToCode           = return False-  | otherwise                      = do-    linkerInfo <- liftIO $ getLinkerInfo logger dflags-    case linkerInfo of-      GnuLD _  -> return True-      _        -> return False-  where platform = targetPlatform dflags-        arch = platformArch platform-        tablesNextToCode = platformTablesNextToCode platform-+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+  )  -- %************************************************************************ -- %*                                                                      *@@ -635,7 +634,7 @@ -- 'setSessionDynFlags' sets both @DynFlags@, and 'getSessionDynFlags' -- retrieves the program @DynFlags@ (for backwards compatibility). --- This is a compatability function which sets dynflags for the top session+-- 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@@ -646,7 +645,7 @@   case S.toList all_uids of     [uid] -> do       setUnitDynFlagsNoCheck uid dflags-      modifySession (hscSetActiveUnitId (homeUnitId_ dflags))+      modifySession (hscUpdateLoggerFlags . hscSetActiveUnitId (homeUnitId_ dflags))       dflags' <- getDynFlags       setTopSessionDynFlags dflags'     [] -> panic "nohue"@@ -677,7 +676,7 @@           , homeUnitEnv_home_unit = Just home_unit           } -  let unit_env = ue_updateHomeUnitEnv upd uid (hsc_unit_env hsc_env)+  let unit_env = UnitEnv.ue_updateHomeUnitEnv upd uid (hsc_unit_env hsc_env)    let dflags = updated_dflags @@ -695,7 +694,7 @@   let !unit_env1 =         if homeUnitId_ dflags /= uid           then-            ue_renameUnitId+            UnitEnv.renameUnitId                   uid                   (homeUnitId_ dflags)                   unit_env0@@ -713,16 +712,70 @@ setTopSessionDynFlags dflags = do   hsc_env <- getSession   logger  <- getLogger+  lookup_cache  <- liftIO $ mkInterpSymbolCache -  -- Interpreter-  interp <- if gopt Opt_ExternalInterpreter dflags-    then do+  -- 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  = "-prof" -- FIXME: can't we have both?+             | profiled && dynamic = "-prof-dyn"+             | profiled  = "-prof"              | dynamic   = "-dyn"              | otherwise = ""            msg = text "Starting " <> text prog@@ -738,14 +791,17 @@             , iservConfHook     = createIservProcessHook (hsc_hooks hsc_env)             , iservConfTrace    = tr             }-         s <- liftIO $ newMVar IServPending+         s <- liftIO $ newMVar InterpPending          loader <- liftIO Loader.uninitializedLoader-         return (Just (Interp (ExternalInterp conf (IServ s)) loader))-    else+         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))+      return (Just (Interp InternalInterp loader lookup_cache)) #else       return Nothing #endif@@ -782,7 +838,7 @@           let cached_unit_dbs = homeUnitEnv_unit_dbs homeUnitEnv               dflags = homeUnitEnv_dflags homeUnitEnv               old_hpt = homeUnitEnv_hpt homeUnitEnv-              home_units = unitEnv_keys (ue_home_unit_graph old_unit_env)+              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 @@ -795,12 +851,13 @@             , homeUnitEnv_home_unit = Just home_unit             } -        let dflags1 = homeUnitEnv_dflags $ unitEnv_lookup (ue_currentUnit old_unit_env) home_unit_graph+        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 }@@ -809,7 +866,115 @@   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@@ -831,7 +996,7 @@ -- invalidateModSummaryCache :: GhcMonad m => m () invalidateModSummaryCache =-  modifySession $ \h -> h { hsc_mod_graph = mapMG inval (hsc_mod_graph h) }+  modifySession $ \hsc_env -> setModuleGraph (mapMG inval (hsc_mod_graph hsc_env)) hsc_env  where   inval ms = ms { ms_hs_hash = fingerprint0 } @@ -848,24 +1013,8 @@ setInteractiveDynFlags :: GhcMonad m => DynFlags -> m () setInteractiveDynFlags dflags = do   logger <- getLogger-  dflags' <- checkNewDynFlags logger dflags-  dflags'' <- checkNewInteractiveDynFlags logger dflags'-  modifySessionM $ \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-                    }-                }-+  icdflags <- normaliseInteractiveDynFlags logger dflags+  modifySessionM (initialiseInteractiveDynFlags icdflags)  -- | Get the 'DynFlags' used to evaluate interactive expressions. getInteractiveDynFlags :: GhcMonad m => m DynFlags@@ -877,9 +1026,9 @@     => Logger     -> DynFlags     -> [Located String]-    -> m (DynFlags, [Located String], [Warn])+    -> m (DynFlags, [Located String], Messages DriverMessage) parseDynamicFlags logger dflags cmdline = do-  (dflags1, leftovers, warns) <- parseDynamicFlagsCmdLine dflags cmdline+  (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)@@ -970,15 +1119,49 @@  ----------------------------------------------------------------------------- +-- | 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) = makeDynFlagsConsistent dflags+  let (dflags', warnings, infoverb) = makeDynFlagsConsistent dflags   let diag_opts = initDiagOpts dflags-  liftIO $ handleFlagWarnings logger diag_opts (map (Warn WarningWithoutFlag) warnings)+      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@@ -988,7 +1171,8 @@   if xopt LangExt.StaticPointers dflags0   then do     let diag_opts = initDiagOpts dflags0-    liftIO $ printOrThrowDiagnostics logger diag_opts $ singleMessage+        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@@ -1027,7 +1211,7 @@   where    filter targets = [ t | t@Target { targetId = id } <- targets, id /= target_id ] --- | Attempts to guess what Target a string refers to.  This function+-- | 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@@ -1036,27 +1220,52 @@ --   - 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+--   - 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+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-   = target (TargetFile file Nothing)+   = pure (TargetFile file Nothing)    | otherwise    = do exists <- liftIO $ doesFileExist hs_file         if exists-           then target (TargetFile hs_file Nothing)+           then pure (TargetFile hs_file Nothing)            else do         exists <- liftIO $ doesFileExist lhs_file         if exists-           then target (TargetFile lhs_file Nothing)+           then pure (TargetFile lhs_file Nothing)            else do         if looksLikeModuleName file-           then target (TargetModule (mkModuleName file))+           then pure (TargetModule (mkModuleName file))            else do         dflags <- getDynFlags         liftIO $ throwGhcExceptionIO@@ -1064,16 +1273,12 @@                  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"+        file+          | '*':rest <- str = rest+          | otherwise       = str -         target tid = do-           tuid <- unitIdOrHomeUnit mUnitId-           pure $ Target tid obj_allowed tuid Nothing+        hs_file  = file <.> "hs"+        lhs_file = file <.> "lhs"  -- | Unwrap 'UnitId' or retrieve the 'UnitId' -- of the current 'HomeUnit'.@@ -1169,9 +1374,9 @@ instance DesugaredMod DesugaredModule where   coreModule m = dm_core_module m -type ParsedSource      = Located HsModule+type ParsedSource      = Located (HsModule GhcPs) type RenamedSource     = (HsGroup GhcRn, [LImportDecl GhcRn], Maybe [(LIE GhcRn, Avails)],-                          Maybe (LHsDoc GhcRn))+                          Maybe (LHsDoc GhcRn), Maybe (XRec GhcRn ModuleName)) type TypecheckedSource = LHsBinds GhcTc  -- NOTE:@@ -1194,11 +1399,11 @@ -- -- 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 :: GhcMonad m => Module -> m ModSummary getModSummary mod = do    mg <- liftM hsc_mod_graph getSession    let mods_by_name = [ ms | ms <- mgModSummaries mg-                      , ms_mod_name ms == mod+                      , ms_mod ms == mod                       , isBootSummary ms == NotBoot ]    case mods_by_name of      [] -> do dflags <- getDynFlags@@ -1229,7 +1434,9 @@  liftIO $ do    let ms          = modSummary pmod    let lcl_dflags  = ms_hspp_opts ms -- take into account pragmas (OPTIONS_GHC, etc.)-   let lcl_hsc_env = hscSetFlags lcl_dflags hsc_env+   let lcl_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,@@ -1247,11 +1454,10 @@          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 $ instEnvElts $ md_insts details,            minf_iface     = Nothing,            minf_safe      = safe,-           minf_modBreaks = emptyModBreaks+           minf_modBreaks = Nothing          }}  -- | Desugar a typechecked module.@@ -1340,8 +1546,7 @@           else              return $ Right mod_guts -     Nothing -> panic "compileToCoreModule: target FilePath not found in\-                           module dependency graph"+     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.@@ -1363,164 +1568,8 @@           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---- | Return @True@ \<==> module is loaded.-isLoaded :: GhcMonad m => ModuleName -> m Bool-isLoaded m = withSession $ \hsc_env ->-  return $! isJust (lookupHpt (hsc_HPT hsc_env) m)--isLoadedModule :: GhcMonad m => UnitId -> ModuleName -> m Bool-isLoadedModule uid m = withSession $ \hsc_env ->-  return $! isJust (lookupHug (hsc_HUG hsc_env) uid m)---- | Return the bindings for the current interactive session.-getBindings :: GhcMonad m => m [TyThing]-getBindings = withSession $ \hsc_env ->-    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)--getPrintUnqual :: GhcMonad m => m PrintUnqualified-getPrintUnqual = withSession $ \hsc_env -> do-  return $ icPrintUnqual (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_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-  if moduleUnitId mdl `S.member` hsc_all_home_unit_ids 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_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-                }))--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 }---getHomeModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo)-getHomeModuleInfo hsc_env mdl =-  case lookupHugByModule mdl (hsc_HUG hsc_env) 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 = 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)--modInfoTopLevelScope :: ModuleInfo -> Maybe [Name]-modInfoTopLevelScope minf-  = fmap (map greMangledName . 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-  let mk_print_unqual = mkPrintUnqualified (hsc_unit_env hsc_env)-  return (fmap mk_print_unqual (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      -> liftIO (lookupType hsc_env name)--modInfoIface :: ModuleInfo -> Maybe ModIface-modInfoIface = minf_iface--modInfoRdrEnv :: ModuleInfo -> Maybe GlobalRdrEnv-modInfoRdrEnv = minf_rdr_env---- | 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 }+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@@ -1706,6 +1755,7 @@  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@@ -1731,7 +1781,7 @@ 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)))+   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)@@ -1768,11 +1818,56 @@ lookupQualifiedModule pkgqual mod_name = findQualifiedModule pkgqual mod_name  lookupLoadedHomeModule :: GhcMonad m => UnitId -> ModuleName -> m (Maybe Module)-lookupLoadedHomeModule uid mod_name = withSession $ \hsc_env ->-  case lookupHug  (hsc_HUG hsc_env) uid mod_name  of+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@@ -1803,14 +1898,17 @@ getGHCiMonad = fmap (ic_monad . hsc_IC) getSession  getHistorySpan :: GhcMonad m => History -> m SrcSpan-getHistorySpan h = withSession $ \hsc_env ->-    return $ GHC.Runtime.Eval.getHistorySpan hsc_env h+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 -> Bool -> Id -> m Term+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 @@ -1830,7 +1928,7 @@ parser :: String         -- ^ Haskell module source text (full Unicode is supported)        -> DynFlags       -- ^ the flags        -> FilePath       -- ^ the filename (for source locations)-       -> (WarningMessages, Either ErrorMessages (Located HsModule))+       -> (WarningMessages, Either ErrorMessages (Located (HsModule GhcPs)))  parser str dflags filename =    let@@ -1994,3 +2092,9 @@  mkApiErr :: DynFlags -> SDoc -> GhcApiError mkApiErr dflags msg = GhcApiError (showSDoc dflags msg)+++#if !defined(javascript_HOST_ARCH)+foreign import ccall unsafe "keepCAFsForGHCi"+    c_keepCAFsForGHCi   :: IO Bool+#endif
GHC/Builtin/Names.hs view
@@ -4,2788 +4,2774 @@ \section[GHC.Builtin.Names]{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 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-     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, 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-     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.--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) GHC.Iface.Env.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]--Note that one-tuples are an exception to the rule, as they do get assigned-known keys. See-Note [One-tuples] (Wrinkle: Make boxed one-tuple names have known keys)-in GHC.Builtin.Types.---}--{-# LANGUAGE CPP #-}-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}--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.Unit.Module.Name-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--{--************************************************************************-*                                                                      *-     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 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,-        mkTrAppName,-        mkTrFunName,-        typeSymbolTypeRepName, typeNatTypeRepName, typeCharTypeRepName,-        trGhcPrimModuleName,--        -- KindReps for common cases-        starKindRepName,-        starArrStarKindRepName,-        starArrStarArrStarKindRepName,--        -- WithDict-        withDictClassName,--        -- 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-        groupWithName,-        considerAccessibleName,--        -- Strings and lists-        unpackCStringName, unpackCStringUtf8Name,-        unpackCStringAppendName, unpackCStringAppendUtf8Name,-        unpackCStringFoldrName, unpackCStringFoldrUtf8Name,-        cstringLengthName,--        -- Overloaded lists-        isListClassName,-        fromListName,-        fromListNName,-        toListName,--        -- 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,-        int8TyConName, int16TyConName, int32TyConName, int64TyConName,-        word8TyConName, word16TyConName, word32TyConName, word64TyConName,--        -- 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,--        bignatFromWordListName,-        bignatEqName,--        -- Float/Double-        integerToFloatName,-        integerToDoubleName,-        naturalToFloatName,-        naturalToDoubleName,-        rationalToFloatName,-        rationalToDoubleName,--        -- Other classes-        randomClassName, randomGenClassName, monadPlusClassName,--        -- Type-level naturals-        knownNatClassName, knownSymbolClassName, knownCharClassName,--        -- Overloaded labels-        fromLabelClassOpName,--        -- Implicit Parameters-        ipClassName,--        -- Overloaded record fields-        hasFieldClassName,--        -- 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--        -- Unsafe coercion proofs-        , unsafeEqualityProofName-        , unsafeEqualityTyConName-        , unsafeReflDataConName-        , unsafeCoercePrimName-    ]--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--}--pRELUDE :: Module-pRELUDE         = mkBaseModule_ pRELUDE_NAME--gHC_PRIM, gHC_PRIM_PANIC, gHC_PRIM_EXCEPTION,-    gHC_TYPES, gHC_GENERICS, gHC_MAGIC, gHC_MAGIC_DICT,-    gHC_CLASSES, gHC_PRIMOPWRAPPERS, gHC_BASE, gHC_ENUM,-    gHC_GHCI, gHC_GHCI_HELPERS, gHC_CSTRING,-    gHC_SHOW, gHC_READ, gHC_NUM, gHC_MAYBE,-    gHC_NUM_INTEGER, gHC_NUM_NATURAL, gHC_NUM_BIGNAT,-    gHC_LIST, gHC_TUPLE, dATA_EITHER, dATA_VOID, dATA_LIST, dATA_STRING,-    dATA_FOLDABLE, dATA_TRAVERSABLE,-    gHC_CONC, gHC_IO, gHC_IO_Exception,-    gHC_ST, gHC_IX, gHC_STABLE, gHC_PTR, gHC_ERR, gHC_REAL,-    gHC_FLOAT, gHC_TOP_HANDLER, sYSTEM_IO, dYNAMIC,-    tYPEABLE, tYPEABLE_INTERNAL, gENERICS,-    rEAD_PREC, lEX, gHC_INT, gHC_WORD, mONAD, mONAD_FIX, mONAD_ZIP, mONAD_FAIL,-    aRROW, gHC_DESUGAR, rANDOM, gHC_EXTS, gHC_IS_LIST,-    cONTROL_EXCEPTION_BASE, gHC_TYPEERROR, gHC_TYPELITS, gHC_TYPELITS_INTERNAL,-    gHC_TYPENATS, gHC_TYPENATS_INTERNAL,-    dATA_COERCE, dEBUG_TRACE, uNSAFE_COERCE :: Module--gHC_PRIM        = mkPrimModule (fsLit "GHC.Prim")   -- Primitive types and values-gHC_PRIM_PANIC  = mkPrimModule (fsLit "GHC.Prim.Panic")-gHC_PRIM_EXCEPTION = mkPrimModule (fsLit "GHC.Prim.Exception")-gHC_TYPES       = mkPrimModule (fsLit "GHC.Types")-gHC_MAGIC       = mkPrimModule (fsLit "GHC.Magic")-gHC_MAGIC_DICT  = mkPrimModule (fsLit "GHC.Magic.Dict")-gHC_CSTRING     = mkPrimModule (fsLit "GHC.CString")-gHC_CLASSES     = mkPrimModule (fsLit "GHC.Classes")-gHC_PRIMOPWRAPPERS = mkPrimModule (fsLit "GHC.PrimopWrappers")--gHC_BASE        = mkBaseModule (fsLit "GHC.Base")-gHC_ENUM        = mkBaseModule (fsLit "GHC.Enum")-gHC_GHCI        = mkBaseModule (fsLit "GHC.GHCi")-gHC_GHCI_HELPERS= mkBaseModule (fsLit "GHC.GHCi.Helpers")-gHC_SHOW        = mkBaseModule (fsLit "GHC.Show")-gHC_READ        = mkBaseModule (fsLit "GHC.Read")-gHC_NUM         = mkBaseModule (fsLit "GHC.Num")-gHC_MAYBE       = mkBaseModule (fsLit "GHC.Maybe")-gHC_NUM_INTEGER = mkBignumModule (fsLit "GHC.Num.Integer")-gHC_NUM_NATURAL = mkBignumModule (fsLit "GHC.Num.Natural")-gHC_NUM_BIGNAT  = mkBignumModule (fsLit "GHC.Num.BigNat")-gHC_LIST        = mkBaseModule (fsLit "GHC.List")-gHC_TUPLE       = mkPrimModule (fsLit "GHC.Tuple")-dATA_EITHER     = mkBaseModule (fsLit "Data.Either")-dATA_VOID       = mkBaseModule (fsLit "Data.Void")-dATA_LIST       = mkBaseModule (fsLit "Data.List")-dATA_STRING     = mkBaseModule (fsLit "Data.String")-dATA_FOLDABLE   = mkBaseModule (fsLit "Data.Foldable")-dATA_TRAVERSABLE= mkBaseModule (fsLit "Data.Traversable")-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_IX          = mkBaseModule (fsLit "GHC.Ix")-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")-gHC_DESUGAR = mkBaseModule (fsLit "GHC.Desugar")-rANDOM          = mkBaseModule (fsLit "System.Random")-gHC_EXTS        = mkBaseModule (fsLit "GHC.Exts")-gHC_IS_LIST     = mkBaseModule (fsLit "GHC.IsList")-cONTROL_EXCEPTION_BASE = mkBaseModule (fsLit "Control.Exception.Base")-gHC_GENERICS    = mkBaseModule (fsLit "GHC.Generics")-gHC_TYPEERROR   = mkBaseModule (fsLit "GHC.TypeError")-gHC_TYPELITS    = mkBaseModule (fsLit "GHC.TypeLits")-gHC_TYPELITS_INTERNAL = mkBaseModule (fsLit "GHC.TypeLits.Internal")-gHC_TYPENATS    = mkBaseModule (fsLit "GHC.TypeNats")-gHC_TYPENATS_INTERNAL = mkBaseModule (fsLit "GHC.TypeNats.Internal")-dATA_COERCE     = mkBaseModule (fsLit "Data.Coerce")-dEBUG_TRACE     = mkBaseModule (fsLit "Debug.Trace")-uNSAFE_COERCE   = mkBaseModule (fsLit "Unsafe.Coerce")--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")--rOOT_MAIN :: Module-rOOT_MAIN       = mkMainModule (fsLit ":Main") -- Root module for initialisation--mkInteractiveModule :: Int -> Module--- (mkInteractiveMoudule 9) makes module 'interactive:Ghci9'-mkInteractiveModule n = mkModule interactiveUnit (mkModuleName ("Ghci" ++ show n))--pRELUDE_NAME, mAIN_NAME :: ModuleName-pRELUDE_NAME   = mkModuleNameFS (fsLit "Prelude")-mAIN_NAME      = mkModuleNameFS (fsLit "Main")--mkPrimModule :: FastString -> Module-mkPrimModule m = mkModule primUnit (mkModuleNameFS m)--mkBignumModule :: FastString -> Module-mkBignumModule m = mkModule bignumUnit (mkModuleNameFS m)--mkBaseModule :: FastString -> Module-mkBaseModule m = mkBaseModule_ (mkModuleNameFS m)--mkBaseModule_ :: ModuleName -> Module-mkBaseModule_ m = mkModule baseUnit 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--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                 = 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 :: 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, integerAdd_RDR, integerMul_RDR :: RdrName-ratioDataCon_RDR        = nameRdrName ratioDataConName-integerAdd_RDR          = nameRdrName integerAddName-integerMul_RDR          = nameRdrName integerMulName--ioDataCon_RDR :: RdrName-ioDataCon_RDR           = nameRdrName ioDataConName--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--fromString_RDR :: RdrName-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, 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_PRIM (fsLit "dataToTag#")-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_IX (fsLit "range")-inRange_RDR             = varQual_RDR gHC_IX (fsLit "inRange")-index_RDR               = varQual_RDR gHC_IX (fsLit "index")-unsafeIndex_RDR         = varQual_RDR gHC_IX (fsLit "unsafeIndex")-unsafeRangeSize_RDR     = varQual_RDR gHC_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_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")--readField_RDR, readFieldHash_RDR, readSymField_RDR :: RdrName-readField_RDR           = varQual_RDR gHC_READ (fsLit "readField")-readFieldHash_RDR       = varQual_RDR gHC_READ (fsLit "readFieldHash")-readSymField_RDR        = varQual_RDR gHC_READ (fsLit "readSymField")--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")--showsPrec_RDR, shows_RDR, showString_RDR,-    showSpace_RDR, showCommaSpace_RDR, showParen_RDR :: RdrName-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")--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  = nameRdrName leftAssociativeDataConName-rightAssocDataCon_RDR = nameRdrName rightAssociativeDataConName-notAssocDataCon_RDR   = nameRdrName notAssociativeDataConName--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, null_RDR, all_RDR, traverse_RDR, mempty_RDR,-    mappend_RDR :: RdrName-fmap_RDR                = nameRdrName fmapName-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")-null_RDR                = varQual_RDR dATA_FOLDABLE       (fsLit "null")-all_RDR                 = varQual_RDR dATA_FOLDABLE       (fsLit "all")-traverse_RDR            = varQual_RDR 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)--{--************************************************************************-*                                                                      *-\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_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  dATA_EITHER (fsLit "Either") eitherTyConKey-leftDataConName   = dcQual dATA_EITHER (fsLit "Left")   leftDataConKey-rightDataConName  = dcQual dATA_EITHER (fsLit "Right")  rightDataConKey--voidTyConName :: Name-voidTyConName = tcQual dATA_VOID (fsLit "Void") voidTyConKey---- Generics (types)-v1TyConName, u1TyConName, par1TyConName, rec1TyConName,-  k1TyConName, m1TyConName, sumTyConName, prodTyConName,-  compTyConName, rTyConName, dTyConName,-  cTyConName, sTyConName, rec0TyConName,-  d1TyConName, c1TyConName, s1TyConName,-  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--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, unpackCStringFoldrUtf8Name,-    unpackCStringAppendName, unpackCStringAppendUtf8Name,-    eqStringName, cstringLengthName :: Name-cstringLengthName       = varQual gHC_CSTRING (fsLit "cstringLength#") cstringLengthIdKey-eqStringName            = varQual gHC_BASE (fsLit "eqString")  eqStringIdKey--unpackCStringName       = varQual gHC_CSTRING (fsLit "unpackCString#") unpackCStringIdKey-unpackCStringAppendName = varQual gHC_CSTRING (fsLit "unpackAppendCString#") unpackCStringAppendIdKey-unpackCStringFoldrName  = varQual gHC_CSTRING (fsLit "unpackFoldrCString#") unpackCStringFoldrIdKey--unpackCStringUtf8Name       = varQual gHC_CSTRING (fsLit "unpackCStringUtf8#") unpackCStringUtf8IdKey-unpackCStringAppendUtf8Name = varQual gHC_CSTRING (fsLit "unpackAppendCStringUtf8#") unpackCStringAppendUtf8IdKey-unpackCStringFoldrUtf8Name  = varQual gHC_CSTRING (fsLit "unpackFoldrCStringUtf8#") unpackCStringFoldrUtf8IdKey----- The 'inline' function-inlineIdName :: Name-inlineIdName            = varQual gHC_MAGIC (fsLit "inline") inlineIdKey---- 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 :: 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---- 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 gHC_BASE       (fsLit "Semigroup") semigroupClassKey-sappendName        = varQual gHC_BASE       (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, considerAccessibleName :: Name-groupWithName          = varQual gHC_EXTS (fsLit "groupWith")          groupWithIdKey-considerAccessibleName = varQual gHC_EXTS (fsLit "considerAccessible") considerAccessibleIdKey---- Random GHC.Base functions-fromStringName, otherwiseIdName, foldrName, buildName, augmentName,-    mapName, appendName, assertName,-    dollarName :: Name-dollarName        = varQual gHC_BASE (fsLit "$")          dollarIdKey-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-fromStringName = varQual dATA_STRING (fsLit "fromString") fromStringClassOpKey---- 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-------------------------------------- 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-   , bignatFromWordListName-   , bignatEqName-   , bignatCompareName-   , bignatCompareWordName-   :: Name--bnbVarQual, bnnVarQual, bniVarQual :: String -> Unique -> Name-bnbVarQual str key = varQual gHC_NUM_BIGNAT  (fsLit str) key-bnnVarQual str key = varQual gHC_NUM_NATURAL (fsLit str) key-bniVarQual str key = varQual gHC_NUM_INTEGER (fsLit str) key---- Types and DataCons-bignatFromWordListName    = bnbVarQual "bigNatFromWordList#"       bignatFromWordListIdKey-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.Real types and classes-rationalTyConName, ratioTyConName, ratioDataConName, realClassName,-    integralClassName, realFracClassName, fractionalClassName,-    fromRationalName, toIntegerName, toRationalName, fromIntegralName,-    realToFracName, mkRationalBase2Name, mkRationalBase10Name :: 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-mkRationalBase2Name  = varQual  gHC_REAL  (fsLit "mkRationalBase2")  mkRationalBase2IdKey-mkRationalBase10Name = varQual  gHC_REAL  (fsLit "mkRationalBase10") mkRationalBase10IdKey--- GHC.Float classes-floatingClassName, realFloatClassName :: Name-floatingClassName  = clsQual gHC_FLOAT (fsLit "Floating")  floatingClassKey-realFloatClassName = clsQual gHC_FLOAT (fsLit "RealFloat") realFloatClassKey---- other GHC.Float functions-integerToFloatName, integerToDoubleName,-  naturalToFloatName, naturalToDoubleName,-  rationalToFloatName, rationalToDoubleName :: Name-integerToFloatName   = varQual gHC_FLOAT (fsLit "integerToFloat#") integerToFloatIdKey-integerToDoubleName  = varQual gHC_FLOAT (fsLit "integerToDouble#") integerToDoubleIdKey-naturalToFloatName   = varQual gHC_FLOAT (fsLit "naturalToFloat#") naturalToFloatIdKey-naturalToDoubleName  = varQual gHC_FLOAT (fsLit "naturalToDouble#") naturalToDoubleIdKey-rationalToFloatName  = varQual gHC_FLOAT (fsLit "rationalToFloat") rationalToFloatIdKey-rationalToDoubleName = varQual gHC_FLOAT (fsLit "rationalToDouble") rationalToDoubleIdKey---- Class Ix-ixClassName :: Name-ixClassName = clsQual gHC_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-  , mkTrAppName-  , mkTrFunName-  , typeRepIdName-  , typeNatTypeRepName-  , typeSymbolTypeRepName-  , typeCharTypeRepName-  , 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-mkTrTypeName          = varQual tYPEABLE_INTERNAL (fsLit "mkTrType")       mkTrTypeKey-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-typeCharTypeRepName   = varQual 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 :: Name-starKindRepName        = varQual gHC_TYPES         (fsLit "krep$*")         starKindRepKey-starArrStarKindRepName = varQual gHC_TYPES         (fsLit "krep$*Arr*")     starArrStarKindRepKey-starArrStarArrStarKindRepName = varQual gHC_TYPES  (fsLit "krep$*->*->*")   starArrStarArrStarKindRepKey---- WithDict-withDictClassName :: Name-withDictClassName     = clsQual gHC_MAGIC_DICT (fsLit "WithDict") withDictClassKey---- Custom type errors-errorMessageTypeErrorFamName-  , typeErrorTextDataConName-  , typeErrorAppendDataConName-  , typeErrorVAppendDataConName-  , typeErrorShowTypeDataConName-  :: Name--errorMessageTypeErrorFamName =-  tcQual gHC_TYPEERROR (fsLit "TypeError") errorMessageTypeErrorFamKey--typeErrorTextDataConName =-  dcQual gHC_TYPEERROR (fsLit "Text") typeErrorTextDataConKey--typeErrorAppendDataConName =-  dcQual gHC_TYPEERROR (fsLit ":<>:") typeErrorAppendDataConKey--typeErrorVAppendDataConName =-  dcQual gHC_TYPEERROR (fsLit ":$$:") typeErrorVAppendDataConKey--typeErrorShowTypeDataConName =-  dcQual gHC_TYPEERROR (fsLit "ShowType") typeErrorShowTypeDataConKey---- Unsafe coercion proofs-unsafeEqualityProofName, unsafeEqualityTyConName, unsafeCoercePrimName,-  unsafeReflDataConName :: Name-unsafeEqualityProofName = varQual uNSAFE_COERCE (fsLit "unsafeEqualityProof") unsafeEqualityProofIdKey-unsafeEqualityTyConName = tcQual uNSAFE_COERCE (fsLit "UnsafeEquality") unsafeEqualityTyConKey-unsafeReflDataConName   = dcQual uNSAFE_COERCE (fsLit "UnsafeRefl")     unsafeReflDataConKey-unsafeCoercePrimName    = varQual uNSAFE_COERCE (fsLit "unsafeCoerce#") unsafeCoercePrimIdKey---- 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---- Debug.Trace-traceName          :: Name-traceName         = varQual dEBUG_TRACE (fsLit "trace") traceKey---- 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_IS_LIST (fsLit "IsList")    isListClassKey-fromListName    = varQual gHC_IS_LIST (fsLit "fromList")  fromListClassOpKey-fromListNName   = varQual gHC_IS_LIST (fsLit "fromListN") fromListNClassOpKey-toListName      = varQual gHC_IS_LIST (fsLit "toList")    toListClassOpKey---- HasField class ops-getFieldName, setFieldName :: Name-getFieldName   = varQual gHC_RECORDS (fsLit "getField") getFieldClassOpKey-setFieldName   = varQual gHC_RECORDS (fsLit "setField") setFieldClassOpKey---- 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-word8TyConName, word16TyConName, word32TyConName, word64TyConName :: Name-word8TyConName    = tcQual  gHC_WORD (fsLit "Word8")  word8TyConKey-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-knownCharClassName :: Name-knownCharClassName  = clsQual gHC_TYPELITS (fsLit "KnownChar") knownCharClassNameKey---- Overloaded labels-fromLabelClassOpName :: Name-fromLabelClassOpName- = varQual gHC_OVER_LABELS (fsLit "fromLabel") fromLabelClassOpKey---- 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 "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_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--{--************************************************************************-*                                                                      *-\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--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.Types.Evidence-knownNatClassNameKey :: Unique-knownNatClassNameKey = mkPreludeClassUnique 42---- KnownSymbol: see Note [KnownNat & KnownSymbol and EvLit] in GHC.Tc.Types.Evidence-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, ioPortPrimTyConKey,-    smallArrayPrimTyConKey, smallMutableArrayPrimTyConKey,-    stringTyConKey :: 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                      = mkPreludeTyConUnique 34-ratioTyConKey                           = mkPreludeTyConUnique 35-rationalTyConKey                        = mkPreludeTyConUnique 36-realWorldTyConKey                       = mkPreludeTyConUnique 37-stablePtrPrimTyConKey                   = mkPreludeTyConUnique 38-stablePtrTyConKey                       = mkPreludeTyConUnique 39-eqTyConKey                              = mkPreludeTyConUnique 40-heqTyConKey                             = mkPreludeTyConUnique 41--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 :: 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--eitherTyConKey :: Unique-eitherTyConKey                          = mkPreludeTyConUnique 84--voidTyConKey :: Unique-voidTyConKey                            = mkPreludeTyConUnique 85--nonEmptyTyConKey :: Unique-nonEmptyTyConKey                        = mkPreludeTyConUnique 86---- Kind constructors-liftedTypeKindTyConKey, unliftedTypeKindTyConKey,-  tYPETyConKey, liftedRepTyConKey, unliftedRepTyConKey,-  constraintKindTyConKey, levityTyConKey, runtimeRepTyConKey,-  vecCountTyConKey, vecElemTyConKey,-  zeroBitRepTyConKey, zeroBitTypeTyConKey :: Unique-liftedTypeKindTyConKey                  = mkPreludeTyConUnique 88-unliftedTypeKindTyConKey                = mkPreludeTyConUnique 89-tYPETyConKey                            = mkPreludeTyConUnique 90-constraintKindTyConKey                  = mkPreludeTyConUnique 92-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---- Custom user type-errors-errorMessageTypeErrorFamKey :: Unique-errorMessageTypeErrorFamKey =  mkPreludeTyConUnique 181--coercibleTyConKey :: Unique-coercibleTyConKey = mkPreludeTyConUnique 183--proxyPrimTyConKey :: Unique-proxyPrimTyConKey = mkPreludeTyConUnique 184--specTyConKey :: Unique-specTyConKey = mkPreludeTyConUnique 185--anyTyConKey :: Unique-anyTyConKey = mkPreludeTyConUnique 186--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-  :: 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--{--************************************************************************-*                                                                      *-\subsubsection[Uniques-prelude-DataCons]{@Uniques@ for wired-in @DataCons@}-*                                                                      *-************************************************************************--}--charDataConKey, consDataConKey, doubleDataConKey, falseDataConKey,-    floatDataConKey, intDataConKey, nilDataConKey,-    ratioDataConKey, stableNameDataConKey, trueDataConKey, wordDataConKey,-    word8DataConKey, ioDataConKey, heqDataConKey,-    coercibleDataConKey, eqDataConKey, nothingDataConKey, justDataConKey,-    nonEmptyDataConKey :: 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-nonEmptyDataConKey                      = mkPreludeDataConUnique 19---- 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---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, augmentIdKey, appendIdKey,-    buildIdKey, foldrIdKey, recSelErrorIdKey,-    seqIdKey, eqStringIdKey,-    noMethodBindingErrorIdKey, nonExhaustiveGuardsErrorIdKey,-    runtimeErrorIdKey, patErrorIdKey, voidPrimIdKey,-    realWorldPrimIdKey, recConErrorIdKey,-    unpackCStringUtf8IdKey, unpackCStringAppendUtf8IdKey, unpackCStringFoldrUtf8IdKey,-    unpackCStringIdKey, unpackCStringAppendIdKey, unpackCStringFoldrIdKey,-    typeErrorIdKey, divIntIdKey, modIntIdKey,-    absentSumFieldErrorIdKey, cstringLengthIdKey,-    raiseOverflowIdKey, raiseUnderflowIdKey, raiseDivZeroIdKey-    :: Unique--wildCardKey                   = mkPreludeMiscIdUnique  0  -- See Note [WildCard binders]-absentErrorIdKey              = mkPreludeMiscIdUnique  1-augmentIdKey                  = mkPreludeMiscIdUnique  2-appendIdKey                   = mkPreludeMiscIdUnique  3-buildIdKey                    = mkPreludeMiscIdUnique  4-foldrIdKey                    = mkPreludeMiscIdUnique  6-recSelErrorIdKey              = mkPreludeMiscIdUnique  7-seqIdKey                      = mkPreludeMiscIdUnique  8-absentSumFieldErrorIdKey      = 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-unpackCStringAppendUtf8IdKey  = mkPreludeMiscIdUnique 18-unpackCStringFoldrUtf8IdKey   = mkPreludeMiscIdUnique 19--unpackCStringIdKey            = mkPreludeMiscIdUnique 20-unpackCStringAppendIdKey      = mkPreludeMiscIdUnique 21-unpackCStringFoldrIdKey       = mkPreludeMiscIdUnique 22--voidPrimIdKey                 = mkPreludeMiscIdUnique 23-typeErrorIdKey                = mkPreludeMiscIdUnique 24-divIntIdKey                   = mkPreludeMiscIdUnique 25-modIntIdKey                   = mkPreludeMiscIdUnique 26-cstringLengthIdKey            = mkPreludeMiscIdUnique 27-raiseOverflowIdKey            = mkPreludeMiscIdUnique 28-raiseUnderflowIdKey           = mkPreludeMiscIdUnique 29-raiseDivZeroIdKey             = mkPreludeMiscIdUnique 30--concatIdKey, filterIdKey, zipIdKey,-    bindIOIdKey, returnIOIdKey, newStablePtrIdKey,-    printIdKey, failIOIdKey, nullAddrIdKey, voidArgIdKey,-    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 :: Unique-thenIOIdKey                   = mkPreludeMiscIdUnique 103-lazyIdKey                     = mkPreludeMiscIdUnique 104-assertErrorIdKey              = mkPreludeMiscIdUnique 105-oneShotKey                    = mkPreludeMiscIdUnique 106-runRWKey                      = mkPreludeMiscIdUnique 107--traceKey :: Unique-traceKey                      = mkPreludeMiscIdUnique 108--inlineIdKey, noinlineIdKey :: Unique-inlineIdKey                   = mkPreludeMiscIdUnique 120--- see below--mapIdKey, groupWithIdKey, dollarIdKey, coercionTokenIdKey, considerAccessibleIdKey :: Unique-mapIdKey                = mkPreludeMiscIdUnique 121-groupWithIdKey          = mkPreludeMiscIdUnique 122-dollarIdKey             = mkPreludeMiscIdUnique 123-coercionTokenIdKey      = mkPreludeMiscIdUnique 124-noinlineIdKey           = mkPreludeMiscIdUnique 125-considerAccessibleIdKey = mkPreludeMiscIdUnique 126--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--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-  , mkTrAppKey-  , mkTrFunKey-  , typeNatTypeRepKey-  , typeSymbolTypeRepKey-  , typeCharTypeRepKey-  , typeRepIdKey-  :: Unique-mkTyConKey            = mkPreludeMiscIdUnique 503-mkTrTypeKey           = mkPreludeMiscIdUnique 504-mkTrConKey            = mkPreludeMiscIdUnique 505-mkTrAppKey            = mkPreludeMiscIdUnique 506-typeNatTypeRepKey     = mkPreludeMiscIdUnique 507-typeSymbolTypeRepKey  = mkPreludeMiscIdUnique 508-typeCharTypeRepKey    = mkPreludeMiscIdUnique 509-typeRepIdKey          = mkPreludeMiscIdUnique 510-mkTrFunKey            = mkPreludeMiscIdUnique 511---- Representations for primitive types-trTYPEKey-  , trTYPE'PtrRepLiftedKey-  , trRuntimeRepKey-  , tr'PtrRepLiftedKey-  , trLiftedRepKey-  :: Unique-trTYPEKey              = mkPreludeMiscIdUnique 512-trTYPE'PtrRepLiftedKey = mkPreludeMiscIdUnique 513-trRuntimeRepKey        = mkPreludeMiscIdUnique 514-tr'PtrRepLiftedKey     = mkPreludeMiscIdUnique 515-trLiftedRepKey         = mkPreludeMiscIdUnique 516---- KindReps for common cases-starKindRepKey, starArrStarKindRepKey, starArrStarArrStarKindRepKey :: Unique-starKindRepKey        = mkPreludeMiscIdUnique 520-starArrStarKindRepKey = mkPreludeMiscIdUnique 521-starArrStarArrStarKindRepKey = mkPreludeMiscIdUnique 522---- Dynamic-toDynIdKey :: Unique-toDynIdKey            = mkPreludeMiscIdUnique 523---bitIntegerIdKey :: Unique-bitIntegerIdKey       = mkPreludeMiscIdUnique 550--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---- Unsafe coercion proofs-unsafeEqualityProofIdKey, unsafeCoercePrimIdKey :: Unique-unsafeEqualityProofIdKey = mkPreludeMiscIdUnique 570-unsafeCoercePrimIdKey    = mkPreludeMiscIdUnique 571---- HasField class ops-getFieldClassOpKey, setFieldClassOpKey :: Unique-getFieldClassOpKey = mkPreludeMiscIdUnique 572-setFieldClassOpKey = mkPreludeMiscIdUnique 573----------------------------------------------------------- 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-   , bignatFromWordListIdKey-   , 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--bignatFromWordListIdKey    = mkPreludeMiscIdUnique 690-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--{--************************************************************************-*                                                                      *-   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-  || any (n `hasKey`)-    [ liftedTypeKindTyConKey, unliftedTypeKindTyConKey-    , liftedDataConKey, unliftedDataConKey-    , tYPETyConKey-    , runtimeRepTyConKey, boxedRepDataConKey-    , eqTyConKey-    , oneDataConKey-    , manyDataConKey-    , funTyConKey ]+Nota Bene: all Names defined in here should come from the base package,+the big-num package or (for plugins) the ghc package.++ - ModuleNames for prelude modules,+        e.g.    pRELUDE_NAME :: ModuleName++ - Modules for prelude modules+        e.g.    pRELUDE :: Module++ - Uniques for Ids, DataCons, TyCons and Classes that the compiler+   "knows about" in some way+        e.g.    orderingTyConKey :: Unique+                minusClassOpKey :: Unique++ - Names for Ids, DataCons, TyCons and Classes that the compiler+   "knows about" in some way+        e.g.    orderingTyConName :: Name+                minusName    :: Name+   One of these Names contains+        (a) the module and occurrence name of the thing+        (b) its Unique+   The way the compiler "knows about" one of these things is+   where the type checker or desugarer needs to look it up. For+   example, when desugaring list comprehensions the desugarer+   needs to conjure up 'foldr'.  It does this by looking up+   foldrName in the environment.++ - RdrNames for Ids, DataCons etc that the compiler may emit into+   generated code (e.g. for deriving).+        e.g.    and_RDR :: RdrName+   It's not necessary to know the uniques for these guys, only their names+++Note [Known-key names]+~~~~~~~~~~~~~~~~~~~~~~+It is *very* important that the compiler gives wired-in things and+things with "known-key" names the correct Uniques wherever they+occur. We have to be careful about this in exactly two places:++  1. When we parse some source code, renaming the AST better yield an+     AST whose Names have the correct uniques++  2. When we read an interface file, the read-in gubbins better have+     the right uniques++This is accomplished through a combination of mechanisms:++  1. When parsing source code, the RdrName-decorated AST has some+     RdrNames which are Exact. These are wired-in RdrNames where+     we could directly tell from the parsed syntax what Name to+     use. For example, when we parse a [] in a type and ListTuplePuns+     are enabled, we can just insert (Exact listTyConName :: RdrName).++     This is just an optimisation: it would be equally valid to output+     Orig RdrNames that correctly record the module (and package) that+     we expect the final Name to come from. The name would be looked up+     in the OrigNameCache (see point 3).++  2. The knownKeyNames (which consist of the basicKnownKeyNames from+     the module, and those names reachable via the wired-in stuff from+     GHC.Builtin.Types) are used to initialise the "OrigNameCache" in+     GHC.Iface.Env.  This initialization ensures that when the type checker+     or renamer (both of which use GHC.Iface.Env) look up an original name+     (i.e. a pair of a Module and an OccName) for a known-key name+     they get the correct Unique.++     This is the most important mechanism for ensuring that known-key+     stuff gets the right Unique, and is why it is so important to+     place your known-key names in the appropriate lists.++  3. For "infinite families" of known-key names (i.e. tuples and sums), we+     have to be extra careful. Because there are an infinite number of+     these things, we cannot add them to the list of known-key names+     used to initialise the OrigNameCache. Instead, lookupOrigNameCache pretends+     that these names are in the cache by using isInfiniteFamilyOrigName_maybe+     before the actual lookup.+     See Note [Infinite families of known-key names] for details.+++Note [Infinite families of known-key names]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Infinite families of known-key things (e.g. tuples and sums) pose a tricky+problem: we can't add them to the knownKeyNames finite map which we use to+ensure that, e.g., a reference to (,) gets assigned the right unique (if this+doesn't sound familiar see Note [Known-key names] above).++We instead handle tuples and sums separately from the "vanilla" known-key+things,++  a) The parser recognises them specially and generates an Exact Name (hence not+     looked up in the orig-name cache)++  b) The known infinite families of names are specially serialised by+     GHC.Iface.Binary.putName, with that special treatment detected when we read+     back to ensure that we get back to the correct uniques.+     See Note [Symbol table representation of names] in GHC.Iface.Binary and+     Note [How tuples work] in GHC.Builtin.Types.++  c) GHC.Iface.Env.lookupOrigNameCache uses isInfiniteFamilyOrigName_maybe to+     map tuples and sums onto their exact names, rather than trying to find them+     in the original-name cache.+     See also Note [Built-in syntax and the OrigNameCache]++-}++{-# LANGUAGE CPP #-}++module GHC.Builtin.Names+   ( Unique, Uniquable(..), hasKey,  -- Re-exported for convenience++   -----------------------------------------------------------+   module GHC.Builtin.Names, -- A huge bunch of (a) Names,  e.g. intTyConName+                             --                 (b) Uniques e.g. intTyConKey+                             --                 (c) Groups of classes and types+                             --                 (d) miscellaneous things+                             -- So many that we export them all+   )+where++import GHC.Prelude++import GHC.Unit.Types+import GHC.Types.Name.Occurrence+import GHC.Types.Name.Reader+import GHC.Types.Unique+import GHC.Builtin.Uniques+import GHC.Types.Name+import GHC.Types.SrcLoc+import GHC.Data.FastString+import GHC.Data.List.Infinite (Infinite (..))+import qualified GHC.Data.List.Infinite as Inf++import Language.Haskell.Syntax.Module.Name++{-+************************************************************************+*                                                                      *+     allNameStrings+*                                                                      *+************************************************************************+-}++allNameStrings :: Infinite String+-- Infinite list of a,b,c...z, aa, ab, ac, ... etc+allNameStrings = Inf.allListsOf ['a'..'z']++allNameStringList :: [String]+-- Infinite list of a,b,c...z, aa, ab, ac, ... etc+allNameStringList = Inf.toList allNameStrings++{-+************************************************************************+*                                                                      *+\subsection{Local Names}+*                                                                      *+************************************************************************++This *local* name is used by the interactive stuff+-}++itName :: Unique -> SrcSpan -> Name+itName uniq loc = mkInternalName uniq (mkOccNameFS varName (fsLit "it")) loc++-- mkUnboundName makes a place-holder Name; it shouldn't be looked at except possibly+-- during compiler debugging.+mkUnboundName :: OccName -> Name+mkUnboundName occ = mkInternalName unboundKey occ noSrcSpan++isUnboundName :: Name -> Bool+isUnboundName name = name `hasKey` unboundKey++{-+************************************************************************+*                                                                      *+\subsection{Known key Names}+*                                                                      *+************************************************************************++This section tells what the compiler knows about the association of+names with uniques.  These ones are the *non* wired-in ones.  The+wired in ones are defined in GHC.Builtin.Types etc.+-}++basicKnownKeyNames :: [Name]  -- See Note [Known-key names]+basicKnownKeyNames+ = genericTyConNames+ ++ [   --  Classes.  *Must* include:+        --      classes that are grabbed by key (e.g., eqClassKey)+        --      classes in "Class.standardClassKeys" (quite a few)+        eqClassName,                    -- mentioned, derivable+        ordClassName,                   -- derivable+        boundedClassName,               -- derivable+        numClassName,                   -- mentioned, numeric+        enumClassName,                  -- derivable+        monadClassName,+        functorClassName,+        realClassName,                  -- numeric+        integralClassName,              -- numeric+        fractionalClassName,            -- numeric+        floatingClassName,              -- numeric+        realFracClassName,              -- numeric+        realFloatClassName,             -- numeric+        dataClassName,+        isStringClassName,+        applicativeClassName,+        alternativeClassName,+        foldableClassName,+        traversableClassName,+        semigroupClassName, sappendName,+        monoidClassName, memptyName, mappendName, mconcatName,++        -- The IO type+        ioTyConName, ioDataConName,+        runMainIOName,+        runRWName,++        -- Type representation types+        trModuleTyConName, trModuleDataConName,+        trNameTyConName, trNameSDataConName, trNameDDataConName,+        trTyConTyConName, trTyConDataConName,++        -- Typeable+        typeableClassName,+        typeRepTyConName,+        someTypeRepTyConName,+        someTypeRepDataConName,+        kindRepTyConName,+        kindRepTyConAppDataConName,+        kindRepVarDataConName,+        kindRepAppDataConName,+        kindRepFunDataConName,+        kindRepTYPEDataConName,+        kindRepTypeLitSDataConName,+        kindRepTypeLitDDataConName,+        typeLitSortTyConName,+        typeLitSymbolDataConName,+        typeLitNatDataConName,+        typeLitCharDataConName,+        typeRepIdName,+        mkTrTypeName,+        mkTrConName,+        mkTrAppCheckedName,+        mkTrFunName,+        typeSymbolTypeRepName, typeNatTypeRepName, typeCharTypeRepName,+        trGhcPrimModuleName,++        -- KindReps for common cases+        starKindRepName,+        starArrStarKindRepName,+        starArrStarArrStarKindRepName,+        constraintKindRepName,++        -- WithDict+        withDictClassName,++        -- DataToTag+        dataToTagClassName,++        -- seq#+        seqHashName,++        -- Dynamic+        toDynName,++        -- Numeric stuff+        negateName, minusName, geName, eqName,+        mkRationalBase2Name, mkRationalBase10Name,++        -- Conversion functions+        rationalTyConName,+        ratioTyConName, ratioDataConName,+        fromRationalName, fromIntegerName,+        toIntegerName, toRationalName,+        fromIntegralName, realToFracName,++        -- Int# stuff+        divIntName, modIntName,++        -- String stuff+        fromStringName,++        -- Enum stuff+        enumFromName, enumFromThenName,+        enumFromThenToName, enumFromToName,++        -- Applicative stuff+        pureAName, apAName, thenAName,++        -- Functor stuff+        fmapName,++        -- Monad stuff+        thenIOName, bindIOName, returnIOName, failIOName, bindMName, thenMName,+        returnMName, joinMName,++        -- MonadFail+        monadFailClassName, failMName,++        -- MonadFix+        monadFixClassName, mfixName,++        -- Arrow stuff+        arrAName, composeAName, firstAName,+        appAName, choiceAName, loopAName,++        -- Ix stuff+        ixClassName,++        -- Show stuff+        showClassName,++        -- Read stuff+        readClassName,++        -- Stable pointers+        newStablePtrName,++        -- GHC Extensions+        considerAccessibleName,++        -- Strings and lists+        unpackCStringName, unpackCStringUtf8Name,+        unpackCStringAppendName, unpackCStringAppendUtf8Name,+        unpackCStringFoldrName, unpackCStringFoldrUtf8Name,+        cstringLengthName,++        -- Overloaded lists+        isListClassName,+        fromListName,+        fromListNName,+        toListName,++        -- Non-empty lists+        nonEmptyTyConName,++        -- Overloaded record dot, record update+        getFieldName, setFieldName,++        -- List operations+        concatName, filterName, mapName,+        zipName, foldrName, buildName, augmentName, appendName,++        -- FFI primitive types that are not wired-in.+        stablePtrTyConName, ptrTyConName, funPtrTyConName, constPtrConName,+        int8TyConName, int16TyConName, int32TyConName, int64TyConName,+        word8TyConName, word16TyConName, word32TyConName, word64TyConName,+        jsvalTyConName,++        -- Others+        otherwiseIdName, inlineIdName,+        eqStringName, assertName,+        assertErrorName, traceName,+        printName,+        dollarName,++        -- ghc-bignum+        integerFromNaturalName,+        integerToNaturalClampName,+        integerToNaturalThrowName,+        integerToNaturalName,+        integerToWordName,+        integerToIntName,+        integerToWord64Name,+        integerToInt64Name,+        integerFromWordName,+        integerFromWord64Name,+        integerFromInt64Name,+        integerAddName,+        integerMulName,+        integerSubName,+        integerNegateName,+        integerAbsName,+        integerPopCountName,+        integerQuotName,+        integerRemName,+        integerDivName,+        integerModName,+        integerDivModName,+        integerQuotRemName,+        integerEncodeFloatName,+        integerEncodeDoubleName,+        integerGcdName,+        integerLcmName,+        integerAndName,+        integerOrName,+        integerXorName,+        integerComplementName,+        integerBitName,+        integerTestBitName,+        integerShiftLName,+        integerShiftRName,++        naturalToWordName,+        naturalPopCountName,+        naturalShiftRName,+        naturalShiftLName,+        naturalAddName,+        naturalSubName,+        naturalSubThrowName,+        naturalSubUnsafeName,+        naturalMulName,+        naturalQuotRemName,+        naturalQuotName,+        naturalRemName,+        naturalAndName,+        naturalAndNotName,+        naturalOrName,+        naturalXorName,+        naturalTestBitName,+        naturalBitName,+        naturalGcdName,+        naturalLcmName,+        naturalLog2Name,+        naturalLogBaseWordName,+        naturalLogBaseName,+        naturalPowModName,+        naturalSizeInBaseName,++        bignatEqName,++        -- Float/Double+        integerToFloatName,+        integerToDoubleName,+        naturalToFloatName,+        naturalToDoubleName,+        rationalToFloatName,+        rationalToDoubleName,++        -- Other classes+        monadPlusClassName,++        -- Type-level naturals+        knownNatClassName, knownSymbolClassName, knownCharClassName,++        -- Overloaded labels+        fromLabelClassOpName,++        -- Implicit Parameters+        ipClassName,++        -- Overloaded record fields+        hasFieldClassName,++        -- ExceptionContext+        exceptionContextTyConName,+        emptyExceptionContextName,++        -- Call Stacks+        callStackTyConName,+        emptyCallStackName, pushCallStackName,++        -- Source Locations+        srcLocDataConName,++        -- Annotation type checking+        toAnnotationWrapperName++        -- The SPEC type for SpecConstr+        , specTyConName++        -- The Either type+        , eitherTyConName, leftDataConName, rightDataConName++        -- The Void type+        , voidTyConName++        -- Plugins+        , pluginTyConName+        , frontendPluginTyConName++        -- Generics+        , genClassName, gen1ClassName+        , datatypeClassName, constructorClassName, selectorClassName++        -- Monad comprehensions+        , guardMName+        , liftMName+        , mzipName++        -- GHCi Sandbox+        , ghciIoClassName, ghciStepIoMName++        -- StaticPtr+        , makeStaticName+        , staticPtrTyConName+        , staticPtrDataConName, staticPtrInfoDataConName+        , fromStaticPtrName++        -- Fingerprint+        , fingerprintDataConName++        -- Custom type errors+        , errorMessageTypeErrorFamName+        , typeErrorTextDataConName+        , typeErrorAppendDataConName+        , typeErrorVAppendDataConName+        , typeErrorShowTypeDataConName++        -- "Unsatisfiable" constraint+        , unsatisfiableClassName+        , unsatisfiableIdName++        -- Unsafe coercion proofs+        , unsafeEqualityProofName+        , unsafeEqualityTyConName+        , unsafeReflDataConName+        , unsafeCoercePrimName++        , unsafeUnpackJSStringUtf8ShShName+    ]++genericTyConNames :: [Name]+genericTyConNames = [+    v1TyConName, u1TyConName, par1TyConName, rec1TyConName,+    k1TyConName, m1TyConName, sumTyConName, prodTyConName,+    compTyConName, rTyConName, dTyConName,+    cTyConName, sTyConName, rec0TyConName,+    d1TyConName, c1TyConName, s1TyConName,+    repTyConName, rep1TyConName, uRecTyConName,+    uAddrTyConName, uCharTyConName, uDoubleTyConName,+    uFloatTyConName, uIntTyConName, uWordTyConName,+    prefixIDataConName, infixIDataConName, leftAssociativeDataConName,+    rightAssociativeDataConName, notAssociativeDataConName,+    sourceUnpackDataConName, sourceNoUnpackDataConName,+    noSourceUnpackednessDataConName, sourceLazyDataConName,+    sourceStrictDataConName, noSourceStrictnessDataConName,+    decidedLazyDataConName, decidedStrictDataConName, decidedUnpackDataConName,+    metaDataDataConName, metaConsDataConName, metaSelDataConName+  ]++{-+************************************************************************+*                                                                      *+\subsection{Module names}+*                                                                      *+************************************************************************+++--MetaHaskell Extension Add a new module here+-}++gHC_PRIM, gHC_PRIM_PANIC,+    gHC_TYPES, gHC_INTERNAL_DATA_DATA, gHC_MAGIC, gHC_MAGIC_DICT,+    gHC_CLASSES, gHC_PRIMOPWRAPPERS :: Module+gHC_PRIM           = mkGhcInternalModule (fsLit "GHC.Internal.Prim")   -- Primitive types and values+gHC_PRIM_PANIC     = mkGhcInternalModule (fsLit "GHC.Internal.Prim.Panic")+gHC_TYPES          = mkGhcInternalModule (fsLit "GHC.Internal.Types")+gHC_MAGIC          = mkGhcInternalModule (fsLit "GHC.Internal.Magic")+gHC_MAGIC_DICT     = mkGhcInternalModule (fsLit "GHC.Internal.Magic.Dict")+gHC_CSTRING        = mkGhcInternalModule (fsLit "GHC.Internal.CString")+gHC_CLASSES        = mkGhcInternalModule (fsLit "GHC.Internal.Classes")+gHC_PRIMOPWRAPPERS = mkGhcInternalModule (fsLit "GHC.Internal.PrimopWrappers")+gHC_INTERNAL_TUPLE = mkGhcInternalModule (fsLit "GHC.Internal.Tuple")++gHC_INTERNAL_CONTROL_MONAD_ZIP :: Module+gHC_INTERNAL_CONTROL_MONAD_ZIP  = mkGhcInternalModule (fsLit "GHC.Internal.Control.Monad.Zip")++gHC_INTERNAL_NUM_INTEGER, gHC_INTERNAL_NUM_NATURAL, gHC_INTERNAL_NUM_BIGNAT :: Module+gHC_INTERNAL_NUM_INTEGER            = mkGhcInternalModule (fsLit "GHC.Internal.Bignum.Integer")+gHC_INTERNAL_NUM_NATURAL            = mkGhcInternalModule (fsLit "GHC.Internal.Bignum.Natural")+gHC_INTERNAL_NUM_BIGNAT             = mkGhcInternalModule (fsLit "GHC.Internal.Bignum.BigNat")++gHC_INTERNAL_BASE, gHC_INTERNAL_ENUM,+    gHC_INTERNAL_GHCI, gHC_INTERNAL_GHCI_HELPERS, gHC_CSTRING, gHC_INTERNAL_DATA_STRING,+    gHC_INTERNAL_SHOW, gHC_INTERNAL_READ, gHC_INTERNAL_NUM, gHC_INTERNAL_MAYBE,+    gHC_INTERNAL_LIST, gHC_INTERNAL_TUPLE, gHC_INTERNAL_DATA_EITHER,+    gHC_INTERNAL_DATA_FOLDABLE, gHC_INTERNAL_DATA_TRAVERSABLE,+    gHC_INTERNAL_EXCEPTION_CONTEXT,+    gHC_INTERNAL_CONC, gHC_INTERNAL_IO, gHC_INTERNAL_IO_Exception,+    gHC_INTERNAL_ST, gHC_INTERNAL_IX, gHC_INTERNAL_STABLE, gHC_INTERNAL_PTR, gHC_INTERNAL_ERR, gHC_INTERNAL_REAL,+    gHC_INTERNAL_FLOAT, gHC_INTERNAL_TOP_HANDLER, gHC_INTERNAL_SYSTEM_IO, gHC_INTERNAL_DYNAMIC,+    gHC_INTERNAL_TYPEABLE, gHC_INTERNAL_TYPEABLE_INTERNAL, gHC_INTERNAL_GENERICS,+    gHC_INTERNAL_READ_PREC, gHC_INTERNAL_LEX, gHC_INTERNAL_INT, gHC_INTERNAL_WORD, gHC_INTERNAL_MONAD, gHC_INTERNAL_MONAD_FIX,  gHC_INTERNAL_MONAD_FAIL,+    gHC_INTERNAL_ARROW, gHC_INTERNAL_DESUGAR, gHC_INTERNAL_RANDOM, gHC_INTERNAL_EXTS, gHC_INTERNAL_IS_LIST,+    gHC_INTERNAL_CONTROL_EXCEPTION_BASE, gHC_INTERNAL_TYPEERROR, gHC_INTERNAL_TYPELITS, gHC_INTERNAL_TYPELITS_INTERNAL,+    gHC_INTERNAL_TYPENATS, gHC_INTERNAL_TYPENATS_INTERNAL,+    gHC_INTERNAL_DATA_COERCE, gHC_INTERNAL_DEBUG_TRACE, gHC_INTERNAL_UNSAFE_COERCE, gHC_INTERNAL_FOREIGN_C_CONSTPTR,+    gHC_INTERNAL_JS_PRIM, gHC_INTERNAL_WASM_PRIM_TYPES :: Module+gHC_INTERNAL_BASE                   = mkGhcInternalModule (fsLit "GHC.Internal.Base")+gHC_INTERNAL_ENUM                   = mkGhcInternalModule (fsLit "GHC.Internal.Enum")+gHC_INTERNAL_GHCI                   = mkGhcInternalModule (fsLit "GHC.Internal.GHCi")+gHC_INTERNAL_GHCI_HELPERS           = mkGhcInternalModule (fsLit "GHC.Internal.GHCi.Helpers")+gHC_INTERNAL_SHOW                   = mkGhcInternalModule (fsLit "GHC.Internal.Show")+gHC_INTERNAL_READ                   = mkGhcInternalModule (fsLit "GHC.Internal.Read")+gHC_INTERNAL_NUM                    = mkGhcInternalModule (fsLit "GHC.Internal.Num")+gHC_INTERNAL_MAYBE                  = mkGhcInternalModule (fsLit "GHC.Internal.Maybe")+gHC_INTERNAL_LIST                   = mkGhcInternalModule (fsLit "GHC.Internal.List")+gHC_INTERNAL_DATA_EITHER            = mkGhcInternalModule (fsLit "GHC.Internal.Data.Either")+gHC_INTERNAL_DATA_STRING            = mkGhcInternalModule (fsLit "GHC.Internal.Data.String")+gHC_INTERNAL_DATA_FOLDABLE          = mkGhcInternalModule (fsLit "GHC.Internal.Data.Foldable")+gHC_INTERNAL_DATA_TRAVERSABLE       = mkGhcInternalModule (fsLit "GHC.Internal.Data.Traversable")+gHC_INTERNAL_CONC                   = mkGhcInternalModule (fsLit "GHC.Internal.GHC.Conc")+gHC_INTERNAL_IO                     = mkGhcInternalModule (fsLit "GHC.Internal.IO")+gHC_INTERNAL_IO_Exception           = mkGhcInternalModule (fsLit "GHC.Internal.IO.Exception")+gHC_INTERNAL_ST                     = mkGhcInternalModule (fsLit "GHC.Internal.ST")+gHC_INTERNAL_IX                     = mkGhcInternalModule (fsLit "GHC.Internal.Ix")+gHC_INTERNAL_STABLE                 = mkGhcInternalModule (fsLit "GHC.Internal.Stable")+gHC_INTERNAL_PTR                    = mkGhcInternalModule (fsLit "GHC.Internal.Ptr")+gHC_INTERNAL_ERR                    = mkGhcInternalModule (fsLit "GHC.Internal.Err")+gHC_INTERNAL_REAL                   = mkGhcInternalModule (fsLit "GHC.Internal.Real")+gHC_INTERNAL_FLOAT                  = mkGhcInternalModule (fsLit "GHC.Internal.Float")+gHC_INTERNAL_TOP_HANDLER            = mkGhcInternalModule (fsLit "GHC.Internal.TopHandler")+gHC_INTERNAL_SYSTEM_IO              = mkGhcInternalModule (fsLit "GHC.Internal.System.IO")+gHC_INTERNAL_DYNAMIC                = mkGhcInternalModule (fsLit "GHC.Internal.Data.Dynamic")+gHC_INTERNAL_TYPEABLE               = mkGhcInternalModule (fsLit "GHC.Internal.Data.Typeable")+gHC_INTERNAL_TYPEABLE_INTERNAL      = mkGhcInternalModule (fsLit "GHC.Internal.Data.Typeable.Internal")+gHC_INTERNAL_DATA_DATA              = mkGhcInternalModule (fsLit "GHC.Internal.Data.Data")+gHC_INTERNAL_READ_PREC              = mkGhcInternalModule (fsLit "GHC.Internal.Text.ParserCombinators.ReadPrec")+gHC_INTERNAL_LEX                    = mkGhcInternalModule (fsLit "GHC.Internal.Text.Read.Lex")+gHC_INTERNAL_INT                    = mkGhcInternalModule (fsLit "GHC.Internal.Int")+gHC_INTERNAL_WORD                   = mkGhcInternalModule (fsLit "GHC.Internal.Word")+gHC_INTERNAL_MONAD                  = mkGhcInternalModule (fsLit "GHC.Internal.Control.Monad")+gHC_INTERNAL_MONAD_FIX              = mkGhcInternalModule (fsLit "GHC.Internal.Control.Monad.Fix")+gHC_INTERNAL_MONAD_FAIL             = mkGhcInternalModule (fsLit "GHC.Internal.Control.Monad.Fail")+gHC_INTERNAL_ARROW                  = mkGhcInternalModule (fsLit "GHC.Internal.Control.Arrow")+gHC_INTERNAL_DESUGAR                = mkGhcInternalModule (fsLit "GHC.Internal.Desugar")+gHC_INTERNAL_RANDOM                 = mkGhcInternalModule (fsLit "GHC.Internal.System.Random")+gHC_INTERNAL_EXTS                   = mkGhcInternalModule (fsLit "GHC.Internal.Exts")+gHC_INTERNAL_IS_LIST                = mkGhcInternalModule (fsLit "GHC.Internal.IsList")+gHC_INTERNAL_CONTROL_EXCEPTION_BASE = mkGhcInternalModule (fsLit "GHC.Internal.Control.Exception.Base")+gHC_INTERNAL_EXCEPTION_CONTEXT      = mkGhcInternalModule (fsLit "GHC.Internal.Exception.Context")+gHC_INTERNAL_GENERICS               = mkGhcInternalModule (fsLit "GHC.Internal.Generics")+gHC_INTERNAL_TYPEERROR              = mkGhcInternalModule (fsLit "GHC.Internal.TypeError")+gHC_INTERNAL_TYPELITS               = mkGhcInternalModule (fsLit "GHC.Internal.TypeLits")+gHC_INTERNAL_TYPELITS_INTERNAL      = mkGhcInternalModule (fsLit "GHC.Internal.TypeLits.Internal")+gHC_INTERNAL_TYPENATS               = mkGhcInternalModule (fsLit "GHC.Internal.TypeNats")+gHC_INTERNAL_TYPENATS_INTERNAL      = mkGhcInternalModule (fsLit "GHC.Internal.TypeNats.Internal")+gHC_INTERNAL_DATA_COERCE            = mkGhcInternalModule (fsLit "GHC.Internal.Data.Coerce")+gHC_INTERNAL_DEBUG_TRACE            = mkGhcInternalModule (fsLit "GHC.Internal.Debug.Trace")+gHC_INTERNAL_UNSAFE_COERCE          = mkGhcInternalModule (fsLit "GHC.Internal.Unsafe.Coerce")+gHC_INTERNAL_FOREIGN_C_CONSTPTR     = mkGhcInternalModule (fsLit "GHC.Internal.Foreign.C.ConstPtr")+gHC_INTERNAL_JS_PRIM                = mkGhcInternalModule (fsLit "GHC.Internal.JS.Prim")+gHC_INTERNAL_WASM_PRIM_TYPES        = mkGhcInternalModule (fsLit "GHC.Internal.Wasm.Prim.Types")++gHC_INTERNAL_SRCLOC :: Module+gHC_INTERNAL_SRCLOC = mkGhcInternalModule (fsLit "GHC.Internal.SrcLoc")++gHC_INTERNAL_STACK, gHC_INTERNAL_STACK_TYPES :: Module+gHC_INTERNAL_STACK = mkGhcInternalModule (fsLit "GHC.Internal.Stack")+gHC_INTERNAL_STACK_TYPES = mkGhcInternalModule (fsLit "GHC.Internal.Stack.Types")++gHC_INTERNAL_STATICPTR :: Module+gHC_INTERNAL_STATICPTR = mkGhcInternalModule (fsLit "GHC.Internal.StaticPtr")++gHC_INTERNAL_STATICPTR_INTERNAL :: Module+gHC_INTERNAL_STATICPTR_INTERNAL = mkGhcInternalModule (fsLit "GHC.Internal.StaticPtr.Internal")++gHC_INTERNAL_FINGERPRINT_TYPE :: Module+gHC_INTERNAL_FINGERPRINT_TYPE = mkGhcInternalModule (fsLit "GHC.Internal.Fingerprint.Type")++gHC_INTERNAL_OVER_LABELS :: Module+gHC_INTERNAL_OVER_LABELS = mkGhcInternalModule (fsLit "GHC.Internal.OverloadedLabels")++gHC_INTERNAL_RECORDS :: Module+gHC_INTERNAL_RECORDS = mkGhcInternalModule (fsLit "GHC.Internal.Records")++rOOT_MAIN :: Module+rOOT_MAIN       = mkMainModule (fsLit ":Main") -- Root module for initialisation++mkInteractiveModule :: String -> Module+-- (mkInteractiveMoudule "9") makes module 'interactive:Ghci9'+mkInteractiveModule n = mkModule interactiveUnit (mkModuleName ("Ghci" ++ n))++pRELUDE_NAME, mAIN_NAME :: ModuleName+pRELUDE_NAME   = mkModuleNameFS (fsLit "Prelude")+mAIN_NAME      = mkModuleNameFS (fsLit "Main")++mkGhcInternalModule :: FastString -> Module+mkGhcInternalModule m = mkGhcInternalModule_ (mkModuleNameFS m)++mkGhcInternalModule_ :: ModuleName -> Module+mkGhcInternalModule_ m = mkModule ghcInternalUnit m++mkThisGhcModule :: FastString -> Module+mkThisGhcModule m = mkThisGhcModule_ (mkModuleNameFS m)++mkThisGhcModule_ :: ModuleName -> Module+mkThisGhcModule_ m = mkModule thisGhcUnit m++mkMainModule :: FastString -> Module+mkMainModule m = mkModule mainUnit (mkModuleNameFS m)++mkMainModule_ :: ModuleName -> Module+mkMainModule_ m = mkModule mainUnit m++{-+************************************************************************+*                                                                      *+                        RdrNames+*                                                                      *+************************************************************************+-}++main_RDR_Unqual    :: RdrName+main_RDR_Unqual = mkUnqual varName (fsLit "main")+        -- We definitely don't want an Orig RdrName, because+        -- main might, in principle, be imported into module Main++eq_RDR, ge_RDR, le_RDR, lt_RDR, gt_RDR, compare_RDR,+    ltTag_RDR, eqTag_RDR, gtTag_RDR :: RdrName+eq_RDR                  = nameRdrName eqName+ge_RDR                  = nameRdrName geName+le_RDR                  = varQual_RDR  gHC_CLASSES (fsLit "<=")+lt_RDR                  = varQual_RDR  gHC_CLASSES (fsLit "<")+gt_RDR                  = varQual_RDR  gHC_CLASSES (fsLit ">")+compare_RDR             = varQual_RDR  gHC_CLASSES (fsLit "compare")+ltTag_RDR               = nameRdrName  ordLTDataConName+eqTag_RDR               = nameRdrName  ordEQDataConName+gtTag_RDR               = nameRdrName  ordGTDataConName++map_RDR, append_RDR :: RdrName+map_RDR                 = nameRdrName mapName+append_RDR              = nameRdrName appendName++foldr_RDR, build_RDR, returnM_RDR, bindM_RDR, failM_RDR+    :: RdrName+foldr_RDR               = nameRdrName foldrName+build_RDR               = nameRdrName buildName+returnM_RDR             = nameRdrName returnMName+bindM_RDR               = nameRdrName bindMName+failM_RDR               = nameRdrName failMName++left_RDR, right_RDR :: RdrName+left_RDR                = nameRdrName leftDataConName+right_RDR               = nameRdrName rightDataConName++fromEnum_RDR, toEnum_RDR, toEnumError_RDR, succError_RDR, predError_RDR, enumIntToWord_RDR :: RdrName+fromEnum_RDR            = varQual_RDR gHC_INTERNAL_ENUM (fsLit "fromEnum")+toEnum_RDR              = varQual_RDR gHC_INTERNAL_ENUM (fsLit "toEnum")+toEnumError_RDR         = varQual_RDR gHC_INTERNAL_ENUM (fsLit "toEnumError")+succError_RDR           = varQual_RDR gHC_INTERNAL_ENUM (fsLit "succError")+predError_RDR           = varQual_RDR gHC_INTERNAL_ENUM (fsLit "predError")+enumIntToWord_RDR       = varQual_RDR gHC_INTERNAL_ENUM (fsLit "enumIntToWord")++enumFrom_RDR, enumFromTo_RDR, enumFromThen_RDR, enumFromThenTo_RDR :: RdrName+enumFrom_RDR            = nameRdrName enumFromName+enumFromTo_RDR          = nameRdrName enumFromToName+enumFromThen_RDR        = nameRdrName enumFromThenName+enumFromThenTo_RDR      = nameRdrName enumFromThenToName++times_RDR, plus_RDR :: RdrName+times_RDR               = varQual_RDR  gHC_INTERNAL_NUM (fsLit "*")+plus_RDR                = varQual_RDR gHC_INTERNAL_NUM (fsLit "+")++compose_RDR :: RdrName+compose_RDR             = varQual_RDR gHC_INTERNAL_BASE (fsLit ".")++not_RDR, dataToTag_RDR, succ_RDR, pred_RDR, minBound_RDR, maxBound_RDR,+    and_RDR, range_RDR, inRange_RDR, index_RDR,+    unsafeIndex_RDR, unsafeRangeSize_RDR :: RdrName+and_RDR                 = varQual_RDR gHC_CLASSES (fsLit "&&")+not_RDR                 = varQual_RDR gHC_CLASSES (fsLit "not")+dataToTag_RDR           = varQual_RDR gHC_MAGIC (fsLit "dataToTag#")+succ_RDR                = varQual_RDR gHC_INTERNAL_ENUM (fsLit "succ")+pred_RDR                = varQual_RDR gHC_INTERNAL_ENUM (fsLit "pred")+minBound_RDR            = varQual_RDR gHC_INTERNAL_ENUM (fsLit "minBound")+maxBound_RDR            = varQual_RDR gHC_INTERNAL_ENUM (fsLit "maxBound")+range_RDR               = varQual_RDR gHC_INTERNAL_IX (fsLit "range")+inRange_RDR             = varQual_RDR gHC_INTERNAL_IX (fsLit "inRange")+index_RDR               = varQual_RDR gHC_INTERNAL_IX (fsLit "index")+unsafeIndex_RDR         = varQual_RDR gHC_INTERNAL_IX (fsLit "unsafeIndex")+unsafeRangeSize_RDR     = varQual_RDR gHC_INTERNAL_IX (fsLit "unsafeRangeSize")++readList_RDR, readListDefault_RDR, readListPrec_RDR, readListPrecDefault_RDR,+    readPrec_RDR, parens_RDR, choose_RDR, lexP_RDR, expectP_RDR :: RdrName+readList_RDR            = varQual_RDR gHC_INTERNAL_READ (fsLit "readList")+readListDefault_RDR     = varQual_RDR gHC_INTERNAL_READ (fsLit "readListDefault")+readListPrec_RDR        = varQual_RDR gHC_INTERNAL_READ (fsLit "readListPrec")+readListPrecDefault_RDR = varQual_RDR gHC_INTERNAL_READ (fsLit "readListPrecDefault")+readPrec_RDR            = varQual_RDR gHC_INTERNAL_READ (fsLit "readPrec")+parens_RDR              = varQual_RDR gHC_INTERNAL_READ (fsLit "parens")+choose_RDR              = varQual_RDR gHC_INTERNAL_READ (fsLit "choose")+lexP_RDR                = varQual_RDR gHC_INTERNAL_READ (fsLit "lexP")+expectP_RDR             = varQual_RDR gHC_INTERNAL_READ (fsLit "expectP")++readField_RDR, readFieldHash_RDR, readSymField_RDR :: RdrName+readField_RDR           = varQual_RDR gHC_INTERNAL_READ (fsLit "readField")+readFieldHash_RDR       = varQual_RDR gHC_INTERNAL_READ (fsLit "readFieldHash")+readSymField_RDR        = varQual_RDR gHC_INTERNAL_READ (fsLit "readSymField")++punc_RDR, ident_RDR, symbol_RDR :: RdrName+punc_RDR                = dataQual_RDR gHC_INTERNAL_LEX (fsLit "Punc")+ident_RDR               = dataQual_RDR gHC_INTERNAL_LEX (fsLit "Ident")+symbol_RDR              = dataQual_RDR gHC_INTERNAL_LEX (fsLit "Symbol")++step_RDR, alt_RDR, reset_RDR, prec_RDR, pfail_RDR :: RdrName+step_RDR                = varQual_RDR  gHC_INTERNAL_READ_PREC (fsLit "step")+alt_RDR                 = varQual_RDR  gHC_INTERNAL_READ_PREC (fsLit "+++")+reset_RDR               = varQual_RDR  gHC_INTERNAL_READ_PREC (fsLit "reset")+prec_RDR                = varQual_RDR  gHC_INTERNAL_READ_PREC (fsLit "prec")+pfail_RDR               = varQual_RDR  gHC_INTERNAL_READ_PREC (fsLit "pfail")++showsPrec_RDR, shows_RDR, showString_RDR,+    showSpace_RDR, showCommaSpace_RDR, showParen_RDR :: RdrName+showsPrec_RDR           = varQual_RDR gHC_INTERNAL_SHOW (fsLit "showsPrec")+shows_RDR               = varQual_RDR gHC_INTERNAL_SHOW (fsLit "shows")+showString_RDR          = varQual_RDR gHC_INTERNAL_SHOW (fsLit "showString")+showSpace_RDR           = varQual_RDR gHC_INTERNAL_SHOW (fsLit "showSpace")+showCommaSpace_RDR      = varQual_RDR gHC_INTERNAL_SHOW (fsLit "showCommaSpace")+showParen_RDR           = varQual_RDR gHC_INTERNAL_SHOW (fsLit "showParen")++error_RDR :: RdrName+error_RDR = varQual_RDR gHC_INTERNAL_ERR (fsLit "error")++-- Generics (constructors and functions)+u1DataCon_RDR, par1DataCon_RDR, rec1DataCon_RDR,+  k1DataCon_RDR, m1DataCon_RDR, l1DataCon_RDR, r1DataCon_RDR,+  prodDataCon_RDR, comp1DataCon_RDR,+  unPar1_RDR, unRec1_RDR, unK1_RDR, unComp1_RDR,+  from_RDR, from1_RDR, to_RDR, to1_RDR,+  datatypeName_RDR, moduleName_RDR, packageName_RDR, isNewtypeName_RDR,+  conName_RDR, conFixity_RDR, conIsRecord_RDR, selName_RDR,+  prefixDataCon_RDR, infixDataCon_RDR, leftAssocDataCon_RDR,+  rightAssocDataCon_RDR, notAssocDataCon_RDR,+  uAddrDataCon_RDR, uCharDataCon_RDR, uDoubleDataCon_RDR,+  uFloatDataCon_RDR, uIntDataCon_RDR, uWordDataCon_RDR,+  uAddrHash_RDR, uCharHash_RDR, uDoubleHash_RDR,+  uFloatHash_RDR, uIntHash_RDR, uWordHash_RDR :: RdrName++u1DataCon_RDR    = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "U1")+par1DataCon_RDR  = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "Par1")+rec1DataCon_RDR  = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "Rec1")+k1DataCon_RDR    = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "K1")+m1DataCon_RDR    = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "M1")++l1DataCon_RDR     = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "L1")+r1DataCon_RDR     = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "R1")++prodDataCon_RDR   = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit ":*:")+comp1DataCon_RDR  = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "Comp1")++unPar1_RDR  = fieldQual_RDR gHC_INTERNAL_GENERICS (fsLit "Par1")  (fsLit "unPar1")+unRec1_RDR  = fieldQual_RDR gHC_INTERNAL_GENERICS (fsLit "Rec1")  (fsLit "unRec1")+unK1_RDR    = fieldQual_RDR gHC_INTERNAL_GENERICS (fsLit "K1")    (fsLit "unK1")+unComp1_RDR = fieldQual_RDR gHC_INTERNAL_GENERICS (fsLit "Comp1") (fsLit "unComp1")++from_RDR  = varQual_RDR gHC_INTERNAL_GENERICS (fsLit "from")+from1_RDR = varQual_RDR gHC_INTERNAL_GENERICS (fsLit "from1")+to_RDR    = varQual_RDR gHC_INTERNAL_GENERICS (fsLit "to")+to1_RDR   = varQual_RDR gHC_INTERNAL_GENERICS (fsLit "to1")++datatypeName_RDR  = varQual_RDR gHC_INTERNAL_GENERICS (fsLit "datatypeName")+moduleName_RDR    = varQual_RDR gHC_INTERNAL_GENERICS (fsLit "moduleName")+packageName_RDR   = varQual_RDR gHC_INTERNAL_GENERICS (fsLit "packageName")+isNewtypeName_RDR = varQual_RDR gHC_INTERNAL_GENERICS (fsLit "isNewtype")+selName_RDR       = varQual_RDR gHC_INTERNAL_GENERICS (fsLit "selName")+conName_RDR       = varQual_RDR gHC_INTERNAL_GENERICS (fsLit "conName")+conFixity_RDR     = varQual_RDR gHC_INTERNAL_GENERICS (fsLit "conFixity")+conIsRecord_RDR   = varQual_RDR gHC_INTERNAL_GENERICS (fsLit "conIsRecord")++prefixDataCon_RDR     = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "Prefix")+infixDataCon_RDR      = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "Infix")+leftAssocDataCon_RDR  = nameRdrName leftAssociativeDataConName+rightAssocDataCon_RDR = nameRdrName rightAssociativeDataConName+notAssocDataCon_RDR   = nameRdrName notAssociativeDataConName++uAddrDataCon_RDR   = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "UAddr")+uCharDataCon_RDR   = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "UChar")+uDoubleDataCon_RDR = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "UDouble")+uFloatDataCon_RDR  = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "UFloat")+uIntDataCon_RDR    = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "UInt")+uWordDataCon_RDR   = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "UWord")++uAddrHash_RDR   = fieldQual_RDR gHC_INTERNAL_GENERICS (fsLit "UAddr")   (fsLit "uAddr#")+uCharHash_RDR   = fieldQual_RDR gHC_INTERNAL_GENERICS (fsLit "UChar")   (fsLit "uChar#")+uDoubleHash_RDR = fieldQual_RDR gHC_INTERNAL_GENERICS (fsLit "UDouble") (fsLit "uDouble#")+uFloatHash_RDR  = fieldQual_RDR gHC_INTERNAL_GENERICS (fsLit "UFloat")  (fsLit "uFloat#")+uIntHash_RDR    = fieldQual_RDR gHC_INTERNAL_GENERICS (fsLit "UInt")    (fsLit "uInt#")+uWordHash_RDR   = fieldQual_RDR gHC_INTERNAL_GENERICS (fsLit "UWord")   (fsLit "uWord#")++fmap_RDR, replace_RDR, pure_RDR, ap_RDR, liftA2_RDR, foldable_foldr_RDR,+    foldMap_RDR, null_RDR, all_RDR, traverse_RDR, mempty_RDR,+    mappend_RDR :: RdrName+fmap_RDR                = nameRdrName fmapName+replace_RDR             = varQual_RDR gHC_INTERNAL_BASE (fsLit "<$")+pure_RDR                = nameRdrName pureAName+ap_RDR                  = nameRdrName apAName+liftA2_RDR              = varQual_RDR gHC_INTERNAL_BASE (fsLit "liftA2")+foldable_foldr_RDR      = varQual_RDR gHC_INTERNAL_DATA_FOLDABLE       (fsLit "foldr")+foldMap_RDR             = varQual_RDR gHC_INTERNAL_DATA_FOLDABLE       (fsLit "foldMap")+null_RDR                = varQual_RDR gHC_INTERNAL_DATA_FOLDABLE       (fsLit "null")+all_RDR                 = varQual_RDR gHC_INTERNAL_DATA_FOLDABLE       (fsLit "all")+traverse_RDR            = varQual_RDR gHC_INTERNAL_DATA_TRAVERSABLE    (fsLit "traverse")+mempty_RDR              = nameRdrName memptyName+mappend_RDR             = nameRdrName mappendName++----------------------+varQual_RDR, tcQual_RDR, clsQual_RDR, dataQual_RDR+    :: Module -> FastString -> RdrName+varQual_RDR  mod str = mkOrig mod (mkOccNameFS varName str)+tcQual_RDR   mod str = mkOrig mod (mkOccNameFS tcName str)+clsQual_RDR  mod str = mkOrig mod (mkOccNameFS clsName str)+dataQual_RDR mod str = mkOrig mod (mkOccNameFS dataName str)++fieldQual_RDR :: Module -> FastString -> FastString -> RdrName+fieldQual_RDR mod con str = mkOrig mod (mkOccNameFS (fieldName con) str)++{-+************************************************************************+*                                                                      *+\subsection{Known-key names}+*                                                                      *+************************************************************************++Many of these Names are not really "built in", but some parts of the+compiler (notably the deriving mechanism) need to mention their names,+and it's convenient to write them all down in one place.+-}++wildCardName :: Name+wildCardName = mkSystemVarName wildCardKey (fsLit "wild")++runMainIOName, runRWName :: Name+runMainIOName = varQual gHC_INTERNAL_TOP_HANDLER (fsLit "runMainIO") runMainKey+runRWName     = varQual gHC_MAGIC       (fsLit "runRW#")    runRWKey++orderingTyConName, ordLTDataConName, ordEQDataConName, ordGTDataConName :: Name+orderingTyConName = tcQual  gHC_TYPES (fsLit "Ordering") orderingTyConKey+ordLTDataConName     = dcQual gHC_TYPES (fsLit "LT") ordLTDataConKey+ordEQDataConName     = dcQual gHC_TYPES (fsLit "EQ") ordEQDataConKey+ordGTDataConName     = dcQual gHC_TYPES (fsLit "GT") ordGTDataConKey++specTyConName :: Name+specTyConName     = tcQual gHC_TYPES (fsLit "SPEC") specTyConKey++eitherTyConName, leftDataConName, rightDataConName :: Name+eitherTyConName   = tcQual  gHC_INTERNAL_DATA_EITHER (fsLit "Either") eitherTyConKey+leftDataConName   = dcQual gHC_INTERNAL_DATA_EITHER (fsLit "Left")   leftDataConKey+rightDataConName  = dcQual gHC_INTERNAL_DATA_EITHER (fsLit "Right")  rightDataConKey++voidTyConName :: Name+voidTyConName = tcQual gHC_INTERNAL_BASE (fsLit "Void") voidTyConKey++-- Generics (types)+v1TyConName, u1TyConName, par1TyConName, rec1TyConName,+  k1TyConName, m1TyConName, sumTyConName, prodTyConName,+  compTyConName, rTyConName, dTyConName,+  cTyConName, sTyConName, rec0TyConName,+  d1TyConName, c1TyConName, s1TyConName,+  repTyConName, rep1TyConName, uRecTyConName,+  uAddrTyConName, uCharTyConName, uDoubleTyConName,+  uFloatTyConName, uIntTyConName, uWordTyConName,+  prefixIDataConName, infixIDataConName, leftAssociativeDataConName,+  rightAssociativeDataConName, notAssociativeDataConName,+  sourceUnpackDataConName, sourceNoUnpackDataConName,+  noSourceUnpackednessDataConName, sourceLazyDataConName,+  sourceStrictDataConName, noSourceStrictnessDataConName,+  decidedLazyDataConName, decidedStrictDataConName, decidedUnpackDataConName,+  metaDataDataConName, metaConsDataConName, metaSelDataConName :: Name++v1TyConName  = tcQual gHC_INTERNAL_GENERICS (fsLit "V1") v1TyConKey+u1TyConName  = tcQual gHC_INTERNAL_GENERICS (fsLit "U1") u1TyConKey+par1TyConName  = tcQual gHC_INTERNAL_GENERICS (fsLit "Par1") par1TyConKey+rec1TyConName  = tcQual gHC_INTERNAL_GENERICS (fsLit "Rec1") rec1TyConKey+k1TyConName  = tcQual gHC_INTERNAL_GENERICS (fsLit "K1") k1TyConKey+m1TyConName  = tcQual gHC_INTERNAL_GENERICS (fsLit "M1") m1TyConKey++sumTyConName    = tcQual gHC_INTERNAL_GENERICS (fsLit ":+:") sumTyConKey+prodTyConName   = tcQual gHC_INTERNAL_GENERICS (fsLit ":*:") prodTyConKey+compTyConName   = tcQual gHC_INTERNAL_GENERICS (fsLit ":.:") compTyConKey++rTyConName  = tcQual gHC_INTERNAL_GENERICS (fsLit "R") rTyConKey+dTyConName  = tcQual gHC_INTERNAL_GENERICS (fsLit "D") dTyConKey+cTyConName  = tcQual gHC_INTERNAL_GENERICS (fsLit "C") cTyConKey+sTyConName  = tcQual gHC_INTERNAL_GENERICS (fsLit "S") sTyConKey++rec0TyConName  = tcQual gHC_INTERNAL_GENERICS (fsLit "Rec0") rec0TyConKey+d1TyConName  = tcQual gHC_INTERNAL_GENERICS (fsLit "D1") d1TyConKey+c1TyConName  = tcQual gHC_INTERNAL_GENERICS (fsLit "C1") c1TyConKey+s1TyConName  = tcQual gHC_INTERNAL_GENERICS (fsLit "S1") s1TyConKey++repTyConName  = tcQual gHC_INTERNAL_GENERICS (fsLit "Rep")  repTyConKey+rep1TyConName = tcQual gHC_INTERNAL_GENERICS (fsLit "Rep1") rep1TyConKey++uRecTyConName      = tcQual gHC_INTERNAL_GENERICS (fsLit "URec") uRecTyConKey+uAddrTyConName     = tcQual gHC_INTERNAL_GENERICS (fsLit "UAddr") uAddrTyConKey+uCharTyConName     = tcQual gHC_INTERNAL_GENERICS (fsLit "UChar") uCharTyConKey+uDoubleTyConName   = tcQual gHC_INTERNAL_GENERICS (fsLit "UDouble") uDoubleTyConKey+uFloatTyConName    = tcQual gHC_INTERNAL_GENERICS (fsLit "UFloat") uFloatTyConKey+uIntTyConName      = tcQual gHC_INTERNAL_GENERICS (fsLit "UInt") uIntTyConKey+uWordTyConName     = tcQual gHC_INTERNAL_GENERICS (fsLit "UWord") uWordTyConKey++prefixIDataConName = dcQual gHC_INTERNAL_GENERICS (fsLit "PrefixI")  prefixIDataConKey+infixIDataConName  = dcQual gHC_INTERNAL_GENERICS (fsLit "InfixI")   infixIDataConKey+leftAssociativeDataConName  = dcQual gHC_INTERNAL_GENERICS (fsLit "LeftAssociative")   leftAssociativeDataConKey+rightAssociativeDataConName = dcQual gHC_INTERNAL_GENERICS (fsLit "RightAssociative")  rightAssociativeDataConKey+notAssociativeDataConName   = dcQual gHC_INTERNAL_GENERICS (fsLit "NotAssociative")    notAssociativeDataConKey++sourceUnpackDataConName         = dcQual gHC_INTERNAL_GENERICS (fsLit "SourceUnpack")         sourceUnpackDataConKey+sourceNoUnpackDataConName       = dcQual gHC_INTERNAL_GENERICS (fsLit "SourceNoUnpack")       sourceNoUnpackDataConKey+noSourceUnpackednessDataConName = dcQual gHC_INTERNAL_GENERICS (fsLit "NoSourceUnpackedness") noSourceUnpackednessDataConKey+sourceLazyDataConName           = dcQual gHC_INTERNAL_GENERICS (fsLit "SourceLazy")           sourceLazyDataConKey+sourceStrictDataConName         = dcQual gHC_INTERNAL_GENERICS (fsLit "SourceStrict")         sourceStrictDataConKey+noSourceStrictnessDataConName   = dcQual gHC_INTERNAL_GENERICS (fsLit "NoSourceStrictness")   noSourceStrictnessDataConKey+decidedLazyDataConName          = dcQual gHC_INTERNAL_GENERICS (fsLit "DecidedLazy")          decidedLazyDataConKey+decidedStrictDataConName        = dcQual gHC_INTERNAL_GENERICS (fsLit "DecidedStrict")        decidedStrictDataConKey+decidedUnpackDataConName        = dcQual gHC_INTERNAL_GENERICS (fsLit "DecidedUnpack")        decidedUnpackDataConKey++metaDataDataConName  = dcQual gHC_INTERNAL_GENERICS (fsLit "MetaData")  metaDataDataConKey+metaConsDataConName  = dcQual gHC_INTERNAL_GENERICS (fsLit "MetaCons")  metaConsDataConKey+metaSelDataConName   = dcQual gHC_INTERNAL_GENERICS (fsLit "MetaSel")   metaSelDataConKey++-- Primitive Int+divIntName, modIntName :: Name+divIntName = varQual gHC_CLASSES (fsLit "divInt#") divIntIdKey+modIntName = varQual gHC_CLASSES (fsLit "modInt#") modIntIdKey++-- Base strings Strings+unpackCStringName, unpackCStringFoldrName,+    unpackCStringUtf8Name, unpackCStringFoldrUtf8Name,+    unpackCStringAppendName, unpackCStringAppendUtf8Name,+    eqStringName, cstringLengthName :: Name+cstringLengthName       = varQual gHC_CSTRING (fsLit "cstringLength#") cstringLengthIdKey+eqStringName            = varQual gHC_INTERNAL_BASE (fsLit "eqString")  eqStringIdKey++unpackCStringName       = varQual gHC_CSTRING (fsLit "unpackCString#") unpackCStringIdKey+unpackCStringAppendName = varQual gHC_CSTRING (fsLit "unpackAppendCString#") unpackCStringAppendIdKey+unpackCStringFoldrName  = varQual gHC_CSTRING (fsLit "unpackFoldrCString#") unpackCStringFoldrIdKey++unpackCStringUtf8Name       = varQual gHC_CSTRING (fsLit "unpackCStringUtf8#") unpackCStringUtf8IdKey+unpackCStringAppendUtf8Name = varQual gHC_CSTRING (fsLit "unpackAppendCStringUtf8#") unpackCStringAppendUtf8IdKey+unpackCStringFoldrUtf8Name  = varQual gHC_CSTRING (fsLit "unpackFoldrCStringUtf8#") unpackCStringFoldrUtf8IdKey+++-- The 'inline' function+inlineIdName :: Name+inlineIdName            = varQual gHC_MAGIC (fsLit "inline") inlineIdKey++-- Base classes (Eq, Ord, Functor)+fmapName, eqClassName, eqName, ordClassName, geName, functorClassName :: Name+eqClassName       = clsQual gHC_CLASSES (fsLit "Eq")      eqClassKey+eqName            = varQual gHC_CLASSES (fsLit "==")      eqClassOpKey+ordClassName      = clsQual gHC_CLASSES (fsLit "Ord")     ordClassKey+geName            = varQual gHC_CLASSES (fsLit ">=")      geClassOpKey+functorClassName  = clsQual gHC_INTERNAL_BASE    (fsLit "Functor") functorClassKey+fmapName          = varQual gHC_INTERNAL_BASE    (fsLit "fmap")    fmapClassOpKey++-- Class Monad+monadClassName, thenMName, bindMName, returnMName :: Name+monadClassName     = clsQual gHC_INTERNAL_BASE (fsLit "Monad")  monadClassKey+thenMName          = varQual gHC_INTERNAL_BASE (fsLit ">>")     thenMClassOpKey+bindMName          = varQual gHC_INTERNAL_BASE (fsLit ">>=")    bindMClassOpKey+returnMName        = varQual gHC_INTERNAL_BASE (fsLit "return") returnMClassOpKey++-- Class MonadFail+monadFailClassName, failMName :: Name+monadFailClassName = clsQual gHC_INTERNAL_MONAD_FAIL (fsLit "MonadFail") monadFailClassKey+failMName          = varQual gHC_INTERNAL_MONAD_FAIL (fsLit "fail")      failMClassOpKey++-- Class Applicative+applicativeClassName, pureAName, apAName, thenAName :: Name+applicativeClassName = clsQual gHC_INTERNAL_BASE (fsLit "Applicative") applicativeClassKey+apAName              = varQual gHC_INTERNAL_BASE (fsLit "<*>")         apAClassOpKey+pureAName            = varQual gHC_INTERNAL_BASE (fsLit "pure")        pureAClassOpKey+thenAName            = varQual gHC_INTERNAL_BASE (fsLit "*>")          thenAClassOpKey++-- Classes (Foldable, Traversable)+foldableClassName, traversableClassName :: Name+foldableClassName     = clsQual  gHC_INTERNAL_DATA_FOLDABLE       (fsLit "Foldable")    foldableClassKey+traversableClassName  = clsQual  gHC_INTERNAL_DATA_TRAVERSABLE    (fsLit "Traversable") traversableClassKey++-- Classes (Semigroup, Monoid)+semigroupClassName, sappendName :: Name+semigroupClassName = clsQual gHC_INTERNAL_BASE       (fsLit "Semigroup") semigroupClassKey+sappendName        = varQual gHC_INTERNAL_BASE       (fsLit "<>")        sappendClassOpKey+monoidClassName, memptyName, mappendName, mconcatName :: Name+monoidClassName    = clsQual gHC_INTERNAL_BASE       (fsLit "Monoid")    monoidClassKey+memptyName         = varQual gHC_INTERNAL_BASE       (fsLit "mempty")    memptyClassOpKey+mappendName        = varQual gHC_INTERNAL_BASE       (fsLit "mappend")   mappendClassOpKey+mconcatName        = varQual gHC_INTERNAL_BASE       (fsLit "mconcat")   mconcatClassOpKey++++-- AMP additions++joinMName, alternativeClassName :: Name+joinMName            = varQual gHC_INTERNAL_BASE (fsLit "join")        joinMIdKey+alternativeClassName = clsQual gHC_INTERNAL_MONAD (fsLit "Alternative") alternativeClassKey++--+joinMIdKey, apAClassOpKey, pureAClassOpKey, thenAClassOpKey,+    alternativeClassKey :: Unique+joinMIdKey          = mkPreludeMiscIdUnique 750+apAClassOpKey       = mkPreludeMiscIdUnique 751 -- <*>+pureAClassOpKey     = mkPreludeMiscIdUnique 752+thenAClassOpKey     = mkPreludeMiscIdUnique 753+alternativeClassKey = mkPreludeMiscIdUnique 754+++-- Functions for GHC extensions+considerAccessibleName :: Name+considerAccessibleName = varQual gHC_INTERNAL_EXTS (fsLit "considerAccessible") considerAccessibleIdKey++-- Random GHC.Internal.Base functions+fromStringName, otherwiseIdName, foldrName, buildName, augmentName,+    mapName, appendName, assertName,+    dollarName :: Name+dollarName        = varQual gHC_INTERNAL_BASE (fsLit "$")          dollarIdKey+otherwiseIdName   = varQual gHC_INTERNAL_BASE (fsLit "otherwise")  otherwiseIdKey+foldrName         = varQual gHC_INTERNAL_BASE (fsLit "foldr")      foldrIdKey+buildName         = varQual gHC_INTERNAL_BASE (fsLit "build")      buildIdKey+augmentName       = varQual gHC_INTERNAL_BASE (fsLit "augment")    augmentIdKey+mapName           = varQual gHC_INTERNAL_BASE (fsLit "map")        mapIdKey+appendName        = varQual gHC_INTERNAL_BASE (fsLit "++")         appendIdKey+assertName        = varQual gHC_INTERNAL_BASE (fsLit "assert")     assertIdKey+fromStringName    = varQual gHC_INTERNAL_DATA_STRING (fsLit "fromString") fromStringClassOpKey++-- Module GHC.Internal.Num+numClassName, fromIntegerName, minusName, negateName :: Name+numClassName      = clsQual gHC_INTERNAL_NUM (fsLit "Num")         numClassKey+fromIntegerName   = varQual gHC_INTERNAL_NUM (fsLit "fromInteger") fromIntegerClassOpKey+minusName         = varQual gHC_INTERNAL_NUM (fsLit "-")           minusClassOpKey+negateName        = varQual gHC_INTERNAL_NUM (fsLit "negate")      negateClassOpKey++---------------------------------+-- ghc-bignum+---------------------------------+integerFromNaturalName+   , integerToNaturalClampName+   , integerToNaturalThrowName+   , integerToNaturalName+   , integerToWordName+   , integerToIntName+   , integerToWord64Name+   , integerToInt64Name+   , integerFromWordName+   , integerFromWord64Name+   , integerFromInt64Name+   , integerAddName+   , integerMulName+   , integerSubName+   , integerNegateName+   , integerAbsName+   , integerPopCountName+   , integerQuotName+   , integerRemName+   , integerDivName+   , integerModName+   , integerDivModName+   , integerQuotRemName+   , integerEncodeFloatName+   , integerEncodeDoubleName+   , integerGcdName+   , integerLcmName+   , integerAndName+   , integerOrName+   , integerXorName+   , integerComplementName+   , integerBitName+   , integerTestBitName+   , integerShiftLName+   , integerShiftRName+   , naturalToWordName+   , naturalPopCountName+   , naturalShiftRName+   , naturalShiftLName+   , naturalAddName+   , naturalSubName+   , naturalSubThrowName+   , naturalSubUnsafeName+   , naturalMulName+   , naturalQuotRemName+   , naturalQuotName+   , naturalRemName+   , naturalAndName+   , naturalAndNotName+   , naturalOrName+   , naturalXorName+   , naturalTestBitName+   , naturalBitName+   , naturalGcdName+   , naturalLcmName+   , naturalLog2Name+   , naturalLogBaseWordName+   , naturalLogBaseName+   , naturalPowModName+   , naturalSizeInBaseName+   , bignatEqName+   , bignatCompareName+   , bignatCompareWordName+   :: Name++bnbVarQual, bnnVarQual, bniVarQual :: String -> Unique -> Name+bnbVarQual str key = varQual gHC_INTERNAL_NUM_BIGNAT  (fsLit str) key+bnnVarQual str key = varQual gHC_INTERNAL_NUM_NATURAL (fsLit str) key+bniVarQual str key = varQual gHC_INTERNAL_NUM_INTEGER (fsLit str) key++-- Types and DataCons+bignatEqName              = bnbVarQual "bigNatEq#"                 bignatEqIdKey+bignatCompareName         = bnbVarQual "bigNatCompare"             bignatCompareIdKey+bignatCompareWordName     = bnbVarQual "bigNatCompareWord#"        bignatCompareWordIdKey++naturalToWordName         = bnnVarQual "naturalToWord#"            naturalToWordIdKey+naturalPopCountName       = bnnVarQual "naturalPopCount#"          naturalPopCountIdKey+naturalShiftRName         = bnnVarQual "naturalShiftR#"            naturalShiftRIdKey+naturalShiftLName         = bnnVarQual "naturalShiftL#"            naturalShiftLIdKey+naturalAddName            = bnnVarQual "naturalAdd"                naturalAddIdKey+naturalSubName            = bnnVarQual "naturalSub"                naturalSubIdKey+naturalSubThrowName       = bnnVarQual "naturalSubThrow"           naturalSubThrowIdKey+naturalSubUnsafeName      = bnnVarQual "naturalSubUnsafe"          naturalSubUnsafeIdKey+naturalMulName            = bnnVarQual "naturalMul"                naturalMulIdKey+naturalQuotRemName        = bnnVarQual "naturalQuotRem#"           naturalQuotRemIdKey+naturalQuotName           = bnnVarQual "naturalQuot"               naturalQuotIdKey+naturalRemName            = bnnVarQual "naturalRem"                naturalRemIdKey+naturalAndName            = bnnVarQual "naturalAnd"                naturalAndIdKey+naturalAndNotName         = bnnVarQual "naturalAndNot"             naturalAndNotIdKey+naturalOrName             = bnnVarQual "naturalOr"                 naturalOrIdKey+naturalXorName            = bnnVarQual "naturalXor"                naturalXorIdKey+naturalTestBitName        = bnnVarQual "naturalTestBit#"           naturalTestBitIdKey+naturalBitName            = bnnVarQual "naturalBit#"               naturalBitIdKey+naturalGcdName            = bnnVarQual "naturalGcd"                naturalGcdIdKey+naturalLcmName            = bnnVarQual "naturalLcm"                naturalLcmIdKey+naturalLog2Name           = bnnVarQual "naturalLog2#"              naturalLog2IdKey+naturalLogBaseWordName    = bnnVarQual "naturalLogBaseWord#"       naturalLogBaseWordIdKey+naturalLogBaseName        = bnnVarQual "naturalLogBase#"           naturalLogBaseIdKey+naturalPowModName         = bnnVarQual "naturalPowMod"             naturalPowModIdKey+naturalSizeInBaseName     = bnnVarQual "naturalSizeInBase#"        naturalSizeInBaseIdKey++integerFromNaturalName    = bniVarQual "integerFromNatural"        integerFromNaturalIdKey+integerToNaturalClampName = bniVarQual "integerToNaturalClamp"     integerToNaturalClampIdKey+integerToNaturalThrowName = bniVarQual "integerToNaturalThrow"     integerToNaturalThrowIdKey+integerToNaturalName      = bniVarQual "integerToNatural"          integerToNaturalIdKey+integerToWordName         = bniVarQual "integerToWord#"            integerToWordIdKey+integerToIntName          = bniVarQual "integerToInt#"             integerToIntIdKey+integerToWord64Name       = bniVarQual "integerToWord64#"          integerToWord64IdKey+integerToInt64Name        = bniVarQual "integerToInt64#"           integerToInt64IdKey+integerFromWordName       = bniVarQual "integerFromWord#"          integerFromWordIdKey+integerFromWord64Name     = bniVarQual "integerFromWord64#"        integerFromWord64IdKey+integerFromInt64Name      = bniVarQual "integerFromInt64#"         integerFromInt64IdKey+integerAddName            = bniVarQual "integerAdd"                integerAddIdKey+integerMulName            = bniVarQual "integerMul"                integerMulIdKey+integerSubName            = bniVarQual "integerSub"                integerSubIdKey+integerNegateName         = bniVarQual "integerNegate"             integerNegateIdKey+integerAbsName            = bniVarQual "integerAbs"                integerAbsIdKey+integerPopCountName       = bniVarQual "integerPopCount#"          integerPopCountIdKey+integerQuotName           = bniVarQual "integerQuot"               integerQuotIdKey+integerRemName            = bniVarQual "integerRem"                integerRemIdKey+integerDivName            = bniVarQual "integerDiv"                integerDivIdKey+integerModName            = bniVarQual "integerMod"                integerModIdKey+integerDivModName         = bniVarQual "integerDivMod#"            integerDivModIdKey+integerQuotRemName        = bniVarQual "integerQuotRem#"           integerQuotRemIdKey+integerEncodeFloatName    = bniVarQual "integerEncodeFloat#"       integerEncodeFloatIdKey+integerEncodeDoubleName   = bniVarQual "integerEncodeDouble#"      integerEncodeDoubleIdKey+integerGcdName            = bniVarQual "integerGcd"                integerGcdIdKey+integerLcmName            = bniVarQual "integerLcm"                integerLcmIdKey+integerAndName            = bniVarQual "integerAnd"                integerAndIdKey+integerOrName             = bniVarQual "integerOr"                 integerOrIdKey+integerXorName            = bniVarQual "integerXor"                integerXorIdKey+integerComplementName     = bniVarQual "integerComplement"         integerComplementIdKey+integerBitName            = bniVarQual "integerBit#"               integerBitIdKey+integerTestBitName        = bniVarQual "integerTestBit#"           integerTestBitIdKey+integerShiftLName         = bniVarQual "integerShiftL#"            integerShiftLIdKey+integerShiftRName         = bniVarQual "integerShiftR#"            integerShiftRIdKey++++---------------------------------+-- End of ghc-bignum+---------------------------------++-- GHC.Internal.Real types and classes+rationalTyConName, ratioTyConName, ratioDataConName, realClassName,+    integralClassName, realFracClassName, fractionalClassName,+    fromRationalName, toIntegerName, toRationalName, fromIntegralName,+    realToFracName, mkRationalBase2Name, mkRationalBase10Name :: Name+rationalTyConName   = tcQual  gHC_INTERNAL_REAL (fsLit "Rational")     rationalTyConKey+ratioTyConName      = tcQual  gHC_INTERNAL_REAL (fsLit "Ratio")        ratioTyConKey+ratioDataConName    = dcQual  gHC_INTERNAL_REAL (fsLit ":%")           ratioDataConKey+realClassName       = clsQual gHC_INTERNAL_REAL (fsLit "Real")         realClassKey+integralClassName   = clsQual gHC_INTERNAL_REAL (fsLit "Integral")     integralClassKey+realFracClassName   = clsQual gHC_INTERNAL_REAL (fsLit "RealFrac")     realFracClassKey+fractionalClassName = clsQual gHC_INTERNAL_REAL (fsLit "Fractional")   fractionalClassKey+fromRationalName    = varQual gHC_INTERNAL_REAL (fsLit "fromRational") fromRationalClassOpKey+toIntegerName       = varQual gHC_INTERNAL_REAL (fsLit "toInteger")    toIntegerClassOpKey+toRationalName      = varQual gHC_INTERNAL_REAL (fsLit "toRational")   toRationalClassOpKey+fromIntegralName    = varQual  gHC_INTERNAL_REAL (fsLit "fromIntegral")fromIntegralIdKey+realToFracName      = varQual  gHC_INTERNAL_REAL (fsLit "realToFrac")  realToFracIdKey+mkRationalBase2Name  = varQual  gHC_INTERNAL_REAL  (fsLit "mkRationalBase2")  mkRationalBase2IdKey+mkRationalBase10Name = varQual  gHC_INTERNAL_REAL  (fsLit "mkRationalBase10") mkRationalBase10IdKey++-- GHC.Internal.Float classes+floatingClassName, realFloatClassName :: Name+floatingClassName  = clsQual gHC_INTERNAL_FLOAT (fsLit "Floating")  floatingClassKey+realFloatClassName = clsQual gHC_INTERNAL_FLOAT (fsLit "RealFloat") realFloatClassKey++-- other GHC.Internal.Float functions+integerToFloatName, integerToDoubleName,+  naturalToFloatName, naturalToDoubleName,+  rationalToFloatName, rationalToDoubleName :: Name+integerToFloatName   = varQual gHC_INTERNAL_FLOAT (fsLit "integerToFloat#") integerToFloatIdKey+integerToDoubleName  = varQual gHC_INTERNAL_FLOAT (fsLit "integerToDouble#") integerToDoubleIdKey+naturalToFloatName   = varQual gHC_INTERNAL_FLOAT (fsLit "naturalToFloat#") naturalToFloatIdKey+naturalToDoubleName  = varQual gHC_INTERNAL_FLOAT (fsLit "naturalToDouble#") naturalToDoubleIdKey+rationalToFloatName  = varQual gHC_INTERNAL_FLOAT (fsLit "rationalToFloat") rationalToFloatIdKey+rationalToDoubleName = varQual gHC_INTERNAL_FLOAT (fsLit "rationalToDouble") rationalToDoubleIdKey++-- Class Ix+ixClassName :: Name+ixClassName = clsQual gHC_INTERNAL_IX (fsLit "Ix") ixClassKey++-- Typeable representation types+trModuleTyConName+  , trModuleDataConName+  , trNameTyConName+  , trNameSDataConName+  , trNameDDataConName+  , trTyConTyConName+  , trTyConDataConName+  :: Name+trModuleTyConName     = tcQual gHC_TYPES          (fsLit "Module")         trModuleTyConKey+trModuleDataConName   = dcQual gHC_TYPES          (fsLit "Module")         trModuleDataConKey+trNameTyConName       = tcQual gHC_TYPES          (fsLit "TrName")         trNameTyConKey+trNameSDataConName    = dcQual gHC_TYPES          (fsLit "TrNameS")        trNameSDataConKey+trNameDDataConName    = dcQual gHC_TYPES          (fsLit "TrNameD")        trNameDDataConKey+trTyConTyConName      = tcQual gHC_TYPES          (fsLit "TyCon")          trTyConTyConKey+trTyConDataConName    = dcQual gHC_TYPES          (fsLit "TyCon")          trTyConDataConKey++kindRepTyConName+  , kindRepTyConAppDataConName+  , kindRepVarDataConName+  , kindRepAppDataConName+  , kindRepFunDataConName+  , kindRepTYPEDataConName+  , kindRepTypeLitSDataConName+  , kindRepTypeLitDDataConName+  :: Name+kindRepTyConName      = tcQual gHC_TYPES          (fsLit "KindRep")        kindRepTyConKey+kindRepTyConAppDataConName = dcQual gHC_TYPES     (fsLit "KindRepTyConApp") kindRepTyConAppDataConKey+kindRepVarDataConName = dcQual gHC_TYPES          (fsLit "KindRepVar")     kindRepVarDataConKey+kindRepAppDataConName = dcQual gHC_TYPES          (fsLit "KindRepApp")     kindRepAppDataConKey+kindRepFunDataConName = dcQual gHC_TYPES          (fsLit "KindRepFun")     kindRepFunDataConKey+kindRepTYPEDataConName = dcQual gHC_TYPES         (fsLit "KindRepTYPE")    kindRepTYPEDataConKey+kindRepTypeLitSDataConName = dcQual gHC_TYPES     (fsLit "KindRepTypeLitS") kindRepTypeLitSDataConKey+kindRepTypeLitDDataConName = dcQual gHC_TYPES     (fsLit "KindRepTypeLitD") kindRepTypeLitDDataConKey++typeLitSortTyConName+  , typeLitSymbolDataConName+  , typeLitNatDataConName+  , typeLitCharDataConName+  :: Name+typeLitSortTyConName     = tcQual gHC_TYPES       (fsLit "TypeLitSort")    typeLitSortTyConKey+typeLitSymbolDataConName = dcQual gHC_TYPES       (fsLit "TypeLitSymbol")  typeLitSymbolDataConKey+typeLitNatDataConName    = dcQual gHC_TYPES       (fsLit "TypeLitNat")     typeLitNatDataConKey+typeLitCharDataConName   = dcQual gHC_TYPES       (fsLit "TypeLitChar")    typeLitCharDataConKey++-- Class Typeable, and functions for constructing `Typeable` dictionaries+typeableClassName+  , typeRepTyConName+  , someTypeRepTyConName+  , someTypeRepDataConName+  , mkTrTypeName+  , mkTrConName+  , mkTrAppCheckedName+  , mkTrFunName+  , typeRepIdName+  , typeNatTypeRepName+  , typeSymbolTypeRepName+  , typeCharTypeRepName+  , trGhcPrimModuleName+  :: Name+typeableClassName     = clsQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "Typeable")       typeableClassKey+typeRepTyConName      = tcQual  gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "TypeRep")        typeRepTyConKey+someTypeRepTyConName   = tcQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "SomeTypeRep")    someTypeRepTyConKey+someTypeRepDataConName = dcQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "SomeTypeRep")    someTypeRepDataConKey+typeRepIdName         = varQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "typeRep#")       typeRepIdKey+mkTrTypeName          = varQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "mkTrType")       mkTrTypeKey+mkTrConName           = varQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "mkTrCon")        mkTrConKey+mkTrAppCheckedName    = varQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "mkTrAppChecked") mkTrAppCheckedKey+mkTrFunName           = varQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "mkTrFun")        mkTrFunKey+typeNatTypeRepName    = varQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "typeNatTypeRep") typeNatTypeRepKey+typeSymbolTypeRepName = varQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "typeSymbolTypeRep") typeSymbolTypeRepKey+typeCharTypeRepName   = varQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "typeCharTypeRep") typeCharTypeRepKey+-- this is the Typeable 'Module' for GHC.Prim (which has no code, so we place in GHC.Types)+-- See Note [Grand plan for Typeable] in GHC.Tc.Instance.Typeable.+trGhcPrimModuleName   = varQual gHC_TYPES         (fsLit "tr$ModuleGHCPrim")  trGhcPrimModuleKey++-- Typeable KindReps for some common cases+starKindRepName, starArrStarKindRepName,+  starArrStarArrStarKindRepName, constraintKindRepName :: Name+starKindRepName        = varQual gHC_TYPES         (fsLit "krep$*")          starKindRepKey+starArrStarKindRepName = varQual gHC_TYPES         (fsLit "krep$*Arr*")      starArrStarKindRepKey+starArrStarArrStarKindRepName = varQual gHC_TYPES  (fsLit "krep$*->*->*")    starArrStarArrStarKindRepKey+constraintKindRepName  = varQual gHC_TYPES         (fsLit "krep$Constraint") constraintKindRepKey++-- WithDict+withDictClassName :: Name+withDictClassName = clsQual gHC_MAGIC_DICT (fsLit "WithDict") withDictClassKey++nonEmptyTyConName :: Name+nonEmptyTyConName = tcQual gHC_INTERNAL_BASE (fsLit "NonEmpty") nonEmptyTyConKey++-- DataToTag+dataToTagClassName :: Name+dataToTagClassName    = clsQual gHC_MAGIC      (fsLit "DataToTag") dataToTagClassKey++-- seq#+seqHashName :: Name+seqHashName = varQual gHC_INTERNAL_IO (fsLit "seq#") seqHashKey++-- Custom type errors+errorMessageTypeErrorFamName+  , typeErrorTextDataConName+  , typeErrorAppendDataConName+  , typeErrorVAppendDataConName+  , typeErrorShowTypeDataConName+  :: Name++errorMessageTypeErrorFamName =+  tcQual gHC_INTERNAL_TYPEERROR (fsLit "TypeError") errorMessageTypeErrorFamKey++typeErrorTextDataConName =+  dcQual gHC_INTERNAL_TYPEERROR (fsLit "Text") typeErrorTextDataConKey++typeErrorAppendDataConName =+  dcQual gHC_INTERNAL_TYPEERROR (fsLit ":<>:") typeErrorAppendDataConKey++typeErrorVAppendDataConName =+  dcQual gHC_INTERNAL_TYPEERROR (fsLit ":$$:") typeErrorVAppendDataConKey++typeErrorShowTypeDataConName =+  dcQual gHC_INTERNAL_TYPEERROR (fsLit "ShowType") typeErrorShowTypeDataConKey++-- "Unsatisfiable" constraint+unsatisfiableClassName, unsatisfiableIdName :: Name+unsatisfiableClassName =+  clsQual gHC_INTERNAL_TYPEERROR (fsLit "Unsatisfiable") unsatisfiableClassNameKey+unsatisfiableIdName =+  varQual gHC_INTERNAL_TYPEERROR (fsLit "unsatisfiable") unsatisfiableIdNameKey++-- Unsafe coercion proofs+unsafeEqualityProofName, unsafeEqualityTyConName, unsafeCoercePrimName,+  unsafeReflDataConName :: Name+unsafeEqualityProofName = varQual gHC_INTERNAL_UNSAFE_COERCE (fsLit "unsafeEqualityProof") unsafeEqualityProofIdKey+unsafeEqualityTyConName = tcQual gHC_INTERNAL_UNSAFE_COERCE (fsLit "UnsafeEquality") unsafeEqualityTyConKey+unsafeReflDataConName   = dcQual gHC_INTERNAL_UNSAFE_COERCE (fsLit "UnsafeRefl")     unsafeReflDataConKey+unsafeCoercePrimName    = varQual gHC_INTERNAL_UNSAFE_COERCE (fsLit "unsafeCoerce#") unsafeCoercePrimIdKey++-- Dynamic+toDynName :: Name+toDynName = varQual gHC_INTERNAL_DYNAMIC (fsLit "toDyn") toDynIdKey++-- Class Data+dataClassName :: Name+dataClassName = clsQual gHC_INTERNAL_DATA_DATA (fsLit "Data") dataClassKey++-- Error module+assertErrorName    :: Name+assertErrorName   = varQual gHC_INTERNAL_IO_Exception (fsLit "assertError") assertErrorIdKey++-- GHC.Internal.Debug.Trace+traceName          :: Name+traceName         = varQual gHC_INTERNAL_DEBUG_TRACE (fsLit "trace") traceKey++-- Enum module (Enum, Bounded)+enumClassName, enumFromName, enumFromToName, enumFromThenName,+    enumFromThenToName, boundedClassName :: Name+enumClassName      = clsQual gHC_INTERNAL_ENUM (fsLit "Enum")           enumClassKey+enumFromName       = varQual gHC_INTERNAL_ENUM (fsLit "enumFrom")       enumFromClassOpKey+enumFromToName     = varQual gHC_INTERNAL_ENUM (fsLit "enumFromTo")     enumFromToClassOpKey+enumFromThenName   = varQual gHC_INTERNAL_ENUM (fsLit "enumFromThen")   enumFromThenClassOpKey+enumFromThenToName = varQual gHC_INTERNAL_ENUM (fsLit "enumFromThenTo") enumFromThenToClassOpKey+boundedClassName   = clsQual gHC_INTERNAL_ENUM (fsLit "Bounded")        boundedClassKey++-- List functions+concatName, filterName, zipName :: Name+concatName        = varQual gHC_INTERNAL_LIST (fsLit "concat") concatIdKey+filterName        = varQual gHC_INTERNAL_LIST (fsLit "filter") filterIdKey+zipName           = varQual gHC_INTERNAL_LIST (fsLit "zip")    zipIdKey++-- Overloaded lists+isListClassName, fromListName, fromListNName, toListName :: Name+isListClassName = clsQual gHC_INTERNAL_IS_LIST (fsLit "IsList")    isListClassKey+fromListName    = varQual gHC_INTERNAL_IS_LIST (fsLit "fromList")  fromListClassOpKey+fromListNName   = varQual gHC_INTERNAL_IS_LIST (fsLit "fromListN") fromListNClassOpKey+toListName      = varQual gHC_INTERNAL_IS_LIST (fsLit "toList")    toListClassOpKey++-- HasField class ops+getFieldName, setFieldName :: Name+getFieldName   = varQual gHC_INTERNAL_RECORDS (fsLit "getField") getFieldClassOpKey+setFieldName   = varQual gHC_INTERNAL_RECORDS (fsLit "setField") setFieldClassOpKey++-- Class Show+showClassName :: Name+showClassName   = clsQual gHC_INTERNAL_SHOW (fsLit "Show")      showClassKey++-- Class Read+readClassName :: Name+readClassName   = clsQual gHC_INTERNAL_READ (fsLit "Read")      readClassKey++-- Classes Generic and Generic1, Datatype, Constructor and Selector+genClassName, gen1ClassName, datatypeClassName, constructorClassName,+  selectorClassName :: Name+genClassName  = clsQual gHC_INTERNAL_GENERICS (fsLit "Generic")  genClassKey+gen1ClassName = clsQual gHC_INTERNAL_GENERICS (fsLit "Generic1") gen1ClassKey++datatypeClassName    = clsQual gHC_INTERNAL_GENERICS (fsLit "Datatype")    datatypeClassKey+constructorClassName = clsQual gHC_INTERNAL_GENERICS (fsLit "Constructor") constructorClassKey+selectorClassName    = clsQual gHC_INTERNAL_GENERICS (fsLit "Selector")    selectorClassKey++genericClassNames :: [Name]+genericClassNames = [genClassName, gen1ClassName]++-- GHCi things+ghciIoClassName, ghciStepIoMName :: Name+ghciIoClassName = clsQual gHC_INTERNAL_GHCI (fsLit "GHCiSandboxIO") ghciIoClassKey+ghciStepIoMName = varQual gHC_INTERNAL_GHCI (fsLit "ghciStepIO") ghciStepIoMClassOpKey++-- IO things+ioTyConName, ioDataConName,+  thenIOName, bindIOName, returnIOName, failIOName :: Name+ioTyConName       = tcQual  gHC_TYPES (fsLit "IO")       ioTyConKey+ioDataConName     = dcQual  gHC_TYPES (fsLit "IO")       ioDataConKey+thenIOName        = varQual gHC_INTERNAL_BASE  (fsLit "thenIO")   thenIOIdKey+bindIOName        = varQual gHC_INTERNAL_BASE  (fsLit "bindIO")   bindIOIdKey+returnIOName      = varQual gHC_INTERNAL_BASE  (fsLit "returnIO") returnIOIdKey+failIOName        = varQual gHC_INTERNAL_IO    (fsLit "failIO")   failIOIdKey++-- IO things+printName :: Name+printName         = varQual gHC_INTERNAL_SYSTEM_IO (fsLit "print") printIdKey++-- Int, Word, and Addr things+int8TyConName, int16TyConName, int32TyConName, int64TyConName :: Name+int8TyConName     = tcQual gHC_INTERNAL_INT  (fsLit "Int8")  int8TyConKey+int16TyConName    = tcQual gHC_INTERNAL_INT  (fsLit "Int16") int16TyConKey+int32TyConName    = tcQual gHC_INTERNAL_INT  (fsLit "Int32") int32TyConKey+int64TyConName    = tcQual gHC_INTERNAL_INT  (fsLit "Int64") int64TyConKey++-- Word module+word8TyConName, word16TyConName, word32TyConName, word64TyConName :: Name+word8TyConName    = tcQual  gHC_INTERNAL_WORD (fsLit "Word8")  word8TyConKey+word16TyConName   = tcQual  gHC_INTERNAL_WORD (fsLit "Word16") word16TyConKey+word32TyConName   = tcQual  gHC_INTERNAL_WORD (fsLit "Word32") word32TyConKey+word64TyConName   = tcQual  gHC_INTERNAL_WORD (fsLit "Word64") word64TyConKey++-- PrelPtr module+ptrTyConName, funPtrTyConName :: Name+ptrTyConName      = tcQual   gHC_INTERNAL_PTR (fsLit "Ptr")    ptrTyConKey+funPtrTyConName   = tcQual   gHC_INTERNAL_PTR (fsLit "FunPtr") funPtrTyConKey++-- Foreign objects and weak pointers+stablePtrTyConName, newStablePtrName :: Name+stablePtrTyConName    = tcQual   gHC_INTERNAL_STABLE (fsLit "StablePtr")    stablePtrTyConKey+newStablePtrName      = varQual  gHC_INTERNAL_STABLE (fsLit "newStablePtr") newStablePtrIdKey++-- Recursive-do notation+monadFixClassName, mfixName :: Name+monadFixClassName  = clsQual gHC_INTERNAL_MONAD_FIX (fsLit "MonadFix") monadFixClassKey+mfixName           = varQual gHC_INTERNAL_MONAD_FIX (fsLit "mfix")     mfixIdKey++-- Arrow notation+arrAName, composeAName, firstAName, appAName, choiceAName, loopAName :: Name+arrAName           = varQual gHC_INTERNAL_ARROW (fsLit "arr")       arrAIdKey+composeAName       = varQual gHC_INTERNAL_DESUGAR (fsLit ">>>") composeAIdKey+firstAName         = varQual gHC_INTERNAL_ARROW (fsLit "first")     firstAIdKey+appAName           = varQual gHC_INTERNAL_ARROW (fsLit "app")       appAIdKey+choiceAName        = varQual gHC_INTERNAL_ARROW (fsLit "|||")       choiceAIdKey+loopAName          = varQual gHC_INTERNAL_ARROW (fsLit "loop")      loopAIdKey++-- Monad comprehensions+guardMName, liftMName, mzipName :: Name+guardMName         = varQual gHC_INTERNAL_MONAD (fsLit "guard")    guardMIdKey+liftMName          = varQual gHC_INTERNAL_MONAD (fsLit "liftM")    liftMIdKey+mzipName           = varQual gHC_INTERNAL_CONTROL_MONAD_ZIP (fsLit "mzip") mzipIdKey+++-- Annotation type checking+toAnnotationWrapperName :: Name+toAnnotationWrapperName = varQual gHC_INTERNAL_DESUGAR (fsLit "toAnnotationWrapper") toAnnotationWrapperIdKey++-- Other classes, needed for type defaulting+monadPlusClassName, isStringClassName :: Name+monadPlusClassName  = clsQual gHC_INTERNAL_MONAD (fsLit "MonadPlus")      monadPlusClassKey+isStringClassName   = clsQual gHC_INTERNAL_DATA_STRING (fsLit "IsString") isStringClassKey++-- Type-level naturals+knownNatClassName :: Name+knownNatClassName     = clsQual gHC_INTERNAL_TYPENATS (fsLit "KnownNat") knownNatClassNameKey+knownSymbolClassName :: Name+knownSymbolClassName  = clsQual gHC_INTERNAL_TYPELITS (fsLit "KnownSymbol") knownSymbolClassNameKey+knownCharClassName :: Name+knownCharClassName  = clsQual gHC_INTERNAL_TYPELITS (fsLit "KnownChar") knownCharClassNameKey++-- Overloaded labels+fromLabelClassOpName :: Name+fromLabelClassOpName+ = varQual gHC_INTERNAL_OVER_LABELS (fsLit "fromLabel") fromLabelClassOpKey++-- Implicit Parameters+ipClassName :: Name+ipClassName+  = clsQual gHC_CLASSES (fsLit "IP") ipClassKey++-- Overloaded record fields+hasFieldClassName :: Name+hasFieldClassName+ = clsQual gHC_INTERNAL_RECORDS (fsLit "HasField") hasFieldClassNameKey++-- ExceptionContext+exceptionContextTyConName, emptyExceptionContextName :: Name+exceptionContextTyConName =+    tcQual gHC_INTERNAL_EXCEPTION_CONTEXT (fsLit "ExceptionContext") exceptionContextTyConKey+emptyExceptionContextName+  = varQual gHC_INTERNAL_EXCEPTION_CONTEXT (fsLit "emptyExceptionContext") emptyExceptionContextKey++-- Source Locations+callStackTyConName, emptyCallStackName, pushCallStackName,+  srcLocDataConName :: Name+callStackTyConName+  = tcQual gHC_INTERNAL_STACK_TYPES  (fsLit "CallStack") callStackTyConKey+emptyCallStackName+  = varQual gHC_INTERNAL_STACK_TYPES (fsLit "emptyCallStack") emptyCallStackKey+pushCallStackName+  = varQual gHC_INTERNAL_STACK_TYPES (fsLit "pushCallStack") pushCallStackKey+srcLocDataConName+  = dcQual gHC_INTERNAL_STACK_TYPES  (fsLit "SrcLoc")    srcLocDataConKey++-- plugins+pLUGINS :: Module+pLUGINS = mkThisGhcModule (fsLit "GHC.Driver.Plugins")+pluginTyConName :: Name+pluginTyConName = tcQual pLUGINS (fsLit "Plugin") pluginTyConKey+frontendPluginTyConName :: Name+frontendPluginTyConName = tcQual pLUGINS (fsLit "FrontendPlugin") frontendPluginTyConKey++-- Static pointers+makeStaticName :: Name+makeStaticName =+    varQual gHC_INTERNAL_STATICPTR_INTERNAL (fsLit "makeStatic") makeStaticKey++staticPtrInfoTyConName :: Name+staticPtrInfoTyConName =+    tcQual gHC_INTERNAL_STATICPTR (fsLit "StaticPtrInfo") staticPtrInfoTyConKey++staticPtrInfoDataConName :: Name+staticPtrInfoDataConName =+    dcQual gHC_INTERNAL_STATICPTR (fsLit "StaticPtrInfo") staticPtrInfoDataConKey++staticPtrTyConName :: Name+staticPtrTyConName =+    tcQual gHC_INTERNAL_STATICPTR (fsLit "StaticPtr") staticPtrTyConKey++staticPtrDataConName :: Name+staticPtrDataConName =+    dcQual gHC_INTERNAL_STATICPTR (fsLit "StaticPtr") staticPtrDataConKey++fromStaticPtrName :: Name+fromStaticPtrName =+    varQual gHC_INTERNAL_STATICPTR (fsLit "fromStaticPtr") fromStaticPtrClassOpKey++fingerprintDataConName :: Name+fingerprintDataConName =+    dcQual gHC_INTERNAL_FINGERPRINT_TYPE (fsLit "Fingerprint") fingerprintDataConKey++constPtrConName :: Name+constPtrConName =+    tcQual gHC_INTERNAL_FOREIGN_C_CONSTPTR (fsLit "ConstPtr") constPtrTyConKey++jsvalTyConName :: Name+jsvalTyConName = tcQual gHC_INTERNAL_WASM_PRIM_TYPES (fsLit "JSVal") jsvalTyConKey++unsafeUnpackJSStringUtf8ShShName :: Name+unsafeUnpackJSStringUtf8ShShName = varQual gHC_INTERNAL_JS_PRIM (fsLit "unsafeUnpackJSStringUtf8##") unsafeUnpackJSStringUtf8ShShKey++{-+************************************************************************+*                                                                      *+\subsection{Local helpers}+*                                                                      *+************************************************************************++All these are original names; hence mkOrig+-}++{-# INLINE varQual #-}+{-# INLINE tcQual #-}+{-# INLINE clsQual #-}+{-# INLINE dcQual #-}+varQual, tcQual, clsQual, dcQual :: Module -> FastString -> Unique -> Name+varQual  modu str unique = mk_known_key_name varName modu str unique+tcQual   modu str unique = mk_known_key_name tcName modu str unique+clsQual  modu str unique = mk_known_key_name clsName modu str unique+dcQual   modu str unique = mk_known_key_name dataName modu str unique++mk_known_key_name :: NameSpace -> Module -> FastString -> Unique -> Name+{-# INLINE mk_known_key_name #-}+mk_known_key_name space modu str unique+  = mkExternalName unique modu (mkOccNameFS space str) noSrcSpan+++{-+************************************************************************+*                                                                      *+\subsubsection[Uniques-prelude-Classes]{@Uniques@ for wired-in @Classes@}+*                                                                      *+************************************************************************+--MetaHaskell extension hand allocate keys here+-}++boundedClassKey, enumClassKey, eqClassKey, floatingClassKey,+    fractionalClassKey, integralClassKey, monadClassKey, dataClassKey,+    functorClassKey, numClassKey, ordClassKey, readClassKey, realClassKey,+    realFloatClassKey, realFracClassKey, showClassKey, ixClassKey :: Unique+boundedClassKey         = mkPreludeClassUnique 1+enumClassKey            = mkPreludeClassUnique 2+eqClassKey              = mkPreludeClassUnique 3+floatingClassKey        = mkPreludeClassUnique 5+fractionalClassKey      = mkPreludeClassUnique 6+integralClassKey        = mkPreludeClassUnique 7+monadClassKey           = mkPreludeClassUnique 8+dataClassKey            = mkPreludeClassUnique 9+functorClassKey         = mkPreludeClassUnique 10+numClassKey             = mkPreludeClassUnique 11+ordClassKey             = mkPreludeClassUnique 12+readClassKey            = mkPreludeClassUnique 13+realClassKey            = mkPreludeClassUnique 14+realFloatClassKey       = mkPreludeClassUnique 15+realFracClassKey        = mkPreludeClassUnique 16+showClassKey            = mkPreludeClassUnique 17+ixClassKey              = mkPreludeClassUnique 18++typeableClassKey :: Unique+typeableClassKey        = mkPreludeClassUnique 20++withDictClassKey :: Unique+withDictClassKey        = mkPreludeClassUnique 21++dataToTagClassKey :: Unique+dataToTagClassKey       = mkPreludeClassUnique 23++monadFixClassKey :: Unique+monadFixClassKey        = mkPreludeClassUnique 28++monadFailClassKey :: Unique+monadFailClassKey       = mkPreludeClassUnique 29++monadPlusClassKey, randomClassKey, randomGenClassKey :: Unique+monadPlusClassKey       = mkPreludeClassUnique 30+randomClassKey          = mkPreludeClassUnique 31+randomGenClassKey       = mkPreludeClassUnique 32++isStringClassKey :: Unique+isStringClassKey        = mkPreludeClassUnique 33++applicativeClassKey, foldableClassKey, traversableClassKey :: Unique+applicativeClassKey     = mkPreludeClassUnique 34+foldableClassKey        = mkPreludeClassUnique 35+traversableClassKey     = mkPreludeClassUnique 36++genClassKey, gen1ClassKey, datatypeClassKey, constructorClassKey,+  selectorClassKey :: Unique+genClassKey   = mkPreludeClassUnique 37+gen1ClassKey  = mkPreludeClassUnique 38++datatypeClassKey    = mkPreludeClassUnique 39+constructorClassKey = mkPreludeClassUnique 40+selectorClassKey    = mkPreludeClassUnique 41++-- KnownNat: see Note [KnownNat & KnownSymbol and EvLit] in GHC.Tc.Instance.Class+knownNatClassNameKey :: Unique+knownNatClassNameKey = mkPreludeClassUnique 42++-- KnownSymbol: see Note [KnownNat & KnownSymbol and EvLit] in GHC.Tc.Instance.Class+knownSymbolClassNameKey :: Unique+knownSymbolClassNameKey = mkPreludeClassUnique 43++knownCharClassNameKey :: Unique+knownCharClassNameKey = mkPreludeClassUnique 44++ghciIoClassKey :: Unique+ghciIoClassKey = mkPreludeClassUnique 45++semigroupClassKey, monoidClassKey :: Unique+semigroupClassKey = mkPreludeClassUnique 47+monoidClassKey    = mkPreludeClassUnique 48++-- Implicit Parameters+ipClassKey :: Unique+ipClassKey = mkPreludeClassUnique 49++-- Overloaded record fields+hasFieldClassNameKey :: Unique+hasFieldClassNameKey = mkPreludeClassUnique 50+++---------------- Template Haskell -------------------+--      GHC.Builtin.Names.TH: USES ClassUniques 200-299+-----------------------------------------------------++{-+************************************************************************+*                                                                      *+\subsubsection[Uniques-prelude-TyCons]{@Uniques@ for wired-in @TyCons@}+*                                                                      *+************************************************************************+-}++addrPrimTyConKey, arrayPrimTyConKey, boolTyConKey,+    byteArrayPrimTyConKey, charPrimTyConKey, charTyConKey, doublePrimTyConKey,+    doubleTyConKey, floatPrimTyConKey, floatTyConKey, fUNTyConKey,+    intPrimTyConKey, intTyConKey, int8TyConKey, int16TyConKey,+    int8PrimTyConKey, int16PrimTyConKey, int32PrimTyConKey, int32TyConKey,+    int64PrimTyConKey, int64TyConKey,+    integerTyConKey, naturalTyConKey,+    listTyConKey, foreignObjPrimTyConKey, maybeTyConKey,+    weakPrimTyConKey, mutableArrayPrimTyConKey,+    mutableByteArrayPrimTyConKey, orderingTyConKey, mVarPrimTyConKey,+    ratioTyConKey, rationalTyConKey, realWorldTyConKey, stablePtrPrimTyConKey,+    stablePtrTyConKey, eqTyConKey, heqTyConKey,+    smallArrayPrimTyConKey, smallMutableArrayPrimTyConKey,+    stringTyConKey,+    ccArrowTyConKey, ctArrowTyConKey, tcArrowTyConKey :: Unique+addrPrimTyConKey                        = mkPreludeTyConUnique  1+arrayPrimTyConKey                       = mkPreludeTyConUnique  3+boolTyConKey                            = mkPreludeTyConUnique  4+byteArrayPrimTyConKey                   = mkPreludeTyConUnique  5+stringTyConKey                          = mkPreludeTyConUnique  6+charPrimTyConKey                        = mkPreludeTyConUnique  7+charTyConKey                            = mkPreludeTyConUnique  8+doublePrimTyConKey                      = mkPreludeTyConUnique  9+doubleTyConKey                          = mkPreludeTyConUnique 10+floatPrimTyConKey                       = mkPreludeTyConUnique 11+floatTyConKey                           = mkPreludeTyConUnique 12+fUNTyConKey                             = mkPreludeTyConUnique 13+intPrimTyConKey                         = mkPreludeTyConUnique 14+intTyConKey                             = mkPreludeTyConUnique 15+int8PrimTyConKey                        = mkPreludeTyConUnique 16+int8TyConKey                            = mkPreludeTyConUnique 17+int16PrimTyConKey                       = mkPreludeTyConUnique 18+int16TyConKey                           = mkPreludeTyConUnique 19+int32PrimTyConKey                       = mkPreludeTyConUnique 20+int32TyConKey                           = mkPreludeTyConUnique 21+int64PrimTyConKey                       = mkPreludeTyConUnique 22+int64TyConKey                           = mkPreludeTyConUnique 23+integerTyConKey                         = mkPreludeTyConUnique 24+naturalTyConKey                         = mkPreludeTyConUnique 25++listTyConKey                            = mkPreludeTyConUnique 26+foreignObjPrimTyConKey                  = mkPreludeTyConUnique 27+maybeTyConKey                           = mkPreludeTyConUnique 28+weakPrimTyConKey                        = mkPreludeTyConUnique 29+mutableArrayPrimTyConKey                = mkPreludeTyConUnique 30+mutableByteArrayPrimTyConKey            = mkPreludeTyConUnique 31+orderingTyConKey                        = mkPreludeTyConUnique 32+mVarPrimTyConKey                        = mkPreludeTyConUnique 33+-- ioPortPrimTyConKey (34) was killed+ratioTyConKey                           = mkPreludeTyConUnique 35+rationalTyConKey                        = mkPreludeTyConUnique 36+realWorldTyConKey                       = mkPreludeTyConUnique 37+stablePtrPrimTyConKey                   = mkPreludeTyConUnique 38+stablePtrTyConKey                       = mkPreludeTyConUnique 39+eqTyConKey                              = mkPreludeTyConUnique 40+heqTyConKey                             = mkPreludeTyConUnique 41++ctArrowTyConKey                       = mkPreludeTyConUnique 42+ccArrowTyConKey                       = mkPreludeTyConUnique 43+tcArrowTyConKey                       = mkPreludeTyConUnique 44++statePrimTyConKey, stableNamePrimTyConKey, stableNameTyConKey,+    mutVarPrimTyConKey, ioTyConKey,+    wordPrimTyConKey, wordTyConKey, word8PrimTyConKey, word8TyConKey,+    word16PrimTyConKey, word16TyConKey, word32PrimTyConKey, word32TyConKey,+    word64PrimTyConKey, word64TyConKey,+    kindConKey, boxityConKey,+    typeConKey, threadIdPrimTyConKey, bcoPrimTyConKey, ptrTyConKey,+    funPtrTyConKey, tVarPrimTyConKey, eqPrimTyConKey,+    eqReprPrimTyConKey, eqPhantPrimTyConKey,+    compactPrimTyConKey, stackSnapshotPrimTyConKey,+    promptTagPrimTyConKey, constPtrTyConKey, jsvalTyConKey :: Unique+statePrimTyConKey                       = mkPreludeTyConUnique 50+stableNamePrimTyConKey                  = mkPreludeTyConUnique 51+stableNameTyConKey                      = mkPreludeTyConUnique 52+eqPrimTyConKey                          = mkPreludeTyConUnique 53+eqReprPrimTyConKey                      = mkPreludeTyConUnique 54+eqPhantPrimTyConKey                     = mkPreludeTyConUnique 55+mutVarPrimTyConKey                      = mkPreludeTyConUnique 56+ioTyConKey                              = mkPreludeTyConUnique 57+wordPrimTyConKey                        = mkPreludeTyConUnique 59+wordTyConKey                            = mkPreludeTyConUnique 60+word8PrimTyConKey                       = mkPreludeTyConUnique 61+word8TyConKey                           = mkPreludeTyConUnique 62+word16PrimTyConKey                      = mkPreludeTyConUnique 63+word16TyConKey                          = mkPreludeTyConUnique 64+word32PrimTyConKey                      = mkPreludeTyConUnique 65+word32TyConKey                          = mkPreludeTyConUnique 66+word64PrimTyConKey                      = mkPreludeTyConUnique 67+word64TyConKey                          = mkPreludeTyConUnique 68+kindConKey                              = mkPreludeTyConUnique 72+boxityConKey                            = mkPreludeTyConUnique 73+typeConKey                              = mkPreludeTyConUnique 74+threadIdPrimTyConKey                    = mkPreludeTyConUnique 75+bcoPrimTyConKey                         = mkPreludeTyConUnique 76+ptrTyConKey                             = mkPreludeTyConUnique 77+funPtrTyConKey                          = mkPreludeTyConUnique 78+tVarPrimTyConKey                        = mkPreludeTyConUnique 79+compactPrimTyConKey                     = mkPreludeTyConUnique 80+stackSnapshotPrimTyConKey               = mkPreludeTyConUnique 81+promptTagPrimTyConKey                   = mkPreludeTyConUnique 82++eitherTyConKey :: Unique+eitherTyConKey                          = mkPreludeTyConUnique 84++voidTyConKey :: Unique+voidTyConKey                            = mkPreludeTyConUnique 85++nonEmptyTyConKey :: Unique+nonEmptyTyConKey                        = mkPreludeTyConUnique 86++dictTyConKey :: Unique+dictTyConKey                            = mkPreludeTyConUnique 87++-- Kind constructors+liftedTypeKindTyConKey, unliftedTypeKindTyConKey,+  tYPETyConKey, cONSTRAINTTyConKey,+  liftedRepTyConKey, unliftedRepTyConKey,+  constraintKindTyConKey, levityTyConKey, runtimeRepTyConKey,+  vecCountTyConKey, vecElemTyConKey,+  zeroBitRepTyConKey, zeroBitTypeTyConKey :: Unique+liftedTypeKindTyConKey                  = mkPreludeTyConUnique 88+unliftedTypeKindTyConKey                = mkPreludeTyConUnique 89+tYPETyConKey                            = mkPreludeTyConUnique 91+cONSTRAINTTyConKey                      = mkPreludeTyConUnique 92+constraintKindTyConKey                  = mkPreludeTyConUnique 93+levityTyConKey                          = mkPreludeTyConUnique 94+runtimeRepTyConKey                      = mkPreludeTyConUnique 95+vecCountTyConKey                        = mkPreludeTyConUnique 96+vecElemTyConKey                         = mkPreludeTyConUnique 97+liftedRepTyConKey                       = mkPreludeTyConUnique 98+unliftedRepTyConKey                     = mkPreludeTyConUnique 99+zeroBitRepTyConKey                         = mkPreludeTyConUnique 100+zeroBitTypeTyConKey                        = mkPreludeTyConUnique 101++pluginTyConKey, frontendPluginTyConKey :: Unique+pluginTyConKey                          = mkPreludeTyConUnique 102+frontendPluginTyConKey                  = mkPreludeTyConUnique 103++trTyConTyConKey, trModuleTyConKey, trNameTyConKey,+  kindRepTyConKey, typeLitSortTyConKey :: Unique+trTyConTyConKey                         = mkPreludeTyConUnique 104+trModuleTyConKey                        = mkPreludeTyConUnique 105+trNameTyConKey                          = mkPreludeTyConUnique 106+kindRepTyConKey                         = mkPreludeTyConUnique 107+typeLitSortTyConKey                     = mkPreludeTyConUnique 108++-- Generics (Unique keys)+v1TyConKey, u1TyConKey, par1TyConKey, rec1TyConKey,+  k1TyConKey, m1TyConKey, sumTyConKey, prodTyConKey,+  compTyConKey, rTyConKey, dTyConKey,+  cTyConKey, sTyConKey, rec0TyConKey,+  d1TyConKey, c1TyConKey, s1TyConKey,+  repTyConKey, rep1TyConKey, uRecTyConKey,+  uAddrTyConKey, uCharTyConKey, uDoubleTyConKey,+  uFloatTyConKey, uIntTyConKey, uWordTyConKey :: Unique++v1TyConKey    = mkPreludeTyConUnique 135+u1TyConKey    = mkPreludeTyConUnique 136+par1TyConKey  = mkPreludeTyConUnique 137+rec1TyConKey  = mkPreludeTyConUnique 138+k1TyConKey    = mkPreludeTyConUnique 139+m1TyConKey    = mkPreludeTyConUnique 140++sumTyConKey   = mkPreludeTyConUnique 141+prodTyConKey  = mkPreludeTyConUnique 142+compTyConKey  = mkPreludeTyConUnique 143++rTyConKey = mkPreludeTyConUnique 144+dTyConKey = mkPreludeTyConUnique 146+cTyConKey = mkPreludeTyConUnique 147+sTyConKey = mkPreludeTyConUnique 148++rec0TyConKey  = mkPreludeTyConUnique 149+d1TyConKey    = mkPreludeTyConUnique 151+c1TyConKey    = mkPreludeTyConUnique 152+s1TyConKey    = mkPreludeTyConUnique 153++repTyConKey  = mkPreludeTyConUnique 155+rep1TyConKey = mkPreludeTyConUnique 156++uRecTyConKey    = mkPreludeTyConUnique 157+uAddrTyConKey   = mkPreludeTyConUnique 158+uCharTyConKey   = mkPreludeTyConUnique 159+uDoubleTyConKey = mkPreludeTyConUnique 160+uFloatTyConKey  = mkPreludeTyConUnique 161+uIntTyConKey    = mkPreludeTyConUnique 162+uWordTyConKey   = mkPreludeTyConUnique 163++-- "Unsatisfiable" constraint+unsatisfiableClassNameKey :: Unique+unsatisfiableClassNameKey = mkPreludeTyConUnique 170++anyTyConKey :: Unique+anyTyConKey = mkPreludeTyConUnique 171++zonkAnyTyConKey :: Unique+zonkAnyTyConKey = mkPreludeTyConUnique 172++-- Custom user type-errors+errorMessageTypeErrorFamKey :: Unique+errorMessageTypeErrorFamKey = mkPreludeTyConUnique 181++coercibleTyConKey :: Unique+coercibleTyConKey = mkPreludeTyConUnique 183++proxyPrimTyConKey :: Unique+proxyPrimTyConKey = mkPreludeTyConUnique 184++specTyConKey :: Unique+specTyConKey = mkPreludeTyConUnique 185++smallArrayPrimTyConKey        = mkPreludeTyConUnique  187+smallMutableArrayPrimTyConKey = mkPreludeTyConUnique  188++staticPtrTyConKey  :: Unique+staticPtrTyConKey  = mkPreludeTyConUnique 189++staticPtrInfoTyConKey :: Unique+staticPtrInfoTyConKey = mkPreludeTyConUnique 190++callStackTyConKey :: Unique+callStackTyConKey = mkPreludeTyConUnique 191++-- Typeables+typeRepTyConKey, someTypeRepTyConKey, someTypeRepDataConKey :: Unique+typeRepTyConKey       = mkPreludeTyConUnique 192+someTypeRepTyConKey   = mkPreludeTyConUnique 193+someTypeRepDataConKey = mkPreludeTyConUnique 194+++typeSymbolAppendFamNameKey :: Unique+typeSymbolAppendFamNameKey = mkPreludeTyConUnique 195++-- Unsafe equality+unsafeEqualityTyConKey :: Unique+unsafeEqualityTyConKey = mkPreludeTyConUnique 196++-- Linear types+multiplicityTyConKey :: Unique+multiplicityTyConKey = mkPreludeTyConUnique 197++unrestrictedFunTyConKey :: Unique+unrestrictedFunTyConKey = mkPreludeTyConUnique 198++multMulTyConKey :: Unique+multMulTyConKey = mkPreludeTyConUnique 199++---------------- Template Haskell -------------------+--      GHC.Builtin.Names.TH: USES TyConUniques 200-299+-----------------------------------------------------++----------------------- SIMD ------------------------+--      USES TyConUniques 300-399+-----------------------------------------------------++#include "primop-vector-uniques.hs-incl"++------------- Type-level Symbol, Nat, Char ----------+--      USES TyConUniques 400-499+-----------------------------------------------------+typeSymbolKindConNameKey, typeCharKindConNameKey,+  typeNatAddTyFamNameKey, typeNatMulTyFamNameKey, typeNatExpTyFamNameKey,+  typeNatSubTyFamNameKey+  , typeSymbolCmpTyFamNameKey, typeNatCmpTyFamNameKey, typeCharCmpTyFamNameKey+  , typeLeqCharTyFamNameKey+  , typeNatDivTyFamNameKey+  , typeNatModTyFamNameKey+  , typeNatLogTyFamNameKey+  , typeConsSymbolTyFamNameKey, typeUnconsSymbolTyFamNameKey+  , typeCharToNatTyFamNameKey, typeNatToCharTyFamNameKey+  , exceptionContextTyConKey, unsafeUnpackJSStringUtf8ShShKey+  :: Unique+typeSymbolKindConNameKey  = mkPreludeTyConUnique 400+typeCharKindConNameKey    = mkPreludeTyConUnique 401+typeNatAddTyFamNameKey    = mkPreludeTyConUnique 402+typeNatMulTyFamNameKey    = mkPreludeTyConUnique 403+typeNatExpTyFamNameKey    = mkPreludeTyConUnique 404+typeNatSubTyFamNameKey    = mkPreludeTyConUnique 405+typeSymbolCmpTyFamNameKey = mkPreludeTyConUnique 406+typeNatCmpTyFamNameKey    = mkPreludeTyConUnique 407+typeCharCmpTyFamNameKey   = mkPreludeTyConUnique 408+typeLeqCharTyFamNameKey   = mkPreludeTyConUnique 409+typeNatDivTyFamNameKey  = mkPreludeTyConUnique 410+typeNatModTyFamNameKey  = mkPreludeTyConUnique 411+typeNatLogTyFamNameKey  = mkPreludeTyConUnique 412+typeConsSymbolTyFamNameKey = mkPreludeTyConUnique 413+typeUnconsSymbolTyFamNameKey = mkPreludeTyConUnique 414+typeCharToNatTyFamNameKey = mkPreludeTyConUnique 415+typeNatToCharTyFamNameKey = mkPreludeTyConUnique 416+constPtrTyConKey = mkPreludeTyConUnique 417++jsvalTyConKey = mkPreludeTyConUnique 418++exceptionContextTyConKey = mkPreludeTyConUnique 420++unsafeUnpackJSStringUtf8ShShKey  = mkPreludeMiscIdUnique 805++{-+************************************************************************+*                                                                      *+\subsubsection[Uniques-prelude-DataCons]{@Uniques@ for wired-in @DataCons@}+*                                                                      *+************************************************************************+-}++charDataConKey, consDataConKey, doubleDataConKey, falseDataConKey,+    floatDataConKey, intDataConKey, nilDataConKey,+    ratioDataConKey, stableNameDataConKey, trueDataConKey, wordDataConKey,+    word8DataConKey, ioDataConKey, heqDataConKey,+    eqDataConKey, nothingDataConKey, justDataConKey :: Unique++charDataConKey                          = mkPreludeDataConUnique  1+consDataConKey                          = mkPreludeDataConUnique  2+doubleDataConKey                        = mkPreludeDataConUnique  3+falseDataConKey                         = mkPreludeDataConUnique  4+floatDataConKey                         = mkPreludeDataConUnique  5+intDataConKey                           = mkPreludeDataConUnique  6+nothingDataConKey                       = mkPreludeDataConUnique  7+justDataConKey                          = mkPreludeDataConUnique  8+eqDataConKey                            = mkPreludeDataConUnique  9+nilDataConKey                           = mkPreludeDataConUnique 10+ratioDataConKey                         = mkPreludeDataConUnique 11+word8DataConKey                         = mkPreludeDataConUnique 12+stableNameDataConKey                    = mkPreludeDataConUnique 13+trueDataConKey                          = mkPreludeDataConUnique 14+wordDataConKey                          = mkPreludeDataConUnique 15+ioDataConKey                            = mkPreludeDataConUnique 16+heqDataConKey                           = mkPreludeDataConUnique 18++-- Generic data constructors+crossDataConKey, inlDataConKey, inrDataConKey, genUnitDataConKey :: Unique+crossDataConKey                         = mkPreludeDataConUnique 20+inlDataConKey                           = mkPreludeDataConUnique 21+inrDataConKey                           = mkPreludeDataConUnique 22+genUnitDataConKey                       = mkPreludeDataConUnique 23++leftDataConKey, rightDataConKey :: Unique+leftDataConKey                          = mkPreludeDataConUnique 25+rightDataConKey                         = mkPreludeDataConUnique 26++ordLTDataConKey, ordEQDataConKey, ordGTDataConKey :: Unique+ordLTDataConKey                         = mkPreludeDataConUnique 27+ordEQDataConKey                         = mkPreludeDataConUnique 28+ordGTDataConKey                         = mkPreludeDataConUnique 29++mkDictDataConKey :: Unique+mkDictDataConKey                        = mkPreludeDataConUnique 30++coercibleDataConKey :: Unique+coercibleDataConKey                     = mkPreludeDataConUnique 32++staticPtrDataConKey :: Unique+staticPtrDataConKey                     = mkPreludeDataConUnique 33++staticPtrInfoDataConKey :: Unique+staticPtrInfoDataConKey                 = mkPreludeDataConUnique 34++fingerprintDataConKey :: Unique+fingerprintDataConKey                   = mkPreludeDataConUnique 35++srcLocDataConKey :: Unique+srcLocDataConKey                        = mkPreludeDataConUnique 37++trTyConDataConKey, trModuleDataConKey,+  trNameSDataConKey, trNameDDataConKey,+  trGhcPrimModuleKey :: Unique+trTyConDataConKey                       = mkPreludeDataConUnique 41+trModuleDataConKey                      = mkPreludeDataConUnique 43+trNameSDataConKey                       = mkPreludeDataConUnique 45+trNameDDataConKey                       = mkPreludeDataConUnique 46+trGhcPrimModuleKey                      = mkPreludeDataConUnique 47++typeErrorTextDataConKey,+  typeErrorAppendDataConKey,+  typeErrorVAppendDataConKey,+  typeErrorShowTypeDataConKey+  :: Unique+typeErrorTextDataConKey                 = mkPreludeDataConUnique 50+typeErrorAppendDataConKey               = mkPreludeDataConUnique 51+typeErrorVAppendDataConKey              = mkPreludeDataConUnique 52+typeErrorShowTypeDataConKey             = mkPreludeDataConUnique 53++prefixIDataConKey, infixIDataConKey, leftAssociativeDataConKey,+    rightAssociativeDataConKey, notAssociativeDataConKey,+    sourceUnpackDataConKey, sourceNoUnpackDataConKey,+    noSourceUnpackednessDataConKey, sourceLazyDataConKey,+    sourceStrictDataConKey, noSourceStrictnessDataConKey,+    decidedLazyDataConKey, decidedStrictDataConKey, decidedUnpackDataConKey,+    metaDataDataConKey, metaConsDataConKey, metaSelDataConKey :: Unique+prefixIDataConKey                       = mkPreludeDataConUnique 54+infixIDataConKey                        = mkPreludeDataConUnique 55+leftAssociativeDataConKey               = mkPreludeDataConUnique 56+rightAssociativeDataConKey              = mkPreludeDataConUnique 57+notAssociativeDataConKey                = mkPreludeDataConUnique 58+sourceUnpackDataConKey                  = mkPreludeDataConUnique 59+sourceNoUnpackDataConKey                = mkPreludeDataConUnique 60+noSourceUnpackednessDataConKey          = mkPreludeDataConUnique 61+sourceLazyDataConKey                    = mkPreludeDataConUnique 62+sourceStrictDataConKey                  = mkPreludeDataConUnique 63+noSourceStrictnessDataConKey            = mkPreludeDataConUnique 64+decidedLazyDataConKey                   = mkPreludeDataConUnique 65+decidedStrictDataConKey                 = mkPreludeDataConUnique 66+decidedUnpackDataConKey                 = mkPreludeDataConUnique 67+metaDataDataConKey                      = mkPreludeDataConUnique 68+metaConsDataConKey                      = mkPreludeDataConUnique 69+metaSelDataConKey                       = mkPreludeDataConUnique 70++vecRepDataConKey, sumRepDataConKey,+  tupleRepDataConKey, boxedRepDataConKey :: Unique+vecRepDataConKey                        = mkPreludeDataConUnique 71+tupleRepDataConKey                      = mkPreludeDataConUnique 72+sumRepDataConKey                        = mkPreludeDataConUnique 73+boxedRepDataConKey                      = mkPreludeDataConUnique 74++boxedRepDataConTyConKey, tupleRepDataConTyConKey :: Unique+-- A promoted data constructors (i.e. a TyCon) has+-- the same key as the data constructor itself+boxedRepDataConTyConKey = boxedRepDataConKey+tupleRepDataConTyConKey = tupleRepDataConKey++-- See Note [Wiring in RuntimeRep] in GHC.Builtin.Types+-- Includes all nullary-data-constructor reps. Does not+-- include BoxedRep, VecRep, SumRep, TupleRep.+runtimeRepSimpleDataConKeys :: [Unique]+runtimeRepSimpleDataConKeys+  = map mkPreludeDataConUnique [75..87]++liftedDataConKey,unliftedDataConKey :: Unique+liftedDataConKey = mkPreludeDataConUnique 88+unliftedDataConKey = mkPreludeDataConUnique 89++-- See Note [Wiring in RuntimeRep] in GHC.Builtin.Types+-- VecCount+vecCountDataConKeys :: [Unique]+vecCountDataConKeys = map mkPreludeDataConUnique [90..95]++-- See Note [Wiring in RuntimeRep] in GHC.Builtin.Types+-- VecElem+vecElemDataConKeys :: [Unique]+vecElemDataConKeys = map mkPreludeDataConUnique [96..105]++-- Typeable things+kindRepTyConAppDataConKey, kindRepVarDataConKey, kindRepAppDataConKey,+    kindRepFunDataConKey, kindRepTYPEDataConKey,+    kindRepTypeLitSDataConKey, kindRepTypeLitDDataConKey+    :: Unique+kindRepTyConAppDataConKey = mkPreludeDataConUnique 106+kindRepVarDataConKey      = mkPreludeDataConUnique 107+kindRepAppDataConKey      = mkPreludeDataConUnique 108+kindRepFunDataConKey      = mkPreludeDataConUnique 109+kindRepTYPEDataConKey     = mkPreludeDataConUnique 110+kindRepTypeLitSDataConKey = mkPreludeDataConUnique 111+kindRepTypeLitDDataConKey = mkPreludeDataConUnique 112++typeLitSymbolDataConKey, typeLitNatDataConKey, typeLitCharDataConKey :: Unique+typeLitSymbolDataConKey   = mkPreludeDataConUnique 113+typeLitNatDataConKey      = mkPreludeDataConUnique 114+typeLitCharDataConKey     = mkPreludeDataConUnique 115++-- Unsafe equality+unsafeReflDataConKey :: Unique+unsafeReflDataConKey      = mkPreludeDataConUnique 116++-- Multiplicity++oneDataConKey, manyDataConKey :: Unique+oneDataConKey = mkPreludeDataConUnique 117+manyDataConKey = mkPreludeDataConUnique 118++-- ghc-bignum+integerISDataConKey, integerINDataConKey, integerIPDataConKey,+   naturalNSDataConKey, naturalNBDataConKey :: Unique+integerISDataConKey       = mkPreludeDataConUnique 120+integerINDataConKey       = mkPreludeDataConUnique 121+integerIPDataConKey       = mkPreludeDataConUnique 122+naturalNSDataConKey       = mkPreludeDataConUnique 123+naturalNBDataConKey       = mkPreludeDataConUnique 124+++---------------- Template Haskell -------------------+--      GHC.Builtin.Names.TH: USES DataUniques 200-250+-----------------------------------------------------+++{-+************************************************************************+*                                                                      *+\subsubsection[Uniques-prelude-Ids]{@Uniques@ for wired-in @Ids@ (except @DataCons@)}+*                                                                      *+************************************************************************+-}++wildCardKey, absentErrorIdKey, absentConstraintErrorIdKey, augmentIdKey, appendIdKey,+    buildIdKey, foldrIdKey, recSelErrorIdKey,+    seqIdKey, eqStringIdKey,+    noMethodBindingErrorIdKey, nonExhaustiveGuardsErrorIdKey,+    impossibleErrorIdKey, impossibleConstraintErrorIdKey,+    patErrorIdKey, voidPrimIdKey,+    realWorldPrimIdKey, recConErrorIdKey,+    unpackCStringUtf8IdKey, unpackCStringAppendUtf8IdKey, unpackCStringFoldrUtf8IdKey,+    unpackCStringIdKey, unpackCStringAppendIdKey, unpackCStringFoldrIdKey,+    typeErrorIdKey, divIntIdKey, modIntIdKey,+    absentSumFieldErrorIdKey, cstringLengthIdKey+    :: Unique++wildCardKey                    = mkPreludeMiscIdUnique  0  -- See Note [WildCard binders]+absentErrorIdKey               = mkPreludeMiscIdUnique  1+absentConstraintErrorIdKey     = mkPreludeMiscIdUnique  2+augmentIdKey                   = mkPreludeMiscIdUnique  3+appendIdKey                    = mkPreludeMiscIdUnique  4+buildIdKey                     = mkPreludeMiscIdUnique  5+foldrIdKey                     = mkPreludeMiscIdUnique  6+recSelErrorIdKey               = mkPreludeMiscIdUnique  7+seqIdKey                       = mkPreludeMiscIdUnique  8+absentSumFieldErrorIdKey       = mkPreludeMiscIdUnique  9+eqStringIdKey                  = mkPreludeMiscIdUnique 10+noMethodBindingErrorIdKey      = mkPreludeMiscIdUnique 11+nonExhaustiveGuardsErrorIdKey  = mkPreludeMiscIdUnique 12+impossibleErrorIdKey           = mkPreludeMiscIdUnique 13+impossibleConstraintErrorIdKey = mkPreludeMiscIdUnique 14+patErrorIdKey                  = mkPreludeMiscIdUnique 15+realWorldPrimIdKey             = mkPreludeMiscIdUnique 16+recConErrorIdKey               = mkPreludeMiscIdUnique 17++unpackCStringUtf8IdKey        = mkPreludeMiscIdUnique 18+unpackCStringAppendUtf8IdKey  = mkPreludeMiscIdUnique 19+unpackCStringFoldrUtf8IdKey   = mkPreludeMiscIdUnique 20++unpackCStringIdKey            = mkPreludeMiscIdUnique 21+unpackCStringAppendIdKey      = mkPreludeMiscIdUnique 22+unpackCStringFoldrIdKey       = mkPreludeMiscIdUnique 23++voidPrimIdKey                 = mkPreludeMiscIdUnique 24+typeErrorIdKey                = mkPreludeMiscIdUnique 25+divIntIdKey                   = mkPreludeMiscIdUnique 26+modIntIdKey                   = mkPreludeMiscIdUnique 27+cstringLengthIdKey            = mkPreludeMiscIdUnique 28++concatIdKey, filterIdKey, zipIdKey,+    bindIOIdKey, returnIOIdKey, newStablePtrIdKey,+    printIdKey, failIOIdKey, nullAddrIdKey, voidArgIdKey,+    otherwiseIdKey, assertIdKey :: Unique+concatIdKey                   = mkPreludeMiscIdUnique 31+filterIdKey                   = mkPreludeMiscIdUnique 32+zipIdKey                      = mkPreludeMiscIdUnique 33+bindIOIdKey                   = mkPreludeMiscIdUnique 34+returnIOIdKey                 = mkPreludeMiscIdUnique 35+newStablePtrIdKey             = mkPreludeMiscIdUnique 36+printIdKey                    = mkPreludeMiscIdUnique 37+failIOIdKey                   = mkPreludeMiscIdUnique 38+nullAddrIdKey                 = mkPreludeMiscIdUnique 39+voidArgIdKey                  = mkPreludeMiscIdUnique 40+otherwiseIdKey                = mkPreludeMiscIdUnique 43+assertIdKey                   = mkPreludeMiscIdUnique 44++leftSectionKey, rightSectionKey :: Unique+leftSectionKey                = mkPreludeMiscIdUnique 45+rightSectionKey               = mkPreludeMiscIdUnique 46++rootMainKey, runMainKey :: Unique+rootMainKey                   = mkPreludeMiscIdUnique 101+runMainKey                    = mkPreludeMiscIdUnique 102++thenIOIdKey, lazyIdKey, assertErrorIdKey, oneShotKey, runRWKey, seqHashKey :: Unique+thenIOIdKey                   = mkPreludeMiscIdUnique 103+lazyIdKey                     = mkPreludeMiscIdUnique 104+assertErrorIdKey              = mkPreludeMiscIdUnique 105+oneShotKey                    = mkPreludeMiscIdUnique 106+runRWKey                      = mkPreludeMiscIdUnique 107++traceKey :: Unique+traceKey                      = mkPreludeMiscIdUnique 108++nospecIdKey :: Unique+nospecIdKey                   = mkPreludeMiscIdUnique 109++inlineIdKey, noinlineIdKey, noinlineConstraintIdKey :: Unique+inlineIdKey                   = mkPreludeMiscIdUnique 120+-- see below++mapIdKey, dollarIdKey, coercionTokenIdKey, considerAccessibleIdKey :: Unique+mapIdKey                = mkPreludeMiscIdUnique 121+dollarIdKey             = mkPreludeMiscIdUnique 123+coercionTokenIdKey      = mkPreludeMiscIdUnique 124+considerAccessibleIdKey = mkPreludeMiscIdUnique 125+noinlineIdKey           = mkPreludeMiscIdUnique 126+noinlineConstraintIdKey = mkPreludeMiscIdUnique 127++integerToFloatIdKey, integerToDoubleIdKey, naturalToFloatIdKey, naturalToDoubleIdKey :: Unique+integerToFloatIdKey    = mkPreludeMiscIdUnique 128+integerToDoubleIdKey   = mkPreludeMiscIdUnique 129+naturalToFloatIdKey    = mkPreludeMiscIdUnique 130+naturalToDoubleIdKey   = mkPreludeMiscIdUnique 131++rationalToFloatIdKey, rationalToDoubleIdKey :: Unique+rationalToFloatIdKey   = mkPreludeMiscIdUnique 132+rationalToDoubleIdKey  = mkPreludeMiscIdUnique 133++seqHashKey             = mkPreludeMiscIdUnique 134++coerceKey :: Unique+coerceKey                     = mkPreludeMiscIdUnique 157++{-+Certain class operations from Prelude classes.  They get their own+uniques so we can look them up easily when we want to conjure them up+during type checking.+-}++-- Just a placeholder for unbound variables produced by the renamer:+unboundKey :: Unique+unboundKey                    = mkPreludeMiscIdUnique 158++fromIntegerClassOpKey, minusClassOpKey, fromRationalClassOpKey,+    enumFromClassOpKey, enumFromThenClassOpKey, enumFromToClassOpKey,+    enumFromThenToClassOpKey, eqClassOpKey, geClassOpKey, negateClassOpKey,+    bindMClassOpKey, thenMClassOpKey, returnMClassOpKey, fmapClassOpKey+    :: Unique+fromIntegerClassOpKey         = mkPreludeMiscIdUnique 160+minusClassOpKey               = mkPreludeMiscIdUnique 161+fromRationalClassOpKey        = mkPreludeMiscIdUnique 162+enumFromClassOpKey            = mkPreludeMiscIdUnique 163+enumFromThenClassOpKey        = mkPreludeMiscIdUnique 164+enumFromToClassOpKey          = mkPreludeMiscIdUnique 165+enumFromThenToClassOpKey      = mkPreludeMiscIdUnique 166+eqClassOpKey                  = mkPreludeMiscIdUnique 167+geClassOpKey                  = mkPreludeMiscIdUnique 168+negateClassOpKey              = mkPreludeMiscIdUnique 169+bindMClassOpKey               = mkPreludeMiscIdUnique 171 -- (>>=)+thenMClassOpKey               = mkPreludeMiscIdUnique 172 -- (>>)+fmapClassOpKey                = mkPreludeMiscIdUnique 173+returnMClassOpKey             = mkPreludeMiscIdUnique 174++-- Recursive do notation+mfixIdKey :: Unique+mfixIdKey       = mkPreludeMiscIdUnique 175++-- MonadFail operations+failMClassOpKey :: Unique+failMClassOpKey = mkPreludeMiscIdUnique 176++-- fromLabel+fromLabelClassOpKey :: Unique+fromLabelClassOpKey = mkPreludeMiscIdUnique 177++-- Arrow notation+arrAIdKey, composeAIdKey, firstAIdKey, appAIdKey, choiceAIdKey,+    loopAIdKey :: Unique+arrAIdKey       = mkPreludeMiscIdUnique 180+composeAIdKey   = mkPreludeMiscIdUnique 181 -- >>>+firstAIdKey     = mkPreludeMiscIdUnique 182+appAIdKey       = mkPreludeMiscIdUnique 183+choiceAIdKey    = mkPreludeMiscIdUnique 184 --  |||+loopAIdKey      = mkPreludeMiscIdUnique 185++fromStringClassOpKey :: Unique+fromStringClassOpKey          = mkPreludeMiscIdUnique 186++-- Annotation type checking+toAnnotationWrapperIdKey :: Unique+toAnnotationWrapperIdKey      = mkPreludeMiscIdUnique 187++-- Conversion functions+fromIntegralIdKey, realToFracIdKey, toIntegerClassOpKey, toRationalClassOpKey :: Unique+fromIntegralIdKey    = mkPreludeMiscIdUnique 190+realToFracIdKey      = mkPreludeMiscIdUnique 191+toIntegerClassOpKey  = mkPreludeMiscIdUnique 192+toRationalClassOpKey = mkPreludeMiscIdUnique 193++-- Monad comprehensions+guardMIdKey, liftMIdKey, mzipIdKey :: Unique+guardMIdKey     = mkPreludeMiscIdUnique 194+liftMIdKey      = mkPreludeMiscIdUnique 195+mzipIdKey       = mkPreludeMiscIdUnique 196++-- GHCi+ghciStepIoMClassOpKey :: Unique+ghciStepIoMClassOpKey = mkPreludeMiscIdUnique 197++-- Overloaded lists+isListClassKey, fromListClassOpKey, fromListNClassOpKey, toListClassOpKey :: Unique+isListClassKey = mkPreludeMiscIdUnique 198+fromListClassOpKey = mkPreludeMiscIdUnique 199+fromListNClassOpKey = mkPreludeMiscIdUnique 500+toListClassOpKey = mkPreludeMiscIdUnique 501++proxyHashKey :: Unique+proxyHashKey = mkPreludeMiscIdUnique 502++---------------- Template Haskell -------------------+--      GHC.Builtin.Names.TH: USES IdUniques 200-499+-----------------------------------------------------++-- Used to make `Typeable` dictionaries+mkTyConKey+  , mkTrTypeKey+  , mkTrConKey+  , mkTrAppCheckedKey+  , mkTrFunKey+  , typeNatTypeRepKey+  , typeSymbolTypeRepKey+  , typeCharTypeRepKey+  , typeRepIdKey+  :: Unique+mkTyConKey            = mkPreludeMiscIdUnique 503+mkTrTypeKey           = mkPreludeMiscIdUnique 504+mkTrConKey            = mkPreludeMiscIdUnique 505+mkTrAppCheckedKey     = mkPreludeMiscIdUnique 506+typeNatTypeRepKey     = mkPreludeMiscIdUnique 507+typeSymbolTypeRepKey  = mkPreludeMiscIdUnique 508+typeCharTypeRepKey    = mkPreludeMiscIdUnique 509+typeRepIdKey          = mkPreludeMiscIdUnique 510+mkTrFunKey            = mkPreludeMiscIdUnique 511++-- KindReps for common cases+starKindRepKey, starArrStarKindRepKey, starArrStarArrStarKindRepKey, constraintKindRepKey :: Unique+starKindRepKey               = mkPreludeMiscIdUnique 520+starArrStarKindRepKey        = mkPreludeMiscIdUnique 521+starArrStarArrStarKindRepKey = mkPreludeMiscIdUnique 522+constraintKindRepKey         = mkPreludeMiscIdUnique 523++-- Dynamic+toDynIdKey :: Unique+toDynIdKey            = mkPreludeMiscIdUnique 530+++heqSCSelIdKey, eqSCSelIdKey, coercibleSCSelIdKey :: Unique+eqSCSelIdKey        = mkPreludeMiscIdUnique 551+heqSCSelIdKey       = mkPreludeMiscIdUnique 552+coercibleSCSelIdKey = mkPreludeMiscIdUnique 553++sappendClassOpKey :: Unique+sappendClassOpKey = mkPreludeMiscIdUnique 554++memptyClassOpKey, mappendClassOpKey, mconcatClassOpKey :: Unique+memptyClassOpKey  = mkPreludeMiscIdUnique 555+mappendClassOpKey = mkPreludeMiscIdUnique 556+mconcatClassOpKey = mkPreludeMiscIdUnique 557++emptyCallStackKey, pushCallStackKey :: Unique+emptyCallStackKey = mkPreludeMiscIdUnique 558+pushCallStackKey  = mkPreludeMiscIdUnique 559++fromStaticPtrClassOpKey :: Unique+fromStaticPtrClassOpKey = mkPreludeMiscIdUnique 560++makeStaticKey :: Unique+makeStaticKey = mkPreludeMiscIdUnique 561++emptyExceptionContextKey :: Unique+emptyExceptionContextKey = mkPreludeMiscIdUnique 562++-- Unsafe coercion proofs+unsafeEqualityProofIdKey, unsafeCoercePrimIdKey :: Unique+unsafeEqualityProofIdKey = mkPreludeMiscIdUnique 570+unsafeCoercePrimIdKey    = mkPreludeMiscIdUnique 571++-- HasField class ops+getFieldClassOpKey, setFieldClassOpKey :: Unique+getFieldClassOpKey = mkPreludeMiscIdUnique 572+setFieldClassOpKey = mkPreludeMiscIdUnique 573++-- "Unsatisfiable" constraints+unsatisfiableIdNameKey :: Unique+unsatisfiableIdNameKey = mkPreludeMiscIdUnique 580++------------------------------------------------------+-- ghc-bignum uses 600-699 uniques+------------------------------------------------------++integerFromNaturalIdKey+   , integerToNaturalClampIdKey+   , integerToNaturalThrowIdKey+   , integerToNaturalIdKey+   , integerToWordIdKey+   , integerToIntIdKey+   , integerToWord64IdKey+   , integerToInt64IdKey+   , integerAddIdKey+   , integerMulIdKey+   , integerSubIdKey+   , integerNegateIdKey+   , integerAbsIdKey+   , integerPopCountIdKey+   , integerQuotIdKey+   , integerRemIdKey+   , integerDivIdKey+   , integerModIdKey+   , integerDivModIdKey+   , integerQuotRemIdKey+   , integerEncodeFloatIdKey+   , integerEncodeDoubleIdKey+   , integerGcdIdKey+   , integerLcmIdKey+   , integerAndIdKey+   , integerOrIdKey+   , integerXorIdKey+   , integerComplementIdKey+   , integerBitIdKey+   , integerTestBitIdKey+   , integerShiftLIdKey+   , integerShiftRIdKey+   , integerFromWordIdKey+   , integerFromWord64IdKey+   , integerFromInt64IdKey+   , naturalToWordIdKey+   , naturalPopCountIdKey+   , naturalShiftRIdKey+   , naturalShiftLIdKey+   , naturalAddIdKey+   , naturalSubIdKey+   , naturalSubThrowIdKey+   , naturalSubUnsafeIdKey+   , naturalMulIdKey+   , naturalQuotRemIdKey+   , naturalQuotIdKey+   , naturalRemIdKey+   , naturalAndIdKey+   , naturalAndNotIdKey+   , naturalOrIdKey+   , naturalXorIdKey+   , naturalTestBitIdKey+   , naturalBitIdKey+   , naturalGcdIdKey+   , naturalLcmIdKey+   , naturalLog2IdKey+   , naturalLogBaseWordIdKey+   , naturalLogBaseIdKey+   , naturalPowModIdKey+   , naturalSizeInBaseIdKey+   , bignatEqIdKey+   , bignatCompareIdKey+   , bignatCompareWordIdKey+   :: Unique++integerFromNaturalIdKey    = mkPreludeMiscIdUnique 600+integerToNaturalClampIdKey = mkPreludeMiscIdUnique 601+integerToNaturalThrowIdKey = mkPreludeMiscIdUnique 602+integerToNaturalIdKey      = mkPreludeMiscIdUnique 603+integerToWordIdKey         = mkPreludeMiscIdUnique 604+integerToIntIdKey          = mkPreludeMiscIdUnique 605+integerToWord64IdKey       = mkPreludeMiscIdUnique 606+integerToInt64IdKey        = mkPreludeMiscIdUnique 607+integerAddIdKey            = mkPreludeMiscIdUnique 608+integerMulIdKey            = mkPreludeMiscIdUnique 609+integerSubIdKey            = mkPreludeMiscIdUnique 610+integerNegateIdKey         = mkPreludeMiscIdUnique 611+integerAbsIdKey            = mkPreludeMiscIdUnique 618+integerPopCountIdKey       = mkPreludeMiscIdUnique 621+integerQuotIdKey           = mkPreludeMiscIdUnique 622+integerRemIdKey            = mkPreludeMiscIdUnique 623+integerDivIdKey            = mkPreludeMiscIdUnique 624+integerModIdKey            = mkPreludeMiscIdUnique 625+integerDivModIdKey         = mkPreludeMiscIdUnique 626+integerQuotRemIdKey        = mkPreludeMiscIdUnique 627+integerEncodeFloatIdKey    = mkPreludeMiscIdUnique 630+integerEncodeDoubleIdKey   = mkPreludeMiscIdUnique 631+integerGcdIdKey            = mkPreludeMiscIdUnique 632+integerLcmIdKey            = mkPreludeMiscIdUnique 633+integerAndIdKey            = mkPreludeMiscIdUnique 634+integerOrIdKey             = mkPreludeMiscIdUnique 635+integerXorIdKey            = mkPreludeMiscIdUnique 636+integerComplementIdKey     = mkPreludeMiscIdUnique 637+integerBitIdKey            = mkPreludeMiscIdUnique 638+integerTestBitIdKey        = mkPreludeMiscIdUnique 639+integerShiftLIdKey         = mkPreludeMiscIdUnique 640+integerShiftRIdKey         = mkPreludeMiscIdUnique 641+integerFromWordIdKey       = mkPreludeMiscIdUnique 642+integerFromWord64IdKey     = mkPreludeMiscIdUnique 643+integerFromInt64IdKey      = mkPreludeMiscIdUnique 644++naturalToWordIdKey         = mkPreludeMiscIdUnique 650+naturalPopCountIdKey       = mkPreludeMiscIdUnique 659+naturalShiftRIdKey         = mkPreludeMiscIdUnique 660+naturalShiftLIdKey         = mkPreludeMiscIdUnique 661+naturalAddIdKey            = mkPreludeMiscIdUnique 662+naturalSubIdKey            = mkPreludeMiscIdUnique 663+naturalSubThrowIdKey       = mkPreludeMiscIdUnique 664+naturalSubUnsafeIdKey      = mkPreludeMiscIdUnique 665+naturalMulIdKey            = mkPreludeMiscIdUnique 666+naturalQuotRemIdKey        = mkPreludeMiscIdUnique 669+naturalQuotIdKey           = mkPreludeMiscIdUnique 670+naturalRemIdKey            = mkPreludeMiscIdUnique 671+naturalAndIdKey            = mkPreludeMiscIdUnique 672+naturalAndNotIdKey         = mkPreludeMiscIdUnique 673+naturalOrIdKey             = mkPreludeMiscIdUnique 674+naturalXorIdKey            = mkPreludeMiscIdUnique 675+naturalTestBitIdKey        = mkPreludeMiscIdUnique 676+naturalBitIdKey            = mkPreludeMiscIdUnique 677+naturalGcdIdKey            = mkPreludeMiscIdUnique 678+naturalLcmIdKey            = mkPreludeMiscIdUnique 679+naturalLog2IdKey           = mkPreludeMiscIdUnique 680+naturalLogBaseWordIdKey    = mkPreludeMiscIdUnique 681+naturalLogBaseIdKey        = mkPreludeMiscIdUnique 682+naturalPowModIdKey         = mkPreludeMiscIdUnique 683+naturalSizeInBaseIdKey     = mkPreludeMiscIdUnique 684++bignatEqIdKey              = mkPreludeMiscIdUnique 691+bignatCompareIdKey         = mkPreludeMiscIdUnique 692+bignatCompareWordIdKey     = mkPreludeMiscIdUnique 693+++------------------------------------------------------+-- ghci optimization for big rationals 700-749 uniques+------------------------------------------------------++-- Creating rationals at runtime.+mkRationalBase2IdKey, mkRationalBase10IdKey :: Unique+mkRationalBase2IdKey  = mkPreludeMiscIdUnique 700+mkRationalBase10IdKey = mkPreludeMiscIdUnique 701 :: Unique++{-+************************************************************************+*                                                                      *+\subsection[Class-std-groups]{Standard groups of Prelude classes}+*                                                                      *+************************************************************************++NOTE: @Eq@ and @Text@ do need to appear in @standardClasses@+even though every numeric class has these two as a superclass,+because the list of ambiguous dictionaries hasn't been simplified.+-}++numericClassKeys :: [Unique]+numericClassKeys =+        [ numClassKey+        , realClassKey+        , integralClassKey+        ]+        ++ fractionalClassKeys++fractionalClassKeys :: [Unique]+fractionalClassKeys =+        [ fractionalClassKey+        , floatingClassKey+        , realFracClassKey+        , realFloatClassKey+        ]++-- The "standard classes" are used in defaulting (Haskell 98 report 4.3.4),+-- and are: "classes defined in the Prelude or a standard library"+standardClassKeys :: [Unique]+standardClassKeys = derivableClassKeys ++ numericClassKeys+                  ++ [randomClassKey, randomGenClassKey,+                      functorClassKey,+                      monadClassKey, monadPlusClassKey, monadFailClassKey,+                      semigroupClassKey, monoidClassKey,+                      isStringClassKey,+                      applicativeClassKey, foldableClassKey,+                      traversableClassKey, alternativeClassKey+                     ]++{-+@derivableClassKeys@ is also used in checking \tr{deriving} constructs+(@GHC.Tc.Deriv@).+-}++derivableClassKeys :: [Unique]+derivableClassKeys+  = [ eqClassKey, ordClassKey, enumClassKey, ixClassKey,+      boundedClassKey, showClassKey, readClassKey ]+++-- These are the "interactive classes" that are consulted when doing+-- defaulting. Does not include Num or IsString, which have special+-- handling.+interactiveClassNames :: [Name]+interactiveClassNames+  = [ showClassName, eqClassName, ordClassName, foldableClassName+    , traversableClassName ]++interactiveClassKeys :: [Unique]+interactiveClassKeys = map getUnique interactiveClassNames
GHC/Builtin/Names/TH.hs view
@@ -10,14 +10,15 @@  import GHC.Builtin.Names( mk_known_key_name ) import GHC.Unit.Types-import GHC.Unit.Module.Name import GHC.Types.Name( Name )-import GHC.Types.Name.Occurrence( tcName, clsName, dataName, varName )+import GHC.Types.Name.Occurrence( tcName, clsName, dataName, varName, fieldName ) import GHC.Types.Name.Reader( RdrName, nameRdrName )-import GHC.Types.Unique+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@@ -30,8 +31,9 @@  templateHaskellNames = [     returnQName, bindQName, sequenceQName, newNameName, liftName, liftTypedName,-    mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameLName,-    mkNameSName,+    mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameG_fldName,+    mkNameLName,+    mkNameSName, mkNameQName,     mkModNameName,     liftStringName,     unTypeName, unTypeCodeName,@@ -45,6 +47,7 @@     litPName, varPName, tupPName, unboxedTupPName, unboxedSumPName,     conPName, tildePName, bangPName, infixPName,     asPName, wildPName, recPName, listPName, sigPName, viewPName,+    typePName, invisPName, orPName,     -- FieldPat     fieldPatName,     -- Match@@ -59,6 +62,7 @@     fromEName, fromThenEName, fromToEName, fromThenToEName,     listEName, sigEName, recConEName, recUpdEName, staticEName, unboundVarEName,     labelEName, implicitParamVarEName, getFieldEName, projectionEName,+    typeEName, forallEName, forallVisEName, constrainedEName,     -- FieldExp     fieldExpName,     -- Body@@ -68,14 +72,17 @@     -- Stmt     bindSName, letSName, noBindSName, parSName, recSName,     -- Dec-    funDName, valDName, dataDName, newtypeDName, tySynDName,+    funDName, valDName, dataDName, newtypeDName, typeDataDName, tySynDName,     classDName, instanceWithOverlapDName,     standaloneDerivWithStrategyDName, sigDName, kiSigDName, forImpDName,-    pragInlDName, pragOpaqueDName, pragSpecDName, pragSpecInlDName, pragSpecInstDName,-    pragRuleDName, pragCompleteDName, pragAnnDName, defaultSigDName, defaultDName,+    pragInlDName, pragOpaqueDName,+    pragSpecDName, pragSpecInlDName, pragSpecEDName, pragSpecInlEDName,+    pragSpecInstDName,+    pragRuleDName, pragCompleteDName, pragAnnDName, pragSCCFunDName, pragSCCFunNamedDName,+    defaultSigDName, defaultDName,     dataFamilyDName, openTypeFamilyDName, closedTypeFamilyDName,     dataInstDName, newtypeInstDName, tySynInstDName,-    infixLDName, infixRDName, infixNDName,+    infixLWithSpecDName, infixRWithSpecDName, infixNWithSpecDName,     roleAnnotDName, patSynDName, patSynSigDName,     implicitParamBindDName,     -- Cxt@@ -108,8 +115,11 @@     -- TyVarBndr     plainTVName, kindedTVName,     plainInvisTVName, kindedInvisTVName,+    plainBndrTVName, kindedBndrTVName,     -- Specificity     specifiedSpecName, inferredSpecName,+    -- Visibility+    bndrReqName, bndrInvisName,     -- Role     nominalRName, representationalRName, phantomRName, inferRName,     -- Kind@@ -133,6 +143,9 @@     -- Overlap     overlappableDataConName, overlappingDataConName, overlapsDataConName,     incoherentDataConName,+    -- NamespaceSpecifier+    noNamespaceSpecifierDataConName, typeNamespaceSpecifierDataConName,+    dataNamespaceSpecifierDataConName,     -- DerivStrategy     stockStrategyName, anyclassStrategyName,     newtypeStrategyName, viaStrategyName,@@ -151,11 +164,14 @@     liftClassName, quoteClassName,      -- And the tycons-    qTyConName, nameTyConName, patTyConName, fieldPatTyConName, matchTyConName,+    qTyConName, nameTyConName, patTyConName,+    fieldPatTyConName, matchTyConName,     expQTyConName, fieldExpTyConName, predTyConName,     stmtTyConName,  decsTyConName, conTyConName, bangTypeTyConName,     varBangTypeTyConName, typeQTyConName, expTyConName, decTyConName,-    typeTyConName, tyVarBndrUnitTyConName, tyVarBndrSpecTyConName, clauseTyConName,+    typeTyConName,+    tyVarBndrUnitTyConName, tyVarBndrSpecTyConName, tyVarBndrVisTyConName,+    clauseTyConName,     patQTyConName, funDepTyConName, decsQTyConName,     ruleBndrTyConName, tySynEqnTyConName,     roleTyConName, codeTyConName, injAnnTyConName, kindTyConName,@@ -163,28 +179,35 @@     modNameTyConName,      -- Quasiquoting-    quoteDecName, quoteTypeName, quoteExpName, quotePatName]+    quasiQuoterTyConName, quoteDecName, quoteTypeName, quoteExpName, quotePatName] -thSyn, thLib, qqLib :: Module-thSyn = mkTHModule (fsLit "Language.Haskell.TH.Syntax")-thLib = mkTHModule (fsLit "Language.Haskell.TH.Lib.Internal")-qqLib = mkTHModule (fsLit "Language.Haskell.TH.Quote")+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 thUnit (mkModuleNameFS m)+mkTHModule m = mkModule ghcInternalUnit (mkModuleNameFS m) -libFun, libTc, thFun, thTc, thCls, thCon, qqFun :: FastString -> Unique -> Name+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-qqFun  = mk_known_key_name varName  qqLib+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 = thCls (fsLit "Lift") liftClassKey+liftClassName = mk_known_key_name clsName liftLib (fsLit "Lift") liftClassKey  quoteClassName :: Name quoteClassName = thCls (fsLit "Quote") quoteClassKey@@ -193,7 +216,7 @@     fieldPatTyConName, expTyConName, decTyConName, typeTyConName,     matchTyConName, clauseTyConName, funDepTyConName, predTyConName,     codeTyConName, injAnnTyConName, overlapTyConName, decsTyConName,-    modNameTyConName :: Name+    modNameTyConName, quasiQuoterTyConName :: Name qTyConName             = thTc (fsLit "Q")              qTyConKey nameTyConName          = thTc (fsLit "Name")           nameTyConKey fieldExpTyConName      = thTc (fsLit "FieldExp")       fieldExpTyConKey@@ -211,28 +234,31 @@ 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_dName, mkNameG_tcName,+    mkNameName, mkNameG_vName, mkNameG_fldName, mkNameG_dName, mkNameG_tcName,     mkNameLName, mkNameSName, liftStringName, unTypeName, unTypeCodeName,-    unsafeCodeCoerceName, liftTypedName, mkModNameName :: Name+    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-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+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     = thFun (fsLit "unType")     unTypeIdKey+unTypeName     = thFld (fsLit "TExp") (fsLit "unType") unTypeIdKey unTypeCodeName    = thFun (fsLit "unTypeCode") unTypeCodeIdKey unsafeCodeCoerceName = thFun (fsLit "unsafeCodeCoerce") unsafeCodeCoerceIdKey-liftTypedName = thFun (fsLit "liftTyped") liftTypedIdKey+liftName       = liftFun (fsLit "lift")      liftIdKey+liftStringName = liftFun (fsLit "liftString")  liftStringIdKey+liftTypedName = liftFun (fsLit "liftTyped") liftTypedIdKey   -------------------- TH.Lib -----------------------@@ -254,7 +280,7 @@ -- data Pat = ... litPName, varPName, tupPName, unboxedTupPName, unboxedSumPName, conPName,     infixPName, tildePName, bangPName, asPName, wildPName, recPName, listPName,-    sigPName, viewPName :: Name+    sigPName, viewPName, typePName, invisPName, orPName :: Name litPName   = libFun (fsLit "litP")   litPIdKey varPName   = libFun (fsLit "varP")   varPIdKey tupPName   = libFun (fsLit "tupP")   tupPIdKey@@ -270,6 +296,9 @@ 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@@ -288,7 +317,8 @@     sectionLName, sectionRName, lamEName, lamCaseEName, lamCasesEName, tupEName,     unboxedTupEName, unboxedSumEName, condEName, multiIfEName, letEName,     caseEName, doEName, mdoEName, compEName, staticEName, unboundVarEName,-    labelEName, implicitParamVarEName, getFieldEName, projectionEName :: Name+    labelEName, implicitParamVarEName, getFieldEName, projectionEName, typeEName,+    forallEName, forallVisEName, constrainedEName :: Name varEName              = libFun (fsLit "varE")              varEIdKey conEName              = libFun (fsLit "conE")              conEIdKey litEName              = libFun (fsLit "litE")              litEIdKey@@ -329,6 +359,10 @@ 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@@ -353,18 +387,21 @@ recSName    = libFun (fsLit "recS")    recSIdKey  -- data Dec = ...-funDName, valDName, dataDName, newtypeDName, tySynDName, classDName,+funDName, valDName, dataDName, newtypeDName, typeDataDName, tySynDName, classDName,     instanceWithOverlapDName, sigDName, kiSigDName, forImpDName, pragInlDName,-    pragSpecDName, pragSpecInlDName, pragSpecInstDName, pragRuleDName,-    pragAnnDName, standaloneDerivWithStrategyDName, defaultSigDName, defaultDName,+    pragSpecDName, pragSpecInlDName, pragSpecEDName, pragSpecInlEDName,+    pragSpecInstDName, pragRuleDName,+    pragAnnDName, pragSCCFunDName, pragSCCFunNamedDName,+    standaloneDerivWithStrategyDName, defaultSigDName, defaultDName,     dataInstDName, newtypeInstDName, tySynInstDName, dataFamilyDName,-    openTypeFamilyDName, closedTypeFamilyDName, infixLDName, infixRDName,-    infixNDName, roleAnnotDName, patSynDName, patSynSigDName,-    pragCompleteDName, implicitParamBindDName, pragOpaqueDName :: Name+    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@@ -378,19 +415,23 @@ 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-infixLDName                      = libFun (fsLit "infixLD")                      infixLDIdKey-infixRDName                      = libFun (fsLit "infixRD")                      infixRDIdKey-infixNDName                      = libFun (fsLit "infixND")                      infixNDIdKey+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@@ -489,11 +530,20 @@ 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@@ -566,7 +616,7 @@     varBangTypeTyConName, typeQTyConName,     decsQTyConName, ruleBndrTyConName, tySynEqnTyConName, roleTyConName,     derivClauseTyConName, kindTyConName,-    tyVarBndrUnitTyConName, tyVarBndrSpecTyConName,+    tyVarBndrUnitTyConName, tyVarBndrSpecTyConName, tyVarBndrVisTyConName,     derivStrategyTyConName :: Name -- These are only used for the types of top-level splices expQTyConName           = libTc (fsLit "ExpQ")           expQTyConKey@@ -586,14 +636,15 @@ 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        = qqFun (fsLit "quoteExp")  quoteExpKey-quotePatName        = qqFun (fsLit "quotePat")  quotePatKey-quoteDecName        = qqFun (fsLit "quoteDec")  quoteDecKey-quoteTypeName       = qqFun (fsLit "quoteType") quoteTypeKey+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@@ -622,6 +673,17 @@ 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@@ -649,14 +711,14 @@ expTyConKey, matchTyConKey, clauseTyConKey, qTyConKey, expQTyConKey,     patTyConKey,     stmtTyConKey, conTyConKey, typeQTyConKey, typeTyConKey,-    tyVarBndrUnitTyConKey, tyVarBndrSpecTyConKey,+    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  :: Unique+    modNameTyConKey, quasiQuoterTyConKey :: Unique expTyConKey             = mkPreludeTyConUnique 200 matchTyConKey           = mkPreludeTyConUnique 201 clauseTyConKey          = mkPreludeTyConUnique 202@@ -691,6 +753,8 @@ tyVarBndrSpecTyConKey   = mkPreludeTyConUnique 237 codeTyConKey            = mkPreludeTyConUnique 238 modNameTyConKey         = mkPreludeTyConUnique 239+tyVarBndrVisTyConKey    = mkPreludeTyConUnique 240+quasiQuoterTyConKey     = mkPreludeTyConUnique 241  {- ********************************************************************* *                                                                      *@@ -728,6 +792,13 @@ overlapsDataConKey     = mkPreludeDataConUnique 211 incoherentDataConKey   = mkPreludeDataConUnique 212 +-- data NamespaceSpecifier = ...+noNamespaceSpecifierDataConKey,+  typeNamespaceSpecifierDataConKey,+  dataNamespaceSpecifierDataConKey :: Unique+noNamespaceSpecifierDataConKey = mkPreludeDataConUnique 213+typeNamespaceSpecifierDataConKey = mkPreludeDataConUnique 214+dataNamespaceSpecifierDataConKey = mkPreludeDataConUnique 215 {- ********************************************************************* *                                                                      *                      Id keys@@ -738,9 +809,9 @@ -- If you want to change this, make sure you check in GHC.Builtin.Names  returnQIdKey, bindQIdKey, sequenceQIdKey, liftIdKey, newNameIdKey,-    mkNameIdKey, mkNameG_vIdKey, mkNameG_dIdKey, mkNameG_tcIdKey,+    mkNameIdKey, mkNameG_vIdKey, mkNameG_fldIdKey, mkNameG_dIdKey, mkNameG_tcIdKey,     mkNameLIdKey, mkNameSIdKey, unTypeIdKey, unTypeCodeIdKey,-    unsafeCodeCoerceIdKey, liftTypedIdKey, mkModNameIdKey :: Unique+    unsafeCodeCoerceIdKey, liftTypedIdKey, mkModNameIdKey, mkNameQIdKey :: Unique returnQIdKey        = mkPreludeMiscIdUnique 200 bindQIdKey          = mkPreludeMiscIdUnique 201 sequenceQIdKey      = mkPreludeMiscIdUnique 202@@ -757,6 +828,8 @@ liftTypedIdKey        = mkPreludeMiscIdUnique 214 mkModNameIdKey        = mkPreludeMiscIdUnique 215 unsafeCodeCoerceIdKey = mkPreludeMiscIdUnique 216+mkNameQIdKey         = mkPreludeMiscIdUnique 217+mkNameG_fldIdKey     = mkPreludeMiscIdUnique 218   -- data Lit = ...@@ -780,7 +853,7 @@ -- data Pat = ... litPIdKey, varPIdKey, tupPIdKey, unboxedTupPIdKey, unboxedSumPIdKey, conPIdKey,   infixPIdKey, tildePIdKey, bangPIdKey, asPIdKey, wildPIdKey, recPIdKey,-  listPIdKey, sigPIdKey, viewPIdKey :: Unique+  listPIdKey, sigPIdKey, viewPIdKey, typePIdKey, invisPIdKey, orPIdKey :: Unique litPIdKey         = mkPreludeMiscIdUnique 240 varPIdKey         = mkPreludeMiscIdUnique 241 tupPIdKey         = mkPreludeMiscIdUnique 242@@ -796,6 +869,9 @@ listPIdKey        = mkPreludeMiscIdUnique 252 sigPIdKey         = mkPreludeMiscIdUnique 253 viewPIdKey        = mkPreludeMiscIdUnique 254+typePIdKey        = mkPreludeMiscIdUnique 255+invisPIdKey       = mkPreludeMiscIdUnique 256+orPIdKey          = mkPreludeMiscIdUnique 257  -- type FieldPat = ... fieldPatIdKey :: Unique@@ -818,7 +894,8 @@     fromEIdKey, fromThenEIdKey, fromToEIdKey, fromThenToEIdKey,     listEIdKey, sigEIdKey, recConEIdKey, recUpdEIdKey, staticEIdKey,     unboundVarEIdKey, labelEIdKey, implicitParamVarEIdKey, mdoEIdKey,-    getFieldEIdKey, projectionEIdKey :: Unique+    getFieldEIdKey, projectionEIdKey, typeEIdKey, forallEIdKey,+    forallVisEIdKey, constrainedEIdKey :: Unique varEIdKey              = mkPreludeMiscIdUnique 270 conEIdKey              = mkPreludeMiscIdUnique 271 litEIdKey              = mkPreludeMiscIdUnique 272@@ -855,28 +932,32 @@ 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 306+fieldExpIdKey       = mkPreludeMiscIdUnique 307  -- data Body = ... guardedBIdKey, normalBIdKey :: Unique-guardedBIdKey     = mkPreludeMiscIdUnique 307-normalBIdKey      = mkPreludeMiscIdUnique 308+guardedBIdKey     = mkPreludeMiscIdUnique 308+normalBIdKey      = mkPreludeMiscIdUnique 309  -- data Guard = ... normalGEIdKey, patGEIdKey :: Unique-normalGEIdKey     = mkPreludeMiscIdUnique 309-patGEIdKey        = mkPreludeMiscIdUnique 310+normalGEIdKey     = mkPreludeMiscIdUnique 310+patGEIdKey        = mkPreludeMiscIdUnique 311  -- data Stmt = ... bindSIdKey, letSIdKey, noBindSIdKey, parSIdKey, recSIdKey :: Unique-bindSIdKey       = mkPreludeMiscIdUnique 311-letSIdKey        = mkPreludeMiscIdUnique 312-noBindSIdKey     = mkPreludeMiscIdUnique 313-parSIdKey        = mkPreludeMiscIdUnique 314-recSIdKey        = mkPreludeMiscIdUnique 315+bindSIdKey       = mkPreludeMiscIdUnique 312+letSIdKey        = mkPreludeMiscIdUnique 313+noBindSIdKey     = mkPreludeMiscIdUnique 314+parSIdKey        = mkPreludeMiscIdUnique 315+recSIdKey        = mkPreludeMiscIdUnique 316  -- data Dec = ... funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey, classDIdKey,@@ -885,9 +966,11 @@     pragRuleDIdKey, pragAnnDIdKey, defaultSigDIdKey, dataFamilyDIdKey,     openTypeFamilyDIdKey, closedTypeFamilyDIdKey, dataInstDIdKey,     newtypeInstDIdKey, tySynInstDIdKey, standaloneDerivWithStrategyDIdKey,-    infixLDIdKey, infixRDIdKey, infixNDIdKey, roleAnnotDIdKey, patSynDIdKey,-    patSynSigDIdKey, pragCompleteDIdKey, implicitParamBindDIdKey,-    kiSigDIdKey, defaultDIdKey, pragOpaqueDIdKey :: Unique+    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@@ -910,9 +993,9 @@ newtypeInstDIdKey                 = mkPreludeMiscIdUnique 339 tySynInstDIdKey                   = mkPreludeMiscIdUnique 340 closedTypeFamilyDIdKey            = mkPreludeMiscIdUnique 341-infixLDIdKey                      = mkPreludeMiscIdUnique 342-infixRDIdKey                      = mkPreludeMiscIdUnique 343-infixNDIdKey                      = mkPreludeMiscIdUnique 344+infixLWithSpecDIdKey              = mkPreludeMiscIdUnique 342+infixRWithSpecDIdKey              = mkPreludeMiscIdUnique 343+infixNWithSpecDIdKey              = mkPreludeMiscIdUnique 344 roleAnnotDIdKey                   = mkPreludeMiscIdUnique 345 standaloneDerivWithStrategyDIdKey = mkPreludeMiscIdUnique 346 defaultSigDIdKey                  = mkPreludeMiscIdUnique 347@@ -922,7 +1005,12 @@ implicitParamBindDIdKey           = mkPreludeMiscIdUnique 351 kiSigDIdKey                       = mkPreludeMiscIdUnique 352 defaultDIdKey                     = mkPreludeMiscIdUnique 353-pragOpaqueDIdKey                   = mkPreludeMiscIdUnique 354+pragOpaqueDIdKey                  = mkPreludeMiscIdUnique 354+typeDataDIdKey                    = mkPreludeMiscIdUnique 355+pragSCCFunDKey                    = mkPreludeMiscIdUnique 356+pragSCCFunNamedDKey               = mkPreludeMiscIdUnique 357+pragSpecEDIdKey                   = mkPreludeMiscIdUnique 358+pragSpecInlEDIdKey                = mkPreludeMiscIdUnique 359  -- type Cxt = ... cxtIdKey :: Unique@@ -1017,6 +1105,10 @@ 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@@ -1101,6 +1193,11 @@ 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+ {- ************************************************************************ *                                                                      *@@ -1109,27 +1206,7 @@ ************************************************************************ -} -lift_RDR, liftTyped_RDR, mkNameG_dRDR, mkNameG_vRDR, unsafeCodeCoerce_RDR :: RdrName+lift_RDR, liftTyped_RDR, unsafeCodeCoerce_RDR :: RdrName lift_RDR     = nameRdrName liftName liftTyped_RDR = nameRdrName liftTypedName unsafeCodeCoerce_RDR = nameRdrName unsafeCodeCoerceName-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
GHC/Builtin/PrimOps.hs view
@@ -5,20 +5,24 @@ -}  {-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}  module GHC.Builtin.PrimOps (         PrimOp(..), PrimOpVecCat(..), allThePrimOps,         primOpType, primOpSig, primOpResultType,         primOpTag, maxPrimOpTag, primOpOcc,         primOpWrapperId,+        pprPrimOp,          tagToEnumKey,          primOpOutOfLine, primOpCodeSize,-        primOpOkForSpeculation, primOpOkForSideEffects,-        primOpIsCheap, primOpFixity, primOpDocs,-        primOpIsDiv,+        primOpOkForSpeculation, primOpOkToDiscard,+        primOpIsWorkFree, primOpIsCheap, primOpFixity, primOpDocs, primOpDeprecations,+        primOpIsDiv, primOpIsReallyInline, +        PrimOpEffect(..), primOpEffect,+         getPrimOpResultInfo,  isComparisonPrimOp, PrimOpResultInfo(..),          PrimCall(..)@@ -31,7 +35,7 @@ import GHC.Builtin.Uniques (mkPrimOpIdUnique, mkPrimOpWrapperUnique ) import GHC.Builtin.Names ( gHC_PRIMOPWRAPPERS ) -import GHC.Core.TyCon    ( TyCon, isPrimTyCon, PrimRep(..) )+import GHC.Core.TyCon    ( isPrimTyCon, isUnboxedTupleTyCon, PrimRep(..) ) import GHC.Core.Type  import GHC.Cmm.Type@@ -40,17 +44,17 @@ import GHC.Types.Id import GHC.Types.Id.Info import GHC.Types.Name-import GHC.Types.RepType ( tyConPrimRep1 )+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.SourceText  ( SourceText(..) )-import GHC.Types.Unique  ( Unique)+import GHC.Types.Unique  ( Unique )  import GHC.Unit.Types    ( Unit )  import GHC.Utils.Outputable+import GHC.Utils.Panic  import GHC.Data.FastString @@ -158,12 +162,15 @@ *                                                                      * ************************************************************************ -See Note [GHC.Prim Docs]+See Note [GHC.Prim Docs] in GHC.Builtin.Utils -} -primOpDocs :: [(String, String)]+primOpDocs :: [(FastString, String)] #include "primop-docs.hs-incl" +primOpDeprecations :: [(OccName, FastString)]+#include "primop-deprecations.hs-incl"+ {- ************************************************************************ *                                                                      *@@ -309,221 +316,316 @@ *                                                                      * ************************************************************************ -Note [Checking versus non-checking primops]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -  In GHC primops break down into two classes:+Note [Exceptions: asynchronous, synchronous, and unchecked]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There are three very different sorts of things in GHC-Haskell that are+sometimes called exceptions: -   a. Checking primops behave, for instance, like division. In this-      case the primop may throw an exception (e.g. division-by-zero)-      and is consequently is marked with the can_fail flag described below.-      The ability to fail comes at the expense of precluding some optimizations.+* Haskell exceptions: -   b. Non-checking primops behavior, for instance, like addition. While-      addition can overflow it does not produce an exception. So can_fail is-      set to False, and we get more optimisation opportunities.  But we must-      never throw an exception, so we cannot rewrite to a call to error.+  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: -  It is important that a non-checking primop never be transformed in a way that-  would cause it to bottom. Doing so would violate Core's let/app invariant-  (see Note [Core let/app invariant] in GHC.Core) which is critical to-  the simplifier's ability to float without fear of changing program meaning.+  * 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. -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.+* Unchecked exceptions: -----------  has_side_effects ----------------------A primop "has_side_effects" if it has some side effect, visible-elsewhere, apart from the result it returns-    - reading or writing to the world (I/O)-    - reading or writing to a mutable data structure (writeIORef)-    - throwing a synchronous Haskell exception+  * 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. -Often such primops have a type like-   State -> input -> (State, output)-so the state token guarantees ordering.  In general we rely on-data dependencies of the state token to enforce write-effect ordering,-but as the notes below make clear, the matter is a bit more complicated-than that. - * NB1: if you inline unsafePerformIO, you may end up with-   side-effecting ops whose 'state' output is discarded.-   And programmers may do that by hand; see #9390.-   That is why we (conservatively) do not discard write-effecting-   primops even if both their state and result is discarded.+Note [Classifying primop effects]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Each primop has an associated 'PrimOpEffect', based on what that+primop can or cannot do at runtime.  This classification is - * 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".+* Recorded in the 'effect' field in primops.txt.pp, and+* Exposed to the compiler via the 'primOpEffect' function in this module. - * NB3: *Read* effects on *mutable* cells (like reading an IORef or a-   MutableArray#) /are/ included.  You may find this surprising because it-   doesn't matter if we don't do them, or do them more than once.  *Sequencing*-   is maintained by the data dependency of the state token.  But see-   "Duplication" below under-   Note [Transformations affected by can_fail and has_side_effects]+See Note [Transformations affected by primop effects] for how we make+use of this categorisation. -   Note that read operations on *immutable* values (like indexArray#) do not-   have has_side_effects.   (They might be marked can_fail, however, because-   you might index out of bounds.)+The meanings of the four constructors of 'PrimOpEffect' are as+follows, in decreasing order of permissiveness: -   Using has_side_effects in this way is a bit of a blunt instrument.  We could-   be more refined by splitting read and write effects (see comments with #3207-   and #20195)+* 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#). -----------  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 denominator)-   array indexing (fails if the index is out of bounds)+    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.) -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 that operations like `indexArray#` that read *immutable*+    data structures do not need such special sequencing-related care,+    and are therefore not marked ReadWriteEffect. -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.+* 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. -            can_fail     has_side_effects-Discard        YES           NO-Float in       YES           YES-Float out      NO            NO-Duplicate      YES           NO+    See also Note [Exceptions: asynchronous, synchronous, and unchecked].+    Examples include raise#, raiseIO#, dataToTagLarge#, and seq#. -* 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 (#9390).  So we (conservatively)-  never discard a has_side_effects primop.+    Note that whether an exception is considered precise or imprecise+    does not matter for the purposes of the PrimOpEffect flag. -  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 #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.+* 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. -  Similarly (a `/#` b) can be discarded.  It can seg-fault or-  cause a hardware exception, but not a synchronous Haskell-  exception.+    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. -  Synchronous Haskell exceptions, e.g. from raiseIO#, are treated-  as has_side_effects and hence are not discarded.+    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. -* Float in.  You can float a can_fail or has_side_effects primop-  *inwards*, but not inside a lambda (see Duplication below).+    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. -* Float out.  You must not float a can_fail primop *outwards* lest-  you escape the dynamic scope of the test.  Example:+    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+    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 has_side_effects primop.  For example:+    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+    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.+    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+    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.+    (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 can_fail primop.  That is really-  the only difference between can_fail and has_side_effects.+    However, it's fine to duplicate a CanFail or ThrowsException primop. -Note [Implementation: how can_fail/has_side_effects affect transformations]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+++Note [Implementation: how PrimOpEffect affects transformations]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ How do we ensure that floating/duplication/discarding are done right in the simplifier? -Two main predicates on primops test these flags:-  primOpOkForSideEffects <=> not has_side_effects-  primOpOkForSpeculation <=> not (has_side_effects || can_fail)+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 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.+    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 can_fail and has_side_effects primops will appear only as the+  * 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. -  * The no-duplicate thing is done via primOpIsCheap, by making-    has_side_effects things (very very very) not-cheap!+  * 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. -} -primOpHasSideEffects :: PrimOp -> Bool-#include "primop-has-side-effects.hs-incl"+primOpEffect :: PrimOp -> PrimOpEffect+#include "primop-effects.hs-incl" -primOpCanFail :: PrimOp -> Bool-#include "primop-can-fail.hs-incl"+data PrimOpEffect+  -- See Note [Classifying primop effects]+  = NoEffect+  | CanFail+  | ThrowsException+  | ReadWriteEffect+  deriving (Eq, Ord)  primOpOkForSpeculation :: PrimOp -> Bool-  -- See Note [PrimOp can_fail and has_side_effects]+  -- See Note [Classifying primop effects]   -- See comments with GHC.Core.Utils.exprOkForSpeculation-  -- primOpOkForSpeculation => primOpOkForSideEffects+  -- primOpOkForSpeculation => primOpOkToDiscard primOpOkForSpeculation op-  =  primOpOkForSideEffects op-  && not (primOpOutOfLine op || primOpCanFail 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 -primOpOkForSideEffects :: PrimOp -> Bool-primOpOkForSideEffects op-  = not (primOpHasSideEffects op)--{--Note [primOpIsCheap]-~~~~~~~~~~~~~~~~~~~~+primOpOkToDiscard :: PrimOp -> Bool+primOpOkToDiscard op+  = primOpEffect op < ThrowsException -@primOpIsCheap@, as used in GHC.Core.Opt.Simplify.Utils.  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.--}+primOpIsWorkFree :: PrimOp -> Bool+#include "primop-is-work-free.hs-incl"  primOpIsCheap :: PrimOp -> Bool--- See Note [PrimOp can_fail and has_side_effects]-primOpIsCheap op = primOpOkForSpeculation op+-- 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@@ -538,7 +640,7 @@ -- 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+-- that (it's primOpIsWorkFree that does) so the problem doesn't occur -- even if primOpIsCheap sometimes says 'True'.  @@ -549,37 +651,44 @@ primOpIsDiv :: PrimOp -> Bool primOpIsDiv op = case op of -  -- TODO: quotRemWord2, Int64, Word64   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@@ -658,7 +767,7 @@ GHC.ByteCode.Linker.primopToCLabel). TODO: Perhaps this should be changed?  Note that these wrappers aren't *quite* as expressive as their unwrapped-breathren, in that they may exhibit less representation polymorphism.+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).@@ -750,8 +859,9 @@         GenPrimOp _occ tyvars arg_tys res_ty -> (tyvars, arg_tys, res_ty   )  data PrimOpResultInfo-  = ReturnsPrim     PrimRep-  | ReturnsAlg      TyCon+  = 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*@@ -760,9 +870,13 @@ getPrimOpResultInfo :: PrimOp -> PrimOpResultInfo getPrimOpResultInfo op   = case (primOpInfo op) of-      Compare _ _                         -> ReturnsPrim (tyConPrimRep1 intPrimTyCon)-      GenPrimOp _ _ _ ty | isPrimTyCon tc -> ReturnsPrim (tyConPrimRep1 tc)-                         | otherwise      -> ReturnsAlg tc+      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@@ -788,8 +902,10 @@  -- Output stuff: -pprPrimOp  :: PrimOp -> SDoc+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  {- ************************************************************************@@ -804,3 +920,12 @@ instance Outputable PrimCall where   ppr (PrimCall lbl pkgId)         = text "__primcall" <+> ppr pkgId <+> ppr lbl++-- | Indicate if a primop is really inline: that is, it isn't out-of-line and it+-- isn't DataToTagOp which are two primops that evaluate their argument+-- hence induce thread/stack/heap changes.+primOpIsReallyInline :: PrimOp -> Bool+primOpIsReallyInline = \case+  DataToTagSmallOp -> False+  DataToTagLargeOp -> False+  p                -> not (primOpOutOfLine p)
GHC/Builtin/PrimOps.hs-boot view
@@ -1,5 +1,6 @@ module GHC.Builtin.PrimOps where -import GHC.Prelude ()+-- See W1 of Note [Tracking dependencies on primitives] in GHC.Internal.Base+import GHC.Base ()  data PrimOp
+ GHC/Builtin/PrimOps/Casts.hs view
@@ -0,0 +1,211 @@+{-+This module contains helpers to cast variables+between different Int/WordReps in StgLand.++-}++module GHC.Builtin.PrimOps.Casts+    ( getCasts )+where++import GHC.Prelude++import GHC.Core.TyCon+import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Types.RepType+import GHC.Core.Type+import GHC.Builtin.Types.Prim++import GHC.Builtin.PrimOps+import GHC.Plugins (HasDebugCallStack)++{- Note [PrimRep based casting]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+This module contains a number of utility functions useful when+converting between variables of differing PrimReps.++The general pattern is:+* We have two primReps `from_rep` and `to_rep`.+* We want a list of PrimOps we can apply to a variable of rep `from_rep`.+Applying the list of primOps in order takes us to `to_rep` from `from_rep` giving+us a variable of the returned type at each step.++E.g. we call `getCasts from_rep to_rep` and get back [(op1#,ty1),(op2#,ty2)].+We can use this result to construct a function of type+`StgExpr -> StgExpr` by construction an expression++    case op1# <from> of (x' :: ty1) -> case op2# x' of x' -> <rhs_hole>++Ideally backends will compile the sequence of PrimOps to a no-op. E.g. by reusing+the same register but just relabeling it as another width.+However this is might not always be possible or the required optimizations+simply not implemented in the backend. This means currently many of these casts+will be cheap but not all of them will be completely zero-cost.++-}++-- | `getCasts from_rep to_rep` gives us a list of primops which when applied in order convert from_rep to to_rep.+-- See Note [PrimRep based casting]+getCasts :: PrimRep -> PrimRep -> [(PrimOp,Type)]+getCasts from_rep to_rep+  -- No-op+  | -- pprTrace "getCasts" (ppr (from_rep,to_rep)) $+    to_rep == from_rep+  = []++  -- Float <-> Double+  | to_rep == FloatRep =+    assertPpr (from_rep == DoubleRep) (ppr from_rep <+> ppr to_rep) $+    [(DoubleToFloatOp,floatPrimTy)]+  | to_rep == DoubleRep =+    assertPpr (from_rep == FloatRep) (ppr from_rep <+> ppr to_rep) $+    [(FloatToDoubleOp,doublePrimTy)]++  -- Addr <-> Word/Int+  | to_rep == AddrRep = wordOrIntToAddrRep from_rep+  | from_rep == AddrRep = addrToWordOrIntRep to_rep++  -- Int* -> Int*+  | primRepIsInt from_rep+  , primRepIsInt to_rep+  = sizedIntToSizedInt from_rep to_rep++  -- Word* -> Word*+  | primRepIsWord from_rep+  , primRepIsWord to_rep+  = sizedWordToSizedWord from_rep to_rep++  -- Word* -> Int*+  | primRepIsWord from_rep+  , primRepIsInt to_rep+  = let (op1,r1) = wordToIntRep from_rep+    in (op1,primRepToType r1):sizedIntToSizedInt r1 to_rep++  -- Int* -> Word*+  | primRepIsInt from_rep+  , primRepIsWord to_rep+  = let (op1,r1) = intToWordRep from_rep+    in (op1,primRepToType r1):sizedWordToSizedWord r1 to_rep++  | otherwise = pprPanic "getCasts:Unexpect rep combination"+                          (ppr (from_rep,to_rep))++wordOrIntToAddrRep :: HasDebugCallStack => PrimRep -> [(PrimOp,Type)]+wordOrIntToAddrRep AddrRep = [] -- No-op argument is already AddrRep+wordOrIntToAddrRep IntRep = [(IntToAddrOp, addrPrimTy)]+wordOrIntToAddrRep WordRep = [(WordToIntOp,intPrimTy), (IntToAddrOp,addrPrimTy)]+wordOrIntToAddrRep r+    | primRepIsInt r = (intToMachineInt r,intPrimTy):[(IntToAddrOp,addrPrimTy)]+    | primRepIsWord r =+        let (op1,r1) = wordToIntRep r+        in (op1, primRepToType r1):[(intToMachineInt r1,intPrimTy), (IntToAddrOp,addrPrimTy)]+    | otherwise = pprPanic "Rep not word or int rep" (ppr r)++addrToWordOrIntRep :: HasDebugCallStack => PrimRep -> [(PrimOp,Type)]+-- Machine sizes+addrToWordOrIntRep IntRep = [(AddrToIntOp, intPrimTy)]+addrToWordOrIntRep WordRep = [(AddrToIntOp,intPrimTy), (IntToWordOp,wordPrimTy)]+-- Explicitly sized reps+addrToWordOrIntRep r+    | primRepIsWord r = (AddrToIntOp,intPrimTy) : (IntToWordOp,wordPrimTy) : sizedWordToSizedWord WordRep r+    | primRepIsInt r = (AddrToIntOp,intPrimTy) : sizedIntToSizedInt IntRep r+    | otherwise = pprPanic "Target rep not word or int rep" (ppr r)+++-- WordX# -> IntX# (same size), argument is source rep+wordToIntRep :: HasDebugCallStack => PrimRep -> (PrimOp,PrimRep)+wordToIntRep rep+    = case rep of+        (WordRep) -> (WordToIntOp, IntRep)+        (Word8Rep) -> (Word8ToInt8Op, Int8Rep)+        (Word16Rep) -> (Word16ToInt16Op, Int16Rep)+        (Word32Rep) -> (Word32ToInt32Op, Int32Rep)+        (Word64Rep) -> (Word64ToInt64Op, Int64Rep)+        _ -> pprPanic "Rep not a wordRep" (ppr rep)++-- IntX# -> WordX#, argument is source rep+intToWordRep :: HasDebugCallStack => PrimRep -> (PrimOp,PrimRep)+intToWordRep rep+    = case rep of+        (IntRep) -> (IntToWordOp, WordRep)+        (Int8Rep) -> (Int8ToWord8Op, Word8Rep)+        (Int16Rep) -> (Int16ToWord16Op, Word16Rep)+        (Int32Rep) -> (Int32ToWord32Op, Word32Rep)+        (Int64Rep) -> (Int64ToWord64Op, Word64Rep)+        _ -> pprPanic "Rep not a wordRep" (ppr rep)++-- Casts between any size int to any other size of int+sizedIntToSizedInt :: HasDebugCallStack => PrimRep -> PrimRep -> [(PrimOp,Type)]+sizedIntToSizedInt r1 r2+    | r1 == r2 = []+-- Cast to Int#+sizedIntToSizedInt r IntRep = [(intToMachineInt r,intPrimTy)]+-- Cast from Int#+sizedIntToSizedInt IntRep r = [(intFromMachineInt r,primRepToType r)]+-- Sized to differently sized must go over machine word.+sizedIntToSizedInt r1 r2 = (intToMachineInt r1,intPrimTy) : [(intFromMachineInt r2,primRepToType r2)]++-- Casts between any size Word to any other size of Word+sizedWordToSizedWord :: HasDebugCallStack => PrimRep -> PrimRep -> [(PrimOp,Type)]+sizedWordToSizedWord r1 r2+    | r1 == r2 = []+-- Cast to Word#+sizedWordToSizedWord r WordRep = [(wordToMachineWord r,wordPrimTy)]+-- Cast from Word#+sizedWordToSizedWord WordRep r = [(wordFromMachineWord r, primRepToType r)]+-- Conversion between different non-machine sizes must go via machine word.+sizedWordToSizedWord r1 r2 = (wordToMachineWord r1,wordPrimTy) : [(wordFromMachineWord r2, primRepToType r2)]+++-- Prefer the definitions above this line if possible+----------------------+++-- Int*# to Int#+{-# INLINE intToMachineInt #-}+intToMachineInt :: HasDebugCallStack => PrimRep -> PrimOp+intToMachineInt r =+    assertPpr (primRepIsInt r) (ppr r) $+    case r of+        (Int8Rep) -> Int8ToIntOp+        (Int16Rep) -> Int16ToIntOp+        (Int32Rep) -> Int32ToIntOp+        (Int64Rep) -> Int64ToIntOp+        _ -> pprPanic "Source rep not int" $ ppr r++-- Int# to Int*#+{-# INLINE intFromMachineInt #-}+intFromMachineInt :: HasDebugCallStack => PrimRep -> PrimOp+intFromMachineInt r =+    assertPpr (primRepIsInt r) (ppr r) $+    case r of+        Int8Rep -> IntToInt8Op+        Int16Rep -> IntToInt16Op+        Int32Rep -> IntToInt32Op+        Int64Rep -> IntToInt64Op+        _ -> pprPanic "Dest rep not sized int" $ ppr r++-- Word# to Word*#+{-# INLINE wordFromMachineWord #-}+wordFromMachineWord :: HasDebugCallStack => PrimRep -> PrimOp+wordFromMachineWord r =+    assert (primRepIsWord r) $+    case r of+        Word8Rep -> WordToWord8Op+        Word16Rep -> WordToWord16Op+        Word32Rep -> WordToWord32Op+        Word64Rep -> WordToWord64Op+        _ -> pprPanic "Dest rep not sized word" $ ppr r++-- Word*# to Word#+{-# INLINE wordToMachineWord #-}+wordToMachineWord :: HasDebugCallStack => PrimRep -> PrimOp+wordToMachineWord r =+    assertPpr (primRepIsWord r) (text "Not a word rep:" <> ppr r) $+    case r of+        Word8Rep -> Word8ToWordOp+        Word16Rep -> Word16ToWordOp+        Word32Rep -> Word32ToWordOp+        Word64Rep -> Word64ToWordOp+        _ -> pprPanic "Dest rep not sized word" $ ppr r
GHC/Builtin/PrimOps/Ids.hs view
@@ -1,3 +1,8 @@++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiWayIf #-}+ -- | PrimOp's Ids module GHC.Builtin.PrimOps.Ids   ( primOpId@@ -9,12 +14,15 @@  -- primop rules are attached to primop ids import {-# SOURCE #-} GHC.Core.Opt.ConstantFold (primOpRules)-import GHC.Core.Type (mkForAllTys, mkVisFunTysMany)+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@@ -23,11 +31,18 @@ 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 ( maybeToList ) +import Data.Maybe ( mapMaybe, listToMaybe, catMaybes, maybeToList ) + -- | Build a PrimOp Id mkPrimOpId :: PrimOp -> Id mkPrimOpId prim_op@@ -38,8 +53,10 @@     name = mkWiredInName gHC_PRIM (primOpOcc prim_op)                          (mkPrimOpIdUnique (primOpTag prim_op))                          (AnId id) UserSyntax-    id   = mkGlobalId (PrimOpId prim_op) name ty info+    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@@ -51,12 +68,90 @@            `setDmdSigInfo`         strict_sig            `setCprSigInfo`         mkCprSig arity cpr            `setInlinePragInfo`     neverInlinePragma-           `setLevityInfoWithType` res_ty                -- We give PrimOps a NOINLINE pragma so that we don't                -- get silly warnings from Desugar.dsRule (the inline_shadows_rule                -- test) about a RULE conflicting with a possible inlining                -- cf #7287 +-- | 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
GHC/Builtin/Types.hs view
@@ -5,2236 +5,2944 @@ -}  {-# LANGUAGE OverloadedStrings #-}--{-# 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_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_maybe,--        -- * 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,--        -- * NonEmpty-        nonEmptyTyCon, nonEmptyTyConName,-        nonEmptyDataCon, nonEmptyDataConName,--        -- * 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,-        pairTyCon, mkPromotedPairTy, isPromotedPairType,-        unboxedUnitTy,-        unboxedUnitTyCon, unboxedUnitDataCon,-        unboxedTupleKind, unboxedSumKind,-        filterCTuple,--        -- ** Constraint tuples-        cTupleTyCon, cTupleTyConName, cTupleTyConNames, isCTupleTyConName,-        cTupleTyConNameArity_maybe,-        cTupleDataCon, cTupleDataConName, cTupleDataConNames,-        cTupleSelId, cTupleSelIdName,--        -- * Any-        anyTyCon, anyTy, anyTypeOfKind,--        -- * Recovery TyCon-        makeRecoveryTyCon,--        -- * Sums-        mkSumTy, sumTyCon, sumDataCon,--        -- * Kinds-        typeSymbolKindCon, typeSymbolKind,-        isLiftedTypeKindTyConName,-        typeToTypeKind,-        liftedRepTyCon, unliftedRepTyCon,-        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, levityTyCon, vecCountTyCon, vecElemTyCon,--        boxedRepDataConTyCon,-        runtimeRepTy, levityTy, liftedRepTy, unliftedRepTy, zeroBitRepTy,--        vecRepDataConTyCon, tupleRepDataConTyCon, sumRepDataConTyCon,--        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-    ) 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.Coercion.Axiom-import GHC.Types.Id-import GHC.Types.TyThing-import GHC.Types.SourceText-import GHC.Types.Var (VarBndr (Bndr))-import GHC.Settings.Constants ( mAX_TUPLE_SIZE, mAX_CTUPLE_SIZE, mAX_SUM_SIZE )-import GHC.Unit.Module        ( Module )-import GHC.Core.Type-import qualified GHC.Core.TyCo.Rep as TyCoRep (Type(TyConApp))-import GHC.Types.RepType-import GHC.Core.DataCon-import GHC.Core.ConLike-import GHC.Core.TyCon-import GHC.Core.Class     ( Class, mkClass )-import GHC.Types.Name.Reader-import GHC.Types.Name as Name-import GHC.Types.Name.Env ( NameEnv, mkNameEnv, lookupNameEnv, lookupNameEnv_NF )-import GHC.Types.Basic-import GHC.Types.ForeignCall-import GHC.Types.Unique.Set-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 GHC.Utils.Panic.Plain--import qualified Data.ByteString.Char8 as BS--import Data.List        ( elemIndex, intersperse )--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.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, including boxed, unboxed and constraint tuples----       (mkTupleTyCon, unitTyCon, pairTyCon)---   * unboxed sums (sumTyCon)--- See Note [Infinite families of known-key names] in GHC.Builtin.Names------ See also Note [Known-key names]-wiredInTyCons :: [TyCon]--wiredInTyCons = [ -- Units are not treated like other tuples, because they-                  -- 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--                -- Solo (i.e., the bosed 1-tuple) is also not treated-                -- like other tuples (i.e. we /do/ include it here),-                -- since it does not use special syntax like other tuples-                -- See Note [One-tuples] (Wrinkle: Make boxed one-tuple names-                -- have known keys) in GHC.Builtin.Types.-                , soloTyCon--                , anyTyCon-                , boolTyCon-                , charTyCon-                , stringTyCon-                , doubleTyCon-                , floatTyCon-                , intTyCon-                , wordTyCon-                , listTyCon-                , orderingTyCon-                , maybeTyCon-                , heqTyCon-                , eqTyCon-                , coercibleTyCon-                , typeSymbolKindCon-                , runtimeRepTyCon-                , levityTyCon-                , vecCountTyCon-                , vecElemTyCon-                , constraintKindTyCon-                , liftedTypeKindTyCon-                , unliftedTypeKindTyCon-                , multiplicityTyCon-                , naturalTyCon-                , integerTyCon-                , liftedRepTyCon-                , unliftedRepTyCon-                , zeroBitRepTyCon-                , zeroBitTypeTyCon-                , nonEmptyTyCon-                ]--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_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   BuiltInSyntax gHC_TYPES (fsLit "[]") listTyConKey listTyCon-nilDataConName    = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit "[]") nilDataConKey nilDataCon-consDataConName   = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit ":") consDataConKey consDataCon--nonEmptyTyConName, nonEmptyDataConName :: Name-nonEmptyTyConName   = mkWiredInTyConName   UserSyntax  gHC_BASE (fsLit "NonEmpty") nonEmptyTyConKey nonEmptyTyCon-nonEmptyDataConName = mkWiredInDataConName UserSyntax  gHC_BASE (fsLit ":|") nonEmptyDataConKey nonEmptyDataCon--maybeTyConName, nothingDataConName, justDataConName :: Name-maybeTyConName     = mkWiredInTyConName   UserSyntax gHC_MAYBE (fsLit "Maybe")-                                          maybeTyConKey maybeTyCon-nothingDataConName = mkWiredInDataConName UserSyntax gHC_MAYBE (fsLit "Nothing")-                                          nothingDataConKey nothingDataCon-justDataConName    = mkWiredInDataConName UserSyntax gHC_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_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)--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]---- | 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--constraintKindTyConName :: Name-constraintKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Constraint") constraintKindTyConKey   constraintKindTyCon--liftedTypeKindTyConName, unliftedTypeKindTyConName, zeroBitTypeTyConName :: Name-liftedTypeKindTyConName   = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Type")         liftedTypeKindTyConKey   liftedTypeKindTyCon-unliftedTypeKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "UnliftedType") unliftedTypeKindTyConKey unliftedTypeKindTyCon-zeroBitTypeTyConName      = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "ZeroBitType")  zeroBitTypeTyConKey      zeroBitTypeTyCon--liftedRepTyConName, unliftedRepTyConName, zeroBitRepTyConName :: Name-liftedRepTyConName   = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "LiftedRep")   liftedRepTyConKey   liftedRepTyCon-unliftedRepTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "UnliftedRep") unliftedRepTyConKey unliftedRepTyCon-zeroBitRepTyConName  = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "ZeroBitRep")  zeroBitRepTyConKey  zeroBitRepTyCon--multiplicityTyConName :: Name-multiplicityTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Multiplicity")-                          multiplicityTyConKey multiplicityTyCon--oneDataConName, manyDataConName :: Name-oneDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "One") oneDataConKey oneDataCon-manyDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "Many") manyDataConKey manyDataCon--runtimeRepTyConName, vecRepDataConName, tupleRepDataConName, sumRepDataConName, boxedRepDataConName :: Name-runtimeRepTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "RuntimeRep") runtimeRepTyConKey runtimeRepTyCon-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-boxedRepDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "BoxedRep") boxedRepDataConKey boxedRepDataCon--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----- See Note [Wiring in RuntimeRep]-runtimeRepSimpleDataConNames :: [Name]-runtimeRepSimpleDataConNames-  = zipWith3Lazy mk_special_dc_name-      [ fsLit "IntRep"-      , fsLit "Int8Rep", fsLit "Int16Rep", fsLit "Int32Rep", fsLit "Int64Rep"-      , fsLit "WordRep"-      , fsLit "Word8Rep", fsLit "Word16Rep", fsLit "Word32Rep", 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--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 VisArg 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 = pcDataConW n univs (map linear tys)--pcDataConW :: Name -> [TyVar] -> [Scaled Type] -> TyCon -> DataCon-pcDataConW n univs tys = pcDataConWithFixity False n univs-                      []    -- no ex_tvs-                      univs -- the univs are precisely the user-written tyvars-                      tys--pcDataConWithFixity :: Bool      -- ^ declared infix?-                    -> Name      -- ^ datacon name-                    -> [TyVar]   -- ^ univ tyvars-                    -> [TyCoVar] -- ^ ex tycovars-                    -> [TyCoVar] -- ^ user-written tycovars-                    -> [Scaled 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] -> [TyCoVar] -> [TyCoVar]-                     -> [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 user_tyvars 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)-                []      -- No labelled fields-                tyvars ex_tyvars-                (mkTyVarBinders SpecifiedSpec user_tyvars)-                []      -- No equality spec-                []      -- No 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---- 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-                         [] [] [] (map linear arg_tys) tycon--{--************************************************************************-*                                                                      *-      Kinds-*                                                                      *-************************************************************************--}--typeSymbolKindCon :: TyCon--- data Symbol-typeSymbolKindCon = pcTyCon typeSymbolKindConName Nothing [] []--typeSymbolKind :: Kind-typeSymbolKind = mkTyConTy typeSymbolKindCon--constraintKindTyCon :: TyCon--- 'TyCon.isConstraintKindCon' assumes that this is an AlgTyCon!-constraintKindTyCon = pcTyCon constraintKindTyConName Nothing [] []--typeToTypeKind, constraintKind :: Kind-typeToTypeKind   = liftedTypeKind `mkVisFunTyMany` liftedTypeKind-constraintKind   = mkTyConTy constraintKindTyCon--{--************************************************************************-*                                                                      *-                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-    - Have a pretend DataCon, defined in GHC.Prim,-      but no actual declaration and no info table--* ConstraintTuples-    - A wired-in type.-    - 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 GHC.Tc.Instance.Class.matchCTuple-    - Currently just go up to 64; 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.-    - Unlike BoxedTuples and UnboxedTuples, which only wire-      in type constructors and data constructors, ConstraintTuples also wire in-      superclass selector functions. For instance, $p1(%,%) and $p2(%,%) are-      the selectors for the binary constraint tuple.--* 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.Iface.Env.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 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:  (,,)   (,,)#-  2-tuples:  (,)    (,)#-  1-tuples:  ??-  0-tuples:  ()     ()#--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 ()     = ()-  data Solo a = Solo a-  data (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`.--Note that there is *not* a unary constraint tuple, unlike for other forms of-tuples. See [Ignore unary constraint tuples] in GHC.Tc.Gen.HsType for more-details.--See also Note [Flattening one-tuples] in GHC.Core.Make and-Note [Don't flatten tuples from HsSyn] in GHC.Core.Make.---------- Wrinkle: Make boxed one-tuple names have known keys--------We make boxed one-tuple names have known keys so that `data Solo a = Solo a`,-defined in GHC.Tuple, will be used when one-tuples are spliced in through-Template Haskell. This program (from #18097) crucially relies on this:--  case $( tupE [ [| "ok" |] ] ) of Solo x -> putStrLn x--Unless Solo has a known key, the type of `$( tupE [ [| "ok" |] ] )` (an-ExplicitTuple of length 1) will not match the type of Solo (an ordinary-data constructor used in a pattern). Making Solo known-key allows GHC to make-this connection.--Unlike Solo, every other tuple is /not/ known-key-(see Note [Infinite families of known-key names] in GHC.Builtin.Names). The-main reason for this exception is that other tuples are written with special-syntax, and as a result, they are renamed using a special `isBuiltInOcc_maybe`-function (see Note [Built-in syntax and the OrigNameCache] in GHC.Types.Name.Cache).-In contrast, Solo is just an ordinary data type with no special syntax, so it-doesn't really make sense to handle it in `isBuiltInOcc_maybe`. Making Solo-known-key is the next-best way to teach the internals of the compiler about it.--}---- | 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--      -- function tycon-      "FUN"  -> Just funTyConName-      "->"  -> Just unrestrictedFunTyConName--      -- boxed tuple data/tycon-      -- We deliberately exclude Solo (the boxed 1-tuple).-      -- See Note [One-tuples] (Wrinkle: Make boxed one-tuple names have known keys)-      "()"    -> Just $ tup_name Boxed 0-      _ | Just rest <- "(" `BS.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-      "Solo#" -> Just $ tup_name Unboxed 1-      _ | Just rest <- "(#" `BS.stripPrefix` name-        , (commas, rest') <- BS.span (==',') rest-        , "#)" <- rest'-             -> Just $ tup_name Unboxed (1+BS.length commas)--      -- unboxed sum tycon-      _ | Just rest <- "(#" `BS.stripPrefix` name-        , (nb_pipes, rest') <- span_pipes rest-        , "#)" <- rest'-             -> Just $ tyConName $ sumTyCon (1+nb_pipes)--      -- unboxed sum datacon-      _ | Just rest <- "(#" `BS.stripPrefix` name-        , (nb_pipes1, rest') <- span_pipes rest-        , Just rest'' <- "_" `BS.stripPrefix` rest'-        , (nb_pipes2, rest''') <- span_pipes rest''-        , "#)" <- rest'''-             -> let arity = nb_pipes1 + nb_pipes2 + 1-                    alt = nb_pipes1 + 1-                in Just $ dataConName $ sumDataCon alt arity-      _ -> Nothing-  where-    name = bytesFS $ occNameFS occ--    span_pipes :: BS.ByteString -> (Int, BS.ByteString)-    span_pipes = go 0-      where-        go nb_pipes bs = case BS.uncons bs of-          Just ('|',rest) -> go (nb_pipes + 1) rest-          Just (' ',rest) -> go nb_pipes       rest-          _               -> (nb_pipes, bs)--    choose_ns :: Name -> Name -> Name-    choose_ns tc dc-      | isTcClsNameSpace ns   = tc-      | 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)--mkTupleStr :: Boxity -> Arity -> String-mkTupleStr Boxed   = mkBoxedTupleStr-mkTupleStr Unboxed = mkUnboxedTupleStr--mkBoxedTupleStr :: Arity -> String-mkBoxedTupleStr 0  = "()"-mkBoxedTupleStr 1  = "Solo"   -- See Note [One-tuples]-mkBoxedTupleStr ar = '(' : commas ar ++ ")"--mkUnboxedTupleStr :: Arity -> String-mkUnboxedTupleStr 0  = "(##)"-mkUnboxedTupleStr 1  = "Solo#"  -- See Note [One-tuples]-mkUnboxedTupleStr ar = "(#" ++ commas ar ++ "#)"--mkConstraintTupleStr :: Arity -> String-mkConstraintTupleStr 0  = "(%%)"-mkConstraintTupleStr 1  = "Solo%"   -- See Note [One-tuples]-mkConstraintTupleStr ar = "(%" ++ commas ar ++ "%)"--commas :: Arity -> String-commas ar = take (ar-1) (repeat ',')--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 :: UniqSet Unique-cTupleTyConKeys = mkUniqSet $ map getUnique cTupleTyConNames--isCTupleTyConName :: Name -> Bool-isCTupleTyConName n- = assertPpr (isExternalName n) (ppr n) $-   getUnique n `elementOfUniqSet` cTupleTyConKeys---- | If the given name is that of a constraint tuple, return its arity.-cTupleTyConNameArity_maybe :: Name -> Maybe Arity-cTupleTyConNameArity_maybe n-  | not (isCTupleTyConName n) = Nothing-  | otherwise = fmap adjustArity (n `elemIndex` cTupleTyConNames)-  where-    -- Since `cTupleTyConNames` jumps straight from the `0` to the `2`-    -- case, we have to adjust accordingly our calculated arity.-    adjustArity a = if a > 0 then a + 1 else a--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 < 2-  = panic ("cTupleSelId: Arity starts from 2. "-           ++ "(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]]-  -- Although GHC does not make use of unary constraint tuples-  -- (see Note [Ignore unary constraint tuples] in GHC.Tc.Gen.HsType),-  -- this array creates one anyway. This is primarily motivated by the fact-  -- that (1) the indices of an Array must be contiguous, and (2) we would like-  -- the index of a constraint tuple in this Array to correspond to its Arity.-  -- We could envision skipping over the unary constraint tuple and having index-  -- 1 correspond to a 2-constraint tuple (and so on), but that's more-  -- complicated than it's worth.---- | 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 tc_arity tuple_con-                         BoxedTuple flavour--    tc_binders  = mkTemplateAnonTyConBinders (replicate 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 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--    tc_arity    = arity * 2-    flavour     = VanillaAlgTyCon (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--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 = pcDataConW dc_name tvs (map unrestricted 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) BuiltInSyntax-    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--unitTyConKey :: Unique-unitTyConKey = getUnique unitTyCon--unitDataCon :: DataCon-unitDataCon   = head (tyConDataCons unitTyCon)--unitDataConId :: Id-unitDataConId = dataConWorkId unitDataCon--soloTyCon :: TyCon-soloTyCon = tupleTyCon Boxed 1--pairTyCon :: TyCon-pairTyCon = tupleTyCon Boxed 2--unboxedUnitTy :: Type-unboxedUnitTy = mkTyConTy unboxedUnitTyCon--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 = intersperse ' ' $ replicate (n-1) '|'---- | OccName for i-th alternative of n-ary unboxed sum data constructor.-mkSumDataConOcc :: ConTag -> Arity -> OccName-mkSumDataConOcc alt n = mkOccName dataName str-  where-    -- No need to cache these, the caching is done in mk_sum-    str = '(' : '#' : ' ' : bars alt ++ '_' : bars (n - alt - 1) ++ " #)"-    bars i = 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)---- | 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)-                         UnboxedSumTyCon--    tc_binders = mkTemplateTyConBinders (replicate arity runtimeRepTy)-                                        (\ks -> map mkTYPEapp 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 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   = pcDataConW eqDataConName tvs [unrestricted sc_pred] tycon--    -- Kind: forall k. k -> k -> Constraint-    binders   = mkTemplateTyConBinders [liftedTypeKind] (\[k] -> [k,k])-    roles     = [Nominal, Nominal, Nominal]-    rhs       = mkDataTyConRhs [datacon]--    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   = pcDataConW heqDataConName tvs [unrestricted 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   = pcDataConW coercibleDataConName tvs [unrestricted 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--}--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]--unrestrictedFunTy :: Type-unrestrictedFunTy = functionWithMultiplicity manyDataConTy--unrestrictedFunTyCon :: TyCon-unrestrictedFunTyCon = buildSynTyCon unrestrictedFunTyConName [] arrowKind [] unrestrictedFunTy-  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 Type         = TYPE LiftedRep    -- liftedTypeKind-         type UnliftedType = TYPE UnliftedRep  -- unliftedTypeKind-         type LiftedRep    = BoxedRep Lifted   -- liftedRepTy-         type UnliftedRep  = BoxedRep Unlifted -- unliftedRepTy--*                                                                      *-********************************************************************* -}---- For these synonyms, see--- Note [TYPE and RuntimeRep] in GHC.Builtin.Types.Prim, and--- Note [Using synonyms to compress types] in GHC.Core.Type--------------------------- @type Type = TYPE ('BoxedRep 'Lifted)@-liftedTypeKindTyCon :: TyCon-liftedTypeKindTyCon-  = buildSynTyCon liftedTypeKindTyConName [] liftedTypeKind [] rhs-  where-    rhs = TyCoRep.TyConApp tYPETyCon [liftedRepTy]--liftedTypeKind :: Type-liftedTypeKind = mkTyConTy liftedTypeKindTyCon--------------------------- | @type UnliftedType = TYPE ('BoxedRep 'Unlifted)@-unliftedTypeKindTyCon :: TyCon-unliftedTypeKindTyCon-  = buildSynTyCon unliftedTypeKindTyConName [] liftedTypeKind [] rhs-  where-    rhs = TyCoRep.TyConApp tYPETyCon [unliftedRepTy]--unliftedTypeKind :: Type-unliftedTypeKind = mkTyConTy unliftedTypeKindTyCon--------------------------- @type ZeroBitType = TYPE ZeroBitRep-zeroBitTypeTyCon :: TyCon-zeroBitTypeTyCon-  = buildSynTyCon zeroBitTypeTyConName [] liftedTypeKind [] rhs-  where-    rhs = TyCoRep.TyConApp tYPETyCon [zeroBitRepTy]--zeroBitTypeKind :: Type-zeroBitTypeKind = mkTyConTy zeroBitTypeTyCon--------------------------- | @type LiftedRep = 'BoxedRep 'Lifted@-liftedRepTyCon :: TyCon-liftedRepTyCon-  = buildSynTyCon liftedRepTyConName [] runtimeRepTy [] rhs-  where-    rhs = TyCoRep.TyConApp boxedRepDataConTyCon [liftedDataConTy]--liftedRepTy :: Type-liftedRepTy = mkTyConTy liftedRepTyCon--------------------------- | @type UnliftedRep = 'BoxedRep 'Unlifted@-unliftedRepTyCon :: TyCon-unliftedRepTyCon-  = buildSynTyCon unliftedRepTyConName [] runtimeRepTy [] rhs-  where-    rhs = TyCoRep.TyConApp boxedRepDataConTyCon [unliftedDataConTy]--unliftedRepTy :: Type-unliftedRepTy = mkTyConTy unliftedRepTyCon--------------------------- | @type ZeroBitRep = 'Tuple '[]-zeroBitRepTyCon :: TyCon-zeroBitRepTyCon-  = buildSynTyCon zeroBitRepTyConName [] runtimeRepTy [] rhs-  where-    rhs = TyCoRep.TyConApp tupleRepDataConTyCon [mkPromotedListTy runtimeRepTy []]--zeroBitRepTy :: Type-zeroBitRepTy = mkTyConTy zeroBitRepTyCon---{- *********************************************************************-*                                                                      *-      data Levity = Lifted | Unlifted-*                                                                      *-********************************************************************* -}--levityTyCon :: TyCon-levityTyCon = pcTyCon levityTyConName Nothing [] [liftedDataCon,unliftedDataCon]--levityTy :: Type-levityTy = mkTyConTy levityTyCon--liftedDataCon, unliftedDataCon :: DataCon-liftedDataCon = pcSpecialDataCon liftedDataConName-    [] levityTyCon LiftedInfo-unliftedDataCon = pcSpecialDataCon unliftedDataConName-    [] levityTyCon UnliftedInfo--liftedDataConTyCon :: TyCon-liftedDataConTyCon = promoteDataCon liftedDataCon--unliftedDataConTyCon :: TyCon-unliftedDataConTyCon = promoteDataCon unliftedDataCon--liftedDataConTy :: Type-liftedDataConTy = mkTyConTy liftedDataConTyCon--unliftedDataConTy :: Type-unliftedDataConTy = mkTyConTy unliftedDataConTyCon---{- *********************************************************************-*                                                                      *-    See Note [Wiring in RuntimeRep]-        data RuntimeRep = VecRep VecCount VecElem-                        | TupleRep [RuntimeRep]-                        | SumRep [RuntimeRep]-                        | BoxedRep Levity-                        | IntRep | Int8Rep | ...etc...-*                                                                      *-********************************************************************* -}--{- Note [Wiring in RuntimeRep]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The RuntimeRep type (and friends) in GHC.Types has a bunch of constructors,-making it a pain to wire in. To ease the pain somewhat, we use lists of-the different bits, like Uniques, Names, DataCons. These lists must be-kept in sync with each other. The rule is this: use the order as declared-in GHC.Types. All places where such lists exist should contain a reference-to this Note, so a search for this Note's name should find all the lists.--See also Note [Getting from RuntimeRep to PrimRep] in GHC.Types.RepType.--}--runtimeRepTyCon :: TyCon-runtimeRepTyCon = pcTyCon runtimeRepTyConName Nothing []-    (vecRepDataCon : tupleRepDataCon :-     sumRepDataCon : boxedRepDataCon : runtimeRepSimpleDataCons)--runtimeRepTy :: Type-runtimeRepTy = mkTyConTy runtimeRepTyCon--boxedRepDataCon :: DataCon-boxedRepDataCon = pcSpecialDataCon boxedRepDataConName-  [ levityTy ] runtimeRepTyCon (RuntimeRep prim_rep_fun)-  where-    -- See Note [Getting from RuntimeRep to PrimRep] in RepType-    prim_rep_fun [lev]-      = case tyConRuntimeRepInfo (tyConAppTyCon lev) of-          LiftedInfo -> [LiftedRep]-          UnliftedInfo -> [UnliftedRep]-          _ -> pprPanic "boxedRepDataCon" (ppr lev)-    prim_rep_fun args-      = pprPanic "boxedRepDataCon" (ppr args)---boxedRepDataConTyCon :: TyCon-boxedRepDataConTyCon = promoteDataCon boxedRepDataCon--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 <- 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-    -- 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 (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-  = zipWithLazy mk_runtime_rep_dc-    [ IntRep-    , Int8Rep, Int16Rep, Int32Rep, Int64Rep-    , WordRep-    , Word8Rep, Word16Rep, Word32Rep, Word64Rep-    , AddrRep-    , FloatRep, DoubleRep-    ]-    runtimeRepSimpleDataConNames-  where-    mk_runtime_rep_dc primrep name-      = pcSpecialDataCon name [] runtimeRepTyCon (RuntimeRep (\_ -> [primrep]))---- See Note [Wiring in RuntimeRep]-intRepDataConTy,-  int8RepDataConTy, int16RepDataConTy, int32RepDataConTy, int64RepDataConTy,-  wordRepDataConTy,-  word8RepDataConTy, word16RepDataConTy, word32RepDataConTy, word64RepDataConTy,-  addrRepDataConTy,-  floatRepDataConTy, doubleRepDataConTy :: Type-[intRepDataConTy,-   int8RepDataConTy, int16RepDataConTy, int32RepDataConTy, int64RepDataConTy,-   wordRepDataConTy,-   word8RepDataConTy, word16RepDataConTy, word32RepDataConTy, word64RepDataConTy,-   addrRepDataConTy,-   floatRepDataConTy, doubleRepDataConTy-   ]-  = map (mkTyConTy . promoteDataCon) runtimeRepSimpleDataCons--vecCountTyCon :: TyCon-vecCountTyCon = pcTyCon 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 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--{- *********************************************************************-*                                                                      *-     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, Float, 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   = 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--{--************************************************************************-*                                                                      *-              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 [] 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)---- NonEmpty lists (used for 'ProjectionE')-nonEmptyTyCon :: TyCon-nonEmptyTyCon = pcTyCon nonEmptyTyConName Nothing [alphaTyVar] [nonEmptyDataCon]--nonEmptyDataCon :: DataCon-nonEmptyDataCon = pcDataConWithFixity True {- Declared infix -}-                    nonEmptyDataConName-                    alpha_tyvar [] alpha_tyvar-                    (map linear [alphaTy, mkTyConApp listTyCon alpha_ty])-                    nonEmptyTyCon---- 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 []--{- *********************************************************************-*                                                                      *-            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_NUM_INTEGER-      (fsLit "Integer")-      integerTyConKey-      integerTyCon-integerISDataConName-   = mkWiredInDataConName-      UserSyntax-      gHC_NUM_INTEGER-      (fsLit "IS")-      integerISDataConKey-      integerISDataCon-integerIPDataConName-   = mkWiredInDataConName-      UserSyntax-      gHC_NUM_INTEGER-      (fsLit "IP")-      integerIPDataConKey-      integerIPDataCon-integerINDataConName-   = mkWiredInDataConName-      UserSyntax-      gHC_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_NUM_NATURAL-      (fsLit "Natural")-      naturalTyConKey-      naturalTyCon-naturalNSDataConName-   = mkWiredInDataConName-      UserSyntax-      gHC_NUM_NATURAL-      (fsLit "NS")-      naturalNSDataConKey-      naturalNSDataCon-naturalNBDataConName-   = mkWiredInDataConName-      UserSyntax-      gHC_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----- | Replaces constraint tuple names with corresponding boxed ones.-filterCTuple :: RdrName -> RdrName-filterCTuple (Exact n)-  | Just arity <- cTupleTyConNameArity_maybe n-  = Exact $ tupleTyConName BoxedTuple arity-filterCTuple rdr = rdr+{-# LANGUAGE ParallelListComp #-}+{-# LANGUAGE MultiWayIf #-}++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++-- | This module is about types that can be defined in Haskell, but which+--   must be wired into the compiler nonetheless.  C.f module "GHC.Builtin.Types.Prim"+module GHC.Builtin.Types (+        -- * Helper functions defined here+        mkWiredInTyConName, -- This is used in GHC.Builtin.Types.Literals to define the+                            -- built-in functions for evaluation.++        mkWiredInIdName,    -- used in GHC.Types.Id.Make++        -- * All wired in things+        wiredInTyCons, isBuiltInOcc, isBuiltInOcc_maybe,+        isTupleTyOrigName_maybe, isSumTyOrigName_maybe,+        isInfiniteFamilyOrigName_maybe,++        -- * Bool+        boolTy, boolTyCon, boolTyCon_RDR, boolTyConName,+        trueDataCon,  trueDataConId,  true_RDR,+        falseDataCon, falseDataConId, false_RDR,+        promotedFalseDataCon, promotedTrueDataCon,++        -- * Ordering+        orderingTyCon,+        ordLTDataCon, ordLTDataConId,+        ordEQDataCon, ordEQDataConId,+        ordGTDataCon, ordGTDataConId,+        promotedLTDataCon, promotedEQDataCon, promotedGTDataCon,++        -- * Boxing primitive types+        boxingDataCon, BoxingInfo(..),++        -- * Char+        charTyCon, charDataCon, charTyCon_RDR,+        charTy, stringTy, charTyConName, stringTyCon_RDR,++        -- * Double+        doubleTyCon, doubleDataCon, doubleTy, doubleTyConName,++        -- * Float+        floatTyCon, floatDataCon, floatTy, floatTyConName,++        -- * Int+        intTyCon, intDataCon, intTyCon_RDR, intDataCon_RDR, intTyConName,+        intTy,++        -- * Word+        wordTyCon, wordDataCon, wordTyConName, wordTy,++        -- * Word8+        word8TyCon, word8DataCon, word8Ty,++        -- * List+        listTyCon, listTyCon_RDR, listTyConName, listTyConKey,+        nilDataCon, nilDataConName, nilDataConKey,+        consDataCon_RDR, consDataCon, consDataConName,+        promotedNilDataCon, promotedConsDataCon,+        mkListTy, mkPromotedListTy, extractPromotedList,++        -- * Maybe+        maybeTyCon, maybeTyConName,+        nothingDataCon, nothingDataConName, promotedNothingDataCon,+        justDataCon, justDataConName, promotedJustDataCon,+        mkPromotedMaybeTy, mkMaybeTy, isPromotedMaybeTy,++        -- * Tuples+        mkTupleTy, mkTupleTy1, mkBoxedTupleTy, mkTupleStr,+        tupleTyCon, tupleDataCon, tupleTyConName, tupleDataConName,+        promotedTupleDataCon,+        unitTyCon, unitDataCon, unitDataConId, unitTy, unitTyConKey,+        soloTyCon,+        soloDataConName,+        pairTyCon, mkPromotedPairTy, isPromotedPairType,+        unboxedUnitTy,+        unboxedUnitTyCon, unboxedUnitDataCon,+        unboxedSoloTyCon, unboxedSoloTyConName, unboxedSoloDataConName,+        unboxedTupleKind, unboxedSumKind,+        mkConstraintTupleTy,++        -- ** Constraint tuples+        cTupleTyCon, cTupleTyConName, cTupleTyConNames, isCTupleTyConName,+        cTupleDataCon, cTupleDataConName, cTupleDataConNames,+        cTupleSelId, cTupleSelIdName,++        -- * Any+        anyTyCon, anyTy, anyTypeOfKind, zonkAnyTyCon,++        -- * Recovery TyCon+        makeRecoveryTyCon,++        -- * Sums+        mkSumTy, sumTyCon, sumDataCon,+        unboxedSumTyConName, unboxedSumDataConName,++        -- * Kinds+        typeSymbolKindCon, typeSymbolKind,+        isLiftedTypeKindTyConName,+        typeToTypeKind,+        liftedRepTyCon, unliftedRepTyCon,+        tYPETyCon, tYPETyConName, tYPEKind,+        cONSTRAINTTyCon, cONSTRAINTTyConName, cONSTRAINTKind,+        constraintKind, liftedTypeKind, unliftedTypeKind, zeroBitTypeKind,+        constraintKindTyCon, liftedTypeKindTyCon, unliftedTypeKindTyCon,+        constraintKindTyConName, liftedTypeKindTyConName, unliftedTypeKindTyConName,+        liftedRepTyConName, unliftedRepTyConName,++        -- * Equality predicates+        heqTyCon, heqTyConName, heqClass, heqDataCon,+        eqTyCon, eqTyConName, eqClass, eqDataCon, eqTyCon_RDR,+        coercibleTyCon, coercibleTyConName, coercibleDataCon, coercibleClass,++        -- * RuntimeRep and friends+        runtimeRepTyCon, vecCountTyCon, vecElemTyCon,++        boxedRepDataConTyCon,+        runtimeRepTy, liftedRepTy, unliftedRepTy, zeroBitRepTy,++        vecRepDataConTyCon, tupleRepDataConTyCon, sumRepDataConTyCon,++        -- * Levity+        levityTyCon, levityTy,+        liftedDataConTyCon, unliftedDataConTyCon,+        liftedDataConTy,    unliftedDataConTy,++        intRepDataConTy,+        int8RepDataConTy, int16RepDataConTy, int32RepDataConTy, int64RepDataConTy,+        wordRepDataConTy,+        word8RepDataConTy, word16RepDataConTy, word32RepDataConTy, word64RepDataConTy,+        addrRepDataConTy,+        floatRepDataConTy, doubleRepDataConTy,++        vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy,+        vec64DataConTy,++        int8ElemRepDataConTy, int16ElemRepDataConTy, int32ElemRepDataConTy,+        int64ElemRepDataConTy, word8ElemRepDataConTy, word16ElemRepDataConTy,+        word32ElemRepDataConTy, word64ElemRepDataConTy, floatElemRepDataConTy,++        doubleElemRepDataConTy,++        -- * Multiplicity and friends+        multiplicityTyConName, oneDataConName, manyDataConName, multiplicityTy,+        multiplicityTyCon, oneDataCon, manyDataCon, oneDataConTy, manyDataConTy,+        oneDataConTyCon, manyDataConTyCon,+        multMulTyCon,++        unrestrictedFunTyCon, unrestrictedFunTyConName,++        -- * Bignum+        integerTy, integerTyCon, integerTyConName,+        integerISDataCon, integerISDataConName,+        integerIPDataCon, integerIPDataConName,+        integerINDataCon, integerINDataConName,+        naturalTy, naturalTyCon, naturalTyConName,+        naturalNSDataCon, naturalNSDataConName,+        naturalNBDataCon, naturalNBDataConName,++         pretendNameIsInScope,+    ) where++import GHC.Prelude++import {-# SOURCE #-} GHC.Types.Id.Make ( mkDataConWorkId, mkDictSelId )++-- friends:+import GHC.Builtin.Names+import GHC.Builtin.Types.Prim+import GHC.Builtin.Uniques++-- others:+import GHC.Core( Expr(Type), mkConApp )+import GHC.Core.Coercion.Axiom+import GHC.Core.Type+import GHC.Types.Id+import GHC.Core.DataCon+import GHC.Core.ConLike+import GHC.Core.TyCon+import GHC.Core.Class     ( Class, mkClass )+import GHC.Core.Map.Type  ( TypeMap, emptyTypeMap, extendTypeMap, lookupTypeMap )+import qualified GHC.Core.TyCo.Rep as TyCoRep ( Type(TyConApp) )++import GHC.Types.TyThing+import GHC.Types.SourceText+import GHC.Types.Var ( VarBndr (Bndr), tyVarName )+import GHC.Types.RepType+import GHC.Types.Name.Reader+import GHC.Types.Name as Name+import GHC.Types.Name.Env ( lookupNameEnv_NF, mkNameEnv )+import GHC.Types.Basic+import GHC.Types.ForeignCall+import GHC.Types.Unique.Set++import {-# SOURCE #-} GHC.Tc.Types.Origin+  ( FixedRuntimeRepOrigin(..), mkFRRUnboxedTuple, mkFRRUnboxedSum )+import {-# SOURCE #-} GHC.Tc.Utils.TcType+  ( ConcreteTvOrigin(..), ConcreteTyVars, noConcreteTyVars )++import GHC.Settings.Constants ( mAX_TUPLE_SIZE, mAX_CTUPLE_SIZE, mAX_SUM_SIZE )+import GHC.Unit.Module        ( Module )++import Data.Maybe+import Data.Array+import GHC.Data.FastString+import GHC.Data.BooleanFormula ( mkAnd )++import GHC.Utils.Outputable+import GHC.Utils.Misc+import GHC.Utils.Panic++import qualified Data.ByteString.Short as SBS+import qualified Data.ByteString.Short.Internal as SBS (unsafeIndex)++import Data.Foldable+import Data.List        ( intersperse )+import Numeric          ( showInt )++import Data.Word (Word8)+import Control.Applicative ((<|>))++alpha_tyvar :: [TyVar]+alpha_tyvar = [alphaTyVar]++alpha_ty :: [Type]+alpha_ty = [alphaTy]++{-+Note [Wired-in Types and Type Constructors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++This module include a lot of wired-in types and type constructors. Here,+these are presented in a tabular format to make it easier to find the+wired-in type identifier corresponding to a known Haskell type. Data+constructors are nested under their corresponding types with two spaces+of indentation.++Identifier              Type    Haskell name          Notes+----------------------------------------------------------------------------+liftedTypeKindTyCon     TyCon   GHC.Types.Type        Synonym for: TYPE LiftedRep+unliftedTypeKindTyCon   TyCon   GHC.Types.Type        Synonym for: TYPE UnliftedRep+liftedRepTyCon          TyCon   GHC.Types.LiftedRep   Synonym for: 'BoxedRep 'Lifted+unliftedRepTyCon        TyCon   GHC.Types.LiftedRep   Synonym for: 'BoxedRep 'Unlifted+levityTyCon             TyCon   GHC.Types.Levity      Data type+  liftedDataConTyCon    TyCon   GHC.Types.Lifted      Data constructor+  unliftedDataConTyCon  TyCon   GHC.Types.Unlifted    Data constructor+vecCountTyCon           TyCon   GHC.Types.VecCount    Data type+  vec2DataConTy         Type    GHC.Types.Vec2        Data constructor+  vec4DataConTy         Type    GHC.Types.Vec4        Data constructor+  vec8DataConTy         Type    GHC.Types.Vec8        Data constructor+  vec16DataConTy        Type    GHC.Types.Vec16       Data constructor+  vec32DataConTy        Type    GHC.Types.Vec32       Data constructor+  vec64DataConTy        Type    GHC.Types.Vec64       Data constructor+runtimeRepTyCon         TyCon   GHC.Types.RuntimeRep  Data type+  boxedRepDataConTyCon  TyCon   GHC.Types.BoxedRep    Data constructor+  intRepDataConTy       Type    GHC.Types.IntRep      Data constructor+  doubleRepDataConTy    Type    GHC.Types.DoubleRep   Data constructor+  floatRepDataConTy     Type    GHC.Types.FloatRep    Data constructor+boolTyCon               TyCon   GHC.Types.Bool        Data type+  trueDataCon           DataCon GHC.Types.True        Data constructor+  falseDataCon          DataCon GHC.Types.False       Data constructor+  promotedTrueDataCon   TyCon   GHC.Types.True        Data constructor+  promotedFalseDataCon  TyCon   GHC.Types.False       Data constructor++************************************************************************+*                                                                      *+\subsection{Wired in type constructors}+*                                                                      *+************************************************************************++If you change which things are wired in, make sure you change their+names in GHC.Builtin.Names, so they use wTcQual, wDataQual, etc++-}+++-- This list is used only to define GHC.Builtin.Utils.knownKeyNames. That in turn+-- is used to initialise the name environment carried around by the renamer.+-- This means that if we look up the name of a TyCon (or its implicit binders)+-- that occurs in this list that name will be assigned the wired-in key we+-- define here.+--+-- Because of their infinite nature, this list excludes+--   * Tuples of all sorts (boxed, unboxed, constraint) (mkTupleTyCon)+--   * Unboxed sums (sumTyCon)+-- See Note [Infinite families of known-key names] in GHC.Builtin.Names+--+-- See also Note [Known-key names]+wiredInTyCons :: [TyCon]++wiredInTyCons = map (dataConTyCon . snd) boxingDataCons+             ++ [ anyTyCon+                , zonkAnyTyCon+                , boolTyCon+                , charTyCon+                , stringTyCon+                , doubleTyCon+                , floatTyCon+                , intTyCon+                , wordTyCon+                , listTyCon+                , orderingTyCon+                , maybeTyCon+                , heqTyCon+                , eqTyCon+                , coercibleTyCon+                , typeSymbolKindCon+                , runtimeRepTyCon+                , levityTyCon+                , vecCountTyCon+                , vecElemTyCon+                , constraintKindTyCon+                , liftedTypeKindTyCon+                , unliftedTypeKindTyCon+                , unrestrictedFunTyCon+                , multiplicityTyCon+                , naturalTyCon+                , integerTyCon+                , liftedRepTyCon+                , unliftedRepTyCon+                , zeroBitRepTyCon+                , zeroBitTypeTyCon+                ]++mkWiredInTyConName :: BuiltInSyntax -> Module -> FastString -> Unique -> TyCon -> Name+mkWiredInTyConName built_in modu fs unique tycon+  = mkWiredInName modu (mkTcOccFS fs) unique+                  (ATyCon tycon)        -- Relevant TyCon+                  built_in++mkWiredInDataConName :: BuiltInSyntax -> Module -> FastString -> Unique -> DataCon -> Name+mkWiredInDataConName built_in modu fs unique datacon+  = mkWiredInName modu (mkDataOccFS fs) unique+                  (AConLike (RealDataCon datacon))    -- Relevant DataCon+                  built_in++mkWiredInIdName :: Module -> FastString -> Unique -> Id -> Name+mkWiredInIdName mod fs uniq id+ = mkWiredInName mod (mkOccNameFS Name.varName fs) uniq (AnId id) UserSyntax++-- See Note [Kind-changing of (~) and Coercible]+-- in libraries/ghc-prim/GHC/Types.hs+eqTyConName, eqDataConName, eqSCSelIdName :: Name+eqTyConName   = mkWiredInTyConName   UserSyntax gHC_TYPES (fsLit "~")   eqTyConKey   eqTyCon+eqDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "Eq#") eqDataConKey eqDataCon+eqSCSelIdName = mkWiredInIdName gHC_TYPES (fsLit "eq_sel") eqSCSelIdKey eqSCSelId++eqTyCon_RDR :: RdrName+eqTyCon_RDR = nameRdrName eqTyConName++-- See Note [Kind-changing of (~) and Coercible]+-- in libraries/ghc-prim/GHC/Types.hs+heqTyConName, heqDataConName, heqSCSelIdName :: Name+heqTyConName   = mkWiredInTyConName   UserSyntax gHC_TYPES (fsLit "~~")   heqTyConKey      heqTyCon+heqDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "HEq#") heqDataConKey heqDataCon+heqSCSelIdName = mkWiredInIdName gHC_TYPES (fsLit "heq_sel") heqSCSelIdKey heqSCSelId++-- See Note [Kind-changing of (~) and Coercible] in libraries/ghc-prim/GHC/Types.hs+coercibleTyConName, coercibleDataConName, coercibleSCSelIdName :: Name+coercibleTyConName   = mkWiredInTyConName   UserSyntax gHC_TYPES (fsLit "Coercible")  coercibleTyConKey   coercibleTyCon+coercibleDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "MkCoercible") coercibleDataConKey coercibleDataCon+coercibleSCSelIdName = mkWiredInIdName gHC_TYPES (fsLit "coercible_sel") coercibleSCSelIdKey coercibleSCSelId++charTyConName, charDataConName, intTyConName, intDataConName, stringTyConName :: Name+charTyConName     = mkWiredInTyConName   UserSyntax gHC_TYPES (fsLit "Char")   charTyConKey charTyCon+charDataConName   = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "C#")     charDataConKey charDataCon+stringTyConName   = mkWiredInTyConName   UserSyntax gHC_INTERNAL_BASE  (fsLit "String") stringTyConKey stringTyCon+intTyConName      = mkWiredInTyConName   UserSyntax gHC_TYPES (fsLit "Int")    intTyConKey   intTyCon+intDataConName    = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "I#")     intDataConKey  intDataCon++boolTyConName, falseDataConName, trueDataConName :: Name+boolTyConName     = mkWiredInTyConName   UserSyntax gHC_TYPES (fsLit "Bool") boolTyConKey boolTyCon+falseDataConName  = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "False") falseDataConKey falseDataCon+trueDataConName   = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "True")  trueDataConKey  trueDataCon++listTyConName, nilDataConName, consDataConName :: Name+listTyConName     = mkWiredInTyConName   UserSyntax    gHC_TYPES (fsLit "List") listTyConKey listTyCon+nilDataConName    = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit "[]") nilDataConKey nilDataCon+consDataConName   = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit ":") consDataConKey consDataCon++maybeTyConName, nothingDataConName, justDataConName :: Name+maybeTyConName     = mkWiredInTyConName   UserSyntax gHC_INTERNAL_MAYBE (fsLit "Maybe")+                                          maybeTyConKey maybeTyCon+nothingDataConName = mkWiredInDataConName UserSyntax gHC_INTERNAL_MAYBE (fsLit "Nothing")+                                          nothingDataConKey nothingDataCon+justDataConName    = mkWiredInDataConName UserSyntax gHC_INTERNAL_MAYBE (fsLit "Just")+                                          justDataConKey justDataCon++wordTyConName, wordDataConName, word8DataConName :: Name+wordTyConName      = mkWiredInTyConName   UserSyntax gHC_TYPES (fsLit "Word")   wordTyConKey     wordTyCon+wordDataConName    = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "W#")     wordDataConKey   wordDataCon+word8DataConName   = mkWiredInDataConName UserSyntax gHC_INTERNAL_WORD  (fsLit "W8#")    word8DataConKey  word8DataCon++floatTyConName, floatDataConName, doubleTyConName, doubleDataConName :: Name+floatTyConName     = mkWiredInTyConName   UserSyntax gHC_TYPES (fsLit "Float")  floatTyConKey    floatTyCon+floatDataConName   = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "F#")     floatDataConKey  floatDataCon+doubleTyConName    = mkWiredInTyConName   UserSyntax gHC_TYPES (fsLit "Double") doubleTyConKey   doubleTyCon+doubleDataConName  = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "D#")     doubleDataConKey doubleDataCon++-- Any++{-+Note [Any types]+~~~~~~~~~~~~~~~~+The type constructors `Any` and `ZonkAny` are closed type families declared thus:++    type family Any     :: forall k.        k where { }+    type family ZonkAny :: forall k. Nat -> k where { }++They are used when we want a type of a particular kind, but we don't really care+what that type is.  The leading example is this: `ZonkAny` is used to instantiate+un-constrained type variables after type checking. For example, consider the+term (length [] :: Int), where++  length :: forall a. [a] -> Int+  []     :: forall a. [a]++We must type-apply `length` and `[]`, but to what type? It doesn't matter!+The typechecker will end up with++  length @alpha ([] @alpha)++where `alpha` is an un-constrained unification variable.  The "zonking" process zaps+that unconstrained `alpha` to an arbitrary type (ZonkAny @Type 3), where the `3` is+arbitrary (see wrinkle (Any5) below).  This is done in `GHC.Tc.Zonk.Type.commitFlexi`.+So we end up with++  length @(ZonkAny @Type 3) ([] @(ZonkAny @Type 3))++`Any` and `ZonkAny` differ only in the presence of the `Nat` argument; see+wrinkle (Any4).++Wrinkles:++(Any1) `Any` and `ZonkAny` are kind polymorphic since in some program we may+   need to use `ZonkAny` to fill in a type variable of some kind other than *+   (see #959 for examples).++(Any2) They are /closed/ type families, with no instances.  For example, suppose that+   with  alpha :: '(k1, k2)  we add a given coercion+             g :: alpha ~ (Fst alpha, Snd alpha)+   and we zonked alpha = ZonkAny @(k1,k2) n.  Then, if `ZonkAny` was a /data/ type,+   we'd get inconsistency because we'd have a Given equality with `ZonkAny` on one+   side and '(,) on the other. See also #9097 and #9636.++   See #25244 for a suggestion that we instead use an /open/ type family for which+   you cannot provide instances.  Probably the difference is not very important.++(Any3) They do not claim to be /data/ types, and that's important for+   the code generator, because the code gen may /enter/ a data value+   but never enters a function value.++(Any4) `ZonkAny` takes a `Nat` argument so that we can readily make up /distinct/+   types (#24817).  Consider++     data SBool a where { STrue :: SBool True; SFalse :: SBool False }++     foo :: forall a b. (SBool a, SBool b)++     bar :: Bool+     bar = case foo @alpha @beta of+             (STrue, SFalse) -> True   -- This branch is not inaccessible!+             _               -> False++   Now, what are `alpha` and `beta`? If we zonk both of them to the same type+   `Any @Type`, the pattern-match checker will (wrongly) report that the first+   branch is inaccessible.  So we zonk them to two /different/ types:+       alpha :=  ZonkAny @Type 4   and   beta :=  ZonkAny @Type k 5+   (The actual numbers are arbitrary; they just need to differ.)++   The unique-name generation comes from field `tcg_zany_n` of `TcGblEnv`; and+   `GHC.Tc.Zonk.Type.commitFlexi` calls `GHC.Tc.Utils.Monad.newZonkAnyType` to+   make up a fresh type.++   If this example seems unconvincing (e.g. in this case foo must be bottom)+   see #24817 for larger but more compelling examples.++(Any5) `Any` and `ZonkAny` are wired-in so we can easily refer to it where we+    don't have a name environment (e.g. see Rules.matchRule for one example)++(Any6) `Any` is defined in library module ghc-prim:GHC.Types, and exported so that+    it is available to users.  For this reason it's treated like any other+    wired-in type:+      - has a fixed unique, anyTyConKey,+      - lives in the global name cache+    Currently `ZonkAny` is not available to users; but it could easily be.++(Any7) Properties of `Any`:+  * When `Any` is instantiated at a lifted type it is inhabited by at least one value,+    namely bottom.++  * You can safely coerce any /lifted/ type to `Any` and back with `unsafeCoerce`.++  * You can safely coerce any /unlifted/ type to `Any` and back with `unsafeCoerceUnlifted`.++  * You can coerce /any/ type to `Any` and back with `unsafeCoerce#`, but it's only safe when+    the kinds of both the type and `Any` match.++  * For lifted/unlifted types `unsafeCoerce[Unlifted]` should be preferred over+    `unsafeCoerce#` as they prevent accidentally coercing between types with kinds+    that don't match.++    See examples in ghc-prim:GHC.Types++(Any8) Warning about unused bindings of type `Any` and `ZonkAny` are suppressed,+    following the same rationale of supressing warning about the unit type.++    For example, consider (#25895):++     do { forever (return ()); blah }++    where forever :: forall a b. IO a -> IO b+    Nothing constrains `b`, so it will be instantiates with `Any` or `ZonkAny`.+    But we certainly don't want to complain about a discarded do-binding.++The Any tycon used to be quite magic, but we have since been able to+implement it merely with an empty kind polymorphic type family. See #10886 for a+bit of history.+-}+++anyTyConName :: Name+anyTyConName =+    mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Any") anyTyConKey anyTyCon++anyTyCon :: TyCon+-- See Note [Any types]+anyTyCon = mkFamilyTyCon anyTyConName binders res_kind Nothing+                         (ClosedSynFamilyTyCon Nothing)+                         Nothing+                         NotInjective+  where+    binders@[kv] = mkTemplateKindTyConBinders [liftedTypeKind]+    res_kind = mkTyVarTy (binderVar kv)++anyTy :: Type+anyTy = mkTyConTy anyTyCon++anyTypeOfKind :: Kind -> Type+anyTypeOfKind kind = mkTyConApp anyTyCon [kind]++zonkAnyTyConName :: Name+zonkAnyTyConName =+    mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "ZonkAny") zonkAnyTyConKey zonkAnyTyCon++zonkAnyTyCon :: TyCon+-- ZonkAnyTyCon :: forall k. Nat -> k+-- See Note [Any types]+zonkAnyTyCon = mkFamilyTyCon zonkAnyTyConName+                         [ mkNamedTyConBinder Specified kv+                         , mkAnonTyConBinder nat_kv ]+                         (mkTyVarTy kv)+                         Nothing+                         (ClosedSynFamilyTyCon Nothing)+                         Nothing+                         NotInjective+  where+    [kv,nat_kv] = mkTemplateKindVars [liftedTypeKind, naturalTy]++-- | Make a fake, recovery 'TyCon' from an existing one.+-- Used when recovering from errors in type declarations+makeRecoveryTyCon :: TyCon -> TyCon+makeRecoveryTyCon tc+  = mkTcTyCon (tyConName tc)+              bndrs res_kind+              noTcTyConScopedTyVars+              True             -- Fully generalised+              flavour          -- Keep old flavour+  where+    flavour = tyConFlavour tc+    [kv] = mkTemplateKindVars [liftedTypeKind]+    (bndrs, res_kind)+       = case flavour of+           PromotedDataConFlavour -> ([mkNamedTyConBinder Inferred kv], mkTyVarTy kv)+           _ -> (tyConBinders tc, tyConResKind tc)+        -- For data types we have already validated their kind, so it+        -- makes sense to keep it. For promoted data constructors we haven't,+        -- so we recover with kind (forall k. k).  Otherwise consider+        --     data T a where { MkT :: Show a => T a }+        -- If T is for some reason invalid, we don't want to fall over+        -- at (promoted) use-sites of MkT.++-- Kinds+typeSymbolKindConName :: Name+typeSymbolKindConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Symbol") typeSymbolKindConNameKey typeSymbolKindCon+++boolTyCon_RDR, false_RDR, true_RDR, intTyCon_RDR, charTyCon_RDR, stringTyCon_RDR,+    intDataCon_RDR, listTyCon_RDR, consDataCon_RDR :: RdrName+boolTyCon_RDR   = nameRdrName boolTyConName+false_RDR       = nameRdrName falseDataConName+true_RDR        = nameRdrName trueDataConName+intTyCon_RDR    = nameRdrName intTyConName+charTyCon_RDR   = nameRdrName charTyConName+stringTyCon_RDR = nameRdrName stringTyConName+intDataCon_RDR  = nameRdrName intDataConName+listTyCon_RDR   = nameRdrName listTyConName+consDataCon_RDR = nameRdrName consDataConName++{-+************************************************************************+*                                                                      *+\subsection{mkWiredInTyCon}+*                                                                      *+************************************************************************+-}++-- This function assumes that the types it creates have all parameters at+-- Representational role, and that there is no kind polymorphism.+pcTyCon :: Name -> Maybe CType -> [TyVar] -> [DataCon] -> TyCon+pcTyCon name cType tyvars cons+  = mkAlgTyCon name+                (mkAnonTyConBinders tyvars)+                liftedTypeKind+                (map (const Representational) tyvars)+                cType+                []              -- No stupid theta+                (mkDataTyConRhs cons)+                (VanillaAlgTyCon (mkPrelTyConRepName name))+                False           -- Not in GADT syntax++pcDataCon :: Name -> [TyVar] -> [Type] -> TyCon -> DataCon+pcDataCon n univs tys+  = pcRepPolyDataCon n univs noConcreteTyVars tys++pcRepPolyDataCon :: Name -> [TyVar] -> ConcreteTyVars+                 -> [Type] -> TyCon -> DataCon+pcRepPolyDataCon n univs conc_tvs tys+  = pcDataConWithFixity False n+      univs+      []    -- no ex_tvs+      conc_tvs+      univs -- the univs are precisely the user-written tyvars+      []    -- No theta+      (map linear tys)++pcDataConConstraint :: Name -> [TyVar] -> ThetaType -> TyCon -> DataCon+-- Used for data constructors whose arguments are all constraints.+-- Notably constraint tuples, Eq# etc.+pcDataConConstraint n univs theta+  = pcDataConWithFixity False n+      univs+      []           -- No ex_tvs+      noConcreteTyVars+      univs        -- The univs are precisely the user-written tyvars+      theta        -- All constraint arguments+      []           -- No value arguments++-- Used for RuntimeRep and friends; things with PromDataConInfo+pcSpecialDataCon :: Name -> [Type] -> TyCon -> PromDataConInfo -> DataCon+pcSpecialDataCon dc_name arg_tys tycon rri+  = pcDataConWithFixity' False dc_name+                         (dataConWorkerUnique (nameUnique dc_name)) rri+                         [] [] noConcreteTyVars [] [] (map linear arg_tys) tycon++pcDataConWithFixity :: Bool      -- ^ declared infix?+                    -> Name      -- ^ datacon name+                    -> [TyVar]   -- ^ univ tyvars+                    -> [TyCoVar] -- ^ ex tycovars+                    -> ConcreteTyVars+                                 -- ^ concrete tyvars+                    -> [TyCoVar] -- ^ user-written tycovars+                    -> ThetaType+                    -> [Scaled Type]    -- ^ args+                    -> TyCon+                    -> DataCon+pcDataConWithFixity infx n = pcDataConWithFixity' infx n+                                 (dataConWorkerUnique (nameUnique n)) NoPromInfo+-- The Name's unique is the first of two free uniques;+-- the first is used for the datacon itself,+-- the second is used for the "worker name"+--+-- To support this the mkPreludeDataConUnique function "allocates"+-- one DataCon unique per pair of Ints.++pcDataConWithFixity' :: Bool -> Name -> Unique -> PromDataConInfo+                     -> [TyVar] -> [TyCoVar]+                     -> ConcreteTyVars+                     -> [TyCoVar]+                     -> ThetaType -> [Scaled Type] -> TyCon -> DataCon+-- The Name should be in the DataName name space; it's the name+-- of the DataCon itself.+--+-- IMPORTANT NOTE:+--    if you try to wire-in a /GADT/ data constructor you will+--    find it hard (we did).  You will need wrapper and worker+--    Names, a DataConBoxer, DataConRep, EqSpec, etc.+--    Try hard not to wire-in GADT data types. You will live+--    to regret doing so (we do).++pcDataConWithFixity' declared_infix dc_name wrk_key rri+                     tyvars ex_tyvars conc_tyvars user_tyvars theta arg_tys tycon+  = data_con+  where+    tag_map = mkTyConTagMap tycon+    -- This constructs the constructor Name to ConTag map once per+    -- constructor, which is quadratic. It's OK here, because it's+    -- only called for wired in data types that don't have a lot of+    -- constructors. It's also likely that GHC will lift tag_map, since+    -- we call pcDataConWithFixity' with static TyCons in the same module.+    -- See Note [Constructor tag allocation] and #14657+    data_con = mkDataCon dc_name declared_infix prom_info+                (map (const no_bang) arg_tys)+                (map (const HsLazy) arg_tys)+                (map (const NotMarkedStrict) arg_tys)+                []      -- No labelled fields+                tyvars ex_tyvars+                conc_tyvars+                (mkTyVarBinders Specified user_tyvars)+                []      -- No equality spec+                theta+                arg_tys (mkTyConApp tycon (mkTyVarTys tyvars))+                rri+                tycon+                (lookupNameEnv_NF tag_map dc_name)+                []      -- No stupid theta+                (mkDataConWorkId wrk_name data_con)+                NoDataConRep    -- Wired-in types are too simple to need wrappers++    no_bang = HsSrcBang NoSourceText NoSrcUnpack NoSrcStrict++    wrk_name = mkDataConWorkerName data_con wrk_key++    prom_info = mkPrelTyConRepName dc_name++mkDataConWorkerName :: DataCon -> Unique -> Name+mkDataConWorkerName data_con wrk_key =+    mkWiredInName modu wrk_occ wrk_key+                  (AnId (dataConWorkId data_con)) UserSyntax+  where+    modu     = assert (isExternalName dc_name) $+               nameModule dc_name+    dc_name = dataConName data_con+    dc_occ  = nameOccName dc_name+    wrk_occ = mkDataConWorkerOcc dc_occ+++{-+************************************************************************+*                                                                      *+              Symbol+*                                                                      *+************************************************************************+-}++typeSymbolKindCon :: TyCon+-- data Symbol+typeSymbolKindCon = pcTyCon typeSymbolKindConName Nothing [] []++typeSymbolKind :: Kind+typeSymbolKind = mkTyConTy typeSymbolKindCon+++{-+************************************************************************+*                                                                      *+                Stuff for dealing with tuples+*                                                                      *+************************************************************************++Note [How tuples work]+~~~~~~~~~~~~~~~~~~~~~~+* There are three families of tuple TyCons and corresponding+  DataCons, expressed by the type BasicTypes.TupleSort:+    data TupleSort = BoxedTuple | UnboxedTuple | ConstraintTuple++* All three families are AlgTyCons, whose AlgTyConRhs is TupleTyCon++* BoxedTuples+    - A wired-in type+    - Data type declarations in GHC.Tuple+    - The data constructors really have an info table++* UnboxedTuples+    - A wired-in type+    - Data type declarations in GHC.Types+      but no actual declaration and no info table++* ConstraintTuples+    - A wired-in type.+    - Declared as classes in GHC.Classes, e.g.+         class (c1,c2) => CTuple2 c1 c2+    - Given constraints: the superclasses automatically become available+    - Wanted constraints: there is a built-in instance+         instance (c1,c2) => CTuple2 c1 c2+      See GHC.Tc.Instance.Class.matchCTuple+    - Currently just go up to 64; beyond that+      you have to use manual nesting+    - Unlike BoxedTuples and UnboxedTuples, which only wire+      in type constructors and data constructors, ConstraintTuples also wire in+      superclass selector functions. For instance, $p1CTuple2 and $p2CTuple2 are+      the selectors for the binary constraint tuple.+    - The parenthesis syntax for grouping constraints in contexts is not treated+      as a constraint tuple. The parser starts with a tuple type, then a+      postprocessing action extracts the individual constraints as a list and+      stores them in the context field of types like HsQualTy.++* In quite a lot of places things are restricted just to+  BoxedTuple/UnboxedTuple, and then we used BasicTypes.Boxity to distinguish+  E.g. tupleTyCon has a Boxity argument++* When looking up an OccName in the original-name cache+  (GHC.Types.Name.Cache.lookupOrigNameCache), we spot the tuple OccName to make+  sure we get the right wired-in name.++* Serialization to interface files works via the usual mechanism for known-key+  things: instead of serializing the OccName we just serialize the key. During+  deserialization we lookup the Name associated with the unique with the logic+  in GHC.Builtin.Uniques. See Note [Symbol table representation of names] for details.++See also Note [Known-key names] in GHC.Builtin.Names.++Note [One-tuples]+~~~~~~~~~~~~~~~~~+GHC supports both boxed and unboxed one-tuples:+ - Unboxed one-tuples are sometimes useful when returning a+   single value after CPR analysis+ - A boxed one-tuple is used by GHC.HsToCore.Utils.mkSelectorBinds, when+   there is just one binder+Basically it keeps everything uniform.++However the /naming/ of the type/data constructors for one-tuples is a+bit odd:+  3-tuples:  Tuple3   (,,)#+  2-tuples:  Tuple2   (,)#+  1-tuples:  ??+  0-tuples:  Unit     ()#++Zero-tuples have used up the logical name. So we use 'Solo' and 'Solo#'+for one-tuples.  So in ghc-prim:GHC.Tuple we see the declarations:+  data Unit = ()+  data Solo a = MkSolo a+  data Tuple2 a b = (a,b)++There is no way to write a boxed one-tuple in Haskell using tuple syntax.+They can, however, be written using other methods:++1. They can be written directly by importing them from GHC.Tuple.+2. They can be generated by way of Template Haskell or in `deriving` code.++There is nothing special about one-tuples in Core; in particular, they have no+custom pretty-printing, just using `Solo`.++See also Note [Flattening one-tuples] in GHC.Core.Make and+Note [Don't flatten tuples from HsSyn] in GHC.Core.Make.++Note [isBuiltInOcc_maybe]+~~~~~~~~~~~~~~~~~~~~~~~~~+`isBuiltInOcc_maybe` matches and resolves names that are occurrences of built-in+syntax, i.e. unqualified names that can be unambiguously resolved even without+knowing what's currently in scope (such names also can't be imported, exported,+or redefined in another module).+More on that in Note [Built-in syntax and the OrigNameCache] in GHC.Types.Name.Cache.++In GHC, there are two use cases for `isBuiltInOcc_maybe`:++1. Making TH's `mkName` work with built-in syntax,+   e.g. $(conT (mkName "[]")) is the same as []++2. Detecting bulit-in syntax in `infix` declarations,+   e.g. users can't write `infixl 6 :` (#15233)++The parser takes a shortcut and produces Exact RdrNames directly,+so it doesn't need to match on an OccName with isBuiltInOcc_maybe.++And here are the properties of `isBuiltInOcc_maybe`:++* The set of names recognized by `isBuiltInOcc_maybe` is essentialy the+  same as the set of names that the parser resolves to Exact RdrNames,+  e.g. "[]", "(,)", or "->".++  We could leave it at that, but we also recognize unboxed sum syntax+  "(#|#)" even though the parser can't handle it. This makes TH's `mkName`+  more permissive than the parser.++* The namespace of the input OccName is treated as a hint, not a+  requirement. For example,++    mkOccName dataName  ":"          maps to  consDataConName+    mkOccName tcClsName ":"   /also/ maps to  consDataConName++  The rationale behind this is that with DataKind or RequiredTypeArguments+  we may get an OccName with the wrong namespace and need to fallback to the+  other one.++* There is a `listTuplePuns :: Bool` parameter to account for the+  ListTuplePuns extension. It has /no/ effect on whether the predicate+  matches (i.e. if the result is Just or Nothing), but it can influence+  which name is returned (TyCon name or DataCon name). For example,++    isBuiltInOcc_maybe False (mkOccName dataName  "[]")  ==  Just nilDataConName+    isBuiltInOcc_maybe False (mkOccName tcClsName "[]")  ==  Just nilDataConName+    isBuiltInOcc_maybe True  (mkOccName dataName  "[]")  ==  Just nilDataConName+    isBuiltInOcc_maybe True  (mkOccName tcClsName "[]")  ==  Just listTyConName++* There is no `Module` parameter because we are matching unqualified+  occurrences of built-in names. It is illegal to qualify built-in syntax,+  e.g. GHC.Types.(,) is a parse error.++* The /input/ to `isBuiltInOcc_maybe` needs to be built-in syntax for the+  predicate to match, but the /output/ is not necessarily built-in syntax.+  For example,++    1) input:   mkTcOcc "[]"          -- built-in syntax+       output:  Just listTyConName    -- user syntax (GHC.Types.List)++    2) input:   mkDataOcc "[]"        -- built-in syntax+       output:  Just nilDataConName   -- built-in syntax []++    3) input:   mkTcOcc "List"        -- user syntax+       output:  Nothing               -- no match++    4) input:   mkTcOcc "(,)"                       -- built-in syntax+       output:  Just (tupleTyConName BoxedTuple 2)  -- user syntax (GHC.Types.Tuple2)++    5) input:   mkTcOcc "(#|#)"               -- built-in syntax+       output:  Just (unboxedSumTyConName 2)  -- user syntax (GHC.Types.Sum2#)++  Therefore, `GHC.Types.Name.isBuiltInSyntax` may or may not hold for the name+  returned by `isBuiltInOcc_maybe`.+-}++-- | Match on built-in syntax as it occurs at use sites.+-- See Note [isBuiltInOcc_maybe]+isBuiltInOcc_maybe :: Bool -> OccName -> Maybe Name+isBuiltInOcc_maybe listTuplePuns occ+  | fs == "->" = Just unrestrictedFunTyConName+  | fs == "[]" = Just (pun listTyConName nilDataConName)+  | fs == ":"  = Just consDataConName+  | Just n <- (is_boxed_tup_syntax fs) = Just (tup_name Boxed n)+  | Just n <- (is_unboxed_tup_syntax fs) = Just (tup_name Unboxed n)+  | Just n <- (is_unboxed_sum_type_syntax fs) = Just (unboxedSumTyConName n)+  | Just (k, n) <- (is_unboxed_sum_data_syntax fs) = Just (unboxedSumDataConName k n)+  | otherwise = Nothing+  where+    fs = occNameFS occ+    ns = occNameSpace occ++    pun :: Name -> Name -> Name+    pun p n+      | listTuplePuns, isTcClsNameSpace ns = p+      | otherwise = n++    tup_name :: Boxity -> Arity -> Name+    tup_name boxity arity+      = pun (tyConName   (tupleTyCon   boxity arity))+            (dataConName (tupleDataCon boxity arity))++-- | Check if the OccName is an occurrence of built-in syntax.+--+-- This is a variant of `isBuiltInOcc_maybe` that returns a `Bool`.+-- See Note [isBuiltInOcc_maybe]+--+-- `isBuiltInOcc` holds for:+--   * function arrow `->`+--   * list syntax `[]`, `:`+--   * boxed tuple syntax `()`, `(,)`, `(,,)`, `(,,,)`, ...+--   * unboxed tuple syntax `(##)`, `(#,#)`, `(#,,#)`, ...+--   * unboxed sum type syntax `(#|#)`, `(#||#)`, `(#|||#)`, ...+--   * unboxed sum data syntax `(#_|#)`, `(#|_#)`, `(#_||#), ...+isBuiltInOcc :: OccName -> Bool+isBuiltInOcc = isJust . isBuiltInOcc_maybe listTuplePuns+  where+    listTuplePuns = False+      -- True/False here is inconsequential because ListTuplePuns doesn't affect+      -- whether isBuiltInOcc_maybe matches. See Note [isBuiltInOcc_maybe]++-- Match on original names of infinite families (tuples and sums).+-- See Note [Infinite families of known-key names] in GHC.Builtin.Names+isInfiniteFamilyOrigName_maybe :: Module -> OccName -> Maybe Name+isInfiniteFamilyOrigName_maybe mod occ =++  -- Tuples, boxed and unboxed+  isTupleTyOrigName_maybe mod occ+  <|> isTupleDataOrigName_maybe mod occ++  -- Constraint tuples+  <|> isCTupleOrigName_maybe mod occ++  -- Unboxed sums+  <|> isSumTyOrigName_maybe mod occ+  <|> isSumDataOrigName_maybe mod occ++-- Check if the string has form "()", "(,)", "(,,)", etc,+-- and return the corresponding tuple arity.+is_boxed_tup_syntax :: FastString -> Maybe Arity+is_boxed_tup_syntax fs+  | fs == "()" = Just 0+  | n >= 2+  , SBS.unsafeIndex sbs 0     == 40  -- ord '('+  , SBS.unsafeIndex sbs (n-1) == 41  -- ord ')'+  , sbs_all sbs 1 (n-1)          44  -- ord ','+  = Just (n-1)+  where+    n   = SBS.length sbs                   -- O(1)+    sbs = fastStringToShortByteString fs   -- O(1) field access+is_boxed_tup_syntax _ = Nothing++-- Check if the string has form "(##)", "(# #)", (#,#)", "(#,,#)", etc,+-- and return the corresponding tuple arity.+is_unboxed_tup_syntax :: FastString -> Maybe Arity+is_unboxed_tup_syntax fs+  | fs == "(##)"  = Just 0+  | fs == "(# #)" = Just 1+  | sbs_unboxed sbs+  , sbs_all sbs 2 (n-2) 44  -- ord ','+  = Just (n-3)+  where+    n   = SBS.length sbs                   -- O(1)+    sbs = fastStringToShortByteString fs   -- O(1) field access+is_unboxed_tup_syntax _ = Nothing++-- Check if the string has form "(#|#)", "(#||#)", (#|||#)", etc,+-- and return the corresponding sum arity.+is_unboxed_sum_type_syntax :: FastString -> Maybe Arity+is_unboxed_sum_type_syntax fs+  | sbs_unboxed sbs+  , Just k <- sbs_pipes sbs 2 (n-2)+  , k > 0+  = Just (k+1)+  where+    n   = SBS.length sbs                   -- O(1)+    sbs = fastStringToShortByteString fs   -- O(1) field access+is_unboxed_sum_type_syntax _ = Nothing++-- Check if the string has form "(#_|#)", "(#_||#)", (#|_|#)", etc,+-- and return the corresponding sum tag and sum arity.+is_unboxed_sum_data_syntax :: FastString -> Maybe (ConTag, Arity)+is_unboxed_sum_data_syntax fs+  | sbs_unboxed sbs+  , Just u <- SBS.elemIndex 95 sbs        -- ord '_'+  , Just k1 <- sbs_pipes sbs 2 u          -- pipes to the left  of '_'+  , Just k2 <- sbs_pipes sbs (u+1) (n-2)  -- pipes to the right of '_'+  = Just (k1+1, k1+k2+1)+  where+    n   = SBS.length sbs                   -- O(1)+    sbs = fastStringToShortByteString fs   -- O(1) field access+is_unboxed_sum_data_syntax _ = Nothing++-- (sbs_all sbs i n x) checks if all bytes in the slice [i..n) are equal to x.+sbs_all :: SBS.ShortByteString -> Int -> Int -> Word8 -> Bool+sbs_all !sbs !i !n !x+  | i < n     = SBS.unsafeIndex sbs i == x && sbs_all sbs (i+1) n x+  | otherwise = True++-- (sbs_pipes sbs i n) checks if all bytes in the slice [i..n) are equal to '|'+-- or ' ', and returns the number of encountered '|'.+sbs_pipes :: SBS.ShortByteString -> Int -> Int -> Maybe Int+sbs_pipes !sbs = go 0+  where+    go :: Int -> Int -> Int -> Maybe Int+    go !k !i !n+      | i < n =+        if | SBS.unsafeIndex sbs i == 124 -> go (k+1) (i+1) n -- ord '|'+           | SBS.unsafeIndex sbs i == 32  -> go k     (i+1) n -- ord ' '+           | otherwise                    -> Nothing+      | otherwise = Just k++-- (sbs_unboxed sbs) checks if the string starts with "(#" and ends with "#)".+sbs_unboxed :: SBS.ShortByteString -> Bool+sbs_unboxed !sbs =+  n >= 4 && SBS.unsafeIndex sbs 0     == 40  -- ord '('+         && SBS.unsafeIndex sbs 1     == 35  -- ord '#'+         && SBS.unsafeIndex sbs (n-2) == 35  -- ord '#'+         && SBS.unsafeIndex sbs (n-1) == 41  -- ord ')'+  where+    n = SBS.length sbs -- O(1)++-- (sbs_Sum sbs) checks if the string has form "SumN#" or "SumNM#",+-- where "N" or "NM" is a decimal numeral in the [2..mAX_SUM_SIZE] range.+sbs_Sum :: SBS.ShortByteString -> Maybe Arity+sbs_Sum !sbs+  | n >= 3 && SBS.unsafeIndex sbs 0 == 83   -- ord 'S'+           && SBS.unsafeIndex sbs 1 == 117  -- ord 'u'+           && SBS.unsafeIndex sbs 2 == 109  -- ord 'm'+  , Just (Unboxed, arity) <- sbs_arity_boxity sbs 3+  , arity >= 2, arity <= mAX_SUM_SIZE+  = Just arity+  | otherwise = Nothing+  where+    n = SBS.length sbs -- O(1)++-- (sbs_Tuple sbs) checks if the string has form "TupleN", "TupleNM", "TupleN#" or "TupleNM#",+-- where "N" or "NM" is a decimal numeral in the [2..mAX_TUPLE_SIZE] range.+sbs_Tuple :: SBS.ShortByteString -> Maybe (Boxity, Arity)+sbs_Tuple !sbs+  | n >= 5 && SBS.unsafeIndex sbs 0 == 84   -- ord 'T'+           && SBS.unsafeIndex sbs 1 == 117  -- ord 'u'+           && SBS.unsafeIndex sbs 2 == 112  -- ord 'p'+           && SBS.unsafeIndex sbs 3 == 108  -- ord 'l'+           && SBS.unsafeIndex sbs 4 == 101  -- ord 'e'+  , Just r@(_, arity) <- sbs_arity_boxity sbs 5+  , arity >= 2, arity <= mAX_TUPLE_SIZE+  = Just r+  | otherwise = Nothing+  where+    n = SBS.length sbs -- O(1)++-- (sbs_CTuple sbs) checks if the string has form "CTupleN" or "CTupleNM",+-- where "N" or "NM" is a decimal numeral in the [2..mAX_CTUPLE_SIZE] range.+sbs_CTuple :: SBS.ShortByteString -> Maybe Arity+sbs_CTuple !sbs+  | n >= 6 && SBS.unsafeIndex sbs 0 == 67   -- ord 'C'+           && SBS.unsafeIndex sbs 1 == 84   -- ord 'T'+           && SBS.unsafeIndex sbs 2 == 117  -- ord 'u'+           && SBS.unsafeIndex sbs 3 == 112  -- ord 'p'+           && SBS.unsafeIndex sbs 4 == 108  -- ord 'l'+           && SBS.unsafeIndex sbs 5 == 101  -- ord 'e'+  , Just (Boxed, arity) <- sbs_arity_boxity sbs 6+  , arity >= 2, arity <= mAX_CTUPLE_SIZE+  = Just arity+  | otherwise = Nothing+  where+    n = SBS.length sbs -- O(1)++-- (sbs_arity_boxity sbs i) parses bytes from position `i` to the end,+-- matching single- and double-digit decimals numerals (i.e. from 0 to 99)+-- possibly followed by '#'. See Note [Small Ints parsing]+sbs_arity_boxity :: SBS.ShortByteString -> Int -> Maybe (Boxity, Arity)+sbs_arity_boxity !sbs !i =+  case n - i of  -- bytes to parse+    1 -> parse1 (SBS.unsafeIndex sbs i)+    2 -> parse2 (SBS.unsafeIndex sbs i) (SBS.unsafeIndex sbs (i+1))+    3 -> parse3 (SBS.unsafeIndex sbs i) (SBS.unsafeIndex sbs (i+1)) (SBS.unsafeIndex sbs (i+2))+    _ -> Nothing+  where+    n = SBS.length sbs -- O(1)++    is_digit :: Word8 -> Bool+    is_digit x = x >= 48 && x <= 57  -- between (ord '0') and (ord '9')++    from_digit :: Word8 -> Int+    from_digit x = fromIntegral (x - 48)++    -- single-digit number+    parse1 :: Word8 -> Maybe (Boxity, Arity)+    parse1 x1 | is_digit x1 = Just (Boxed, from_digit x1)+    parse1 _ = Nothing++    -- double-digit number, or a single-digit number followed by '#'+    parse2 :: Word8 -> Word8 -> Maybe (Boxity, Arity)+    parse2 x1 35  -- ord '#'+      | is_digit x1 = Just (Unboxed, from_digit x1)+    parse2 x1 x2+      | is_digit x1, is_digit x2+      = Just (Boxed, from_digit x1 * 10 + from_digit x2)+    parse2 _ _ = Nothing++    -- double-digit number followed by '#'+    parse3 :: Word8 -> Word8 -> Word8 -> Maybe (Boxity, Arity)+    parse3 x1 x2 35 -- ord '#'+      | is_digit x1, is_digit x2+      = Just (Unboxed, from_digit x1 * 10 + from_digit x2)+    parse3 _ _ _ = Nothing++-- Identify original names of boxed and unboxed tuple type constructors.+-- Examples:+--   0b) isTupleTyOrigName_maybe GHC.Tuple (mkTcOcc "Unit")    =  Just <wired-in Name for 0-tuples>+--   1b) isTupleTyOrigName_maybe GHC.Tuple (mkTcOcc "Solo")    =  Just <wired-in Name for 1-tuples>+--   2b) isTupleTyOrigName_maybe GHC.Tuple (mkTcOcc "Tuple2")  =  Just <wired-in Name for 2-tuples>+--   0u) isTupleTyOrigName_maybe GHC.Types (mkTcOcc "Unit#")   =  Just <wired-in Name for unboxed 0-tuples>+--   1u) isTupleTyOrigName_maybe GHC.Types (mkTcOcc "Solo#")   =  Just <wired-in Name for unboxed 1-tuples>+--   2u) isTupleTyOrigName_maybe GHC.Types (mkTcOcc "Tuple2#") =  Just <wired-in Name for unboxed 2-tuples>+--   ...+--   64b) isTupleTyOrigName_maybe GHC.Tuple (mkTcOcc "Tuple64")  =  Just <wired-in Name for 64-tuples>+--   64u) isTupleTyOrigName_maybe GHC.Types (mkTcOcc "Tuple64#") =  Just <wired-in Name for unboxed 64-tuples>+--+-- Non-examples: "()", "(##)", "(,)", "(#,#)", "(,,)", "(#,,#)", etc.+-- As far as tuple /types/ are concerned, these are not the original names+-- but rather punned names under ListTuplePuns.+--+-- Also non-examples: "Tuple0", "Tuple0#", "Tuple1", and "Tuple1#".+-- These are merely type synonyms for "Unit", "Unit#", "Solo", and "Solo#".+isTupleTyOrigName_maybe :: Module -> OccName -> Maybe Name+isTupleTyOrigName_maybe mod occ+  | mod == gHC_INTERNAL_TUPLE = match_occ_boxed+  | mod == gHC_TYPES          = match_occ_unboxed+  where+    fs  = occNameFS occ+    ns  = occNameSpace occ+    sbs = fastStringToShortByteString fs   -- O(1) field access++    match_occ_boxed+      | occ == occName unitTyConName = Just unitTyConName+      | occ == occName soloTyConName = Just soloTyConName+      | isTcClsNameSpace ns, Just (boxity@Boxed, n) <- sbs_Tuple sbs, n >= 2+      = Just (tyConName (tupleTyCon boxity n))+      | otherwise = Nothing++    match_occ_unboxed+      | occ == occName unboxedUnitTyConName = Just unboxedUnitTyConName+      | occ == occName unboxedSoloTyConName = Just unboxedSoloTyConName+      | isTcClsNameSpace ns, Just (boxity@Unboxed, n) <- sbs_Tuple sbs, n >= 2+      = Just (tyConName (tupleTyCon boxity n))+      | otherwise = Nothing++isTupleTyOrigName_maybe _ _ = Nothing++-- Identify original names of boxed and unboxed tuple data constructors.+-- Examples:+--   0b) isTupleDataOrigName_maybe GHC.Tuple (mkDataOcc "()")      =  Just <wired-in Name for 0-tuples>+--   1b) isTupleDataOrigName_maybe GHC.Tuple (mkDataOcc "MkSolo")  =  Just <wired-in Name for 1-tuples>+--   2b) isTupleDataOrigName_maybe GHC.Tuple (mkDataOcc "(,)")     =  Just <wired-in Name for 2-tuples>+--   ...+--   0u) isTupleDataOrigName_maybe GHC.Types (mkDataOcc "(##)")    =  Just <wired-in Name for unboxed 0-tuples>+--   1u) isTupleDataOrigName_maybe GHC.Types (mkDataOcc "MkSolo#") =  Just <wired-in Name for unboxed 1-tuples>+--   2u) isTupleDataOrigName_maybe GHC.Types (mkDataOcc "(#,#)")   =  Just <wired-in Name for unboxed 2-tuples>+--   ...+--+-- Non-examples: Tuple<n> or Tuple<n>#, as this is the name format of tuple /type/ constructors.+isTupleDataOrigName_maybe :: Module -> OccName -> Maybe Name+isTupleDataOrigName_maybe mod occ+  | mod == gHC_INTERNAL_TUPLE = match_occ_boxed+  | mod == gHC_TYPES          = match_occ_unboxed+  where+    match_occ_boxed+      | occ == occName soloDataConName = Just soloDataConName+      | isDataConNameSpace ns, Just n <- (is_boxed_tup_syntax fs)+      = Just (tupleDataConName Boxed n)+      | otherwise = Nothing+    match_occ_unboxed+      | occ == occName unboxedSoloDataConName = Just unboxedSoloDataConName+      | isDataConNameSpace ns, Just n <- (is_unboxed_tup_syntax fs)+      = Just (tupleDataConName Unboxed n)+      | otherwise = Nothing+    fs = occNameFS occ+    ns = occNameSpace occ+isTupleDataOrigName_maybe _ _ = Nothing++-- Identify original names of constraint tuples.+-- Examples:+--   0) isCTupleOrigName_maybe GHC.Classes (mkClsOcc "CUnit")    =  Just <wired-in Name for 0-ctuples>+--   1) isCTupleOrigName_maybe GHC.Classes (mkClsOcc "CSolo")    =  Just <wired-in Name for 1-ctuples>+--   2) isCTupleOrigName_maybe GHC.Classes (mkClsOcc "CTuple2")  =  Just <wired-in Name for 2-ctuples>+--   ...+--   64) isCTupleOrigName_maybe GHC.Classes (mkClsOcc "CTuple64")  =  Just <wired-in Name for 64-ctuples>+--+-- Non-examples: "()", "(,)", "(,,)", etc.+-- As far as constraint tuples are concerned, these are not the original names+-- but rather punned names under ListTuplePuns.+--+-- Also non-examples: "CTuple0" and "CTuple1".+-- These are merely type synonyms for "CUnit" and "CSolo".+isCTupleOrigName_maybe :: Module -> OccName -> Maybe Name+isCTupleOrigName_maybe mod occ+  | mod == gHC_CLASSES+  = match_occ+  where+    fs  = occNameFS occ+    sbs = fastStringToShortByteString fs   -- O(1) field access+    match_occ+      | occ == occName (cTupleTyConName 0) = Just (cTupleTyConName 0)  -- CUnit+      | occ == occName (cTupleTyConName 1) = Just (cTupleTyConName 1)  -- CSolo++      | Just num <- sbs_CTuple sbs, num >= 2+      = Just $ cTupleTyConName num++      | otherwise = Nothing++isCTupleOrigName_maybe _ _ = Nothing++-- Identify original names of unboxed sum type constructors.+-- Examples:+--   2) isSumTyOrigName_maybe GHC.Types (mkTcOcc "Sum2#") =  Just <wired-in Name for unboxed 2-sums>+--   3) isSumTyOrigName_maybe GHC.Types (mkTcOcc "Sum3#") =  Just <wired-in Name for unboxed 3-sums>+--   4) isSumTyOrigName_maybe GHC.Types (mkTcOcc "Sum4#") =  Just <wired-in Name for unboxed 4-sums>+--   ...+--   64) isSumTyOrigName_maybe GHC.Types (mkTcOcc "Sum64#") =  Just <wired-in Name for unboxed 64-sums>+--+-- Non-examples: "(#|#)", "(#||#)", "(#|||#)", etc. These are not valid syntax.+-- Also non-examples: "Sum0#", "Sum1#". These do not exist.+isSumTyOrigName_maybe :: Module -> OccName -> Maybe Name+isSumTyOrigName_maybe mod occ+  | mod == gHC_TYPES+  , isTcClsNameSpace ns+  , Just n <- sbs_Sum sbs+  , n >= 2+  = Just (tyConName (sumTyCon n))+  where+    fs  = occNameFS occ+    ns  = occNameSpace occ+    sbs = fastStringToShortByteString fs   -- O(1) field access+isSumTyOrigName_maybe _ _ = Nothing++-- Identify original names of unboxed sum data constructors.+-- "(#_|#)", "(#_||#)", (#|_|#)"+--+-- Examples:+--   1/2) isSumTyOrigName_maybe GHC.Types (mkDataOcc "(#_|#)")  =  Just <wired-in Name for 1st alt of unboxed 2-sums>+--   1/3) isSumTyOrigName_maybe GHC.Types (mkDataOcc "(#_||#)") =  Just <wired-in Name for 1st alt of unboxed 3-sums>+--   2/3) isSumTyOrigName_maybe GHC.Types (mkDataOcc "(#|_|#)") =  Just <wired-in Name for 2nd alt of unboxed 3-sums>+--   ...+--+-- Non-examples: Sum<n>#, as this is the name format of unboxed sum /type/ constructors.+isSumDataOrigName_maybe :: Module -> OccName -> Maybe Name+isSumDataOrigName_maybe mod occ+  | mod == gHC_TYPES+  , isDataConNameSpace ns+  , Just (k,n) <- (is_unboxed_sum_data_syntax fs)+  = Just (unboxedSumDataConName k n)+  where fs = occNameFS occ+        ns = occNameSpace occ+isSumDataOrigName_maybe _ _ = Nothing++{-+Note [Small Ints parsing]+~~~~~~~~~~~~~~~~~~~~~~~~~+Currently, tuples in Haskell have a maximum arity of 64.+To parse strings of length 1 and 2 more efficiently, we+can utilize an ad-hoc solution that matches their characters.+This results in a speedup of up to 40 times compared to using+`readMaybe @Int` on my machine.+-}++mkTupleOcc :: NameSpace -> Boxity -> Arity -> (OccName, BuiltInSyntax)+mkTupleOcc ns b ar = (mkOccName ns str, built_in)+  where (str, built_in) = mkTupleStr' ns b ar++mkCTupleOcc :: NameSpace -> Arity -> OccName+mkCTupleOcc ns ar = mkOccName ns (mkConstraintTupleStr ar)++mkTupleStr :: Boxity -> NameSpace -> Arity -> String+mkTupleStr b ns ar = str+  where (str, _) = mkTupleStr' ns b ar++mkTupleStr' :: NameSpace -> Boxity -> Arity -> (String, BuiltInSyntax)+mkTupleStr' ns Boxed 0+  | isDataConNameSpace ns = ("()", BuiltInSyntax)+  | otherwise             = ("Unit", UserSyntax)+mkTupleStr' ns Boxed 1+  | isDataConNameSpace ns = ("MkSolo", UserSyntax)  -- See Note [One-tuples]+  | otherwise             = ("Solo",   UserSyntax)+mkTupleStr' ns Boxed ar+  | isDataConNameSpace ns = ('(' : commas ar ++ ")", BuiltInSyntax)+  | otherwise             = ("Tuple" ++ showInt ar "", UserSyntax)+mkTupleStr' ns Unboxed 0+  | isDataConNameSpace ns = ("(##)",  BuiltInSyntax)+  | otherwise             = ("Unit#", UserSyntax)+mkTupleStr' ns Unboxed 1+  | isDataConNameSpace ns = ("MkSolo#", UserSyntax) -- See Note [One-tuples]+  | otherwise             = ("Solo#",   UserSyntax)+mkTupleStr' ns Unboxed ar+  | isDataConNameSpace ns = ("(#" ++ commas ar ++ "#)", BuiltInSyntax)+  | otherwise             = ("Tuple" ++ show ar ++ "#", UserSyntax)++mkConstraintTupleStr :: Arity -> String+mkConstraintTupleStr 0 = "CUnit"+mkConstraintTupleStr 1 = "CSolo"+mkConstraintTupleStr ar = "CTuple" ++ show ar++commas :: Arity -> String+commas ar = replicate (ar-1) ','++cTupleTyCon :: Arity -> TyCon+cTupleTyCon i+  | i > mAX_CTUPLE_SIZE = fstOf3 (mk_ctuple i) -- Build one specially+  | otherwise           = fstOf3 (cTupleArr ! i)++cTupleTyConName :: Arity -> Name+cTupleTyConName a = tyConName (cTupleTyCon a)++cTupleTyConNames :: [Name]+cTupleTyConNames = map cTupleTyConName (0 : [2..mAX_CTUPLE_SIZE])++cTupleTyConKeys :: UniqueSet+cTupleTyConKeys = fromListUniqueSet $ map getUnique cTupleTyConNames++isCTupleTyConName :: Name -> Bool+isCTupleTyConName n+ = assertPpr (isExternalName n) (ppr n) $+   getUnique n `memberUniqueSet` cTupleTyConKeys++cTupleDataCon :: Arity -> DataCon+cTupleDataCon i+  | i > mAX_CTUPLE_SIZE = sndOf3 (mk_ctuple i) -- Build one specially+  | otherwise           = sndOf3 (cTupleArr ! i)++cTupleDataConName :: Arity -> Name+cTupleDataConName i = dataConName (cTupleDataCon i)++cTupleDataConNames :: [Name]+cTupleDataConNames = map cTupleDataConName (0 : [2..mAX_CTUPLE_SIZE])++cTupleSelId :: ConTag -- Superclass position+            -> Arity  -- Arity+            -> Id+cTupleSelId sc_pos arity+  | sc_pos > arity+  = panic ("cTupleSelId: index out of bounds: superclass position: "+           ++ show sc_pos ++ " > arity " ++ show arity)++  | sc_pos <= 0+  = panic ("cTupleSelId: Superclass positions start from 1. "+           ++ "(superclass position: " ++ show sc_pos+           ++ ", arity: " ++ show arity ++ ")")++  | arity < 1+  = panic ("cTupleSelId: Arity starts from 1. "+           ++ "(superclass position: " ++ show sc_pos+           ++ ", arity: " ++ show arity ++ ")")++  | arity > mAX_CTUPLE_SIZE+  = thdOf3 (mk_ctuple arity) ! (sc_pos - 1)  -- Build one specially++  | otherwise+  = thdOf3 (cTupleArr ! arity) ! (sc_pos - 1)++cTupleSelIdName :: ConTag -- Superclass position+                -> Arity  -- Arity+                -> Name+cTupleSelIdName sc_pos arity = idName (cTupleSelId sc_pos arity)++tupleTyCon :: Boxity -> Arity -> TyCon+tupleTyCon sort i | i > mAX_TUPLE_SIZE = fst (mk_tuple sort i)  -- Build one specially+tupleTyCon Boxed   i = fst (boxedTupleArr   ! i)+tupleTyCon Unboxed i = fst (unboxedTupleArr ! i)++tupleTyConName :: TupleSort -> Arity -> Name+tupleTyConName ConstraintTuple a = cTupleTyConName a+tupleTyConName BoxedTuple      a = tyConName (tupleTyCon Boxed a)+tupleTyConName UnboxedTuple    a = tyConName (tupleTyCon Unboxed a)++promotedTupleDataCon :: Boxity -> Arity -> TyCon+promotedTupleDataCon boxity i = promoteDataCon (tupleDataCon boxity i)++tupleDataCon :: Boxity -> Arity -> DataCon+tupleDataCon sort i | i > mAX_TUPLE_SIZE = snd (mk_tuple sort i)    -- Build one specially+tupleDataCon Boxed   i = snd (boxedTupleArr   ! i)+tupleDataCon Unboxed i = snd (unboxedTupleArr ! i)++tupleDataConName :: Boxity -> Arity -> Name+tupleDataConName sort i = dataConName (tupleDataCon sort i)++mkPromotedPairTy :: Kind -> Kind -> Type -> Type -> Type+mkPromotedPairTy k1 k2 t1 t2 = mkTyConApp (promotedTupleDataCon Boxed 2) [k1,k2,t1,t2]++isPromotedPairType :: Type -> Maybe (Type, Type)+isPromotedPairType t+  | Just (tc, [_,_,x,y]) <- splitTyConApp_maybe t+  , tc == promotedTupleDataCon Boxed 2+  = Just (x, y)+  | otherwise = Nothing++boxedTupleArr, unboxedTupleArr :: Array Int (TyCon,DataCon)+boxedTupleArr   = listArray (0,mAX_TUPLE_SIZE) [mk_tuple Boxed   i | i <- [0..mAX_TUPLE_SIZE]]+unboxedTupleArr = listArray (0,mAX_TUPLE_SIZE) [mk_tuple Unboxed i | i <- [0..mAX_TUPLE_SIZE]]++-- | Cached type constructors, data constructors, and superclass selectors for+-- constraint tuples. The outer array is indexed by the arity of the constraint+-- tuple and the inner array is indexed by the superclass position.+cTupleArr :: Array Int (TyCon, DataCon, Array Int Id)+cTupleArr = listArray (0,mAX_CTUPLE_SIZE) [mk_ctuple i | i <- [0..mAX_CTUPLE_SIZE]]++-- | Given the TupleRep/SumRep tycon and list of RuntimeReps of the unboxed+-- tuple/sum arguments, produces the return kind of an unboxed tuple/sum type+-- constructor. @unboxedTupleSumKind [IntRep, LiftedRep] --> TYPE (TupleRep/SumRep+-- [IntRep, LiftedRep])@+unboxedTupleSumKind :: TyCon -> [Type] -> Kind+unboxedTupleSumKind tc rr_tys+  = mkTYPEapp (mkTyConApp tc [mkPromotedListTy runtimeRepTy rr_tys])++-- | Specialization of 'unboxedTupleSumKind' for tuples+unboxedTupleKind :: [Type] -> Kind+unboxedTupleKind = unboxedTupleSumKind tupleRepDataConTyCon++mk_tuple :: Boxity -> Int -> (TyCon,DataCon)+mk_tuple Boxed arity = (tycon, tuple_con)+  where+    tycon = mkTupleTyCon tc_name tc_binders tc_res_kind tuple_con+                         BoxedTuple flavour++    tc_binders  = mkTemplateAnonTyConBinders (replicate arity liftedTypeKind)+    tc_res_kind = liftedTypeKind+    flavour     = VanillaAlgTyCon (mkPrelTyConRepName tc_name)++    dc_tvs     = binderVars tc_binders+    dc_arg_tys = mkTyVarTys dc_tvs+    tuple_con  = pcDataCon dc_name dc_tvs dc_arg_tys tycon++    boxity  = Boxed+    modu    = gHC_INTERNAL_TUPLE+    tc_name = mkWiredInName modu occ tc_uniq (ATyCon tycon) built_in+      where (occ, built_in) = mkTupleOcc tcName boxity arity+    dc_name = mkWiredInName modu occ dc_uniq (AConLike (RealDataCon tuple_con)) built_in+      where (occ, built_in) = mkTupleOcc dataName boxity arity+    tc_uniq = mkTupleTyConUnique   boxity arity+    dc_uniq = mkTupleDataConUnique boxity arity++mk_tuple Unboxed arity = (tycon, tuple_con)+  where+    tycon = mkTupleTyCon tc_name tc_binders tc_res_kind tuple_con+                         UnboxedTuple flavour++    -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon+    -- Kind:  forall (k1:RuntimeRep) (k2:RuntimeRep). TYPE k1 -> TYPE k2 -> TYPE (TupleRep [k1, k2])+    tc_binders = mkTemplateTyConBinders (replicate arity runtimeRepTy)+                                        (\ks -> map mkTYPEapp ks)++    tc_res_kind = unboxedTupleKind rr_tys+    flavour     = VanillaAlgTyCon (mkPrelTyConRepName tc_name)++    dc_tvs               = binderVars tc_binders+    (rr_tvs, dc_arg_tvs) = splitAt arity dc_tvs+    rr_tys               = mkTyVarTys rr_tvs+    dc_arg_tys           = mkTyVarTys dc_arg_tvs+    tuple_con            = pcRepPolyDataCon dc_name dc_tvs conc_tvs dc_arg_tys tycon+    conc_tvs =+      mkNameEnv+        [ (tyVarName rr_tv, ConcreteFRR $ FixedRuntimeRepOrigin ty $ mkFRRUnboxedTuple pos)+        | rr_tv <- rr_tvs+        | ty <- dc_arg_tys+        | pos <- [1..arity] ]++    boxity  = Unboxed+    modu    = gHC_TYPES+    tc_name = mkWiredInName modu occ tc_uniq (ATyCon tycon) built_in+      where (occ, built_in) = mkTupleOcc tcName boxity arity+    dc_name = mkWiredInName modu occ dc_uniq (AConLike (RealDataCon tuple_con)) built_in+      where (occ, built_in) = mkTupleOcc dataName boxity arity+    tc_uniq = mkTupleTyConUnique   boxity arity+    dc_uniq = mkTupleDataConUnique boxity arity++mk_ctuple :: Arity -> (TyCon, DataCon, Array ConTagZ Id)+mk_ctuple arity = (tycon, tuple_con, sc_sel_ids_arr)+  where+    tycon = mkClassTyCon tc_name binders roles+                         rhs klass+                         (mkPrelTyConRepName tc_name)++    klass     = mk_ctuple_class tycon sc_theta sc_sel_ids+    tuple_con = pcDataConConstraint dc_name tvs sc_theta tycon++    binders = mkTemplateAnonTyConBinders (replicate arity constraintKind)+    roles   = replicate arity Nominal+    rhs     = TupleTyCon{data_con = tuple_con, tup_sort = ConstraintTuple}++    modu    = gHC_CLASSES+    tc_name = mkWiredInName modu (mkCTupleOcc tcName arity) tc_uniq+                         (ATyCon tycon) UserSyntax+    dc_name = mkWiredInName modu (mkCTupleOcc dataName arity) dc_uniq+                            (AConLike (RealDataCon tuple_con)) BuiltInSyntax+    tc_uniq = mkCTupleTyConUnique   arity+    dc_uniq = mkCTupleDataConUnique arity++    tvs            = binderVars binders+    sc_theta       = map mkTyVarTy tvs+    sc_sel_ids     = [mk_sc_sel_id sc_pos | sc_pos <- [0..arity-1]]+    sc_sel_ids_arr = listArray (0,arity-1) sc_sel_ids++    mk_sc_sel_id sc_pos =+      let sc_sel_id_uniq = mkCTupleSelIdUnique sc_pos arity+          sc_sel_id_occ  = mkCTupleOcc tcName arity+          sc_sel_id_name = mkWiredInIdName+                             gHC_CLASSES+                             (occNameFS (mkSuperDictSelOcc sc_pos sc_sel_id_occ))+                             sc_sel_id_uniq+                             sc_sel_id+          sc_sel_id      = mkDictSelId sc_sel_id_name klass++      in sc_sel_id++unitTyCon :: TyCon+unitTyCon = tupleTyCon Boxed 0++unitTyConName :: Name+unitTyConName = tyConName unitTyCon++unitTyConKey :: Unique+unitTyConKey = getUnique unitTyCon++unitDataCon :: DataCon+unitDataCon   = head (tyConDataCons unitTyCon)++unitDataConId :: Id+unitDataConId = dataConWorkId unitDataCon++soloTyCon :: TyCon+soloTyCon = tupleTyCon Boxed 1++soloTyConName :: Name+soloTyConName = tyConName soloTyCon++soloDataConName :: Name+soloDataConName = tupleDataConName Boxed 1++pairTyCon :: TyCon+pairTyCon = tupleTyCon Boxed 2++unboxedUnitTy :: Type+unboxedUnitTy = mkTyConTy unboxedUnitTyCon++unboxedUnitTyCon :: TyCon+unboxedUnitTyCon = tupleTyCon Unboxed 0++unboxedUnitTyConName :: Name+unboxedUnitTyConName = tyConName unboxedUnitTyCon++unboxedUnitDataCon :: DataCon+unboxedUnitDataCon = tupleDataCon Unboxed 0++unboxedSoloTyCon :: TyCon+unboxedSoloTyCon = tupleTyCon Unboxed 1++unboxedSoloTyConName :: Name+unboxedSoloTyConName = tyConName unboxedSoloTyCon++unboxedSoloDataConName :: Name+unboxedSoloDataConName = tupleDataConName Unboxed 1++{- *********************************************************************+*                                                                      *+      Unboxed sums+*                                                                      *+********************************************************************* -}++-- | OccName for n-ary unboxed sum type constructor.+mkSumTyConOcc :: Arity -> OccName+mkSumTyConOcc n = mkOccName tcName str+  where+    -- No need to cache these, the caching is done in mk_sum+    str = "Sum" ++ show n ++ "#"++-- | OccName for i-th alternative of n-ary unboxed sum data constructor.+mkSumDataConOcc :: ConTag -> Arity -> OccName+mkSumDataConOcc alt n = mkOccName dataName str+  where+    -- No need to cache these, the caching is done in mk_sum+    str = '(' : '#' : ' ' : bars alt ++ '_' : bars (n - alt - 1) ++ " #)"+    bars i = intersperse ' ' $ replicate i '|'++-- | Type constructor for n-ary unboxed sum.+sumTyCon :: Arity -> TyCon+sumTyCon arity+  | arity > mAX_SUM_SIZE+  = fst (mk_sum arity)  -- Build one specially++  | arity < 2+  = panic ("sumTyCon: Arity starts from 2. (arity: " ++ show arity ++ ")")++  | otherwise+  = fst (unboxedSumArr ! arity)++unboxedSumTyConName :: Arity -> Name+unboxedSumTyConName arity = tyConName (sumTyCon arity)++-- | Data constructor for i-th alternative of a n-ary unboxed sum.+sumDataCon :: ConTag -- Alternative+           -> Arity  -- Arity+           -> DataCon+sumDataCon alt arity+  | alt > arity+  = panic ("sumDataCon: index out of bounds: alt: "+           ++ show alt ++ " > arity " ++ show arity)++  | alt <= 0+  = panic ("sumDataCon: Alts start from 1. (alt: " ++ show alt+           ++ ", arity: " ++ show arity ++ ")")++  | arity < 2+  = panic ("sumDataCon: Arity starts from 2. (alt: " ++ show alt+           ++ ", arity: " ++ show arity ++ ")")++  | arity > mAX_SUM_SIZE+  = snd (mk_sum arity) ! (alt - 1)  -- Build one specially++  | otherwise+  = snd (unboxedSumArr ! arity) ! (alt - 1)++unboxedSumDataConName :: ConTag -> Arity -> Name+unboxedSumDataConName alt arity = dataConName (sumDataCon alt arity)++-- | Cached type and data constructors for sums. The outer array is+-- indexed by the arity of the sum and the inner array is indexed by+-- the alternative.+unboxedSumArr :: Array Int (TyCon, Array Int DataCon)+unboxedSumArr = listArray (2,mAX_SUM_SIZE) [mk_sum i | i <- [2..mAX_SUM_SIZE]]++-- | Specialization of 'unboxedTupleSumKind' for sums+unboxedSumKind :: [Type] -> Kind+unboxedSumKind = unboxedTupleSumKind sumRepDataConTyCon++-- | Create type constructor and data constructors for n-ary unboxed sum.+mk_sum :: Arity -> (TyCon, Array ConTagZ DataCon)+mk_sum arity = (tycon, sum_cons)+  where+    tycon   = mkSumTyCon tc_name tc_binders tc_res_kind (elems sum_cons)+                         UnboxedSumTyCon++    tc_binders = mkTemplateTyConBinders (replicate arity runtimeRepTy)+                                        (\ks -> map mkTYPEapp ks)++    tyvars = binderVars tc_binders++    tc_res_kind = unboxedSumKind rr_tys++    (rr_tvs, dc_arg_tvs) = splitAt arity tyvars+    rr_tys               = mkTyVarTys rr_tvs+    dc_arg_tys           = mkTyVarTys dc_arg_tvs++    conc_tvs =+      mkNameEnv+        [ (tyVarName rr_tv, ConcreteFRR $ FixedRuntimeRepOrigin ty $ mkFRRUnboxedSum (Just pos))+        | rr_tv <- rr_tvs+        | ty <- dc_arg_tys+        | pos <- [1..arity] ]++    tc_name = mkWiredInName gHC_TYPES (mkSumTyConOcc arity) tc_uniq+                            (ATyCon tycon) UserSyntax++    sum_cons = listArray (0,arity-1) [sum_con i | i <- [0..arity-1]]+    sum_con i =+      let dc = pcRepPolyDataCon dc_name+                  tyvars -- univ tyvars+                  conc_tvs+                  [dc_arg_tys !! i] -- arg types+                  tycon++          dc_name = mkWiredInName gHC_TYPES+                                  (mkSumDataConOcc i arity)+                                  (dc_uniq i)+                                  (AConLike (RealDataCon dc))+                                  BuiltInSyntax+      in dc++    tc_uniq   = mkSumTyConUnique   arity+    dc_uniq i = mkSumDataConUnique i arity++{-+************************************************************************+*                                                                      *+              Equality types and classes+*                                                                      *+********************************************************************* -}++-- See Note [The equality types story] in GHC.Builtin.Types.Prim+-- ((~~) :: forall k1 k2 (a :: k1) (b :: k2). a -> b -> Constraint)+--+-- It's tempting to put functional dependencies on (~~), but it's not+-- necessary because the functional-dependency coverage check looks+-- through superclasses, and (~#) is handled in that check.++eqTyCon,   heqTyCon,   coercibleTyCon   :: TyCon+eqClass,   heqClass,   coercibleClass   :: Class+eqDataCon, heqDataCon, coercibleDataCon :: DataCon+eqSCSelId, heqSCSelId, coercibleSCSelId :: Id++(eqTyCon, eqClass, eqDataCon, eqSCSelId)+  = (tycon, klass, datacon, sc_sel_id)+  where+    tycon     = mkClassTyCon eqTyConName binders roles+                             rhs klass+                             (mkPrelTyConRepName eqTyConName)+    klass     = mk_class tycon sc_pred sc_sel_id+    datacon   = pcDataConConstraint eqDataConName tvs [sc_pred] tycon++    -- Kind: forall k. k -> k -> Constraint+    binders   = mkTemplateTyConBinders [liftedTypeKind] (\[k] -> [k,k])+    roles     = [Nominal, Nominal, Nominal]+    rhs       = mkDataTyConRhs [datacon]+                -- rhs: a DataTyCon, not a UnaryClassTyCon!  Yes it has one+                --      field, but it has unboxed type (a ~# b),+                --      so the class must provide the box.++    tvs@[k,a,b] = binderVars binders+    sc_pred     = mkTyConApp eqPrimTyCon (mkTyVarTys [k,k,a,b])+    sc_sel_id   = mkDictSelId eqSCSelIdName klass++(heqTyCon, heqClass, heqDataCon, heqSCSelId)+  = (tycon, klass, datacon, sc_sel_id)+  where+    tycon     = mkClassTyCon heqTyConName binders roles+                             rhs klass+                             (mkPrelTyConRepName heqTyConName)+    klass     = mk_class tycon sc_pred sc_sel_id+    datacon   = pcDataConConstraint heqDataConName tvs [sc_pred] tycon++    -- Kind: forall k1 k2. k1 -> k2 -> Constraint+    binders   = mkTemplateTyConBinders [liftedTypeKind, liftedTypeKind] id+    roles     = [Nominal, Nominal, Nominal, Nominal]+    rhs       = mkDataTyConRhs [datacon]++    tvs       = binderVars binders+    sc_pred   = mkTyConApp eqPrimTyCon (mkTyVarTys tvs)+    sc_sel_id = mkDictSelId heqSCSelIdName klass++(coercibleTyCon, coercibleClass, coercibleDataCon, coercibleSCSelId)+  = (tycon, klass, datacon, sc_sel_id)+  where+    tycon     = mkClassTyCon coercibleTyConName binders roles+                             rhs klass+                             (mkPrelTyConRepName coercibleTyConName)+    klass     = mk_class tycon sc_pred sc_sel_id+    datacon   = pcDataConConstraint coercibleDataConName tvs [sc_pred] tycon++    -- Kind: forall k. k -> k -> Constraint+    binders   = mkTemplateTyConBinders [liftedTypeKind] (\[k] -> [k,k])+    roles     = [Nominal, Representational, Representational]+    rhs       = mkDataTyConRhs [datacon]++    tvs@[k,a,b] = binderVars binders+    sc_pred     = mkTyConApp eqReprPrimTyCon (mkTyVarTys [k, k, a, b])+    sc_sel_id   = mkDictSelId coercibleSCSelIdName klass++mk_class :: TyCon -> PredType -> Id -> Class+mk_class tycon sc_pred sc_sel_id+  = mkClass (tyConName tycon) (tyConTyVars tycon) [] [sc_pred] [sc_sel_id]+            [] [] (mkAnd []) tycon++mk_ctuple_class :: TyCon -> ThetaType -> [Id] -> Class+mk_ctuple_class tycon sc_theta sc_sel_ids+  = mkClass (tyConName tycon) (tyConTyVars tycon) [] sc_theta sc_sel_ids+            [] [] (mkAnd []) tycon++{- *********************************************************************+*                                                                      *+                Multiplicity Polymorphism+*                                                                      *+********************************************************************* -}++{- Multiplicity polymorphism is implemented very similarly to representation+ polymorphism. We write in the multiplicity kind and the One and Many+ types which can appear in user programs. These are defined properly in GHC.Types.++data Multiplicity = One | Many+-}++multiplicityTyConName :: Name+multiplicityTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Multiplicity")+                          multiplicityTyConKey multiplicityTyCon++oneDataConName, manyDataConName :: Name+oneDataConName  = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "One") oneDataConKey oneDataCon+manyDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "Many") manyDataConKey manyDataCon++multiplicityTy :: Type+multiplicityTy = mkTyConTy multiplicityTyCon++multiplicityTyCon :: TyCon+multiplicityTyCon = pcTyCon multiplicityTyConName Nothing []+                            [oneDataCon, manyDataCon]++oneDataCon, manyDataCon :: DataCon+oneDataCon = pcDataCon oneDataConName [] [] multiplicityTyCon+manyDataCon = pcDataCon manyDataConName [] [] multiplicityTyCon++oneDataConTy, manyDataConTy :: Type+oneDataConTy = mkTyConTy oneDataConTyCon+manyDataConTy = mkTyConTy manyDataConTyCon++oneDataConTyCon, manyDataConTyCon :: TyCon+oneDataConTyCon = promoteDataCon oneDataCon+manyDataConTyCon = promoteDataCon manyDataCon++multMulTyConName :: Name+multMulTyConName =+    mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "MultMul") multMulTyConKey multMulTyCon++multMulTyCon :: TyCon+multMulTyCon = mkFamilyTyCon multMulTyConName binders multiplicityTy Nothing+                         (BuiltInSynFamTyCon trivialBuiltInFamily)+                         Nothing+                         NotInjective+  where+    binders = mkTemplateAnonTyConBinders [multiplicityTy, multiplicityTy]++------------------------+-- type (->) :: forall (rep1 :: RuntimeRep) (rep2 :: RuntimeRep).+--              TYPE rep1 -> TYPE rep2 -> Type+-- type (->) = FUN 'Many+unrestrictedFunTyCon :: TyCon+unrestrictedFunTyCon+  = buildSynTyCon unrestrictedFunTyConName [] arrowKind []+                  (TyCoRep.TyConApp fUNTyCon [manyDataConTy])+  where+    arrowKind = mkTyConKind binders liftedTypeKind+    -- See also funTyCon+    binders = [ Bndr runtimeRep1TyVar (NamedTCB Inferred)+              , Bndr runtimeRep2TyVar (NamedTCB Inferred) ]+              ++ mkTemplateAnonTyConBinders [ mkTYPEapp runtimeRep1Ty+                                            , mkTYPEapp runtimeRep2Ty ]++unrestrictedFunTyConName :: Name+unrestrictedFunTyConName = mkWiredInTyConName BuiltInSyntax gHC_TYPES (fsLit "->")+                                              unrestrictedFunTyConKey unrestrictedFunTyCon+++{- *********************************************************************+*                                                                      *+      Type synonyms (all declared in ghc-prim:GHC.Types)++         type CONSTRAINT   :: RuntimeRep -> Type -- primitive; cONSTRAINTKind+         type Constraint   = CONSTRAINT LiftedRep  :: Type    -- constraintKind++         type TYPE         :: RuntimeRep -> Type  -- primitive; tYPEKind+         type Type         = TYPE LiftedRep   :: Type         -- liftedTypeKind+         type UnliftedType = TYPE UnliftedRep :: Type         -- unliftedTypeKind++         type LiftedRep    = BoxedRep Lifted   :: RuntimeRep  -- liftedRepTy+         type UnliftedRep  = BoxedRep Unlifted :: RuntimeRep  -- unliftedRepTy++*                                                                      *+********************************************************************* -}++-- For these synonyms, see+-- Note [TYPE and CONSTRAINT] in GHC.Builtin.Types.Prim, and+-- Note [Using synonyms to compress types] in GHC.Core.Type++{- Note [Naked FunTy]+~~~~~~~~~~~~~~~~~~~~~+GHC.Core.TyCo.Rep.mkFunTy has assertions about the consistency of the argument+flag and arg/res types.  But when constructing the kinds of tYPETyCon and+cONSTRAINTTyCon we don't want to make these checks because+     TYPE :: RuntimeRep -> Type+i.e. TYPE :: RuntimeRep -> TYPE LiftedRep++so the check will loop infinitely.  Hence the use of a naked FunTy+constructor in tTYPETyCon and cONSTRAINTTyCon.+-}+++----------------------+-- type Constraint = CONSTRAINT LiftedRep+constraintKindTyCon :: TyCon+constraintKindTyCon+  = buildSynTyCon constraintKindTyConName [] liftedTypeKind [] rhs+  where+    rhs = TyCoRep.TyConApp cONSTRAINTTyCon [liftedRepTy]++constraintKindTyConName :: Name+constraintKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Constraint")+                                             constraintKindTyConKey constraintKindTyCon++constraintKind :: Kind+constraintKind = mkTyConTy constraintKindTyCon++----------------------+-- type Type = TYPE LiftedRep+liftedTypeKindTyCon :: TyCon+liftedTypeKindTyCon+  = buildSynTyCon liftedTypeKindTyConName [] liftedTypeKind [] rhs+  where+    rhs = TyCoRep.TyConApp tYPETyCon [liftedRepTy]++liftedTypeKindTyConName :: Name+liftedTypeKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Type")+                                             liftedTypeKindTyConKey liftedTypeKindTyCon++liftedTypeKind, typeToTypeKind :: Type+liftedTypeKind = mkTyConTy liftedTypeKindTyCon+typeToTypeKind = liftedTypeKind `mkVisFunTyMany` liftedTypeKind++----------------------+-- type UnliftedType = TYPE ('BoxedRep 'Unlifted)+unliftedTypeKindTyCon :: TyCon+unliftedTypeKindTyCon+  = buildSynTyCon unliftedTypeKindTyConName [] liftedTypeKind [] rhs+  where+    rhs = TyCoRep.TyConApp tYPETyCon [unliftedRepTy]++unliftedTypeKindTyConName :: Name+unliftedTypeKindTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "UnliftedType")+                                                unliftedTypeKindTyConKey unliftedTypeKindTyCon++unliftedTypeKind :: Type+unliftedTypeKind = mkTyConTy unliftedTypeKindTyCon+++{- *********************************************************************+*                                                                      *+      data Levity = Lifted | Unlifted+*                                                                      *+********************************************************************* -}++levityTyConName, liftedDataConName, unliftedDataConName :: Name+levityTyConName     = mkWiredInTyConName   UserSyntax gHC_TYPES (fsLit "Levity")   levityTyConKey     levityTyCon+liftedDataConName   = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "Lifted")   liftedDataConKey   liftedDataCon+unliftedDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "Unlifted") unliftedDataConKey unliftedDataCon++levityTyCon :: TyCon+levityTyCon = pcTyCon levityTyConName Nothing [] [liftedDataCon,unliftedDataCon]++levityTy :: Type+levityTy = mkTyConTy levityTyCon++liftedDataCon, unliftedDataCon :: DataCon+liftedDataCon = pcSpecialDataCon liftedDataConName+    [] levityTyCon (Levity Lifted)+unliftedDataCon = pcSpecialDataCon unliftedDataConName+    [] levityTyCon (Levity Unlifted)++liftedDataConTyCon :: TyCon+liftedDataConTyCon = promoteDataCon liftedDataCon++unliftedDataConTyCon :: TyCon+unliftedDataConTyCon = promoteDataCon unliftedDataCon++liftedDataConTy :: Type+liftedDataConTy = mkTyConTy liftedDataConTyCon++unliftedDataConTy :: Type+unliftedDataConTy = mkTyConTy unliftedDataConTyCon+++{- *********************************************************************+*                                                                      *+    See Note [Wiring in RuntimeRep]+        data RuntimeRep = VecRep VecCount VecElem+                        | TupleRep [RuntimeRep]+                        | SumRep [RuntimeRep]+                        | BoxedRep Levity+                        | IntRep | Int8Rep | ...etc...+*                                                                      *+********************************************************************* -}++{- Note [Wiring in RuntimeRep]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The RuntimeRep type (and friends) in GHC.Types has a bunch of constructors,+making it a pain to wire in. To ease the pain somewhat, we use lists of+the different bits, like Uniques, Names, DataCons. These lists must be+kept in sync with each other. The rule is this: use the order as declared+in GHC.Types. All places where such lists exist should contain a reference+to this Note, so a search for this Note's name should find all the lists.++See also Note [Getting from RuntimeRep to PrimRep] in GHC.Types.RepType.+-}++runtimeRepTyCon :: TyCon+runtimeRepTyCon = pcTyCon runtimeRepTyConName Nothing []+    -- Here we list all the data constructors+    -- of the RuntimeRep data type+    (vecRepDataCon : tupleRepDataCon :+     sumRepDataCon : boxedRepDataCon :+     runtimeRepSimpleDataCons)++runtimeRepTy :: Type+runtimeRepTy = mkTyConTy runtimeRepTyCon++runtimeRepTyConName, vecRepDataConName, tupleRepDataConName, sumRepDataConName, boxedRepDataConName :: Name+runtimeRepTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "RuntimeRep") runtimeRepTyConKey runtimeRepTyCon++vecRepDataConName   = mk_runtime_rep_dc_name (fsLit "VecRep")   vecRepDataConKey   vecRepDataCon+tupleRepDataConName = mk_runtime_rep_dc_name (fsLit "TupleRep") tupleRepDataConKey tupleRepDataCon+sumRepDataConName   = mk_runtime_rep_dc_name (fsLit "SumRep")   sumRepDataConKey   sumRepDataCon+boxedRepDataConName = mk_runtime_rep_dc_name (fsLit "BoxedRep") boxedRepDataConKey boxedRepDataCon++mk_runtime_rep_dc_name :: FastString -> Unique -> DataCon -> Name+mk_runtime_rep_dc_name fs u dc = mkWiredInDataConName UserSyntax gHC_TYPES fs u dc++boxedRepDataCon :: DataCon+boxedRepDataCon = pcSpecialDataCon boxedRepDataConName+  [ levityTy ] runtimeRepTyCon (RuntimeRep prim_rep_fun)+  where+    -- See Note [Getting from RuntimeRep to PrimRep] in RepType+    prim_rep_fun [lev]+      = case tyConAppTyCon_maybe lev of+          Just tc -> case tyConPromDataConInfo tc of+            Levity l -> [BoxedRep (Just l)]+            _        -> [BoxedRep Nothing]+          Nothing    -> [BoxedRep Nothing]+    prim_rep_fun args+      = pprPanic "boxedRepDataCon" (ppr args)+++boxedRepDataConTyCon :: TyCon+boxedRepDataConTyCon = promoteDataCon boxedRepDataCon++tupleRepDataCon :: DataCon+tupleRepDataCon = pcSpecialDataCon tupleRepDataConName [ mkListTy runtimeRepTy ]+                                   runtimeRepTyCon (RuntimeRep prim_rep_fun)+  where+    -- See Note [Getting from RuntimeRep to PrimRep] in GHC.Types.RepType+    prim_rep_fun [rr_ty_list]+      = concatMap (runtimeRepPrimRep doc) rr_tys+      where+        rr_tys = extractPromotedList rr_ty_list+        doc    = text "tupleRepDataCon" <+> ppr rr_tys+    prim_rep_fun args+      = pprPanic "tupleRepDataCon" (ppr args)++tupleRepDataConTyCon :: TyCon+tupleRepDataConTyCon = promoteDataCon tupleRepDataCon++sumRepDataCon :: DataCon+sumRepDataCon = pcSpecialDataCon sumRepDataConName [ mkListTy runtimeRepTy ]+                                 runtimeRepTyCon (RuntimeRep prim_rep_fun)+  where+    -- See Note [Getting from RuntimeRep to PrimRep] in GHC.Types.RepType+    prim_rep_fun [rr_ty_list]+      = map slotPrimRep (toList (ubxSumRepType prim_repss))+      where+        rr_tys     = extractPromotedList rr_ty_list+        doc        = text "sumRepDataCon" <+> ppr rr_tys+        prim_repss = map (runtimeRepPrimRep doc) rr_tys+    prim_rep_fun args+      = pprPanic "sumRepDataCon" (ppr args)++sumRepDataConTyCon :: TyCon+sumRepDataConTyCon = promoteDataCon sumRepDataCon++-- See Note [Wiring in RuntimeRep]+-- See Note [Getting from RuntimeRep to PrimRep] in GHC.Types.RepType+runtimeRepSimpleDataCons :: [DataCon]+runtimeRepSimpleDataCons+  = zipWith mk_runtime_rep_dc runtimeRepSimpleDataConKeys+            [ (fsLit "IntRep",    IntRep)+            , (fsLit "Int8Rep",   Int8Rep)+            , (fsLit "Int16Rep",  Int16Rep)+            , (fsLit "Int32Rep",  Int32Rep)+            , (fsLit "Int64Rep",  Int64Rep)+            , (fsLit "WordRep",   WordRep)+            , (fsLit "Word8Rep",  Word8Rep)+            , (fsLit "Word16Rep", Word16Rep)+            , (fsLit "Word32Rep", Word32Rep)+            , (fsLit "Word64Rep", Word64Rep)+            , (fsLit "AddrRep",   AddrRep)+            , (fsLit "FloatRep",  FloatRep)+            , (fsLit "DoubleRep", DoubleRep) ]+  where+    mk_runtime_rep_dc :: Unique -> (FastString, PrimRep) -> DataCon+    mk_runtime_rep_dc uniq (fs, primrep)+      = data_con+      where+        data_con = pcSpecialDataCon dc_name [] runtimeRepTyCon (RuntimeRep (\_ -> [primrep]))+        dc_name  = mk_runtime_rep_dc_name fs uniq data_con++-- See Note [Wiring in RuntimeRep]+intRepDataConTy,+  int8RepDataConTy, int16RepDataConTy, int32RepDataConTy, int64RepDataConTy,+  wordRepDataConTy,+  word8RepDataConTy, word16RepDataConTy, word32RepDataConTy, word64RepDataConTy,+  addrRepDataConTy,+  floatRepDataConTy, doubleRepDataConTy :: RuntimeRepType+[intRepDataConTy,+   int8RepDataConTy, int16RepDataConTy, int32RepDataConTy, int64RepDataConTy,+   wordRepDataConTy,+   word8RepDataConTy, word16RepDataConTy, word32RepDataConTy, word64RepDataConTy,+   addrRepDataConTy,+   floatRepDataConTy, doubleRepDataConTy+   ]+  = map (mkTyConTy . promoteDataCon) runtimeRepSimpleDataCons++----------------------+-- | @type ZeroBitRep = 'Tuple '[]+zeroBitRepTyCon :: TyCon+zeroBitRepTyCon+  = buildSynTyCon zeroBitRepTyConName [] runtimeRepTy [] rhs+  where+    rhs = TyCoRep.TyConApp tupleRepDataConTyCon [mkPromotedListTy runtimeRepTy []]++zeroBitRepTyConName :: Name+zeroBitRepTyConName  = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "ZeroBitRep")+                                          zeroBitRepTyConKey  zeroBitRepTyCon++zeroBitRepTy :: RuntimeRepType+zeroBitRepTy = mkTyConTy zeroBitRepTyCon++----------------------+-- @type ZeroBitType = TYPE ZeroBitRep+zeroBitTypeTyCon :: TyCon+zeroBitTypeTyCon+  = buildSynTyCon zeroBitTypeTyConName [] liftedTypeKind [] rhs+  where+    rhs = TyCoRep.TyConApp tYPETyCon [zeroBitRepTy]++zeroBitTypeTyConName :: Name+zeroBitTypeTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "ZeroBitType")+                                          zeroBitTypeTyConKey zeroBitTypeTyCon++zeroBitTypeKind :: Type+zeroBitTypeKind = mkTyConTy zeroBitTypeTyCon++----------------------+-- | @type LiftedRep = 'BoxedRep 'Lifted@+liftedRepTyCon :: TyCon+liftedRepTyCon+  = buildSynTyCon liftedRepTyConName [] runtimeRepTy [] rhs+  where+    rhs = TyCoRep.TyConApp boxedRepDataConTyCon [liftedDataConTy]++liftedRepTyConName :: Name+liftedRepTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "LiftedRep")+                                        liftedRepTyConKey liftedRepTyCon++liftedRepTy :: RuntimeRepType+liftedRepTy = mkTyConTy liftedRepTyCon++----------------------+-- | @type UnliftedRep = 'BoxedRep 'Unlifted@+unliftedRepTyCon :: TyCon+unliftedRepTyCon+  = buildSynTyCon unliftedRepTyConName [] runtimeRepTy [] rhs+  where+    rhs = TyCoRep.TyConApp boxedRepDataConTyCon [unliftedDataConTy]++unliftedRepTyConName :: Name+unliftedRepTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "UnliftedRep")+                                          unliftedRepTyConKey unliftedRepTyCon++unliftedRepTy :: RuntimeRepType+unliftedRepTy = mkTyConTy unliftedRepTyCon+++{- *********************************************************************+*                                                                      *+         VecCount, VecElem+*                                                                      *+********************************************************************* -}++vecCountTyConName :: Name+vecCountTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "VecCount") vecCountTyConKey vecCountTyCon++vecElemTyConName :: Name+vecElemTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "VecElem") vecElemTyConKey vecElemTyCon++vecRepDataCon :: DataCon+vecRepDataCon = pcSpecialDataCon vecRepDataConName [ mkTyConTy vecCountTyCon+                                                   , mkTyConTy vecElemTyCon ]+                                 runtimeRepTyCon+                                 (RuntimeRep prim_rep_fun)+  where+    -- See Note [Getting from RuntimeRep to PrimRep] in GHC.Types.RepType+    prim_rep_fun [count, elem]+      | VecCount n <- tyConPromDataConInfo (tyConAppTyCon count)+      , VecElem  e <- tyConPromDataConInfo (tyConAppTyCon elem)+      = [VecRep n e]+    prim_rep_fun args+      = pprPanic "vecRepDataCon" (ppr args)++vecRepDataConTyCon :: TyCon+vecRepDataConTyCon = promoteDataCon vecRepDataCon++vecCountTyCon :: TyCon+vecCountTyCon = pcTyCon vecCountTyConName Nothing [] vecCountDataCons++-- See Note [Wiring in RuntimeRep]+vecCountDataCons :: [DataCon]+vecCountDataCons = zipWith mk_vec_count_dc [1..6] vecCountDataConKeys+  where+    mk_vec_count_dc logN key = con+      where+        n = 2^(logN :: Int)+        name = mk_runtime_rep_dc_name (fsLit ("Vec" ++ show n)) key con+        con = pcSpecialDataCon name [] vecCountTyCon (VecCount n)++-- See Note [Wiring in RuntimeRep]+vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy,+  vec64DataConTy :: Type+[vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy,+  vec64DataConTy] = map (mkTyConTy . promoteDataCon) vecCountDataCons++vecElemTyCon :: TyCon+vecElemTyCon = pcTyCon vecElemTyConName Nothing [] vecElemDataCons++-- See Note [Wiring in RuntimeRep]+vecElemDataCons :: [DataCon]+vecElemDataCons = zipWith3 mk_vec_elem_dc+  [ fsLit "Int8ElemRep", fsLit "Int16ElemRep", fsLit "Int32ElemRep", fsLit "Int64ElemRep"+  , fsLit "Word8ElemRep", fsLit "Word16ElemRep", fsLit "Word32ElemRep", fsLit "Word64ElemRep"+  , fsLit "FloatElemRep", fsLit "DoubleElemRep" ]+  [ Int8ElemRep, Int16ElemRep, Int32ElemRep, Int64ElemRep+  , Word8ElemRep, Word16ElemRep, Word32ElemRep, Word64ElemRep+  , FloatElemRep, DoubleElemRep ]+    vecElemDataConKeys+  where+    mk_vec_elem_dc nameFs elemRep key = con+      where+        name = mk_runtime_rep_dc_name nameFs key con+        con = pcSpecialDataCon name [] vecElemTyCon (VecElem elemRep)++-- See Note [Wiring in RuntimeRep]+int8ElemRepDataConTy, int16ElemRepDataConTy, int32ElemRepDataConTy,+  int64ElemRepDataConTy, word8ElemRepDataConTy, word16ElemRepDataConTy,+  word32ElemRepDataConTy, word64ElemRepDataConTy, floatElemRepDataConTy,+  doubleElemRepDataConTy :: Type+[int8ElemRepDataConTy, int16ElemRepDataConTy, int32ElemRepDataConTy,+  int64ElemRepDataConTy, word8ElemRepDataConTy, word16ElemRepDataConTy,+  word32ElemRepDataConTy, word64ElemRepDataConTy, floatElemRepDataConTy,+  doubleElemRepDataConTy] = map (mkTyConTy . promoteDataCon)+                                vecElemDataCons++{- *********************************************************************+*                                                                      *+     The boxed primitive types: Char, Int, etc+*                                                                      *+********************************************************************* -}++charTy :: Type+charTy = mkTyConTy charTyCon++charTyCon :: TyCon+charTyCon   = pcTyCon charTyConName+                   (Just (CType NoSourceText Nothing+                                  (NoSourceText,fsLit "HsChar")))+                   [] [charDataCon]+charDataCon :: DataCon+charDataCon = pcDataCon charDataConName [] [charPrimTy] charTyCon++stringTy :: Type+stringTy = mkTyConTy stringTyCon++stringTyCon :: TyCon+-- We have this wired-in so that Haskell literal strings+-- get type String (in hsLitType), which in turn influences+-- inferred types and error messages+stringTyCon = buildSynTyCon stringTyConName+                            [] liftedTypeKind []+                            (mkListTy charTy)++intTy :: Type+intTy = mkTyConTy intTyCon++intTyCon :: TyCon+intTyCon = pcTyCon intTyConName+               (Just (CType NoSourceText Nothing (NoSourceText,fsLit "HsInt")))+                 [] [intDataCon]+intDataCon :: DataCon+intDataCon = pcDataCon intDataConName [] [intPrimTy] intTyCon++wordTy :: Type+wordTy = mkTyConTy wordTyCon++wordTyCon :: TyCon+wordTyCon = pcTyCon wordTyConName+            (Just (CType NoSourceText Nothing (NoSourceText, fsLit "HsWord")))+               [] [wordDataCon]+wordDataCon :: DataCon+wordDataCon = pcDataCon wordDataConName [] [wordPrimTy] wordTyCon++word8Ty :: Type+word8Ty = mkTyConTy word8TyCon++word8TyCon :: TyCon+word8TyCon = pcTyCon word8TyConName+                     (Just (CType NoSourceText Nothing+                            (NoSourceText, fsLit "HsWord8"))) []+                     [word8DataCon]+word8DataCon :: DataCon+word8DataCon = pcDataCon word8DataConName [] [word8PrimTy] word8TyCon++floatTy :: Type+floatTy = mkTyConTy floatTyCon++floatTyCon :: TyCon+floatTyCon   = pcTyCon floatTyConName+                      (Just (CType NoSourceText Nothing+                             (NoSourceText, fsLit "HsFloat"))) []+                      [floatDataCon]+floatDataCon :: DataCon+floatDataCon = pcDataCon         floatDataConName [] [floatPrimTy] floatTyCon++doubleTy :: Type+doubleTy = mkTyConTy doubleTyCon++doubleTyCon :: TyCon+doubleTyCon = pcTyCon doubleTyConName+                      (Just (CType NoSourceText Nothing+                             (NoSourceText,fsLit "HsDouble"))) []+                      [doubleDataCon]++doubleDataCon :: DataCon+doubleDataCon = pcDataCon doubleDataConName [] [doublePrimTy] doubleTyCon++{- *********************************************************************+*                                                                      *+              Boxing data constructors+*                                                                      *+********************************************************************* -}++{- Note [Boxing constructors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In ghc-prim:GHC.Types we have a family of data types, one for each RuntimeRep+that "box" unlifted values into a (boxed, lifted) value of kind Type. For example++  type Int8Box :: TYPE Int8Rep -> Type+  data Int8Box (a :: TYPE Int8Rep) = MkInt8Box a+    -- MkInt8Box :: forall (a :: TYPE Int8Rep). a -> Int8Box a++Then we can package an `Int8#` into an `Int8Box` with `MkInt8Box`.  We can also+package up a (lifted) Constraint as a value of kind Type.++There are a fixed number of RuntimeReps, so we only need a fixed number+of boxing types.  (For TupleRep we need to box recursively; not yet done,+see #22336.)++This is used:++* In desugaring, when we need to package up a bunch of values into a tuple,+  for example when desugaring arrows.  See Note [Big tuples] in GHC.Core.Make.++* In let-floating when we want to float an unlifted sub-expression.+  See Note [Floating MFEs of unlifted type] in GHC.Core.Opt.SetLevels++In this module we make wired-in data type declarations for all of+these boxing functions.  The goal is to define boxingDataCon_maybe.++Wrinkles+(W1) The runtime system has special treatment (e.g. commoning up during GC)+     for Int and Char values. See  Note [CHARLIKE and INTLIKE closures] and+     Note [Precomputed static closures] in the RTS.++     So we treat Int# and Char# specially, in specialBoxingDataCon_maybe+-}++data BoxingInfo b+  = BI_NoBoxNeeded   -- The type has kind Type, so there is nothing to do++  | BI_NoBoxAvailable  -- The type does not have kind Type, but sadly we+                       -- don't have a boxing data constructor either++  | BI_Box             -- The type does not have kind Type, and we do have a+                       -- boxing data constructor; here it is+      { bi_data_con   :: DataCon+      , bi_inst_con   :: Expr b+      , bi_boxed_type :: Type }+    -- e.g. BI_Box { bi_data_con = I#, bi_inst_con = I#, bi_boxed_type = Int }+    --        recall: data Int = I# Int#+    --+    --      BI_Box { bi_data_con = MkInt8Box, bi_inst_con = MkInt8Box @ty+    --             , bi_boxed_type = Int8Box ty }+    --        recall: data Int8Box (a :: TYPE Int8Rep) = MkIntBox a++boxingDataCon :: Type -> BoxingInfo b+-- ^ Given a type 'ty', if 'ty' is not of kind Type, return a data constructor that+--   will box it, and the type of the boxed thing, which /does/ now have kind Type.+-- See Note [Boxing constructors]+boxingDataCon ty+  | tcIsLiftedTypeKind kind+  = BI_NoBoxNeeded    -- Fast path for Type++  | Just box_con <- specialBoxingDataCon_maybe ty+  = BI_Box { bi_data_con = box_con, bi_inst_con = mkConApp box_con []+           , bi_boxed_type = tyConNullaryTy (dataConTyCon box_con) }++  | Just box_con <- lookupTypeMap boxingDataConMap kind+  = BI_Box { bi_data_con = box_con, bi_inst_con = mkConApp box_con [Type ty]+           , bi_boxed_type = mkTyConApp (dataConTyCon box_con) [ty] }++  | otherwise+  = BI_NoBoxAvailable++  where+    kind = typeKind ty++specialBoxingDataCon_maybe :: Type -> Maybe DataCon+-- ^ See Note [Boxing constructors] wrinkle (W1)+specialBoxingDataCon_maybe ty+  = case splitTyConApp_maybe ty of+      Just (tc, _) | tc `hasKey` intPrimTyConKey  -> Just intDataCon+                   | tc `hasKey` charPrimTyConKey -> Just charDataCon+      _ -> Nothing++boxingDataConMap :: TypeMap DataCon+-- See Note [Boxing constructors]+boxingDataConMap = foldl add emptyTypeMap boxingDataCons+  where+    add bdcm (kind, boxing_con) = extendTypeMap bdcm kind boxing_con++boxingDataCons :: [(Kind, DataCon)]+-- The Kind is the kind of types for which the DataCon is the right boxing+boxingDataCons = zipWith mkBoxingDataCon+  (map mkBoxingTyConUnique [1..])+  [ (mkTYPEapp wordRepDataConTy, fsLit "WordBox", fsLit "MkWordBox")+  , (mkTYPEapp intRepDataConTy,  fsLit "IntBox",  fsLit "MkIntBox")++  , (mkTYPEapp floatRepDataConTy,  fsLit "FloatBox",  fsLit "MkFloatBox")+  , (mkTYPEapp doubleRepDataConTy,  fsLit "DoubleBox",  fsLit "MkDoubleBox")++  , (mkTYPEapp int8RepDataConTy,  fsLit "Int8Box",  fsLit "MkInt8Box")+  , (mkTYPEapp int16RepDataConTy, fsLit "Int16Box", fsLit "MkInt16Box")+  , (mkTYPEapp int32RepDataConTy, fsLit "Int32Box", fsLit "MkInt32Box")+  , (mkTYPEapp int64RepDataConTy, fsLit "Int64Box", fsLit "MkInt64Box")++  , (mkTYPEapp word8RepDataConTy,  fsLit "Word8Box",   fsLit "MkWord8Box")+  , (mkTYPEapp word16RepDataConTy, fsLit "Word16Box",  fsLit "MkWord16Box")+  , (mkTYPEapp word32RepDataConTy, fsLit "Word32Box",  fsLit "MkWord32Box")+  , (mkTYPEapp word64RepDataConTy, fsLit "Word64Box",  fsLit "MkWord64Box")++  , (unliftedTypeKind, fsLit "LiftBox", fsLit "MkLiftBox")+  , (constraintKind,   fsLit "DictBox", fsLit "MkDictBox") ]++mkBoxingDataCon :: Unique -> (Kind, FastString, FastString) -> (Kind, DataCon)+mkBoxingDataCon uniq_tc (kind, fs_tc, fs_dc)+  = (kind, dc)+  where+    uniq_dc = boxingDataConUnique uniq_tc++    (tv:_) = mkTemplateTyVars (repeat kind)+    tc = pcTyCon tc_name Nothing [tv] [dc]+    tc_name = mkWiredInTyConName UserSyntax gHC_TYPES fs_tc uniq_tc tc++    dc | isConstraintKind kind+       = pcDataConConstraint dc_name [tv] [mkTyVarTy tv] tc+       | otherwise+       = pcDataCon           dc_name [tv] [mkTyVarTy tv] tc+    dc_name = mkWiredInDataConName UserSyntax gHC_TYPES fs_dc uniq_dc dc++{-+************************************************************************+*                                                                      *+              The Bool type+*                                                                      *+************************************************************************++An ordinary enumeration type, but deeply wired in.  There are no+magical operations on @Bool@ (just the regular Prelude code).++{\em BEGIN IDLE SPECULATION BY SIMON}++This is not the only way to encode @Bool@.  A more obvious coding makes+@Bool@ just a boxed up version of @Bool#@, like this:+\begin{verbatim}+type Bool# = Int#+data Bool = MkBool Bool#+\end{verbatim}++Unfortunately, this doesn't correspond to what the Report says @Bool@+looks like!  Furthermore, we get slightly less efficient code (I+think) with this coding. @gtInt@ would look like this:++\begin{verbatim}+gtInt :: Int -> Int -> Bool+gtInt x y = case x of I# x# ->+            case y of I# y# ->+            case (gtIntPrim x# y#) of+                b# -> MkBool b#+\end{verbatim}++Notice that the result of the @gtIntPrim@ comparison has to be turned+into an integer (here called @b#@), and returned in a @MkBool@ box.++The @if@ expression would compile to this:+\begin{verbatim}+case (gtInt x y) of+  MkBool b# -> case b# of { 1# -> e1; 0# -> e2 }+\end{verbatim}++I think this code is a little less efficient than the previous code,+but I'm not certain.  At all events, corresponding with the Report is+important.  The interesting thing is that the language is expressive+enough to describe more than one alternative; and that a type doesn't+necessarily need to be a straightforwardly boxed version of its+primitive counterpart.++{\em END IDLE SPECULATION BY SIMON}+-}++boolTy :: Type+boolTy = mkTyConTy boolTyCon++boolTyCon :: TyCon+boolTyCon = pcTyCon boolTyConName+                    (Just (CType NoSourceText Nothing+                           (NoSourceText, fsLit "HsBool")))+                    [] [falseDataCon, trueDataCon]++falseDataCon, trueDataCon :: DataCon+falseDataCon = pcDataCon falseDataConName [] [] boolTyCon+trueDataCon  = pcDataCon trueDataConName  [] [] boolTyCon++falseDataConId, trueDataConId :: Id+falseDataConId = dataConWorkId falseDataCon+trueDataConId  = dataConWorkId trueDataCon++orderingTyCon :: TyCon+orderingTyCon = pcTyCon orderingTyConName Nothing+                        [] [ordLTDataCon, ordEQDataCon, ordGTDataCon]++ordLTDataCon, ordEQDataCon, ordGTDataCon :: DataCon+ordLTDataCon = pcDataCon ordLTDataConName  [] [] orderingTyCon+ordEQDataCon = pcDataCon ordEQDataConName  [] [] orderingTyCon+ordGTDataCon = pcDataCon ordGTDataConName  [] [] orderingTyCon++ordLTDataConId, ordEQDataConId, ordGTDataConId :: Id+ordLTDataConId = dataConWorkId ordLTDataCon+ordEQDataConId = dataConWorkId ordEQDataCon+ordGTDataConId = dataConWorkId ordGTDataCon++{-+************************************************************************+*                                                                      *+            The List type+   Special syntax, deeply wired in,+   but otherwise an ordinary algebraic data type+*                                                                      *+************************************************************************++       data [] a = [] | a : (List a)+-}++mkListTy :: Type -> Type+mkListTy ty = mkTyConApp listTyCon [ty]++listTyCon :: TyCon+listTyCon = pcTyCon listTyConName Nothing [alphaTyVar] [nilDataCon, consDataCon]++-- See also Note [Empty lists] in GHC.Hs.Expr.+nilDataCon :: DataCon+nilDataCon  = pcDataCon nilDataConName alpha_tyvar [] listTyCon++consDataCon :: DataCon+consDataCon = pcDataConWithFixity True {- Declared infix -}+               consDataConName+               alpha_tyvar [] noConcreteTyVars alpha_tyvar []+               (map linear [alphaTy, mkTyConApp listTyCon alpha_ty])+               listTyCon++-- Interesting: polymorphic recursion would help here.+-- We can't use (mkListTy alphaTy) in the defn of consDataCon, else mkListTy+-- gets the over-specific type (Type -> Type)++-- Wired-in type Maybe++maybeTyCon :: TyCon+maybeTyCon = pcTyCon maybeTyConName Nothing alpha_tyvar+                     [nothingDataCon, justDataCon]++nothingDataCon :: DataCon+nothingDataCon = pcDataCon nothingDataConName alpha_tyvar [] maybeTyCon++justDataCon :: DataCon+justDataCon = pcDataCon justDataConName alpha_tyvar [alphaTy] maybeTyCon++mkPromotedMaybeTy :: Kind -> Maybe Type -> Type+mkPromotedMaybeTy k (Just x) = mkTyConApp promotedJustDataCon [k,x]+mkPromotedMaybeTy k Nothing  = mkTyConApp promotedNothingDataCon [k]++mkMaybeTy :: Type -> Kind+mkMaybeTy t = mkTyConApp maybeTyCon [t]++isPromotedMaybeTy :: Type -> Maybe (Maybe Type)+isPromotedMaybeTy t+  | Just (tc,[_,x]) <- splitTyConApp_maybe t, tc == promotedJustDataCon = return $ Just x+  | Just (tc,[_])   <- splitTyConApp_maybe t, tc == promotedNothingDataCon = return $ Nothing+  | otherwise = Nothing+++{-+** *********************************************************************+*                                                                      *+            The tuple types+*                                                                      *+************************************************************************++The tuple types are definitely magic, because they form an infinite+family.++\begin{itemize}+\item+They have a special family of type constructors, of type @TyCon@+These contain the tycon arity, but don't require a Unique.++\item+They have a special family of constructors, of type+@Id@. Again these contain their arity but don't need a Unique.++\item+There should be a magic way of generating the info tables and+entry code for all tuples.++But at the moment we just compile a Haskell source+file\srcloc{lib/prelude/...} containing declarations like:+\begin{verbatim}+data Tuple0             = Tup0+data Tuple2  a b        = Tup2  a b+data Tuple3  a b c      = Tup3  a b c+data Tuple4  a b c d    = Tup4  a b c d+...+\end{verbatim}+The print-names associated with the magic @Id@s for tuple constructors+``just happen'' to be the same as those generated by these+declarations.++\item+The instance environment should have a magic way to know+that each tuple type is an instances of classes @Eq@, @Ix@, @Ord@ and+so on. \ToDo{Not implemented yet.}++\item+There should also be a way to generate the appropriate code for each+of these instances, but (like the info tables and entry code) it is+done by enumeration\srcloc{lib/prelude/InTup?.hs}.+\end{itemize}+-}++-- | Make a tuple type. The list of types should /not/ include any+-- RuntimeRep specifications. Boxed 1-tuples are flattened.+-- See Note [One-tuples]+mkTupleTy :: Boxity -> [Type] -> Type+-- Special case for *boxed* 1-tuples, which are represented by the type itself+mkTupleTy Boxed   [ty] = ty+mkTupleTy boxity  tys  = mkTupleTy1 boxity tys++-- | Make a tuple type. The list of types should /not/ include any+-- RuntimeRep specifications. Boxed 1-tuples are *not* flattened.+-- See Note [One-tuples] and Note [Don't flatten tuples from HsSyn]+-- in "GHC.Core.Make"+mkTupleTy1 :: Boxity -> [Type] -> Type+mkTupleTy1 Boxed   tys  = mkTyConApp (tupleTyCon Boxed (length tys)) tys+mkTupleTy1 Unboxed tys  = mkTyConApp (tupleTyCon Unboxed (length tys))+                                     (map getRuntimeRep tys ++ tys)++-- | Build the type of a small tuple that holds the specified type of thing+-- Flattens 1-tuples. See Note [One-tuples].+mkBoxedTupleTy :: [Type] -> Type+mkBoxedTupleTy tys = mkTupleTy Boxed tys++unitTy :: Type+unitTy = mkTupleTy Boxed []++-- Make a constraint tuple, flattening a 1-tuple as usual+-- If we get a constraint tuple that is bigger than the pre-built+--   ones (in ghc-prim:GHC.Tuple), then just make one up anyway; it won't+--   have an info table in the RTS, so we can't use it at runtime.  But+--   this is used only in filling in extra-constraint wildcards, so it+--   never is used at runtime anyway+--   See GHC.Tc.Gen.HsType Note [Extra-constraint holes in partial type signatures]+mkConstraintTupleTy :: [Type] -> Type+mkConstraintTupleTy [ty] = ty+mkConstraintTupleTy tys = mkTyConApp (cTupleTyCon (length tys)) tys+++{- *********************************************************************+*                                                                      *+            The sum types+*                                                                      *+************************************************************************+-}++mkSumTy :: [Type] -> Type+mkSumTy tys = mkTyConApp (sumTyCon (length tys))+                         (map getRuntimeRep tys ++ tys)++-- Promoted Booleans++promotedFalseDataCon, promotedTrueDataCon :: TyCon+promotedTrueDataCon   = promoteDataCon trueDataCon+promotedFalseDataCon  = promoteDataCon falseDataCon++-- Promoted Maybe+promotedNothingDataCon, promotedJustDataCon :: TyCon+promotedNothingDataCon = promoteDataCon nothingDataCon+promotedJustDataCon    = promoteDataCon justDataCon++-- Promoted Ordering++promotedLTDataCon+  , promotedEQDataCon+  , promotedGTDataCon+  :: TyCon+promotedLTDataCon     = promoteDataCon ordLTDataCon+promotedEQDataCon     = promoteDataCon ordEQDataCon+promotedGTDataCon     = promoteDataCon ordGTDataCon++-- Promoted List+promotedConsDataCon, promotedNilDataCon :: TyCon+promotedConsDataCon   = promoteDataCon consDataCon+promotedNilDataCon    = promoteDataCon nilDataCon++-- | Make a *promoted* list.+mkPromotedListTy :: Kind   -- ^ of the elements of the list+                 -> [Type] -- ^ elements+                 -> Type+mkPromotedListTy k tys+  = foldr cons nil tys+  where+    cons :: Type  -- element+         -> Type  -- list+         -> Type+    cons elt list = mkTyConApp promotedConsDataCon [k, elt, list]++    nil :: Type+    nil = mkTyConApp promotedNilDataCon [k]++-- | Extract the elements of a promoted list. Panics if the type is not a+-- promoted list+extractPromotedList :: Type    -- ^ The promoted list+                    -> [Type]+extractPromotedList tys = go tys+  where+    go list_ty+      | Just (tc, [_k, t, ts]) <- splitTyConApp_maybe list_ty+      = assert (tc `hasKey` consDataConKey) $+        t : go ts++      | Just (tc, [_k]) <- splitTyConApp_maybe list_ty+      = assert (tc `hasKey` nilDataConKey)+        []++      | otherwise+      = pprPanic "extractPromotedList" (ppr tys)++---------------------------------------+-- ghc-bignum+---------------------------------------++integerTyConName+   , integerISDataConName+   , integerIPDataConName+   , integerINDataConName+   :: Name+integerTyConName+   = mkWiredInTyConName+      UserSyntax+      gHC_INTERNAL_NUM_INTEGER+      (fsLit "Integer")+      integerTyConKey+      integerTyCon+integerISDataConName+   = mkWiredInDataConName+      UserSyntax+      gHC_INTERNAL_NUM_INTEGER+      (fsLit "IS")+      integerISDataConKey+      integerISDataCon+integerIPDataConName+   = mkWiredInDataConName+      UserSyntax+      gHC_INTERNAL_NUM_INTEGER+      (fsLit "IP")+      integerIPDataConKey+      integerIPDataCon+integerINDataConName+   = mkWiredInDataConName+      UserSyntax+      gHC_INTERNAL_NUM_INTEGER+      (fsLit "IN")+      integerINDataConKey+      integerINDataCon++integerTy :: Type+integerTy = mkTyConTy integerTyCon++integerTyCon :: TyCon+integerTyCon = pcTyCon integerTyConName Nothing []+                  [integerISDataCon, integerIPDataCon, integerINDataCon]++integerISDataCon :: DataCon+integerISDataCon = pcDataCon integerISDataConName [] [intPrimTy] integerTyCon++integerIPDataCon :: DataCon+integerIPDataCon = pcDataCon integerIPDataConName [] [byteArrayPrimTy] integerTyCon++integerINDataCon :: DataCon+integerINDataCon = pcDataCon integerINDataConName [] [byteArrayPrimTy] integerTyCon++naturalTyConName+   , naturalNSDataConName+   , naturalNBDataConName+   :: Name+naturalTyConName+   = mkWiredInTyConName+      UserSyntax+      gHC_INTERNAL_NUM_NATURAL+      (fsLit "Natural")+      naturalTyConKey+      naturalTyCon+naturalNSDataConName+   = mkWiredInDataConName+      UserSyntax+      gHC_INTERNAL_NUM_NATURAL+      (fsLit "NS")+      naturalNSDataConKey+      naturalNSDataCon+naturalNBDataConName+   = mkWiredInDataConName+      UserSyntax+      gHC_INTERNAL_NUM_NATURAL+      (fsLit "NB")+      naturalNBDataConKey+      naturalNBDataCon++naturalTy :: Type+naturalTy = mkTyConTy naturalTyCon++naturalTyCon :: TyCon+naturalTyCon = pcTyCon naturalTyConName Nothing []+                  [naturalNSDataCon, naturalNBDataCon]++naturalNSDataCon :: DataCon+naturalNSDataCon = pcDataCon naturalNSDataConName [] [wordPrimTy] naturalTyCon++naturalNBDataCon :: DataCon+naturalNBDataCon = pcDataCon naturalNBDataConName [] [byteArrayPrimTy] naturalTyCon+++{-+************************************************************************+*                                                                      *+   Semi-builtin names+*                                                                      *+************************************************************************++Note [pretendNameIsInScope]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+In general, we filter out instances that mention types whose names are+not in scope. However, in the situations listed below, we make an exception+for some commonly used names, such as Data.Kind.Type, which may not actually+be in scope but should be treated as though they were in scope.+This includes built-in names, as well as a few extra names such as+'Type', 'TYPE', 'BoxedRep', etc.++Situations in which we apply this special logic:++  - GHCi's :info command, see GHC.Runtime.Eval.getInfo.+    This fixes #1581.++  - When reporting instance overlap errors. Not doing so could mean+    that we would omit instances for typeclasses like++      type Cls :: k -> Constraint+      class Cls a++    because BoxedRep/Lifted were not in scope.+    See GHC.Tc.Errors.potentialInstancesErrMsg.+    This fixes one of the issues reported in #20465.+-}++-- | Should this name be considered in-scope, even though it technically isn't?+--+-- This ensures that we don't filter out information because, e.g.,+-- Data.Kind.Type isn't imported.+--+-- See Note [pretendNameIsInScope].+pretendNameIsInScope :: Name -> Bool+pretendNameIsInScope n+  = isBuiltInSyntax n+  || isTupleTyConName n+  || isSumTyConName n+  || isCTupleTyConName n+  || any (n `hasKey`)+    [ liftedTypeKindTyConKey, unliftedTypeKindTyConKey+    , liftedDataConKey, unliftedDataConKey+    , tYPETyConKey+    , cONSTRAINTTyConKey+    , runtimeRepTyConKey, boxedRepDataConKey+    , eqTyConKey+    , listTyConKey+    , oneDataConKey+    , manyDataConKey+    , fUNTyConKey, unrestrictedFunTyConKey ]
GHC/Builtin/Types.hs-boot view
@@ -1,7 +1,7 @@ module GHC.Builtin.Types where  import {-# SOURCE #-} GHC.Core.TyCon    ( TyCon )-import {-# SOURCE #-} GHC.Core.TyCo.Rep (Type, Kind)+import {-# SOURCE #-} GHC.Core.TyCo.Rep (Type, Kind, RuntimeRepType) import {-# SOURCE #-} GHC.Core.DataCon  ( DataCon )  import GHC.Types.Basic (Arity, TupleSort, Boxity, ConTag)@@ -15,9 +15,10 @@ coercibleTyCon, heqTyCon :: TyCon  unitTy :: Type-+unitTyCon :: TyCon  liftedTypeKindTyConName :: Name+constraintKindTyConName :: Name  liftedTypeKind, unliftedTypeKind, zeroBitTypeKind :: Kind @@ -33,7 +34,7 @@ boxedRepDataConTyCon, liftedDataConTyCon :: TyCon vecRepDataConTyCon, tupleRepDataConTyCon :: TyCon -liftedRepTy, unliftedRepTy, zeroBitRepTy :: Type+liftedRepTy, unliftedRepTy, zeroBitRepTy :: RuntimeRepType liftedDataConTy, unliftedDataConTy :: Type  intRepDataConTy,@@ -41,7 +42,7 @@   wordRepDataConTy,   word8RepDataConTy, word16RepDataConTy, word32RepDataConTy, word64RepDataConTy,   addrRepDataConTy,-  floatRepDataConTy, doubleRepDataConTy :: Type+  floatRepDataConTy, doubleRepDataConTy :: RuntimeRepType  vec2DataConTy, vec4DataConTy, vec8DataConTy, vec16DataConTy, vec32DataConTy,   vec64DataConTy :: Type@@ -64,7 +65,7 @@ multMulTyCon :: TyCon  tupleTyConName :: TupleSort -> Arity -> Name-+tupleDataConName :: Boxity -> Arity -> Name  integerTy, naturalTy :: Type
GHC/Builtin/Types/Literals.hs view
@@ -1,1163 +1,1176 @@ {-# LANGUAGE LambdaCase #-}--module GHC.Builtin.Types.Literals-  ( 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.Data.Pair-import GHC.Tc.Utils.TcType ( TcType, tcEqType )-import GHC.Core.TyCon    ( TyCon, FamTyConFlav(..), mkFamilyTyCon-                         , Injectivity(..) )-import GHC.Core.Coercion ( Role(..) )-import GHC.Tc.Types.Constraint ( Xi )-import GHC.Core.Coercion.Axiom ( CoAxiomRule(..), BuiltInSynFamily(..), TypeEqn )-import GHC.Types.Name          ( Name, BuiltInSyntax(..) )-import GHC.Types.Unique.FM-import GHC.Builtin.Types-import GHC.Builtin.Types.Prim  ( mkTemplateAnonTyConBinders )-import GHC.Builtin.Names-                  ( gHC_TYPELITS-                  , gHC_TYPELITS_INTERNAL-                  , gHC_TYPENATS-                  , gHC_TYPENATS_INTERNAL-                  , typeNatAddTyFamNameKey-                  , typeNatMulTyFamNameKey-                  , typeNatExpTyFamNameKey-                  , typeNatSubTyFamNameKey-                  , typeNatDivTyFamNameKey-                  , typeNatModTyFamNameKey-                  , typeNatLogTyFamNameKey-                  , typeNatCmpTyFamNameKey-                  , typeSymbolCmpTyFamNameKey-                  , typeSymbolAppendFamNameKey-                  , typeCharCmpTyFamNameKey-                  , typeConsSymbolTyFamNameKey-                  , typeUnconsSymbolTyFamNameKey-                  , typeCharToNatTyFamNameKey-                  , typeNatToCharTyFamNameKey-                  )-import GHC.Data.FastString-import Control.Monad ( guard )-import Data.List  ( isPrefixOf, isSuffixOf )-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.--* Exposing associated type family axioms--  When defining the type family TyCon, you will need to define an axiom for-  the type family in general (see, for instance, axAddDef), and perhaps other-  auxiliary axioms for special cases of the type family (see, for instance,-  axAdd0L and axAdd0R).--  After you have defined all of these axioms, be sure to include them in the-  typeNatCoAxiomRules list, defined in GHC.Builtin.Types.Literals.-  (Not doing so caused #14934.)--* 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.--}--{--------------------------------------------------------------------------------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-  ]--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--typeNatDivTyCon :: TyCon-typeNatDivTyCon = mkTypeNatFunTyCon2 name-  BuiltInSynFamily-    { sfMatchFam      = matchFamDiv-    , sfInteractTop   = interactTopDiv-    , sfInteractInert = interactInertDiv-    }-  where-  name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "Div")-            typeNatDivTyFamNameKey typeNatDivTyCon--typeNatModTyCon :: TyCon-typeNatModTyCon = mkTypeNatFunTyCon2 name-  BuiltInSynFamily-    { sfMatchFam      = matchFamMod-    , sfInteractTop   = interactTopMod-    , sfInteractInert = interactInertMod-    }-  where-  name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "Mod")-            typeNatModTyFamNameKey typeNatModTyCon--typeNatExpTyCon :: TyCon-typeNatExpTyCon = mkTypeNatFunTyCon2 name-  BuiltInSynFamily-    { sfMatchFam      = matchFamExp-    , sfInteractTop   = interactTopExp-    , sfInteractInert = interactInertExp-    }-  where-  name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "^")-                typeNatExpTyFamNameKey typeNatExpTyCon--typeNatLogTyCon :: TyCon-typeNatLogTyCon = mkTypeNatFunTyCon1 name-  BuiltInSynFamily-    { sfMatchFam      = matchFamLog-    , sfInteractTop   = interactTopLog-    , sfInteractInert = interactInertLog-    }-  where-  name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "Log2")-            typeNatLogTyFamNameKey typeNatLogTyCon----typeNatCmpTyCon :: TyCon-typeNatCmpTyCon =-  mkFamilyTyCon name-    (mkTemplateAnonTyConBinders [ naturalTy, naturalTy ])-    orderingKind-    Nothing-    (BuiltInSynFamTyCon ops)-    Nothing-    NotInjective--  where-  name = mkWiredInTyConName UserSyntax gHC_TYPENATS_INTERNAL (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_INTERNAL (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--typeConsSymbolTyCon :: TyCon-typeConsSymbolTyCon =-  mkFamilyTyCon name-    (mkTemplateAnonTyConBinders [ charTy, typeSymbolKind ])-    typeSymbolKind-    Nothing-    (BuiltInSynFamTyCon ops)-    Nothing-    (Injective [True, True])-  where-  name = mkWiredInTyConName UserSyntax gHC_TYPELITS (fsLit "ConsSymbol")-                  typeConsSymbolTyFamNameKey typeConsSymbolTyCon-  ops = BuiltInSynFamily-      { sfMatchFam      = matchFamConsSymbol-      , sfInteractTop   = interactTopConsSymbol-      , sfInteractInert = interactInertConsSymbol-      }--typeUnconsSymbolTyCon :: TyCon-typeUnconsSymbolTyCon =-  mkFamilyTyCon name-    (mkTemplateAnonTyConBinders [ typeSymbolKind ])-    (mkMaybeTy charSymbolPairKind)-    Nothing-    (BuiltInSynFamTyCon ops)-    Nothing-    (Injective [True])-  where-  name = mkWiredInTyConName UserSyntax gHC_TYPELITS (fsLit "UnconsSymbol")-                  typeUnconsSymbolTyFamNameKey typeUnconsSymbolTyCon-  ops = BuiltInSynFamily-      { sfMatchFam      = matchFamUnconsSymbol-      , sfInteractTop   = interactTopUnconsSymbol-      , sfInteractInert = interactInertUnconsSymbol-      }--typeCharToNatTyCon :: TyCon-typeCharToNatTyCon =-  mkFamilyTyCon name-    (mkTemplateAnonTyConBinders [ charTy ])-    naturalTy-    Nothing-    (BuiltInSynFamTyCon ops)-    Nothing-    (Injective [True])-  where-  name = mkWiredInTyConName UserSyntax gHC_TYPELITS (fsLit "CharToNat")-                  typeCharToNatTyFamNameKey typeCharToNatTyCon-  ops = BuiltInSynFamily-      { sfMatchFam      = matchFamCharToNat-      , sfInteractTop   = interactTopCharToNat-      , sfInteractInert = \_ _ _ _ -> []-      }---typeNatToCharTyCon :: TyCon-typeNatToCharTyCon =-  mkFamilyTyCon name-    (mkTemplateAnonTyConBinders [ naturalTy ])-    charTy-    Nothing-    (BuiltInSynFamTyCon ops)-    Nothing-    (Injective [True])-  where-  name = mkWiredInTyConName UserSyntax gHC_TYPELITS (fsLit "NatToChar")-                  typeNatToCharTyFamNameKey typeNatToCharTyCon-  ops = BuiltInSynFamily-      { sfMatchFam      = matchFamNatToChar-      , sfInteractTop   = interactTopNatToChar-      , sfInteractInert = \_ _ _ _ -> []-      }---- 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--{--------------------------------------------------------------------------------Built-in rules axioms--------------------------------------------------------------------------------}---- If you add additional rules, please remember to add them to--- `typeNatCoAxiomRules` also.--- See Note [Adding built-in type families]-axAddDef-  , axMulDef-  , axExpDef-  , axCmpNatDef-  , axCmpSymbolDef-  , axAppendSymbolDef-  , axConsSymbolDef-  , axUnconsSymbolDef-  , axCharToNatDef-  , axNatToCharDef-  , axAdd0L-  , axAdd0R-  , axMul0L-  , axMul0R-  , axMul1L-  , axMul1R-  , axExp1L-  , axExp0R-  , axExp1R-  , axCmpNatRefl-  , axCmpSymbolRefl-  , axSubDef-  , axSub0R-  , axAppendSymbol0R-  , axAppendSymbol0L-  , axDivDef-  , axDiv1-  , axModDef-  , axMod1-  , axLogDef-  :: CoAxiomRule--axAddDef = mkBinAxiom "AddDef" typeNatAddTyCon isNumLitTy isNumLitTy $-              \x y -> Just $ num (x + y)--axMulDef = mkBinAxiom "MulDef" typeNatMulTyCon isNumLitTy isNumLitTy $-              \x y -> Just $ num (x * y)--axExpDef = mkBinAxiom "ExpDef" typeNatExpTyCon isNumLitTy isNumLitTy $-              \x y -> Just $ num (x ^ y)--axCmpNatDef   = mkBinAxiom "CmpNatDef" typeNatCmpTyCon isNumLitTy isNumLitTy-              $ \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 (lexicalCompareFS 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)-    }--axConsSymbolDef =-  mkBinAxiom "ConsSymbolDef" typeConsSymbolTyCon isCharLitTy isStrLitTy $-    \c str -> Just $ mkStrLitTy (consFS c str)--axUnconsSymbolDef =-  mkUnAxiom "UnconsSymbolDef" typeUnconsSymbolTyCon isStrLitTy $-    \str -> Just $-      mkPromotedMaybeTy charSymbolPairKind (fmap reifyCharSymbolPairTy (unconsFS str))--axCharToNatDef =-  mkUnAxiom "CharToNatDef" typeCharToNatTyCon isCharLitTy $-    \c -> Just $ num (charToInteger c)--axNatToCharDef =-  mkUnAxiom "NatToCharDef" typeNatToCharTyCon isNumLitTy $-    \n -> fmap mkCharLitTy (integerToChar n)--axSubDef = mkBinAxiom "SubDef" typeNatSubTyCon isNumLitTy isNumLitTy $-              \x y -> fmap num (minus x y)--axDivDef = mkBinAxiom "DivDef" typeNatDivTyCon isNumLitTy isNumLitTy $-              \x y -> do guard (y /= 0)-                         return (num (div x y))--axModDef = mkBinAxiom "ModDef" typeNatModTyCon isNumLitTy isNumLitTy $-              \x y -> do guard (y /= 0)-                         return (num (mod x y))--axLogDef = mkUnAxiom "LogDef" typeNatLogTyCon isNumLitTy $-              \x -> do (a,_) <- genLog x 2-                       return (num a)--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-axDiv1      = mkAxiom1 "Div1"     $ \(Pair s t) -> (tDiv s (num 1) === t)-axMod1      = mkAxiom1 "Mod1"     $ \(Pair s _) -> (tMod s (num 1) === num 0)-                                    -- XXX: Shouldn't we check that _ is 0?-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-axCmpNatRefl    = mkAxiom1 "CmpNatRefl"-                $ \(Pair s _) -> (cmpNat s s) === ordering EQ-axCmpSymbolRefl = mkAxiom1 "CmpSymbolRefl"-                $ \(Pair s _) -> (cmpSymbol s s) === ordering EQ-axAppendSymbol0R  = mkAxiom1 "Concat0R"-            $ \(Pair s t) -> (mkStrLitTy nilFS `appendSymbol` s) === t-axAppendSymbol0L  = mkAxiom1 "Concat0L"-            $ \(Pair s t) -> (s `appendSymbol` mkStrLitTy nilFS) === t---- 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 $ map (\x -> (coaxrName x, x))-  [ axAddDef-  , axMulDef-  , axExpDef-  , axCmpNatDef-  , axCmpSymbolDef-  , axCmpCharDef-  , axAppendSymbolDef-  , axConsSymbolDef-  , axUnconsSymbolDef-  , axCharToNatDef-  , axNatToCharDef-  , axAdd0L-  , axAdd0R-  , axMul0L-  , axMul0R-  , axMul1L-  , axMul1R-  , axExp1L-  , axExp0R-  , axExp1R-  , axCmpNatRefl-  , axCmpSymbolRefl-  , axCmpCharRefl-  , axSubDef-  , axSub0R-  , axAppendSymbol0R-  , axAppendSymbol0L-  , axDivDef-  , axDiv1-  , axModDef-  , axMod1-  , axLogDef-  ]----{--------------------------------------------------------------------------------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]--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]--(===) :: Type -> Type -> Pair Type-x === y = Pair x y--num :: Integer -> Type-num = mkNumLitTy--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--known :: (Integer -> Bool) -> TcType -> Bool-known p x = case isNumLitTy x of-              Just a  -> p a-              Nothing -> False--mkUnAxiom :: String -> TyCon -> (Type -> Maybe a) -> (a -> Maybe Type) -> CoAxiomRule-mkUnAxiom str tc isReqTy f =-  CoAxiomRule-    { coaxrName      = fsLit str-    , coaxrAsmpRoles = [Nominal]-    , coaxrRole      = Nominal-    , coaxrProves    = \cs ->-        do [Pair s1 s2] <- return cs-           s2' <- isReqTy s2-           z   <- f s2'-           return (mkTyConApp tc [s1] === z)-    }---- For the definitional axioms-mkBinAxiom :: String -> TyCon ->-              (Type -> Maybe a) ->-              (Type -> Maybe b) ->-              (a -> b -> Maybe Type) -> CoAxiomRule-mkBinAxiom str tc isReqTy1 isReqTy2 f =-  CoAxiomRule-    { coaxrName      = fsLit str-    , coaxrAsmpRoles = [Nominal, Nominal]-    , coaxrRole      = Nominal-    , coaxrProves    = \cs ->-        do [Pair s1 s2, Pair t1 t2] <- return cs-           s2' <- isReqTy1 s2-           t2' <- isReqTy2 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--matchFamDiv :: [Type] -> Maybe (CoAxiomRule, [Type], Type)-matchFamDiv [s,t]-  | Just 1 <- mbY = Just (axDiv1, [s], s)-  | Just x <- mbX, Just y <- mbY, y /= 0 = Just (axDivDef, [s,t], num (div x y))-  where mbX = isNumLitTy s-        mbY = isNumLitTy t-matchFamDiv _ = Nothing--matchFamMod :: [Type] -> Maybe (CoAxiomRule, [Type], Type)-matchFamMod [s,t]-  | Just 1 <- mbY = Just (axMod1, [s], num 0)-  | Just x <- mbX, Just y <- mbY, y /= 0 = Just (axModDef, [s,t], num (mod x y))-  where mbX = isNumLitTy s-        mbY = isNumLitTy t-matchFamMod _ = 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--matchFamLog :: [Type] -> Maybe (CoAxiomRule, [Type], Type)-matchFamLog [s]-  | Just x <- mbX, Just (n,_) <- genLog x 2 = Just (axLogDef, [s], num n)-  where mbX = isNumLitTy s-matchFamLog _ = 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 (lexicalCompareFS 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--matchFamConsSymbol :: [Type] -> Maybe (CoAxiomRule, [Type], Type)-matchFamConsSymbol [s,t]-  | Just x <- mbX, Just y <- mbY =-    Just (axConsSymbolDef, [s,t], mkStrLitTy (consFS x y))-  where-  mbX = isCharLitTy s-  mbY = isStrLitTy t-matchFamConsSymbol _ = Nothing--reifyCharSymbolPairTy :: (Char, FastString) -> Type-reifyCharSymbolPairTy (c, s) = charSymbolPair (mkCharLitTy c) (mkStrLitTy s)--matchFamUnconsSymbol :: [Type] -> Maybe (CoAxiomRule, [Type], Type)-matchFamUnconsSymbol [s]-  | Just x <- mbX =-    Just (axUnconsSymbolDef, [s]-         , mkPromotedMaybeTy charSymbolPairKind (fmap reifyCharSymbolPairTy (unconsFS x)))-  where-  mbX = isStrLitTy s-matchFamUnconsSymbol _ = Nothing--matchFamCharToNat :: [Type] -> Maybe (CoAxiomRule, [Type], Type)-matchFamCharToNat [c]-  | Just c' <- isCharLitTy c, n <- charToInteger c'-  = Just (axCharToNatDef, [c], mkNumLitTy n)-  | otherwise = Nothing-matchFamCharToNat _ = Nothing--matchFamNatToChar :: [Type] -> Maybe (CoAxiomRule, [Type], Type)-matchFamNatToChar [n]-  | Just n' <- isNumLitTy n, Just c <- integerToChar n'-  = Just (axNatToCharDef, [n], mkCharLitTy c)-  | otherwise = Nothing-matchFamNatToChar _ = Nothing--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--{--------------------------------------------------------------------------------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 _ _ = []--interactTopDiv :: [Xi] -> Xi -> [Pair Type]-interactTopDiv _ _ = []   -- I can't think of anything...--interactTopMod :: [Xi] -> Xi -> [Pair Type]-interactTopMod _ _ = []   -- I can't think of anything...--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 _ _ = []--interactTopLog :: [Xi] -> Xi -> [Pair Type]-interactTopLog _ _ = []   -- I can't think of anything...----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 _ _ = []--interactTopConsSymbol :: [Xi] -> Xi -> [Pair Type]-interactTopConsSymbol [s,t] r-  -- ConsSymbol a b ~ "blah" => (a ~ 'b', b ~ "lah")-  | Just fs <- isStrLitTy r-  , Just (x, xs) <- unconsFS fs =-    [ s === mkCharLitTy x, t === mkStrLitTy xs ]--interactTopConsSymbol _ _ = []--interactTopUnconsSymbol :: [Xi] -> Xi -> [Pair Type]-interactTopUnconsSymbol [s] r-  -- (UnconsSymbol b ~ Nothing) => (b ~ "")-  | Just Nothing <- mbX =-    [ s === mkStrLitTy nilFS ]-  -- (UnconsSymbol b ~ Just ('f',"oobar")) => (b ~ "foobar")-  | Just (Just r) <- mbX-  , Just (c, str) <- isPromotedPairType r-  , Just chr <- isCharLitTy c-  , Just str1 <- isStrLitTy str =-    [ s === (mkStrLitTy $ consFS chr str1) ]--  where-  mbX = isPromotedMaybeTy r--interactTopUnconsSymbol _ _ = []--interactTopCharToNat :: [Xi] -> Xi -> [Pair Type]-interactTopCharToNat [s] r-  -- (CharToNat c ~ 122) => (c ~ 'z')-  | Just n <- isNumLitTy r-  , Just c <- integerToChar n-  = [ s === mkCharLitTy c ]-interactTopCharToNat _ _ = []--interactTopNatToChar :: [Xi] -> Xi -> [Pair Type]-interactTopNatToChar [s] r-  -- (NatToChar n ~ 'z') => (n ~ 122)-  | Just c <- isCharLitTy r-  = [ s === mkNumLitTy (charToInteger c) ]-interactTopNatToChar _ _ = []--{--------------------------------------------------------------------------------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 _ _ _ _ = []--interactInertDiv :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type]-interactInertDiv _ _ _ _ = []--interactInertMod :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type]-interactInertMod _ _ _ _ = []--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 _ _ _ _ = []--interactInertLog :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type]-interactInertLog _ _ _ _ = []---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 _ _ _ _ = []---interactInertConsSymbol :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type]-interactInertConsSymbol [x1, y1] z1 [x2, y2] z2-  | sameZ         = [ x1 === x2, y1 === y2 ]-  where sameZ = tcEqType z1 z2-interactInertConsSymbol _ _ _ _ = []--interactInertUnconsSymbol :: [Xi] -> Xi -> [Xi] -> Xi -> [Pair Type]-interactInertUnconsSymbol [x1] z1 [x2] z2-  | tcEqType z1 z2 = [ x1 === x2 ]-interactInertUnconsSymbol _ _ _ _ = []---{- ------------------------------------------------------------------------------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)---------------------------------------------------------------------------------typeCharCmpTyCon :: TyCon-typeCharCmpTyCon =-  mkFamilyTyCon name-    (mkTemplateAnonTyConBinders [ charTy, charTy ])-    orderingKind-    Nothing-    (BuiltInSynFamTyCon ops)-    Nothing-    NotInjective-  where-  name = mkWiredInTyConName UserSyntax gHC_TYPELITS_INTERNAL (fsLit "CmpChar")-                  typeCharCmpTyFamNameKey typeCharCmpTyCon-  ops = BuiltInSynFamily-      { sfMatchFam      = matchFamCmpChar-      , sfInteractTop   = interactTopCmpChar-      , sfInteractInert = \_ _ _ _ -> []-      }--interactTopCmpChar :: [Xi] -> Xi -> [Pair Type]-interactTopCmpChar [s,t] r-  | Just EQ <- isOrderingLitTy r = [ s === t ]-interactTopCmpChar _ _ = []--cmpChar :: Type -> Type -> Type-cmpChar s t = mkTyConApp typeCharCmpTyCon [s,t]--axCmpCharDef, axCmpCharRefl :: CoAxiomRule-axCmpCharDef =-  mkBinAxiom "CmpCharDef" typeCharCmpTyCon isCharLitTy isCharLitTy $-    \chr1 chr2 -> Just $ ordering $ compare chr1 chr2-axCmpCharRefl = mkAxiom1 "CmpCharRefl"-  $ \(Pair s _) -> (cmpChar s s) === ordering EQ--matchFamCmpChar :: [Type] -> Maybe (CoAxiomRule, [Type], Type)-matchFamCmpChar [s,t]-  | Just x <- mbX, Just y <- mbY =-    Just (axCmpCharDef, [s,t], ordering (compare x y))-  | tcEqType s t = Just (axCmpCharRefl, [s], ordering EQ)-  where mbX = isCharLitTy s-        mbY = isCharLitTy t-matchFamCmpChar _ = Nothing+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}   -- See calls to mkTemplateTyVars++module GHC.Builtin.Types.Literals+  ( tryInteractInertFam, tryInteractTopFam, tryMatchFam++  , typeNatTyCons+  , typeNatCoAxiomRules+  , BuiltInSynFamily(..)++    -- If you define a new built-in type family, make sure to export its TyCon+    -- from here as well.+    -- See Note [Adding built-in type families]+  , typeNatAddTyCon+  , typeNatMulTyCon+  , typeNatExpTyCon+  , typeNatSubTyCon+  , typeNatDivTyCon+  , typeNatModTyCon+  , typeNatLogTyCon+  , typeNatCmpTyCon+  , typeSymbolCmpTyCon+  , typeSymbolAppendTyCon+  , typeCharCmpTyCon+  , typeConsSymbolTyCon+  , typeUnconsSymbolTyCon+  , typeCharToNatTyCon+  , typeNatToCharTyCon+  ) where++import GHC.Prelude++import GHC.Core.Type+import GHC.Core.Unify      ( tcMatchTys )+import GHC.Data.Pair+import GHC.Core.TyCon    ( TyCon, FamTyConFlav(..), mkFamilyTyCon, tyConArity+                         , Injectivity(..), isBuiltInSynFamTyCon_maybe )+import GHC.Core.Coercion.Axiom+import GHC.Core.TyCo.Compare   ( tcEqType )+import GHC.Types.Name          ( Name, BuiltInSyntax(..) )+import GHC.Types.Unique.FM+import GHC.Builtin.Types+import GHC.Builtin.Types.Prim  ( mkTemplateAnonTyConBinders, mkTemplateTyVars )+import GHC.Builtin.Names+                  ( gHC_INTERNAL_TYPELITS+                  , gHC_INTERNAL_TYPELITS_INTERNAL+                  , gHC_INTERNAL_TYPENATS+                  , gHC_INTERNAL_TYPENATS_INTERNAL+                  , typeNatAddTyFamNameKey+                  , typeNatMulTyFamNameKey+                  , typeNatExpTyFamNameKey+                  , typeNatSubTyFamNameKey+                  , typeNatDivTyFamNameKey+                  , typeNatModTyFamNameKey+                  , typeNatLogTyFamNameKey+                  , typeNatCmpTyFamNameKey+                  , typeSymbolCmpTyFamNameKey+                  , typeSymbolAppendFamNameKey+                  , typeCharCmpTyFamNameKey+                  , typeConsSymbolTyFamNameKey+                  , typeUnconsSymbolTyFamNameKey+                  , typeCharToNatTyFamNameKey+                  , typeNatToCharTyFamNameKey+                  )+import GHC.Data.FastString+import GHC.Utils.Panic+import GHC.Utils.Outputable++import Control.Monad ( guard )+import Data.List  ( isPrefixOf, isSuffixOf )+import Data.Maybe ( listToMaybe )+import qualified Data.Char as Char++{-+Note [Type-level literals]+~~~~~~~~~~~~~~~~~~~~~~~~~~+There are currently three forms of type-level literals: natural numbers, symbols, and+characters.++Type-level literals are supported by CoAxiomRules (conditional axioms), which+power the built-in type families (see Note [Adding built-in type families]).+Currently, all built-in type families are for the express purpose of supporting+type-level literals.++See also the Wiki page:++    https://gitlab.haskell.org/ghc/ghc/wikis/type-nats++Note [Adding built-in type families]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There are a few steps to adding a built-in type family:++* Adding a unique for the type family TyCon++  These go in GHC.Builtin.Names. It will likely be of the form+  @myTyFamNameKey = mkPreludeTyConUnique xyz@, where @xyz@ is a number that+  has not been chosen before in GHC.Builtin.Names. There are several examples already+  in GHC.Builtin.Names—see, for instance, typeNatAddTyFamNameKey.++* Adding the type family TyCon itself++  This goes in GHC.Builtin.Types.Literals. There are plenty of examples of how to define+  these -- see, for instance, typeNatAddTyCon.++  Once your TyCon has been defined, be sure to:++  - Export it from GHC.Builtin.Types.Literals. (Not doing so caused #14632.)+  - Include it in the typeNatTyCons list, defined in GHC.Builtin.Types.Literals.++* Define the type family somewhere++  Finally, you will need to define the type family somewhere, likely in @base@.+  Currently, all of the built-in type families are defined in GHC.TypeLits or+  GHC.TypeNats, so those are likely candidates.++  Since the behavior of your built-in type family is specified in GHC.Builtin.Types.Literals,+  you should give an open type family definition with no instances, like so:++    type family MyTypeFam (m :: Nat) (n :: Nat) :: Nat++  Changing the argument and result kinds as appropriate.++* Update the relevant test cases++  The GHC test suite will likely need to be updated after you add your built-in+  type family. For instance:++  - The T9181 test prints the :browse contents of GHC.TypeLits, so if you added+    a test there, the expected output of T9181 will need to change.+  - The TcTypeNatSimple and TcTypeSymbolSimple tests have compile-time unit+    tests, as well as TcTypeNatSimpleRun and TcTypeSymbolSimpleRun, which have+    runtime unit tests. Consider adding further unit tests to those if your+    built-in type family deals with Nats or Symbols, respectively.++Note [Inlining axiom constructors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We have a number of constructor functions with types like+   mkUnaryConstFoldAxiom :: TyCon -> String+                         -> (Type -> Maybe a)+                         -> (a -> Maybe Type)+                         -> BuiltInFamRewrite++For very type-family-heavy code, these higher order argument are inefficient;+e.g. the fourth argument might always return (Just ty) in the above. Inlining+them is a bit brutal, but not bad, makes a few-percent difference in, say+perf test T13386.++These functions aren't exported, so the effect is very local.++-}++-------------------------------------------------------------------------------+--     Key utility functions+-------------------------------------------------------------------------------++tryInteractTopFam :: BuiltInSynFamily -> TyCon -> [Type] -> Type+                  -> [(CoAxiomRule, TypeEqn)]+-- The returned CoAxiomRule is always unary+tryInteractTopFam fam fam_tc tys r+  = [(bifinj_axr bif, eqn_out) | bif  <- sfInteract fam+                               , Just eqn_out <- [bifinj_proves bif eqn_in] ]+  where+    eqn_in :: TypeEqn+    eqn_in = Pair (mkTyConApp fam_tc tys) r++tryInteractInertFam :: BuiltInSynFamily -> TyCon+                    -> [Type] -> [Type] -- F tys1 ~ F tys2+                    -> [(CoAxiomRule, TypeEqn)]+tryInteractInertFam builtin_fam fam_tc tys1 tys2+  = [(bifinj_axr bif, eqn_out) | bif <- sfInteract builtin_fam+                               , Just eqn_out <- [bifinj_proves bif eqn_in] ]+  where+    eqn_in = Pair (mkTyConApp fam_tc tys1) (mkTyConApp fam_tc tys2)++tryMatchFam :: BuiltInSynFamily -> [Type]+            -> Maybe (CoAxiomRule, [Type], Type)+-- Does this reduce on the given arguments?+-- If it does, returns (CoAxiomRule, types to instantiate the rule at, rhs type)+-- That is: mkAxiomCo (BuiltInFamRew ax) (map mkNomReflCo ts)+--              :: F tys ~r rhs,+tryMatchFam builtin_fam arg_tys+  = listToMaybe $   -- Pick first rule to match+    [ (bifrw_axr rw_ax, inst_tys, res_ty)+    | rw_ax <- sfMatchFam builtin_fam+    , Just (inst_tys,res_ty) <- [bifrw_match rw_ax arg_tys] ]++-------------------------------------------------------------------------------+--          Constructing BuiltInFamInjectivity, BuiltInFamRewrite+-------------------------------------------------------------------------------++mkUnaryConstFoldAxiom :: TyCon -> String+                      -> (Type -> Maybe a)+                      -> (a -> Maybe Type)+                      -> BuiltInFamRewrite+-- For the definitional axioms, like  (3+4 --> 7)+{-# INLINE mkUnaryConstFoldAxiom #-}  -- See Note [Inlining axiom constructors]+mkUnaryConstFoldAxiom fam_tc str isReqTy f+  = bif+  where+    bif = BIF_Rewrite+      { bifrw_name   = fsLit str+      , bifrw_axr    = BuiltInFamRew bif+      , bifrw_fam_tc = fam_tc+      , bifrw_arity  = 1+      , bifrw_match  = \ts -> do { [t1] <- return ts+                                 ; t1' <- isReqTy t1+                                 ; res <- f t1'+                                 ; return ([t1], res) }+      , bifrw_proves = \cs -> do { [Pair s1 s2] <- return cs+                                 ; s2' <- isReqTy s2+                                 ; z   <- f s2'+                                 ; return (mkTyConApp fam_tc [s1] === z) }+      }++mkBinConstFoldAxiom :: TyCon -> String+                    -> (Type -> Maybe a)+                    -> (Type -> Maybe b)+                    -> (a -> b -> Maybe Type)+                    -> BuiltInFamRewrite+-- For the definitional axioms, like  (3+4 --> 7)+{-# INLINE mkBinConstFoldAxiom #-}  -- See Note [Inlining axiom constructors]+mkBinConstFoldAxiom fam_tc str isReqTy1 isReqTy2 f+  = bif+  where+    bif = BIF_Rewrite+      { bifrw_name   = fsLit str+      , bifrw_axr    = BuiltInFamRew bif+      , bifrw_fam_tc = fam_tc+      , bifrw_arity  = 2+      , bifrw_match  = \ts -> do { [t1,t2] <- return ts+                                 ; t1' <- isReqTy1 t1+                                 ; t2' <- isReqTy2 t2+                                 ; res <- f t1' t2'+                                 ; return ([t1,t2], res) }+      , bifrw_proves = \cs -> do { [Pair s1 s2, Pair t1 t2] <- return cs+                                 ; s2' <- isReqTy1 s2+                                 ; t2' <- isReqTy2 t2+                                 ; z   <- f s2' t2'+                                 ; return (mkTyConApp fam_tc [s1,t1] === z) }+      }++mkRewriteAxiom :: TyCon -> String+               -> [TyVar] -> [Type]  -- LHS of axiom+               -> Type               -- RHS of axiom+               -> BuiltInFamRewrite+-- Not higher order, no benefit in inlining+-- See Note [Inlining axiom constructors]+mkRewriteAxiom fam_tc str tpl_tvs lhs_tys rhs_ty+  = assertPpr (tyConArity fam_tc == length lhs_tys) (text str <+> ppr lhs_tys) $+    bif+  where+    bif = BIF_Rewrite+      { bifrw_name   = fsLit str+      , bifrw_axr    = BuiltInFamRew bif+      , bifrw_fam_tc = fam_tc+      , bifrw_arity  = bif_arity+      , bifrw_match  = match_fn+      , bifrw_proves = inst_fn }++    bif_arity = length tpl_tvs++    match_fn :: [Type] -> Maybe ([Type],Type)+    match_fn arg_tys+      = assertPpr (tyConArity fam_tc == length arg_tys) (text str <+> ppr arg_tys) $+        case tcMatchTys lhs_tys arg_tys of+          Nothing    -> Nothing+          Just subst -> Just (substTyVars subst tpl_tvs, substTy subst rhs_ty)++    inst_fn :: [TypeEqn] -> Maybe TypeEqn+    inst_fn inst_eqns+      = assertPpr (length inst_eqns == bif_arity) (text str $$ ppr inst_eqns) $+        Just (mkTyConApp fam_tc (substTys (zipTCvSubst tpl_tvs tys1) lhs_tys)+              ===+              substTy (zipTCvSubst tpl_tvs tys2) rhs_ty)+      where+        (tys1, tys2) = unzipPairs inst_eqns++mkTopUnaryFamDeduction :: String -> TyCon+                     -> (Type -> Type -> Maybe TypeEqn)+                     -> BuiltInFamInjectivity+-- Deduction from (F s ~ r) where `F` is a unary type function+{-# INLINE mkTopUnaryFamDeduction #-}  -- See Note [Inlining axiom constructors]+mkTopUnaryFamDeduction str fam_tc f+  = bif+  where+    bif = BIF_Interact+      { bifinj_name   = fsLit str+      , bifinj_axr    = BuiltInFamInj bif+      , bifinj_proves = \(Pair lhs rhs)+                        -> do { (tc, [a]) <- splitTyConApp_maybe lhs+                              ; massertPpr (tc == fam_tc) (ppr tc $$ ppr fam_tc)+                              ; f a rhs } }++mkTopBinFamDeduction :: String -> TyCon+                     -> (Type -> Type -> Type -> Maybe TypeEqn)+                     -> BuiltInFamInjectivity+-- Deduction from (F s t  ~ r) where `F` is a binary type function+{-# INLINE mkTopBinFamDeduction #-}  -- See Note [Inlining axiom constructors]+mkTopBinFamDeduction str fam_tc f+  = bif+  where+    bif = BIF_Interact+      { bifinj_name   = fsLit str+      , bifinj_axr    = BuiltInFamInj bif+      , bifinj_proves = \(Pair lhs rhs) ->+                        do { (tc, [a,b]) <- splitTyConApp_maybe lhs+                           ; massertPpr (tc == fam_tc) (ppr tc $$ ppr fam_tc)+                           ; f a b rhs } }++mkUnaryBIF :: String -> TyCon -> BuiltInFamInjectivity+-- Not higher order, no benefit in inlining+-- See Note [Inlining axiom constructors]+mkUnaryBIF str fam_tc+  = bif+  where+    bif = BIF_Interact { bifinj_name   = fsLit str+                       , bifinj_axr    = BuiltInFamInj bif+                       , bifinj_proves = proves }+    proves (Pair lhs rhs)+      = do { (tc2, [x2]) <- splitTyConApp_maybe rhs+           ; guard (tc2 == fam_tc)+           ; (tc1, [x1]) <- splitTyConApp_maybe lhs+           ; massertPpr (tc1 == fam_tc) (ppr tc1 $$ ppr fam_tc)+           ; return (Pair x1 x2) }++mkBinBIF :: String -> TyCon+         -> WhichArg -> WhichArg+         -> (Type -> Bool)         -- The guard on the equal args, if any+         -> BuiltInFamInjectivity+{-# INLINE mkBinBIF #-}  -- See Note [Inlining axiom constructors]+mkBinBIF str fam_tc eq1 eq2 check_me+  = bif+  where+    bif = BIF_Interact { bifinj_name   = fsLit str+                       , bifinj_axr    = BuiltInFamInj bif+                       , bifinj_proves = proves }+    proves (Pair lhs rhs)+      = do { (tc2, [x2,y2]) <- splitTyConApp_maybe rhs+           ; guard (tc2 == fam_tc)+           ; (tc1, [x1,y1]) <- splitTyConApp_maybe lhs+           ; massertPpr (tc1 == fam_tc) (ppr tc1 $$ ppr fam_tc)+           ; case (eq1, eq2) of+               (ArgX,ArgX) -> do_it x1 x2 y1 y2+               (ArgX,ArgY) -> do_it x1 y2 x2 y1+               (ArgY,ArgX) -> do_it y1 x2 y2 x1+               (ArgY,ArgY) -> do_it y1 y2 x1 x2 }++    do_it a1 a2 b1 b2 = do { same a1 a2; guard (check_me a1); return (Pair b1 b2) }++noGuard :: Type -> Bool+noGuard _ = True++numGuard :: (Integer -> Bool) -> Type -> Bool+numGuard pred ty = case isNumLitTy ty of+                      Just n  -> pred n+                      Nothing -> False++data WhichArg = ArgX | ArgY+++-------------------------------------------------------------------------------+--     Built-in type constructors for functions on type-level nats+-------------------------------------------------------------------------------++-- The list of built-in type family TyCons that GHC uses.+-- If you define a built-in type family, make sure to add it to this list.+-- See Note [Adding built-in type families]+typeNatTyCons :: [TyCon]+typeNatTyCons =+  [ typeNatAddTyCon+  , typeNatMulTyCon+  , typeNatExpTyCon+  , typeNatSubTyCon+  , typeNatDivTyCon+  , typeNatModTyCon+  , typeNatLogTyCon+  , typeNatCmpTyCon+  , typeSymbolCmpTyCon+  , typeSymbolAppendTyCon+  , typeCharCmpTyCon+  , typeConsSymbolTyCon+  , typeUnconsSymbolTyCon+  , typeCharToNatTyCon+  , typeNatToCharTyCon+  ]+++-- The list of built-in type family axioms that GHC uses.+-- If you define new axioms, make sure to include them in this list.+-- See Note [Adding built-in type families]+typeNatCoAxiomRules :: UniqFM FastString CoAxiomRule+typeNatCoAxiomRules+  = listToUFM $+    [ pr | tc <- typeNatTyCons+         , Just ops <- [isBuiltInSynFamTyCon_maybe tc]+         , pr <- [ (bifinj_name bif, bifinj_axr bif) | bif <- sfInteract ops ]+              ++ [ (bifrw_name bif,  bifrw_axr bif)  | bif <- sfMatchFam ops ] ]++-------------------------------------------------------------------------------+--                   Addition (+)+-------------------------------------------------------------------------------++typeNatAddTyCon :: TyCon+typeNatAddTyCon = mkTypeNatFunTyCon2 name+  BuiltInSynFamily+    { sfMatchFam  = axAddRewrites+    , sfInteract  = axAddInjectivity+    }+  where+    name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPENATS (fsLit "+")+              typeNatAddTyFamNameKey typeNatAddTyCon+++sn,tn :: TyVar  -- Of kind Natural+(sn: tn: _) = mkTemplateTyVars (repeat typeSymbolKind)++axAddRewrites :: [BuiltInFamRewrite]+axAddRewrites+  = [ mkRewriteAxiom   tc "Add0L" [tn] [num 0, var tn] (var tn)   -- 0 + t --> t+    , mkRewriteAxiom   tc "Add0R" [sn] [var sn, num 0] (var sn)   -- s + 0 --> s+    , mkBinConstFoldAxiom tc "AddDef" isNumLitTy isNumLitTy $     -- 3 + 4 --> 7+      \x y -> Just $ num (x + y) ]+  where+    tc = typeNatAddTyCon++axAddInjectivity :: [BuiltInFamInjectivity]+axAddInjectivity+  = [ -- (s + t ~ 0) => (s ~ 0)+      mkTopBinFamDeduction "AddT-0L" tc $ \ a _b r ->+      do { _ <- known r (== 0); return (Pair a (num 0)) }++    , -- (s + t ~ 0) => (t ~ 0)+      mkTopBinFamDeduction "AddT-0R" tc $ \ _a b r ->+      do { _ <- known r (== 0); return (Pair b (num 0)) }++    , -- (5 + t ~ 8) => (t ~ 3)+      mkTopBinFamDeduction "AddT-KKL" tc $ \ a b r ->+      do { na <- isNumLitTy a; nr <- known r (>= na); return (Pair b (num (nr-na))) }++    , -- (s + 5 ~ 8) => (s ~ 3)+      mkTopBinFamDeduction "AddT-KKR" tc $ \ a b r ->+      do { nb <- isNumLitTy b; nr <- known r (>= nb); return (Pair a (num (nr-nb))) }++    , mkBinBIF "AddI-xx" tc ArgX ArgX noGuard  -- x1+y1~x2+y2 {x1=x2}=> (y1 ~ y2)+    , mkBinBIF "AddI-xy" tc ArgX ArgY noGuard  -- x1+y1~x2+y2 {x1=y2}=> (x2 ~ y1)+    , mkBinBIF "AddI-yx" tc ArgY ArgX noGuard  -- x1+y1~x2+y2 {y1=x2}=> (x1 ~ y2)+    , mkBinBIF "AddI-yy" tc ArgY ArgY noGuard  -- x1+y1~x2+y2 {y1=y2}=> (x1 ~ x2)+    ]+  where+    tc = typeNatAddTyCon++-------------------------------------------------------------------------------+--                   Subtraction (-)+-------------------------------------------------------------------------------++typeNatSubTyCon :: TyCon+typeNatSubTyCon = mkTypeNatFunTyCon2 name+  BuiltInSynFamily+    { sfMatchFam = axSubRewrites+    , sfInteract = axSubInjectivity+    }+  where+  name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPENATS (fsLit "-")+            typeNatSubTyFamNameKey typeNatSubTyCon++axSubRewrites :: [BuiltInFamRewrite]+axSubRewrites+  = [ mkRewriteAxiom   tc "Sub0R" [sn] [var sn, num 0] (var sn)   -- s - 0 --> s+    , mkBinConstFoldAxiom tc "SubDef" isNumLitTy isNumLitTy $     -- 4 - 3 --> 1  if x>=y+      \x y -> fmap num (minus x y) ]+  where+    tc = typeNatSubTyCon++axSubInjectivity :: [BuiltInFamInjectivity]+axSubInjectivity+  = [ -- (a - b ~ 5) => (5 + b ~ a)+      mkTopBinFamDeduction "SubT" tc $ \ a b r ->+      do { _ <- isNumLitTy r; return (Pair (r .+. b) a) }++    , mkBinBIF "SubI-xx" tc ArgX ArgX noGuard -- (x-y1 ~ x-y2) => (y1 ~ y2)+    , mkBinBIF "SubI-yy" tc ArgY ArgY noGuard -- (x1-y ~ x2-y) => (x1 ~ x2)+    ]+  where+    tc = typeNatSubTyCon++{-+Note [Weakened interaction rule for subtraction]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A simpler interaction here might be:++  `s - t ~ r` --> `t + r ~ s`++This would enable us to reuse all the code for addition.+Unfortunately, this works a little too well at the moment.+Consider the following example:++    0 - 5 ~ r --> 5 + r ~ 0 --> (5 = 0, r = 0)++This (correctly) spots that the constraint cannot be solved.++However, this may be a problem if the constraint did not+need to be solved in the first place!  Consider the following example:++f :: Proxy (If (5 <=? 0) (0 - 5) (5 - 0)) -> Proxy 5+f = id++Currently, GHC is strict while evaluating functions, so this does not+work, because even though the `If` should evaluate to `5 - 0`, we+also evaluate the "then" branch which generates the constraint `0 - 5 ~ r`,+which fails.++So, for the time being, we only add an improvement when the RHS is a constant,+which happens to work OK for the moment, although clearly we need to do+something more general.+-}+++-------------------------------------------------------------------------------+--                   Multiplication (*)+-------------------------------------------------------------------------------++typeNatMulTyCon :: TyCon+typeNatMulTyCon = mkTypeNatFunTyCon2 name+  BuiltInSynFamily { sfMatchFam = axMulRewrites+                   , sfInteract = axMulInjectivity  }+  where+    name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPENATS (fsLit "*")+              typeNatMulTyFamNameKey typeNatMulTyCon++axMulRewrites :: [BuiltInFamRewrite]+axMulRewrites+  = [ mkRewriteAxiom   tc "Mul0L" [tn] [num 0, var tn] (num 0)   -- 0 * t --> 0+    , mkRewriteAxiom   tc "Mul0R" [sn] [var sn, num 0] (num 0)   -- s * 0 --> 0+    , mkRewriteAxiom   tc "Mul1L" [tn] [num 1, var tn] (var tn)  -- 1 * t --> t+    , mkRewriteAxiom   tc "Mul1R" [sn] [var sn, num 1] (var sn)  -- s * 1 --> s+    , mkBinConstFoldAxiom tc "MulDef" isNumLitTy isNumLitTy $    -- 3 + 4 --> 12+      \x y -> Just $ num (x * y) ]+  where+    tc = typeNatMulTyCon++axMulInjectivity :: [BuiltInFamInjectivity]+axMulInjectivity+  = [ -- (s * t ~ 1)  => (s ~ 1)+      mkTopBinFamDeduction "MulT1" tc $ \ s _t r ->+      do { _ <- known r (== 1); return (Pair s r) }++    , -- (s * t ~ 1)  => (t ~ 1)+      mkTopBinFamDeduction "MulT2" tc $ \ _s t r ->+      do { _ <- known r (== 1); return (Pair t r) }++    , -- (3 * t ~ 15) => (t ~ 5)+      mkTopBinFamDeduction "MulT3" tc $ \ s t r ->+      do { ns <- isNumLitTy s; nr <- isNumLitTy r; y <- divide nr ns; return (Pair t (num y)) }++    , -- (s * 3 ~ 15) => (s ~ 5)+      mkTopBinFamDeduction "MulT4" tc $ \ s t r ->+      do { nt <- isNumLitTy t; nr <- isNumLitTy r; y <- divide nr nt; return (Pair s (num y)) }++    , mkBinBIF "MulI-xx" tc ArgX ArgX (numGuard (/= 0))    -- (x*y1 ~ x*y2) {x/=0}=> (y1 ~ y2)+    , mkBinBIF "MulI-yy" tc ArgY ArgY (numGuard (/= 0))    -- (x1*y ~ x2*y) {y/=0}=> (x1 ~ x2)+    ]+  where+    tc = typeNatMulTyCon+++-------------------------------------------------------------------------------+--                   Division: Div and Mod+-------------------------------------------------------------------------------++typeNatDivTyCon :: TyCon+typeNatDivTyCon = mkTypeNatFunTyCon2 name+  BuiltInSynFamily { sfMatchFam = axDivRewrites+                   , sfInteract = [] }+  where+  name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPENATS (fsLit "Div")+            typeNatDivTyFamNameKey typeNatDivTyCon++typeNatModTyCon :: TyCon+typeNatModTyCon = mkTypeNatFunTyCon2 name+  BuiltInSynFamily { sfMatchFam = axModRewrites+                   , sfInteract = [] }+  where+  name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPENATS (fsLit "Mod")+            typeNatModTyFamNameKey typeNatModTyCon++axDivRewrites :: [BuiltInFamRewrite]+axDivRewrites+  = [ mkRewriteAxiom   tc "Div1" [sn] [var sn, num 1] (var sn)   -- s `div` 1 --> s+    , mkBinConstFoldAxiom tc "DivDef" isNumLitTy isNumLitTy $    -- 8 `div` 4 --> 2+      \x y -> do { guard (y /= 0); return (num (div x y)) } ]+  where+    tc = typeNatDivTyCon++axModRewrites :: [BuiltInFamRewrite]+axModRewrites+  = [ mkRewriteAxiom   tc "Mod1" [sn] [var sn, num 1] (num 0)   -- s `mod` 1 --> 0+    , mkBinConstFoldAxiom tc "ModDef" isNumLitTy isNumLitTy $   -- 8 `mod` 3 --> 2+      \x y -> do { guard (y /= 0); return (num (mod x y)) } ]+  where+    tc = typeNatModTyCon++-------------------------------------------------------------------------------+--                   Exponentiation: Exp+-------------------------------------------------------------------------------++typeNatExpTyCon :: TyCon  -- Exponentiation+typeNatExpTyCon = mkTypeNatFunTyCon2 name+  BuiltInSynFamily { sfMatchFam = axExpRewrites+                   , sfInteract = axExpInjectivity }+  where+  name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPENATS (fsLit "^")+                typeNatExpTyFamNameKey typeNatExpTyCon++axExpRewrites :: [BuiltInFamRewrite]+axExpRewrites+  = [ mkRewriteAxiom   tc "Exp0R" [sn] [var sn, num 0] (num 1)   -- s ^ 0 --> 1+    , mkRewriteAxiom   tc "Exp1L" [tn] [num 1, var tn] (num 1)   -- 1 ^ t --> 1+    , mkRewriteAxiom   tc "Exp1R" [sn] [var sn, num 1] (var sn)  -- s ^ 1 --> s+    , mkBinConstFoldAxiom tc "ExpDef" isNumLitTy isNumLitTy $    -- 2 ^ 3 --> 8+      \x y -> Just (num (x ^ y)) ]+  where+    tc = typeNatExpTyCon++axExpInjectivity :: [BuiltInFamInjectivity]+axExpInjectivity+  = [ -- (s ^ t ~ 0) => (s ~ 0)+      mkTopBinFamDeduction "ExpT1" tc $ \ s _t r ->+      do { 0 <- isNumLitTy r; return (Pair s r) }++    , -- (2 ^ t ~ 8) => (t ~ 3)+      mkTopBinFamDeduction "ExpT2" tc $ \ s t r ->+      do { ns <- isNumLitTy s; nr <- isNumLitTy r; y <- logExact nr ns; return (Pair t (num y)) }++    , -- (s ^ 2 ~ 9) => (s ~ 3)+      mkTopBinFamDeduction "ExpT3" tc $ \ s t r ->+      do { nt <- isNumLitTy t; nr <- isNumLitTy r; y <- rootExact nr nt; return (Pair s (num y)) }++    , mkBinBIF "ExpI-xx" tc ArgX ArgX (numGuard (> 1))    -- (x^y1 ~ x^y2) {x>1}=> (y1 ~ y2)+    , mkBinBIF "ExpI-yy" tc ArgY ArgY (numGuard (/= 0))   -- (x1*y ~ x2*y) {y/=0}=> (x1 ~ x2)+    ]+  where+    tc = typeNatExpTyCon++-------------------------------------------------------------------------------+--                   Logarithm: Log2+-------------------------------------------------------------------------------++typeNatLogTyCon :: TyCon+typeNatLogTyCon = mkTypeNatFunTyCon1 name+  BuiltInSynFamily { sfMatchFam = axLogRewrites+                   , sfInteract = [] }+  where+  name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPENATS (fsLit "Log2")+            typeNatLogTyFamNameKey typeNatLogTyCon++axLogRewrites :: [BuiltInFamRewrite]+axLogRewrites+  = [ mkUnaryConstFoldAxiom tc "LogDef" isNumLitTy $       -- log 8 --> 3+      \x -> do { (a,_) <- genLog x 2; return (num a) } ]+  where+    tc = typeNatLogTyCon++-------------------------------------------------------------------------------+--               Comparision of Nats: CmpNat+-------------------------------------------------------------------------------++typeNatCmpTyCon :: TyCon+typeNatCmpTyCon+  = mkFamilyTyCon name+      (mkTemplateAnonTyConBinders [ naturalTy, naturalTy ])+      orderingKind+      Nothing+      (BuiltInSynFamTyCon ops)+      Nothing+      NotInjective++  where+    name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPENATS_INTERNAL (fsLit "CmpNat")+                  typeNatCmpTyFamNameKey typeNatCmpTyCon+    ops = BuiltInSynFamily { sfMatchFam = axCmpNatRewrites+                           , sfInteract = axCmpNatInjectivity }++axCmpNatRewrites :: [BuiltInFamRewrite]+axCmpNatRewrites+  = [ mkRewriteAxiom   tc "CmpNatRefl" [sn] [var sn, var sn] (ordering EQ)    -- s `cmp` s --> EQ+    , mkBinConstFoldAxiom tc "CmpNatDef" isNumLitTy isNumLitTy $              -- 2 `cmp` 3 --> LT+      \x y -> Just (ordering (compare x y)) ]+  where+    tc = typeNatCmpTyCon++axCmpNatInjectivity :: [BuiltInFamInjectivity]+axCmpNatInjectivity+  = [ -- s `cmp` t ~ EQ   ==>   s ~ t+      mkTopBinFamDeduction "CmpNatT3" typeNatCmpTyCon $ \ s t r ->+      do { EQ <- isOrderingLitTy r; return (Pair s t) } ]++-------------------------------------------------------------------------------+--              Comparsion of Symbols: CmpSymbol+-------------------------------------------------------------------------------++typeSymbolCmpTyCon :: TyCon+typeSymbolCmpTyCon =+  mkFamilyTyCon name+    (mkTemplateAnonTyConBinders [typeSymbolKind, typeSymbolKind])+    orderingKind+    Nothing+    (BuiltInSynFamTyCon ops)+    Nothing+    NotInjective++  where+  name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPELITS_INTERNAL (fsLit "CmpSymbol")+                typeSymbolCmpTyFamNameKey typeSymbolCmpTyCon+  ops = BuiltInSynFamily { sfMatchFam = axSymbolCmpRewrites+                         , sfInteract = axSymbolCmpInjectivity }++ss,ts :: TyVar  -- Of kind Symbol+(ss: ts: _) = mkTemplateTyVars (repeat typeSymbolKind)++axSymbolCmpRewrites :: [BuiltInFamRewrite]+axSymbolCmpRewrites+  = [ mkRewriteAxiom   tc "CmpSymbolRefl" [ss] [var ss, var ss] (ordering EQ) -- s `cmp` s --> EQ+    , mkBinConstFoldAxiom tc "CmpSymbolDef" isStrLitTy isStrLitTy $           -- "a" `cmp` "b" --> LT+      \x y -> Just (ordering (lexicalCompareFS x y)) ]+  where+    tc = typeSymbolCmpTyCon++axSymbolCmpInjectivity :: [BuiltInFamInjectivity]+axSymbolCmpInjectivity+  = [ mkTopBinFamDeduction "CmpSymbolT" typeSymbolCmpTyCon $ \ s t r ->+      do { EQ <- isOrderingLitTy r; return (Pair s t) } ]+++-------------------------------------------------------------------------------+--            AppendSymbol+-------------------------------------------------------------------------------++typeSymbolAppendTyCon :: TyCon+typeSymbolAppendTyCon = mkTypeSymbolFunTyCon2 name+  BuiltInSynFamily { sfMatchFam = axAppendRewrites+                   , sfInteract = axAppendInjectivity }+  where+  name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPELITS (fsLit "AppendSymbol")+                typeSymbolAppendFamNameKey typeSymbolAppendTyCon++axAppendRewrites :: [BuiltInFamRewrite]+axAppendRewrites+  = [ mkRewriteAxiom   tc "Concat0R" [ts] [nullStrLitTy, var ts] (var ts) -- "" ++ t --> t+    , mkRewriteAxiom   tc "Concat0L" [ss] [var ss, nullStrLitTy] (var ss) -- s ++ "" --> s+    , mkBinConstFoldAxiom tc "AppendSymbolDef" isStrLitTy isStrLitTy $    -- "a" ++ "b" --> "ab"+      \x y -> Just (mkStrLitTy (appendFS x y)) ]+  where+    tc = typeSymbolAppendTyCon++axAppendInjectivity :: [BuiltInFamInjectivity]+axAppendInjectivity+ = [ -- (AppendSymbol a b ~ "") => (a ~ "")+     mkTopBinFamDeduction "AppendSymbolT1" tc $ \ a _b r ->+     do { rs <- isStrLitTy r; guard (nullFS rs); return (Pair a nullStrLitTy) }++   , -- (AppendSymbol a b ~ "") => (b ~ "")+     mkTopBinFamDeduction "AppendSymbolT2" tc $ \ _a b r ->+     do { rs <- isStrLitTy r; guard (nullFS rs); return (Pair b nullStrLitTy) }++   , -- (AppendSymbol "foo" b ~ "foobar") => (b ~ "bar")+     mkTopBinFamDeduction "AppendSymbolT3" tc $ \ a b r ->+     do { as <- isStrLitTyS a; rs <- isStrLitTyS r; guard (as `isPrefixOf` rs)+        ; return (Pair b (mkStrLitTyS (drop (length as) rs))) }++   , -- (AppendSymbol f "bar" ~ "foobar") => (f ~ "foo")+     mkTopBinFamDeduction "AppendSymbolT3" tc $ \ a b r ->+     do { bs <- isStrLitTyS b; rs <- isStrLitTyS r; guard (bs `isSuffixOf` rs)+        ; return (Pair a (mkStrLitTyS (take (length rs - length bs) rs))) }++    , mkBinBIF "AppI-xx" tc ArgX ArgX noGuard  -- (x++y1 ~ x++y2) => (y1 ~ y2)+    , mkBinBIF "AppI-yy" tc ArgY ArgY noGuard  -- (x1++y ~ x2++y) => (x1 ~ x2)+    ]+  where+    tc = typeSymbolAppendTyCon++-------------------------------------------------------------------------------+--            ConsSymbol+-------------------------------------------------------------------------------++typeConsSymbolTyCon :: TyCon+typeConsSymbolTyCon =+  mkFamilyTyCon name+    (mkTemplateAnonTyConBinders [ charTy, typeSymbolKind ])+    typeSymbolKind+    Nothing+    (BuiltInSynFamTyCon ops)+    Nothing+    (Injective [True, True])+  where+  name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPELITS (fsLit "ConsSymbol")+                  typeConsSymbolTyFamNameKey typeConsSymbolTyCon+  ops = BuiltInSynFamily  { sfMatchFam = axConsRewrites+                          , sfInteract = axConsInjectivity }++axConsRewrites :: [BuiltInFamRewrite]+axConsRewrites+  = [ mkBinConstFoldAxiom tc "ConsSymbolDef" isCharLitTy isStrLitTy $    -- 'a' : "bc" --> "abc"+      \x y -> Just $ mkStrLitTy (consFS x y) ]+  where+    tc = typeConsSymbolTyCon++axConsInjectivity :: [BuiltInFamInjectivity]+axConsInjectivity+  = [ -- ConsSymbol a b ~ "blah" => (a ~ 'b')+      mkTopBinFamDeduction "ConsSymbolT1" tc $ \ a _b r ->+      do { rs <- isStrLitTy r; (x,_) <- unconsFS rs; return (Pair a (mkCharLitTy x)) }++    , -- ConsSymbol a b ~ "blah" => (b ~ "lah")+      mkTopBinFamDeduction "ConsSymbolT2" tc $ \ _a b r ->+      do { rs <- isStrLitTy r; (_,xs) <- unconsFS rs; return (Pair b (mkStrLitTy xs)) }+++    , mkBinBIF "ConsI-xx" tc ArgX ArgX noGuard  -- (x:y1 ~ x:y2) => (y1 ~ y2)+    , mkBinBIF "ConsI-yy" tc ArgY ArgY noGuard  -- (x1:y ~ x2:y) => (x1 ~ x2)+    ]+  where+    tc = typeConsSymbolTyCon++-------------------------------------------------------------------------------+--            UnconsSymbol+-------------------------------------------------------------------------------++typeUnconsSymbolTyCon :: TyCon+typeUnconsSymbolTyCon =+  mkFamilyTyCon name+    (mkTemplateAnonTyConBinders [ typeSymbolKind ])+    (mkMaybeTy charSymbolPairKind)+    Nothing+    (BuiltInSynFamTyCon ops)+    Nothing+    (Injective [True])+  where+  name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPELITS (fsLit "UnconsSymbol")+                  typeUnconsSymbolTyFamNameKey typeUnconsSymbolTyCon+  ops = BuiltInSynFamily { sfMatchFam = axUnconsRewrites+                         , sfInteract = axUnconsInjectivity }++computeUncons :: FastString -> Type+computeUncons str+  = mkPromotedMaybeTy charSymbolPairKind (fmap reify (unconsFS str))+  where+    reify :: (Char, FastString) -> Type+    reify (c, s) = charSymbolPair (mkCharLitTy c) (mkStrLitTy s)++axUnconsRewrites :: [BuiltInFamRewrite]+axUnconsRewrites+  = [ mkUnaryConstFoldAxiom tc "ConsSymbolDef" isStrLitTy $    -- 'a' : "bc" --> "abc"+      \x -> Just $ computeUncons x ]+  where+    tc = typeUnconsSymbolTyCon++axUnconsInjectivity :: [BuiltInFamInjectivity]+axUnconsInjectivity+  = [ -- (UnconsSymbol b ~ Nothing) => (b ~ "")+      mkTopUnaryFamDeduction "UnconsSymbolT1" tc $ \b r ->+      do { Nothing  <- isPromotedMaybeTy r; return (Pair b nullStrLitTy) }++    , -- (UnconsSymbol b ~ Just ('f',"oobar")) => (b ~ "foobar")+      mkTopUnaryFamDeduction "UnconsSymbolT2" tc $ \b r ->+      do { Just pr <- isPromotedMaybeTy r+         ; (c,s) <- isPromotedPairType pr+         ; chr <- isCharLitTy c+         ; str <- isStrLitTy s+         ; return (Pair b (mkStrLitTy (consFS chr str))) }++    , mkUnaryBIF "UnconsI1" tc  -- (UnconsSymbol x1 ~ z, UnconsSymbol x2 ~ z) => (x1 ~ x2)+    ]+  where+    tc = typeUnconsSymbolTyCon++-------------------------------------------------------------------------------+--            CharToNat+-------------------------------------------------------------------------------++typeCharToNatTyCon :: TyCon+typeCharToNatTyCon =+  mkFamilyTyCon name+    (mkTemplateAnonTyConBinders [ charTy ])+    naturalTy+    Nothing+    (BuiltInSynFamTyCon ops)+    Nothing+    (Injective [True])+  where+  name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPELITS (fsLit "CharToNat")+                  typeCharToNatTyFamNameKey typeCharToNatTyCon+  ops = BuiltInSynFamily { sfMatchFam = axCharToNatRewrites+                         , sfInteract = axCharToNatInjectivity }++axCharToNatRewrites :: [BuiltInFamRewrite]+axCharToNatRewrites+  = [ mkUnaryConstFoldAxiom tc "CharToNatDef" isCharLitTy $    -- CharToNat 'a' --> 97+      \x -> Just $ num (charToInteger x) ]+  where+    tc = typeCharToNatTyCon++axCharToNatInjectivity :: [BuiltInFamInjectivity]+axCharToNatInjectivity+  = [ -- (CharToNat c ~ 122) => (c ~ 'z')+      mkTopUnaryFamDeduction "CharToNatT1" typeCharToNatTyCon $ \c r ->+      do { nr <- isNumLitTy r; chr <- integerToChar nr; return (Pair c (mkCharLitTy chr)) } ]++-------------------------------------------------------------------------------+--            NatToChar+-------------------------------------------------------------------------------++typeNatToCharTyCon :: TyCon+typeNatToCharTyCon =+  mkFamilyTyCon name+    (mkTemplateAnonTyConBinders [ naturalTy ])+    charTy+    Nothing+    (BuiltInSynFamTyCon ops)+    Nothing+    (Injective [True])+  where+  name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPELITS (fsLit "NatToChar")+                  typeNatToCharTyFamNameKey typeNatToCharTyCon+  ops = BuiltInSynFamily { sfMatchFam = axNatToCharRewrites+                         , sfInteract = axNatToCharInjectivity }++axNatToCharRewrites :: [BuiltInFamRewrite]+axNatToCharRewrites+  = [ mkUnaryConstFoldAxiom tc "NatToCharDef" isNumLitTy $    -- NatToChar 97 --> 'a'+      \n -> fmap mkCharLitTy (integerToChar n) ]+  where+    tc = typeNatToCharTyCon++axNatToCharInjectivity :: [BuiltInFamInjectivity]+axNatToCharInjectivity+  = [ -- (NatToChar n ~ 'z') => (n ~ 122)+      mkTopUnaryFamDeduction "CharToNatT1" typeNatToCharTyCon $ \n r ->+      do { c <- isCharLitTy r; return (Pair n (mkNumLitTy (charToInteger c))) } ]+++-----------------------------------------------------------------------------+--                       CmpChar+-----------------------------------------------------------------------------++typeCharCmpTyCon :: TyCon+typeCharCmpTyCon =+  mkFamilyTyCon name+    (mkTemplateAnonTyConBinders [ charTy, charTy ])+    orderingKind+    Nothing+    (BuiltInSynFamTyCon ops)+    Nothing+    NotInjective+  where+  name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPELITS_INTERNAL (fsLit "CmpChar")+                  typeCharCmpTyFamNameKey typeCharCmpTyCon+  ops = BuiltInSynFamily { sfMatchFam = axCharCmpRewrites+                         , sfInteract = axCharCmpInjectivity }++sc :: TyVar  -- Of kind Char+(sc: _) = mkTemplateTyVars (repeat charTy)++axCharCmpRewrites :: [BuiltInFamRewrite]+axCharCmpRewrites+  = [ mkRewriteAxiom   tc "CmpCharRefl" [sc] [var sc, var sc] (ordering EQ) -- s `cmp` s --> EQ+    , mkBinConstFoldAxiom tc "CmpCharDef" isCharLitTy isCharLitTy $         -- 'a' `cmp` 'b' --> LT+      \chr1 chr2 -> Just $ ordering $ compare chr1 chr2 ]+  where+    tc = typeCharCmpTyCon++axCharCmpInjectivity :: [BuiltInFamInjectivity]+axCharCmpInjectivity+  = [  -- (CmpChar s t ~ EQ) => s ~ t+      mkTopBinFamDeduction "CmpCharT" typeCharCmpTyCon $ \ s t r ->+      do { EQ <- isOrderingLitTy r; return (Pair s t) } ]+++{-------------------------------------------------------------------------------+Various utilities for making axioms and types+-------------------------------------------------------------------------------}++(===) :: Type -> Type -> Pair Type+x === y = Pair x y++num :: Integer -> Type+num = mkNumLitTy++var :: TyVar -> Type+var = mkTyVarTy++(.+.) :: Type -> Type -> Type+s .+. t = mkTyConApp typeNatAddTyCon [s,t]++{-+(.-.) :: Type -> Type -> Type+s .-. t = mkTyConApp typeNatSubTyCon [s,t]++(.*.) :: Type -> Type -> Type+s .*. t = mkTyConApp typeNatMulTyCon [s,t]++tDiv :: Type -> Type -> Type+tDiv s t = mkTyConApp typeNatDivTyCon [s,t]++tMod :: Type -> Type -> Type+tMod s t = mkTyConApp typeNatModTyCon [s,t]++(.^.) :: Type -> Type -> Type+s .^. t = mkTyConApp typeNatExpTyCon [s,t]++cmpNat :: Type -> Type -> Type+cmpNat s t = mkTyConApp typeNatCmpTyCon [s,t]++cmpSymbol :: Type -> Type -> Type+cmpSymbol s t = mkTyConApp typeSymbolCmpTyCon [s,t]++appendSymbol :: Type -> Type -> Type+appendSymbol s t = mkTyConApp typeSymbolAppendTyCon [s, t]+-}+++nullStrLitTy :: Type  -- The type ""+nullStrLitTy = mkStrLitTy nilFS++isStrLitTyS :: Type -> Maybe String+isStrLitTyS ty = do { fs <- isStrLitTy ty; return (unpackFS fs) }++mkStrLitTyS :: String -> Type+mkStrLitTyS s = mkStrLitTy (mkFastString s)++charSymbolPair :: Type -> Type -> Type+charSymbolPair = mkPromotedPairTy charTy typeSymbolKind++charSymbolPairKind :: Kind+charSymbolPairKind = mkTyConApp pairTyCon [charTy, typeSymbolKind]++orderingKind :: Kind+orderingKind = mkTyConApp orderingTyCon []++ordering :: Ordering -> Type+ordering o =+  case o of+    LT -> mkTyConApp promotedLTDataCon []+    EQ -> mkTyConApp promotedEQDataCon []+    GT -> mkTyConApp promotedGTDataCon []++isOrderingLitTy :: Type -> Maybe Ordering+isOrderingLitTy tc =+  do (tc1,[]) <- splitTyConApp_maybe tc+     case () of+       _ | tc1 == promotedLTDataCon -> return LT+         | tc1 == promotedEQDataCon -> return EQ+         | tc1 == promotedGTDataCon -> return GT+         | otherwise                -> Nothing++-- Make a unary built-in constructor of kind: Nat -> Nat+mkTypeNatFunTyCon1 :: Name -> BuiltInSynFamily -> TyCon+mkTypeNatFunTyCon1 op tcb =+  mkFamilyTyCon op+    (mkTemplateAnonTyConBinders [ naturalTy ])+    naturalTy+    Nothing+    (BuiltInSynFamTyCon tcb)+    Nothing+    NotInjective++-- Make a binary built-in constructor of kind: Nat -> Nat -> Nat+mkTypeNatFunTyCon2 :: Name -> BuiltInSynFamily -> TyCon+mkTypeNatFunTyCon2 op tcb =+  mkFamilyTyCon op+    (mkTemplateAnonTyConBinders [ naturalTy, naturalTy ])+    naturalTy+    Nothing+    (BuiltInSynFamTyCon tcb)+    Nothing+    NotInjective++-- Make a binary built-in constructor of kind: Symbol -> Symbol -> Symbol+mkTypeSymbolFunTyCon2 :: Name -> BuiltInSynFamily -> TyCon+mkTypeSymbolFunTyCon2 op tcb =+  mkFamilyTyCon op+    (mkTemplateAnonTyConBinders [ typeSymbolKind, typeSymbolKind ])+    typeSymbolKind+    Nothing+    (BuiltInSynFamTyCon tcb)+    Nothing+    NotInjective++same :: Type -> Type -> Maybe ()+same ty1 ty2 = guard (ty1 `tcEqType` ty2)++known :: Type -> (Integer -> Bool) -> Maybe Integer+known x p = do { nx <- isNumLitTy x; guard (p nx); return nx }++charToInteger :: Char -> Integer+charToInteger c = fromIntegral (Char.ord c)++integerToChar :: Integer -> Maybe Char+integerToChar n | inBounds = Just (Char.chr (fromInteger n))+  where inBounds = n >= charToInteger minBound &&+                   n <= charToInteger maxBound+integerToChar _ = Nothing+++{- -----------------------------------------------------------------------------+These inverse functions are used for simplifying propositions using+concrete natural numbers.+----------------------------------------------------------------------------- -}++-- | Subtract two natural numbers.+minus :: Integer -> Integer -> Maybe Integer+minus x y = if x >= y then Just (x - y) else Nothing++-- | Compute the exact logarithm of a natural number.+-- The logarithm base is the second argument.+logExact :: Integer -> Integer -> Maybe Integer+logExact x y = do (z,True) <- genLog x y+                  return z+++-- | Divide two natural numbers.+divide :: Integer -> Integer -> Maybe Integer+divide _ 0  = Nothing+divide x y  = case divMod x y of+                (a,0) -> Just a+                _     -> Nothing++-- | Compute the exact root of a natural number.+-- The second argument specifies which root we are computing.+rootExact :: Integer -> Integer -> Maybe Integer+rootExact x y = do (z,True) <- genRoot x y+                   return z++++{- | Compute the n-th root of a natural number, rounded down to+the closest natural number.  The boolean indicates if the result+is exact (i.e., True means no rounding was done, False means rounded down).+The second argument specifies which root we are computing. -}+genRoot :: Integer -> Integer -> Maybe (Integer, Bool)+genRoot _  0    = Nothing+genRoot x0 1    = Just (x0, True)+genRoot x0 root = Just (search 0 (x0+1))+  where+  search from to = let x = from + div (to - from) 2+                       a = x ^ root+                   in case compare a x0 of+                        EQ              -> (x, True)+                        LT | x /= from  -> search x to+                           | otherwise  -> (from, False)+                        GT | x /= to    -> search from x+                           | otherwise  -> (from, False)++{- | Compute the logarithm of a number in the given base, rounded down to the+closest integer.  The boolean indicates if we the result is exact+(i.e., True means no rounding happened, False means we rounded down).+The logarithm base is the second argument. -}+genLog :: Integer -> Integer -> Maybe (Integer, Bool)+genLog x 0    = if x == 1 then Just (0, True) else Nothing+genLog _ 1    = Nothing+genLog 0 _    = Nothing+genLog x base = Just (exactLoop 0 x)+  where+  exactLoop s i+    | i == 1     = (s,True)+    | i < base   = (s,False)+    | otherwise  =+        let s1 = s + 1+        in s1 `seq` case divMod i base of+                      (j,r)+                        | r == 0    -> exactLoop s1 j+                        | otherwise -> (underLoop s1 j, False)++  underLoop s i+    | i < base  = s+    | otherwise = let s1 = s + 1 in s1 `seq` underLoop s1 (div i base)+
GHC/Builtin/Types/Prim.hs view
@@ -30,6 +30,8 @@         levity1TyVarInf, levity2TyVarInf,         levity1Ty, levity2Ty, +        alphaConstraintTyVar, alphaConstraintTy,+         openAlphaTyVar, openBetaTyVar, openGammaTyVar,         openAlphaTyVarSpec, openBetaTyVarSpec, openGammaTyVarSpec,         openAlphaTy, openBetaTy, openGammaTy,@@ -41,13 +43,16 @@         multiplicityTyVar1, multiplicityTyVar2,          -- Kind constructors...-        tYPETyCon, tYPETyConName,+        tYPETyCon, tYPETyConName, tYPEKind,+        cONSTRAINTTyCon, cONSTRAINTTyConName, cONSTRAINTKind, -        -- Kinds-        mkTYPEapp,+        -- Arrows+        funTyFlagTyCon, isArrowTyCon,+        fUNTyCon,       fUNTyConName,+        ctArrowTyCon, ctArrowTyConName,+        ccArrowTyCon, ccArrowTyConName,+        tcArrowTyCon, tcArrowTyConName, -        functionWithMultiplicity,-        funTyCon, funTyConName,         unexposedPrimTyCons, exposedPrimTyCons, primTyCons,          charPrimTyCon,          charPrimTy, charPrimTyConName,@@ -58,7 +63,8 @@         doublePrimTyCon,        doublePrimTy, doublePrimTyConName,          statePrimTyCon,         mkStatePrimTy,-        realWorldTyCon,         realWorldTy, realWorldStatePrimTy,+        realWorldTyCon,         realWorldTy,+        realWorldStatePrimTy,   realWorldMutableByteArrayPrimTy,          proxyPrimTyCon,         mkProxyPrimTy, @@ -71,7 +77,6 @@         mutVarPrimTyCon, mkMutVarPrimTy,          mVarPrimTyCon,                  mkMVarPrimTy,-        ioPortPrimTyCon,                mkIOPortPrimTy,         tVarPrimTyCon,                  mkTVarPrimTy,         stablePtrPrimTyCon,             mkStablePtrPrimTy,         stableNamePrimTyCon,            mkStableNamePrimTy,@@ -80,6 +85,7 @@         weakPrimTyCon,                  mkWeakPrimTy,         threadIdPrimTyCon,              threadIdPrimTy,         stackSnapshotPrimTyCon,         stackSnapshotPrimTy,+        promptTagPrimTyCon,             mkPromptTagPrimTy,          int8PrimTyCon,          int8PrimTy, int8PrimTyConName,         word8PrimTyCon,         word8PrimTy, word8PrimTyConName,@@ -105,7 +111,7 @@ import GHC.Prelude  import {-# SOURCE #-} GHC.Builtin.Types-  ( runtimeRepTy, levityTy, unboxedTupleKind, liftedTypeKind+  ( runtimeRepTy, levityTy, unboxedTupleKind, liftedTypeKind, unliftedTypeKind   , boxedRepDataConTyCon, vecRepDataConTyCon   , liftedRepTy, unliftedRepTy, zeroBitRepTy   , intRepDataConTy@@ -120,45 +126,134 @@   , int64ElemRepDataConTy, word8ElemRepDataConTy, word16ElemRepDataConTy   , word32ElemRepDataConTy, word64ElemRepDataConTy, floatElemRepDataConTy   , doubleElemRepDataConTy-  , multiplicityTy )+  , multiplicityTy+  , constraintKind ) -import GHC.Types.Var    ( TyVarBinder, TyVar+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 {-# SOURCE #-} GHC.Types.TyThing-import GHC.Core.TyCon import GHC.Types.SrcLoc import GHC.Types.Unique+ import GHC.Builtin.Uniques import GHC.Builtin.Names-import GHC.Data.FastString import GHC.Utils.Misc ( changeLast )-import GHC.Core.TyCo.Rep -- Doesn't need special access, but this is easier to avoid-                         -- import loops which show up if you import Type instead-import {-# SOURCE #-} GHC.Core.Type ( mkTyConTy, mkTyConApp, mkTYPEapp, getLevity )+import GHC.Utils.Panic ( assertPpr )+import GHC.Utils.Outputable +import GHC.Data.FastString import Data.Char -{--************************************************************************+{- ********************************************************************* *                                                                      *-\subsection{Primitive type constructors}+             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.--- It's important to keep these separate as we don't want users to be able to--- write them (see #15209) or see them in GHCi's @:browse@ output--- (see #12023).+-- | Primitive 'TyCon's that are defined in GHC.Prim but not "exposed".+-- See Note [Unexposed TyCons] unexposedPrimTyCons :: [TyCon] unexposedPrimTyCons-  = [ eqPrimTyCon-    , eqReprPrimTyCon-    , eqPhantPrimTyCon+  = [ 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.@@ -182,7 +277,6 @@     , mutableByteArrayPrimTyCon     , smallMutableArrayPrimTyCon     , mVarPrimTyCon-    , ioPortPrimTyCon     , tVarPrimTyCon     , mutVarPrimTyCon     , realWorldTyCon@@ -198,28 +292,15 @@     , word32PrimTyCon     , word64PrimTyCon     , stackSnapshotPrimTyCon+    , promptTagPrimTyCon +    , fUNTyCon     , tYPETyCon-    , funTyCon+    , cONSTRAINTTyCon  #include "primop-vector-tycons.hs-incl"     ] -mkPrimTc :: FastString -> Unique -> TyCon -> Name-mkPrimTc fs unique tycon-  = mkWiredInName gHC_PRIM (mkTcOccFS fs)-                  unique-                  (mkATyCon tycon)        -- Relevant TyCon-                  UserSyntax--mkBuiltInPrimTc :: FastString -> Unique -> TyCon -> Name-mkBuiltInPrimTc fs unique tycon-  = mkWiredInName gHC_PRIM (mkTcOccFS fs)-                  unique-                  (mkATyCon tycon)        -- Relevant TyCon-                  BuiltInSyntax-- charPrimTyConName, intPrimTyConName, int8PrimTyConName, int16PrimTyConName, int32PrimTyConName, int64PrimTyConName,   wordPrimTyConName, word32PrimTyConName, word8PrimTyConName, word16PrimTyConName, word64PrimTyConName,   addrPrimTyConName, floatPrimTyConName, doublePrimTyConName,@@ -227,11 +308,11 @@   arrayPrimTyConName, smallArrayPrimTyConName, byteArrayPrimTyConName,   mutableArrayPrimTyConName, mutableByteArrayPrimTyConName,   smallMutableArrayPrimTyConName, mutVarPrimTyConName, mVarPrimTyConName,-  ioPortPrimTyConName, tVarPrimTyConName, stablePtrPrimTyConName,+  tVarPrimTyConName, stablePtrPrimTyConName,   stableNamePrimTyConName, compactPrimTyConName, bcoPrimTyConName,   weakPrimTyConName, threadIdPrimTyConName,   eqPrimTyConName, eqReprPrimTyConName, eqPhantPrimTyConName,-  stackSnapshotPrimTyConName :: Name+  stackSnapshotPrimTyConName, promptTagPrimTyConName :: Name charPrimTyConName             = mkPrimTc (fsLit "Char#") charPrimTyConKey charPrimTyCon intPrimTyConName              = mkPrimTc (fsLit "Int#") intPrimTyConKey  intPrimTyCon int8PrimTyConName             = mkPrimTc (fsLit "Int8#") int8PrimTyConKey int8PrimTyCon@@ -259,7 +340,6 @@ mutableByteArrayPrimTyConName = mkPrimTc (fsLit "MutableByteArray#") mutableByteArrayPrimTyConKey mutableByteArrayPrimTyCon smallMutableArrayPrimTyConName= mkPrimTc (fsLit "SmallMutableArray#") smallMutableArrayPrimTyConKey smallMutableArrayPrimTyCon mutVarPrimTyConName           = mkPrimTc (fsLit "MutVar#") mutVarPrimTyConKey mutVarPrimTyCon-ioPortPrimTyConName           = mkPrimTc (fsLit "IOPort#") ioPortPrimTyConKey ioPortPrimTyCon mVarPrimTyConName             = mkPrimTc (fsLit "MVar#") mVarPrimTyConKey mVarPrimTyCon tVarPrimTyConName             = mkPrimTc (fsLit "TVar#") tVarPrimTyConKey tVarPrimTyCon stablePtrPrimTyConName        = mkPrimTc (fsLit "StablePtr#") stablePtrPrimTyConKey stablePtrPrimTyCon@@ -269,14 +349,15 @@ bcoPrimTyConName              = mkPrimTc (fsLit "BCO") bcoPrimTyConKey bcoPrimTyCon weakPrimTyConName             = mkPrimTc (fsLit "Weak#") weakPrimTyConKey weakPrimTyCon threadIdPrimTyConName         = mkPrimTc (fsLit "ThreadId#") threadIdPrimTyConKey threadIdPrimTyCon+promptTagPrimTyConName        = mkPrimTc (fsLit "PromptTag#") promptTagPrimTyConKey promptTagPrimTyCon -{--************************************************************************+{- ********************************************************************* *                                                                      *-\subsection{Support code}+                Type variables *                                                                      *-************************************************************************+********************************************************************* -} +{- alphaTyVars is a list of type variables for use in templates:         ["a", "b", ..., "z", "t1", "t2", ... ] -}@@ -337,8 +418,8 @@                              -- 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, *])+--   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@@ -352,8 +433,8 @@                              -- 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 mkTemplateKiTyVar RuntimeRep (\r -> [TYPE r, *])+--   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@@ -363,13 +444,16 @@  mkTemplateKindTyConBinders :: [Kind] -> [TyConBinder] -- Makes named, Specified binders-mkTemplateKindTyConBinders kinds = [mkNamedTyConBinder Specified tv | tv <- mkTemplateKindVars kinds]+mkTemplateKindTyConBinders kinds+  = [mkNamedTyConBinder Specified tv | tv <- mkTemplateKindVars kinds]  mkTemplateAnonTyConBinders :: [Kind] -> [TyConBinder]-mkTemplateAnonTyConBinders kinds = mkAnonTyConBinders VisArg (mkTemplateTyVars kinds)+mkTemplateAnonTyConBinders kinds+  = mkAnonTyConBinders (mkTemplateTyVars kinds)  mkTemplateAnonTyConBindersFrom :: Int -> [Kind] -> [TyConBinder]-mkTemplateAnonTyConBindersFrom n kinds = mkAnonTyConBinders VisArg (mkTemplateTyVarsFrom n kinds)+mkTemplateAnonTyConBindersFrom n kinds+  = mkAnonTyConBinders (mkTemplateTyVarsFrom n kinds)  alphaTyVars :: [TyVar] alphaTyVars = mkTemplateTyVars $ repeat liftedTypeKind@@ -380,13 +464,22 @@ 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 (mkTYPEapp unliftedRepTy)+alphaTyVarsUnliftedRep = mkTemplateTyVars $ repeat unliftedTypeKind  alphaTyVarUnliftedRep :: TyVar (alphaTyVarUnliftedRep:_) = alphaTyVarsUnliftedRep@@ -404,7 +497,7 @@ runtimeRep1TyVarInf = mkTyVarBinder Inferred runtimeRep1TyVar runtimeRep2TyVarInf = mkTyVarBinder Inferred runtimeRep2TyVar -runtimeRep1Ty, runtimeRep2Ty, runtimeRep3Ty :: Type+runtimeRep1Ty, runtimeRep2Ty, runtimeRep3Ty :: RuntimeRepType runtimeRep1Ty = mkTyVarTy runtimeRep1TyVar runtimeRep2Ty = mkTyVarTy runtimeRep2TyVar runtimeRep3Ty = mkTyVarTy runtimeRep3TyVar@@ -413,7 +506,9 @@ -- beta  :: TYPE r2 -- gamma :: TYPE r3 [openAlphaTyVar,openBetaTyVar,openGammaTyVar]-  = mkTemplateTyVars [mkTYPEapp runtimeRep1Ty, mkTYPEapp runtimeRep2Ty, mkTYPEapp runtimeRep3Ty]+  = mkTemplateTyVars [ mk_TYPE_app runtimeRep1Ty+                     , mk_TYPE_app runtimeRep2Ty+                     , mk_TYPE_app runtimeRep3Ty]  openAlphaTyVarSpec, openBetaTyVarSpec, openGammaTyVarSpec :: TyVarBinder openAlphaTyVarSpec = mkTyVarBinder Specified openAlphaTyVar@@ -442,8 +537,8 @@ levPolyAlphaTyVar, levPolyBetaTyVar :: TyVar [levPolyAlphaTyVar, levPolyBetaTyVar] =   mkTemplateTyVars-    [mkTYPEapp (mkTyConApp boxedRepDataConTyCon [levity1Ty])-    ,mkTYPEapp (mkTyConApp boxedRepDataConTyCon [levity2Ty])]+    [ mk_TYPE_app (mkTyConApp boxedRepDataConTyCon [levity1Ty])+    , mk_TYPE_app (mkTyConApp boxedRepDataConTyCon [levity2Ty])] -- alpha :: TYPE ('BoxedRep l) -- beta  :: TYPE ('BoxedRep k) @@ -468,82 +563,289 @@ ************************************************************************ -} -funTyConName :: Name-funTyConName = mkPrimTcName UserSyntax (fsLit "FUN") funTyConKey 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 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. To allow visible application a type synonym can be--- defined:------ @--- type Arr :: forall (rep1 :: RuntimeRep) (rep2 :: RuntimeRep).---             TYPE rep1 -> TYPE rep2 -> Type--- type Arr = FUN 'Many--- @----funTyCon :: TyCon-funTyCon = mkFunTyCon funTyConName tc_bndrs tc_rep_nm+-- 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 [ mkTYPEapp runtimeRep1Ty-                                             , mkTYPEapp runtimeRep2Ty-                                             ]-    tc_rep_nm = mkPrelTyConRepName funTyConName+               ++ 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]+ {- ************************************************************************ *                                                                      *-                Kinds+                Type and Constraint *                                                                      * ************************************************************************ -Note [TYPE and RuntimeRep]+Note [TYPE and CONSTRAINT]  aka Note [Type vs Constraint] ~~~~~~~~~~~~~~~~~~~~~~~~~~-All types that classify values have a kind of the form (TYPE rr), where+GHC distinguishes Type from Constraint throughout the compiler.+See GHC Proposal #518, and tickets #21623 and #11715. -    data RuntimeRep     -- Defined in ghc-prim:GHC.Types+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--    rr :: RuntimeRep+  data Levity = Lifted | Unlifted -    TYPE :: RuntimeRep -> TYPE 'LiftedRep  -- Built in+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)+    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]) -We abbreviate '*' specially:-    type LiftedRep = 'BoxedRep 'Lifted-    type * = TYPE LiftedRep+    Eq Int       :: CONSTRAINT (BoxedRep Lifted)+    IP "foo" Int :: CONSTRAINT (BoxedRep Lifted)+    a ~ b        :: CONSTRAINT (BoxedRep Lifted)+    a ~# b       :: CONSTRAINT (TupleRep []) -The 'rr' parameter tells us how the value is represented at runtime.+Constraints are mostly lifted, but unlifted ones are useful too.+Specifically  (a ~# b) :: CONSTRAINT (TupleRep []) -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). ...+Wrinkles++(W1) Type and Constraint are considered distinct throughout GHC. But they+     are not /apart/: see Note [Type and Constraint are not apart]++(W2) We need two absent-error Ids, aBSENT_ERROR_ID for types of kind Type, and+     aBSENT_CONSTRAINT_ERROR_ID for types of kind Constraint.+     See Note [Type vs Constraint for error ids] in GHC.Core.Make.+     Ditto noInlineId vs noInlineConstraintId in GHC.Types.Id.Make;+     see Note [inlineId magic].++(W3) We need a TypeOrConstraint flag in LitRubbish.++(W4) In the CPR transformation, we can't unbox constructors with constraint+     arguments because unboxed tuples (# …, … #) currently only supports fields+     of type TYPE rr. See (CPR2) in Note [Which types are unboxed?] in+     GHC.Core.Opt.WorkWrap.Utils.++Note [Type and Constraint are not apart]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Type and Constraint are not equal (eqType) but they are not /apart/+either. Reason (c.f. #7451):++* We want to allow newtype classes, where+    class C a where { op :: a -> a }++* The axiom for such a class will look like+    axiom axC a :: (C a :: Constraint) ~# (a->a :: Type)++* This axiom connects a type of kind Type with one of kind Constraint+  That is dangerous: kindCo (axC Int) :: Type ~N Constraint+  And /that/ is bad because we could have+     type family F a where+        F Type       = Int+        F Constraint = Bool+  So now we can prove Int ~N Bool, and all is lost.  We prevent this+  by saying that Type and Constraint are not Apart, which makes the+  above type family instances illegal.++So we ensure that Type and Constraint are not apart; or, more+precisely, that TYPE and CONSTRAINT are not apart.  This+non-apart-ness check is implemented in GHC.Core.Unify.unify_ty: look+for `maybeApart MARTypeVsConstraint`.++Note that, as before, nothing prevents writing instances like:++  instance C (Proxy @Type a) where ...++In particular, TYPE and CONSTRAINT (and the synonyms Type, Constraint+etc) are all allowed in instance heads. It's just that TYPE is not+apart from CONSTRAINT, which means that the above instance would+irretrievably overlap with:++  instance C (Proxy @Constraint a) where ...++Wrinkles++(W1) In GHC.Core.RoughMap.roughMatchTyConName we are careful to map+     TYPE and CONSTRAINT to the same rough-map key.  Reason:+     If we insert (F @Constraint tys) into a FamInstEnv, and look+     up (F @Type tys'), we /must/ ensure that the (C @Constraint tys)+     appears among the unifiables when we do the lookupRM' in+     GHC.Core.FamInstEnv.lookup_fam_inst_env'.  So for the RoughMap we+     simply pretend that they are the same type constructor.  If we+     don't, we'll treat them as fully apart, which is unsound.++(W2) We must extend this treatment to the different arrow types (see+     Note [Function type constructors and FunTy]): if we have+       FunCo (axC Int) <Int> :: (C Int => Int) ~ ((Int -> Int) -> Int),+     then we could extract an equality between (=>) and (->). We thus+     must ensure that (=>) and (->) (among the other arrow combinations)+     are not Apart. See the FunTy/FunTy case in GHC.Core.Unify.unify_ty.++(W3) Are (TYPE IntRep) and (CONSTRAINT WordRep) apart?  In truth yes,+     they are.  But it's easier to say that they are not apart, by+     reporting "maybeApart" (which is always safe), rather than+     recurse into the arguments (whose kinds may be utterly different)+     to look for apartness inside them.  Again this is in+     GHC.Core.Unify.unify_ty.++(W4) We give a different Typeable instance for Type than for Constraint.+     For type classes instances (unlike type family instances) it is not+     /unsound/ for Type and Constraint to treated as fully distinct; and+     for Typeable is desirable to give them different TypeReps.+     Certainly,+       - both Type and Constraint must /have/ a TypeRep, and+       - they had better not be the same (else eqTypeRep would give us+         a proof Type ~N Constraint, which we do not want+     So in GHC.Tc.Instance.Class.matchTypeable, Type and Constraint are+     treated as separate TyCons; i.e. given no special treatment.++Note [RuntimeRep polymorphism]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Generally speaking, you can't be polymorphic in `RuntimeRep`.  E.g+   f :: forall (rr::RuntimeRep) (a::TYPE rr). a -> [a]+   f = /\(rr::RuntimeRep) (a::rr) \(a::rr). ... This is no good: we could not generate code for 'f', because the calling convention for 'f' varies depending on whether the argument is a a Int, Int#, or Float#.  (You could imagine generating specialised@@ -552,7 +854,7 @@ 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+* error :: forall (rr::RuntimeRep) (a::TYPE rr). String -> a   Code generator never has to manipulate the return value.  * unsafeCoerce#, defined in Desugar.mkUnsafeCoercePair:@@ -566,85 +868,40 @@      (#,#) :: forall (r1 :: RuntimeRep) (r2 :: RuntimeRep)                      (a :: TYPE r1) (b :: TYPE r2).                      a -> b -> TYPE ('TupleRep '[r1, r2])- -} +---------------------- tYPETyCon :: TyCon-tYPETyConName :: Name- tYPETyCon = mkPrimTyCon tYPETyConName                         (mkTemplateAnonTyConBinders [runtimeRepTy])                         liftedTypeKind                         [Nominal] ------------------------------ ... and now their names+tYPETyConName :: Name+tYPETyConName = mkPrimTc (fsLit "TYPE") tYPETyConKey tYPETyCon --- If you edit these, you may need to update the GHC formalism--- See Note [GHC Formalism] in GHC.Core.Lint-tYPETyConName             = mkPrimTcName UserSyntax (fsLit "TYPE") tYPETyConKey tYPETyCon+tYPEKind :: Type+tYPEKind = mkTyConTy tYPETyCon -mkPrimTcName :: BuiltInSyntax -> FastString -> Unique -> TyCon -> Name-mkPrimTcName built_in_syntax occ key tycon-  = mkWiredInName gHC_PRIM (mkTcOccFS occ) key (mkATyCon tycon) built_in_syntax+----------------------+cONSTRAINTTyCon :: TyCon+cONSTRAINTTyCon = mkPrimTyCon cONSTRAINTTyConName+                              (mkTemplateAnonTyConBinders [runtimeRepTy])+                              liftedTypeKind+                              [Nominal] ------------------------------+cONSTRAINTTyConName :: Name+cONSTRAINTTyConName = mkPrimTc (fsLit "CONSTRAINT") cONSTRAINTTyConKey cONSTRAINTTyCon --- Given a Multiplicity, applies FUN to it.-functionWithMultiplicity :: Type -> Type-functionWithMultiplicity mul = TyConApp funTyCon [mul]+cONSTRAINTKind :: Type+cONSTRAINTKind = mkTyConTy cONSTRAINTTyCon -{--************************************************************************++{- ********************************************************************* *                                                                      *-   Basic primitive types (@Char#@, @Int#@, etc.)+       Basic primitive types (Char#, Int#, etc.) *                                                                      *-************************************************************************--}---- | 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 = mkTYPEapp 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.------ Only use this in "GHC.Builtin.Types.Prim".-pcPrimTyCon_LevPolyLastArg :: Name-                           -> [Role] -- ^ roles of the arguments (must be non-empty),-                                     -- not including the implicit argument of kind 'Levity',-                                     -- which always has 'Nominal' role-                           -> RuntimeRepType  -- ^ representation of the fully-applied type-                           -> TyCon-pcPrimTyCon_LevPolyLastArg name roles res_rep-  = mkPrimTyCon name binders result_kind (Nominal : roles)-    where-      result_kind = mkTYPEapp res_rep-      lev_bndr = mkNamedTyConBinder Inferred levity1TyVar-      binders  = lev_bndr : mkTemplateAnonTyConBinders anon_bndr_kis-      lev_tv   = mkTyVarTy (binderVar lev_bndr)--      -- [ Type, ..., Type, TYPE (BoxedRep l) ]-      anon_bndr_kis = changeLast (liftedTypeKind <$ roles)-                        (mkTYPEapp $ mkTyConApp boxedRepDataConTyCon [lev_tv])+********************************************************************* -}  charPrimTy :: Type charPrimTy      = mkTyConTy charPrimTyCon@@ -757,7 +1014,7 @@     -------------------------- 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.isEqPrimPred and classifies as an EqPred in+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.@@ -785,8 +1042,8 @@  * 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 [Naturally coherent classes]-   in GHC.Tc.Solver.Interact.+   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@@ -795,7 +1052,7 @@ 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.Interact.matchClassInst to+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. @@ -815,6 +1072,8 @@  * 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@@ -917,10 +1176,9 @@ 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{GHC.Builtin.Types}, not here.-+realWorldMutableByteArrayPrimTy :: Type+realWorldMutableByteArrayPrimTy+  = mkMutableByteArrayPrimTy realWorldTy -- MutableByteArray# RealWorld  mkProxyPrimTy :: Type -> Type -> Type mkProxyPrimTy k ty = TyConApp proxyPrimTyCon [k, ty]@@ -944,9 +1202,9 @@                       -- See Note [The equality types story] eqPrimTyCon  = mkPrimTyCon eqPrimTyConName binders res_kind roles   where-    -- Kind :: forall k1 k2. k1 -> k2 -> TYPE (TupleRep '[])+    -- Kind :: forall k1 k2. k1 -> k2 -> CONSTRAINT ZeroBitRep     binders  = mkTemplateTyConBinders [liftedTypeKind, liftedTypeKind] id-    res_kind = unboxedTupleKind []+    res_kind = TyConApp cONSTRAINTTyCon [zeroBitRepTy]     roles    = [Nominal, Nominal, Nominal, Nominal]  -- like eqPrimTyCon, but the type for *Representational* coercions@@ -955,9 +1213,9 @@ eqReprPrimTyCon :: TyCon   -- See Note [The equality types story] eqReprPrimTyCon = mkPrimTyCon eqReprPrimTyConName binders res_kind roles   where-    -- Kind :: forall k1 k2. k1 -> k2 -> TYPE (TupleRep '[])+    -- Kind :: forall k1 k2. k1 -> k2 -> CONSTRAINT ZeroBitRep     binders  = mkTemplateTyConBinders [liftedTypeKind, liftedTypeKind] id-    res_kind = unboxedTupleKind []+    res_kind = TyConApp cONSTRAINTTyCon [zeroBitRepTy]     roles    = [Nominal, Nominal, Representational, Representational]  -- like eqPrimTyCon, but the type for *Phantom* coercions.@@ -966,9 +1224,9 @@ eqPhantPrimTyCon :: TyCon eqPhantPrimTyCon = mkPrimTyCon eqPhantPrimTyConName binders res_kind roles   where-    -- Kind :: forall k1 k2. k1 -> k2 -> TYPE (TupleRep '[])+    -- Kind :: forall k1 k2. k1 -> k2 -> CONSTRAINT ZeroBitRep     binders  = mkTemplateTyConBinders [liftedTypeKind, liftedTypeKind] id-    res_kind = unboxedTupleKind []+    res_kind = TyConApp cONSTRAINTTyCon [zeroBitRepTy]     roles    = [Nominal, Nominal, Phantom, Phantom]  -- | Given a Role, what TyCon is the type of equality predicates at that role?@@ -1022,20 +1280,6 @@ {- ************************************************************************ *                                                                      *-\subsection[TysPrim-io-port-var]{The synchronizing I/O Port type}-*                                                                      *-************************************************************************--}--ioPortPrimTyCon :: TyCon-ioPortPrimTyCon = pcPrimTyCon_LevPolyLastArg ioPortPrimTyConName [Nominal, Representational] unliftedRepTy--mkIOPortPrimTy :: Type -> Type -> Type-mkIOPortPrimTy s elt          = TyConApp ioPortPrimTyCon [getLevity elt, s, elt]--{--************************************************************************-*                                                                      *    The synchronizing variable type \subsection[TysPrim-synch-var]{The synchronizing variable type} *                                                                      *@@ -1170,6 +1414,20 @@ 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]  {- ************************************************************************
− GHC/Builtin/Types/Prim.hs-boot 
@@ -1,5 +0,0 @@-module GHC.Builtin.Types.Prim where--import GHC.Core.TyCon--tYPETyCon :: TyCon
GHC/Builtin/Uniques.hs view
@@ -13,16 +13,20 @@        -- * Getting the 'Unique's of 'Name's       -- ** Anonymous sums-    , mkSumTyConUnique-    , mkSumDataConUnique+    , mkSumTyConUnique, mkSumDataConUnique+    , isSumTyConUnique+       -- ** Tuples       -- *** Vanilla     , mkTupleTyConUnique     , mkTupleDataConUnique+    , isTupleTyConUnique+    , isTupleDataConLikeUnique       -- *** Constraint     , mkCTupleTyConUnique     , mkCTupleDataConUnique     , mkCTupleSelIdUnique+    , isCTupleTyConUnique        -- ** Making built-in uniques     , mkAlphaTyVarUnique@@ -30,14 +34,16 @@     , mkPreludeMiscIdUnique, mkPreludeDataConUnique     , mkPreludeTyConUnique, mkPreludeClassUnique -    , mkVarOccUnique, mkDataOccUnique, mkTvOccUnique, mkTcOccUnique     , mkRegSingleUnique, mkRegPairUnique, mkRegClassUnique, mkRegSubUnique     , mkCostCentreUnique +    , varNSUnique, dataNSUnique, tvNSUnique, tcNSUnique+    , mkFldNSUnique, isFldNSUnique+     , mkBuiltinUnique     , mkPseudoUniqueE -      -- ** Deriving uniquesc+      -- ** Deriving uniques       -- *** From TyCon name uniques     , tyConRepNameUnique       -- *** From DataCon name uniques@@ -45,6 +51,9 @@      , initExitJoinUnique +      -- Boxing data types+    , mkBoxingTyConUnique, boxingDataConUnique+     ) where  import GHC.Prelude@@ -60,9 +69,9 @@  import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Utils.Panic.Plain  import Data.Maybe+import GHC.Utils.Word64 (word64ToInt)  -- | Get the 'Name' associated with a known-key 'Unique'. knownUniqueName :: Unique -> Maybe Name@@ -78,7 +87,9 @@       'm' -> Just $ getCTupleDataConName n       _   -> Nothing   where-    (tag, n) = unpkUnique u+    (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]@@ -107,16 +118,26 @@  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)+    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-  = mkUnique 'z' (arity `shiftL` 8 + alt `shiftL` 2) {- skip the tycon -}+  = mkUniqueInt 'z' (arity `shiftL` 8 + alt `shiftL` 2) {- skip the tycon -}  getUnboxedSumName :: Int -> Name getUnboxedSumName n@@ -203,18 +224,29 @@ -}  mkCTupleTyConUnique :: Arity -> Unique-mkCTupleTyConUnique a = mkUnique 'k' (2*a)+mkCTupleTyConUnique a = mkUniqueInt 'k' (2*a)  mkCTupleDataConUnique :: Arity -> Unique-mkCTupleDataConUnique a = mkUnique 'm' (3*a)+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-  = mkUnique 'j' (arity `shiftL` cTupleSelIdArityBits + sc_pos)+  = 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@@ -256,13 +288,37 @@ -- 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)+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  = mkUnique '4' (2*a)-mkTupleTyConUnique Unboxed         a  = mkUnique '5' (2*a)+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@@ -281,7 +337,7 @@       _          -> panic "getTupleDataConName: impossible"  {--Note [Uniques for wired-in prelude things and known masks]+Note [Uniques for wired-in prelude things and known tags] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Allocation of unique supply characters:         v,u: for renumbering value-, and usage- vars.@@ -297,6 +353,7 @@         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@@ -310,6 +367,27 @@         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@@ -319,61 +397,86 @@ mkPrimOpWrapperUnique  :: Int -> Unique mkPreludeMiscIdUnique  :: Int -> Unique -mkAlphaTyVarUnique   i = mkUnique '1' i-mkPreludeClassUnique i = mkUnique '2' i+mkAlphaTyVarUnique   i = mkUniqueInt '1' i+mkPreludeClassUnique i = mkUniqueInt '2' i  ---------------------------------------------------mkPrimOpIdUnique op         = mkUnique '9' (2*op)-mkPrimOpWrapperUnique op    = mkUnique '9' (2*op+1)-mkPreludeMiscIdUnique  i    = mkUnique '0' 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 = mkUnique 'B' i-mkPseudoUniqueE i = mkUnique 'E' i -- used in NCG spiller to create spill VirtualRegs+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 = mkUnique 'R'-mkRegSubUnique    = mkUnique 'S'-mkRegPairUnique   = mkUnique 'P'-mkRegClassUnique  = mkUnique 'L'+mkRegSingleUnique = mkUniqueInt 'R'+mkRegSubUnique    = mkUniqueInt 'S'+mkRegPairUnique   = mkUniqueInt 'P'+mkRegClassUnique  = mkUniqueInt 'L'  mkCostCentreUnique :: Int -> Unique-mkCostCentreUnique = mkUnique 'C'+mkCostCentreUnique = mkUniqueInt 'C' -mkVarOccUnique, mkDataOccUnique, mkTvOccUnique, mkTcOccUnique :: FastString -> Unique--- See Note [The Unique of an OccName] in GHC.Types.Name.Occurrence-mkVarOccUnique  fs = mkUnique 'i' (uniqueOfFS fs)-mkDataOccUnique fs = mkUnique 'd' (uniqueOfFS fs)-mkTvOccUnique   fs = mkUnique 'v' (uniqueOfFS fs)-mkTcOccUnique   fs = mkUnique 'c' (uniqueOfFS fs)+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:---    * u: the TyCon itself---    * u+1: the TyConRepName of the TyCon+-- See Note [Related uniques for wired-in things]  mkPreludeTyConUnique   :: Int -> Unique-mkPreludeTyConUnique i                = mkUnique '3' (2*i)+mkPreludeTyConUnique i = mkUniqueInt '3' (2*i)  tyConRepNameUnique :: Unique -> Unique tyConRepNameUnique  u = incrUnique u  -------------------------------------------------- -- 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.+-- See Note [Related uniques for wired-in things]  mkPreludeDataConUnique :: Int -> Unique-mkPreludeDataConUnique i              = mkUnique '6' (3*i)    -- Must be alphabetic+mkPreludeDataConUnique i = mkUniqueInt '6' (3*i)    -- Must be alphabetic --------------------------------------------------- dataConTyRepNameUnique, dataConWorkerUnique :: Unique -> Unique dataConWorkerUnique  u = incrUnique u dataConTyRepNameUnique u = stepUnique u 2++--------------------------------------------------+-- The data constructors of RuntimeRep occupy *five* slots:+-- See Note [Related uniques for wired-in things]+--+--    Example: WordRep+--+-- * u: the TyCon of the boxing data type WordBox+-- * u+1: the TyConRepName of the boxing data type+-- * u+2: the DataCon for MkWordBox+-- * u+3: the worker id for MkWordBox+-- * u+4: the TyConRepName of the promoted TyCon 'MkWordBox+--+-- Note carefully that+-- * u,u+1 are in sync with the conventions for+--          wired-in type constructors, above+-- * u+2,u+3,u+4 are in sync with the conventions for+--               wired-in data constructors, above+-- A little delicate!++mkBoxingTyConUnique :: Int -> Unique+mkBoxingTyConUnique i = mkUniqueInt 'b' (5*i)++boxingDataConUnique :: Unique -> Unique+boxingDataConUnique u = stepUnique u 2
GHC/Builtin/Uniques.hs-boot view
@@ -4,7 +4,6 @@ import GHC.Types.Unique import {-# SOURCE #-} GHC.Types.Name import GHC.Types.Basic-import GHC.Data.FastString  -- Needed by GHC.Builtin.Types knownUniqueName :: Unique -> Maybe Name@@ -27,7 +26,6 @@ mkPseudoUniqueE, mkBuiltinUnique :: Int -> Unique  mkRegSingleUnique, mkRegPairUnique, mkRegSubUnique, mkRegClassUnique :: Int -> Unique-mkVarOccUnique, mkDataOccUnique, mkTvOccUnique, mkTcOccUnique :: FastString -> Unique  initExitJoinUnique :: Unique
GHC/Builtin/Utils.hs view
@@ -34,6 +34,8 @@          ghcPrimExports,         ghcPrimDeclDocs,+        ghcPrimWarns,+        ghcPrimFixities,          -- * Random other things         maybeCharLikeCon, maybeIntLikeCon,@@ -61,25 +63,28 @@  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 )+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.List        ( intercalate , find ) import Data.Maybe  {-@@ -116,12 +121,8 @@ 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-       -- "<<details unavailable>>" error. (This seems to happen only in the-       -- stage 2 compiler, for reasons I [Richard] have no clue of.)+  , Just badNamesDoc <- knownKeyNamesOkay all_names+  = pprPanic "badAllKnownKeyNames" badNamesDoc   | otherwise   = all_names   where@@ -161,16 +162,15 @@                         Nothing -> []  -- | Check the known-key names list of consistency.-knownKeyNamesOkay :: [Name] -> Maybe String+knownKeyNamesOkay :: [Name] -> Maybe SDoc knownKeyNamesOkay all_names   | ns@(_:_) <- filter (not . isValidKnownKeyUnique . getUnique) all_names-  = Just $ "    Out-of-range known-key uniques: ["-        ++ intercalate ", " (map (occNameString . nameOccName) ns) ++-         "]"+  = Just $ text "    Out-of-range known-key uniques: " <>+           brackets (pprWithCommas (ppr . nameOccName) ns)   | null badNamesPairs   = Nothing   | otherwise-  = Just badNamesStr+  = Just badNamesDoc   where     namesEnv      = foldl' (\m n -> extendNameEnv_Acc (:) Utils.singleton m n n)                            emptyUFM all_names@@ -178,14 +178,14 @@     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+    badNamesDoc :: SDoc+    badNamesDoc  = vcat $ map pairToDoc badNamesPairs -    pairToStr (uniq, ns) = "        " ++-                           show uniq ++-                           ": [" ++-                           intercalate ", " (map (occNameString . nameOccName) ns) ++-                           "]"+    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.@@ -239,21 +239,76 @@  ghcPrimExports :: [IfaceExport] ghcPrimExports- = map (avail . idName) ghcPrimIds ++-   map (avail . idName) allThePrimOpIds ++-   [ availTC n [n] []-   | tc <- exposedPrimTyCons, let n = tyConName tc  ]+ = 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-    names = map idName ghcPrimIds ++-            map idName allThePrimOpIds ++-            map tyConName exposedPrimTyCons     findName (nameStr, doc)-      | Just name <- find ((nameStr ==) . getOccString) names+      | 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.+-}+  {- ************************************************************************
− GHC/Builtin/bytearray-ops.txt.pp 
@@ -1,551 +0,0 @@----------------------------------------- ByteArray# operations------------------------------------------ Do not edit. This file is generated by utils/genprimopcode/gen_bytearray_ops.py.--- To regenerate run,------      python3 utils/genprimops/gen_bytearray_ops.py > compiler/GHC/Builtin/bytearray-ops.txt.pp------------------------------------------ aligned index operations---------------------------------------primop IndexByteArrayOp_Char "indexCharArray#" GenPrimOp-   ByteArray# -> Int# -> Char#-   {Read a 8-bit character; offset in bytes.}-   with can_fail = True--primop IndexByteArrayOp_WideChar "indexWideCharArray#" GenPrimOp-   ByteArray# -> Int# -> Char#-   {Read a 32-bit character; offset in 4-byte words.}-   with can_fail = True--primop IndexByteArrayOp_Int "indexIntArray#" GenPrimOp-   ByteArray# -> Int# -> Int#-   {Read a word-sized integer; offset in machine words.}-   with can_fail = True--primop IndexByteArrayOp_Word "indexWordArray#" GenPrimOp-   ByteArray# -> Int# -> Word#-   {Read a word-sized unsigned integer; offset in machine words.}-   with can_fail = True--primop IndexByteArrayOp_Addr "indexAddrArray#" GenPrimOp-   ByteArray# -> Int# -> Addr#-   {Read a machine address; offset in machine words.}-   with can_fail = True--primop IndexByteArrayOp_Float "indexFloatArray#" GenPrimOp-   ByteArray# -> Int# -> Float#-   {Read a single-precision floating-point value; offset in 4-byte words.}-   with can_fail = True--primop IndexByteArrayOp_Double "indexDoubleArray#" GenPrimOp-   ByteArray# -> Int# -> Double#-   {Read a double-precision floating-point value; offset in 8-byte words.}-   with can_fail = True--primop IndexByteArrayOp_StablePtr "indexStablePtrArray#" GenPrimOp-   ByteArray# -> Int# -> StablePtr# a-   {Read a {\tt StablePtr#} value; offset in machine words.}-   with can_fail = True--primop IndexByteArrayOp_Int8 "indexInt8Array#" GenPrimOp-   ByteArray# -> Int# -> Int8#-   {Read a 8-bit signed integer; offset in bytes.}-   with can_fail = True--primop IndexByteArrayOp_Int16 "indexInt16Array#" GenPrimOp-   ByteArray# -> Int# -> Int16#-   {Read a 16-bit signed integer; offset in 2-byte words.}-   with can_fail = True--primop IndexByteArrayOp_Int32 "indexInt32Array#" GenPrimOp-   ByteArray# -> Int# -> Int32#-   {Read a 32-bit signed integer; offset in 4-byte words.}-   with can_fail = True--primop IndexByteArrayOp_Int64 "indexInt64Array#" GenPrimOp-   ByteArray# -> Int# -> Int64#-   {Read a 64-bit signed integer; offset in 8-byte words.}-   with can_fail = True--primop IndexByteArrayOp_Word8 "indexWord8Array#" GenPrimOp-   ByteArray# -> Int# -> Word8#-   {Read a 8-bit unsigned integer; offset in bytes.}-   with can_fail = True--primop IndexByteArrayOp_Word16 "indexWord16Array#" GenPrimOp-   ByteArray# -> Int# -> Word16#-   {Read a 16-bit unsigned integer; offset in 2-byte words.}-   with can_fail = True--primop IndexByteArrayOp_Word32 "indexWord32Array#" GenPrimOp-   ByteArray# -> Int# -> Word32#-   {Read a 32-bit unsigned integer; offset in 4-byte words.}-   with can_fail = True--primop IndexByteArrayOp_Word64 "indexWord64Array#" GenPrimOp-   ByteArray# -> Int# -> Word64#-   {Read a 64-bit unsigned integer; offset in 8-byte words.}-   with can_fail = True------------------------------------------ unaligned index operations---------------------------------------primop IndexByteArrayOp_Word8AsChar "indexWord8ArrayAsChar#" GenPrimOp-   ByteArray# -> Int# -> Char#-   {Read a 8-bit character; offset in bytes.}-   with can_fail = True--primop IndexByteArrayOp_Word8AsWideChar "indexWord8ArrayAsWideChar#" GenPrimOp-   ByteArray# -> Int# -> Char#-   {Read a 32-bit character; offset in bytes.}-   with can_fail = True--primop IndexByteArrayOp_Word8AsInt "indexWord8ArrayAsInt#" GenPrimOp-   ByteArray# -> Int# -> Int#-   {Read a word-sized integer; offset in bytes.}-   with can_fail = True--primop IndexByteArrayOp_Word8AsWord "indexWord8ArrayAsWord#" GenPrimOp-   ByteArray# -> Int# -> Word#-   {Read a word-sized unsigned integer; offset in bytes.}-   with can_fail = True--primop IndexByteArrayOp_Word8AsAddr "indexWord8ArrayAsAddr#" GenPrimOp-   ByteArray# -> Int# -> Addr#-   {Read a machine address; offset in bytes.}-   with can_fail = True--primop IndexByteArrayOp_Word8AsFloat "indexWord8ArrayAsFloat#" GenPrimOp-   ByteArray# -> Int# -> Float#-   {Read a single-precision floating-point value; offset in bytes.}-   with can_fail = True--primop IndexByteArrayOp_Word8AsDouble "indexWord8ArrayAsDouble#" GenPrimOp-   ByteArray# -> Int# -> Double#-   {Read a double-precision floating-point value; offset in bytes.}-   with can_fail = True--primop IndexByteArrayOp_Word8AsStablePtr "indexWord8ArrayAsStablePtr#" GenPrimOp-   ByteArray# -> Int# -> StablePtr# a-   {Read a {\tt StablePtr#} value; offset in bytes.}-   with can_fail = True--primop IndexByteArrayOp_Word8AsInt16 "indexWord8ArrayAsInt16#" GenPrimOp-   ByteArray# -> Int# -> Int16#-   {Read a 16-bit signed integer; offset in bytes.}-   with can_fail = True--primop IndexByteArrayOp_Word8AsInt32 "indexWord8ArrayAsInt32#" GenPrimOp-   ByteArray# -> Int# -> Int32#-   {Read a 32-bit signed integer; offset in bytes.}-   with can_fail = True--primop IndexByteArrayOp_Word8AsInt64 "indexWord8ArrayAsInt64#" GenPrimOp-   ByteArray# -> Int# -> Int64#-   {Read a 64-bit signed integer; offset in bytes.}-   with can_fail = True--primop IndexByteArrayOp_Word8AsWord16 "indexWord8ArrayAsWord16#" GenPrimOp-   ByteArray# -> Int# -> Word16#-   {Read a 16-bit unsigned integer; offset in bytes.}-   with can_fail = True--primop IndexByteArrayOp_Word8AsWord32 "indexWord8ArrayAsWord32#" GenPrimOp-   ByteArray# -> Int# -> Word32#-   {Read a 32-bit unsigned integer; offset in bytes.}-   with can_fail = True--primop IndexByteArrayOp_Word8AsWord64 "indexWord8ArrayAsWord64#" GenPrimOp-   ByteArray# -> Int# -> Word64#-   {Read a 64-bit unsigned integer; offset in bytes.}-   with can_fail = True------------------------------------------ aligned read operations---------------------------------------primop ReadByteArrayOp_Char "readCharArray#" GenPrimOp-   MutableByteArray# s -> Int# -> State# s -> (# State# s, Char# #)-   {Read a 8-bit character; offset in bytes.}-   with has_side_effects = True-        can_fail = True--primop ReadByteArrayOp_WideChar "readWideCharArray#" GenPrimOp-   MutableByteArray# s -> Int# -> State# s -> (# State# s, Char# #)-   {Read a 32-bit character; offset in 4-byte words.}-   with has_side_effects = True-        can_fail = True--primop ReadByteArrayOp_Int "readIntArray#" GenPrimOp-   MutableByteArray# s -> Int# -> State# s -> (# State# s, Int# #)-   {Read a word-sized integer; offset in machine words.}-   with has_side_effects = True-        can_fail = True--primop ReadByteArrayOp_Word "readWordArray#" GenPrimOp-   MutableByteArray# s -> Int# -> State# s -> (# State# s, Word# #)-   {Read a word-sized unsigned integer; offset in machine words.}-   with has_side_effects = True-        can_fail = True--primop ReadByteArrayOp_Addr "readAddrArray#" GenPrimOp-   MutableByteArray# s -> Int# -> State# s -> (# State# s, Addr# #)-   {Read a machine address; offset in machine words.}-   with has_side_effects = True-        can_fail = True--primop ReadByteArrayOp_Float "readFloatArray#" GenPrimOp-   MutableByteArray# s -> Int# -> State# s -> (# State# s, Float# #)-   {Read a single-precision floating-point value; offset in 4-byte words.}-   with has_side_effects = True-        can_fail = True--primop ReadByteArrayOp_Double "readDoubleArray#" GenPrimOp-   MutableByteArray# s -> Int# -> State# s -> (# State# s, Double# #)-   {Read a double-precision floating-point value; offset in 8-byte words.}-   with has_side_effects = True-        can_fail = True--primop ReadByteArrayOp_StablePtr "readStablePtrArray#" GenPrimOp-   MutableByteArray# s -> Int# -> State# s -> (# State# s, StablePtr# a #)-   {Read a {\tt StablePtr#} value; offset in machine words.}-   with has_side_effects = True-        can_fail = True--primop ReadByteArrayOp_Int8 "readInt8Array#" GenPrimOp-   MutableByteArray# s -> Int# -> State# s -> (# State# s, Int8# #)-   {Read a 8-bit signed integer; offset in bytes.}-   with has_side_effects = True-        can_fail = True--primop ReadByteArrayOp_Int16 "readInt16Array#" GenPrimOp-   MutableByteArray# s -> Int# -> State# s -> (# State# s, Int16# #)-   {Read a 16-bit signed integer; offset in 2-byte words.}-   with has_side_effects = True-        can_fail = True--primop ReadByteArrayOp_Int32 "readInt32Array#" GenPrimOp-   MutableByteArray# s -> Int# -> State# s -> (# State# s, Int32# #)-   {Read a 32-bit signed integer; offset in 4-byte words.}-   with has_side_effects = True-        can_fail = True--primop ReadByteArrayOp_Int64 "readInt64Array#" GenPrimOp-   MutableByteArray# s -> Int# -> State# s -> (# State# s, Int64# #)-   {Read a 64-bit signed integer; offset in 8-byte words.}-   with has_side_effects = True-        can_fail = True--primop ReadByteArrayOp_Word8 "readWord8Array#" GenPrimOp-   MutableByteArray# s -> Int# -> State# s -> (# State# s, Word8# #)-   {Read a 8-bit unsigned integer; offset in bytes.}-   with has_side_effects = True-        can_fail = True--primop ReadByteArrayOp_Word16 "readWord16Array#" GenPrimOp-   MutableByteArray# s -> Int# -> State# s -> (# State# s, Word16# #)-   {Read a 16-bit unsigned integer; offset in 2-byte words.}-   with has_side_effects = True-        can_fail = True--primop ReadByteArrayOp_Word32 "readWord32Array#" GenPrimOp-   MutableByteArray# s -> Int# -> State# s -> (# State# s, Word32# #)-   {Read a 32-bit unsigned integer; offset in 4-byte words.}-   with has_side_effects = True-        can_fail = True--primop ReadByteArrayOp_Word64 "readWord64Array#" GenPrimOp-   MutableByteArray# s -> Int# -> State# s -> (# State# s, Word64# #)-   {Read a 64-bit unsigned integer; offset in 8-byte words.}-   with has_side_effects = True-        can_fail = True------------------------------------------ unaligned read operations---------------------------------------primop ReadByteArrayOp_Word8AsChar "readWord8ArrayAsChar#" GenPrimOp-   MutableByteArray# s -> Int# -> State# s -> (# State# s, Char# #)-   {Read a 8-bit character; offset in bytes.}-   with has_side_effects = True-        can_fail = True--primop ReadByteArrayOp_Word8AsWideChar "readWord8ArrayAsWideChar#" GenPrimOp-   MutableByteArray# s -> Int# -> State# s -> (# State# s, Char# #)-   {Read a 32-bit character; offset in bytes.}-   with has_side_effects = True-        can_fail = True--primop ReadByteArrayOp_Word8AsInt "readWord8ArrayAsInt#" GenPrimOp-   MutableByteArray# s -> Int# -> State# s -> (# State# s, Int# #)-   {Read a word-sized integer; offset in bytes.}-   with has_side_effects = True-        can_fail = True--primop ReadByteArrayOp_Word8AsWord "readWord8ArrayAsWord#" GenPrimOp-   MutableByteArray# s -> Int# -> State# s -> (# State# s, Word# #)-   {Read a word-sized unsigned integer; offset in bytes.}-   with has_side_effects = True-        can_fail = True--primop ReadByteArrayOp_Word8AsAddr "readWord8ArrayAsAddr#" GenPrimOp-   MutableByteArray# s -> Int# -> State# s -> (# State# s, Addr# #)-   {Read a machine address; offset in bytes.}-   with has_side_effects = True-        can_fail = True--primop ReadByteArrayOp_Word8AsFloat "readWord8ArrayAsFloat#" GenPrimOp-   MutableByteArray# s -> Int# -> State# s -> (# State# s, Float# #)-   {Read a single-precision floating-point value; offset in bytes.}-   with has_side_effects = True-        can_fail = True--primop ReadByteArrayOp_Word8AsDouble "readWord8ArrayAsDouble#" GenPrimOp-   MutableByteArray# s -> Int# -> State# s -> (# State# s, Double# #)-   {Read a double-precision floating-point value; offset in bytes.}-   with has_side_effects = True-        can_fail = True--primop ReadByteArrayOp_Word8AsStablePtr "readWord8ArrayAsStablePtr#" GenPrimOp-   MutableByteArray# s -> Int# -> State# s -> (# State# s, StablePtr# a #)-   {Read a {\tt StablePtr#} value; offset in bytes.}-   with has_side_effects = True-        can_fail = True--primop ReadByteArrayOp_Word8AsInt16 "readWord8ArrayAsInt16#" GenPrimOp-   MutableByteArray# s -> Int# -> State# s -> (# State# s, Int16# #)-   {Read a 16-bit signed integer; offset in bytes.}-   with has_side_effects = True-        can_fail = True--primop ReadByteArrayOp_Word8AsInt32 "readWord8ArrayAsInt32#" GenPrimOp-   MutableByteArray# s -> Int# -> State# s -> (# State# s, Int32# #)-   {Read a 32-bit signed integer; offset in bytes.}-   with has_side_effects = True-        can_fail = True--primop ReadByteArrayOp_Word8AsInt64 "readWord8ArrayAsInt64#" GenPrimOp-   MutableByteArray# s -> Int# -> State# s -> (# State# s, Int64# #)-   {Read a 64-bit signed integer; offset in bytes.}-   with has_side_effects = True-        can_fail = True--primop ReadByteArrayOp_Word8AsWord16 "readWord8ArrayAsWord16#" GenPrimOp-   MutableByteArray# s -> Int# -> State# s -> (# State# s, Word16# #)-   {Read a 16-bit unsigned integer; offset in bytes.}-   with has_side_effects = True-        can_fail = True--primop ReadByteArrayOp_Word8AsWord32 "readWord8ArrayAsWord32#" GenPrimOp-   MutableByteArray# s -> Int# -> State# s -> (# State# s, Word32# #)-   {Read a 32-bit unsigned integer; offset in bytes.}-   with has_side_effects = True-        can_fail = True--primop ReadByteArrayOp_Word8AsWord64 "readWord8ArrayAsWord64#" GenPrimOp-   MutableByteArray# s -> Int# -> State# s -> (# State# s, Word64# #)-   {Read a 64-bit unsigned integer; offset in bytes.}-   with has_side_effects = True-        can_fail = True------------------------------------------ aligned write operations---------------------------------------primop WriteByteArrayOp_Char "writeCharArray#" GenPrimOp-   MutableByteArray# s -> Int# -> Char# -> State# s -> State# s-   {Write a 8-bit character; offset in bytes.}-   with has_side_effects = True-        can_fail = True--primop WriteByteArrayOp_WideChar "writeWideCharArray#" GenPrimOp-   MutableByteArray# s -> Int# -> Char# -> State# s -> State# s-   {Write a 32-bit character; offset in 4-byte words.}-   with has_side_effects = True-        can_fail = True--primop WriteByteArrayOp_Int "writeIntArray#" GenPrimOp-   MutableByteArray# s -> Int# -> Int# -> State# s -> State# s-   {Write a word-sized integer; offset in machine words.}-   with has_side_effects = True-        can_fail = True--primop WriteByteArrayOp_Word "writeWordArray#" GenPrimOp-   MutableByteArray# s -> Int# -> Word# -> State# s -> State# s-   {Write a word-sized unsigned integer; offset in machine words.}-   with has_side_effects = True-        can_fail = True--primop WriteByteArrayOp_Addr "writeAddrArray#" GenPrimOp-   MutableByteArray# s -> Int# -> Addr# -> State# s -> State# s-   {Write a machine address; offset in machine words.}-   with has_side_effects = True-        can_fail = True--primop WriteByteArrayOp_Float "writeFloatArray#" GenPrimOp-   MutableByteArray# s -> Int# -> Float# -> State# s -> State# s-   {Write a single-precision floating-point value; offset in 4-byte words.}-   with has_side_effects = True-        can_fail = True--primop WriteByteArrayOp_Double "writeDoubleArray#" GenPrimOp-   MutableByteArray# s -> Int# -> Double# -> State# s -> State# s-   {Write a double-precision floating-point value; offset in 8-byte words.}-   with has_side_effects = True-        can_fail = True--primop WriteByteArrayOp_StablePtr "writeStablePtrArray#" GenPrimOp-   MutableByteArray# s -> Int# -> StablePtr# a -> State# s -> State# s-   {Write a {\tt StablePtr#} value; offset in machine words.}-   with has_side_effects = True-        can_fail = True--primop WriteByteArrayOp_Int8 "writeInt8Array#" GenPrimOp-   MutableByteArray# s -> Int# -> Int8# -> State# s -> State# s-   {Write a 8-bit signed integer; offset in bytes.}-   with has_side_effects = True-        can_fail = True--primop WriteByteArrayOp_Int16 "writeInt16Array#" GenPrimOp-   MutableByteArray# s -> Int# -> Int16# -> State# s -> State# s-   {Write a 16-bit signed integer; offset in 2-byte words.}-   with has_side_effects = True-        can_fail = True--primop WriteByteArrayOp_Int32 "writeInt32Array#" GenPrimOp-   MutableByteArray# s -> Int# -> Int32# -> State# s -> State# s-   {Write a 32-bit signed integer; offset in 4-byte words.}-   with has_side_effects = True-        can_fail = True--primop WriteByteArrayOp_Int64 "writeInt64Array#" GenPrimOp-   MutableByteArray# s -> Int# -> Int64# -> State# s -> State# s-   {Write a 64-bit signed integer; offset in 8-byte words.}-   with has_side_effects = True-        can_fail = True--primop WriteByteArrayOp_Word8 "writeWord8Array#" GenPrimOp-   MutableByteArray# s -> Int# -> Word8# -> State# s -> State# s-   {Write a 8-bit unsigned integer; offset in bytes.}-   with has_side_effects = True-        can_fail = True--primop WriteByteArrayOp_Word16 "writeWord16Array#" GenPrimOp-   MutableByteArray# s -> Int# -> Word16# -> State# s -> State# s-   {Write a 16-bit unsigned integer; offset in 2-byte words.}-   with has_side_effects = True-        can_fail = True--primop WriteByteArrayOp_Word32 "writeWord32Array#" GenPrimOp-   MutableByteArray# s -> Int# -> Word32# -> State# s -> State# s-   {Write a 32-bit unsigned integer; offset in 4-byte words.}-   with has_side_effects = True-        can_fail = True--primop WriteByteArrayOp_Word64 "writeWord64Array#" GenPrimOp-   MutableByteArray# s -> Int# -> Word64# -> State# s -> State# s-   {Write a 64-bit unsigned integer; offset in 8-byte words.}-   with has_side_effects = True-        can_fail = True------------------------------------------ unaligned write operations---------------------------------------primop WriteByteArrayOp_Word8AsChar "writeWord8ArrayAsChar#" GenPrimOp-   MutableByteArray# s -> Int# -> Char# -> State# s -> State# s-   {Write a 8-bit character; offset in bytes.}-   with has_side_effects = True-        can_fail = True--primop WriteByteArrayOp_Word8AsWideChar "writeWord8ArrayAsWideChar#" GenPrimOp-   MutableByteArray# s -> Int# -> Char# -> State# s -> State# s-   {Write a 32-bit character; offset in bytes.}-   with has_side_effects = True-        can_fail = True--primop WriteByteArrayOp_Word8AsInt "writeWord8ArrayAsInt#" GenPrimOp-   MutableByteArray# s -> Int# -> Int# -> State# s -> State# s-   {Write a word-sized integer; offset in bytes.}-   with has_side_effects = True-        can_fail = True--primop WriteByteArrayOp_Word8AsWord "writeWord8ArrayAsWord#" GenPrimOp-   MutableByteArray# s -> Int# -> Word# -> State# s -> State# s-   {Write a word-sized unsigned integer; offset in bytes.}-   with has_side_effects = True-        can_fail = True--primop WriteByteArrayOp_Word8AsAddr "writeWord8ArrayAsAddr#" GenPrimOp-   MutableByteArray# s -> Int# -> Addr# -> State# s -> State# s-   {Write a machine address; offset in bytes.}-   with has_side_effects = True-        can_fail = True--primop WriteByteArrayOp_Word8AsFloat "writeWord8ArrayAsFloat#" GenPrimOp-   MutableByteArray# s -> Int# -> Float# -> State# s -> State# s-   {Write a single-precision floating-point value; offset in bytes.}-   with has_side_effects = True-        can_fail = True--primop WriteByteArrayOp_Word8AsDouble "writeWord8ArrayAsDouble#" GenPrimOp-   MutableByteArray# s -> Int# -> Double# -> State# s -> State# s-   {Write a double-precision floating-point value; offset in bytes.}-   with has_side_effects = True-        can_fail = True--primop WriteByteArrayOp_Word8AsStablePtr "writeWord8ArrayAsStablePtr#" GenPrimOp-   MutableByteArray# s -> Int# -> StablePtr# a -> State# s -> State# s-   {Write a {\tt StablePtr#} value; offset in bytes.}-   with has_side_effects = True-        can_fail = True--primop WriteByteArrayOp_Word8AsInt16 "writeWord8ArrayAsInt16#" GenPrimOp-   MutableByteArray# s -> Int# -> Int16# -> State# s -> State# s-   {Write a 16-bit signed integer; offset in bytes.}-   with has_side_effects = True-        can_fail = True--primop WriteByteArrayOp_Word8AsInt32 "writeWord8ArrayAsInt32#" GenPrimOp-   MutableByteArray# s -> Int# -> Int32# -> State# s -> State# s-   {Write a 32-bit signed integer; offset in bytes.}-   with has_side_effects = True-        can_fail = True--primop WriteByteArrayOp_Word8AsInt64 "writeWord8ArrayAsInt64#" GenPrimOp-   MutableByteArray# s -> Int# -> Int64# -> State# s -> State# s-   {Write a 64-bit signed integer; offset in bytes.}-   with has_side_effects = True-        can_fail = True--primop WriteByteArrayOp_Word8AsWord16 "writeWord8ArrayAsWord16#" GenPrimOp-   MutableByteArray# s -> Int# -> Word16# -> State# s -> State# s-   {Write a 16-bit unsigned integer; offset in bytes.}-   with has_side_effects = True-        can_fail = True--primop WriteByteArrayOp_Word8AsWord32 "writeWord8ArrayAsWord32#" GenPrimOp-   MutableByteArray# s -> Int# -> Word32# -> State# s -> State# s-   {Write a 32-bit unsigned integer; offset in bytes.}-   with has_side_effects = True-        can_fail = True--primop WriteByteArrayOp_Word8AsWord64 "writeWord8ArrayAsWord64#" GenPrimOp-   MutableByteArray# s -> Int# -> Word64# -> State# s -> State# s-   {Write a 64-bit unsigned integer; offset in bytes.}-   with has_side_effects = True-        can_fail = True-
GHC/Builtin/primops.txt.pp view
@@ -74,3840 +74,4412 @@ --   2. The dummy Prim.hs file, which is used for Haddock and --      contains descriptions taken from primops.txt.pp. --      All definitions are replaced by placeholders.---      See Note [GHC.Prim Docs] in genprimopcode.------   3. The module PrimopWrappers.hs, which wraps every call for GHCi;---      see Note [Primop wrappers] in GHC.Builtin.Primops for details.------ * This file does not list internal-only equality types---   (GHC.Builtin.Types.Prim.unexposedPrimTyCons and coercionToken#---   in GHC.Types.Id.Make) which are defined but not exported from GHC.Prim.---   Every export of GHC.Prim should be in listed in this file.------ * The primitive types should be listed in primTyCons in Builtin.Types.Prim---   in addition to primops.txt.pp.---   (This task should be delegated to genprimopcode in the future.)------------ Information on how PrimOps are implemented and the steps necessary to--- add a new one can be found in the Commentary:------  https://gitlab.haskell.org/ghc/ghc/wikis/commentary/prim-ops------ This file is divided into named sections, each containing or more--- primop entries. Section headers have the format:------      section "section-name" {description}------ This information is used solely when producing documentation; it is--- otherwise ignored.  The description is optional.------ The format of each primop entry is as follows:------      primop internal-name "name-in-program-text" category type {description} attributes---- The default attribute values which apply if you don't specify--- other ones.  Attribute values can be True, False, or arbitrary--- text between curly brackets.  This is a kludge to enable--- processors of this file to easily get hold of simple info--- (eg, out_of_line), whilst avoiding parsing complex expressions--- needed for strictness info.------ type refers to the general category of the primop. There are only two:------  * Compare:   A comparison operation of the shape a -> a -> Int#---  * GenPrimOp: Any other sort of primop------- The vector attribute is rather special. It takes a list of 3-tuples, each of--- which is of the form <ELEM_TYPE,SCALAR_TYPE,LENGTH>. ELEM_TYPE is the type of--- the elements in the vector; LENGTH is the length of the vector; and--- SCALAR_TYPE is the scalar type used to inject to/project from vector--- element. Note that ELEM_TYPE and SCALAR_TYPE are not the same; for example,--- to broadcast a scalar value to a vector whose elements are of type Int8, we--- use an Int#.---- When a primtype or primop has a vector attribute, it is instantiated at each--- 3-tuple in the list of 3-tuples. That is, the vector attribute allows us to--- define a family of types or primops. Vector support also adds three new--- keywords: VECTOR, SCALAR, and VECTUPLE. These keywords are expanded to types--- derived from the 3-tuple. For the 3-tuple <Int64#,Int64#,2>, VECTOR expands to--- Int64X2#, SCALAR expands to Int64#, and VECTUPLE expands to (# Int64#, Int64# #).--defaults-   has_side_effects = False-   out_of_line      = False   -- See Note [When do out-of-line primops go in primops.txt.pp]-   can_fail         = False   -- See Note [PrimOp can_fail and has_side_effects] in PrimOp-   commutable       = False-   code_size        = { primOpCodeSizeDefault }-   strictness       = { \ arity -> mkClosedDmdSig (replicate arity topDmd) topDiv }-   fixity           = Nothing-   llvm_only        = False-   vector           = []-   deprecated_msg   = {}      -- A non-empty message indicates deprecation---- Note [When do out-of-line primops go in primops.txt.pp]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- Out of line primops are those with a C-- implementation. But that--- doesn't mean they *just* have an C-- implementation. As mentioned in--- Note [Inlining out-of-line primops and heap checks], some out-of-line--- primops also have additional internal implementations under certain--- conditions. Now that `foreign import prim` exists, only those primops--- which have both internal and external implementations ought to be--- this file. The rest aren't really primops, since they don't need--- bespoke compiler support but just a general way to interface with--- C--. They are just foreign calls.------ Unfortunately, for the time being most of the primops which should be--- moved according to the previous paragraph can't yet. There are some--- superficial restrictions in `foreign import prim` which must be fixed--- first. Specifically, `foreign import prim` always requires:------   - No polymorphism in type---   - `strictness       = <default>`---   - `can_fail         = False`---   - `has_side_effects = True`------ https://gitlab.haskell.org/ghc/ghc/issues/16929 tracks this issue,--- and has a table of which external-only primops are blocked by which--- of these. Hopefully those restrictions are relaxed so the rest of--- those can be moved over.------ 'module GHC.Prim.Ext is a temporarily "holding ground" for primops--- that were formally in here, until they can be given a better home.--- Likewise, their underlying C-- implementation need not live in the--- RTS either. Best case (in my view), both the C-- and `foreign import--- prim` can be moved to a small library tailured to the features being--- implemented and dependencies of those features.---- Currently, documentation is produced using latex, so contents of--- description fields should be legal latex. Descriptions can contain--- matched pairs of embedded curly brackets.---- Note [Levity and representation polymorphic primops]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- In the types of primops in this module,------ * The names `a,b,c,s` stand for type variables of kind Type------ * The names `v` and `w` stand for levity-polymorphic---   type variables.---   For example:---      op :: v -> w -> Int---   really means---      op :: forall {l :: Levity} (a :: TYPE (BoxedRep l))---                   {k :: Levity} (b :: TYPE (BoxedRep k)).---            a -> b -> Int---  Two important things to note:---     - `v` and `w` have independent levities `l` and `k` (respectively), and---       these are inferred (not specified), as seen from the curly brackets.---     - `v` and `w` end up written as `a` and `b` (respectively) in types,---       which means that one shouldn't write a primop type involving both---       `a` and `v`, nor `b` and `w`.------ * The names `o` and `p` stand for representation-polymorphic---   type variables, similarly to `v` and `w` above. For example:---      op :: o -> p -> Int---   really means---      op :: forall {q :: RuntimeRep} (a :: TYPE q)---                   {r :: RuntimeRep} (b :: TYPE r)---            a -> b -> Int---   We note:---    - `o` and `p` have independent `RuntimeRep`s `q` and `r`, which are---       inferred type variables (like for `v` and `w` above).---    - `o` and `p` share textual names with `a` and `b` (respectively).---      This means one shouldn't write a type involving both `a` and `o`,---      nor `b` and `p`, nor `o` and `v`, etc.--section "The word size story."-        {Haskell98 specifies that signed integers (type {\tt Int})-         must contain at least 30 bits. GHC always implements {\tt-         Int} using the primitive type {\tt Int\#}, whose size equals-         the {\tt MachDeps.h} constant {\tt WORD\_SIZE\_IN\_BITS}.-         This is normally set based on the {\tt config.h} parameter-         {\tt SIZEOF\_HSWORD}, i.e., 32 bits on 32-bit machines, 64-         bits on 64-bit machines.--         GHC also implements a primitive unsigned integer type {\tt-         Word\#} which always has the same number of bits as {\tt-         Int\#}.--         In addition, GHC supports families of explicit-sized integers-         and words at 8, 16, 32, and 64 bits, with the usual-         arithmetic operations, comparisons, and a range of-         conversions.--         Finally, there are strongly deprecated primops for coercing-         between {\tt Addr\#}, the primitive type of machine-         addresses, and {\tt Int\#}.  These are pretty bogus anyway,-         but will work on existing 32-bit and 64-bit GHC targets; they-         are completely bogus when tag bits are used in {\tt Int\#},-         so are not available in this case.  }---------------------------------------------------------------------------section "Char#"-        {Operations on 31-bit characters.}---------------------------------------------------------------------------primtype Char#--primop   CharGtOp  "gtChar#"   Compare   Char# -> Char# -> Int#-primop   CharGeOp  "geChar#"   Compare   Char# -> Char# -> Int#--primop   CharEqOp  "eqChar#"   Compare-   Char# -> Char# -> Int#-   with commutable = True--primop   CharNeOp  "neChar#"   Compare-   Char# -> Char# -> Int#-   with commutable = True--primop   CharLtOp  "ltChar#"   Compare   Char# -> Char# -> Int#-primop   CharLeOp  "leChar#"   Compare   Char# -> Char# -> Int#--primop   OrdOp   "ord#"  GenPrimOp   Char# -> Int#-   with code_size = 0---------------------------------------------------------------------------section "Int8#"-        {Operations on 8-bit integers.}---------------------------------------------------------------------------primtype Int8#--primop Int8ToIntOp "int8ToInt#" GenPrimOp Int8# -> Int#-primop IntToInt8Op "intToInt8#" GenPrimOp Int# -> Int8#--primop Int8NegOp "negateInt8#" GenPrimOp Int8# -> Int8#--primop Int8AddOp "plusInt8#" GenPrimOp Int8# -> Int8# -> Int8#-  with-    commutable = True--primop Int8SubOp "subInt8#" GenPrimOp Int8# -> Int8# -> Int8#--primop Int8MulOp "timesInt8#" GenPrimOp Int8# -> Int8# -> Int8#-  with-    commutable = True--primop Int8QuotOp "quotInt8#" GenPrimOp Int8# -> Int8# -> Int8#-  with-    can_fail = True--primop Int8RemOp "remInt8#" GenPrimOp Int8# -> Int8# -> Int8#-  with-    can_fail = True--primop Int8QuotRemOp "quotRemInt8#" GenPrimOp Int8# -> Int8# -> (# Int8#, Int8# #)-  with-    can_fail = True--primop Int8SllOp "uncheckedShiftLInt8#"  GenPrimOp Int8# -> Int# -> Int8#-primop Int8SraOp "uncheckedShiftRAInt8#" GenPrimOp Int8# -> Int# -> Int8#-primop Int8SrlOp "uncheckedShiftRLInt8#" GenPrimOp Int8# -> Int# -> Int8#--primop Int8ToWord8Op "int8ToWord8#" GenPrimOp Int8# -> Word8#-   with code_size = 0--primop Int8EqOp "eqInt8#" Compare Int8# -> Int8# -> Int#-primop Int8GeOp "geInt8#" Compare Int8# -> Int8# -> Int#-primop Int8GtOp "gtInt8#" Compare Int8# -> Int8# -> Int#-primop Int8LeOp "leInt8#" Compare Int8# -> Int8# -> Int#-primop Int8LtOp "ltInt8#" Compare Int8# -> Int8# -> Int#-primop Int8NeOp "neInt8#" Compare Int8# -> Int8# -> Int#---------------------------------------------------------------------------section "Word8#"-        {Operations on 8-bit unsigned words.}---------------------------------------------------------------------------primtype Word8#--primop Word8ToWordOp "word8ToWord#" GenPrimOp Word8# -> Word#-primop WordToWord8Op "wordToWord8#" GenPrimOp Word# -> Word8#--primop Word8AddOp "plusWord8#" GenPrimOp Word8# -> Word8# -> Word8#-  with-    commutable = True--primop Word8SubOp "subWord8#" GenPrimOp Word8# -> Word8# -> Word8#--primop Word8MulOp "timesWord8#" GenPrimOp Word8# -> Word8# -> Word8#-  with-    commutable = True--primop Word8QuotOp "quotWord8#" GenPrimOp Word8# -> Word8# -> Word8#-  with-    can_fail = True--primop Word8RemOp "remWord8#" GenPrimOp Word8# -> Word8# -> Word8#-  with-    can_fail = True--primop Word8QuotRemOp "quotRemWord8#" GenPrimOp Word8# -> Word8# -> (# Word8#, Word8# #)-  with-    can_fail = True--primop Word8AndOp "andWord8#" GenPrimOp Word8# -> Word8# -> Word8#-   with commutable = True--primop Word8OrOp "orWord8#" GenPrimOp Word8# -> Word8# -> Word8#-   with commutable = True--primop Word8XorOp "xorWord8#" GenPrimOp Word8# -> Word8# -> Word8#-   with commutable = True--primop Word8NotOp "notWord8#" GenPrimOp Word8# -> Word8#--primop Word8SllOp "uncheckedShiftLWord8#"  GenPrimOp Word8# -> Int# -> Word8#-primop Word8SrlOp "uncheckedShiftRLWord8#" GenPrimOp Word8# -> Int# -> Word8#--primop Word8ToInt8Op "word8ToInt8#" GenPrimOp Word8# -> Int8#-   with code_size = 0--primop Word8EqOp "eqWord8#" Compare Word8# -> Word8# -> Int#-primop Word8GeOp "geWord8#" Compare Word8# -> Word8# -> Int#-primop Word8GtOp "gtWord8#" Compare Word8# -> Word8# -> Int#-primop Word8LeOp "leWord8#" Compare Word8# -> Word8# -> Int#-primop Word8LtOp "ltWord8#" Compare Word8# -> Word8# -> Int#-primop Word8NeOp "neWord8#" Compare Word8# -> Word8# -> Int#---------------------------------------------------------------------------section "Int16#"-        {Operations on 16-bit integers.}---------------------------------------------------------------------------primtype Int16#--primop Int16ToIntOp "int16ToInt#" GenPrimOp Int16# -> Int#-primop IntToInt16Op "intToInt16#" GenPrimOp Int# -> Int16#--primop Int16NegOp "negateInt16#" GenPrimOp Int16# -> Int16#--primop Int16AddOp "plusInt16#" GenPrimOp Int16# -> Int16# -> Int16#-  with-    commutable = True--primop Int16SubOp "subInt16#" GenPrimOp Int16# -> Int16# -> Int16#--primop Int16MulOp "timesInt16#" GenPrimOp Int16# -> Int16# -> Int16#-  with-    commutable = True--primop Int16QuotOp "quotInt16#" GenPrimOp Int16# -> Int16# -> Int16#-  with-    can_fail = True--primop Int16RemOp "remInt16#" GenPrimOp Int16# -> Int16# -> Int16#-  with-    can_fail = True--primop Int16QuotRemOp "quotRemInt16#" GenPrimOp Int16# -> Int16# -> (# Int16#, Int16# #)-  with-    can_fail = True--primop Int16SllOp "uncheckedShiftLInt16#"  GenPrimOp Int16# -> Int# -> Int16#-primop Int16SraOp "uncheckedShiftRAInt16#" GenPrimOp Int16# -> Int# -> Int16#-primop Int16SrlOp "uncheckedShiftRLInt16#" GenPrimOp Int16# -> Int# -> Int16#--primop Int16ToWord16Op "int16ToWord16#" GenPrimOp Int16# -> Word16#-   with code_size = 0--primop Int16EqOp "eqInt16#" Compare Int16# -> Int16# -> Int#-primop Int16GeOp "geInt16#" Compare Int16# -> Int16# -> Int#-primop Int16GtOp "gtInt16#" Compare Int16# -> Int16# -> Int#-primop Int16LeOp "leInt16#" Compare Int16# -> Int16# -> Int#-primop Int16LtOp "ltInt16#" Compare Int16# -> Int16# -> Int#-primop Int16NeOp "neInt16#" Compare Int16# -> Int16# -> Int#---------------------------------------------------------------------------section "Word16#"-        {Operations on 16-bit unsigned words.}---------------------------------------------------------------------------primtype Word16#--primop Word16ToWordOp "word16ToWord#" GenPrimOp Word16# -> Word#-primop WordToWord16Op "wordToWord16#" GenPrimOp Word# -> Word16#--primop Word16AddOp "plusWord16#" GenPrimOp Word16# -> Word16# -> Word16#-  with-    commutable = True--primop Word16SubOp "subWord16#" GenPrimOp Word16# -> Word16# -> Word16#--primop Word16MulOp "timesWord16#" GenPrimOp Word16# -> Word16# -> Word16#-  with-    commutable = True--primop Word16QuotOp "quotWord16#" GenPrimOp Word16# -> Word16# -> Word16#-  with-    can_fail = True--primop Word16RemOp "remWord16#" GenPrimOp Word16# -> Word16# -> Word16#-  with-    can_fail = True--primop Word16QuotRemOp "quotRemWord16#" GenPrimOp Word16# -> Word16# -> (# Word16#, Word16# #)-  with-    can_fail = True--primop Word16AndOp "andWord16#" GenPrimOp Word16# -> Word16# -> Word16#-   with commutable = True--primop Word16OrOp "orWord16#" GenPrimOp Word16# -> Word16# -> Word16#-   with commutable = True--primop Word16XorOp "xorWord16#" GenPrimOp Word16# -> Word16# -> Word16#-   with commutable = True--primop Word16NotOp "notWord16#" GenPrimOp Word16# -> Word16#--primop Word16SllOp "uncheckedShiftLWord16#"  GenPrimOp Word16# -> Int# -> Word16#-primop Word16SrlOp "uncheckedShiftRLWord16#" GenPrimOp Word16# -> Int# -> Word16#--primop Word16ToInt16Op "word16ToInt16#" GenPrimOp Word16# -> Int16#-   with code_size = 0--primop Word16EqOp "eqWord16#" Compare Word16# -> Word16# -> Int#-primop Word16GeOp "geWord16#" Compare Word16# -> Word16# -> Int#-primop Word16GtOp "gtWord16#" Compare Word16# -> Word16# -> Int#-primop Word16LeOp "leWord16#" Compare Word16# -> Word16# -> Int#-primop Word16LtOp "ltWord16#" Compare Word16# -> Word16# -> Int#-primop Word16NeOp "neWord16#" Compare Word16# -> Word16# -> Int#---------------------------------------------------------------------------section "Int32#"-        {Operations on 32-bit integers.}---------------------------------------------------------------------------primtype Int32#--primop Int32ToIntOp "int32ToInt#" GenPrimOp Int32# -> Int#-primop IntToInt32Op "intToInt32#" GenPrimOp Int# -> Int32#--primop Int32NegOp "negateInt32#" GenPrimOp Int32# -> Int32#--primop Int32AddOp "plusInt32#" GenPrimOp Int32# -> Int32# -> Int32#-  with-    commutable = True--primop Int32SubOp "subInt32#" GenPrimOp Int32# -> Int32# -> Int32#--primop Int32MulOp "timesInt32#" GenPrimOp Int32# -> Int32# -> Int32#-  with-    commutable = True--primop Int32QuotOp "quotInt32#" GenPrimOp Int32# -> Int32# -> Int32#-  with-    can_fail = True--primop Int32RemOp "remInt32#" GenPrimOp Int32# -> Int32# -> Int32#-  with-    can_fail = True--primop Int32QuotRemOp "quotRemInt32#" GenPrimOp Int32# -> Int32# -> (# Int32#, Int32# #)-  with-    can_fail = True--primop Int32SllOp "uncheckedShiftLInt32#"  GenPrimOp Int32# -> Int# -> Int32#-primop Int32SraOp "uncheckedShiftRAInt32#" GenPrimOp Int32# -> Int# -> Int32#-primop Int32SrlOp "uncheckedShiftRLInt32#" GenPrimOp Int32# -> Int# -> Int32#--primop Int32ToWord32Op "int32ToWord32#" GenPrimOp Int32# -> Word32#-   with code_size = 0--primop Int32EqOp "eqInt32#" Compare Int32# -> Int32# -> Int#-primop Int32GeOp "geInt32#" Compare Int32# -> Int32# -> Int#-primop Int32GtOp "gtInt32#" Compare Int32# -> Int32# -> Int#-primop Int32LeOp "leInt32#" Compare Int32# -> Int32# -> Int#-primop Int32LtOp "ltInt32#" Compare Int32# -> Int32# -> Int#-primop Int32NeOp "neInt32#" Compare Int32# -> Int32# -> Int#---------------------------------------------------------------------------section "Word32#"-        {Operations on 32-bit unsigned words.}---------------------------------------------------------------------------primtype Word32#--primop Word32ToWordOp "word32ToWord#" GenPrimOp Word32# -> Word#-primop WordToWord32Op "wordToWord32#" GenPrimOp Word# -> Word32#--primop Word32AddOp "plusWord32#" GenPrimOp Word32# -> Word32# -> Word32#-  with-    commutable = True--primop Word32SubOp "subWord32#" GenPrimOp Word32# -> Word32# -> Word32#--primop Word32MulOp "timesWord32#" GenPrimOp Word32# -> Word32# -> Word32#-  with-    commutable = True--primop Word32QuotOp "quotWord32#" GenPrimOp Word32# -> Word32# -> Word32#-  with-    can_fail = True--primop Word32RemOp "remWord32#" GenPrimOp Word32# -> Word32# -> Word32#-  with-    can_fail = True--primop Word32QuotRemOp "quotRemWord32#" GenPrimOp Word32# -> Word32# -> (# Word32#, Word32# #)-  with-    can_fail = True--primop Word32AndOp "andWord32#" GenPrimOp Word32# -> Word32# -> Word32#-   with commutable = True--primop Word32OrOp "orWord32#" GenPrimOp Word32# -> Word32# -> Word32#-   with commutable = True--primop Word32XorOp "xorWord32#" GenPrimOp Word32# -> Word32# -> Word32#-   with commutable = True--primop Word32NotOp "notWord32#" GenPrimOp Word32# -> Word32#--primop Word32SllOp "uncheckedShiftLWord32#"  GenPrimOp Word32# -> Int# -> Word32#-primop Word32SrlOp "uncheckedShiftRLWord32#" GenPrimOp Word32# -> Int# -> Word32#--primop Word32ToInt32Op "word32ToInt32#" GenPrimOp Word32# -> Int32#-   with code_size = 0--primop Word32EqOp "eqWord32#" Compare Word32# -> Word32# -> Int#-primop Word32GeOp "geWord32#" Compare Word32# -> Word32# -> Int#-primop Word32GtOp "gtWord32#" Compare Word32# -> Word32# -> Int#-primop Word32LeOp "leWord32#" Compare Word32# -> Word32# -> Int#-primop Word32LtOp "ltWord32#" Compare Word32# -> Word32# -> Int#-primop Word32NeOp "neWord32#" Compare Word32# -> Word32# -> Int#---------------------------------------------------------------------------section "Int64#"-        {Operations on 64-bit signed words.}---------------------------------------------------------------------------primtype Int64#--primop Int64ToIntOp "int64ToInt#" GenPrimOp Int64# -> Int#-primop IntToInt64Op "intToInt64#" GenPrimOp Int# -> Int64#--primop Int64NegOp "negateInt64#" GenPrimOp Int64# -> Int64#--primop Int64AddOp "plusInt64#" GenPrimOp Int64# -> Int64# -> Int64#-  with-    commutable = True--primop Int64SubOp "subInt64#" GenPrimOp Int64# -> Int64# -> Int64#--primop Int64MulOp "timesInt64#" GenPrimOp Int64# -> Int64# -> Int64#-  with-    commutable = True--primop Int64QuotOp "quotInt64#" GenPrimOp Int64# -> Int64# -> Int64#-  with-    can_fail = True--primop Int64RemOp "remInt64#" GenPrimOp Int64# -> Int64# -> Int64#-  with-    can_fail = True--primop Int64SllOp "uncheckedIShiftL64#"  GenPrimOp Int64# -> Int# -> Int64#-primop Int64SraOp "uncheckedIShiftRA64#" GenPrimOp Int64# -> Int# -> Int64#-primop Int64SrlOp "uncheckedIShiftRL64#" GenPrimOp Int64# -> Int# -> Int64#--primop Int64ToWord64Op "int64ToWord64#" GenPrimOp Int64# -> Word64#-   with code_size = 0--primop Int64EqOp "eqInt64#" Compare Int64# -> Int64# -> Int#-primop Int64GeOp "geInt64#" Compare Int64# -> Int64# -> Int#-primop Int64GtOp "gtInt64#" Compare Int64# -> Int64# -> Int#-primop Int64LeOp "leInt64#" Compare Int64# -> Int64# -> Int#-primop Int64LtOp "ltInt64#" Compare Int64# -> Int64# -> Int#-primop Int64NeOp "neInt64#" Compare Int64# -> Int64# -> Int#---------------------------------------------------------------------------section "Word64#"-        {Operations on 64-bit unsigned words.}---------------------------------------------------------------------------primtype Word64#--primop Word64ToWordOp "word64ToWord#" GenPrimOp Word64# -> Word#-primop WordToWord64Op "wordToWord64#" GenPrimOp Word# -> Word64#--primop Word64AddOp "plusWord64#" GenPrimOp Word64# -> Word64# -> Word64#-  with-    commutable = True--primop Word64SubOp "subWord64#" GenPrimOp Word64# -> Word64# -> Word64#--primop Word64MulOp "timesWord64#" GenPrimOp Word64# -> Word64# -> Word64#-  with-    commutable = True--primop Word64QuotOp "quotWord64#" GenPrimOp Word64# -> Word64# -> Word64#-  with-    can_fail = True--primop Word64RemOp "remWord64#" GenPrimOp Word64# -> Word64# -> Word64#-  with-    can_fail = True--primop Word64AndOp "and64#" GenPrimOp Word64# -> Word64# -> Word64#-   with commutable = True--primop Word64OrOp "or64#" GenPrimOp Word64# -> Word64# -> Word64#-   with commutable = True--primop Word64XorOp "xor64#" GenPrimOp Word64# -> Word64# -> Word64#-   with commutable = True--primop Word64NotOp "not64#" GenPrimOp Word64# -> Word64#--primop Word64SllOp "uncheckedShiftL64#"  GenPrimOp Word64# -> Int# -> Word64#-primop Word64SrlOp "uncheckedShiftRL64#" GenPrimOp Word64# -> Int# -> Word64#--primop Word64ToInt64Op "word64ToInt64#" GenPrimOp Word64# -> Int64#-   with code_size = 0--primop Word64EqOp "eqWord64#" Compare Word64# -> Word64# -> Int#-primop Word64GeOp "geWord64#" Compare Word64# -> Word64# -> Int#-primop Word64GtOp "gtWord64#" Compare Word64# -> Word64# -> Int#-primop Word64LeOp "leWord64#" Compare Word64# -> Word64# -> Int#-primop Word64LtOp "ltWord64#" Compare Word64# -> Word64# -> Int#-primop Word64NeOp "neWord64#" Compare Word64# -> Word64# -> Int#---------------------------------------------------------------------------section "Int#"-        {Operations on native-size integers (32+ bits).}---------------------------------------------------------------------------primtype Int#--primop   IntAddOp    "+#"    GenPrimOp-   Int# -> Int# -> Int#-   with commutable = True-        fixity = infixl 6--primop   IntSubOp    "-#"    GenPrimOp   Int# -> Int# -> Int#-   with fixity = infixl 6--primop   IntMulOp    "*#"-   GenPrimOp   Int# -> Int# -> Int#-   {Low word of signed integer multiply.}-   with commutable = True-        fixity = infixl 7--primop   IntMul2Op    "timesInt2#" GenPrimOp-   Int# -> Int# -> (# Int#, Int#, Int# #)-   {Return a triple (isHighNeeded,high,low) where high and low are respectively-   the high and low bits of the double-word result. isHighNeeded is a cheap way-   to test if the high word is a sign-extension of the low word (isHighNeeded =-   0#) or not (isHighNeeded = 1#).}--primop   IntMulMayOfloOp  "mulIntMayOflo#"-   GenPrimOp   Int# -> Int# -> Int#-   {Return non-zero if there is any possibility that the upper word of a-    signed integer multiply might contain useful information.  Return-    zero only if you are completely sure that no overflow can occur.-    On a 32-bit platform, the recommended implementation is to do a-    32 x 32 -> 64 signed multiply, and subtract result[63:32] from-    (result[31] >>signed 31).  If this is zero, meaning that the-    upper word is merely a sign extension of the lower one, no-    overflow can occur.--    On a 64-bit platform it is not always possible to-    acquire the top 64 bits of the result.  Therefore, a recommended-    implementation is to take the absolute value of both operands, and-    return 0 iff bits[63:31] of them are zero, since that means that their-    magnitudes fit within 31 bits, so the magnitude of the product must fit-    into 62 bits.--    If in doubt, return non-zero, but do make an effort to create the-    correct answer for small args, since otherwise the performance of-    \texttt{(*) :: Integer -> Integer -> Integer} will be poor.-   }-   with commutable = True--primop   IntQuotOp    "quotInt#"    GenPrimOp-   Int# -> Int# -> Int#-   {Rounds towards zero. The behavior is undefined if the second argument is-    zero.-   }-   with can_fail = True--primop   IntRemOp    "remInt#"    GenPrimOp-   Int# -> Int# -> Int#-   {Satisfies \texttt{(quotInt\# x y) *\# y +\# (remInt\# x y) == x}. The-    behavior is undefined if the second argument is zero.-   }-   with can_fail = True--primop   IntQuotRemOp "quotRemInt#"    GenPrimOp-   Int# -> Int# -> (# Int#, Int# #)-   {Rounds towards zero.}-   with can_fail = True--primop   IntAndOp   "andI#"   GenPrimOp    Int# -> Int# -> Int#-   {Bitwise "and".}-   with commutable = True--primop   IntOrOp   "orI#"     GenPrimOp    Int# -> Int# -> Int#-   {Bitwise "or".}-   with commutable = True--primop   IntXorOp   "xorI#"   GenPrimOp    Int# -> Int# -> Int#-   {Bitwise "xor".}-   with commutable = True--primop   IntNotOp   "notI#"   GenPrimOp   Int# -> Int#-   {Bitwise "not", also known as the binary complement.}--primop   IntNegOp    "negateInt#"    GenPrimOp   Int# -> Int#-   {Unary negation.-    Since the negative {\tt Int#} range extends one further than the-    positive range, {\tt negateInt#} of the most negative number is an-    identity operation. This way, {\tt negateInt#} is always its own inverse.}--primop   IntAddCOp   "addIntC#"    GenPrimOp   Int# -> Int# -> (# Int#, Int# #)-         {Add signed integers reporting overflow.-          First member of result is the sum truncated to an {\tt Int#};-          second member is zero if the true sum fits in an {\tt Int#},-          nonzero if overflow occurred (the sum is either too large-          or too small to fit in an {\tt Int#}).}-   with code_size = 2-        commutable = True--primop   IntSubCOp   "subIntC#"    GenPrimOp   Int# -> Int# -> (# Int#, Int# #)-         {Subtract signed integers reporting overflow.-          First member of result is the difference truncated to an {\tt Int#};-          second member is zero if the true difference fits in an {\tt Int#},-          nonzero if overflow occurred (the difference is either too large-          or too small to fit in an {\tt Int#}).}-   with code_size = 2--primop   IntGtOp  ">#"   Compare   Int# -> Int# -> Int#-   with fixity = infix 4--primop   IntGeOp  ">=#"   Compare   Int# -> Int# -> Int#-   with fixity = infix 4--primop   IntEqOp  "==#"   Compare-   Int# -> Int# -> Int#-   with commutable = True-        fixity = infix 4--primop   IntNeOp  "/=#"   Compare-   Int# -> Int# -> Int#-   with commutable = True-        fixity = infix 4--primop   IntLtOp  "<#"   Compare   Int# -> Int# -> Int#-   with fixity = infix 4--primop   IntLeOp  "<=#"   Compare   Int# -> Int# -> Int#-   with fixity = infix 4--primop   ChrOp   "chr#"   GenPrimOp   Int# -> Char#-   with code_size = 0--primop   IntToWordOp "int2Word#" GenPrimOp Int# -> Word#-   with code_size = 0--primop   IntToFloatOp   "int2Float#"      GenPrimOp  Int# -> Float#-   {Convert an {\tt Int#} to the corresponding {\tt Float#} with the same-    integral value (up to truncation due to floating-point precision). e.g.-    {\tt int2Float# 1# == 1.0#}}-primop   IntToDoubleOp   "int2Double#"          GenPrimOp  Int# -> Double#-   {Convert an {\tt Int#} to the corresponding {\tt Double#} with the same-    integral value (up to truncation due to floating-point precision). e.g.-    {\tt int2Double# 1# == 1.0##}}--primop   WordToFloatOp   "word2Float#"      GenPrimOp  Word# -> Float#-   {Convert an {\tt Word#} to the corresponding {\tt Float#} with the same-    integral value (up to truncation due to floating-point precision). e.g.-    {\tt word2Float# 1## == 1.0#}}-primop   WordToDoubleOp   "word2Double#"          GenPrimOp  Word# -> Double#-   {Convert an {\tt Word#} to the corresponding {\tt Double#} with the same-    integral value (up to truncation due to floating-point precision). e.g.-    {\tt word2Double# 1## == 1.0##}}--primop   IntSllOp   "uncheckedIShiftL#" GenPrimOp  Int# -> Int# -> Int#-         {Shift left.  Result undefined if shift amount is not-          in the range 0 to word size - 1 inclusive.}-primop   IntSraOp   "uncheckedIShiftRA#" GenPrimOp Int# -> Int# -> Int#-         {Shift right arithmetic.  Result undefined if shift amount is not-          in the range 0 to word size - 1 inclusive.}-primop   IntSrlOp   "uncheckedIShiftRL#" GenPrimOp Int# -> Int# -> Int#-         {Shift right logical.  Result undefined if shift amount is not-          in the range 0 to word size - 1 inclusive.}---------------------------------------------------------------------------section "Word#"-        {Operations on native-sized unsigned words (32+ bits).}---------------------------------------------------------------------------primtype Word#--primop   WordAddOp   "plusWord#"   GenPrimOp   Word# -> Word# -> Word#-   with commutable = True--primop   WordAddCOp   "addWordC#"   GenPrimOp   Word# -> Word# -> (# Word#, Int# #)-         {Add unsigned integers reporting overflow.-          The first element of the pair is the result.  The second element is-          the carry flag, which is nonzero on overflow. See also {\tt plusWord2#}.}-   with code_size = 2-        commutable = True--primop   WordSubCOp   "subWordC#"   GenPrimOp   Word# -> Word# -> (# Word#, Int# #)-         {Subtract unsigned integers reporting overflow.-          The first element of the pair is the result.  The second element is-          the carry flag, which is nonzero on overflow.}-   with code_size = 2--primop   WordAdd2Op   "plusWord2#"   GenPrimOp   Word# -> Word# -> (# Word#, Word# #)-         {Add unsigned integers, with the high part (carry) in the first-          component of the returned pair and the low part in the second-          component of the pair. See also {\tt addWordC#}.}-   with code_size = 2-        commutable = True--primop   WordSubOp   "minusWord#"   GenPrimOp   Word# -> Word# -> Word#--primop   WordMulOp   "timesWord#"   GenPrimOp   Word# -> Word# -> Word#-   with commutable = True---- Returns (# high, low #)-primop   WordMul2Op  "timesWord2#"   GenPrimOp-   Word# -> Word# -> (# Word#, Word# #)-   with commutable = True--primop   WordQuotOp   "quotWord#"   GenPrimOp   Word# -> Word# -> Word#-   with can_fail = True--primop   WordRemOp   "remWord#"   GenPrimOp   Word# -> Word# -> Word#-   with can_fail = True--primop   WordQuotRemOp "quotRemWord#" GenPrimOp-   Word# -> Word# -> (# Word#, Word# #)-   with can_fail = True--primop   WordQuotRem2Op "quotRemWord2#" GenPrimOp-   Word# -> Word# -> Word# -> (# Word#, Word# #)-         { Takes high word of dividend, then low word of dividend, then divisor.-           Requires that high word < divisor.}-   with can_fail = True--primop   WordAndOp   "and#"   GenPrimOp   Word# -> Word# -> Word#-   with commutable = True--primop   WordOrOp   "or#"   GenPrimOp   Word# -> Word# -> Word#-   with commutable = True--primop   WordXorOp   "xor#"   GenPrimOp   Word# -> Word# -> Word#-   with commutable = True--primop   WordNotOp   "not#"   GenPrimOp   Word# -> Word#--primop   WordSllOp   "uncheckedShiftL#"   GenPrimOp   Word# -> Int# -> Word#-         {Shift left logical.   Result undefined if shift amount is not-          in the range 0 to word size - 1 inclusive.}-primop   WordSrlOp   "uncheckedShiftRL#"   GenPrimOp   Word# -> Int# -> Word#-         {Shift right logical.   Result undefined if shift  amount is not-          in the range 0 to word size - 1 inclusive.}--primop   WordToIntOp   "word2Int#"   GenPrimOp   Word# -> Int#-   with code_size = 0--primop   WordGtOp   "gtWord#"   Compare   Word# -> Word# -> Int#-primop   WordGeOp   "geWord#"   Compare   Word# -> Word# -> Int#-primop   WordEqOp   "eqWord#"   Compare   Word# -> Word# -> Int#-primop   WordNeOp   "neWord#"   Compare   Word# -> Word# -> Int#-primop   WordLtOp   "ltWord#"   Compare   Word# -> Word# -> Int#-primop   WordLeOp   "leWord#"   Compare   Word# -> Word# -> Int#--primop   PopCnt8Op   "popCnt8#"   GenPrimOp   Word# -> Word#-    {Count the number of set bits in the lower 8 bits of a word.}-primop   PopCnt16Op   "popCnt16#"   GenPrimOp   Word# -> Word#-    {Count the number of set bits in the lower 16 bits of a word.}-primop   PopCnt32Op   "popCnt32#"   GenPrimOp   Word# -> Word#-    {Count the number of set bits in the lower 32 bits of a word.}-primop   PopCnt64Op   "popCnt64#"   GenPrimOp   Word64# -> Word#-    {Count the number of set bits in a 64-bit word.}-primop   PopCntOp   "popCnt#"   GenPrimOp   Word# -> Word#-    {Count the number of set bits in a word.}--primop   Pdep8Op   "pdep8#"   GenPrimOp   Word# -> Word# -> Word#-    {Deposit bits to lower 8 bits of a word at locations specified by a mask.}-primop   Pdep16Op   "pdep16#"   GenPrimOp   Word# -> Word# -> Word#-    {Deposit bits to lower 16 bits of a word at locations specified by a mask.}-primop   Pdep32Op   "pdep32#"   GenPrimOp   Word# -> Word# -> Word#-    {Deposit bits to lower 32 bits of a word at locations specified by a mask.}-primop   Pdep64Op   "pdep64#"   GenPrimOp   Word64# -> Word64# -> Word64#-    {Deposit bits to a word at locations specified by a mask.}-primop   PdepOp   "pdep#"   GenPrimOp   Word# -> Word# -> Word#-    {Deposit bits to a word at locations specified by a mask.}--primop   Pext8Op   "pext8#"   GenPrimOp   Word# -> Word# -> Word#-    {Extract bits from lower 8 bits of a word at locations specified by a mask.}-primop   Pext16Op   "pext16#"   GenPrimOp   Word# -> Word# -> Word#-    {Extract bits from lower 16 bits of a word at locations specified by a mask.}-primop   Pext32Op   "pext32#"   GenPrimOp   Word# -> Word# -> Word#-    {Extract bits from lower 32 bits of a word at locations specified by a mask.}-primop   Pext64Op   "pext64#"   GenPrimOp   Word64# -> Word64# -> Word64#-    {Extract bits from a word at locations specified by a mask.}-primop   PextOp   "pext#"   GenPrimOp   Word# -> Word# -> Word#-    {Extract bits from a word at locations specified by a mask.}--primop   Clz8Op   "clz8#" GenPrimOp   Word# -> Word#-    {Count leading zeros in the lower 8 bits of a word.}-primop   Clz16Op   "clz16#" GenPrimOp   Word# -> Word#-    {Count leading zeros in the lower 16 bits of a word.}-primop   Clz32Op   "clz32#" GenPrimOp   Word# -> Word#-    {Count leading zeros in the lower 32 bits of a word.}-primop   Clz64Op   "clz64#" GenPrimOp Word64# -> Word#-    {Count leading zeros in a 64-bit word.}-primop   ClzOp     "clz#"   GenPrimOp   Word# -> Word#-    {Count leading zeros in a word.}--primop   Ctz8Op   "ctz8#"  GenPrimOp   Word# -> Word#-    {Count trailing zeros in the lower 8 bits of a word.}-primop   Ctz16Op   "ctz16#" GenPrimOp   Word# -> Word#-    {Count trailing zeros in the lower 16 bits of a word.}-primop   Ctz32Op   "ctz32#" GenPrimOp   Word# -> Word#-    {Count trailing zeros in the lower 32 bits of a word.}-primop   Ctz64Op   "ctz64#" GenPrimOp Word64# -> Word#-    {Count trailing zeros in a 64-bit word.}-primop   CtzOp     "ctz#"   GenPrimOp   Word# -> Word#-    {Count trailing zeros in a word.}--primop   BSwap16Op   "byteSwap16#"   GenPrimOp   Word# -> Word#-    {Swap bytes in the lower 16 bits of a word. The higher bytes are undefined. }-primop   BSwap32Op   "byteSwap32#"   GenPrimOp   Word# -> Word#-    {Swap bytes in the lower 32 bits of a word. The higher bytes are undefined. }-primop   BSwap64Op   "byteSwap64#"   GenPrimOp   Word64# -> Word64#-    {Swap bytes in a 64 bits of a word.}-primop   BSwapOp     "byteSwap#"     GenPrimOp   Word# -> Word#-    {Swap bytes in a word.}--primop   BRev8Op    "bitReverse8#"   GenPrimOp   Word# -> Word#-    {Reverse the order of the bits in a 8-bit word.}-primop   BRev16Op   "bitReverse16#"   GenPrimOp   Word# -> Word#-    {Reverse the order of the bits in a 16-bit word.}-primop   BRev32Op   "bitReverse32#"   GenPrimOp   Word# -> Word#-    {Reverse the order of the bits in a 32-bit word.}-primop   BRev64Op   "bitReverse64#"   GenPrimOp   Word64# -> Word64#-    {Reverse the order of the bits in a 64-bit word.}-primop   BRevOp     "bitReverse#"     GenPrimOp   Word# -> Word#-    {Reverse the order of the bits in a word.}---------------------------------------------------------------------------section "Narrowings"-        {Explicit narrowing of native-sized ints or words.}---------------------------------------------------------------------------primop   Narrow8IntOp      "narrow8Int#"      GenPrimOp   Int# -> Int#-primop   Narrow16IntOp     "narrow16Int#"     GenPrimOp   Int# -> Int#-primop   Narrow32IntOp     "narrow32Int#"     GenPrimOp   Int# -> Int#-primop   Narrow8WordOp     "narrow8Word#"     GenPrimOp   Word# -> Word#-primop   Narrow16WordOp    "narrow16Word#"    GenPrimOp   Word# -> Word#-primop   Narrow32WordOp    "narrow32Word#"    GenPrimOp   Word# -> Word#---------------------------------------------------------------------------section "Double#"-        {Operations on double-precision (64 bit) floating-point numbers.}---------------------------------------------------------------------------primtype Double#--primop   DoubleGtOp ">##"   Compare   Double# -> Double# -> Int#-   with fixity = infix 4--primop   DoubleGeOp ">=##"   Compare   Double# -> Double# -> Int#-   with fixity = infix 4--primop DoubleEqOp "==##"   Compare-   Double# -> Double# -> Int#-   with commutable = True-        fixity = infix 4--primop DoubleNeOp "/=##"   Compare-   Double# -> Double# -> Int#-   with commutable = True-        fixity = infix 4--primop   DoubleLtOp "<##"   Compare   Double# -> Double# -> Int#-   with fixity = infix 4--primop   DoubleLeOp "<=##"   Compare   Double# -> Double# -> Int#-   with fixity = infix 4--primop   DoubleAddOp   "+##"   GenPrimOp-   Double# -> Double# -> Double#-   with commutable = True-        fixity = infixl 6--primop   DoubleSubOp   "-##"   GenPrimOp   Double# -> Double# -> Double#-   with fixity = infixl 6--primop   DoubleMulOp   "*##"   GenPrimOp-   Double# -> Double# -> Double#-   with commutable = True-        fixity = infixl 7--primop   DoubleDivOp   "/##"   GenPrimOp-   Double# -> Double# -> Double#-   with can_fail = True-        fixity = infixl 7--primop   DoubleNegOp   "negateDouble#"  GenPrimOp   Double# -> Double#--primop   DoubleFabsOp  "fabsDouble#"    GenPrimOp   Double# -> Double#--primop   DoubleToIntOp   "double2Int#"          GenPrimOp  Double# -> Int#-   {Truncates a {\tt Double#} value to the nearest {\tt Int#}.-    Results are undefined if the truncation if truncation yields-    a value outside the range of {\tt Int#}.}--primop   DoubleToFloatOp   "double2Float#" GenPrimOp Double# -> Float#--primop   DoubleExpOp   "expDouble#"      GenPrimOp-   Double# -> Double#-   with-   code_size = { primOpCodeSizeForeignCall }--primop   DoubleExpM1Op "expm1Double#"    GenPrimOp-   Double# -> Double#-   with-   code_size = { primOpCodeSizeForeignCall }--primop   DoubleLogOp   "logDouble#"      GenPrimOp-   Double# -> Double#-   with-   code_size = { primOpCodeSizeForeignCall }-   can_fail = True--primop   DoubleLog1POp   "log1pDouble#"      GenPrimOp-   Double# -> Double#-   with-   code_size = { primOpCodeSizeForeignCall }-   can_fail = True--primop   DoubleSqrtOp   "sqrtDouble#"      GenPrimOp-   Double# -> Double#-   with-   code_size = { primOpCodeSizeForeignCall }--primop   DoubleSinOp   "sinDouble#"      GenPrimOp-   Double# -> Double#-   with-   code_size = { primOpCodeSizeForeignCall }--primop   DoubleCosOp   "cosDouble#"      GenPrimOp-   Double# -> Double#-   with-   code_size = { primOpCodeSizeForeignCall }--primop   DoubleTanOp   "tanDouble#"      GenPrimOp-   Double# -> Double#-   with-   code_size = { primOpCodeSizeForeignCall }--primop   DoubleAsinOp   "asinDouble#"      GenPrimOp-   Double# -> Double#-   with-   code_size = { primOpCodeSizeForeignCall }-   can_fail = True--primop   DoubleAcosOp   "acosDouble#"      GenPrimOp-   Double# -> Double#-   with-   code_size = { primOpCodeSizeForeignCall }-   can_fail = True--primop   DoubleAtanOp   "atanDouble#"      GenPrimOp-   Double# -> Double#-   with-   code_size = { primOpCodeSizeForeignCall }--primop   DoubleSinhOp   "sinhDouble#"      GenPrimOp-   Double# -> Double#-   with-   code_size = { primOpCodeSizeForeignCall }--primop   DoubleCoshOp   "coshDouble#"      GenPrimOp-   Double# -> Double#-   with-   code_size = { primOpCodeSizeForeignCall }--primop   DoubleTanhOp   "tanhDouble#"      GenPrimOp-   Double# -> Double#-   with-   code_size = { primOpCodeSizeForeignCall }--primop   DoubleAsinhOp   "asinhDouble#"      GenPrimOp-   Double# -> Double#-   with-   code_size = { primOpCodeSizeForeignCall }--primop   DoubleAcoshOp   "acoshDouble#"      GenPrimOp-   Double# -> Double#-   with-   code_size = { primOpCodeSizeForeignCall }--primop   DoubleAtanhOp   "atanhDouble#"      GenPrimOp-   Double# -> Double#-   with-   code_size = { primOpCodeSizeForeignCall }--primop   DoublePowerOp   "**##" GenPrimOp-   Double# -> Double# -> Double#-   {Exponentiation.}-   with-   code_size = { primOpCodeSizeForeignCall }--primop   DoubleDecode_2IntOp   "decodeDouble_2Int#" GenPrimOp-   Double# -> (# Int#, Word#, Word#, Int# #)-   {Convert to integer.-    First component of the result is -1 or 1, indicating the sign of the-    mantissa. The next two are the high and low 32 bits of the mantissa-    respectively, and the last is the exponent.}-   with out_of_line = True--primop   DoubleDecode_Int64Op   "decodeDouble_Int64#" GenPrimOp-   Double# -> (# Int64#, Int# #)-   {Decode {\tt Double\#} into mantissa and base-2 exponent.}-   with out_of_line = True---------------------------------------------------------------------------section "Float#"-        {Operations on single-precision (32-bit) floating-point numbers.}---------------------------------------------------------------------------primtype Float#--primop   FloatGtOp  "gtFloat#"   Compare   Float# -> Float# -> Int#-primop   FloatGeOp  "geFloat#"   Compare   Float# -> Float# -> Int#--primop   FloatEqOp  "eqFloat#"   Compare-   Float# -> Float# -> Int#-   with commutable = True--primop   FloatNeOp  "neFloat#"   Compare-   Float# -> Float# -> Int#-   with commutable = True--primop   FloatLtOp  "ltFloat#"   Compare   Float# -> Float# -> Int#-primop   FloatLeOp  "leFloat#"   Compare   Float# -> Float# -> Int#--primop   FloatAddOp   "plusFloat#"      GenPrimOp-   Float# -> Float# -> Float#-   with commutable = True--primop   FloatSubOp   "minusFloat#"      GenPrimOp      Float# -> Float# -> Float#--primop   FloatMulOp   "timesFloat#"      GenPrimOp-   Float# -> Float# -> Float#-   with commutable = True--primop   FloatDivOp   "divideFloat#"      GenPrimOp-   Float# -> Float# -> Float#-   with can_fail = True--primop   FloatNegOp   "negateFloat#"      GenPrimOp    Float# -> Float#--primop   FloatFabsOp  "fabsFloat#"        GenPrimOp    Float# -> Float#--primop   FloatToIntOp   "float2Int#"      GenPrimOp  Float# -> Int#-   {Truncates a {\tt Float#} value to the nearest {\tt Int#}.-    Results are undefined if the truncation if truncation yields-    a value outside the range of {\tt Int#}.}--primop   FloatExpOp   "expFloat#"      GenPrimOp-   Float# -> Float#-   with-   code_size = { primOpCodeSizeForeignCall }--primop   FloatExpM1Op   "expm1Float#"      GenPrimOp-   Float# -> Float#-   with-   code_size = { primOpCodeSizeForeignCall }--primop   FloatLogOp   "logFloat#"      GenPrimOp-   Float# -> Float#-   with-   code_size = { primOpCodeSizeForeignCall }-   can_fail = True--primop   FloatLog1POp  "log1pFloat#"     GenPrimOp-   Float# -> Float#-   with-   code_size = { primOpCodeSizeForeignCall }-   can_fail = True--primop   FloatSqrtOp   "sqrtFloat#"      GenPrimOp-   Float# -> Float#-   with-   code_size = { primOpCodeSizeForeignCall }--primop   FloatSinOp   "sinFloat#"      GenPrimOp-   Float# -> Float#-   with-   code_size = { primOpCodeSizeForeignCall }--primop   FloatCosOp   "cosFloat#"      GenPrimOp-   Float# -> Float#-   with-   code_size = { primOpCodeSizeForeignCall }--primop   FloatTanOp   "tanFloat#"      GenPrimOp-   Float# -> Float#-   with-   code_size = { primOpCodeSizeForeignCall }--primop   FloatAsinOp   "asinFloat#"      GenPrimOp-   Float# -> Float#-   with-   code_size = { primOpCodeSizeForeignCall }-   can_fail = True--primop   FloatAcosOp   "acosFloat#"      GenPrimOp-   Float# -> Float#-   with-   code_size = { primOpCodeSizeForeignCall }-   can_fail = True--primop   FloatAtanOp   "atanFloat#"      GenPrimOp-   Float# -> Float#-   with-   code_size = { primOpCodeSizeForeignCall }--primop   FloatSinhOp   "sinhFloat#"      GenPrimOp-   Float# -> Float#-   with-   code_size = { primOpCodeSizeForeignCall }--primop   FloatCoshOp   "coshFloat#"      GenPrimOp-   Float# -> Float#-   with-   code_size = { primOpCodeSizeForeignCall }--primop   FloatTanhOp   "tanhFloat#"      GenPrimOp-   Float# -> Float#-   with-   code_size = { primOpCodeSizeForeignCall }--primop   FloatAsinhOp   "asinhFloat#"      GenPrimOp-   Float# -> Float#-   with-   code_size = { primOpCodeSizeForeignCall }--primop   FloatAcoshOp   "acoshFloat#"      GenPrimOp-   Float# -> Float#-   with-   code_size = { primOpCodeSizeForeignCall }--primop   FloatAtanhOp   "atanhFloat#"      GenPrimOp-   Float# -> Float#-   with-   code_size = { primOpCodeSizeForeignCall }--primop   FloatPowerOp   "powerFloat#"      GenPrimOp-   Float# -> Float# -> Float#-   with-   code_size = { primOpCodeSizeForeignCall }--primop   FloatToDoubleOp   "float2Double#" GenPrimOp  Float# -> Double#--primop   FloatDecode_IntOp   "decodeFloat_Int#" GenPrimOp-   Float# -> (# Int#, Int# #)-   {Convert to integers.-    First {\tt Int\#} in result is the mantissa; second is the exponent.}-   with out_of_line = True---------------------------------------------------------------------------section "Arrays"-        {Operations on {\tt Array\#}.}---------------------------------------------------------------------------primtype Array# a--primtype MutableArray# s a--primop  NewArrayOp "newArray#" GenPrimOp-   Int# -> v -> State# s -> (# State# s, MutableArray# s v #)-   {Create a new mutable array with the specified number of elements,-    in the specified state thread,-    with each element containing the specified initial value.}-   with-   out_of_line = True-   has_side_effects = True--primop  ReadArrayOp "readArray#" GenPrimOp-   MutableArray# s v -> Int# -> State# s -> (# State# s, v #)-   {Read from specified index of mutable array. Result is not yet evaluated.}-   with-   has_side_effects = True-   can_fail         = True--primop  WriteArrayOp "writeArray#" GenPrimOp-   MutableArray# s v -> Int# -> v -> State# s -> State# s-   {Write to specified index of mutable array.}-   with-   has_side_effects = True-   can_fail         = True-   code_size        = 2 -- card update too--primop  SizeofArrayOp "sizeofArray#" GenPrimOp-   Array# v -> Int#-   {Return the number of elements in the array.}--primop  SizeofMutableArrayOp "sizeofMutableArray#" GenPrimOp-   MutableArray# s v -> Int#-   {Return the number of elements in the array.}--primop  IndexArrayOp "indexArray#" GenPrimOp-   Array# v -> Int# -> (# v #)-   {Read from the specified index of an immutable array. The result is packaged-    into an unboxed unary tuple; the result itself is not yet-    evaluated. Pattern matching on the tuple forces the indexing of the-    array to happen but does not evaluate the element itself. Evaluating-    the thunk prevents additional thunks from building up on the-    heap. Avoiding these thunks, in turn, reduces references to the-    argument array, allowing it to be garbage collected more promptly.}-   with-   can_fail         = True--primop  UnsafeFreezeArrayOp "unsafeFreezeArray#" GenPrimOp-   MutableArray# s v -> State# s -> (# State# s, Array# v #)-   {Make a mutable array immutable, without copying.}-   with-   has_side_effects = True--primop  UnsafeThawArrayOp  "unsafeThawArray#" GenPrimOp-   Array# v -> State# s -> (# State# s, MutableArray# s v #)-   {Make an immutable array mutable, without copying.}-   with-   out_of_line = True-   has_side_effects = True--primop  CopyArrayOp "copyArray#" GenPrimOp-  Array# v -> Int# -> MutableArray# s v -> Int# -> Int# -> State# s -> State# s-  {Given a source array, an offset into the source array, a-   destination array, an offset into the destination array, and a-   number of elements to copy, copy the elements from the source array-   to the destination array. Both arrays must fully contain the-   specified ranges, but this is not checked. The two arrays must not-   be the same array in different states, but this is not checked-   either.}-  with-  out_of_line      = True-  has_side_effects = True-  can_fail         = True--primop  CopyMutableArrayOp "copyMutableArray#" GenPrimOp-  MutableArray# s v -> Int# -> MutableArray# s v -> Int# -> Int# -> State# s -> State# s-  {Given a source array, an offset into the source array, a-   destination array, an offset into the destination array, and a-   number of elements to copy, copy the elements from the source array-   to the destination array. Both arrays must fully contain the-   specified ranges, but this is not checked. In the case where-   the source and destination are the same array the source and-   destination regions may overlap.}-  with-  out_of_line      = True-  has_side_effects = True-  can_fail         = True--primop  CloneArrayOp "cloneArray#" GenPrimOp-  Array# v -> Int# -> Int# -> Array# v-  {Given a source array, an offset into the source array, and a number-   of elements to copy, create a new array with the elements from the-   source array. The provided array must fully contain the specified-   range, but this is not checked.}-  with-  out_of_line      = True-  has_side_effects = True-  can_fail         = True--primop  CloneMutableArrayOp "cloneMutableArray#" GenPrimOp-  MutableArray# s v -> Int# -> Int# -> State# s -> (# State# s, MutableArray# s v #)-  {Given a source array, an offset into the source array, and a number-   of elements to copy, create a new array with the elements from the-   source array. The provided array must fully contain the specified-   range, but this is not checked.}-  with-  out_of_line      = True-  has_side_effects = True-  can_fail         = True--primop  FreezeArrayOp "freezeArray#" GenPrimOp-  MutableArray# s v -> Int# -> Int# -> State# s -> (# State# s, Array# v #)-  {Given a source array, an offset into the source array, and a number-   of elements to copy, create a new array with the elements from the-   source array. The provided array must fully contain the specified-   range, but this is not checked.}-  with-  out_of_line      = True-  has_side_effects = True-  can_fail         = True--primop  ThawArrayOp "thawArray#" GenPrimOp-  Array# v -> Int# -> Int# -> State# s -> (# State# s, MutableArray# s v #)-  {Given a source array, an offset into the source array, and a number-   of elements to copy, create a new array with the elements from the-   source array. The provided array must fully contain the specified-   range, but this is not checked.}-  with-  out_of_line      = True-  has_side_effects = True-  can_fail         = True--primop CasArrayOp  "casArray#" GenPrimOp-   MutableArray# s v -> Int# -> v -> v -> State# s -> (# State# s, Int#, v #)-   {Given an array, an offset, the expected old value, and-    the new value, perform an atomic compare and swap (i.e. write the new-    value if the current value and the old value are the same pointer).-    Returns 0 if the swap succeeds and 1 if it fails. Additionally, returns-    the element at the offset after the operation completes. This means that-    on a success the new value is returned, and on a failure the actual old-    value (not the expected one) is returned. Implies a full memory barrier.-    The use of a pointer equality on a boxed value makes this function harder-    to use correctly than {\tt casIntArray\#}. All of the difficulties-    of using {\tt reallyUnsafePtrEquality\#} correctly apply to-    {\tt casArray\#} as well.-   }-   with-   out_of_line = True-   has_side_effects = True-   can_fail = True -- Might index out of bounds----------------------------------------------------------------------------section "Small Arrays"--        {Operations on {\tt SmallArray\#}. A {\tt SmallArray\#} works-         just like an {\tt Array\#}, but with different space use and-         performance characteristics (that are often useful with small-         arrays). The {\tt SmallArray\#} and {\tt SmallMutableArray#}-         lack a `card table'. The purpose of a card table is to avoid-         having to scan every element of the array on each GC by-         keeping track of which elements have changed since the last GC-         and only scanning those that have changed. So the consequence-         of there being no card table is that the representation is-         somewhat smaller and the writes are somewhat faster (because-         the card table does not need to be updated). The disadvantage-         of course is that for a {\tt SmallMutableArray#} the whole-         array has to be scanned on each GC. Thus it is best suited for-         use cases where the mutable array is not long lived, e.g.-         where a mutable array is initialised quickly and then frozen-         to become an immutable {\tt SmallArray\#}.-        }----------------------------------------------------------------------------primtype SmallArray# a--primtype SmallMutableArray# s a--primop  NewSmallArrayOp "newSmallArray#" GenPrimOp-   Int# -> v -> State# s -> (# State# s, SmallMutableArray# s v #)-   {Create a new mutable array with the specified number of elements,-    in the specified state thread,-    with each element containing the specified initial value.}-   with-   out_of_line = True-   has_side_effects = True--primop  ShrinkSmallMutableArrayOp_Char "shrinkSmallMutableArray#" GenPrimOp-   SmallMutableArray# s v -> Int# -> State# s -> State# s-   {Shrink mutable array to new specified size, in-    the specified state thread. The new size argument must be less than or-    equal to the current size as reported by {\tt getSizeofSmallMutableArray\#}.}-   with out_of_line = True-        has_side_effects = True--primop  ReadSmallArrayOp "readSmallArray#" GenPrimOp-   SmallMutableArray# s v -> Int# -> State# s -> (# State# s, v #)-   {Read from specified index of mutable array. Result is not yet evaluated.}-   with-   has_side_effects = True-   can_fail         = True--primop  WriteSmallArrayOp "writeSmallArray#" GenPrimOp-   SmallMutableArray# s v -> Int# -> v -> State# s -> State# s-   {Write to specified index of mutable array.}-   with-   has_side_effects = True-   can_fail         = True--primop  SizeofSmallArrayOp "sizeofSmallArray#" GenPrimOp-   SmallArray# v -> Int#-   {Return the number of elements in the array.}--primop  SizeofSmallMutableArrayOp "sizeofSmallMutableArray#" GenPrimOp-   SmallMutableArray# s v -> Int#-   {Return the number of elements in the array. Note that this is deprecated-   as it is unsafe in the presence of shrink and resize operations on the-   same small mutable array.}-   with deprecated_msg = { Use 'getSizeofSmallMutableArray#' instead }--primop  GetSizeofSmallMutableArrayOp "getSizeofSmallMutableArray#" GenPrimOp-   SmallMutableArray# s v -> State# s -> (# State# s, Int# #)-   {Return the number of elements in the array.}--primop  IndexSmallArrayOp "indexSmallArray#" GenPrimOp-   SmallArray# v -> Int# -> (# v #)-   {Read from specified index of immutable array. Result is packaged into-    an unboxed singleton; the result itself is not yet evaluated.}-   with-   can_fail         = True--primop  UnsafeFreezeSmallArrayOp "unsafeFreezeSmallArray#" GenPrimOp-   SmallMutableArray# s v -> State# s -> (# State# s, SmallArray# v #)-   {Make a mutable array immutable, without copying.}-   with-   has_side_effects = True--primop  UnsafeThawSmallArrayOp  "unsafeThawSmallArray#" GenPrimOp-   SmallArray# v -> State# s -> (# State# s, SmallMutableArray# s v #)-   {Make an immutable array mutable, without copying.}-   with-   out_of_line = True-   has_side_effects = True---- The code_size is only correct for the case when the copy family of--- primops aren't inlined. It would be nice to keep track of both.--primop  CopySmallArrayOp "copySmallArray#" GenPrimOp-  SmallArray# v -> Int# -> SmallMutableArray# s v -> Int# -> Int# -> State# s -> State# s-  {Given a source array, an offset into the source array, a-   destination array, an offset into the destination array, and a-   number of elements to copy, copy the elements from the source array-   to the destination array. Both arrays must fully contain the-   specified ranges, but this is not checked. The two arrays must not-   be the same array in different states, but this is not checked-   either.}-  with-  out_of_line      = True-  has_side_effects = True-  can_fail         = True--primop  CopySmallMutableArrayOp "copySmallMutableArray#" GenPrimOp-  SmallMutableArray# s v -> Int# -> SmallMutableArray# s v -> Int# -> Int# -> State# s -> State# s-  {Given a source array, an offset into the source array, a-   destination array, an offset into the destination array, and a-   number of elements to copy, copy the elements from the source array-   to the destination array. The source and destination arrays can-   refer to the same array. Both arrays must fully contain the-   specified ranges, but this is not checked.-   The regions are allowed to overlap, although this is only possible when the same-   array is provided as both the source and the destination. }-  with-  out_of_line      = True-  has_side_effects = True-  can_fail         = True--primop  CloneSmallArrayOp "cloneSmallArray#" GenPrimOp-  SmallArray# v -> Int# -> Int# -> SmallArray# v-  {Given a source array, an offset into the source array, and a number-   of elements to copy, create a new array with the elements from the-   source array. The provided array must fully contain the specified-   range, but this is not checked.}-  with-  out_of_line      = True-  has_side_effects = True-  can_fail         = True--primop  CloneSmallMutableArrayOp "cloneSmallMutableArray#" GenPrimOp-  SmallMutableArray# s v -> Int# -> Int# -> State# s -> (# State# s, SmallMutableArray# s v #)-  {Given a source array, an offset into the source array, and a number-   of elements to copy, create a new array with the elements from the-   source array. The provided array must fully contain the specified-   range, but this is not checked.}-  with-  out_of_line      = True-  has_side_effects = True-  can_fail         = True--primop  FreezeSmallArrayOp "freezeSmallArray#" GenPrimOp-  SmallMutableArray# s v -> Int# -> Int# -> State# s -> (# State# s, SmallArray# v #)-  {Given a source array, an offset into the source array, and a number-   of elements to copy, create a new array with the elements from the-   source array. The provided array must fully contain the specified-   range, but this is not checked.}-  with-  out_of_line      = True-  has_side_effects = True-  can_fail         = True--primop  ThawSmallArrayOp "thawSmallArray#" GenPrimOp-  SmallArray# v -> Int# -> Int# -> State# s -> (# State# s, SmallMutableArray# s v #)-  {Given a source array, an offset into the source array, and a number-   of elements to copy, create a new array with the elements from the-   source array. The provided array must fully contain the specified-   range, but this is not checked.}-  with-  out_of_line      = True-  has_side_effects = True-  can_fail         = True--primop CasSmallArrayOp  "casSmallArray#" GenPrimOp-   SmallMutableArray# s v -> Int# -> v -> v -> State# s -> (# State# s, Int#, v #)-   {Unsafe, machine-level atomic compare and swap on an element within an array.-    See the documentation of {\tt casArray\#}.}-   with-   out_of_line = True-   has_side_effects = True-   can_fail = True -- Might index out of bounds---------------------------------------------------------------------------section "Byte Arrays"-        {A {\tt ByteArray\#} is a region of-         raw memory in the garbage-collected heap, which is not-         scanned for pointers. -         There are three sets of operations for accessing byte array contents:-         index for reading from immutable byte arrays, and read/write-         for mutable byte arrays.  Each set contains operations for a-         range of useful primitive data types.  Each operation takes-         an offset measured in terms of the size of the primitive type-         being read or written.--         }----------------------------------------------------------------------------primtype ByteArray#-{-  A boxed, unlifted datatype representing a region of raw memory in the garbage-collected heap,-  which is not scanned for pointers during garbage collection.--  It is created by freezing a 'MutableByteArray#' with 'unsafeFreezeByteArray#'.-  Freezing is essentially a no-op, as MutableByteArray# and ByteArray# share the same heap structure under the hood.--  The immutable and mutable variants are commonly used for scenarios requiring high-performance data structures,-  like Text, Primitive Vector, Unboxed Array, and ShortByteString.- -  Another application of fundamental importance is 'Integer', which is backed by 'ByteArray#'.- -  The representation on the heap of a Byte Array is:- -  > +------------+-----------------+-----------------------+-  > |            |                 |                       |-  > |   HEADER   | SIZE (in bytes) |       PAYLOAD         |-  > |            |                 |                       |-  > +------------+-----------------+-----------------------+- -  To obtain a pointer to actual payload (e.g., for FFI purposes) use 'byteArrayContents#' or 'mutableByteArrayContents#'.- -  Alternatively, enabling the UnliftedFFITypes extension-  allows to mention 'ByteArray#' and 'MutableByteArray#' in FFI type signatures directly.-}--primtype MutableByteArray# s-{ A mutable ByteAray#. It can be created in three ways:--  * 'newByteArray#': Create an unpinned array.-  * 'newPinnedByteArray#': This will create a pinned array,-  * 'newAlignedPinnedByteArray#': This will create a pinned array, with a custom alignment.--  Unpinned arrays can be moved around during garbage collection, so you must not store or pass pointers to these values-  if there is a chance for the garbage collector to kick in. That said, even unpinned arrays can be passed to unsafe FFI calls,-  because no garbage collection happens during these unsafe calls-  (see [Guaranteed Call Safety](https://ghc.gitlab.haskell.org/ghc/doc/users_guide/exts/ffi.html#guaranteed-call-safety)-  in the GHC Manual). For safe FFI calls, byte arrays must be not only pinned, but also kept alive by means of the keepAlive# function-  for the duration of a call (that's because garbage collection cannot move a pinned array, but is free to scrap it altogether).-}--primop  NewByteArrayOp_Char "newByteArray#" GenPrimOp-   Int# -> State# s -> (# State# s, MutableByteArray# s #)-   {Create a new mutable byte array of specified size (in bytes), in-    the specified state thread. The size of the memory underlying the-    array will be rounded up to the platform's word size.}-   with out_of_line = True-        has_side_effects = True--primop  NewPinnedByteArrayOp_Char "newPinnedByteArray#" GenPrimOp-   Int# -> State# s -> (# State# s, MutableByteArray# s #)-   {Like 'newByteArray#' but GC guarantees not to move it.}-   with out_of_line = True-        has_side_effects = True--primop  NewAlignedPinnedByteArrayOp_Char "newAlignedPinnedByteArray#" GenPrimOp-   Int# -> Int# -> State# s -> (# State# s, MutableByteArray# s #)-   {Like 'newPinnedByteArray#' but allow specifying an arbitrary-    alignment, which must be a power of two.}-   with out_of_line = True-        has_side_effects = True--primop  MutableByteArrayIsPinnedOp "isMutableByteArrayPinned#" GenPrimOp-   MutableByteArray# s -> Int#-   {Determine whether a {\tt MutableByteArray\#} is guaranteed not to move-   during GC.}-   with out_of_line = True--primop  ByteArrayIsPinnedOp "isByteArrayPinned#" GenPrimOp-   ByteArray# -> Int#-   {Determine whether a {\tt ByteArray\#} is guaranteed not to move during GC.}-   with out_of_line = True--primop  ByteArrayContents_Char "byteArrayContents#" GenPrimOp-   ByteArray# -> Addr#-   {Intended for use with pinned arrays; otherwise very unsafe!}--primop  MutableByteArrayContents_Char "mutableByteArrayContents#" GenPrimOp-   MutableByteArray# s -> Addr#-   {Intended for use with pinned arrays; otherwise very unsafe!}--primop  ShrinkMutableByteArrayOp_Char "shrinkMutableByteArray#" GenPrimOp-   MutableByteArray# s -> Int# -> State# s -> State# s-   {Shrink mutable byte array to new specified size (in bytes), in-    the specified state thread. The new size argument must be less than or-    equal to the current size as reported by {\tt getSizeofMutableByteArray\#}.}-   with out_of_line = True-        has_side_effects = True--primop  ResizeMutableByteArrayOp_Char "resizeMutableByteArray#" GenPrimOp-   MutableByteArray# s -> Int# -> State# s -> (# State# s,MutableByteArray# s #)-   {Resize (unpinned) mutable byte array to new specified size (in bytes).-    The returned {\tt MutableByteArray\#} is either the original-    {\tt MutableByteArray\#} resized in-place or, if not possible, a newly-    allocated (unpinned) {\tt MutableByteArray\#} (with the original content-    copied over).--    To avoid undefined behaviour, the original {\tt MutableByteArray\#} shall-    not be accessed anymore after a {\tt resizeMutableByteArray\#} has been-    performed.  Moreover, no reference to the old one should be kept in order-    to allow garbage collection of the original {\tt MutableByteArray\#} in-    case a new {\tt MutableByteArray\#} had to be allocated.}-   with out_of_line = True-        has_side_effects = True--primop  UnsafeFreezeByteArrayOp "unsafeFreezeByteArray#" GenPrimOp-   MutableByteArray# s -> State# s -> (# State# s, ByteArray# #)-   {Make a mutable byte array immutable, without copying.}-   with-   has_side_effects = True--primop  SizeofByteArrayOp "sizeofByteArray#" GenPrimOp-   ByteArray# -> Int#-   {Return the size of the array in bytes.}--primop  SizeofMutableByteArrayOp "sizeofMutableByteArray#" GenPrimOp-   MutableByteArray# s -> Int#-   {Return the size of the array in bytes. Note that this is deprecated as it is-   unsafe in the presence of shrink and resize operations on the same mutable byte-   array.}-   with deprecated_msg = { Use 'getSizeofMutableByteArray#' instead }--primop  GetSizeofMutableByteArrayOp "getSizeofMutableByteArray#" GenPrimOp-   MutableByteArray# s -> State# s -> (# State# s, Int# #)-   {Return the number of elements in the array.}--#include "bytearray-ops.txt.pp"--primop  CompareByteArraysOp "compareByteArrays#" GenPrimOp-   ByteArray# -> Int# -> ByteArray# -> Int# -> Int# -> Int#-   {{\tt compareByteArrays# src1 src1_ofs src2 src2_ofs n} compares-    {\tt n} bytes starting at offset {\tt src1_ofs} in the first-    {\tt ByteArray#} {\tt src1} to the range of {\tt n} bytes-    (i.e. same length) starting at offset {\tt src2_ofs} of the second-    {\tt ByteArray#} {\tt src2}.  Both arrays must fully contain the-    specified ranges, but this is not checked.  Returns an {\tt Int#}-    less than, equal to, or greater than zero if the range is found,-    respectively, to be byte-wise lexicographically less than, to-    match, or be greater than the second range.}-   with-   can_fail = True--primop  CopyByteArrayOp "copyByteArray#" GenPrimOp-  ByteArray# -> Int# -> MutableByteArray# s -> Int# -> Int# -> State# s -> State# s-  {{\tt copyByteArray# src src_ofs dst dst_ofs n} copies the range-   starting at offset {\tt src_ofs} of length {\tt n} from the-   {\tt ByteArray#} {\tt src} to the {\tt MutableByteArray#} {\tt dst}-   starting at offset {\tt dst_ofs}.  Both arrays must fully contain-   the specified ranges, but this is not checked.  The two arrays must-   not be the same array in different states, but this is not checked-   either.}-  with-  has_side_effects = True-  code_size = { primOpCodeSizeForeignCall + 4}-  can_fail = True--primop  CopyMutableByteArrayOp "copyMutableByteArray#" GenPrimOp-  MutableByteArray# s -> Int# -> MutableByteArray# s -> Int# -> Int# -> State# s -> State# s-  {Copy a range of the first MutableByteArray\# to the specified region in the second MutableByteArray\#.-   Both arrays must fully contain the specified ranges, but this is not checked. The regions are-   allowed to overlap, although this is only possible when the same array is provided-   as both the source and the destination.}-  with-  has_side_effects = True-  code_size = { primOpCodeSizeForeignCall + 4 }-  can_fail = True--primop  CopyByteArrayToAddrOp "copyByteArrayToAddr#" GenPrimOp-  ByteArray# -> Int# -> Addr# -> Int# -> State# s -> State# s-  {Copy a range of the ByteArray\# to the memory range starting at the Addr\#.-   The ByteArray\# and the memory region at Addr\# must fully contain the-   specified ranges, but this is not checked. The Addr\# must not point into the-   ByteArray\# (e.g. if the ByteArray\# were pinned), but this is not checked-   either.}-  with-  has_side_effects = True-  code_size = { primOpCodeSizeForeignCall + 4}-  can_fail = True--primop  CopyMutableByteArrayToAddrOp "copyMutableByteArrayToAddr#" GenPrimOp-  MutableByteArray# s -> Int# -> Addr# -> Int# -> State# s -> State# s-  {Copy a range of the MutableByteArray\# to the memory range starting at the-   Addr\#. The MutableByteArray\# and the memory region at Addr\# must fully-   contain the specified ranges, but this is not checked. The Addr\# must not-   point into the MutableByteArray\# (e.g. if the MutableByteArray\# were-   pinned), but this is not checked either.}-  with-  has_side_effects = True-  code_size = { primOpCodeSizeForeignCall + 4}-  can_fail = True--primop  CopyAddrToByteArrayOp "copyAddrToByteArray#" GenPrimOp-  Addr# -> MutableByteArray# s -> Int# -> Int# -> State# s -> State# s-  {Copy a memory range starting at the Addr\# to the specified range in the-   MutableByteArray\#. The memory region at Addr\# and the ByteArray\# must fully-   contain the specified ranges, but this is not checked. The Addr\# must not-   point into the MutableByteArray\# (e.g. if the MutableByteArray\# were pinned),-   but this is not checked either.}-  with-  has_side_effects = True-  code_size = { primOpCodeSizeForeignCall + 4}-  can_fail = True--primop  SetByteArrayOp "setByteArray#" GenPrimOp-  MutableByteArray# s -> Int# -> Int# -> Int# -> State# s -> State# s-  {{\tt setByteArray# ba off len c} sets the byte range {\tt [off, off+len)} of-   the {\tt MutableByteArray#} to the byte {\tt c}.}-  with-  has_side_effects = True-  code_size = { primOpCodeSizeForeignCall + 4 }-  can_fail = True---- Atomic operations--primop  AtomicReadByteArrayOp_Int "atomicReadIntArray#" GenPrimOp-   MutableByteArray# s -> Int# -> State# s -> (# State# s, Int# #)-   {Given an array and an offset in machine words, read an element. The-    index is assumed to be in bounds. Implies a full memory barrier.}-   with has_side_effects = True-        can_fail = True--primop  AtomicWriteByteArrayOp_Int "atomicWriteIntArray#" GenPrimOp-   MutableByteArray# s -> Int# -> Int# -> State# s -> State# s-   {Given an array and an offset in machine words, write an element. The-    index is assumed to be in bounds. Implies a full memory barrier.}-   with has_side_effects = True-        can_fail = True--primop CasByteArrayOp_Int "casIntArray#" GenPrimOp-   MutableByteArray# s -> Int# -> Int# -> Int# -> State# s -> (# State# s, Int# #)-   {Given an array, an offset in machine words, the expected old value, and-    the new value, perform an atomic compare and swap i.e. write the new-    value if the current value matches the provided old value. Returns-    the value of the element before the operation. Implies a full memory-    barrier.}-   with has_side_effects = True-        can_fail = True--primop CasByteArrayOp_Int8 "casInt8Array#" GenPrimOp-   MutableByteArray# s -> Int# -> Int8# -> Int8# -> State# s -> (# State# s, Int8# #)-   {Given an array, an offset in bytes, the expected old value, and-    the new value, perform an atomic compare and swap i.e. write the new-    value if the current value matches the provided old value. Returns-    the value of the element before the operation. Implies a full memory-    barrier.}-   with has_side_effects = True-        can_fail = True--primop CasByteArrayOp_Int16 "casInt16Array#" GenPrimOp-   MutableByteArray# s -> Int# -> Int16# -> Int16# -> State# s -> (# State# s, Int16# #)-   {Given an array, an offset in 16 bit units, the expected old value, and-    the new value, perform an atomic compare and swap i.e. write the new-    value if the current value matches the provided old value. Returns-    the value of the element before the operation. Implies a full memory-    barrier.}-   with has_side_effects = True-        can_fail = True--primop CasByteArrayOp_Int32 "casInt32Array#" GenPrimOp-   MutableByteArray# s -> Int# -> Int32# -> Int32# -> State# s -> (# State# s, Int32# #)-   {Given an array, an offset in 32 bit units, the expected old value, and-    the new value, perform an atomic compare and swap i.e. write the new-    value if the current value matches the provided old value. Returns-    the value of the element before the operation. Implies a full memory-    barrier.}-   with has_side_effects = True-        can_fail = True--primop CasByteArrayOp_Int64 "casInt64Array#" GenPrimOp-   MutableByteArray# s -> Int# -> Int64# -> Int64# -> State# s -> (# State# s, Int64# #)-   {Given an array, an offset in 64 bit units, the expected old value, and-    the new value, perform an atomic compare and swap i.e. write the new-    value if the current value matches the provided old value. Returns-    the value of the element before the operation. Implies a full memory-    barrier.}-   with has_side_effects = True-        can_fail = True--primop FetchAddByteArrayOp_Int "fetchAddIntArray#" GenPrimOp-   MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s, Int# #)-   {Given an array, and offset in machine words, and a value to add,-    atomically add the value to the element. Returns the value of the-    element before the operation. Implies a full memory barrier.}-   with has_side_effects = True-        can_fail = True--primop FetchSubByteArrayOp_Int "fetchSubIntArray#" GenPrimOp-   MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s, Int# #)-   {Given an array, and offset in machine words, and a value to subtract,-    atomically subtract the value from the element. Returns the value of-    the element before the operation. Implies a full memory barrier.}-   with has_side_effects = True-        can_fail = True--primop FetchAndByteArrayOp_Int "fetchAndIntArray#" GenPrimOp-   MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s, Int# #)-   {Given an array, and offset in machine words, and a value to AND,-    atomically AND the value into the element. Returns the value of the-    element before the operation. Implies a full memory barrier.}-   with has_side_effects = True-        can_fail = True--primop FetchNandByteArrayOp_Int "fetchNandIntArray#" GenPrimOp-   MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s, Int# #)-   {Given an array, and offset in machine words, and a value to NAND,-    atomically NAND the value into the element. Returns the value of the-    element before the operation. Implies a full memory barrier.}-   with has_side_effects = True-        can_fail = True--primop FetchOrByteArrayOp_Int "fetchOrIntArray#" GenPrimOp-   MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s, Int# #)-   {Given an array, and offset in machine words, and a value to OR,-    atomically OR the value into the element. Returns the value of the-    element before the operation. Implies a full memory barrier.}-   with has_side_effects = True-        can_fail = True--primop FetchXorByteArrayOp_Int "fetchXorIntArray#" GenPrimOp-   MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s, Int# #)-   {Given an array, and offset in machine words, and a value to XOR,-    atomically XOR the value into the element. Returns the value of the-    element before the operation. Implies a full memory barrier.}-   with has_side_effects = True-        can_fail = True---------------------------------------------------------------------------section "Addr#"---------------------------------------------------------------------------primtype Addr#-        { An arbitrary machine address assumed to point outside-         the garbage-collected heap. }--pseudoop "nullAddr#" Addr#-        { The null address. }--primop   AddrAddOp "plusAddr#" GenPrimOp Addr# -> Int# -> Addr#-primop   AddrSubOp "minusAddr#" GenPrimOp Addr# -> Addr# -> Int#-         {Result is meaningless if two {\tt Addr\#}s are so far apart that their-         difference doesn't fit in an {\tt Int\#}.}-primop   AddrRemOp "remAddr#" GenPrimOp Addr# -> Int# -> Int#-         {Return the remainder when the {\tt Addr\#} arg, treated like an {\tt Int\#},-          is divided by the {\tt Int\#} arg.}-primop   AddrToIntOp  "addr2Int#"     GenPrimOp   Addr# -> Int#-        {Coerce directly from address to int.}-   with code_size = 0-        deprecated_msg = { This operation is strongly deprecated. }-primop   IntToAddrOp   "int2Addr#"    GenPrimOp  Int# -> Addr#-        {Coerce directly from int to address.}-   with code_size = 0-        deprecated_msg = { This operation is strongly deprecated. }--primop   AddrGtOp  "gtAddr#"   Compare   Addr# -> Addr# -> Int#-primop   AddrGeOp  "geAddr#"   Compare   Addr# -> Addr# -> Int#-primop   AddrEqOp  "eqAddr#"   Compare   Addr# -> Addr# -> Int#-primop   AddrNeOp  "neAddr#"   Compare   Addr# -> Addr# -> Int#-primop   AddrLtOp  "ltAddr#"   Compare   Addr# -> Addr# -> Int#-primop   AddrLeOp  "leAddr#"   Compare   Addr# -> Addr# -> Int#--primop IndexOffAddrOp_Char "indexCharOffAddr#" GenPrimOp-   Addr# -> Int# -> Char#-   {Reads 8-bit character; offset in bytes.}-   with can_fail = True--primop IndexOffAddrOp_WideChar "indexWideCharOffAddr#" GenPrimOp-   Addr# -> Int# -> Char#-   {Reads 31-bit character; offset in 4-byte words.}-   with can_fail = True--primop IndexOffAddrOp_Int "indexIntOffAddr#" GenPrimOp-   Addr# -> Int# -> Int#-   with can_fail = True--primop IndexOffAddrOp_Word "indexWordOffAddr#" GenPrimOp-   Addr# -> Int# -> Word#-   with can_fail = True--primop IndexOffAddrOp_Addr "indexAddrOffAddr#" GenPrimOp-   Addr# -> Int# -> Addr#-   with can_fail = True--primop IndexOffAddrOp_Float "indexFloatOffAddr#" GenPrimOp-   Addr# -> Int# -> Float#-   with can_fail = True--primop IndexOffAddrOp_Double "indexDoubleOffAddr#" GenPrimOp-   Addr# -> Int# -> Double#-   with can_fail = True--primop IndexOffAddrOp_StablePtr "indexStablePtrOffAddr#" GenPrimOp-   Addr# -> Int# -> StablePtr# a-   with can_fail = True--primop IndexOffAddrOp_Int8 "indexInt8OffAddr#" GenPrimOp-   Addr# -> Int# -> Int8#-   with can_fail = True--primop IndexOffAddrOp_Int16 "indexInt16OffAddr#" GenPrimOp-   Addr# -> Int# -> Int16#-   with can_fail = True--primop IndexOffAddrOp_Int32 "indexInt32OffAddr#" GenPrimOp-   Addr# -> Int# -> Int32#-   with can_fail = True--primop IndexOffAddrOp_Int64 "indexInt64OffAddr#" GenPrimOp-   Addr# -> Int# -> Int64#-   with can_fail = True--primop IndexOffAddrOp_Word8 "indexWord8OffAddr#" GenPrimOp-   Addr# -> Int# -> Word8#-   with can_fail = True--primop IndexOffAddrOp_Word16 "indexWord16OffAddr#" GenPrimOp-   Addr# -> Int# -> Word16#-   with can_fail = True--primop IndexOffAddrOp_Word32 "indexWord32OffAddr#" GenPrimOp-   Addr# -> Int# -> Word32#-   with can_fail = True--primop IndexOffAddrOp_Word64 "indexWord64OffAddr#" GenPrimOp-   Addr# -> Int# -> Word64#-   with can_fail = True--primop ReadOffAddrOp_Char "readCharOffAddr#" GenPrimOp-   Addr# -> Int# -> State# s -> (# State# s, Char# #)-   {Reads 8-bit character; offset in bytes.}-   with has_side_effects = True-        can_fail         = True--primop ReadOffAddrOp_WideChar "readWideCharOffAddr#" GenPrimOp-   Addr# -> Int# -> State# s -> (# State# s, Char# #)-   {Reads 31-bit character; offset in 4-byte words.}-   with has_side_effects = True-        can_fail         = True--primop ReadOffAddrOp_Int "readIntOffAddr#" GenPrimOp-   Addr# -> Int# -> State# s -> (# State# s, Int# #)-   with has_side_effects = True-        can_fail         = True--primop ReadOffAddrOp_Word "readWordOffAddr#" GenPrimOp-   Addr# -> Int# -> State# s -> (# State# s, Word# #)-   with has_side_effects = True-        can_fail         = True--primop ReadOffAddrOp_Addr "readAddrOffAddr#" GenPrimOp-   Addr# -> Int# -> State# s -> (# State# s, Addr# #)-   with has_side_effects = True-        can_fail         = True--primop ReadOffAddrOp_Float "readFloatOffAddr#" GenPrimOp-   Addr# -> Int# -> State# s -> (# State# s, Float# #)-   with has_side_effects = True-        can_fail         = True--primop ReadOffAddrOp_Double "readDoubleOffAddr#" GenPrimOp-   Addr# -> Int# -> State# s -> (# State# s, Double# #)-   with has_side_effects = True-        can_fail         = True--primop ReadOffAddrOp_StablePtr "readStablePtrOffAddr#" GenPrimOp-   Addr# -> Int# -> State# s -> (# State# s, StablePtr# a #)-   with has_side_effects = True-        can_fail         = True--primop ReadOffAddrOp_Int8 "readInt8OffAddr#" GenPrimOp-   Addr# -> Int# -> State# s -> (# State# s, Int8# #)-   with has_side_effects = True-        can_fail         = True--primop ReadOffAddrOp_Int16 "readInt16OffAddr#" GenPrimOp-   Addr# -> Int# -> State# s -> (# State# s, Int16# #)-   with has_side_effects = True-        can_fail         = True--primop ReadOffAddrOp_Int32 "readInt32OffAddr#" GenPrimOp-   Addr# -> Int# -> State# s -> (# State# s, Int32# #)-   with has_side_effects = True-        can_fail         = True--primop ReadOffAddrOp_Int64 "readInt64OffAddr#" GenPrimOp-   Addr# -> Int# -> State# s -> (# State# s, Int64# #)-   with has_side_effects = True-        can_fail         = True--primop ReadOffAddrOp_Word8 "readWord8OffAddr#" GenPrimOp-   Addr# -> Int# -> State# s -> (# State# s, Word8# #)-   with has_side_effects = True-        can_fail         = True--primop ReadOffAddrOp_Word16 "readWord16OffAddr#" GenPrimOp-   Addr# -> Int# -> State# s -> (# State# s, Word16# #)-   with has_side_effects = True-        can_fail         = True--primop ReadOffAddrOp_Word32 "readWord32OffAddr#" GenPrimOp-   Addr# -> Int# -> State# s -> (# State# s, Word32# #)-   with has_side_effects = True-        can_fail         = True--primop ReadOffAddrOp_Word64 "readWord64OffAddr#" GenPrimOp-   Addr# -> Int# -> State# s -> (# State# s, Word64# #)-   with has_side_effects = True-        can_fail         = True--primop  WriteOffAddrOp_Char "writeCharOffAddr#" GenPrimOp-   Addr# -> Int# -> Char# -> State# s -> State# s-   with has_side_effects = True-        can_fail         = True--primop  WriteOffAddrOp_WideChar "writeWideCharOffAddr#" GenPrimOp-   Addr# -> Int# -> Char# -> State# s -> State# s-   with has_side_effects = True-        can_fail         = True--primop  WriteOffAddrOp_Int "writeIntOffAddr#" GenPrimOp-   Addr# -> Int# -> Int# -> State# s -> State# s-   with has_side_effects = True-        can_fail         = True--primop  WriteOffAddrOp_Word "writeWordOffAddr#" GenPrimOp-   Addr# -> Int# -> Word# -> State# s -> State# s-   with has_side_effects = True-        can_fail         = True--primop  WriteOffAddrOp_Addr "writeAddrOffAddr#" GenPrimOp-   Addr# -> Int# -> Addr# -> State# s -> State# s-   with has_side_effects = True-        can_fail         = True--primop  WriteOffAddrOp_Float "writeFloatOffAddr#" GenPrimOp-   Addr# -> Int# -> Float# -> State# s -> State# s-   with has_side_effects = True-        can_fail         = True--primop  WriteOffAddrOp_Double "writeDoubleOffAddr#" GenPrimOp-   Addr# -> Int# -> Double# -> State# s -> State# s-   with has_side_effects = True-        can_fail         = True--primop  WriteOffAddrOp_StablePtr "writeStablePtrOffAddr#" GenPrimOp-   Addr# -> Int# -> StablePtr# a -> State# s -> State# s-   with has_side_effects = True-        can_fail         = True--primop  WriteOffAddrOp_Int8 "writeInt8OffAddr#" GenPrimOp-   Addr# -> Int# -> Int8# -> State# s -> State# s-   with has_side_effects = True-        can_fail         = True--primop  WriteOffAddrOp_Int16 "writeInt16OffAddr#" GenPrimOp-   Addr# -> Int# -> Int16# -> State# s -> State# s-   with has_side_effects = True-        can_fail         = True--primop  WriteOffAddrOp_Int32 "writeInt32OffAddr#" GenPrimOp-   Addr# -> Int# -> Int32# -> State# s -> State# s-   with has_side_effects = True-        can_fail         = True--primop  WriteOffAddrOp_Int64 "writeInt64OffAddr#" GenPrimOp-   Addr# -> Int# -> Int64# -> State# s -> State# s-   with has_side_effects = True-        can_fail         = True--primop  WriteOffAddrOp_Word8 "writeWord8OffAddr#" GenPrimOp-   Addr# -> Int# -> Word8# -> State# s -> State# s-   with has_side_effects = True-        can_fail         = True--primop  WriteOffAddrOp_Word16 "writeWord16OffAddr#" GenPrimOp-   Addr# -> Int# -> Word16# -> State# s -> State# s-   with has_side_effects = True-        can_fail         = True--primop  WriteOffAddrOp_Word32 "writeWord32OffAddr#" GenPrimOp-   Addr# -> Int# -> Word32# -> State# s -> State# s-   with has_side_effects = True-        can_fail         = True--primop  WriteOffAddrOp_Word64 "writeWord64OffAddr#" GenPrimOp-   Addr# -> Int# -> Word64# -> State# s -> State# s-   with has_side_effects = True-        can_fail         = True--primop  InterlockedExchange_Addr "atomicExchangeAddrAddr#" GenPrimOp-   Addr# -> Addr# -> State# s -> (# State# s, Addr# #)-   {The atomic exchange operation. Atomically exchanges the value at the first address-    with the Addr# given as second argument. Implies a read barrier.}-   with has_side_effects = True-        can_fail         = True--primop  InterlockedExchange_Word "atomicExchangeWordAddr#" GenPrimOp-   Addr# -> Word# -> State# s -> (# State# s, Word# #)-   {The atomic exchange operation. Atomically exchanges the value at the address-    with the given value. Returns the old value. Implies a read barrier.}-   with has_side_effects = True-        can_fail         = True--primop  CasAddrOp_Addr "atomicCasAddrAddr#" GenPrimOp-   Addr# -> Addr# -> Addr# -> State# s -> (# State# s, Addr# #)-   { Compare and swap on a word-sized memory location.--     Use as: \s -> atomicCasAddrAddr# location expected desired s--     This version always returns the old value read. This follows the normal-     protocol for CAS operations (and matches the underlying instruction on-     most architectures).--     Implies a full memory barrier.}-   with has_side_effects = True-        can_fail         = True--primop  CasAddrOp_Word "atomicCasWordAddr#" GenPrimOp-   Addr# -> Word# -> Word# -> State# s -> (# State# s, Word# #)-   { Compare and swap on a word-sized and aligned memory location.--     Use as: \s -> atomicCasWordAddr# location expected desired s--     This version always returns the old value read. This follows the normal-     protocol for CAS operations (and matches the underlying instruction on-     most architectures).--     Implies a full memory barrier.}-   with has_side_effects = True-        can_fail         = True--primop  CasAddrOp_Word8 "atomicCasWord8Addr#" GenPrimOp-   Addr# -> Word8# -> Word8# -> State# s -> (# State# s, Word8# #)-   { Compare and swap on a 8 bit-sized and aligned memory location.--     Use as: \s -> atomicCasWordAddr8# location expected desired s--     This version always returns the old value read. This follows the normal-     protocol for CAS operations (and matches the underlying instruction on-     most architectures).--     Implies a full memory barrier.}-   with has_side_effects = True-        can_fail         = True--primop  CasAddrOp_Word16 "atomicCasWord16Addr#" GenPrimOp-   Addr# -> Word16# -> Word16# -> State# s -> (# State# s, Word16# #)-   { Compare and swap on a 16 bit-sized and aligned memory location.--     Use as: \s -> atomicCasWordAddr16# location expected desired s--     This version always returns the old value read. This follows the normal-     protocol for CAS operations (and matches the underlying instruction on-     most architectures).--     Implies a full memory barrier.}-   with has_side_effects = True-        can_fail         = True--primop  CasAddrOp_Word32 "atomicCasWord32Addr#" GenPrimOp-   Addr# -> Word32# -> Word32# -> State# s -> (# State# s, Word32# #)-   { Compare and swap on a 32 bit-sized and aligned memory location.--     Use as: \s -> atomicCasWordAddr32# location expected desired s--     This version always returns the old value read. This follows the normal-     protocol for CAS operations (and matches the underlying instruction on-     most architectures).--     Implies a full memory barrier.}-   with has_side_effects = True-        can_fail         = True--primop  CasAddrOp_Word64 "atomicCasWord64Addr#" GenPrimOp-   Addr# -> Word64# -> Word64# -> State# s -> (# State# s, Word64# #)-   { Compare and swap on a 64 bit-sized and aligned memory location.--     Use as: \s -> atomicCasWordAddr64# location expected desired s--     This version always returns the old value read. This follows the normal-     protocol for CAS operations (and matches the underlying instruction on-     most architectures).--     Implies a full memory barrier.}-   with has_side_effects = True-        can_fail         = True--primop FetchAddAddrOp_Word "fetchAddWordAddr#" GenPrimOp-   Addr# -> Word# -> State# s -> (# State# s, Word# #)-   {Given an address, and a value to add,-    atomically add the value to the element. Returns the value of the-    element before the operation. Implies a full memory barrier.}-   with has_side_effects = True-        can_fail = True--primop FetchSubAddrOp_Word "fetchSubWordAddr#" GenPrimOp-   Addr# -> Word# -> State# s -> (# State# s, Word# #)-   {Given an address, and a value to subtract,-    atomically subtract the value from the element. Returns the value of-    the element before the operation. Implies a full memory barrier.}-   with has_side_effects = True-        can_fail = True--primop FetchAndAddrOp_Word "fetchAndWordAddr#" GenPrimOp-   Addr# -> Word# -> State# s -> (# State# s, Word# #)-   {Given an address, and a value to AND,-    atomically AND the value into the element. Returns the value of the-    element before the operation. Implies a full memory barrier.}-   with has_side_effects = True-        can_fail = True--primop FetchNandAddrOp_Word "fetchNandWordAddr#" GenPrimOp-   Addr# -> Word# -> State# s -> (# State# s, Word# #)-   {Given an address, and a value to NAND,-    atomically NAND the value into the element. Returns the value of the-    element before the operation. Implies a full memory barrier.}-   with has_side_effects = True-        can_fail = True--primop FetchOrAddrOp_Word "fetchOrWordAddr#" GenPrimOp-   Addr# -> Word# -> State# s -> (# State# s, Word# #)-   {Given an address, and a value to OR,-    atomically OR the value into the element. Returns the value of the-    element before the operation. Implies a full memory barrier.}-   with has_side_effects = True-        can_fail = True--primop FetchXorAddrOp_Word "fetchXorWordAddr#" GenPrimOp-   Addr# -> Word# -> State# s -> (# State# s, Word# #)-   {Given an address, and a value to XOR,-    atomically XOR the value into the element. Returns the value of the-    element before the operation. Implies a full memory barrier.}-   with has_side_effects = True-        can_fail = True--primop  AtomicReadAddrOp_Word "atomicReadWordAddr#" GenPrimOp-   Addr# -> State# s -> (# State# s, Word# #)-   {Given an address, read a machine word.  Implies a full memory barrier.}-   with has_side_effects = True-        can_fail = True--primop  AtomicWriteAddrOp_Word "atomicWriteWordAddr#" GenPrimOp-   Addr# -> Word# -> State# s -> State# s-   {Given an address, write a machine word. Implies a full memory barrier.}-   with has_side_effects = True-        can_fail = True----------------------------------------------------------------------------section "Mutable variables"-        {Operations on MutVar\#s.}---------------------------------------------------------------------------primtype MutVar# s a-        {A {\tt MutVar\#} behaves like a single-element mutable array.}--primop  NewMutVarOp "newMutVar#" GenPrimOp-   v -> State# s -> (# State# s, MutVar# s v #)-   {Create {\tt MutVar\#} with specified initial value in specified state thread.}-   with-   out_of_line = True-   has_side_effects = True---- Note [Why MutVar# ops can't fail]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~------ We don't label readMutVar# or writeMutVar# as can_fail.--- This may seem a bit peculiar, because they surely *could*--- fail spectacularly if passed a pointer to unallocated memory.--- But MutVar#s are always correct by construction; we never--- test if a pointer is valid before using it with these operations.--- So we never have to worry about floating the pointer reference--- outside a validity test. At the moment, has_side_effects blocks--- up the relevant optimizations anyway, but we hope to draw finer--- distinctions soon, which should improve matters for readMutVar#--- at least.--primop  ReadMutVarOp "readMutVar#" GenPrimOp-   MutVar# s v -> State# s -> (# State# s, v #)-   {Read contents of {\tt MutVar\#}. Result is not yet evaluated.}-   with-   -- See Note [Why MutVar# ops can't fail]-   has_side_effects = True--primop  WriteMutVarOp "writeMutVar#"  GenPrimOp-   MutVar# s v -> v -> State# s -> State# s-   {Write contents of {\tt MutVar\#}.}-   with-   -- See Note [Why MutVar# ops can't fail]-   has_side_effects = True-   code_size = { primOpCodeSizeForeignCall } -- for the write barrier---- Note [Why not an unboxed tuple in atomicModifyMutVar2#?]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- Looking at the type of atomicModifyMutVar2#, one might wonder why--- it doesn't return an unboxed tuple. e.g.,------   MutVar# s a -> (a -> (# a, b #)) -> State# s -> (# State# s, a, (# a, b #) #)------ The reason is that atomicModifyMutVar2# relies on laziness for its atomicity.--- Given a MutVar# containing x, atomicModifyMutVar2# merely replaces--- its contents with a thunk of the form (fst (f x)). This can be done using an--- atomic compare-and-swap as it is merely replacing a pointer.--primop  AtomicModifyMutVar2Op "atomicModifyMutVar2#" GenPrimOp-   MutVar# s a -> (a -> c) -> State# s -> (# State# s, a, c #)-   { Modify the contents of a {\tt MutVar\#}, returning the previous-     contents and the result of applying the given function to the-     previous contents. Note that this isn't strictly-     speaking the correct type for this function; it should really be-     {\tt MutVar\# s a -> (a -> (a,b)) -> State\# s -> (\# State\# s, a, (a, b) \#)},-     but we don't know about pairs here. }-   with-   out_of_line = True-   has_side_effects = True-   can_fail         = True--primop  AtomicModifyMutVar_Op "atomicModifyMutVar_#" GenPrimOp-   MutVar# s a -> (a -> a) -> State# s -> (# State# s, a, a #)-   { Modify the contents of a {\tt MutVar\#}, returning the previous-     contents and the result of applying the given function to the-     previous contents. }-   with-   out_of_line = True-   has_side_effects = True-   can_fail         = True--primop  CasMutVarOp "casMutVar#" GenPrimOp-  MutVar# s v -> v -> v -> State# s -> (# State# s, Int#, v #)-   { Compare-and-swap: perform a pointer equality test between-     the first value passed to this function and the value-     stored inside the {\tt MutVar\#}. If the pointers are equal,-     replace the stored value with the second value passed to this-     function, otherwise do nothing.-     Returns the final value stored inside the {\tt MutVar\#}.-     The {\tt Int\#} indicates whether a swap took place,-     with {\tt 1\#} meaning that we didn't swap, and {\tt 0\#}-     that we did.-     Implies a full memory barrier.-     Because the comparison is done on the level of pointers,-     all of the difficulties of using-     {\tt reallyUnsafePtrEquality\#} correctly apply to-     {\tt casMutVar\#} as well.-   }-   with-   out_of_line = True-   has_side_effects = True---------------------------------------------------------------------------section "Exceptions"----------------------------------------------------------------------------- Note [Strictness for mask/unmask/catch]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- Consider this example, which comes from GHC.IO.Handle.Internals:---    wantReadableHandle3 f ma b st---      = case ... of---          DEFAULT -> case ma of MVar a -> ...---          0#      -> maskAsyncExceptions# (\st -> case ma of MVar a -> ...)--- The outer case just decides whether to mask exceptions, but we don't want--- thereby to hide the strictness in 'ma'!  Hence the use of strictOnceApply1Dmd--- in mask and unmask. But catch really is lazy in its first argument, see--- #11555. So for IO actions 'ma' we often use a wrapper around it that is--- head-strict in 'ma': GHC.IO.catchException.--primop  CatchOp "catch#" GenPrimOp-          (State# RealWorld -> (# State# RealWorld, o #) )-       -> (w -> State# RealWorld -> (# State# RealWorld, o #) )-       -> State# RealWorld-       -> (# State# RealWorld, o #)-   with-   strictness  = { \ _arity -> mkClosedDmdSig [ lazyApply1Dmd-                                                 , lazyApply2Dmd-                                                 , topDmd] topDiv }-                 -- See Note [Strictness for mask/unmask/catch]-   out_of_line = True-   has_side_effects = True--primop  RaiseOp "raise#" GenPrimOp-   v -> p-      -- NB: "v" is the same as "a" except levity-polymorphic,-      -- and "p" is the same as "b" except representation-polymorphic-      -- See Note [Levity and representation polymorphic primops]-   with-   -- In contrast to 'raiseIO#', which throws a *precise* exception,-   -- exceptions thrown by 'raise#' are considered *imprecise*.-   -- See Note [Precise vs imprecise exceptions] in GHC.Types.Demand.-   -- Hence, it has 'botDiv', not 'exnDiv'.-   -- For the same reasons, 'raise#' is marked as "can_fail" (which 'raiseIO#'-   -- is not), but not as "has_side_effects" (which 'raiseIO#' is).-   -- See Note [PrimOp can_fail and has_side_effects] in "GHC.Builtin.PrimOps".-   strictness  = { \ _arity -> mkClosedDmdSig [topDmd] botDiv }-   out_of_line = True-   can_fail = True--primop  RaiseIOOp "raiseIO#" GenPrimOp-   v -> State# RealWorld -> (# State# RealWorld, p #)-   with-   -- See Note [Precise exceptions and strictness analysis] in "GHC.Types.Demand"-   -- for why this is the *only* primop that has 'exnDiv'-   strictness  = { \ _arity -> mkClosedDmdSig [topDmd, topDmd] exnDiv }-   out_of_line = True-   has_side_effects = True--primop  MaskAsyncExceptionsOp "maskAsyncExceptions#" GenPrimOp-        (State# RealWorld -> (# State# RealWorld, o #))-     -> (State# RealWorld -> (# State# RealWorld, o #))-   with-   strictness  = { \ _arity -> mkClosedDmdSig [strictOnceApply1Dmd,topDmd] topDiv }-                 -- See Note [Strictness for mask/unmask/catch]-   out_of_line = True-   has_side_effects = True--primop  MaskUninterruptibleOp "maskUninterruptible#" GenPrimOp-        (State# RealWorld -> (# State# RealWorld, o #))-     -> (State# RealWorld -> (# State# RealWorld, o #))-   with-   strictness  = { \ _arity -> mkClosedDmdSig [strictOnceApply1Dmd,topDmd] topDiv }-   out_of_line = True-   has_side_effects = True--primop  UnmaskAsyncExceptionsOp "unmaskAsyncExceptions#" GenPrimOp-        (State# RealWorld -> (# State# RealWorld, o #))-     -> (State# RealWorld -> (# State# RealWorld, o #))-   with-   strictness  = { \ _arity -> mkClosedDmdSig [strictOnceApply1Dmd,topDmd] topDiv }-                 -- See Note [Strictness for mask/unmask/catch]-   out_of_line = True-   has_side_effects = True--primop  MaskStatus "getMaskingState#" GenPrimOp-        State# RealWorld -> (# State# RealWorld, Int# #)-   with-   out_of_line = True-   has_side_effects = True---------------------------------------------------------------------------section "STM-accessible Mutable Variables"---------------------------------------------------------------------------primtype TVar# s a--primop  AtomicallyOp "atomically#" GenPrimOp-      (State# RealWorld -> (# State# RealWorld, v #) )-   -> State# RealWorld -> (# State# RealWorld, v #)-   with-   strictness  = { \ _arity -> mkClosedDmdSig [strictManyApply1Dmd,topDmd] topDiv }-                 -- See Note [Strictness for mask/unmask/catch]-   out_of_line = True-   has_side_effects = True---- NB: retry#'s strictness information specifies it to diverge.--- This lets the compiler perform some extra simplifications, since retry#--- will technically never return.------ This allows the simplifier to replace things like:---   case retry# s1---     (# s2, a #) -> e--- with:---   retry# s1--- where 'e' would be unreachable anyway.  See #8091.-primop  RetryOp "retry#" GenPrimOp-   State# RealWorld -> (# State# RealWorld, v #)-   with-   strictness  = { \ _arity -> mkClosedDmdSig [topDmd] botDiv }-   out_of_line = True-   has_side_effects = True--primop  CatchRetryOp "catchRetry#" GenPrimOp-      (State# RealWorld -> (# State# RealWorld, v #) )-   -> (State# RealWorld -> (# State# RealWorld, v #) )-   -> (State# RealWorld -> (# State# RealWorld, v #) )-   with-   strictness  = { \ _arity -> mkClosedDmdSig [ lazyApply1Dmd-                                                 , lazyApply1Dmd-                                                 , topDmd ] topDiv }-                 -- See Note [Strictness for mask/unmask/catch]-   out_of_line = True-   has_side_effects = True--primop  CatchSTMOp "catchSTM#" GenPrimOp-      (State# RealWorld -> (# State# RealWorld, v #) )-   -> (b -> State# RealWorld -> (# State# RealWorld, v #) )-   -> (State# RealWorld -> (# State# RealWorld, v #) )-   with-   strictness  = { \ _arity -> mkClosedDmdSig [ lazyApply1Dmd-                                                 , lazyApply2Dmd-                                                 , topDmd ] topDiv }-                 -- See Note [Strictness for mask/unmask/catch]-   out_of_line = True-   has_side_effects = True--primop  NewTVarOp "newTVar#" GenPrimOp-       v-    -> State# s -> (# State# s, TVar# s v #)-   {Create a new {\tt TVar\#} holding a specified initial value.}-   with-   out_of_line  = True-   has_side_effects = True--primop  ReadTVarOp "readTVar#" GenPrimOp-       TVar# s v-    -> State# s -> (# State# s, v #)-   {Read contents of {\tt TVar\#} inside an STM transaction,-    i.e. within a call to {\tt atomically\#}.-    Does not force evaluation of the result.}-   with-   out_of_line  = True-   has_side_effects = True--primop ReadTVarIOOp "readTVarIO#" GenPrimOp-       TVar# s v-    -> State# s -> (# State# s, v #)-   {Read contents of {\tt TVar\#} outside an STM transaction.-   Does not force evaluation of the result.}-   with-   out_of_line      = True-   has_side_effects = True--primop  WriteTVarOp "writeTVar#" GenPrimOp-       TVar# s v-    -> v-    -> State# s -> State# s-   {Write contents of {\tt TVar\#}.}-   with-   out_of_line      = True-   has_side_effects = True----------------------------------------------------------------------------section "Synchronized Mutable Variables"-        {Operations on {\tt MVar\#}s. }---------------------------------------------------------------------------primtype MVar# s a-        { A shared mutable variable ({\it not} the same as a {\tt MutVar\#}!).-        (Note: in a non-concurrent implementation, {\tt (MVar\# a)} can be-        represented by {\tt (MutVar\# (Maybe a))}.) }--primop  NewMVarOp "newMVar#"  GenPrimOp-   State# s -> (# State# s, MVar# s v #)-   {Create new {\tt MVar\#}; initially empty.}-   with-   out_of_line = True-   has_side_effects = True--primop  TakeMVarOp "takeMVar#" GenPrimOp-   MVar# s v -> State# s -> (# State# s, v #)-   {If {\tt MVar\#} is empty, block until it becomes full.-   Then remove and return its contents, and set it empty.}-   with-   out_of_line      = True-   has_side_effects = True--primop  TryTakeMVarOp "tryTakeMVar#" GenPrimOp-   MVar# s v -> State# s -> (# State# s, Int#, v #)-   {If {\tt MVar\#} is empty, immediately return with integer 0 and value undefined.-   Otherwise, return with integer 1 and contents of {\tt MVar\#}, and set {\tt MVar\#} empty.}-   with-   out_of_line      = True-   has_side_effects = True--primop  PutMVarOp "putMVar#" GenPrimOp-   MVar# s v -> v -> State# s -> State# s-   {If {\tt MVar\#} is full, block until it becomes empty.-   Then store value arg as its new contents.}-   with-   out_of_line      = True-   has_side_effects = True--primop  TryPutMVarOp "tryPutMVar#" GenPrimOp-   MVar# s v -> v -> State# s -> (# State# s, Int# #)-   {If {\tt MVar\#} is full, immediately return with integer 0.-    Otherwise, store value arg as {\tt MVar\#}'s new contents, and return with integer 1.}-   with-   out_of_line      = True-   has_side_effects = True--primop  ReadMVarOp "readMVar#" GenPrimOp-   MVar# s v -> State# s -> (# State# s, v #)-   {If {\tt MVar\#} is empty, block until it becomes full.-   Then read its contents without modifying the MVar, without possibility-   of intervention from other threads.}-   with-   out_of_line      = True-   has_side_effects = True--primop  TryReadMVarOp "tryReadMVar#" GenPrimOp-   MVar# s v -> State# s -> (# State# s, Int#, v #)-   {If {\tt MVar\#} is empty, immediately return with integer 0 and value undefined.-   Otherwise, return with integer 1 and contents of {\tt MVar\#}.}-   with-   out_of_line      = True-   has_side_effects = True--primop  IsEmptyMVarOp "isEmptyMVar#" GenPrimOp-   MVar# s v -> State# s -> (# State# s, Int# #)-   {Return 1 if {\tt MVar\#} is empty; 0 otherwise.}-   with-   out_of_line = True-   has_side_effects = True----------------------------------------------------------------------------section "Synchronized I/O Ports"-        {Operations on {\tt IOPort\#}s. }---------------------------------------------------------------------------primtype IOPort# s a-        { A shared I/O port is almost the same as a {\tt MVar\#}!).-        The main difference is that IOPort has no deadlock detection or-        deadlock breaking code that forcibly releases the lock. }--primop  NewIOPortOp "newIOPort#"  GenPrimOp-   State# s -> (# State# s, IOPort# s v #)-   {Create new {\tt IOPort\#}; initially empty.}-   with-   out_of_line = True-   has_side_effects = True--primop  ReadIOPortOp "readIOPort#" GenPrimOp-   IOPort# s v -> State# s -> (# State# s, v #)-   {If {\tt IOPort\#} is empty, block until it becomes full.-   Then remove and return its contents, and set it empty.-   Throws an {\tt IOPortException} if another thread is already-   waiting to read this {\tt IOPort\#}.}-   with-   out_of_line      = True-   has_side_effects = True--primop  WriteIOPortOp "writeIOPort#" GenPrimOp-   IOPort# s v -> v -> State# s -> (# State# s, Int# #)-   {If {\tt IOPort\#} is full, immediately return with integer 0,-    throwing an {\tt IOPortException}.-    Otherwise, store value arg as {\tt IOPort\#}'s new contents,-    and return with integer 1. }-   with-   out_of_line      = True-   has_side_effects = True---------------------------------------------------------------------------section "Delay/wait operations"---------------------------------------------------------------------------primop  DelayOp "delay#" GenPrimOp-   Int# -> State# s -> State# s-   {Sleep specified number of microseconds.}-   with-   has_side_effects = True-   out_of_line      = True--primop  WaitReadOp "waitRead#" GenPrimOp-   Int# -> State# s -> State# s-   {Block until input is available on specified file descriptor.}-   with-   has_side_effects = True-   out_of_line      = True--primop  WaitWriteOp "waitWrite#" GenPrimOp-   Int# -> State# s -> State# s-   {Block until output is possible on specified file descriptor.}-   with-   has_side_effects = True-   out_of_line      = True---------------------------------------------------------------------------section "Concurrency primitives"---------------------------------------------------------------------------primtype State# s-        { {\tt State\#} is the primitive, unlifted type of states.  It has-        one type parameter, thus {\tt State\# RealWorld}, or {\tt State\# s},-        where s is a type variable. The only purpose of the type parameter-        is to keep different state threads separate.  It is represented by-        nothing at all. }--primtype RealWorld-        { {\tt RealWorld} is deeply magical.  It is {\it primitive}, but it is not-        {\it unlifted} (hence {\tt ptrArg}).  We never manipulate values of type-        {\tt RealWorld}; it's only used in the type system, to parameterise {\tt State\#}. }--primtype ThreadId#-        {(In a non-concurrent implementation, this can be a singleton-        type, whose (unique) value is returned by {\tt myThreadId\#}.  The-        other operations can be omitted.)}--primop  ForkOp "fork#" GenPrimOp-   (State# RealWorld -> (# State# RealWorld, o #))-   -> State# RealWorld -> (# State# RealWorld, ThreadId# #)-   with-   has_side_effects = True-   out_of_line      = True-   strictness  = { \ _arity -> mkClosedDmdSig [ lazyApply1Dmd-                                              , topDmd ] topDiv }--primop  ForkOnOp "forkOn#" GenPrimOp-   Int# -> (State# RealWorld -> (# State# RealWorld, o #))-   -> State# RealWorld -> (# State# RealWorld, ThreadId# #)-   with-   has_side_effects = True-   out_of_line      = True-   strictness  = { \ _arity -> mkClosedDmdSig [ topDmd-                                              , lazyApply1Dmd-                                              , topDmd ] topDiv }--primop  KillThreadOp "killThread#"  GenPrimOp-   ThreadId# -> a -> State# RealWorld -> State# RealWorld-   with-   has_side_effects = True-   out_of_line      = True--primop  YieldOp "yield#" GenPrimOp-   State# RealWorld -> State# RealWorld-   with-   has_side_effects = True-   out_of_line      = True--primop  MyThreadIdOp "myThreadId#" GenPrimOp-   State# RealWorld -> (# State# RealWorld, ThreadId# #)-   with-   has_side_effects = True--primop LabelThreadOp "labelThread#" GenPrimOp-   ThreadId# -> Addr# -> State# RealWorld -> State# RealWorld-   with-   has_side_effects = True-   out_of_line      = True--primop  IsCurrentThreadBoundOp "isCurrentThreadBound#" GenPrimOp-   State# RealWorld -> (# State# RealWorld, Int# #)-   with-   out_of_line = True-   has_side_effects = True--primop  NoDuplicateOp "noDuplicate#" GenPrimOp-   State# s -> State# s-   with-   out_of_line = True-   has_side_effects = True--primop  ThreadStatusOp "threadStatus#" GenPrimOp-   ThreadId# -> State# RealWorld -> (# State# RealWorld, Int#, Int#, Int# #)-   with-   out_of_line = True-   has_side_effects = True---------------------------------------------------------------------------section "Weak pointers"---------------------------------------------------------------------------primtype Weak# b---- N.B. "v" and "w" denote levity-polymorphic type variables.--- See Note [Levity and representation polymorphic primops]--primop  MkWeakOp "mkWeak#" GenPrimOp-   v -> w -> (State# RealWorld -> (# State# RealWorld, c #))-     -> State# RealWorld -> (# State# RealWorld, Weak# w #)-   { {\tt mkWeak# k v finalizer s} creates a weak reference to value {\tt k},-     with an associated reference to some value {\tt v}. If {\tt k} is still-     alive then {\tt v} can be retrieved using {\tt deRefWeak#}. Note that-     the type of {\tt k} must be represented by a pointer (i.e. of kind {\tt-     TYPE 'LiftedRep} or {\tt TYPE 'UnliftedRep}). }-   with-   has_side_effects = True-   out_of_line      = True--primop  MkWeakNoFinalizerOp "mkWeakNoFinalizer#" GenPrimOp-   v -> w -> State# RealWorld -> (# State# RealWorld, Weak# w #)-   with-   has_side_effects = True-   out_of_line      = True--primop  AddCFinalizerToWeakOp "addCFinalizerToWeak#" GenPrimOp-   Addr# -> Addr# -> Int# -> Addr# -> Weak# w-          -> State# RealWorld -> (# State# RealWorld, Int# #)-   { {\tt addCFinalizerToWeak# fptr ptr flag eptr w} attaches a C-     function pointer {\tt fptr} to a weak pointer {\tt w} as a finalizer. If-     {\tt flag} is zero, {\tt fptr} will be called with one argument,-     {\tt ptr}. Otherwise, it will be called with two arguments,-     {\tt eptr} and {\tt ptr}. {\tt addCFinalizerToWeak#} returns-     1 on success, or 0 if {\tt w} is already dead. }-   with-   has_side_effects = True-   out_of_line      = True--primop  DeRefWeakOp "deRefWeak#" GenPrimOp-   Weak# v -> State# RealWorld -> (# State# RealWorld, Int#, v #)-   with-   has_side_effects = True-   out_of_line      = True--primop  FinalizeWeakOp "finalizeWeak#" GenPrimOp-   Weak# v -> State# RealWorld -> (# State# RealWorld, Int#,-              (State# RealWorld -> (# State# RealWorld, b #) ) #)-   { Finalize a weak pointer. The return value is an unboxed tuple-     containing the new state of the world and an "unboxed Maybe",-     represented by an {\tt Int#} and a (possibly invalid) finalization-     action. An {\tt Int#} of {\tt 1} indicates that the finalizer is valid. The-     return value {\tt b} from the finalizer should be ignored. }-   with-   has_side_effects = True-   out_of_line      = True--primop TouchOp "touch#" GenPrimOp-   v -> State# RealWorld -> State# RealWorld-   with-   code_size = { 0 }-   has_side_effects = True---------------------------------------------------------------------------section "Stable pointers and names"---------------------------------------------------------------------------primtype StablePtr# a--primtype StableName# a--primop  MakeStablePtrOp "makeStablePtr#" GenPrimOp-   v -> State# RealWorld -> (# State# RealWorld, StablePtr# v #)-   with-   has_side_effects = True-   out_of_line      = True--primop  DeRefStablePtrOp "deRefStablePtr#" GenPrimOp-   StablePtr# v -> State# RealWorld -> (# State# RealWorld, v #)-   with-   has_side_effects = True-   out_of_line      = True--primop  EqStablePtrOp "eqStablePtr#" GenPrimOp-   StablePtr# v -> StablePtr# v -> Int#-   with-   has_side_effects = True--primop  MakeStableNameOp "makeStableName#" GenPrimOp-   v -> State# RealWorld -> (# State# RealWorld, StableName# v #)-   with-   has_side_effects = True-   out_of_line      = True--primop  StableNameToIntOp "stableNameToInt#" GenPrimOp-   StableName# v -> Int#---------------------------------------------------------------------------section "Compact normal form"--        {Primitives for working with compact regions. The {\tt ghc\-compact}-         library and the {\tt compact} library demonstrate how to use these-         primitives. The documentation below draws a distinction between-         a CNF and a compact block. A CNF contains one or more compact-         blocks. The source file {\tt rts\/sm\/CNF.c}-         diagrams this relationship. When discussing a compact-         block, an additional distinction is drawn between capacity and-         utilized bytes. The capacity is the maximum number of bytes that-         the compact block can hold. The utilized bytes is the number of-         bytes that are actually used by the compact block.-        }----------------------------------------------------------------------------primtype Compact#--primop  CompactNewOp "compactNew#" GenPrimOp-   Word# -> State# RealWorld -> (# State# RealWorld, Compact# #)-   { Create a new CNF with a single compact block. The argument is-     the capacity of the compact block (in bytes, not words).-     The capacity is rounded up to a multiple of the allocator block size-     and is capped to one mega block. }-   with-   has_side_effects = True-   out_of_line      = True--primop  CompactResizeOp "compactResize#" GenPrimOp-   Compact# -> Word# -> State# RealWorld ->-   State# RealWorld-   { Set the new allocation size of the CNF. This value (in bytes)-     determines the capacity of each compact block in the CNF. It-     does not retroactively affect existing compact blocks in the CNF. }-   with-   has_side_effects = True-   out_of_line      = True--primop  CompactContainsOp "compactContains#" GenPrimOp-   Compact# -> a -> State# RealWorld -> (# State# RealWorld, Int# #)-   { Returns 1\# if the object is contained in the CNF, 0\# otherwise. }-   with-   out_of_line      = True--primop  CompactContainsAnyOp "compactContainsAny#" GenPrimOp-   a -> State# RealWorld -> (# State# RealWorld, Int# #)-   { Returns 1\# if the object is in any CNF at all, 0\# otherwise. }-   with-   out_of_line      = True--primop  CompactGetFirstBlockOp "compactGetFirstBlock#" GenPrimOp-   Compact# -> State# RealWorld -> (# State# RealWorld, Addr#, Word# #)-   { Returns the address and the utilized size (in bytes) of the-     first compact block of a CNF.}-   with-   out_of_line      = True--primop  CompactGetNextBlockOp "compactGetNextBlock#" GenPrimOp-   Compact# -> Addr# -> State# RealWorld -> (# State# RealWorld, Addr#, Word# #)-   { Given a CNF and the address of one its compact blocks, returns the-     next compact block and its utilized size, or {\tt nullAddr\#} if the-     argument was the last compact block in the CNF. }-   with-   out_of_line      = True--primop  CompactAllocateBlockOp "compactAllocateBlock#" GenPrimOp-   Word# -> Addr# -> State# RealWorld -> (# State# RealWorld, Addr# #)-   { Attempt to allocate a compact block with the capacity (in-     bytes) given by the first argument. The {\texttt Addr\#} is a pointer-     to previous compact block of the CNF or {\texttt nullAddr\#} to create a-     new CNF with a single compact block.--     The resulting block is not known to the GC until-     {\texttt compactFixupPointers\#} is called on it, and care must be taken-     so that the address does not escape or memory will be leaked.-   }-   with-   has_side_effects = True-   out_of_line      = True--primop  CompactFixupPointersOp "compactFixupPointers#" GenPrimOp-   Addr# -> Addr# -> State# RealWorld -> (# State# RealWorld, Compact#, Addr# #)-   { Given the pointer to the first block of a CNF and the-     address of the root object in the old address space, fix up-     the internal pointers inside the CNF to account for-     a different position in memory than when it was serialized.-     This method must be called exactly once after importing-     a serialized CNF. It returns the new CNF and the new adjusted-     root address. }-   with-   has_side_effects = True-   out_of_line      = True--primop CompactAdd "compactAdd#" GenPrimOp-   Compact# -> a -> State# RealWorld -> (# State# RealWorld, a #)-   { Recursively add a closure and its transitive closure to a-     {\texttt Compact\#} (a CNF), evaluating any unevaluated components-     at the same time. Note: {\texttt compactAdd\#} is not thread-safe, so-     only one thread may call {\texttt compactAdd\#} with a particular-     {\texttt Compact\#} at any given time. The primop does not-     enforce any mutual exclusion; the caller is expected to-     arrange this. }-   with-   has_side_effects = True-   out_of_line      = True--primop CompactAddWithSharing "compactAddWithSharing#" GenPrimOp-   Compact# -> a -> State# RealWorld -> (# State# RealWorld, a #)-   { Like {\texttt compactAdd\#}, but retains sharing and cycles-   during compaction. }-   with-   has_side_effects = True-   out_of_line      = True--primop CompactSize "compactSize#" GenPrimOp-   Compact# -> State# RealWorld -> (# State# RealWorld, Word# #)-   { Return the total capacity (in bytes) of all the compact blocks-     in the CNF. }-   with-   has_side_effects = True-   out_of_line      = True---------------------------------------------------------------------------section "Unsafe pointer equality"---  (#1 Bad Guy: Alastair Reid :)----------------------------------------------------------------------------- `v` and `w` are levity-polymorphic type variables with independent levities.--- See Note [Levity and representation polymorphic primops]-primop  ReallyUnsafePtrEqualityOp "reallyUnsafePtrEquality#" GenPrimOp-   v -> w -> Int#-   { Returns {\texttt 1\#} if the given pointers are equal and {\texttt 0\#} otherwise. }-   with-   can_fail   = True -- See Note [reallyUnsafePtrEquality# can_fail]---- Note [Pointer comparison operations]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- The primop `reallyUnsafePtrEquality#` does a direct pointer--- equality between two (boxed) values.  Several things to note:------ * It is levity-polymorphic. It works for TYPE (BoxedRep Lifted) and---   TYPE (BoxedRep Unlifted). But not TYPE IntRep, for example.---   This levity-polymorphism comes from the use of the type variables---   "v" and "w". See Note [Levity and representation polymorphic primops]------ * It does not evaluate its arguments. The user of the primop is responsible---   for doing so.------ * It is hetero-typed; you can compare pointers of different types.---   This is used in various packages such as containers & unordered-containers.------ * It is obviously very dangerous, because---      let x = f y in reallyUnsafePtrEquality# x x---   will probably return True, whereas---      reallyUnsafePtrEquality# (f y) (f y)---   will probably return False. ("probably", because it's affected---   by CSE and inlining).------ * reallyUnsafePtrEquality# can't fail, but it is marked as such---   to prevent it from floating out.---   See Note [reallyUnsafePtrEquality# can_fail]------ The library GHC.Exts provides several less Wild-West functions--- for use in specific cases, namely:------   reallyUnsafePtrEquality :: a -> a -> Int#  -- not levity-polymorphic, nor hetero-typed---   sameArray# :: Array# a -> Array# a -> Int#---   sameMutableArray# :: MutableArray# s a -> MutableArray# s a -> Int#---   sameSmallArray# :: SmallArray# a -> SmallArray# a -> Int#---   sameSmallMutableArray# :: SmallMutableArray# s a -> SmallMutableArray# s a -> Int#---   sameByteArray# :: ByteArray# -> ByteArray# -> Int#---   sameMutableByteArray# :: MutableByteArray# s -> MutableByteArray# s -> Int#---   sameArrayArray# :: ArrayArray# -> ArrayArray# -> Int#---   sameMutableArrayArray# :: MutableArrayArray# s -> MutableArrayArray# s -> Int#---   sameMutVar# :: MutVar# s a -> MutVar# s a -> Int#---   sameTVar# :: TVar# s a -> TVar# s a -> Int#---   sameMVar# :: MVar# s a -> MVar# s a -> Int#---   sameIOPort# :: IOPort# s a -> IOPort# s a -> Int#---   eqStableName# :: StableName# a -> StableName# b -> Int#------ These operations are all specialisations of reallyUnsafePtrEquality#.---- Note [reallyUnsafePtrEquality# can_fail]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- reallyUnsafePtrEquality# can't actually fail, per se, but we mark it--- can_fail anyway. Until 5a9a1738023a, GHC considered primops okay for--- speculation only when their arguments were known to be forced. This was--- unnecessarily conservative, but it prevented reallyUnsafePtrEquality# from--- floating out of places where its arguments were known to be forced.--- Unfortunately, GHC could sometimes lose track of whether those arguments--- were forced, leading to let/app invariant failures (see #13027 and the--- discussion in #11444). Now that ok_for_speculation skips over lifted--- arguments, we need to explicitly prevent reallyUnsafePtrEquality#--- from floating out. Imagine if we had------     \x y . case x of x'---              DEFAULT ->---            case y of y'---              DEFAULT ->---               let eq = reallyUnsafePtrEquality# x' y'---               in ...------ If the let floats out, we'll get------     \x y . let eq = reallyUnsafePtrEquality# x y---            in case x of ...------ The trouble is that pointer equality between thunks is very different--- from pointer equality between the values those thunks reduce to, and the latter--- is typically much more precise.---------------------------------------------------------------------------section "Parallelism"---------------------------------------------------------------------------primop  ParOp "par#" GenPrimOp-   a -> Int#-   with-      -- Note that Par is lazy to avoid that the sparked thing-      -- gets evaluated strictly, which it should *not* be-   has_side_effects = True-   code_size = { primOpCodeSizeForeignCall }-   deprecated_msg = { Use 'spark#' instead }--primop SparkOp "spark#" GenPrimOp-   a -> State# s -> (# State# s, a #)-   with has_side_effects = True-   code_size = { primOpCodeSizeForeignCall }--primop SeqOp "seq#" GenPrimOp-   a -> State# s -> (# State# s, a #)-   -- See Note [seq# magic] in GHC.Core.Op.ConstantFold--primop GetSparkOp "getSpark#" GenPrimOp-   State# s -> (# State# s, Int#, a #)-   with-   has_side_effects = True-   out_of_line = True--primop NumSparks "numSparks#" GenPrimOp-   State# s -> (# State# s, Int# #)-   { Returns the number of sparks in the local spark pool. }-   with-   has_side_effects = True-   out_of_line = True----------------------------------------------------------------------------section "Controlling object lifetime"-        {Ensuring that objects don't die a premature death.}----------------------------------------------------------------------------- See Note [keepAlive# magic] in GHC.CoreToStg.Prep.--- NB: "v" is the same as "a" except levity-polymorphic,--- and "p" is the same as "b" except representation-polymorphic.--- See Note [Levity and representation polymorphic primops]-primop KeepAliveOp "keepAlive#" GenPrimOp-   v -> State# RealWorld -> (State# RealWorld -> p) -> p-   { \tt{keepAlive# x s k} keeps the value \tt{x} alive during the execution-     of the computation \tt{k}.--     Note that the result type here isn't quite as unrestricted as the-     polymorphic type might suggest; ticket \#21868 for details. }-   with-   out_of_line = True-   strictness = { \ _arity -> mkClosedDmdSig [topDmd, topDmd, strictOnceApply1Dmd] topDiv }----------------------------------------------------------------------------section "Tag to enum stuff"-        {Convert back and forth between values of enumerated types-        and small integers.}---------------------------------------------------------------------------primop  DataToTagOp "dataToTag#" GenPrimOp-   a -> Int#  -- Zero-indexed; the first constructor has tag zero-   with-   strictness = { \ _arity -> mkClosedDmdSig [evalDmd] topDiv }-   -- See Note [dataToTag# magic] in GHC.Core.Opt.ConstantFold--primop  TagToEnumOp "tagToEnum#" GenPrimOp-   Int# -> a---------------------------------------------------------------------------section "Bytecode operations"-        {Support for manipulating bytecode objects used by the interpreter and-        linker.--        Bytecode objects are heap objects which represent top-level bindings and-        contain a list of instructions and data needed by these instructions.}---------------------------------------------------------------------------primtype BCO-   { Primitive bytecode type. }--primop   AddrToAnyOp "addrToAny#" GenPrimOp-   Addr# -> (# a #)-   { Convert an {\tt Addr\#} to a followable Any type. }-   with-   code_size = 0--primop   AnyToAddrOp "anyToAddr#" GenPrimOp-   a -> State# RealWorld -> (# State# RealWorld, Addr# #)-   { Retrieve the address of any Haskell value. This is-     essentially an {\texttt unsafeCoerce\#}, but if implemented as such-     the core lint pass complains and fails to compile.-     As a primop, it is opaque to core/stg, and only appears-     in cmm (where the copy propagation pass will get rid of it).-     Note that "a" must be a value, not a thunk! It's too late-     for strictness analysis to enforce this, so you're on your-     own to guarantee this. Also note that {\texttt Addr\#} is not a GC-     pointer - up to you to guarantee that it does not become-     a dangling pointer immediately after you get it.}-   with-   code_size = 0--primop   MkApUpd0_Op "mkApUpd0#" GenPrimOp-   BCO -> (# a #)-   { Wrap a BCO in a {\tt AP_UPD} thunk which will be updated with the value of-     the BCO when evaluated. }-   with-   out_of_line = True--primop  NewBCOOp "newBCO#" GenPrimOp-   ByteArray# -> ByteArray# -> Array# a -> Int# -> ByteArray# -> State# s -> (# State# s, BCO #)-   { {\tt newBCO\# instrs lits ptrs arity bitmap} creates a new bytecode object. The-     resulting object encodes a function of the given arity with the instructions-     encoded in {\tt instrs}, and a static reference table usage bitmap given by-     {\tt bitmap}. }-   with-   has_side_effects = True-   out_of_line      = True--primop  UnpackClosureOp "unpackClosure#" GenPrimOp-   a -> (# Addr#, ByteArray#, Array# b #)-   { {\tt unpackClosure\# closure} copies the closure and pointers in the-     payload of the given closure into two new arrays, and returns a pointer to-     the first word of the closure's info table, a non-pointer array for the raw-     bytes of the closure, and a pointer array for the pointers in the payload. }-   with-   out_of_line = True--primop  ClosureSizeOp "closureSize#" GenPrimOp-   a -> Int#-   { {\tt closureSize\# closure} returns the size of the given closure in-     machine words. }-   with-   out_of_line = True--primop  GetApStackValOp "getApStackVal#" GenPrimOp-   a -> Int# -> (# Int#, b #)-   with-   out_of_line = True---------------------------------------------------------------------------section "Misc"-        {These aren't nearly as wired in as Etc...}---------------------------------------------------------------------------primop  GetCCSOfOp "getCCSOf#" GenPrimOp-   a -> State# s -> (# State# s, Addr# #)--primop  GetCurrentCCSOp "getCurrentCCS#" GenPrimOp-   a -> State# s -> (# State# s, Addr# #)-   { Returns the current {\tt CostCentreStack} (value is {\tt NULL} if-     not profiling).  Takes a dummy argument which can be used to-     avoid the call to {\tt getCurrentCCS\#} being floated out by the-     simplifier, which would result in an uninformative stack-     ("CAF"). }--primop  ClearCCSOp "clearCCS#" GenPrimOp-   (State# s -> (# State# s, a #)) -> State# s -> (# State# s, a #)-   { Run the supplied IO action with an empty CCS.  For example, this-     is used by the interpreter to run an interpreted computation-     without the call stack showing that it was invoked from GHC. }-   with-   out_of_line = True---------------------------------------------------------------------------section "Info Table Origin"--------------------------------------------------------------------------primop WhereFromOp "whereFrom#" GenPrimOp-   a -> State# s -> (# State# s, Addr# #)-   { Returns the {\tt InfoProvEnt } for the info table of the given object-     (value is {\tt NULL} if the table does not exist or there is no information-     about the closure).}-   with-   out_of_line = True---------------------------------------------------------------------------section "Etc"-        {Miscellaneous built-ins}---------------------------------------------------------------------------primtype FUN m a b-  {The builtin function type, written in infix form as {\tt a # m -> b}.-   Values of this type are functions taking inputs of type {\tt a} and-   producing outputs of type {\tt b}. The multiplicity of the input is-   {\tt m}.--   Note that {\tt FUN m a b} permits representation polymorphism in both-   {\tt a} and {\tt b}, so that types like {\tt Int\# -> Int\#} can still be-   well-kinded.-  }--pseudoop "realWorld#"-   State# RealWorld-   { The token used in the implementation of the IO monad as a state monad.-     It does not pass any information at runtime.-     See also {\tt GHC.Magic.runRW\#}. }--pseudoop "void#"-   (# #)-   { This is an alias for the unboxed unit tuple constructor.-     In earlier versions of GHC, {\tt void\#} was a value-     of the primitive type {\tt Void\#}, which is now defined to be {\tt (\# \#)}.-   }-   with deprecated_msg = { Use an unboxed unit tuple instead }--primtype Proxy# a-   { The type constructor {\tt Proxy#} is used to bear witness to some-   type variable. It's used when you want to pass around proxy values-   for doing things like modelling type applications. A {\tt Proxy#}-   is not only unboxed, it also has a polymorphic kind, and has no-   runtime representation, being totally free. }--pseudoop "proxy#"-   Proxy# a-   { Witness for an unboxed {\tt Proxy#} value, which has no runtime-   representation. }--pseudoop   "seq"-   a -> b -> b-   { The value of {\tt seq a b} is bottom if {\tt a} is bottom, and-     otherwise equal to {\tt b}. In other words, it evaluates the first-     argument {\tt a} to weak head normal form (WHNF). {\tt seq} is usually-     introduced to improve performance by avoiding unneeded laziness.--     A note on evaluation order: the expression {\tt seq a b} does-     {\it not} guarantee that {\tt a} will be evaluated before {\tt b}.-     The only guarantee given by {\tt seq} is that the both {\tt a}-     and {\tt b} will be evaluated before {\tt seq} returns a value.-     In particular, this means that {\tt b} may be evaluated before-     {\tt a}. If you need to guarantee a specific order of evaluation,-     you must use the function {\tt pseq} from the "parallel" package. }-   with fixity = infixr 0-         -- This fixity is only the one picked up by Haddock. If you-         -- change this, do update 'ghcPrimIface' in 'GHC.Iface.Load'.--pseudoop   "unsafeCoerce#"-   a -> b-   { The function {\tt unsafeCoerce\#} allows you to side-step the typechecker entirely. That-        is, it allows you to coerce any type into any other type. If you use this function,-        you had better get it right, otherwise segmentation faults await. It is generally-        used when you want to write a program that you know is well-typed, but where Haskell's-        type system is not expressive enough to prove that it is well typed.--        The following uses of {\tt unsafeCoerce\#} are supposed to work (i.e. not lead to-        spurious compile-time or run-time crashes):--         * Casting any lifted type to {\tt Any}--         * Casting {\tt Any} back to the real type--         * Casting an unboxed type to another unboxed type of the same size.-           (Casting between floating-point and integral types does not work.-           See the {\tt GHC.Float} module for functions to do work.)--         * Casting between two types that have the same runtime representation.  One case is when-           the two types differ only in "phantom" type parameters, for example-           {\tt Ptr Int} to {\tt Ptr Float}, or {\tt [Int]} to {\tt [Float]} when the list is-           known to be empty.  Also, a {\tt newtype} of a type {\tt T} has the same representation-           at runtime as {\tt T}.--        Other uses of {\tt unsafeCoerce\#} are undefined.  In particular, you should not use-        {\tt unsafeCoerce\#} to cast a T to an algebraic data type D, unless T is also-        an algebraic data type.  For example, do not cast {\tt Int->Int} to {\tt Bool}, even if-        you later cast that {\tt Bool} back to {\tt Int->Int} before applying it.  The reasons-        have to do with GHC's internal representation details (for the cognoscenti, data values-        can be entered but function closures cannot).  If you want a safe type to cast things-        to, use {\tt Any}, which is not an algebraic data type.--        }-   with can_fail = True---- NB. It is tempting to think that casting a value to a type that it doesn't have is safe--- as long as you don't "do anything" with the value in its cast form, such as seq on it.  This--- isn't the case: the compiler can insert seqs itself, and if these happen at the wrong type,--- Bad Things Might Happen.  See bug #1616: in this case we cast a function of type (a,b) -> (a,b)--- to () -> () and back again.  The strictness analyser saw that the function was strict, but--- the wrapper had type () -> (), and hence the wrapper de-constructed the (), the worker re-constructed--- a new (), with the result that the code ended up with "case () of (a,b) -> ...".--primop  TraceEventOp "traceEvent#" GenPrimOp-   Addr# -> State# s -> State# s-   { Emits an event via the RTS tracing framework.  The contents-     of the event is the zero-terminated byte string passed as the first-     argument.  The event will be emitted either to the {\tt .eventlog} file,-     or to stderr, depending on the runtime RTS flags. }-   with-   has_side_effects = True-   out_of_line      = True--primop  TraceEventBinaryOp "traceBinaryEvent#" GenPrimOp-   Addr# -> Int# -> State# s -> State# s-   { Emits an event via the RTS tracing framework.  The contents-     of the event is the binary object passed as the first argument with-     the given length passed as the second argument. The event will be-     emitted to the {\tt .eventlog} file. }-   with-   has_side_effects = True-   out_of_line      = True--primop  TraceMarkerOp "traceMarker#" GenPrimOp-   Addr# -> State# s -> State# s-   { Emits a marker event via the RTS tracing framework.  The contents-     of the event is the zero-terminated byte string passed as the first-     argument.  The event will be emitted either to the {\tt .eventlog} file,-     or to stderr, depending on the runtime RTS flags. }-   with-   has_side_effects = True-   out_of_line      = True--primop  SetThreadAllocationCounter "setThreadAllocationCounter#" GenPrimOp-   Int64# -> State# RealWorld -> State# RealWorld-   { Sets the allocation counter for the current thread to the given value. }-   with-   has_side_effects = True-   out_of_line      = True--primtype StackSnapshot#-   { Haskell representation of a {\tt StgStack*} that was created (cloned)-     with a function in {\tt GHC.Stack.CloneStack}. Please check the-     documentation in this module for more detailed explanations. }---------------------------------------------------------------------------section "Safe coercions"---------------------------------------------------------------------------pseudoop   "coerce"-   Coercible a b => a -> b-   { The function {\tt coerce} allows you to safely convert between values of-     types that have the same representation with no run-time overhead. In the-     simplest case you can use it instead of a newtype constructor, to go from-     the newtype's concrete type to the abstract type. But it also works in-     more complicated settings, e.g. converting a list of newtypes to a list of-     concrete types.--     This function is representation-polymorphic, but the-     {\tt RuntimeRep} type argument is marked as {\tt Inferred}, meaning-     that it is not available for visible type application. This means-     the typechecker will accept {\tt coerce @Int @Age 42}.-   }---------------------------------------------------------------------------section "SIMD Vectors"-        {Operations on SIMD vectors.}---------------------------------------------------------------------------#define ALL_VECTOR_TYPES \-  [<Int8,Int8#,16>,<Int16,Int16#,8>,<Int32,Int32#,4>,<Int64,Int64#,2> \-  ,<Int8,Int8#,32>,<Int16,Int16#,16>,<Int32,Int32#,8>,<Int64,Int64#,4> \-  ,<Int8,Int8#,64>,<Int16,Int16#,32>,<Int32,Int32#,16>,<Int64,Int64#,8> \-  ,<Word8,Word#,16>,<Word16,Word#,8>,<Word32,Word32#,4>,<Word64,Word64#,2> \-  ,<Word8,Word#,32>,<Word16,Word#,16>,<Word32,Word32#,8>,<Word64,Word64#,4> \-  ,<Word8,Word#,64>,<Word16,Word#,32>,<Word32,Word32#,16>,<Word64,Word64#,8> \-  ,<Float,Float#,4>,<Double,Double#,2> \-  ,<Float,Float#,8>,<Double,Double#,4> \-  ,<Float,Float#,16>,<Double,Double#,8>]--#define SIGNED_VECTOR_TYPES \-  [<Int8,Int8#,16>,<Int16,Int16#,8>,<Int32,Int32#,4>,<Int64,Int64#,2> \-  ,<Int8,Int8#,32>,<Int16,Int16#,16>,<Int32,Int32#,8>,<Int64,Int64#,4> \-  ,<Int8,Int8#,64>,<Int16,Int16#,32>,<Int32,Int32#,16>,<Int64,Int64#,8> \-  ,<Float,Float#,4>,<Double,Double#,2> \-  ,<Float,Float#,8>,<Double,Double#,4> \-  ,<Float,Float#,16>,<Double,Double#,8>]--#define FLOAT_VECTOR_TYPES \-  [<Float,Float#,4>,<Double,Double#,2> \-  ,<Float,Float#,8>,<Double,Double#,4> \-  ,<Float,Float#,16>,<Double,Double#,8>]--#define INT_VECTOR_TYPES \-  [<Int8,Int8#,16>,<Int16,Int16#,8>,<Int32,Int32#,4>,<Int64,Int64#,2> \-  ,<Int8,Int8#,32>,<Int16,Int16#,16>,<Int32,Int32#,8>,<Int64,Int64#,4> \-  ,<Int8,Int8#,64>,<Int16,Int16#,32>,<Int32,Int32#,16>,<Int64,Int64#,8> \-  ,<Word8,Word#,16>,<Word16,Word#,8>,<Word32,Word32#,4>,<Word64,Word64#,2> \-  ,<Word8,Word#,32>,<Word16,Word#,16>,<Word32,Word32#,8>,<Word64,Word64#,4> \-  ,<Word8,Word#,64>,<Word16,Word#,32>,<Word32,Word32#,16>,<Word64,Word64#,8>]--primtype VECTOR-   with llvm_only = True-        vector = ALL_VECTOR_TYPES--primop VecBroadcastOp "broadcast#" GenPrimOp-   SCALAR -> VECTOR-   { Broadcast a scalar to all elements of a vector. }-   with llvm_only = True-        vector = ALL_VECTOR_TYPES--primop VecPackOp "pack#" GenPrimOp-   VECTUPLE -> VECTOR-   { Pack the elements of an unboxed tuple into a vector. }-   with llvm_only = True-        vector = ALL_VECTOR_TYPES--primop VecUnpackOp "unpack#" GenPrimOp-   VECTOR -> VECTUPLE-   { Unpack the elements of a vector into an unboxed tuple. #}-   with llvm_only = True-        vector = ALL_VECTOR_TYPES--primop VecInsertOp "insert#" GenPrimOp-   VECTOR -> SCALAR -> Int# -> VECTOR-   { Insert a scalar at the given position in a vector. }-   with can_fail = True-        llvm_only = True-        vector = ALL_VECTOR_TYPES--primop VecAddOp "plus#" GenPrimOp-   VECTOR -> VECTOR -> VECTOR-   { Add two vectors element-wise. }-   with commutable = True-        llvm_only = True-        vector = ALL_VECTOR_TYPES--primop VecSubOp "minus#" GenPrimOp-   VECTOR -> VECTOR -> VECTOR-   { Subtract two vectors element-wise. }-   with llvm_only = True-        vector = ALL_VECTOR_TYPES--primop VecMulOp "times#" GenPrimOp-   VECTOR -> VECTOR -> VECTOR-   { Multiply two vectors element-wise. }-   with commutable = True-        llvm_only = True-        vector = ALL_VECTOR_TYPES--primop VecDivOp "divide#" GenPrimOp-   VECTOR -> VECTOR -> VECTOR-   { Divide two vectors element-wise. }-   with can_fail = True-        llvm_only = True-        vector = FLOAT_VECTOR_TYPES--primop VecQuotOp "quot#" GenPrimOp-   VECTOR -> VECTOR -> VECTOR-   { Rounds towards zero element-wise. }-   with can_fail = True-        llvm_only = True-        vector = INT_VECTOR_TYPES--primop VecRemOp "rem#" GenPrimOp-   VECTOR -> VECTOR -> VECTOR-   { Satisfies \texttt{(quot\# x y) times\# y plus\# (rem\# x y) == x}. }-   with can_fail = True-        llvm_only = True-        vector = INT_VECTOR_TYPES--primop VecNegOp "negate#" GenPrimOp-   VECTOR -> VECTOR-   { Negate element-wise. }-   with llvm_only = True-        vector = SIGNED_VECTOR_TYPES--primop VecIndexByteArrayOp "indexArray#" GenPrimOp-   ByteArray# -> Int# -> VECTOR-   { Read a vector from specified index of immutable array. }-   with can_fail = True-        llvm_only = True-        vector = ALL_VECTOR_TYPES--primop VecReadByteArrayOp "readArray#" GenPrimOp-   MutableByteArray# s -> Int# -> State# s -> (# State# s, VECTOR #)-   { Read a vector from specified index of mutable array. }-   with has_side_effects = True-        can_fail = True-        llvm_only = True-        vector = ALL_VECTOR_TYPES--primop VecWriteByteArrayOp "writeArray#" GenPrimOp-   MutableByteArray# s -> Int# -> VECTOR -> State# s -> State# s-   { Write a vector to specified index of mutable array. }-   with has_side_effects = True-        can_fail = True-        llvm_only = True-        vector = ALL_VECTOR_TYPES--primop VecIndexOffAddrOp "indexOffAddr#" GenPrimOp-   Addr# -> Int# -> VECTOR-   { Reads vector; offset in bytes. }-   with can_fail = True-        llvm_only = True-        vector = ALL_VECTOR_TYPES--primop VecReadOffAddrOp "readOffAddr#" GenPrimOp-   Addr# -> Int# -> State# s -> (# State# s, VECTOR #)-   { Reads vector; offset in bytes. }-   with has_side_effects = True-        can_fail = True-        llvm_only = True-        vector = ALL_VECTOR_TYPES--primop VecWriteOffAddrOp "writeOffAddr#" GenPrimOp-   Addr# -> Int# -> VECTOR -> State# s -> State# s-   { Write vector; offset in bytes. }-   with has_side_effects = True-        can_fail = True-        llvm_only = True-        vector = ALL_VECTOR_TYPES---primop VecIndexScalarByteArrayOp "indexArrayAs#" GenPrimOp-   ByteArray# -> Int# -> VECTOR-   { Read a vector from specified index of immutable array of scalars; offset is in scalar elements. }-   with can_fail = True-        llvm_only = True-        vector = ALL_VECTOR_TYPES--primop VecReadScalarByteArrayOp "readArrayAs#" GenPrimOp-   MutableByteArray# s -> Int# -> State# s -> (# State# s, VECTOR #)-   { Read a vector from specified index of mutable array of scalars; offset is in scalar elements. }-   with has_side_effects = True-        can_fail = True-        llvm_only = True-        vector = ALL_VECTOR_TYPES--primop VecWriteScalarByteArrayOp "writeArrayAs#" GenPrimOp-   MutableByteArray# s -> Int# -> VECTOR -> State# s -> State# s-   { Write a vector to specified index of mutable array of scalars; offset is in scalar elements. }-   with has_side_effects = True-        can_fail = True-        llvm_only = True-        vector = ALL_VECTOR_TYPES--primop VecIndexScalarOffAddrOp "indexOffAddrAs#" GenPrimOp-   Addr# -> Int# -> VECTOR-   { Reads vector; offset in scalar elements. }-   with can_fail = True-        llvm_only = True-        vector = ALL_VECTOR_TYPES--primop VecReadScalarOffAddrOp "readOffAddrAs#" GenPrimOp-   Addr# -> Int# -> State# s -> (# State# s, VECTOR #)-   { Reads vector; offset in scalar elements. }-   with has_side_effects = True-        can_fail = True-        llvm_only = True-        vector = ALL_VECTOR_TYPES--primop VecWriteScalarOffAddrOp "writeOffAddrAs#" GenPrimOp-   Addr# -> Int# -> VECTOR -> State# s -> State# s-   { Write vector; offset in scalar elements. }-   with has_side_effects = True-        can_fail = True-        llvm_only = True-        vector = ALL_VECTOR_TYPES----------------------------------------------------------------------------section "Prefetch"-        {Prefetch operations: Note how every prefetch operation has a name-  with the pattern prefetch*N#, where N is either 0,1,2, or 3.--  This suffix number, N, is the "locality level" of the prefetch, following the-  convention in GCC and other compilers.-  Higher locality numbers correspond to the memory being loaded in more-  levels of the cpu cache, and being retained after initial use. The naming-  convention follows the naming convention of the prefetch intrinsic found-  in the GCC and Clang C compilers.--  On the LLVM backend, prefetch*N# uses the LLVM prefetch intrinsic-  with locality level N. The code generated by LLVM is target architecture-  dependent, but should agree with the GHC NCG on x86 systems.--  On the PPC native backend, prefetch*N is a No-Op.--  On the x86 NCG, N=0 will generate prefetchNTA,-  N=1 generates prefetcht2, N=2 generates prefetcht1, and-  N=3 generates prefetcht0.--  For streaming workloads, the prefetch*0 operations are recommended.-  For workloads which do many reads or writes to a memory location in a short period of time,-  prefetch*3 operations are recommended.--  For further reading about prefetch and associated systems performance optimization,-  the instruction set and optimization manuals by Intel and other CPU vendors are-  excellent starting place.---  The "Intel 64 and IA-32 Architectures Optimization Reference Manual" is-  especially a helpful read, even if your software is meant for other CPU-  architectures or vendor hardware. The manual can be found at-  http://www.intel.com/content/www/us/en/architecture-and-technology/64-ia-32-architectures-optimization-manual.html .--  The {\tt prefetch*} family of operations has the order of operations-  determined by passing around the {\tt State#} token.--  To get a "pure" version of these operations, use {\tt inlinePerformIO} which is quite safe in this context.--  It is important to note that while the prefetch operations will never change the-  answer to a pure computation, They CAN change the memory locations resident-  in a CPU cache and that may change the performance and timing characteristics-  of an application. The prefetch operations are marked has_side_effects=True-  to reflect that these operations have side effects with respect to the runtime-  performance characteristics of the resulting code. Additionally, if the prefetchValue-  operations did not have this attribute, GHC does a float out transformation that-  results in a let/app violation, at least with the current design.-  }---------------------------------------------------------------------------------- the Int# argument for prefetch is the byte offset on the byteArray or  Addr#------primop PrefetchByteArrayOp3 "prefetchByteArray3#" GenPrimOp-  ByteArray# -> Int# ->  State# s -> State# s-  with has_side_effects =  True--primop PrefetchMutableByteArrayOp3 "prefetchMutableByteArray3#" GenPrimOp-  MutableByteArray# s -> Int# -> State# s -> State# s-  with has_side_effects =  True--primop PrefetchAddrOp3 "prefetchAddr3#" GenPrimOp-  Addr# -> Int# -> State# s -> State# s-  with has_side_effects =  True--primop PrefetchValueOp3 "prefetchValue3#" GenPrimOp-   a -> State# s -> State# s-   with has_side_effects =  True-------primop PrefetchByteArrayOp2 "prefetchByteArray2#" GenPrimOp-  ByteArray# -> Int# ->  State# s -> State# s-  with has_side_effects =  True--primop PrefetchMutableByteArrayOp2 "prefetchMutableByteArray2#" GenPrimOp-  MutableByteArray# s -> Int# -> State# s -> State# s-  with has_side_effects =  True--primop PrefetchAddrOp2 "prefetchAddr2#" GenPrimOp-  Addr# -> Int# ->  State# s -> State# s-  with has_side_effects =  True--primop PrefetchValueOp2 "prefetchValue2#" GenPrimOp-   a ->  State# s -> State# s-   with has_side_effects =  True-------primop PrefetchByteArrayOp1 "prefetchByteArray1#" GenPrimOp-   ByteArray# -> Int# -> State# s -> State# s-   with has_side_effects =  True--primop PrefetchMutableByteArrayOp1 "prefetchMutableByteArray1#" GenPrimOp-  MutableByteArray# s -> Int# -> State# s -> State# s-  with has_side_effects =  True--primop PrefetchAddrOp1 "prefetchAddr1#" GenPrimOp-  Addr# -> Int# -> State# s -> State# s-  with has_side_effects =  True--primop PrefetchValueOp1 "prefetchValue1#" GenPrimOp-   a -> State# s -> State# s-   with has_side_effects =  True-------primop PrefetchByteArrayOp0 "prefetchByteArray0#" GenPrimOp-  ByteArray# -> Int# ->  State# s -> State# s-  with has_side_effects =  True--primop PrefetchMutableByteArrayOp0 "prefetchMutableByteArray0#" GenPrimOp-  MutableByteArray# s -> Int# -> State# s -> State# s-  with has_side_effects =  True--primop PrefetchAddrOp0 "prefetchAddr0#" GenPrimOp-  Addr# -> Int# -> State# s -> State# s-  with has_side_effects =  True--primop PrefetchValueOp0 "prefetchValue0#" GenPrimOp-   a -> State# s -> State# s-   with has_side_effects =  True+--      See Note [GHC.Prim Docs] in GHC.Builtin.Utils.+--+--   3. The module PrimopWrappers.hs, which wraps every call for GHCi;+--      see Note [Primop wrappers] in GHC.Builtin.Primops for details.+--+-- * This file does not list internal-only equality types+--   (GHC.Builtin.Types.Prim.unexposedPrimTyCons and coercionToken#+--   in GHC.Types.Id.Make) which are defined but not exported from GHC.Prim.+--   Every export of GHC.Prim should be in listed in this file.+--+-- * The primitive types should be listed in primTyCons in Builtin.Types.Prim+--   in addition to primops.txt.pp.+--   (This task should be delegated to genprimopcode in the future.)+--+--+--+-- Information on how PrimOps are implemented and the steps necessary to+-- add a new one can be found in the Commentary:+--+--  https://gitlab.haskell.org/ghc/ghc/wikis/commentary/prim-ops+--+-- This file is divided into named sections, each containing or more+-- primop entries. Section headers have the format:+--+--      section "section-name" {haddock-description}+--+-- This information is used solely when producing documentation; it is+-- otherwise ignored.  The haddock-description is optional.+--+-- The format of each primop entry is as follows:+--+--      primop internal-name "name-in-program-text" category type {haddock-description} attributes++-- The default attribute values which apply if you don't specify+-- other ones.  Attribute values can be True, False, or arbitrary+-- text between curly brackets.  This is a kludge to enable+-- processors of this file to easily get hold of simple info+-- (eg, out_of_line), whilst avoiding parsing complex expressions+-- needed for strictness info.+--+-- type refers to the general category of the primop. There are only two:+--+--  * Compare:   A comparison operation of the shape a -> a -> Int#+--  * GenPrimOp: Any other sort of primop+--++-- The vector attribute is rather special. It takes a list of 3-tuples, each of+-- which is of the form <ELEM_TYPE,SCALAR_TYPE,LENGTH>. ELEM_TYPE is the type of+-- the elements in the vector; LENGTH is the length of the vector; and+-- SCALAR_TYPE is the scalar type used to inject to/project from vector+-- element. Note that ELEM_TYPE and SCALAR_TYPE are not the same; for example,+-- to broadcast a scalar value to a vector whose elements are of type Int8, we+-- use an Int#.++-- When a primtype or primop has a vector attribute, it is instantiated at each+-- 3-tuple in the list of 3-tuples. That is, the vector attribute allows us to+-- define a family of types or primops. Vector support also adds three new+-- keywords: VECTOR, SCALAR, and VECTUPLE. These keywords are expanded to types+-- derived from the 3-tuple. For the 3-tuple <Int64#,Int64#,2>, VECTOR expands to+-- Int64X2#, SCALAR expands to Int64#, and VECTUPLE expands to (# Int64#, Int64# #).++defaults+   effect           = NoEffect -- See Note [Classifying primop effects] in GHC.Builtin.PrimOps+   can_fail_warning = WarnIfEffectIsCanFail+   out_of_line      = False   -- See Note [When do out-of-line primops go in primops.txt.pp]+   commutable       = False+   code_size        = { primOpCodeSizeDefault }+   work_free        = { primOpCodeSize _thisOp == 0 }+   cheap            = { primOpOkForSpeculation _thisOp }+   strictness       = { \ arity -> mkClosedDmdSig (replicate arity topDmd) topDiv }+   fixity           = Nothing+   vector           = []+   deprecated_msg   = {}      -- A non-empty message indicates deprecation+   div_like         = False   -- Second argument expected to be non zero - used for tests+   defined_bits     = Nothing -- The number of bits the operation is defined for (if not all bits)++-- Note [When do out-of-line primops go in primops.txt.pp]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- Out of line primops are those with a C-- implementation. But that+-- doesn't mean they *just* have an C-- implementation. As mentioned in+-- Note [Inlining out-of-line primops and heap checks], some out-of-line+-- primops also have additional internal implementations under certain+-- conditions. Now that `foreign import prim` exists, only those primops+-- which have both internal and external implementations ought to be+-- this file. The rest aren't really primops, since they don't need+-- bespoke compiler support but just a general way to interface with+-- C--. They are just foreign calls.+--+-- Unfortunately, for the time being most of the primops which should be+-- moved according to the previous paragraph can't yet. There are some+-- superficial restrictions in `foreign import prim` which must be fixed+-- first. Specifically, `foreign import prim` always requires:+--+--   - No polymorphism in type+--   - `strictness       = <default>`+--   - `effect           = ReadWriteEffect`+--+-- https://gitlab.haskell.org/ghc/ghc/issues/16929 tracks this issue,+-- and has a table of which external-only primops are blocked by which+-- of these. Hopefully those restrictions are relaxed so the rest of+-- those can be moved over.+--+-- 'module GHC.Prim.Ext is a temporarily "holding ground" for primops+-- that were formally in here, until they can be given a better home.+-- Likewise, their underlying C-- implementation need not live in the+-- RTS either. Best case (in my view), both the C-- and `foreign import+-- prim` can be moved to a small library tailured to the features being+-- implemented and dependencies of those features.++-- Note [Levity and representation polymorphic primops]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- In the types of primops in this module,+--+-- * The names `a,b,c,s` stand for type variables of kind Type+--+-- * The names `a_reppoly` and `b_reppoly` stand for representation-polymorphic+--   type variables. For example:+--      op :: a_reppoly -> b_reppoly -> Int+--   really means+--      op :: forall {rep1 :: RuntimeRep} {rep2 :: RuntimeRep}+--                   (a :: TYPE rep1) (b :: TYPE rep2).+--            a -> b -> Int+--+--   Note:+--     - `a_reppoly` and `b_reppoly` have independent `RuntimeRep`s, which+--       are *inferred* type variables.+--     - any use-site of a primop in which the kind of a type appearing in+--       negative position is `a_reppoly` and `b_reppoly`+--       must instantiate the representation to a concrete RuntimeRep.+--       See Note [Representation-polymorphism checking built-ins] in GHC.Tc.Gen.Head.+--     - `a_reppoly` and `b_reppoly` share textual names with `a` and `b` (respectively).+--       This means one shouldn't write a type involving both `a` and `a_reppoly`.+--+-- * The names `a_levpoly` and `b_levpoly` stand for levity-polymorphic+--   type variables, similar to `a_reppoly` and `b_reppoly`.+--   For example:+--      op :: a_levpoly -> b_levpoly -> Int+--   really means+--      op :: forall {l :: Levity} {k :: Levity}+--                   (a :: TYPE (BoxedRep l)) (b :: TYPE (BoxedRep k)).+--            a -> b -> Int+--  Note:+--     - `a_levpoly` and `b_levpoly` have independent levities `l` and `k` (respectively), and+--       these are inferred (not specified), as seen from the curly brackets.+--     - any use site of a primop in which `a_levpoly` or `b_levpoly` appear as+--       the kind of a type appearing in negative position in the type of the+--       primop, we require the Levity to be instantiated to a concrete Levity.+--     - `a_levpoly` and `b_levpoly` share textual names with `a` and `b` (respectively).+--       This means one shouldn't write a type involving both `a` and `a_levpoly`,+--       nor `a_levpoly` and `a_reppoly`, etc.++section "The word size story."+        {Haskell98 specifies that signed integers (type 'Int')+         must contain at least 30 bits. GHC always implements+         'Int' using the primitive type 'Int#', whose size equals+         the @MachDeps.h@ constant @WORD\_SIZE\_IN\_BITS@.+         This is normally set based on the RTS @ghcautoconf.h@ parameter+         @SIZEOF\_HSWORD@, i.e., 32 bits on 32-bit machines, 64+         bits on 64-bit machines.++         GHC also implements a primitive unsigned integer type+         'Word#' which always has the same number of bits as 'Int#'.++         In addition, GHC supports families of explicit-sized integers+         and words at 8, 16, 32, and 64 bits, with the usual+         arithmetic operations, comparisons, and a range of+         conversions.++         Finally, there are strongly deprecated primops for coercing+         between 'Addr#', the primitive type of machine+         addresses, and 'Int#'.  These are pretty bogus anyway,+         but will work on existing 32-bit and 64-bit GHC targets; they+         are completely bogus when tag bits are used in 'Int#',+         so are not available in this case.}++------------------------------------------------------------------------+section "Char#"+        {Operations on 31-bit characters.}+------------------------------------------------------------------------++primtype Char#++primop   CharGtOp  "gtChar#"   Compare   Char# -> Char# -> Int#+primop   CharGeOp  "geChar#"   Compare   Char# -> Char# -> Int#++primop   CharEqOp  "eqChar#"   Compare+   Char# -> Char# -> Int#+   with commutable = True++primop   CharNeOp  "neChar#"   Compare+   Char# -> Char# -> Int#+   with commutable = True++primop   CharLtOp  "ltChar#"   Compare   Char# -> Char# -> Int#+primop   CharLeOp  "leChar#"   Compare   Char# -> Char# -> Int#++primop   OrdOp   "ord#"  GenPrimOp   Char# -> Int#+   with code_size = 0++------------------------------------------------------------------------+section "Int8#"+        {Operations on 8-bit integers.}+------------------------------------------------------------------------++primtype Int8#++primop Int8ToIntOp "int8ToInt#" GenPrimOp Int8# -> Int#+primop IntToInt8Op "intToInt8#" GenPrimOp Int# -> Int8#++primop Int8NegOp "negateInt8#" GenPrimOp Int8# -> Int8#++primop Int8AddOp "plusInt8#" GenPrimOp Int8# -> Int8# -> Int8#+  with+    commutable = True++primop Int8SubOp "subInt8#" GenPrimOp Int8# -> Int8# -> Int8#++primop Int8MulOp "timesInt8#" GenPrimOp Int8# -> Int8# -> Int8#+  with+    commutable = True++primop Int8QuotOp "quotInt8#" GenPrimOp Int8# -> Int8# -> Int8#+  with+    effect = CanFail+    div_like = True++primop Int8RemOp "remInt8#" GenPrimOp Int8# -> Int8# -> Int8#+  with+    effect = CanFail+    div_like = True+++primop Int8QuotRemOp "quotRemInt8#" GenPrimOp Int8# -> Int8# -> (# Int8#, Int8# #)+  with+    effect = CanFail+    div_like = True++primop Int8SllOp "uncheckedShiftLInt8#"  GenPrimOp Int8# -> Int# -> Int8#+primop Int8SraOp "uncheckedShiftRAInt8#" GenPrimOp Int8# -> Int# -> Int8#+primop Int8SrlOp "uncheckedShiftRLInt8#" GenPrimOp Int8# -> Int# -> Int8#++primop Int8ToWord8Op "int8ToWord8#" GenPrimOp Int8# -> Word8#+   with code_size = 0++primop Int8EqOp "eqInt8#" Compare Int8# -> Int8# -> Int#+primop Int8GeOp "geInt8#" Compare Int8# -> Int8# -> Int#+primop Int8GtOp "gtInt8#" Compare Int8# -> Int8# -> Int#+primop Int8LeOp "leInt8#" Compare Int8# -> Int8# -> Int#+primop Int8LtOp "ltInt8#" Compare Int8# -> Int8# -> Int#+primop Int8NeOp "neInt8#" Compare Int8# -> Int8# -> Int#++------------------------------------------------------------------------+section "Word8#"+        {Operations on 8-bit unsigned words.}+------------------------------------------------------------------------++primtype Word8#++primop Word8ToWordOp "word8ToWord#" GenPrimOp Word8# -> Word#+primop WordToWord8Op "wordToWord8#" GenPrimOp Word# -> Word8#++primop Word8AddOp "plusWord8#" GenPrimOp Word8# -> Word8# -> Word8#+  with+    commutable = True++primop Word8SubOp "subWord8#" GenPrimOp Word8# -> Word8# -> Word8#++primop Word8MulOp "timesWord8#" GenPrimOp Word8# -> Word8# -> Word8#+  with+    commutable = True++primop Word8QuotOp "quotWord8#" GenPrimOp Word8# -> Word8# -> Word8#+  with+    effect = CanFail+    div_like = True++primop Word8RemOp "remWord8#" GenPrimOp Word8# -> Word8# -> Word8#+  with+    effect = CanFail+    div_like = True++primop Word8QuotRemOp "quotRemWord8#" GenPrimOp Word8# -> Word8# -> (# Word8#, Word8# #)+  with+    effect = CanFail+    div_like = True++primop Word8AndOp "andWord8#" GenPrimOp Word8# -> Word8# -> Word8#+   with commutable = True++primop Word8OrOp "orWord8#" GenPrimOp Word8# -> Word8# -> Word8#+   with commutable = True++primop Word8XorOp "xorWord8#" GenPrimOp Word8# -> Word8# -> Word8#+   with commutable = True++primop Word8NotOp "notWord8#" GenPrimOp Word8# -> Word8#++primop Word8SllOp "uncheckedShiftLWord8#"  GenPrimOp Word8# -> Int# -> Word8#+primop Word8SrlOp "uncheckedShiftRLWord8#" GenPrimOp Word8# -> Int# -> Word8#++primop Word8ToInt8Op "word8ToInt8#" GenPrimOp Word8# -> Int8#+   with code_size = 0++primop Word8EqOp "eqWord8#" Compare Word8# -> Word8# -> Int#+primop Word8GeOp "geWord8#" Compare Word8# -> Word8# -> Int#+primop Word8GtOp "gtWord8#" Compare Word8# -> Word8# -> Int#+primop Word8LeOp "leWord8#" Compare Word8# -> Word8# -> Int#+primop Word8LtOp "ltWord8#" Compare Word8# -> Word8# -> Int#+primop Word8NeOp "neWord8#" Compare Word8# -> Word8# -> Int#++------------------------------------------------------------------------+section "Int16#"+        {Operations on 16-bit integers.}+------------------------------------------------------------------------++primtype Int16#++primop Int16ToIntOp "int16ToInt#" GenPrimOp Int16# -> Int#+primop IntToInt16Op "intToInt16#" GenPrimOp Int# -> Int16#++primop Int16NegOp "negateInt16#" GenPrimOp Int16# -> Int16#++primop Int16AddOp "plusInt16#" GenPrimOp Int16# -> Int16# -> Int16#+  with+    commutable = True++primop Int16SubOp "subInt16#" GenPrimOp Int16# -> Int16# -> Int16#++primop Int16MulOp "timesInt16#" GenPrimOp Int16# -> Int16# -> Int16#+  with+    commutable = True++primop Int16QuotOp "quotInt16#" GenPrimOp Int16# -> Int16# -> Int16#+  with+    effect = CanFail+    div_like = True++primop Int16RemOp "remInt16#" GenPrimOp Int16# -> Int16# -> Int16#+  with+    effect = CanFail+    div_like = True++primop Int16QuotRemOp "quotRemInt16#" GenPrimOp Int16# -> Int16# -> (# Int16#, Int16# #)+  with+    effect = CanFail+    div_like = True++primop Int16SllOp "uncheckedShiftLInt16#"  GenPrimOp Int16# -> Int# -> Int16#+primop Int16SraOp "uncheckedShiftRAInt16#" GenPrimOp Int16# -> Int# -> Int16#+primop Int16SrlOp "uncheckedShiftRLInt16#" GenPrimOp Int16# -> Int# -> Int16#++primop Int16ToWord16Op "int16ToWord16#" GenPrimOp Int16# -> Word16#+   with code_size = 0++primop Int16EqOp "eqInt16#" Compare Int16# -> Int16# -> Int#+primop Int16GeOp "geInt16#" Compare Int16# -> Int16# -> Int#+primop Int16GtOp "gtInt16#" Compare Int16# -> Int16# -> Int#+primop Int16LeOp "leInt16#" Compare Int16# -> Int16# -> Int#+primop Int16LtOp "ltInt16#" Compare Int16# -> Int16# -> Int#+primop Int16NeOp "neInt16#" Compare Int16# -> Int16# -> Int#++------------------------------------------------------------------------+section "Word16#"+        {Operations on 16-bit unsigned words.}+------------------------------------------------------------------------++primtype Word16#++primop Word16ToWordOp "word16ToWord#" GenPrimOp Word16# -> Word#+primop WordToWord16Op "wordToWord16#" GenPrimOp Word# -> Word16#++primop Word16AddOp "plusWord16#" GenPrimOp Word16# -> Word16# -> Word16#+  with+    commutable = True++primop Word16SubOp "subWord16#" GenPrimOp Word16# -> Word16# -> Word16#++primop Word16MulOp "timesWord16#" GenPrimOp Word16# -> Word16# -> Word16#+  with+    commutable = True++primop Word16QuotOp "quotWord16#" GenPrimOp Word16# -> Word16# -> Word16#+  with+    effect = CanFail+    div_like = True++primop Word16RemOp "remWord16#" GenPrimOp Word16# -> Word16# -> Word16#+  with+    effect = CanFail+    div_like = True++primop Word16QuotRemOp "quotRemWord16#" GenPrimOp Word16# -> Word16# -> (# Word16#, Word16# #)+  with+    effect = CanFail+    div_like = True++primop Word16AndOp "andWord16#" GenPrimOp Word16# -> Word16# -> Word16#+   with commutable = True++primop Word16OrOp "orWord16#" GenPrimOp Word16# -> Word16# -> Word16#+   with commutable = True++primop Word16XorOp "xorWord16#" GenPrimOp Word16# -> Word16# -> Word16#+   with commutable = True++primop Word16NotOp "notWord16#" GenPrimOp Word16# -> Word16#++primop Word16SllOp "uncheckedShiftLWord16#"  GenPrimOp Word16# -> Int# -> Word16#+primop Word16SrlOp "uncheckedShiftRLWord16#" GenPrimOp Word16# -> Int# -> Word16#++primop Word16ToInt16Op "word16ToInt16#" GenPrimOp Word16# -> Int16#+   with code_size = 0++primop Word16EqOp "eqWord16#" Compare Word16# -> Word16# -> Int#+primop Word16GeOp "geWord16#" Compare Word16# -> Word16# -> Int#+primop Word16GtOp "gtWord16#" Compare Word16# -> Word16# -> Int#+primop Word16LeOp "leWord16#" Compare Word16# -> Word16# -> Int#+primop Word16LtOp "ltWord16#" Compare Word16# -> Word16# -> Int#+primop Word16NeOp "neWord16#" Compare Word16# -> Word16# -> Int#++------------------------------------------------------------------------+section "Int32#"+        {Operations on 32-bit integers.}+------------------------------------------------------------------------++primtype Int32#++primop Int32ToIntOp "int32ToInt#" GenPrimOp Int32# -> Int#+primop IntToInt32Op "intToInt32#" GenPrimOp Int# -> Int32#++primop Int32NegOp "negateInt32#" GenPrimOp Int32# -> Int32#++primop Int32AddOp "plusInt32#" GenPrimOp Int32# -> Int32# -> Int32#+  with+    commutable = True++primop Int32SubOp "subInt32#" GenPrimOp Int32# -> Int32# -> Int32#++primop Int32MulOp "timesInt32#" GenPrimOp Int32# -> Int32# -> Int32#+  with+    commutable = True++primop Int32QuotOp "quotInt32#" GenPrimOp Int32# -> Int32# -> Int32#+  with+    effect = CanFail+    div_like = True++primop Int32RemOp "remInt32#" GenPrimOp Int32# -> Int32# -> Int32#+  with+    effect = CanFail+    div_like = True++primop Int32QuotRemOp "quotRemInt32#" GenPrimOp Int32# -> Int32# -> (# Int32#, Int32# #)+  with+    effect = CanFail+    div_like = True++primop Int32SllOp "uncheckedShiftLInt32#"  GenPrimOp Int32# -> Int# -> Int32#+primop Int32SraOp "uncheckedShiftRAInt32#" GenPrimOp Int32# -> Int# -> Int32#+primop Int32SrlOp "uncheckedShiftRLInt32#" GenPrimOp Int32# -> Int# -> Int32#++primop Int32ToWord32Op "int32ToWord32#" GenPrimOp Int32# -> Word32#+   with code_size = 0++primop Int32EqOp "eqInt32#" Compare Int32# -> Int32# -> Int#+primop Int32GeOp "geInt32#" Compare Int32# -> Int32# -> Int#+primop Int32GtOp "gtInt32#" Compare Int32# -> Int32# -> Int#+primop Int32LeOp "leInt32#" Compare Int32# -> Int32# -> Int#+primop Int32LtOp "ltInt32#" Compare Int32# -> Int32# -> Int#+primop Int32NeOp "neInt32#" Compare Int32# -> Int32# -> Int#++------------------------------------------------------------------------+section "Word32#"+        {Operations on 32-bit unsigned words.}+------------------------------------------------------------------------++primtype Word32#++primop Word32ToWordOp "word32ToWord#" GenPrimOp Word32# -> Word#+primop WordToWord32Op "wordToWord32#" GenPrimOp Word# -> Word32#++primop Word32AddOp "plusWord32#" GenPrimOp Word32# -> Word32# -> Word32#+  with+    commutable = True++primop Word32SubOp "subWord32#" GenPrimOp Word32# -> Word32# -> Word32#++primop Word32MulOp "timesWord32#" GenPrimOp Word32# -> Word32# -> Word32#+  with+    commutable = True++primop Word32QuotOp "quotWord32#" GenPrimOp Word32# -> Word32# -> Word32#+  with+    effect = CanFail+    div_like = True++primop Word32RemOp "remWord32#" GenPrimOp Word32# -> Word32# -> Word32#+  with+    effect = CanFail+    div_like = True++primop Word32QuotRemOp "quotRemWord32#" GenPrimOp Word32# -> Word32# -> (# Word32#, Word32# #)+  with+    effect = CanFail+    div_like = True++primop Word32AndOp "andWord32#" GenPrimOp Word32# -> Word32# -> Word32#+   with commutable = True++primop Word32OrOp "orWord32#" GenPrimOp Word32# -> Word32# -> Word32#+   with commutable = True++primop Word32XorOp "xorWord32#" GenPrimOp Word32# -> Word32# -> Word32#+   with commutable = True++primop Word32NotOp "notWord32#" GenPrimOp Word32# -> Word32#++primop Word32SllOp "uncheckedShiftLWord32#"  GenPrimOp Word32# -> Int# -> Word32#+primop Word32SrlOp "uncheckedShiftRLWord32#" GenPrimOp Word32# -> Int# -> Word32#++primop Word32ToInt32Op "word32ToInt32#" GenPrimOp Word32# -> Int32#+   with code_size = 0++primop Word32EqOp "eqWord32#" Compare Word32# -> Word32# -> Int#+primop Word32GeOp "geWord32#" Compare Word32# -> Word32# -> Int#+primop Word32GtOp "gtWord32#" Compare Word32# -> Word32# -> Int#+primop Word32LeOp "leWord32#" Compare Word32# -> Word32# -> Int#+primop Word32LtOp "ltWord32#" Compare Word32# -> Word32# -> Int#+primop Word32NeOp "neWord32#" Compare Word32# -> Word32# -> Int#++------------------------------------------------------------------------+section "Int64#"+        {Operations on 64-bit signed words.}+------------------------------------------------------------------------++primtype Int64#++primop Int64ToIntOp "int64ToInt#" GenPrimOp Int64# -> Int#+primop IntToInt64Op "intToInt64#" GenPrimOp Int# -> Int64#++primop Int64NegOp "negateInt64#" GenPrimOp Int64# -> Int64#++primop Int64AddOp "plusInt64#" GenPrimOp Int64# -> Int64# -> Int64#+  with+    commutable = True++primop Int64SubOp "subInt64#" GenPrimOp Int64# -> Int64# -> Int64#++primop Int64MulOp "timesInt64#" GenPrimOp Int64# -> Int64# -> Int64#+  with+    commutable = True++primop Int64QuotOp "quotInt64#" GenPrimOp Int64# -> Int64# -> Int64#+  with+    effect = CanFail+    div_like = True++primop Int64RemOp "remInt64#" GenPrimOp Int64# -> Int64# -> Int64#+  with+    effect = CanFail+    div_like = True++primop Int64SllOp "uncheckedIShiftL64#"  GenPrimOp Int64# -> Int# -> Int64#+primop Int64SraOp "uncheckedIShiftRA64#" GenPrimOp Int64# -> Int# -> Int64#+primop Int64SrlOp "uncheckedIShiftRL64#" GenPrimOp Int64# -> Int# -> Int64#++primop Int64ToWord64Op "int64ToWord64#" GenPrimOp Int64# -> Word64#+   with code_size = 0++primop Int64EqOp "eqInt64#" Compare Int64# -> Int64# -> Int#+primop Int64GeOp "geInt64#" Compare Int64# -> Int64# -> Int#+primop Int64GtOp "gtInt64#" Compare Int64# -> Int64# -> Int#+primop Int64LeOp "leInt64#" Compare Int64# -> Int64# -> Int#+primop Int64LtOp "ltInt64#" Compare Int64# -> Int64# -> Int#+primop Int64NeOp "neInt64#" Compare Int64# -> Int64# -> Int#++------------------------------------------------------------------------+section "Word64#"+        {Operations on 64-bit unsigned words.}+------------------------------------------------------------------------++primtype Word64#++primop Word64ToWordOp "word64ToWord#" GenPrimOp Word64# -> Word#+primop WordToWord64Op "wordToWord64#" GenPrimOp Word# -> Word64#++primop Word64AddOp "plusWord64#" GenPrimOp Word64# -> Word64# -> Word64#+  with+    commutable = True++primop Word64SubOp "subWord64#" GenPrimOp Word64# -> Word64# -> Word64#++primop Word64MulOp "timesWord64#" GenPrimOp Word64# -> Word64# -> Word64#+  with+    commutable = True++primop Word64QuotOp "quotWord64#" GenPrimOp Word64# -> Word64# -> Word64#+  with+    effect = CanFail+    div_like = True++primop Word64RemOp "remWord64#" GenPrimOp Word64# -> Word64# -> Word64#+  with+    effect = CanFail+    div_like = True++primop Word64AndOp "and64#" GenPrimOp Word64# -> Word64# -> Word64#+   with commutable = True++primop Word64OrOp "or64#" GenPrimOp Word64# -> Word64# -> Word64#+   with commutable = True++primop Word64XorOp "xor64#" GenPrimOp Word64# -> Word64# -> Word64#+   with commutable = True++primop Word64NotOp "not64#" GenPrimOp Word64# -> Word64#++primop Word64SllOp "uncheckedShiftL64#"  GenPrimOp Word64# -> Int# -> Word64#+primop Word64SrlOp "uncheckedShiftRL64#" GenPrimOp Word64# -> Int# -> Word64#++primop Word64ToInt64Op "word64ToInt64#" GenPrimOp Word64# -> Int64#+   with code_size = 0++primop Word64EqOp "eqWord64#" Compare Word64# -> Word64# -> Int#+primop Word64GeOp "geWord64#" Compare Word64# -> Word64# -> Int#+primop Word64GtOp "gtWord64#" Compare Word64# -> Word64# -> Int#+primop Word64LeOp "leWord64#" Compare Word64# -> Word64# -> Int#+primop Word64LtOp "ltWord64#" Compare Word64# -> Word64# -> Int#+primop Word64NeOp "neWord64#" Compare Word64# -> Word64# -> Int#++------------------------------------------------------------------------+section "Int#"+        {Operations on native-size integers (32+ bits).}+------------------------------------------------------------------------++primtype Int#++primop   IntAddOp    "+#"    GenPrimOp+   Int# -> Int# -> Int#+   with commutable = True+        fixity = infixl 6++primop   IntSubOp    "-#"    GenPrimOp   Int# -> Int# -> Int#+   with fixity = infixl 6++primop   IntMulOp    "*#"+   GenPrimOp   Int# -> Int# -> Int#+   {Low word of signed integer multiply.}+   with commutable = True+        fixity = infixl 7++primop   IntMul2Op    "timesInt2#" GenPrimOp+   Int# -> Int# -> (# Int#, Int#, Int# #)+   {Return a triple (isHighNeeded,high,low) where high and low are respectively+   the high and low bits of the double-word result. isHighNeeded is a cheap way+   to test if the high word is a sign-extension of the low word (isHighNeeded =+   0#) or not (isHighNeeded = 1#).}++primop   IntMulMayOfloOp  "mulIntMayOflo#"+   GenPrimOp   Int# -> Int# -> Int#+   {Return non-zero if there is any possibility that the upper word of a+    signed integer multiply might contain useful information.  Return+    zero only if you are completely sure that no overflow can occur.+    On a 32-bit platform, the recommended implementation is to do a+    32 x 32 -> 64 signed multiply, and subtract result[63:32] from+    (result[31] >>signed 31).  If this is zero, meaning that the+    upper word is merely a sign extension of the lower one, no+    overflow can occur.++    On a 64-bit platform it is not always possible to+    acquire the top 64 bits of the result.  Therefore, a recommended+    implementation is to take the absolute value of both operands, and+    return 0 iff bits[63:31] of them are zero, since that means that their+    magnitudes fit within 31 bits, so the magnitude of the product must fit+    into 62 bits.++    If in doubt, return non-zero, but do make an effort to create the+    correct answer for small args, since otherwise the performance of+    @(*) :: Integer -> Integer -> Integer@ will be poor.+   }+   with commutable = True++primop   IntQuotOp    "quotInt#"    GenPrimOp+   Int# -> Int# -> Int#+   {Rounds towards zero. The behavior is undefined if the second argument is+    zero.+   }+   with effect = CanFail+        div_like = True++primop   IntRemOp    "remInt#"    GenPrimOp+   Int# -> Int# -> Int#+   {Satisfies @('quotInt#' x y) '*#' y '+#' ('remInt#' x y) == x@. The+    behavior is undefined if the second argument is zero.+   }+   with effect = CanFail+        div_like = True++primop   IntQuotRemOp "quotRemInt#"    GenPrimOp+   Int# -> Int# -> (# Int#, Int# #)+   {Rounds towards zero.}+   with effect = CanFail+        div_like = True++primop   IntAndOp   "andI#"   GenPrimOp    Int# -> Int# -> Int#+   {Bitwise "and".}+   with commutable = True++primop   IntOrOp   "orI#"     GenPrimOp    Int# -> Int# -> Int#+   {Bitwise "or".}+   with commutable = True++primop   IntXorOp   "xorI#"   GenPrimOp    Int# -> Int# -> Int#+   {Bitwise "xor".}+   with commutable = True++primop   IntNotOp   "notI#"   GenPrimOp   Int# -> Int#+   {Bitwise "not", also known as the binary complement.}++primop   IntNegOp    "negateInt#"    GenPrimOp   Int# -> Int#+   {Unary negation.+    Since the negative 'Int#' range extends one further than the+    positive range, 'negateInt#' of the most negative number is an+    identity operation. This way, 'negateInt#' is always its own inverse.}++primop   IntAddCOp   "addIntC#"    GenPrimOp   Int# -> Int# -> (# Int#, Int# #)+         {Add signed integers reporting overflow.+          First member of result is the sum truncated to an 'Int#';+          second member is zero if the true sum fits in an 'Int#',+          nonzero if overflow occurred (the sum is either too large+          or too small to fit in an 'Int#').}+   with code_size = 2+        commutable = True++primop   IntSubCOp   "subIntC#"    GenPrimOp   Int# -> Int# -> (# Int#, Int# #)+         {Subtract signed integers reporting overflow.+          First member of result is the difference truncated to an 'Int#';+          second member is zero if the true difference fits in an 'Int#',+          nonzero if overflow occurred (the difference is either too large+          or too small to fit in an 'Int#').}+   with code_size = 2++primop   IntGtOp  ">#"   Compare   Int# -> Int# -> Int#+   with fixity = infix 4++primop   IntGeOp  ">=#"   Compare   Int# -> Int# -> Int#+   with fixity = infix 4++primop   IntEqOp  "==#"   Compare+   Int# -> Int# -> Int#+   with commutable = True+        fixity = infix 4++primop   IntNeOp  "/=#"   Compare+   Int# -> Int# -> Int#+   with commutable = True+        fixity = infix 4++primop   IntLtOp  "<#"   Compare   Int# -> Int# -> Int#+   with fixity = infix 4++primop   IntLeOp  "<=#"   Compare   Int# -> Int# -> Int#+   with fixity = infix 4++primop   ChrOp   "chr#"   GenPrimOp   Int# -> Char#+   with code_size = 0++primop   IntToWordOp "int2Word#" GenPrimOp Int# -> Word#+   with code_size = 0++primop   IntToFloatOp   "int2Float#"      GenPrimOp  Int# -> Float#+   {Convert an 'Int#' to the corresponding 'Float#' with the same+    integral value (up to truncation due to floating-point precision). e.g.+    @'int2Float#' 1# == 1.0#@}+primop   IntToDoubleOp   "int2Double#"          GenPrimOp  Int# -> Double#+   {Convert an 'Int#' to the corresponding 'Double#' with the same+    integral value (up to truncation due to floating-point precision). e.g.+    @'int2Double#' 1# == 1.0##@}++primop   WordToFloatOp   "word2Float#"      GenPrimOp  Word# -> Float#+   {Convert an 'Word#' to the corresponding 'Float#' with the same+    integral value (up to truncation due to floating-point precision). e.g.+    @'word2Float#' 1## == 1.0#@}+primop   WordToDoubleOp   "word2Double#"          GenPrimOp  Word# -> Double#+   {Convert an 'Word#' to the corresponding 'Double#' with the same+    integral value (up to truncation due to floating-point precision). e.g.+    @'word2Double#' 1## == 1.0##@}++primop   IntSllOp   "uncheckedIShiftL#" GenPrimOp  Int# -> Int# -> Int#+         {Shift left.  Result undefined if shift amount is not+          in the range 0 to word size - 1 inclusive.}+primop   IntSraOp   "uncheckedIShiftRA#" GenPrimOp Int# -> Int# -> Int#+         {Shift right arithmetic.  Result undefined if shift amount is not+          in the range 0 to word size - 1 inclusive.}+primop   IntSrlOp   "uncheckedIShiftRL#" GenPrimOp Int# -> Int# -> Int#+         {Shift right logical.  Result undefined if shift amount is not+          in the range 0 to word size - 1 inclusive.}++------------------------------------------------------------------------+section "Word#"+        {Operations on native-sized unsigned words (32+ bits).}+------------------------------------------------------------------------++primtype Word#++primop   WordAddOp   "plusWord#"   GenPrimOp   Word# -> Word# -> Word#+   with commutable = True++primop   WordAddCOp   "addWordC#"   GenPrimOp   Word# -> Word# -> (# Word#, Int# #)+         {Add unsigned integers reporting overflow.+          The first element of the pair is the result.  The second element is+          the carry flag, which is nonzero on overflow. See also 'plusWord2#'.}+   with code_size = 2+        commutable = True++primop   WordSubCOp   "subWordC#"   GenPrimOp   Word# -> Word# -> (# Word#, Int# #)+         {Subtract unsigned integers reporting overflow.+          The first element of the pair is the result.  The second element is+          the carry flag, which is nonzero on overflow.}+   with code_size = 2++primop   WordAdd2Op   "plusWord2#"   GenPrimOp   Word# -> Word# -> (# Word#, Word# #)+         {Add unsigned integers, with the high part (carry) in the first+          component of the returned pair and the low part in the second+          component of the pair. See also 'addWordC#'.}+   with code_size = 2+        commutable = True++primop   WordSubOp   "minusWord#"   GenPrimOp   Word# -> Word# -> Word#++primop   WordMulOp   "timesWord#"   GenPrimOp   Word# -> Word# -> Word#+   with commutable = True++-- Returns (# high, low #)+primop   WordMul2Op  "timesWord2#"   GenPrimOp+   Word# -> Word# -> (# Word#, Word# #)+   with commutable = True++primop   WordQuotOp   "quotWord#"   GenPrimOp   Word# -> Word# -> Word#+   with effect = CanFail+        div_like = True++primop   WordRemOp   "remWord#"   GenPrimOp   Word# -> Word# -> Word#+   with effect = CanFail+        div_like = True++primop   WordQuotRemOp "quotRemWord#" GenPrimOp+   Word# -> Word# -> (# Word#, Word# #)+   with effect = CanFail+        div_like = True++primop   WordQuotRem2Op "quotRemWord2#" GenPrimOp+   Word# -> Word# -> Word# -> (# Word#, Word# #)+         { Takes high word of dividend, then low word of dividend, then divisor.+           Requires that high word < divisor.}+   with effect = CanFail+        div_like = True++primop   WordAndOp   "and#"   GenPrimOp   Word# -> Word# -> Word#+   with commutable = True++primop   WordOrOp   "or#"   GenPrimOp   Word# -> Word# -> Word#+   with commutable = True++primop   WordXorOp   "xor#"   GenPrimOp   Word# -> Word# -> Word#+   with commutable = True++primop   WordNotOp   "not#"   GenPrimOp   Word# -> Word#++primop   WordSllOp   "uncheckedShiftL#"   GenPrimOp   Word# -> Int# -> Word#+         {Shift left logical.   Result undefined if shift amount is not+          in the range 0 to word size - 1 inclusive.}+primop   WordSrlOp   "uncheckedShiftRL#"   GenPrimOp   Word# -> Int# -> Word#+         {Shift right logical.   Result undefined if shift  amount is not+          in the range 0 to word size - 1 inclusive.}++primop   WordToIntOp   "word2Int#"   GenPrimOp   Word# -> Int#+   with code_size = 0++primop   WordGtOp   "gtWord#"   Compare   Word# -> Word# -> Int#+primop   WordGeOp   "geWord#"   Compare   Word# -> Word# -> Int#+primop   WordEqOp   "eqWord#"   Compare   Word# -> Word# -> Int#+primop   WordNeOp   "neWord#"   Compare   Word# -> Word# -> Int#+primop   WordLtOp   "ltWord#"   Compare   Word# -> Word# -> Int#+primop   WordLeOp   "leWord#"   Compare   Word# -> Word# -> Int#++primop   PopCnt8Op   "popCnt8#"   GenPrimOp   Word# -> Word#+    {Count the number of set bits in the lower 8 bits of a word.}+primop   PopCnt16Op   "popCnt16#"   GenPrimOp   Word# -> Word#+    {Count the number of set bits in the lower 16 bits of a word.}+primop   PopCnt32Op   "popCnt32#"   GenPrimOp   Word# -> Word#+    {Count the number of set bits in the lower 32 bits of a word.}+primop   PopCnt64Op   "popCnt64#"   GenPrimOp   Word64# -> Word#+    {Count the number of set bits in a 64-bit word.}+primop   PopCntOp   "popCnt#"   GenPrimOp   Word# -> Word#+    {Count the number of set bits in a word.}++primop   Pdep8Op   "pdep8#"   GenPrimOp   Word# -> Word# -> Word#+    {Deposit bits to lower 8 bits of a word at locations specified by a mask.++    @since 0.5.2.0}+primop   Pdep16Op   "pdep16#"   GenPrimOp   Word# -> Word# -> Word#+    {Deposit bits to lower 16 bits of a word at locations specified by a mask.++    @since 0.5.2.0}+primop   Pdep32Op   "pdep32#"   GenPrimOp   Word# -> Word# -> Word#+    {Deposit bits to lower 32 bits of a word at locations specified by a mask.++    @since 0.5.2.0}+primop   Pdep64Op   "pdep64#"   GenPrimOp   Word64# -> Word64# -> Word64#+    {Deposit bits to a word at locations specified by a mask.++    @since 0.5.2.0}+primop   PdepOp   "pdep#"   GenPrimOp   Word# -> Word# -> Word#+    {Deposit bits to a word at locations specified by a mask, aka+    [parallel bit deposit](https://en.wikipedia.org/wiki/Bit_Manipulation_Instruction_Sets#Parallel_bit_deposit_and_extract).++    Software emulation:++    > pdep :: Word -> Word -> Word+    > pdep src mask = go 0 src mask+    >   where+    >     go :: Word -> Word -> Word -> Word+    >     go result _ 0 = result+    >     go result src mask = go newResult newSrc newMask+    >       where+    >         maskCtz   = countTrailingZeros mask+    >         newResult = if testBit src 0 then setBit result maskCtz else result+    >         newSrc    = src `shiftR` 1+    >         newMask   = clearBit mask maskCtz++    @since 0.5.2.0}++primop   Pext8Op   "pext8#"   GenPrimOp   Word# -> Word# -> Word#+    {Extract bits from lower 8 bits of a word at locations specified by a mask.++    @since 0.5.2.0}+primop   Pext16Op   "pext16#"   GenPrimOp   Word# -> Word# -> Word#+    {Extract bits from lower 16 bits of a word at locations specified by a mask.++    @since 0.5.2.0}+primop   Pext32Op   "pext32#"   GenPrimOp   Word# -> Word# -> Word#+    {Extract bits from lower 32 bits of a word at locations specified by a mask.++    @since 0.5.2.0}+primop   Pext64Op   "pext64#"   GenPrimOp   Word64# -> Word64# -> Word64#+    {Extract bits from a word at locations specified by a mask.++    @since 0.5.2.0}+primop   PextOp   "pext#"   GenPrimOp   Word# -> Word# -> Word#+    {Extract bits from a word at locations specified by a mask, aka+    [parallel bit extract](https://en.wikipedia.org/wiki/Bit_Manipulation_Instruction_Sets#Parallel_bit_deposit_and_extract).++    Software emulation:++    > pext :: Word -> Word -> Word+    > pext src mask = loop 0 0 0+    >   where+    >     loop i count result+    >       | i >= finiteBitSize (0 :: Word)+    >       = result+    >       | testBit mask i+    >       = loop (i + 1) (count + 1) (if testBit src i then setBit result count else result)+    >       | otherwise+    >       = loop (i + 1) count result++    @since 0.5.2.0}++primop   Clz8Op   "clz8#" GenPrimOp   Word# -> Word#+    {Count leading zeros in the lower 8 bits of a word.}+primop   Clz16Op   "clz16#" GenPrimOp   Word# -> Word#+    {Count leading zeros in the lower 16 bits of a word.}+primop   Clz32Op   "clz32#" GenPrimOp   Word# -> Word#+    {Count leading zeros in the lower 32 bits of a word.}+primop   Clz64Op   "clz64#" GenPrimOp Word64# -> Word#+    {Count leading zeros in a 64-bit word.}+primop   ClzOp     "clz#"   GenPrimOp   Word# -> Word#+    {Count leading zeros in a word.}++primop   Ctz8Op   "ctz8#"  GenPrimOp   Word# -> Word#+    {Count trailing zeros in the lower 8 bits of a word.}+primop   Ctz16Op   "ctz16#" GenPrimOp   Word# -> Word#+    {Count trailing zeros in the lower 16 bits of a word.}+primop   Ctz32Op   "ctz32#" GenPrimOp   Word# -> Word#+    {Count trailing zeros in the lower 32 bits of a word.}+primop   Ctz64Op   "ctz64#" GenPrimOp Word64# -> Word#+    {Count trailing zeros in a 64-bit word.}+primop   CtzOp     "ctz#"   GenPrimOp   Word# -> Word#+    {Count trailing zeros in a word.}++primop   BSwap16Op   "byteSwap16#"   GenPrimOp   Word# -> Word#+    {Swap bytes in the lower 16 bits of a word. The higher bytes are undefined. }+    with defined_bits = 16+primop   BSwap32Op   "byteSwap32#"   GenPrimOp   Word# -> Word#+    {Swap bytes in the lower 32 bits of a word. The higher bytes are undefined. }+    with defined_bits = 32+primop   BSwap64Op   "byteSwap64#"   GenPrimOp   Word64# -> Word64#+    {Swap bytes in a 64 bits of a word.}+primop   BSwapOp     "byteSwap#"     GenPrimOp   Word# -> Word#+    {Swap bytes in a word.}++primop   BRev8Op    "bitReverse8#"   GenPrimOp   Word# -> Word#+    {Reverse the order of the bits in a 8-bit word.}+    with defined_bits = 8+primop   BRev16Op   "bitReverse16#"   GenPrimOp   Word# -> Word#+    {Reverse the order of the bits in a 16-bit word.}+    with defined_bits = 16+primop   BRev32Op   "bitReverse32#"   GenPrimOp   Word# -> Word#+    {Reverse the order of the bits in a 32-bit word.}+    with defined_bits = 32+primop   BRev64Op   "bitReverse64#"   GenPrimOp   Word64# -> Word64#+    {Reverse the order of the bits in a 64-bit word.}+primop   BRevOp     "bitReverse#"     GenPrimOp   Word# -> Word#+    {Reverse the order of the bits in a word.}++------------------------------------------------------------------------+section "Narrowings"+        {Explicit narrowing of native-sized ints or words.}+------------------------------------------------------------------------++primop   Narrow8IntOp      "narrow8Int#"      GenPrimOp   Int# -> Int#+primop   Narrow16IntOp     "narrow16Int#"     GenPrimOp   Int# -> Int#+primop   Narrow32IntOp     "narrow32Int#"     GenPrimOp   Int# -> Int#+primop   Narrow8WordOp     "narrow8Word#"     GenPrimOp   Word# -> Word#+primop   Narrow16WordOp    "narrow16Word#"    GenPrimOp   Word# -> Word#+primop   Narrow32WordOp    "narrow32Word#"    GenPrimOp   Word# -> Word#++------------------------------------------------------------------------+section "Double#"+        {Operations on double-precision (64 bit) floating-point numbers.}+------------------------------------------------------------------------++primtype Double#++primop   DoubleGtOp ">##"   Compare   Double# -> Double# -> Int#+   with fixity = infix 4++primop   DoubleGeOp ">=##"   Compare   Double# -> Double# -> Int#+   with fixity = infix 4++primop DoubleEqOp "==##"   Compare+   Double# -> Double# -> Int#+   with commutable = True+        fixity = infix 4++primop DoubleNeOp "/=##"   Compare+   Double# -> Double# -> Int#+   with commutable = True+        fixity = infix 4++primop   DoubleLtOp "<##"   Compare   Double# -> Double# -> Int#+   with fixity = infix 4++primop   DoubleLeOp "<=##"   Compare   Double# -> Double# -> Int#+   with fixity = infix 4++primop   DoubleMinOp   "minDouble#"      GenPrimOp+   Double# -> Double# -> Double#+   {Return the minimum of the arguments.+   When the arguments are numerically equal (e.g. @0.0##@ and @-0.0##@)+   or one of the arguments is not-a-number (NaN),+   it is unspecified which one is returned.}+   with commutable = True++primop   DoubleMaxOp   "maxDouble#"      GenPrimOp+   Double# -> Double# -> Double#+   {Return the maximum of the arguments.+   When the arguments are numerically equal (e.g. @0.0##@ and @-0.0##@)+   or one of the arguments is not-a-number (NaN),+   it is unspecified which one is returned.}+   with commutable = True++primop   DoubleAddOp   "+##"   GenPrimOp+   Double# -> Double# -> Double#+   with commutable = True+        fixity = infixl 6++primop   DoubleSubOp   "-##"   GenPrimOp   Double# -> Double# -> Double#+   with fixity = infixl 6++primop   DoubleMulOp   "*##"   GenPrimOp+   Double# -> Double# -> Double#+   with commutable = True+        fixity = infixl 7++primop   DoubleDivOp   "/##"   GenPrimOp+   Double# -> Double# -> Double#+   with effect = CanFail -- Can this one really fail?+        fixity = infixl 7++primop   DoubleNegOp   "negateDouble#"  GenPrimOp   Double# -> Double#++primop   DoubleFabsOp  "fabsDouble#"    GenPrimOp   Double# -> Double#++primop   DoubleToIntOp   "double2Int#"          GenPrimOp  Double# -> Int#+   {Truncates a 'Double#' value to the nearest 'Int#'.+    Results are undefined if the truncation if truncation yields+    a value outside the range of 'Int#'.}++primop   DoubleToFloatOp   "double2Float#" GenPrimOp Double# -> Float#++primop   DoubleExpOp   "expDouble#"      GenPrimOp+   Double# -> Double#+   with+   code_size = { primOpCodeSizeForeignCall }++primop   DoubleExpM1Op "expm1Double#"    GenPrimOp+   Double# -> Double#+   with+   code_size = { primOpCodeSizeForeignCall }++primop   DoubleLogOp   "logDouble#"      GenPrimOp+   Double# -> Double#+   with+   code_size = { primOpCodeSizeForeignCall }+   effect = CanFail++primop   DoubleLog1POp   "log1pDouble#"      GenPrimOp+   Double# -> Double#+   with+   code_size = { primOpCodeSizeForeignCall }+   effect = CanFail++primop   DoubleSqrtOp   "sqrtDouble#"      GenPrimOp+   Double# -> Double#+   with+   code_size = { primOpCodeSizeForeignCall }++primop   DoubleSinOp   "sinDouble#"      GenPrimOp+   Double# -> Double#+   with+   code_size = { primOpCodeSizeForeignCall }++primop   DoubleCosOp   "cosDouble#"      GenPrimOp+   Double# -> Double#+   with+   code_size = { primOpCodeSizeForeignCall }++primop   DoubleTanOp   "tanDouble#"      GenPrimOp+   Double# -> Double#+   with+   code_size = { primOpCodeSizeForeignCall }++primop   DoubleAsinOp   "asinDouble#"      GenPrimOp+   Double# -> Double#+   with+   code_size = { primOpCodeSizeForeignCall }+   effect = CanFail++primop   DoubleAcosOp   "acosDouble#"      GenPrimOp+   Double# -> Double#+   with+   code_size = { primOpCodeSizeForeignCall }+   effect = CanFail++primop   DoubleAtanOp   "atanDouble#"      GenPrimOp+   Double# -> Double#+   with+   code_size = { primOpCodeSizeForeignCall }++primop   DoubleSinhOp   "sinhDouble#"      GenPrimOp+   Double# -> Double#+   with+   code_size = { primOpCodeSizeForeignCall }++primop   DoubleCoshOp   "coshDouble#"      GenPrimOp+   Double# -> Double#+   with+   code_size = { primOpCodeSizeForeignCall }++primop   DoubleTanhOp   "tanhDouble#"      GenPrimOp+   Double# -> Double#+   with+   code_size = { primOpCodeSizeForeignCall }++primop   DoubleAsinhOp   "asinhDouble#"      GenPrimOp+   Double# -> Double#+   with+   code_size = { primOpCodeSizeForeignCall }++primop   DoubleAcoshOp   "acoshDouble#"      GenPrimOp+   Double# -> Double#+   with+   code_size = { primOpCodeSizeForeignCall }++primop   DoubleAtanhOp   "atanhDouble#"      GenPrimOp+   Double# -> Double#+   with+   code_size = { primOpCodeSizeForeignCall }++primop   DoublePowerOp   "**##" GenPrimOp+   Double# -> Double# -> Double#+   {Exponentiation.}+   with+   code_size = { primOpCodeSizeForeignCall }++primop   DoubleDecode_2IntOp   "decodeDouble_2Int#" GenPrimOp+   Double# -> (# Int#, Word#, Word#, Int# #)+   {Convert to integer.+    First component of the result is -1 or 1, indicating the sign of the+    mantissa. The next two are the high and low 32 bits of the mantissa+    respectively, and the last is the exponent.}+   with out_of_line = True++primop   DoubleDecode_Int64Op   "decodeDouble_Int64#" GenPrimOp+   Double# -> (# Int64#, Int# #)+   {Decode 'Double#' into mantissa and base-2 exponent.}+   with out_of_line = True++primop CastDoubleToWord64Op "castDoubleToWord64#" GenPrimOp+   Double# -> Word64#+   {Bitcast a 'Double#' into a 'Word64#'}++primop CastWord64ToDoubleOp "castWord64ToDouble#" GenPrimOp+   Word64# -> Double#+   {Bitcast a 'Word64#' into a 'Double#'}++------------------------------------------------------------------------+section "Float#"+        {Operations on single-precision (32-bit) floating-point numbers.}+------------------------------------------------------------------------++primtype Float#++primop   FloatGtOp  "gtFloat#"   Compare   Float# -> Float# -> Int#+primop   FloatGeOp  "geFloat#"   Compare   Float# -> Float# -> Int#++primop   FloatEqOp  "eqFloat#"   Compare+   Float# -> Float# -> Int#+   with commutable = True++primop   FloatNeOp  "neFloat#"   Compare+   Float# -> Float# -> Int#+   with commutable = True++primop   FloatLtOp  "ltFloat#"   Compare   Float# -> Float# -> Int#+primop   FloatLeOp  "leFloat#"   Compare   Float# -> Float# -> Int#++primop   FloatMinOp   "minFloat#"      GenPrimOp+   Float# -> Float# -> Float#+   {Return the minimum of the arguments.+   When the arguments are numerically equal (e.g. @0.0#@ and @-0.0#@)+   or one of the arguments is not-a-number (NaN),+   it is unspecified which one is returned.}+   with commutable = True++primop   FloatMaxOp   "maxFloat#"      GenPrimOp+   Float# -> Float# -> Float#+   {Return the maximum of the arguments.+   When the arguments are numerically equal (e.g. @0.0#@ and @-0.0#@)+   or one of the arguments is not-a-number (NaN),+   it is unspecified which one is returned.}+   with commutable = True++primop   FloatAddOp   "plusFloat#"      GenPrimOp+   Float# -> Float# -> Float#+   with commutable = True++primop   FloatSubOp   "minusFloat#"      GenPrimOp      Float# -> Float# -> Float#++primop   FloatMulOp   "timesFloat#"      GenPrimOp+   Float# -> Float# -> Float#+   with commutable = True++primop   FloatDivOp   "divideFloat#"      GenPrimOp+   Float# -> Float# -> Float#+   with effect = CanFail++primop   FloatNegOp   "negateFloat#"      GenPrimOp    Float# -> Float#++primop   FloatFabsOp  "fabsFloat#"        GenPrimOp    Float# -> Float#++primop   FloatToIntOp   "float2Int#"      GenPrimOp  Float# -> Int#+   {Truncates a 'Float#' value to the nearest 'Int#'.+    Results are undefined if the truncation if truncation yields+    a value outside the range of 'Int#'.}++primop   FloatExpOp   "expFloat#"      GenPrimOp+   Float# -> Float#+   with+   code_size = { primOpCodeSizeForeignCall }++primop   FloatExpM1Op   "expm1Float#"      GenPrimOp+   Float# -> Float#+   with+   code_size = { primOpCodeSizeForeignCall }++primop   FloatLogOp   "logFloat#"      GenPrimOp+   Float# -> Float#+   with+   code_size = { primOpCodeSizeForeignCall }+   effect = CanFail++primop   FloatLog1POp  "log1pFloat#"     GenPrimOp+   Float# -> Float#+   with+   code_size = { primOpCodeSizeForeignCall }+   effect = CanFail++primop   FloatSqrtOp   "sqrtFloat#"      GenPrimOp+   Float# -> Float#+   with+   code_size = { primOpCodeSizeForeignCall }++primop   FloatSinOp   "sinFloat#"      GenPrimOp+   Float# -> Float#+   with+   code_size = { primOpCodeSizeForeignCall }++primop   FloatCosOp   "cosFloat#"      GenPrimOp+   Float# -> Float#+   with+   code_size = { primOpCodeSizeForeignCall }++primop   FloatTanOp   "tanFloat#"      GenPrimOp+   Float# -> Float#+   with+   code_size = { primOpCodeSizeForeignCall }++primop   FloatAsinOp   "asinFloat#"      GenPrimOp+   Float# -> Float#+   with+   code_size = { primOpCodeSizeForeignCall }+   effect = CanFail++primop   FloatAcosOp   "acosFloat#"      GenPrimOp+   Float# -> Float#+   with+   code_size = { primOpCodeSizeForeignCall }+   effect = CanFail++primop   FloatAtanOp   "atanFloat#"      GenPrimOp+   Float# -> Float#+   with+   code_size = { primOpCodeSizeForeignCall }++primop   FloatSinhOp   "sinhFloat#"      GenPrimOp+   Float# -> Float#+   with+   code_size = { primOpCodeSizeForeignCall }++primop   FloatCoshOp   "coshFloat#"      GenPrimOp+   Float# -> Float#+   with+   code_size = { primOpCodeSizeForeignCall }++primop   FloatTanhOp   "tanhFloat#"      GenPrimOp+   Float# -> Float#+   with+   code_size = { primOpCodeSizeForeignCall }++primop   FloatAsinhOp   "asinhFloat#"      GenPrimOp+   Float# -> Float#+   with+   code_size = { primOpCodeSizeForeignCall }++primop   FloatAcoshOp   "acoshFloat#"      GenPrimOp+   Float# -> Float#+   with+   code_size = { primOpCodeSizeForeignCall }++primop   FloatAtanhOp   "atanhFloat#"      GenPrimOp+   Float# -> Float#+   with+   code_size = { primOpCodeSizeForeignCall }++primop   FloatPowerOp   "powerFloat#"      GenPrimOp+   Float# -> Float# -> Float#+   with+   code_size = { primOpCodeSizeForeignCall }++primop   FloatToDoubleOp   "float2Double#" GenPrimOp  Float# -> Double#++primop   FloatDecode_IntOp   "decodeFloat_Int#" GenPrimOp+   Float# -> (# Int#, Int# #)+   {Convert to integers.+    First 'Int#' in result is the mantissa; second is the exponent.}+   with out_of_line = True++primop CastFloatToWord32Op "castFloatToWord32#" GenPrimOp+   Float# -> Word32#+   {Bitcast a 'Float#' into a 'Word32#'}++primop CastWord32ToFloatOp "castWord32ToFloat#" GenPrimOp+   Word32# -> Float#+   {Bitcast a 'Word32#' into a 'Float#'}++------------------------------------------------------------------------+section "Fused multiply-add operations"+  { #fma#++    The fused multiply-add primops 'fmaddFloat#' and 'fmaddDouble#'+    implement the operation++    \[+    \lambda\ x\ y\ z \rightarrow x * y + z+    \]++    with a single floating-point rounding operation at the end, as opposed to+    rounding twice (which can accumulate rounding errors).++    These primops can be compiled directly to a single machine instruction on+    architectures that support them. Currently, these are:++      1. x86 with CPUs that support the FMA3 extended instruction set (which+         includes most processors since 2013).+      2. PowerPC.+      3. AArch64.++    This requires users pass the '-mfma' flag to GHC. Otherwise, the primop+    is implemented by falling back to the C standard library, which might+    perform software emulation (this may yield results that are not IEEE+    compliant on some platforms).++    The additional operations 'fmsubFloat#'/'fmsubDouble#',+    'fnmaddFloat#'/'fnmaddDouble#' and 'fnmsubFloat#'/'fnmsubDouble#' provide+    variants on 'fmaddFloat#'/'fmaddDouble#' in which some signs are changed:++    \[+    \begin{aligned}+    \mathrm{fmadd}\ x\ y\ z &= \phantom{+} x * y + z \\[8pt]+    \mathrm{fmsub}\ x\ y\ z &= \phantom{+} x * y - z \\[8pt]+    \mathrm{fnmadd}\ x\ y\ z &= - x * y + z \\[8pt]+    \mathrm{fnmsub}\ x\ y\ z &= - x * y - z+    \end{aligned}+    \]++    }+------------------------------------------------------------------------++primop   FloatFMAdd   "fmaddFloat#" GenPrimOp+   Float# -> Float# -> Float# -> Float#+   {Fused multiply-add operation @x*y+z@. See "GHC.Prim#fma".}+primop   FloatFMSub   "fmsubFloat#" GenPrimOp+   Float# -> Float# -> Float# -> Float#+   {Fused multiply-subtract operation @x*y-z@. See "GHC.Prim#fma".}+primop   FloatFNMAdd   "fnmaddFloat#" GenPrimOp+   Float# -> Float# -> Float# -> Float#+   {Fused negate-multiply-add operation @-x*y+z@. See "GHC.Prim#fma".}+primop   FloatFNMSub   "fnmsubFloat#" GenPrimOp+   Float# -> Float# -> Float# -> Float#+   {Fused negate-multiply-subtract operation @-x*y-z@. See "GHC.Prim#fma".}++primop   DoubleFMAdd   "fmaddDouble#" GenPrimOp+   Double# -> Double# -> Double# -> Double#+   {Fused multiply-add operation @x*y+z@. See "GHC.Prim#fma".}+primop   DoubleFMSub   "fmsubDouble#" GenPrimOp+   Double# -> Double# -> Double# -> Double#+   {Fused multiply-subtract operation @x*y-z@. See "GHC.Prim#fma".}+primop   DoubleFNMAdd   "fnmaddDouble#" GenPrimOp+   Double# -> Double# -> Double# -> Double#+   {Fused negate-multiply-add operation @-x*y+z@. See "GHC.Prim#fma".}+primop   DoubleFNMSub   "fnmsubDouble#" GenPrimOp+   Double# -> Double# -> Double# -> Double#+   {Fused negate-multiply-subtract operation @-x*y-z@. See "GHC.Prim#fma".}++------------------------------------------------------------------------+section "Arrays"+        {Operations on 'Array#'.}+------------------------------------------------------------------------++primtype Array# a++primtype MutableArray# s a++primop  NewArrayOp "newArray#" GenPrimOp+   Int# -> a_levpoly -> State# s -> (# State# s, MutableArray# s a_levpoly #)+   {Create a new mutable array with the specified number of elements,+    in the specified state thread,+    with each element containing the specified initial value.}+   with+   out_of_line = True+   effect = ReadWriteEffect++primop  ReadArrayOp "readArray#" GenPrimOp+   MutableArray# s a_levpoly -> Int# -> State# s -> (# State# s, a_levpoly #)+   {Read from specified index of mutable array. Result is not yet evaluated.}+   with+   effect = ReadWriteEffect+   can_fail_warning = YesWarnCanFail++primop  WriteArrayOp "writeArray#" GenPrimOp+   MutableArray# s a_levpoly -> Int# -> a_levpoly -> State# s -> State# s+   {Write to specified index of mutable array.}+   with+   effect = ReadWriteEffect+   can_fail_warning = YesWarnCanFail+   code_size = 2 -- card update too++primop  SizeofArrayOp "sizeofArray#" GenPrimOp+   Array# a_levpoly -> Int#+   {Return the number of elements in the array.}++primop  SizeofMutableArrayOp "sizeofMutableArray#" GenPrimOp+   MutableArray# s a_levpoly -> Int#+   {Return the number of elements in the array.}++primop  IndexArrayOp "indexArray#" GenPrimOp+   Array# a_levpoly -> Int# -> (# a_levpoly #)+   {Read from the specified index of an immutable array. The result is packaged+    into an unboxed unary tuple; the result itself is not yet+    evaluated. Pattern matching on the tuple forces the indexing of the+    array to happen but does not evaluate the element itself. Evaluating+    the thunk prevents additional thunks from building up on the+    heap. Avoiding these thunks, in turn, reduces references to the+    argument array, allowing it to be garbage collected more promptly.}+   with+   effect = CanFail++-- Note [primOpEffect of unsafe freezes and thaws]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- Mutable and immutable pointer arrays have different info table+-- pointers; this is for the benefit of the garbage collector.+-- Consequently, unsafe freeze/thaw operations on pointer arrays are+-- NOT no-ops: They at least have to update the info table pointer. (For+-- thaw, they also add the array to the mutable set.)+--+-- We don't want to duplicate this, so these operations are considered+-- to have effect = ReadWriteEffect.+--+-- (Actually, these operations /are/ no-ops in the JS backend, where+-- mutable and immutable arrays are the same because JS. But we don't+-- have target-dependent primOpEffect yet.)+--+-- This reasoning does not apply to byte arrays, which the garbage+-- collector can always ignore the contents of.  Their unsafe freeze+-- and thaw operations really are no-ops; their underlying heap+-- objects are always ARR_WORDS.++primop  UnsafeFreezeArrayOp "unsafeFreezeArray#" GenPrimOp+   MutableArray# s a_levpoly -> State# s -> (# State# s, Array# a_levpoly #)+   {Make a mutable array immutable, without copying.}+   with+   effect = ReadWriteEffect+   -- see Note [primOpEffect of unsafe freezes and thaws]++primop  UnsafeThawArrayOp  "unsafeThawArray#" GenPrimOp+   Array# a_levpoly -> State# s -> (# State# s, MutableArray# s a_levpoly #)+   {Make an immutable array mutable, without copying.}+   with+   out_of_line = True+   effect = ReadWriteEffect+   -- see Note [primOpEffect of unsafe freezes and thaws]++primop  CopyArrayOp "copyArray#" GenPrimOp+  Array# a_levpoly -> Int# -> MutableArray# s a_levpoly -> Int# -> Int# -> State# s -> State# s+  {Given a source array, an offset into the source array, a+   destination array, an offset into the destination array, and a+   number of elements to copy, copy the elements from the source array+   to the destination array. Both arrays must fully contain the+   specified ranges, but this is not checked. The two arrays must not+   be the same array in different states, but this is not checked+   either.}+  with+  out_of_line      = True+  effect = ReadWriteEffect+  can_fail_warning = YesWarnCanFail++primop  CopyMutableArrayOp "copyMutableArray#" GenPrimOp+  MutableArray# s a_levpoly -> Int# -> MutableArray# s a_levpoly -> Int# -> Int# -> State# s -> State# s+  {Given a source array, an offset into the source array, a+   destination array, an offset into the destination array, and a+   number of elements to copy, copy the elements from the source array+   to the destination array. Both arrays must fully contain the+   specified ranges, but this is not checked. In the case where+   the source and destination are the same array the source and+   destination regions may overlap.}+  with+  out_of_line      = True+  effect = ReadWriteEffect+  can_fail_warning = YesWarnCanFail++primop  CloneArrayOp "cloneArray#" GenPrimOp+  Array# a_levpoly -> Int# -> Int# -> Array# a_levpoly+  {Given a source array, an offset into the source array, and a number+   of elements to copy, create a new array with the elements from the+   source array. The provided array must fully contain the specified+   range, but this is not checked.}+  with+  out_of_line      = True+  effect = ReadWriteEffect -- assumed too expensive to duplicate?+  can_fail_warning = YesWarnCanFail++primop  CloneMutableArrayOp "cloneMutableArray#" GenPrimOp+  MutableArray# s a_levpoly -> Int# -> Int# -> State# s -> (# State# s, MutableArray# s a_levpoly #)+  {Given a source array, an offset into the source array, and a number+   of elements to copy, create a new array with the elements from the+   source array. The provided array must fully contain the specified+   range, but this is not checked.}+  with+  out_of_line      = True+  effect = ReadWriteEffect+  can_fail_warning = YesWarnCanFail++primop  FreezeArrayOp "freezeArray#" GenPrimOp+  MutableArray# s a_levpoly -> Int# -> Int# -> State# s -> (# State# s, Array# a_levpoly #)+  {Given a source array, an offset into the source array, and a number+   of elements to copy, create a new array with the elements from the+   source array. The provided array must fully contain the specified+   range, but this is not checked.}+  with+  out_of_line      = True+  effect = ReadWriteEffect+  can_fail_warning = YesWarnCanFail++primop  ThawArrayOp "thawArray#" GenPrimOp+  Array# a_levpoly -> Int# -> Int# -> State# s -> (# State# s, MutableArray# s a_levpoly #)+  {Given a source array, an offset into the source array, and a number+   of elements to copy, create a new array with the elements from the+   source array. The provided array must fully contain the specified+   range, but this is not checked.}+  with+  out_of_line      = True+  effect = ReadWriteEffect+  can_fail_warning = YesWarnCanFail++primop CasArrayOp  "casArray#" GenPrimOp+   MutableArray# s a_levpoly -> Int# -> a_levpoly -> a_levpoly -> State# s -> (# State# s, Int#, a_levpoly #)+   {Given an array, an offset, the expected old value, and+    the new value, perform an atomic compare and swap (i.e. write the new+    value if the current value and the old value are the same pointer).+    Returns 0 if the swap succeeds and 1 if it fails. Additionally, returns+    the element at the offset after the operation completes. This means that+    on a success the new value is returned, and on a failure the actual old+    value (not the expected one) is returned. Implies a full memory barrier.+    The use of a pointer equality on a boxed value makes this function harder+    to use correctly than 'casIntArray#'. All of the difficulties+    of using 'reallyUnsafePtrEquality#' correctly apply to+    'casArray#' as well.+   }+   with+   out_of_line = True+   effect = ReadWriteEffect+   can_fail_warning = YesWarnCanFail+++------------------------------------------------------------------------+section "Small Arrays"++        {Operations on 'SmallArray#'. A 'SmallArray#' works+         just like an 'Array#', but with different space use and+         performance characteristics (that are often useful with small+         arrays). The 'SmallArray#' and 'SmallMutableArray#'+         lack a `card table'. The purpose of a card table is to avoid+         having to scan every element of the array on each GC by+         keeping track of which elements have changed since the last GC+         and only scanning those that have changed. So the consequence+         of there being no card table is that the representation is+         somewhat smaller and the writes are somewhat faster (because+         the card table does not need to be updated). The disadvantage+         of course is that for a 'SmallMutableArray#' the whole+         array has to be scanned on each GC. Thus it is best suited for+         use cases where the mutable array is not long lived, e.g.+         where a mutable array is initialised quickly and then frozen+         to become an immutable 'SmallArray#'.+        }++------------------------------------------------------------------------++primtype SmallArray# a++primtype SmallMutableArray# s a++primop  NewSmallArrayOp "newSmallArray#" GenPrimOp+   Int# -> a_levpoly -> State# s -> (# State# s, SmallMutableArray# s a_levpoly #)+   {Create a new mutable array with the specified number of elements,+    in the specified state thread,+    with each element containing the specified initial value.}+   with+   out_of_line = True+   effect = ReadWriteEffect++primop  ShrinkSmallMutableArrayOp_Char "shrinkSmallMutableArray#" GenPrimOp+   SmallMutableArray# s a_levpoly -> Int# -> State# s -> State# s+   {Shrink mutable array to new specified size, in+    the specified state thread. The new size argument must be less than or+    equal to the current size as reported by 'getSizeofSmallMutableArray#'.++    Assuming the non-profiling RTS, for the copying garbage collector+    (default) this primitive compiles to an O(1) operation in C--, modifying+    the array in-place. For the non-moving garbage collector, however, the+    time is proportional to the number of elements shrinked out. Backends+    bypassing C-- representation (such as JavaScript) might behave+    differently.++    @since 0.6.1}+   with out_of_line = True+        effect = ReadWriteEffect+        can_fail_warning = YesWarnCanFail+        -- can fail because of the "newSize <= oldSize" requirement++primop  ReadSmallArrayOp "readSmallArray#" GenPrimOp+   SmallMutableArray# s a_levpoly -> Int# -> State# s -> (# State# s, a_levpoly #)+   {Read from specified index of mutable array. Result is not yet evaluated.}+   with+   effect = ReadWriteEffect+   can_fail_warning = YesWarnCanFail++primop  WriteSmallArrayOp "writeSmallArray#" GenPrimOp+   SmallMutableArray# s a_levpoly -> Int# -> a_levpoly -> State# s -> State# s+   {Write to specified index of mutable array.}+   with+   effect = ReadWriteEffect+   can_fail_warning = YesWarnCanFail++primop  SizeofSmallArrayOp "sizeofSmallArray#" GenPrimOp+   SmallArray# a_levpoly -> Int#+   {Return the number of elements in the array.}++primop  SizeofSmallMutableArrayOp "sizeofSmallMutableArray#" GenPrimOp+   SmallMutableArray# s a_levpoly -> Int#+   {Return the number of elements in the array. __Deprecated__, it is+   unsafe in the presence of 'shrinkSmallMutableArray#' and @resizeSmallMutableArray#@+   operations on the same small mutable array.}+   with deprecated_msg = { Use 'getSizeofSmallMutableArray#' instead }++primop  GetSizeofSmallMutableArrayOp "getSizeofSmallMutableArray#" GenPrimOp+   SmallMutableArray# s a_levpoly -> State# s -> (# State# s, Int# #)+   {Return the number of elements in the array, correctly accounting for+   the effect of 'shrinkSmallMutableArray#' and @resizeSmallMutableArray#@.++   @since 0.6.1}++primop  IndexSmallArrayOp "indexSmallArray#" GenPrimOp+   SmallArray# a_levpoly -> Int# -> (# a_levpoly #)+   {Read from specified index of immutable array. Result is packaged into+    an unboxed singleton; the result itself is not yet evaluated.}+   with+   effect = CanFail++primop  UnsafeFreezeSmallArrayOp "unsafeFreezeSmallArray#" GenPrimOp+   SmallMutableArray# s a_levpoly -> State# s -> (# State# s, SmallArray# a_levpoly #)+   {Make a mutable array immutable, without copying.}+   with+   effect = ReadWriteEffect+   -- see Note [primOpEffect of unsafe freezes and thaws]++primop  UnsafeThawSmallArrayOp  "unsafeThawSmallArray#" GenPrimOp+   SmallArray# a_levpoly -> State# s -> (# State# s, SmallMutableArray# s a_levpoly #)+   {Make an immutable array mutable, without copying.}+   with+   out_of_line = True+   effect = ReadWriteEffect+   -- see Note [primOpEffect of unsafe freezes and thaws]++-- The code_size is only correct for the case when the copy family of+-- primops aren't inlined. It would be nice to keep track of both.++primop  CopySmallArrayOp "copySmallArray#" GenPrimOp+  SmallArray# a_levpoly -> Int# -> SmallMutableArray# s a_levpoly -> Int# -> Int# -> State# s -> State# s+  {Given a source array, an offset into the source array, a+   destination array, an offset into the destination array, and a+   number of elements to copy, copy the elements from the source array+   to the destination array. Both arrays must fully contain the+   specified ranges, but this is not checked. The two arrays must not+   be the same array in different states, but this is not checked+   either.}+  with+  out_of_line = True+  effect = ReadWriteEffect+  can_fail_warning = YesWarnCanFail++primop  CopySmallMutableArrayOp "copySmallMutableArray#" GenPrimOp+  SmallMutableArray# s a_levpoly -> Int# -> SmallMutableArray# s a_levpoly -> Int# -> Int# -> State# s -> State# s+  {Given a source array, an offset into the source array, a+   destination array, an offset into the destination array, and a+   number of elements to copy, copy the elements from the source array+   to the destination array. The source and destination arrays can+   refer to the same array. Both arrays must fully contain the+   specified ranges, but this is not checked.+   The regions are allowed to overlap, although this is only possible when the same+   array is provided as both the source and the destination. }+  with+  out_of_line = True+  effect = ReadWriteEffect+  can_fail_warning = YesWarnCanFail++primop  CloneSmallArrayOp "cloneSmallArray#" GenPrimOp+  SmallArray# a_levpoly -> Int# -> Int# -> SmallArray# a_levpoly+  {Given a source array, an offset into the source array, and a number+   of elements to copy, create a new array with the elements from the+   source array. The provided array must fully contain the specified+   range, but this is not checked.}+  with+  out_of_line      = True+  effect = ReadWriteEffect -- assumed too expensive to duplicate?+  can_fail_warning = YesWarnCanFail++primop  CloneSmallMutableArrayOp "cloneSmallMutableArray#" GenPrimOp+  SmallMutableArray# s a_levpoly -> Int# -> Int# -> State# s -> (# State# s, SmallMutableArray# s a_levpoly #)+  {Given a source array, an offset into the source array, and a number+   of elements to copy, create a new array with the elements from the+   source array. The provided array must fully contain the specified+   range, but this is not checked.}+  with+  out_of_line      = True+  effect = ReadWriteEffect+  can_fail_warning = YesWarnCanFail++primop  FreezeSmallArrayOp "freezeSmallArray#" GenPrimOp+  SmallMutableArray# s a_levpoly -> Int# -> Int# -> State# s -> (# State# s, SmallArray# a_levpoly #)+  {Given a source array, an offset into the source array, and a number+   of elements to copy, create a new array with the elements from the+   source array. The provided array must fully contain the specified+   range, but this is not checked.}+  with+  out_of_line      = True+  effect = ReadWriteEffect+  can_fail_warning = YesWarnCanFail++primop  ThawSmallArrayOp "thawSmallArray#" GenPrimOp+  SmallArray# a_levpoly -> Int# -> Int# -> State# s -> (# State# s, SmallMutableArray# s a_levpoly #)+  {Given a source array, an offset into the source array, and a number+   of elements to copy, create a new array with the elements from the+   source array. The provided array must fully contain the specified+   range, but this is not checked.}+  with+  out_of_line      = True+  effect = ReadWriteEffect+  can_fail_warning = YesWarnCanFail++primop CasSmallArrayOp  "casSmallArray#" GenPrimOp+   SmallMutableArray# s a_levpoly -> Int# -> a_levpoly -> a_levpoly -> State# s -> (# State# s, Int#, a_levpoly #)+   {Unsafe, machine-level atomic compare and swap on an element within an array.+    See the documentation of 'casArray#'.}+   with+   out_of_line = True+   effect = ReadWriteEffect -- Might index out of bounds+   can_fail_warning = YesWarnCanFail++------------------------------------------------------------------------+section "Byte Arrays"+        {A 'ByteArray#' is a region of+         raw memory in the garbage-collected heap, which is not+         scanned for pointers.+         There are three sets of operations for accessing byte array contents:+         index for reading from immutable byte arrays, and read/write+         for mutable byte arrays.  Each set contains operations for a+         range of useful primitive data types.  Each operation takes+         an offset measured in terms of the size of the primitive type+         being read or written.++         }++------------------------------------------------------------------------++primtype ByteArray#+{+  A boxed, unlifted datatype representing a region of raw memory in the garbage-collected heap,+  which is not scanned for pointers during garbage collection.++  It is created by freezing a 'MutableByteArray#' with 'unsafeFreezeByteArray#'.+  Freezing is essentially a no-op, as 'MutableByteArray#' and 'ByteArray#' share the same heap structure under the hood.++  The immutable and mutable variants are commonly used for scenarios requiring high-performance data structures,+  like @Text@, @Primitive Vector@, @Unboxed Array@, and @ShortByteString@.++  Another application of fundamental importance is 'Integer', which is backed by 'ByteArray#'.++  The representation on the heap of a Byte Array is:++  > +------------+-----------------+-----------------------++  > |            |                 |                       |+  > |   HEADER   | SIZE (in bytes) |       PAYLOAD         |+  > |            |                 |                       |+  > +------------+-----------------+-----------------------+++  To obtain a pointer to actual payload (e.g., for FFI purposes) use 'byteArrayContents#' or 'mutableByteArrayContents#'.++  Alternatively, enabling the @UnliftedFFITypes@ extension+  allows to mention 'ByteArray#' and 'MutableByteArray#' in FFI type signatures directly.+}++primtype MutableByteArray# s+{ A mutable 'ByteAray#'. It can be created in three ways:++  * 'newByteArray#': Create an unpinned array.+  * 'newPinnedByteArray#': This will create a pinned array,+  * 'newAlignedPinnedByteArray#': This will create a pinned array, with a custom alignment.++  Unpinned arrays can be moved around during garbage collection, so you must not store or pass pointers to these values+  if there is a chance for the garbage collector to kick in. That said, even unpinned arrays can be passed to unsafe FFI calls,+  because no garbage collection happens during these unsafe calls+  (see [Guaranteed Call Safety](https://ghc.gitlab.haskell.org/ghc/doc/users_guide/exts/ffi.html#guaranteed-call-safety)+  in the GHC Manual). For safe FFI calls, byte arrays must be not only pinned, but also kept alive by means of the keepAlive# function+  for the duration of a call (that's because garbage collection cannot move a pinned array, but is free to scrap it altogether).+}++primop  NewByteArrayOp_Char "newByteArray#" GenPrimOp+   Int# -> State# s -> (# State# s, MutableByteArray# s #)+   {Create a new mutable byte array of specified size (in bytes), in+    the specified state thread. The size of the memory underlying the+    array will be rounded up to the platform's word size.}+   with out_of_line = True+        effect = ReadWriteEffect++primop  NewPinnedByteArrayOp_Char "newPinnedByteArray#" GenPrimOp+   Int# -> State# s -> (# State# s, MutableByteArray# s #)+   {Like 'newByteArray#' but GC guarantees not to move it.}+   with out_of_line = True+        effect = ReadWriteEffect++primop  NewAlignedPinnedByteArrayOp_Char "newAlignedPinnedByteArray#" GenPrimOp+   Int# -> Int# -> State# s -> (# State# s, MutableByteArray# s #)+   {Like 'newPinnedByteArray#' but allow specifying an arbitrary+    alignment, which must be a power of two.}+   with out_of_line = True+        effect = ReadWriteEffect+        can_fail_warning = YesWarnCanFail+        -- can fail warning for the "power of two" requirement++primop  MutableByteArrayIsPinnedOp "isMutableByteArrayPinned#" GenPrimOp+   MutableByteArray# s -> Int#+   {Determine whether a 'MutableByteArray#' is guaranteed not to move+   during GC.}+   with out_of_line = True++primop  ByteArrayIsPinnedOp "isByteArrayPinned#" GenPrimOp+   ByteArray# -> Int#+   {Determine whether a 'ByteArray#' is guaranteed not to move.}+   with out_of_line = True++primop  ByteArrayIsWeaklyPinnedOp "isByteArrayWeaklyPinned#" GenPrimOp+   ByteArray# -> Int#+   {Similar to 'isByteArrayPinned#'. Weakly pinned byte arrays are allowed+    to be copied into compact regions by the user, potentially invalidating+    the results of earlier calls to 'byteArrayContents#'.++    See the section `Pinned Byte Arrays` in the user guide for more information.++    This function also returns true for regular pinned bytearrays.+   }+   with out_of_line = True++primop  MutableByteArrayIsWeaklyPinnedOp "isMutableByteArrayWeaklyPinned#" GenPrimOp+   MutableByteArray# s -> Int#+   { 'isByteArrayWeaklyPinned#' but for mutable arrays.+   }+   with out_of_line = True++primop  ByteArrayContents_Char "byteArrayContents#" GenPrimOp+   ByteArray# -> Addr#+   {Intended for use with pinned arrays; otherwise very unsafe!}++primop  MutableByteArrayContents_Char "mutableByteArrayContents#" GenPrimOp+   MutableByteArray# s -> Addr#+   {Intended for use with pinned arrays; otherwise very unsafe!}++primop  ShrinkMutableByteArrayOp_Char "shrinkMutableByteArray#" GenPrimOp+   MutableByteArray# s -> Int# -> State# s -> State# s+   {Shrink mutable byte array to new specified size (in bytes), in+    the specified state thread. The new size argument must be less than or+    equal to the current size as reported by 'getSizeofMutableByteArray#'.++    Assuming the non-profiling RTS, this primitive compiles to an O(1)+    operation in C--, modifying the array in-place. Backends bypassing C--+    representation (such as JavaScript) might behave differently.++    @since 0.4.0.0}+   with out_of_line = True+        effect = ReadWriteEffect+        can_fail_warning = YesWarnCanFail+        -- can fail for the "newSize <= oldSize" requirement++primop  ResizeMutableByteArrayOp_Char "resizeMutableByteArray#" GenPrimOp+   MutableByteArray# s -> Int# -> State# s -> (# State# s,MutableByteArray# s #)+   {Resize mutable byte array to new specified size (in bytes), shrinking or growing it.+    The returned 'MutableByteArray#' is either the original+    'MutableByteArray#' resized in-place or, if not possible, a newly+    allocated (unpinned) 'MutableByteArray#' (with the original content+    copied over).++    To avoid undefined behaviour, the original 'MutableByteArray#' shall+    not be accessed anymore after a 'resizeMutableByteArray#' has been+    performed.  Moreover, no reference to the old one should be kept in order+    to allow garbage collection of the original 'MutableByteArray#' in+    case a new 'MutableByteArray#' had to be allocated.++    @since 0.4.0.0}+   with out_of_line = True+        effect = ReadWriteEffect++primop  UnsafeFreezeByteArrayOp "unsafeFreezeByteArray#" GenPrimOp+   MutableByteArray# s -> State# s -> (# State# s, ByteArray# #)+   {Make a mutable byte array immutable, without copying.}+   with+   code_size = 0+   effect = NoEffect+   -- see Note [primOpEffect of unsafe freezes and thaws]++primop  UnsafeThawByteArrayOp "unsafeThawByteArray#" GenPrimOp+   ByteArray# -> State# s -> (# State# s, MutableByteArray# s #)+   {Make an immutable byte array mutable, without copying.++    @since 0.12.0.0}+   with+   code_size = 0+   effect = NoEffect+   -- see Note [primOpEffect of unsafe freezes and thaws]++primop  SizeofByteArrayOp "sizeofByteArray#" GenPrimOp+   ByteArray# -> Int#+   {Return the size of the array in bytes.}++primop  SizeofMutableByteArrayOp "sizeofMutableByteArray#" GenPrimOp+   MutableByteArray# s -> Int#+   {Return the size of the array in bytes. __Deprecated__, it is+   unsafe in the presence of 'shrinkMutableByteArray#' and 'resizeMutableByteArray#'+   operations on the same mutable byte+   array.}+   with deprecated_msg = { Use 'getSizeofMutableByteArray#' instead }++primop  GetSizeofMutableByteArrayOp "getSizeofMutableByteArray#" GenPrimOp+   MutableByteArray# s -> State# s -> (# State# s, Int# #)+   {Return the number of elements in the array, correctly accounting for+   the effect of 'shrinkMutableByteArray#' and 'resizeMutableByteArray#'.++   @since 0.5.0.0}+++bytearray_access_ops+-- This generates a whole bunch of primops;+-- see utils/genprimopcode/AccessOps.hs+++primop  CompareByteArraysOp "compareByteArrays#" GenPrimOp+   ByteArray# -> Int# -> ByteArray# -> Int# -> Int# -> Int#+   {@'compareByteArrays#' src1 src1_ofs src2 src2_ofs n@ compares+    @n@ bytes starting at offset @src1_ofs@ in the first+    'ByteArray#' @src1@ to the range of @n@ bytes+    (i.e. same length) starting at offset @src2_ofs@ of the second+    'ByteArray#' @src2@.  Both arrays must fully contain the+    specified ranges, but this is not checked.  Returns an 'Int#'+    less than, equal to, or greater than zero if the range is found,+    respectively, to be byte-wise lexicographically less than, to+    match, or be greater than the second range.++    @since 0.5.2.0}+   with+   effect = CanFail++primop  CopyByteArrayOp "copyByteArray#" GenPrimOp+  ByteArray# -> Int# -> MutableByteArray# s -> Int# -> Int# -> State# s -> State# s+  { @'copyByteArray#' src src_ofs dst dst_ofs len@ copies the range+    starting at offset @src_ofs@ of length @len@ from the+    'ByteArray#' @src@ to the 'MutableByteArray#' @dst@+    starting at offset @dst_ofs@.  Both arrays must fully contain+    the specified ranges, but this is not checked.  The two arrays must+    not be the same array in different states, but this is not checked+    either.+  }+  with+  effect = ReadWriteEffect+  can_fail_warning = YesWarnCanFail+  code_size = { primOpCodeSizeForeignCall + 4}++primop  CopyMutableByteArrayOp "copyMutableByteArray#" GenPrimOp+  MutableByteArray# s -> Int# -> MutableByteArray# s -> Int# -> Int# -> State# s -> State# s+  { @'copyMutableByteArray#' src src_ofs dst dst_ofs len@ copies the+    range starting at offset @src_ofs@ of length @len@ from the+    'MutableByteArray#' @src@ to the 'MutableByteArray#' @dst@+    starting at offset @dst_ofs@.  Both arrays must fully contain the+    specified ranges, but this is not checked.  The regions are+    allowed to overlap, although this is only possible when the same+    array is provided as both the source and the destination.+  }+  with+  effect = ReadWriteEffect+  can_fail_warning = YesWarnCanFail+  code_size = { primOpCodeSizeForeignCall + 4 }++primop  CopyMutableByteArrayNonOverlappingOp "copyMutableByteArrayNonOverlapping#" GenPrimOp+  MutableByteArray# s -> Int# -> MutableByteArray# s -> Int# -> Int# -> State# s -> State# s+  { @'copyMutableByteArrayNonOverlapping#' src src_ofs dst dst_ofs len@+    copies the range starting at offset @src_ofs@ of length @len@ from+    the 'MutableByteArray#' @src@ to the 'MutableByteArray#' @dst@+    starting at offset @dst_ofs@.  Both arrays must fully contain the+    specified ranges, but this is not checked.  The regions are /not/+    allowed to overlap, but this is also not checked.++    @since 0.11.0+  }+  with+  effect = ReadWriteEffect+  can_fail_warning = YesWarnCanFail+  code_size = { primOpCodeSizeForeignCall + 4 }++primop  CopyByteArrayToAddrOp "copyByteArrayToAddr#" GenPrimOp+  ByteArray# -> Int# -> Addr# -> Int# -> State# s -> State# s+  {Copy a range of the ByteArray\# to the memory range starting at the Addr\#.+   The ByteArray\# and the memory region at Addr\# must fully contain the+   specified ranges, but this is not checked. The Addr\# must not point into the+   ByteArray\# (e.g. if the ByteArray\# were pinned), but this is not checked+   either.}+  with+  effect = ReadWriteEffect+  can_fail_warning = YesWarnCanFail+  code_size = { primOpCodeSizeForeignCall + 4 }++primop  CopyMutableByteArrayToAddrOp "copyMutableByteArrayToAddr#" GenPrimOp+  MutableByteArray# s -> Int# -> Addr# -> Int# -> State# s -> State# s+  {Copy a range of the MutableByteArray\# to the memory range starting at the+   Addr\#. The MutableByteArray\# and the memory region at Addr\# must fully+   contain the specified ranges, but this is not checked. The Addr\# must not+   point into the MutableByteArray\# (e.g. if the MutableByteArray\# were+   pinned), but this is not checked either.}+  with+  effect = ReadWriteEffect+  can_fail_warning = YesWarnCanFail+  code_size = { primOpCodeSizeForeignCall + 4 }++primop  CopyAddrToByteArrayOp "copyAddrToByteArray#" GenPrimOp+  Addr# -> MutableByteArray# s -> Int# -> Int# -> State# s -> State# s+  {Copy a memory range starting at the Addr\# to the specified range in the+   MutableByteArray\#. The memory region at Addr\# and the ByteArray\# must fully+   contain the specified ranges, but this is not checked. The Addr\# must not+   point into the MutableByteArray\# (e.g. if the MutableByteArray\# were pinned),+   but this is not checked either.}+  with+  effect = ReadWriteEffect+  can_fail_warning = YesWarnCanFail+  code_size = { primOpCodeSizeForeignCall + 4 }++primop  CopyAddrToAddrOp "copyAddrToAddr#" GenPrimOp+  Addr# -> Addr# -> Int# -> State# RealWorld -> State# RealWorld+  { @'copyAddrToAddr#' src dest len@ copies @len@ bytes+    from @src@ to @dest@.  These two memory ranges are allowed to overlap.++    Analogous to the standard C function @memmove@, but with a different+    argument order.++    @since 0.11.0+  }+  with+  effect = ReadWriteEffect+  can_fail_warning = YesWarnCanFail+  code_size = { primOpCodeSizeForeignCall }++primop  CopyAddrToAddrNonOverlappingOp "copyAddrToAddrNonOverlapping#" GenPrimOp+  Addr# -> Addr# -> Int# -> State# RealWorld -> State# RealWorld+  { @'copyAddrToAddrNonOverlapping#' src dest len@ copies @len@ bytes+    from @src@ to @dest@.  As the name suggests, these two memory ranges+    /must not overlap/, although this pre-condition is not checked.++    Analogous to the standard C function @memcpy@, but with a different+    argument order.++    @since 0.11.0+  }+  with+  effect = ReadWriteEffect+  can_fail_warning = YesWarnCanFail+  code_size = { primOpCodeSizeForeignCall }++primop  SetByteArrayOp "setByteArray#" GenPrimOp+  MutableByteArray# s -> Int# -> Int# -> Int# -> State# s -> State# s+  {@'setByteArray#' ba off len c@ sets the byte range @[off, off+len)@ of+   the 'MutableByteArray#' to the byte @c@.}+  with+  effect = ReadWriteEffect+  can_fail_warning = YesWarnCanFail+  code_size = { primOpCodeSizeForeignCall + 4 }++primop  SetAddrRangeOp "setAddrRange#" GenPrimOp+  Addr# -> Int# -> Int# -> State# RealWorld -> State# RealWorld+  { @'setAddrRange#' dest len c@ sets all of the bytes in+    @[dest, dest+len)@ to the value @c@.++    Analogous to the standard C function @memset@, but with a different+    argument order.++    @since 0.11.0+  }+  with+  effect = ReadWriteEffect+  can_fail_warning = YesWarnCanFail+  code_size = { primOpCodeSizeForeignCall }++-- Atomic operations++primop  AtomicReadByteArrayOp_Int "atomicReadIntArray#" GenPrimOp+   MutableByteArray# s -> Int# -> State# s -> (# State# s, Int# #)+   {Given an array and an offset in machine words, read an element. The+    index is assumed to be in bounds. Implies a full memory barrier.}+   with+   effect = ReadWriteEffect+   can_fail_warning = YesWarnCanFail++primop  AtomicWriteByteArrayOp_Int "atomicWriteIntArray#" GenPrimOp+   MutableByteArray# s -> Int# -> Int# -> State# s -> State# s+   {Given an array and an offset in machine words, write an element. The+    index is assumed to be in bounds. Implies a full memory barrier.}+   with+   effect = ReadWriteEffect+   can_fail_warning = YesWarnCanFail++primop CasByteArrayOp_Int "casIntArray#" GenPrimOp+   MutableByteArray# s -> Int# -> Int# -> Int# -> State# s -> (# State# s, Int# #)+   {Given an array, an offset in machine words, the expected old value, and+    the new value, perform an atomic compare and swap i.e. write the new+    value if the current value matches the provided old value. Returns+    the value of the element before the operation. Implies a full memory+    barrier.}+   with+   effect = ReadWriteEffect+   can_fail_warning = YesWarnCanFail++primop CasByteArrayOp_Int8 "casInt8Array#" GenPrimOp+   MutableByteArray# s -> Int# -> Int8# -> Int8# -> State# s -> (# State# s, Int8# #)+   {Given an array, an offset in bytes, the expected old value, and+    the new value, perform an atomic compare and swap i.e. write the new+    value if the current value matches the provided old value. Returns+    the value of the element before the operation. Implies a full memory+    barrier.}+   with+   effect = ReadWriteEffect+   can_fail_warning = YesWarnCanFail++primop CasByteArrayOp_Int16 "casInt16Array#" GenPrimOp+   MutableByteArray# s -> Int# -> Int16# -> Int16# -> State# s -> (# State# s, Int16# #)+   {Given an array, an offset in 16 bit units, the expected old value, and+    the new value, perform an atomic compare and swap i.e. write the new+    value if the current value matches the provided old value. Returns+    the value of the element before the operation. Implies a full memory+    barrier.}+   with+   effect = ReadWriteEffect+   can_fail_warning = YesWarnCanFail++primop CasByteArrayOp_Int32 "casInt32Array#" GenPrimOp+   MutableByteArray# s -> Int# -> Int32# -> Int32# -> State# s -> (# State# s, Int32# #)+   {Given an array, an offset in 32 bit units, the expected old value, and+    the new value, perform an atomic compare and swap i.e. write the new+    value if the current value matches the provided old value. Returns+    the value of the element before the operation. Implies a full memory+    barrier.}+   with+   effect = ReadWriteEffect+   can_fail_warning = YesWarnCanFail++primop CasByteArrayOp_Int64 "casInt64Array#" GenPrimOp+   MutableByteArray# s -> Int# -> Int64# -> Int64# -> State# s -> (# State# s, Int64# #)+   {Given an array, an offset in 64 bit units, the expected old value, and+    the new value, perform an atomic compare and swap i.e. write the new+    value if the current value matches the provided old value. Returns+    the value of the element before the operation. Implies a full memory+    barrier.}+   with+   effect = ReadWriteEffect+   can_fail_warning = YesWarnCanFail++primop FetchAddByteArrayOp_Int "fetchAddIntArray#" GenPrimOp+   MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s, Int# #)+   {Given an array, and offset in machine words, and a value to add,+    atomically add the value to the element. Returns the value of the+    element before the operation. Implies a full memory barrier.}+   with+   effect = ReadWriteEffect+   can_fail_warning = YesWarnCanFail++primop FetchSubByteArrayOp_Int "fetchSubIntArray#" GenPrimOp+   MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s, Int# #)+   {Given an array, and offset in machine words, and a value to subtract,+    atomically subtract the value from the element. Returns the value of+    the element before the operation. Implies a full memory barrier.}+   with+   effect = ReadWriteEffect+   can_fail_warning = YesWarnCanFail++primop FetchAndByteArrayOp_Int "fetchAndIntArray#" GenPrimOp+   MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s, Int# #)+   {Given an array, and offset in machine words, and a value to AND,+    atomically AND the value into the element. Returns the value of the+    element before the operation. Implies a full memory barrier.}+   with+   effect = ReadWriteEffect+   can_fail_warning = YesWarnCanFail++primop FetchNandByteArrayOp_Int "fetchNandIntArray#" GenPrimOp+   MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s, Int# #)+   {Given an array, and offset in machine words, and a value to NAND,+    atomically NAND the value into the element. Returns the value of the+    element before the operation. Implies a full memory barrier.}+   with+   effect = ReadWriteEffect+   can_fail_warning = YesWarnCanFail++primop FetchOrByteArrayOp_Int "fetchOrIntArray#" GenPrimOp+   MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s, Int# #)+   {Given an array, and offset in machine words, and a value to OR,+    atomically OR the value into the element. Returns the value of the+    element before the operation. Implies a full memory barrier.}+   with+   effect = ReadWriteEffect+   can_fail_warning = YesWarnCanFail++primop FetchXorByteArrayOp_Int "fetchXorIntArray#" GenPrimOp+   MutableByteArray# s -> Int# -> Int# -> State# s -> (# State# s, Int# #)+   {Given an array, and offset in machine words, and a value to XOR,+    atomically XOR the value into the element. Returns the value of the+    element before the operation. Implies a full memory barrier.}+   with+   effect = ReadWriteEffect+   can_fail_warning = YesWarnCanFail++------------------------------------------------------------------------+section "Addr#"+------------------------------------------------------------------------++primtype Addr#+        { An arbitrary machine address assumed to point outside+         the garbage-collected heap. }++pseudoop "nullAddr#" Addr#+        { The null address. }++primop   AddrAddOp "plusAddr#" GenPrimOp Addr# -> Int# -> Addr#+primop   AddrSubOp "minusAddr#" GenPrimOp Addr# -> Addr# -> Int#+         {Result is meaningless if two 'Addr#'s are so far apart that their+         difference doesn't fit in an 'Int#'.}+primop   AddrRemOp "remAddr#" GenPrimOp Addr# -> Int# -> Int#+         {Return the remainder when the 'Addr#' arg, treated like an 'Int#',+          is divided by the 'Int#' arg.}+primop   AddrToIntOp  "addr2Int#"     GenPrimOp   Addr# -> Int#+        {Coerce directly from address to int. Users are discouraged from using+         this operation as it makes little sense on platforms with tagged pointers.}+   with code_size = 0+primop   IntToAddrOp   "int2Addr#"    GenPrimOp  Int# -> Addr#+        {Coerce directly from int to address. Users are discouraged from using+         this operation as it makes little sense on platforms with tagged pointers.}+   with code_size = 0++primop   AddrGtOp  "gtAddr#"   Compare   Addr# -> Addr# -> Int#+primop   AddrGeOp  "geAddr#"   Compare   Addr# -> Addr# -> Int#+primop   AddrEqOp  "eqAddr#"   Compare   Addr# -> Addr# -> Int#+primop   AddrNeOp  "neAddr#"   Compare   Addr# -> Addr# -> Int#+primop   AddrLtOp  "ltAddr#"   Compare   Addr# -> Addr# -> Int#+primop   AddrLeOp  "leAddr#"   Compare   Addr# -> Addr# -> Int#+++addr_access_ops+-- This generates a whole bunch of primops;+-- see utils/genprimopcode/AccessOps.hs+++primop  InterlockedExchange_Addr "atomicExchangeAddrAddr#" GenPrimOp+   Addr# -> Addr# -> State# s -> (# State# s, Addr# #)+   {The atomic exchange operation. Atomically exchanges the value at the first address+    with the Addr# given as second argument. Implies a read barrier.}+   with+   effect = ReadWriteEffect+   can_fail_warning = YesWarnCanFail++primop  InterlockedExchange_Word "atomicExchangeWordAddr#" GenPrimOp+   Addr# -> Word# -> State# s -> (# State# s, Word# #)+   {The atomic exchange operation. Atomically exchanges the value at the address+    with the given value. Returns the old value. Implies a read barrier.}+   with+   effect = ReadWriteEffect+   can_fail_warning = YesWarnCanFail++primop  CasAddrOp_Addr "atomicCasAddrAddr#" GenPrimOp+   Addr# -> Addr# -> Addr# -> State# s -> (# State# s, Addr# #)+   { Compare and swap on a word-sized memory location.++     Use as: \s -> atomicCasAddrAddr# location expected desired s++     This version always returns the old value read. This follows the normal+     protocol for CAS operations (and matches the underlying instruction on+     most architectures).++     Implies a full memory barrier.}+   with+   effect = ReadWriteEffect+   can_fail_warning = YesWarnCanFail++primop  CasAddrOp_Word "atomicCasWordAddr#" GenPrimOp+   Addr# -> Word# -> Word# -> State# s -> (# State# s, Word# #)+   { Compare and swap on a word-sized and aligned memory location.++     Use as: \s -> atomicCasWordAddr# location expected desired s++     This version always returns the old value read. This follows the normal+     protocol for CAS operations (and matches the underlying instruction on+     most architectures).++     Implies a full memory barrier.}+   with+   effect = ReadWriteEffect+   can_fail_warning = YesWarnCanFail++primop  CasAddrOp_Word8 "atomicCasWord8Addr#" GenPrimOp+   Addr# -> Word8# -> Word8# -> State# s -> (# State# s, Word8# #)+   { Compare and swap on a 8 bit-sized and aligned memory location.++     Use as: \s -> atomicCasWordAddr8# location expected desired s++     This version always returns the old value read. This follows the normal+     protocol for CAS operations (and matches the underlying instruction on+     most architectures).++     Implies a full memory barrier.}+   with+   effect = ReadWriteEffect+   can_fail_warning = YesWarnCanFail++primop  CasAddrOp_Word16 "atomicCasWord16Addr#" GenPrimOp+   Addr# -> Word16# -> Word16# -> State# s -> (# State# s, Word16# #)+   { Compare and swap on a 16 bit-sized and aligned memory location.++     Use as: \s -> atomicCasWordAddr16# location expected desired s++     This version always returns the old value read. This follows the normal+     protocol for CAS operations (and matches the underlying instruction on+     most architectures).++     Implies a full memory barrier.}+   with+   effect = ReadWriteEffect+   can_fail_warning = YesWarnCanFail++primop  CasAddrOp_Word32 "atomicCasWord32Addr#" GenPrimOp+   Addr# -> Word32# -> Word32# -> State# s -> (# State# s, Word32# #)+   { Compare and swap on a 32 bit-sized and aligned memory location.++     Use as: \s -> atomicCasWordAddr32# location expected desired s++     This version always returns the old value read. This follows the normal+     protocol for CAS operations (and matches the underlying instruction on+     most architectures).++     Implies a full memory barrier.}+   with+   effect = ReadWriteEffect+   can_fail_warning = YesWarnCanFail++primop  CasAddrOp_Word64 "atomicCasWord64Addr#" GenPrimOp+   Addr# -> Word64# -> Word64# -> State# s -> (# State# s, Word64# #)+   { Compare and swap on a 64 bit-sized and aligned memory location.++     Use as: \s -> atomicCasWordAddr64# location expected desired s++     This version always returns the old value read. This follows the normal+     protocol for CAS operations (and matches the underlying instruction on+     most architectures).++     Implies a full memory barrier.}+   with+   effect = ReadWriteEffect+   can_fail_warning = YesWarnCanFail++primop FetchAddAddrOp_Word "fetchAddWordAddr#" GenPrimOp+   Addr# -> Word# -> State# s -> (# State# s, Word# #)+   {Given an address, and a value to add,+    atomically add the value to the element. Returns the value of the+    element before the operation. Implies a full memory barrier.}+   with+   effect = ReadWriteEffect+   can_fail_warning = YesWarnCanFail++primop FetchSubAddrOp_Word "fetchSubWordAddr#" GenPrimOp+   Addr# -> Word# -> State# s -> (# State# s, Word# #)+   {Given an address, and a value to subtract,+    atomically subtract the value from the element. Returns the value of+    the element before the operation. Implies a full memory barrier.}+   with+   effect = ReadWriteEffect+   can_fail_warning = YesWarnCanFail++primop FetchAndAddrOp_Word "fetchAndWordAddr#" GenPrimOp+   Addr# -> Word# -> State# s -> (# State# s, Word# #)+   {Given an address, and a value to AND,+    atomically AND the value into the element. Returns the value of the+    element before the operation. Implies a full memory barrier.}+   with+   effect = ReadWriteEffect+   can_fail_warning = YesWarnCanFail++primop FetchNandAddrOp_Word "fetchNandWordAddr#" GenPrimOp+   Addr# -> Word# -> State# s -> (# State# s, Word# #)+   {Given an address, and a value to NAND,+    atomically NAND the value into the element. Returns the value of the+    element before the operation. Implies a full memory barrier.}+   with+   effect = ReadWriteEffect+   can_fail_warning = YesWarnCanFail++primop FetchOrAddrOp_Word "fetchOrWordAddr#" GenPrimOp+   Addr# -> Word# -> State# s -> (# State# s, Word# #)+   {Given an address, and a value to OR,+    atomically OR the value into the element. Returns the value of the+    element before the operation. Implies a full memory barrier.}+   with+   effect = ReadWriteEffect+   can_fail_warning = YesWarnCanFail++primop FetchXorAddrOp_Word "fetchXorWordAddr#" GenPrimOp+   Addr# -> Word# -> State# s -> (# State# s, Word# #)+   {Given an address, and a value to XOR,+    atomically XOR the value into the element. Returns the value of the+    element before the operation. Implies a full memory barrier.}+   with+   effect = ReadWriteEffect+   can_fail_warning = YesWarnCanFail++primop  AtomicReadAddrOp_Word "atomicReadWordAddr#" GenPrimOp+   Addr# -> State# s -> (# State# s, Word# #)+   {Given an address, read a machine word.  Implies a full memory barrier.}+   with+   effect = ReadWriteEffect+   can_fail_warning = YesWarnCanFail++primop  AtomicWriteAddrOp_Word "atomicWriteWordAddr#" GenPrimOp+   Addr# -> Word# -> State# s -> State# s+   {Given an address, write a machine word. Implies a full memory barrier.}+   with+   effect = ReadWriteEffect+   can_fail_warning = YesWarnCanFail+++------------------------------------------------------------------------+section "Mutable variables"+        {Operations on MutVar\#s.}+------------------------------------------------------------------------++primtype MutVar# s a+        {A 'MutVar#' behaves like a single-element mutable array.}++primop  NewMutVarOp "newMutVar#" GenPrimOp+   a_levpoly -> State# s -> (# State# s, MutVar# s a_levpoly #)+   {Create 'MutVar#' with specified initial value in specified state thread.}+   with+   out_of_line = True+   effect = ReadWriteEffect++-- Note [Why MutVar# ops can't fail]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- We don't label readMutVar# or writeMutVar# as CanFail.+-- This may seem a bit peculiar, because they surely *could*+-- fail spectacularly if passed a pointer to unallocated memory.+-- But MutVar#s are always correct by construction; we never+-- test if a pointer is valid before using it with these operations.+-- So we never have to worry about floating the pointer reference+-- outside a validity test. At the moment, ReadWriteEffect blocks+-- up the relevant optimizations anyway, but we hope to draw finer+-- distinctions soon, which should improve matters for readMutVar#+-- at least.++primop  ReadMutVarOp "readMutVar#" GenPrimOp+   MutVar# s a_levpoly -> State# s -> (# State# s, a_levpoly #)+   {Read contents of 'MutVar#'. Result is not yet evaluated.}+   with+   -- See Note [Why MutVar# ops can't fail]+   effect = ReadWriteEffect++primop  WriteMutVarOp "writeMutVar#"  GenPrimOp+   MutVar# s a_levpoly -> a_levpoly -> State# s -> State# s+   {Write contents of 'MutVar#'.}+   with+   -- See Note [Why MutVar# ops can't fail]+   effect = ReadWriteEffect+   code_size = { primOpCodeSizeForeignCall } -- for the write barrier++primop  AtomicSwapMutVarOp "atomicSwapMutVar#" GenPrimOp+   MutVar# s a_levpoly -> a_levpoly -> State# s -> (# State# s, a_levpoly #)+   {Atomically exchange the value of a 'MutVar#'.}+   with+   effect = ReadWriteEffect++-- Note [Why not an unboxed tuple in atomicModifyMutVar2#?]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- Looking at the type of atomicModifyMutVar2#, one might wonder why+-- it doesn't return an unboxed tuple. e.g.,+--+--   MutVar# s a -> (a -> (# a, b #)) -> State# s -> (# State# s, a, (# a, b #) #)+--+-- The reason is that atomicModifyMutVar2# relies on laziness for its atomicity.+-- Given a MutVar# containing x, atomicModifyMutVar2# merely replaces+-- its contents with a thunk of the form (fst (f x)). This can be done using an+-- atomic compare-and-swap as it is merely replacing a pointer.++primop  AtomicModifyMutVar2Op "atomicModifyMutVar2#" GenPrimOp+   MutVar# s a -> (a -> c) -> State# s -> (# State# s, a, c #)+   { Modify the contents of a 'MutVar#', returning the previous+     contents @x :: a@ and the result of applying the given function to the+     previous contents @f x :: c@.++     The @data@ type @c@ (not a @newtype@!) must be a record whose first field+     is of lifted type @a :: Type@ and is not unpacked. For example, product+     types @c ~ Solo a@ or @c ~ (a, b)@ work well. If the record type is both+     monomorphic and strict in its first field, it's recommended to mark the+     latter @{-# NOUNPACK #-}@ explicitly.++     Under the hood 'atomicModifyMutVar2#' atomically replaces a pointer to an+     old @x :: a@ with a pointer to a selector thunk @fst r@, where+     @fst@ is a selector for the first field of the record and @r@ is a+     function application thunk @r = f x@.++     @atomicModifyIORef2Native@ from @atomic-modify-general@ package makes an+     effort to reflect restrictions on @c@ faithfully, providing a+     well-typed high-level wrapper.}+   with+   out_of_line = True+   effect = ReadWriteEffect+   strictness  = { \ _arity -> mkClosedDmdSig [ topDmd, lazyApply1Dmd, topDmd ] topDiv }++primop  AtomicModifyMutVar_Op "atomicModifyMutVar_#" GenPrimOp+   MutVar# s a -> (a -> a) -> State# s -> (# State# s, a, a #)+   { Modify the contents of a 'MutVar#', returning the previous+     contents and the result of applying the given function to the+     previous contents. }+   with+   out_of_line = True+   effect = ReadWriteEffect+   strictness  = { \ _arity -> mkClosedDmdSig [ topDmd, lazyApply1Dmd, topDmd ] topDiv }++primop  CasMutVarOp "casMutVar#" GenPrimOp+  MutVar# s a_levpoly -> a_levpoly -> a_levpoly -> State# s -> (# State# s, Int#, a_levpoly #)+   { Compare-and-swap: perform a pointer equality test between+     the first value passed to this function and the value+     stored inside the 'MutVar#'. If the pointers are equal,+     replace the stored value with the second value passed to this+     function, otherwise do nothing.+     Returns the final value stored inside the 'MutVar#'.+     The 'Int#' indicates whether a swap took place,+     with @1#@ meaning that we didn't swap, and @0#@+     that we did.+     Implies a full memory barrier.+     Because the comparison is done on the level of pointers,+     all of the difficulties of using+     'reallyUnsafePtrEquality#' correctly apply to+     'casMutVar#' as well.+   }+   with+   out_of_line = True+   effect = ReadWriteEffect++------------------------------------------------------------------------+section "Exceptions"+------------------------------------------------------------------------++-- Note [Strict IO wrappers]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~+-- Consider this example, which comes from GHC.IO.Handle.Internals:+--    wantReadableHandle3 f mv b st+--      = case ... of+--          DEFAULT -> case mv of MVar a -> ...+--          0#      -> maskAsyncExceptions# (\st -> case mv of MVar a -> ...)+-- The outer case just decides whether to mask exceptions, but we don't want+-- thereby to hide the strictness in `mv`!  Hence the use of strictOnceApply1Dmd+-- in mask#, unmask# and atomically# (where we use strictManyApply1Dmd to respect+-- that it potentially calls its action multiple times).+--+-- Note [Strictness for catch-style primops]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- The catch#-style primops always call their action, just like outlined+-- in Note [Strict IO wrappers].+-- However, it is important that we give their first arg lazyApply1Dmd and not+-- strictOnceApply1Dmd, like for mask#. Here is why. Consider a call+--+--   catch# act handler s+--+-- If `act = raiseIO# ...`, using strictOnceApply1Dmd for `act` would mean that+-- the call forwards the dead-end flag from `act` (see Note [Dead ends] and+-- Note [Precise exceptions and strictness analysis]).+-- This would cause dead code elimination to discard the continuation of the+-- catch# call, among other things. This first came up in #11555.+--+-- Hence catch# uses lazyApply1Dmd in order /not/ to forward the dead-end flag+-- from `act`. (This is a bit brutal, but the language of strictness types is+-- not expressive enough to give it a more precise semantics that is still+-- sound.)+-- For perf reasons we often (but not always) choose to use a wrapper around+-- catch# that is head-strict in `act`: GHC.IO.catchException.+--+-- A similar caveat applies to prompt#, which can be seen as a+-- generalisation of catch# as explained in GHC.Prim#continuations#.+-- The reason is that even if `act` appears dead-ending (e.g., looping)+-- `prompt# tag ma s` might return alright due to a (higher-order) use of+-- `control0#` in `act`. This came up in #25439.++primop  CatchOp "catch#" GenPrimOp+          (State# RealWorld -> (# State# RealWorld, a_reppoly #) )+       -> (b_levpoly -> State# RealWorld -> (# State# RealWorld, a_reppoly #) )+       -> State# RealWorld+       -> (# State# RealWorld, a_reppoly #)+   { @'catch#' k handler s@ evaluates @k s@, invoking @handler@ on any exceptions+     thrown.++     Note that the result type here isn't quite as unrestricted as the+     polymorphic type might suggest; see the section \"RuntimeRep polymorphism+     in continuation-style primops\" for details. }+   with+   strictness  = { \ _arity -> mkClosedDmdSig [ lazyApply1Dmd+                                                 , lazyApply2Dmd+                                                 , topDmd] topDiv }+                 -- See Note [Strictness for catch-style primops]+   out_of_line = True+   effect = ReadWriteEffect+   -- Either inner computation might potentially raise an unchecked exception,+   -- but it doesn't seem worth putting a WARNING in the haddocks over++primop  RaiseOp "raise#" GenPrimOp+   a_levpoly -> b_reppoly+   with+   -- In contrast to 'raiseIO#', which throws a *precise* exception,+   -- exceptions thrown by 'raise#' are considered *imprecise*.+   -- See Note [Precise vs imprecise exceptions] in GHC.Types.Demand.+   -- Hence, it has 'botDiv', not 'exnDiv'.+   strictness  = { \ _arity -> mkClosedDmdSig [topDmd] botDiv }+   out_of_line = True+   effect = ThrowsException+   work_free = True++primop  RaiseUnderflowOp "raiseUnderflow#" GenPrimOp+   (# #) -> b_reppoly+   with+   strictness  = { \ _arity -> mkClosedDmdSig [topDmd] botDiv }+   out_of_line = True+   effect = ThrowsException+   code_size = { primOpCodeSizeForeignCall }+   work_free = True++primop  RaiseOverflowOp "raiseOverflow#" GenPrimOp+   (# #) -> b_reppoly+   with+   strictness  = { \ _arity -> mkClosedDmdSig [topDmd] botDiv }+   out_of_line = True+   effect = ThrowsException+   code_size = { primOpCodeSizeForeignCall }+   work_free = True++primop  RaiseDivZeroOp "raiseDivZero#" GenPrimOp+   (# #) -> b_reppoly+   with+   strictness  = { \ _arity -> mkClosedDmdSig [topDmd] botDiv }+   out_of_line = True+   effect = ThrowsException+   code_size = { primOpCodeSizeForeignCall }+   work_free = True++primop  RaiseIOOp "raiseIO#" GenPrimOp+   a_levpoly -> State# RealWorld -> (# State# RealWorld, b_reppoly #)+   with+   -- See Note [Precise exceptions and strictness analysis] in "GHC.Types.Demand"+   -- for why this is the *only* primop that has 'exnDiv'+   strictness  = { \ _arity -> mkClosedDmdSig [topDmd, topDmd] exnDiv }+   out_of_line = True+   effect = ThrowsException+   work_free = True++primop  MaskAsyncExceptionsOp "maskAsyncExceptions#" GenPrimOp+        (State# RealWorld -> (# State# RealWorld, a_reppoly #))+     -> (State# RealWorld -> (# State# RealWorld, a_reppoly #))+   { @'maskAsyncExceptions#' k s@ evaluates @k s@ such that asynchronous+     exceptions are deferred until after evaluation has finished.++     Note that the result type here isn't quite as unrestricted as the+     polymorphic type might suggest; see the section \"RuntimeRep polymorphism+     in continuation-style primops\" for details. }+   with+   strictness  = { \ _arity -> mkClosedDmdSig [strictOnceApply1Dmd,topDmd] topDiv }+                 -- See Note [Strict IO wrappers]+   out_of_line = True+   effect = ReadWriteEffect++primop  MaskUninterruptibleOp "maskUninterruptible#" GenPrimOp+        (State# RealWorld -> (# State# RealWorld, a_reppoly #))+     -> (State# RealWorld -> (# State# RealWorld, a_reppoly #))+   { @'maskUninterruptible#' k s@ evaluates @k s@ such that asynchronous+     exceptions are deferred until after evaluation has finished.++     Note that the result type here isn't quite as unrestricted as the+     polymorphic type might suggest; see the section \"RuntimeRep polymorphism+     in continuation-style primops\" for details. }+   with+   strictness  = { \ _arity -> mkClosedDmdSig [strictOnceApply1Dmd,topDmd] topDiv }+                 -- See Note [Strict IO wrappers]+   out_of_line = True+   effect = ReadWriteEffect++primop  UnmaskAsyncExceptionsOp "unmaskAsyncExceptions#" GenPrimOp+        (State# RealWorld -> (# State# RealWorld, a_reppoly #))+     -> (State# RealWorld -> (# State# RealWorld, a_reppoly #))+   { @'unmaskAsyncUninterruptible#' k s@ evaluates @k s@ such that asynchronous+     exceptions are unmasked.++     Note that the result type here isn't quite as unrestricted as the+     polymorphic type might suggest; see the section \"RuntimeRep polymorphism+     in continuation-style primops\" for details. }+   with+   strictness  = { \ _arity -> mkClosedDmdSig [strictOnceApply1Dmd,topDmd] topDiv }+                 -- See Note [Strict IO wrappers]+   out_of_line = True+   effect = ReadWriteEffect++primop  MaskStatus "getMaskingState#" GenPrimOp+        State# RealWorld -> (# State# RealWorld, Int# #)+   with+   out_of_line = True+   effect = ReadWriteEffect++------------------------------------------------------------------------+section "Continuations"+  { #continuations#++    These operations provide access to first-class delimited continuations,+    which allow a computation to access and manipulate portions of its+    /current continuation/. Operationally, they are implemented by direct+    manipulation of the RTS call stack, which may provide significant+    performance gains relative to manual continuation-passing style (CPS) for+    some programs.++    Intuitively, the delimited control operators 'prompt#' and+    'control0#' can be understood by analogy to 'catch#' and 'raiseIO#',+    respectively:++      * Like 'catch#', 'prompt#' does not do anything on its own, it+        just /delimits/ a subcomputation (the source of the name "delimited+        continuations").++      * Like 'raiseIO#', 'control0#' aborts to the nearest enclosing+        'prompt#' before resuming execution.++    However, /unlike/ 'raiseIO#', 'control0#' does /not/ discard+    the aborted computation: instead, it /captures/ it in a form that allows+    it to be resumed later. In other words, 'control0#' does not+    irreversibly abort the local computation before returning to the enclosing+    'prompt#', it merely suspends it. All local context of the suspended+    computation is packaged up and returned as an ordinary function that can be+    invoked at a later point in time to /continue/ execution, which is why+    the suspended computation is known as a /first-class continuation/.++    In GHC, every continuation prompt is associated with exactly one+    'PromptTag#'. Prompt tags are unique, opaque values created by+    'newPromptTag#' that may only be compared for equality. Both 'prompt#'+    and 'control0#' accept a 'PromptTag#' argument, and 'control0#'+    captures the continuation up to the nearest enclosing use of 'prompt#'+    /with the same tag/. This allows a program to control exactly which+    prompt it will abort to by using different tags, similar to how a program+    can control which 'catch' it will abort to by throwing different types+    of exceptions. Additionally, 'PromptTag#' accepts a single type parameter,+    which is used to relate the expected result type at the point of the+    'prompt#' to the type of the continuation produced by 'control0#'.++    == The gory details++    The high-level explanation provided above should hopefully provide some+    intuition for what these operations do, but it is not very precise; this+    section provides a more thorough explanation.++    The 'prompt#' operation morally has the following type:++@+'prompt#' :: 'PromptTag#' a -> IO a -> IO a+@++    If a computation @/m/@ never calls 'control0#', then+    @'prompt#' /tag/ /m/@ is equivalent to just @/m/@, i.e. the 'prompt#' is+    a no-op. This implies the following law:++    \[+    \mathtt{prompt\#}\ \mathit{tag}\ (\mathtt{pure}\ x) \equiv \mathtt{pure}\ x+    \]++    The 'control0#' operation morally has the following type:++@+'control0#' :: 'PromptTag#' a -> ((IO b -> IO a) -> IO a) -> IO b+@++    @'control0#' /tag/ /f/@ captures the current continuation up to the nearest+    enclosing @'prompt#' /tag/@ and resumes execution from the point of the call+    to 'prompt#', passing the captured continuation to @/f/@. To make that+    somewhat more precise, we can say 'control0#' obeys the following law:++    \[+    \mathtt{prompt\#}\ \mathit{tag}\ (\mathtt{control0\#}\ tag\ f \mathbin{\mathtt{>>=}} k)+      \equiv f\ (\lambda\ m \rightarrow m \mathbin{\mathtt{>>=}} k)+    \]++    However, this law does not fully describe the behavior of 'control0#',+    as it does not account for situations where 'control0#' does not appear+    immediately inside 'prompt#'. Capturing the semantics more precisely+    requires some additional notational machinery; a common approach is to+    use [reduction semantics](https://en.wikipedia.org/wiki/Operational_semantics#Reduction_semantics).+    Assuming an appropriate definition of evaluation contexts \(E\), the+    semantics of 'prompt#' and 'control0#' can be given as follows:++    \[+    \begin{aligned}+    E[\mathtt{prompt\#}\ \mathit{tag}\ (\mathtt{pure}\ v)]+      &\longrightarrow E[\mathtt{pure}\ v] \\[8pt]+    E_1[\mathtt{prompt\#}\ \mathit{tag}\ E_2[\mathtt{control0\#}\ tag\ f]]+      &\longrightarrow E_1[f\ (\lambda\ m \rightarrow E_2[m])] \\[-2pt]+      \mathrm{where}\;\: \mathtt{prompt\#}\ \mathit{tag} &\not\in E_2+    \end{aligned}+    \]++    A full treatment of the semantics and metatheory of delimited control is+    well outside the scope of this documentation, but a good, thorough+    overview (in Haskell) is provided in [A Monadic Framework for Delimited+    Continuations](https://legacy.cs.indiana.edu/~dyb/pubs/monadicDC.pdf) by+    Dybvig et al.++    == Safety and invariants++    Correct uses of 'control0#' must obey the following restrictions:++    1. The behavior of 'control0#' is only well-defined within a /strict+       'State#' thread/, such as those associated with @IO@ and strict @ST@+       computations.++    2. Furthermore, 'control0#' may only be called within the dynamic extent+       of a 'prompt#' with a matching tag somewhere in the /current/ strict+       'State#' thread. Effectively, this means that a matching prompt must+       exist somewhere, and the captured continuation must /not/ contain any+       uses of @unsafePerformIO@, @runST@, @unsafeInterleaveIO@, etc. For+       example, the following program is ill-defined:++        @+        'prompt#' /tag/ $+          evaluate (unsafePerformIO $ 'control0#' /tag/ /f/)+        @++        In this example, the use of 'prompt#' appears in a different 'State#'+        thread from the use of 'control0#', so there is no valid prompt in+        scope to capture up to.++    3. Finally, 'control0#' may not be used within 'State#' threads associated+       with an STM transaction (i.e. those introduced by 'atomically#').++    If the runtime is able to detect that any of these invariants have been+    violated in a way that would compromise internal invariants of the runtime,+    'control0#' will fail by raising an exception. However, such violations+    are only detected on a best-effort basis, as the bookkeeping necessary for+    detecting /all/ illegal uses of 'control0#' would have significant overhead.+    Therefore, although the operations are "safe" from the runtime's point of+    view (e.g. they will not compromise memory safety or clobber internal runtime+    state), it is still ultimately the programmer's responsibility to ensure+    these invariants hold to guarantee predictable program behavior.++    In a similar vein, since each captured continuation includes the full local+    context of the suspended computation, it can safely be resumed arbitrarily+    many times without violating any invariants of the runtime system. However,+    use of these operations in an arbitrary 'IO' computation may be unsafe for+    other reasons, as most 'IO' code is not written with reentrancy in mind. For+    example, a computation suspended in the middle of reading a file will likely+    finish reading it when it is resumed; further attempts to resume from the+    same place would then fail because the file handle was already closed.++    In other words, although the RTS ensures that a computation's control state+    and local variables are properly restored for each distinct resumption of+    a continuation, it makes no attempt to duplicate any local state the+    computation may have been using (and could not possibly do so in general).+    Furthermore, it provides no mechanism for an arbitrary computation to+    protect itself against unwanted reentrancy (i.e. there is no analogue to+    Scheme's @dynamic-wind@). For those reasons, manipulating the continuation+    is only safe if the caller can be certain that doing so will not violate any+    expectations or invariants of the enclosing computation. }+------------------------------------------------------------------------++primtype PromptTag# a+   { See "GHC.Prim#continuations". }++primop  NewPromptTagOp "newPromptTag#" GenPrimOp+        State# RealWorld -> (# State# RealWorld, PromptTag# a #)+   { See "GHC.Prim#continuations". }+   with+   out_of_line = True+   effect = ReadWriteEffect++primop  PromptOp "prompt#" GenPrimOp+        PromptTag# a+     -> (State# RealWorld -> (# State# RealWorld, a #))+     -> State# RealWorld -> (# State# RealWorld, a #)+   { See "GHC.Prim#continuations". }+   with+   strictness = { \ _arity -> mkClosedDmdSig [topDmd, lazyApply1Dmd, topDmd] topDiv }+                 -- See Note [Strictness for catch-style primops]+   out_of_line = True+   effect = ReadWriteEffect++primop  Control0Op "control0#" GenPrimOp+        PromptTag# a+     -> (((State# RealWorld -> (# State# RealWorld, b_reppoly #))+          -> State# RealWorld -> (# State# RealWorld, a #))+         -> State# RealWorld -> (# State# RealWorld, a #))+     -> State# RealWorld -> (# State# RealWorld, b_reppoly #)+   { See "GHC.Prim#continuations". }+   with+   strictness = { \ _arity -> mkClosedDmdSig [topDmd, lazyApply2Dmd, topDmd] topDiv }+   out_of_line = True+   effect = ReadWriteEffect+   can_fail_warning = YesWarnCanFail++------------------------------------------------------------------------+section "STM-accessible Mutable Variables"+------------------------------------------------------------------------++primtype TVar# s a++primop  AtomicallyOp "atomically#" GenPrimOp+      (State# RealWorld -> (# State# RealWorld, a_levpoly #) )+   -> State# RealWorld -> (# State# RealWorld, a_levpoly #)+   with+   strictness  = { \ _arity -> mkClosedDmdSig [strictManyApply1Dmd,topDmd] topDiv }+                 -- See Note [Strict IO wrappers]+   out_of_line = True+   effect = ReadWriteEffect++-- NB: retry#'s strictness information specifies it to diverge.+-- This lets the compiler perform some extra simplifications, since retry#+-- will technically never return.+--+-- This allows the simplifier to replace things like:+--   case retry# s1+--     (# s2, a #) -> e+-- with:+--   retry# s1+-- where 'e' would be unreachable anyway.  See #8091.+primop  RetryOp "retry#" GenPrimOp+   State# RealWorld -> (# State# RealWorld, a_levpoly #)+   with+   strictness  = { \ _arity -> mkClosedDmdSig [topDmd] botDiv }+   out_of_line = True+   effect = ReadWriteEffect++primop  CatchRetryOp "catchRetry#" GenPrimOp+      (State# RealWorld -> (# State# RealWorld, a_levpoly #) )+   -> (State# RealWorld -> (# State# RealWorld, a_levpoly #) )+   -> (State# RealWorld -> (# State# RealWorld, a_levpoly #) )+   with+   strictness  = { \ _arity -> mkClosedDmdSig [ lazyApply1Dmd+                                                 , lazyApply1Dmd+                                                 , topDmd ] topDiv }+                 -- See Note [Strictness for catch-style primops]+   out_of_line = True+   effect = ReadWriteEffect++primop  CatchSTMOp "catchSTM#" GenPrimOp+      (State# RealWorld -> (# State# RealWorld, a_levpoly #) )+   -> (b -> State# RealWorld -> (# State# RealWorld, a_levpoly #) )+   -> (State# RealWorld -> (# State# RealWorld, a_levpoly #) )+   with+   strictness  = { \ _arity -> mkClosedDmdSig [ lazyApply1Dmd+                                                 , lazyApply2Dmd+                                                 , topDmd ] topDiv }+                 -- See Note [Strictness for catch-style primops]+   out_of_line = True+   effect = ReadWriteEffect++primop  NewTVarOp "newTVar#" GenPrimOp+       a_levpoly+    -> State# s -> (# State# s, TVar# s a_levpoly #)+   {Create a new 'TVar#' holding a specified initial value.}+   with+   out_of_line  = True+   effect = ReadWriteEffect++primop  ReadTVarOp "readTVar#" GenPrimOp+       TVar# s a_levpoly+    -> State# s -> (# State# s, a_levpoly #)+   {Read contents of 'TVar#' inside an STM transaction,+    i.e. within a call to 'atomically#'.+    Does not force evaluation of the result.}+   with+   out_of_line  = True+   effect = ReadWriteEffect++primop ReadTVarIOOp "readTVarIO#" GenPrimOp+       TVar# s a_levpoly+    -> State# s -> (# State# s, a_levpoly #)+   {Read contents of 'TVar#' outside an STM transaction.+   Does not force evaluation of the result.}+   with+   out_of_line      = True+   effect = ReadWriteEffect++primop  WriteTVarOp "writeTVar#" GenPrimOp+       TVar# s a_levpoly+    -> a_levpoly+    -> State# s -> State# s+   {Write contents of 'TVar#'.}+   with+   out_of_line      = True+   effect = ReadWriteEffect+++------------------------------------------------------------------------+section "Synchronized Mutable Variables"+        {Operations on 'MVar#'s. }+------------------------------------------------------------------------++primtype MVar# s a+        { A shared mutable variable (/not/ the same as a 'MutVar#'!).+        (Note: in a non-concurrent implementation, @('MVar#' a)@ can be+        represented by @('MutVar#' (Maybe a))@.) }++primop  NewMVarOp "newMVar#"  GenPrimOp+   State# s -> (# State# s, MVar# s a_levpoly #)+   {Create new 'MVar#'; initially empty.}+   with+   out_of_line = True+   effect = ReadWriteEffect++primop  TakeMVarOp "takeMVar#" GenPrimOp+   MVar# s a_levpoly -> State# s -> (# State# s, a_levpoly #)+   {If 'MVar#' is empty, block until it becomes full.+   Then remove and return its contents, and set it empty.}+   with+   out_of_line      = True+   effect = ReadWriteEffect++primop  TryTakeMVarOp "tryTakeMVar#" GenPrimOp+   MVar# s a_levpoly -> State# s -> (# State# s, Int#, a_levpoly #)+   {If 'MVar#' is empty, immediately return with integer 0 and value undefined.+   Otherwise, return with integer 1 and contents of 'MVar#', and set 'MVar#' empty.}+   with+   out_of_line      = True+   effect = ReadWriteEffect++primop  PutMVarOp "putMVar#" GenPrimOp+   MVar# s a_levpoly -> a_levpoly -> State# s -> State# s+   {If 'MVar#' is full, block until it becomes empty.+   Then store value arg as its new contents.}+   with+   out_of_line      = True+   effect = ReadWriteEffect++primop  TryPutMVarOp "tryPutMVar#" GenPrimOp+   MVar# s a_levpoly -> a_levpoly -> State# s -> (# State# s, Int# #)+   {If 'MVar#' is full, immediately return with integer 0.+    Otherwise, store value arg as 'MVar#''s new contents, and return with integer 1.}+   with+   out_of_line      = True+   effect = ReadWriteEffect++primop  ReadMVarOp "readMVar#" GenPrimOp+   MVar# s a_levpoly -> State# s -> (# State# s, a_levpoly #)+   {If 'MVar#' is empty, block until it becomes full.+   Then read its contents without modifying the MVar, without possibility+   of intervention from other threads.}+   with+   out_of_line      = True+   effect = ReadWriteEffect++primop  TryReadMVarOp "tryReadMVar#" GenPrimOp+   MVar# s a_levpoly -> State# s -> (# State# s, Int#, a_levpoly #)+   {If 'MVar#' is empty, immediately return with integer 0 and value undefined.+   Otherwise, return with integer 1 and contents of 'MVar#'.}+   with+   out_of_line      = True+   effect = ReadWriteEffect++primop  IsEmptyMVarOp "isEmptyMVar#" GenPrimOp+   MVar# s a_levpoly -> State# s -> (# State# s, Int# #)+   {Return 1 if 'MVar#' is empty; 0 otherwise.}+   with+   out_of_line = True+   effect = ReadWriteEffect+++------------------------------------------------------------------------+section "Delay/wait operations"+------------------------------------------------------------------------++primop  DelayOp "delay#" GenPrimOp+   Int# -> State# s -> State# s+   {Sleep specified number of microseconds.}+   with+   effect = ReadWriteEffect+   out_of_line      = True++primop  WaitReadOp "waitRead#" GenPrimOp+   Int# -> State# s -> State# s+   {Block until input is available on specified file descriptor.}+   with+   effect = ReadWriteEffect+   out_of_line      = True++primop  WaitWriteOp "waitWrite#" GenPrimOp+   Int# -> State# s -> State# s+   {Block until output is possible on specified file descriptor.}+   with+   effect = ReadWriteEffect+   out_of_line      = True++------------------------------------------------------------------------+section "Concurrency primitives"+------------------------------------------------------------------------++primtype State# s+        { 'State#' is the primitive, unlifted type of states.  It has+        one type parameter, thus @'State#' 'RealWorld'@, or @'State#' s@,+        where s is a type variable. The only purpose of the type parameter+        is to keep different state threads separate.  It is represented by+        nothing at all. }++primtype RealWorld+        { 'RealWorld' is deeply magical.  It is /primitive/, but it is not+        /unlifted/ (hence @ptrArg@).  We never manipulate values of type+        'RealWorld'; it's only used in the type system, to parameterise 'State#'. }++primtype ThreadId#+        {(In a non-concurrent implementation, this can be a singleton+        type, whose (unique) value is returned by 'myThreadId#'.  The+        other operations can be omitted.)}++primop  ForkOp "fork#" GenPrimOp+   (State# RealWorld -> (# State# RealWorld, a_reppoly #))+   -> State# RealWorld -> (# State# RealWorld, ThreadId# #)+   with+   effect = ReadWriteEffect+   out_of_line      = True+   strictness  = { \ _arity -> mkClosedDmdSig [ lazyApply1Dmd+                                              , topDmd ] topDiv }++primop  ForkOnOp "forkOn#" GenPrimOp+   Int# -> (State# RealWorld -> (# State# RealWorld, a_reppoly #))+   -> State# RealWorld -> (# State# RealWorld, ThreadId# #)+   with+   effect = ReadWriteEffect+   out_of_line      = True+   strictness  = { \ _arity -> mkClosedDmdSig [ topDmd+                                              , lazyApply1Dmd+                                              , topDmd ] topDiv }++primop  KillThreadOp "killThread#"  GenPrimOp+   ThreadId# -> a -> State# RealWorld -> State# RealWorld+   with+   effect = ReadWriteEffect+   out_of_line      = True++primop  YieldOp "yield#" GenPrimOp+   State# RealWorld -> State# RealWorld+   with+   effect = ReadWriteEffect+   out_of_line      = True++primop  MyThreadIdOp "myThreadId#" GenPrimOp+   State# RealWorld -> (# State# RealWorld, ThreadId# #)+   with+   effect = ReadWriteEffect++primop LabelThreadOp "labelThread#" GenPrimOp+   ThreadId# -> ByteArray# -> State# RealWorld -> State# RealWorld+   {Set the label of the given thread. The @ByteArray#@ should contain+    a UTF-8-encoded string.}+   with+   effect = ReadWriteEffect+   out_of_line      = True++primop  IsCurrentThreadBoundOp "isCurrentThreadBound#" GenPrimOp+   State# RealWorld -> (# State# RealWorld, Int# #)+   with+   out_of_line = True+   effect = ReadWriteEffect++primop  NoDuplicateOp "noDuplicate#" GenPrimOp+   State# s -> State# s+   with+   out_of_line = True+   effect = ReadWriteEffect++primop GetThreadLabelOp "threadLabel#" GenPrimOp+   ThreadId# -> State# RealWorld -> (# State# RealWorld, Int#, ByteArray# #)+   {Get the label of the given thread.+    Morally of type @ThreadId# -> IO (Maybe ByteArray#)@, with a @1#@ tag+    denoting @Just@.++    @since 0.10}+   with+   out_of_line      = True++primop  ThreadStatusOp "threadStatus#" GenPrimOp+   ThreadId# -> State# RealWorld -> (# State# RealWorld, Int#, Int#, Int# #)+   {Get the status of the given thread. Result is+    @(ThreadStatus, Capability, Locked)@ where+    @ThreadStatus@ is one of the status constants defined in+    @rts/Constants.h@, @Capability@ is the number of+    the capability which currently owns the thread, and+    @Locked@ is a boolean indicating whether the+    thread is bound to that capability.++    @since 0.9}+   with+   out_of_line = True+   effect = ReadWriteEffect++primop ListThreadsOp "listThreads#" GenPrimOp+   State# RealWorld -> (# State# RealWorld, Array# ThreadId# #)+   { Returns an array of the threads started by the program. Note that this+     threads which have finished execution may or may not be present in this+     list, depending upon whether they have been collected by the garbage collector.++     @since 0.10}+   with+   out_of_line = True+   effect = ReadWriteEffect++------------------------------------------------------------------------+section "Weak pointers"+------------------------------------------------------------------------++primtype Weak# b++primop  MkWeakOp "mkWeak#" GenPrimOp+   a_levpoly -> b_levpoly -> (State# RealWorld -> (# State# RealWorld, c #))+     -> State# RealWorld -> (# State# RealWorld, Weak# b_levpoly #)+   { @'mkWeak#' k v finalizer s@ creates a weak reference to value @k@,+     with an associated reference to some value @v@. If @k@ is still+     alive then @v@ can be retrieved using 'deRefWeak#'. Note that+     the type of @k@ must be represented by a pointer (i.e. of kind+     @'TYPE' ''LiftedRep' or @'TYPE' ''UnliftedRep'@). }+   with+   effect = ReadWriteEffect+   out_of_line      = True++primop  MkWeakNoFinalizerOp "mkWeakNoFinalizer#" GenPrimOp+   a_levpoly -> b_levpoly -> State# RealWorld -> (# State# RealWorld, Weak# b_levpoly #)+   with+   effect = ReadWriteEffect+   out_of_line      = True++primop  AddCFinalizerToWeakOp "addCFinalizerToWeak#" GenPrimOp+   Addr# -> Addr# -> Int# -> Addr# -> Weak# b_levpoly+          -> State# RealWorld -> (# State# RealWorld, Int# #)+   { @'addCFinalizerToWeak#' fptr ptr flag eptr w@ attaches a C+     function pointer @fptr@ to a weak pointer @w@ as a finalizer. If+     @flag@ is zero, @fptr@ will be called with one argument,+     @ptr@. Otherwise, it will be called with two arguments,+     @eptr@ and @ptr@. 'addCFinalizerToWeak#' returns+     1 on success, or 0 if @w@ is already dead. }+   with+   effect = ReadWriteEffect+   out_of_line      = True++primop  DeRefWeakOp "deRefWeak#" GenPrimOp+   Weak# a_levpoly -> State# RealWorld -> (# State# RealWorld, Int#, a_levpoly #)+   with+   effect = ReadWriteEffect+   out_of_line      = True++primop  FinalizeWeakOp "finalizeWeak#" GenPrimOp+   Weak# a_levpoly -> State# RealWorld -> (# State# RealWorld, Int#,+              (State# RealWorld -> (# State# RealWorld, b #) ) #)+   { Finalize a weak pointer. The return value is an unboxed tuple+     containing the new state of the world and an "unboxed Maybe",+     represented by an 'Int#' and a (possibly invalid) finalization+     action. An 'Int#' of @1@ indicates that the finalizer is valid. The+     return value @b@ from the finalizer should be ignored. }+   with+   effect = ReadWriteEffect+   out_of_line      = True++primop TouchOp "touch#" GenPrimOp+   a_levpoly -> State# s -> State# s+   with+   code_size = 0+   effect = ReadWriteEffect -- see Note [touch# has ReadWriteEffect]+   work_free = False+++-- Note [touch# has ReadWriteEffect]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- Although touch# emits no code, it is marked as ReadWriteEffect to+-- prevent it from being defeated by the optimizer:+--  * Discarding a touch# call would defeat its whole purpose.+--  * Strictly floating a touch# call out would shorten the lifetime+--    of the touched object, again defeating its purpose.+--  * Duplicating a touch# call might unpredictably extend the lifetime+--    of the touched object.  Although this would not defeat the purpose+--    of touch#, it seems undesirable.+--+-- In practice, this designation probably doesn't matter in most cases,+-- as touch# is usually tightly coupled with a "real" read or write effect.++------------------------------------------------------------------------+section "Stable pointers and names"+------------------------------------------------------------------------++primtype StablePtr# a++primtype StableName# a++primop  MakeStablePtrOp "makeStablePtr#" GenPrimOp+   a_levpoly -> State# RealWorld -> (# State# RealWorld, StablePtr# a_levpoly #)+   with+   effect = ReadWriteEffect+   out_of_line      = True++primop  DeRefStablePtrOp "deRefStablePtr#" GenPrimOp+   StablePtr# a_levpoly -> State# RealWorld -> (# State# RealWorld, a_levpoly #)+   with+   effect = ReadWriteEffect+   out_of_line      = True++primop  EqStablePtrOp "eqStablePtr#" GenPrimOp+   StablePtr# a_levpoly -> StablePtr# a_levpoly -> Int#+   with+   effect = ReadWriteEffect++primop  MakeStableNameOp "makeStableName#" GenPrimOp+   a_levpoly -> State# RealWorld -> (# State# RealWorld, StableName# a_levpoly #)+   with+   effect = ReadWriteEffect+   out_of_line      = True++primop  StableNameToIntOp "stableNameToInt#" GenPrimOp+   StableName# a_levpoly -> Int#++------------------------------------------------------------------------+section "Compact normal form"++        {Primitives for working with compact regions. The @ghc-compact@+         library and the @compact@ library demonstrate how to use these+         primitives. The documentation below draws a distinction between+         a CNF and a compact block. A CNF contains one or more compact+         blocks. The source file @rts\/sm\/CNF.c@+         diagrams this relationship. When discussing a compact+         block, an additional distinction is drawn between capacity and+         utilized bytes. The capacity is the maximum number of bytes that+         the compact block can hold. The utilized bytes is the number of+         bytes that are actually used by the compact block.+        }++------------------------------------------------------------------------++primtype Compact#++primop  CompactNewOp "compactNew#" GenPrimOp+   Word# -> State# RealWorld -> (# State# RealWorld, Compact# #)+   { Create a new CNF with a single compact block. The argument is+     the capacity of the compact block (in bytes, not words).+     The capacity is rounded up to a multiple of the allocator block size+     and is capped to one mega block. }+   with+   effect = ReadWriteEffect+   out_of_line      = True++primop  CompactResizeOp "compactResize#" GenPrimOp+   Compact# -> Word# -> State# RealWorld ->+   State# RealWorld+   { Set the new allocation size of the CNF. This value (in bytes)+     determines the capacity of each compact block in the CNF. It+     does not retroactively affect existing compact blocks in the CNF. }+   with+   effect = ReadWriteEffect+   out_of_line      = True++primop  CompactContainsOp "compactContains#" GenPrimOp+   Compact# -> a -> State# RealWorld -> (# State# RealWorld, Int# #)+   { Returns 1\# if the object is contained in the CNF, 0\# otherwise. }+   with+   out_of_line      = True++primop  CompactContainsAnyOp "compactContainsAny#" GenPrimOp+   a -> State# RealWorld -> (# State# RealWorld, Int# #)+   { Returns 1\# if the object is in any CNF at all, 0\# otherwise. }+   with+   out_of_line      = True++primop  CompactGetFirstBlockOp "compactGetFirstBlock#" GenPrimOp+   Compact# -> State# RealWorld -> (# State# RealWorld, Addr#, Word# #)+   { Returns the address and the utilized size (in bytes) of the+     first compact block of a CNF.}+   with+   out_of_line      = True++primop  CompactGetNextBlockOp "compactGetNextBlock#" GenPrimOp+   Compact# -> Addr# -> State# RealWorld -> (# State# RealWorld, Addr#, Word# #)+   { Given a CNF and the address of one its compact blocks, returns the+     next compact block and its utilized size, or 'nullAddr#' if the+     argument was the last compact block in the CNF. }+   with+   out_of_line      = True++primop  CompactAllocateBlockOp "compactAllocateBlock#" GenPrimOp+   Word# -> Addr# -> State# RealWorld -> (# State# RealWorld, Addr# #)+   { Attempt to allocate a compact block with the capacity (in+     bytes) given by the first argument. The 'Addr#' is a pointer+     to previous compact block of the CNF or 'nullAddr#' to create a+     new CNF with a single compact block.++     The resulting block is not known to the GC until+     'compactFixupPointers#' is called on it, and care must be taken+     so that the address does not escape or memory will be leaked.+   }+   with+   effect = ReadWriteEffect+   out_of_line      = True++primop  CompactFixupPointersOp "compactFixupPointers#" GenPrimOp+   Addr# -> Addr# -> State# RealWorld -> (# State# RealWorld, Compact#, Addr# #)+   { Given the pointer to the first block of a CNF and the+     address of the root object in the old address space, fix up+     the internal pointers inside the CNF to account for+     a different position in memory than when it was serialized.+     This method must be called exactly once after importing+     a serialized CNF. It returns the new CNF and the new adjusted+     root address. }+   with+   effect = ReadWriteEffect+   out_of_line      = True++primop CompactAdd "compactAdd#" GenPrimOp+   Compact# -> a -> State# RealWorld -> (# State# RealWorld, a #)+   { Recursively add a closure and its transitive closure to a+     'Compact#' (a CNF), evaluating any unevaluated components+     at the same time. Note: 'compactAdd#' is not thread-safe, so+     only one thread may call 'compactAdd#' with a particular+     'Compact#' at any given time. The primop does not+     enforce any mutual exclusion; the caller is expected to+     arrange this. }+   with+   effect = ReadWriteEffect+   out_of_line      = True++primop CompactAddWithSharing "compactAddWithSharing#" GenPrimOp+   Compact# -> a -> State# RealWorld -> (# State# RealWorld, a #)+   { Like 'compactAdd#', but retains sharing and cycles+   during compaction. }+   with+   effect = ReadWriteEffect+   out_of_line      = True++primop CompactSize "compactSize#" GenPrimOp+   Compact# -> State# RealWorld -> (# State# RealWorld, Word# #)+   { Return the total capacity (in bytes) of all the compact blocks+     in the CNF. }+   with+   effect = ReadWriteEffect+   out_of_line      = True++------------------------------------------------------------------------+section "Unsafe pointer equality"+--  (#1 Bad Guy: Alastair Reid :)+------------------------------------------------------------------------++primop  ReallyUnsafePtrEqualityOp "reallyUnsafePtrEquality#" GenPrimOp+   a_levpoly -> b_levpoly -> Int#+   { Returns @1#@ if the given pointers are equal and @0#@ otherwise. }+   with+   effect = CanFail -- See Note [reallyUnsafePtrEquality# CanFail]+   can_fail_warning = DoNotWarnCanFail++-- Note [Pointer comparison operations]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- The primop `reallyUnsafePtrEquality#` does a direct pointer+-- equality between two (boxed) values.  Several things to note:+--+-- (PE1) It is levity-polymorphic. It works for TYPE (BoxedRep Lifted) and+--       TYPE (BoxedRep Unlifted). But not TYPE IntRep, for example.+--       This levity-polymorphism comes from the use of the type variables+--       "a_levpoly" and "b_levpoly". See Note [Levity and representation polymorphic primops]+--+-- (PE2) It is hetero-typed; you can compare pointers of different types.+--       This is used in various packages such as containers & unordered-containers.+--+-- (PE3) It does not evaluate its arguments. The user of the primop is responsible+--       for doing so.  Consider+--            let { x = p+q; y = q+p } in reallyUnsafePtrEquality# x y+--       Here `x` and `y` point to different closures, so the expression will+--       probably return False; but if `x` and/or `y` were evaluated for some+--       other reason, then it might return True.+--+-- (PE4) It is obviously very dangerous, because replacing equals with equals+--       in the program can change the result.  For example+--           let x = f y in reallyUnsafePtrEquality# x x+--       will probably return True, whereas+--            reallyUnsafePtrEquality# (f y) (f y)+--       will probably return False. ("probably", because it's affected+--       by CSE and inlining).+--+-- (PE5) reallyUnsafePtrEquality# can't fail, but it is marked as such+--       to prevent it from floating out.+--       See Note [reallyUnsafePtrEquality# CanFail]+--+-- The library GHC.Prim.PtrEq (and GHC.Exts) provides+--+--   unsafePtrEquality# ::+--     forall (a :: UnliftedType) (b :: UnliftedType). a -> b -> Int#+--+-- It is still heterotyped (like (PE2)), but it's restricted to unlifted types+-- (unlike (PE1)).  That means that (PE3) doesn't apply: unlifted types are+-- always evaluated, which makes it a bit less unsafe.+--+-- However unsafePtrEquality# is /implemented/ by a call to+-- reallyUnsafePtrEquality#, so using the former is really just a documentation+-- hint to the reader of the code.  GHC behaves no differently.+--+-- The same library provides less Wild-West functions+-- for use in specific cases, namely:+--+--   reallyUnsafePtrEquality :: a -> a -> Int#  -- not levity-polymorphic, nor hetero-typed+--   sameArray# :: Array# a -> Array# a -> Int#+--   sameMutableArray# :: MutableArray# s a -> MutableArray# s a -> Int#+--   sameSmallArray# :: SmallArray# a -> SmallArray# a -> Int#+--   sameSmallMutableArray# :: SmallMutableArray# s a -> SmallMutableArray# s a -> Int#+--   sameByteArray# :: ByteArray# -> ByteArray# -> Int#+--   sameMutableByteArray# :: MutableByteArray# s -> MutableByteArray# s -> Int#+--   sameArrayArray# :: ArrayArray# -> ArrayArray# -> Int#+--   sameMutableArrayArray# :: MutableArrayArray# s -> MutableArrayArray# s -> Int#+--   sameMutVar# :: MutVar# s a -> MutVar# s a -> Int#+--   sameTVar# :: TVar# s a -> TVar# s a -> Int#+--   sameMVar# :: MVar# s a -> MVar# s a -> Int#+--   eqStableName# :: StableName# a -> StableName# b -> Int#+--+-- These operations are all specialisations of unsafePtrEquality#.++-- Note [reallyUnsafePtrEquality# CanFail]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- reallyUnsafePtrEquality# can't actually fail, per se, but we mark it+-- CanFail anyway. Until 5a9a1738023a, GHC considered primops okay for+-- speculation only when their arguments were known to be forced. This was+-- unnecessarily conservative, but it prevented reallyUnsafePtrEquality# from+-- floating out of places where its arguments were known to be forced.+-- Unfortunately, GHC could sometimes lose track of whether those arguments+-- were forced, leading to let-can-float invariant failures (see #13027 and the+-- discussion in #11444). Now that ok_for_speculation skips over lifted+-- arguments, we need to explicitly prevent reallyUnsafePtrEquality#+-- from floating out. Imagine if we had+--+--     \x y . case x of x'+--              DEFAULT ->+--            case y of y'+--              DEFAULT ->+--               let eq = reallyUnsafePtrEquality# x' y'+--               in ...+--+-- If the let floats out, we'll get+--+--     \x y . let eq = reallyUnsafePtrEquality# x y+--            in case x of ...+--+-- The trouble is that pointer equality between thunks is very different+-- from pointer equality between the values those thunks reduce to, and the latter+-- is typically much more precise.++------------------------------------------------------------------------+section "Parallelism"+------------------------------------------------------------------------++primop  ParOp "par#" GenPrimOp a -> Int#+   {Create a new spark evaluating the given argument.+    The return value should always be 1.+    Users are encouraged to use spark# instead.}+   with+      -- Note that Par is lazy to avoid that the sparked thing+      -- gets evaluated strictly, which it should *not* be+   effect = ReadWriteEffect+   code_size = { primOpCodeSizeForeignCall }+   -- `par#` was suppose to be deprecated in favor of `spark#` [1], however it+   -- wasn't clear how to replace it with `spark#` [2] and `par#` is still used+   -- to implement `GHC.Internal.Conc.Sync.par`. So we undeprecated it until+   -- everything is sorted out (see #24825).+   --+   -- [1] https://gitlab.haskell.org/ghc/ghc/-/issues/15227#note_154293+   -- [2] https://gitlab.haskell.org/ghc/ghc/-/merge_requests/5548#note_347791+   --+   -- deprecated_msg = { Use 'spark#' instead }++primop SparkOp "spark#" GenPrimOp+   a -> State# s -> (# State# s, a #)+   with effect = ReadWriteEffect+   code_size = { primOpCodeSizeForeignCall }++primop GetSparkOp "getSpark#" GenPrimOp+   State# s -> (# State# s, Int#, a #)+   with+   effect = ReadWriteEffect+   out_of_line = True++primop NumSparks "numSparks#" GenPrimOp+   State# s -> (# State# s, Int# #)+   { Returns the number of sparks in the local spark pool. }+   with+   effect = ReadWriteEffect+   out_of_line = True++++------------------------------------------------------------------------+section "Controlling object lifetime"+        {Ensuring that objects don't die a premature death.}+------------------------------------------------------------------------++-- See Note [keepAlive# magic] in GHC.CoreToStg.Prep.+primop KeepAliveOp "keepAlive#" GenPrimOp+   a_levpoly -> State# s -> (State# s -> b_reppoly) -> b_reppoly+   { @'keepAlive#' x s k@ keeps the value @x@ alive during the execution+     of the computation @k@.++     Note that the result type here isn't quite as unrestricted as the+     polymorphic type might suggest; see the section \"RuntimeRep polymorphism+     in continuation-style primops\" for details. }+   with+   out_of_line = True+   strictness = { \ _arity -> mkClosedDmdSig [topDmd, topDmd, strictOnceApply1Dmd] topDiv }+                 -- See Note [Strict IO wrappers]+   effect = ReadWriteEffect+   -- The invoked computation may have side effects+++------------------------------------------------------------------------+section "Tag to enum stuff"+        {Convert back and forth between values of enumerated types+        and small integers.}+------------------------------------------------------------------------++primop  DataToTagSmallOp "dataToTagSmall#" GenPrimOp+   a_levpoly -> Int#+   { Used internally to implement @dataToTag#@: Use that function instead!+     This one normally offers /no advantage/ and comes with no stability+     guarantees: it may change its type, its name, or its behavior+     with /no warning/ between compiler releases.++     It is expected that this function will be un-exposed in a future+     release of ghc.++     For more details, look at @Note [DataToTag overview]@+     in GHC.Tc.Instance.Class in the source code for+     /the specific compiler version you are using./+   }+   with+   deprecated_msg = { Use dataToTag# from \"GHC.Magic\" instead. }+   strictness = { \ _arity -> mkClosedDmdSig [evalDmd] topDiv }+   effect = ThrowsException+   cheap = True++primop  DataToTagLargeOp "dataToTagLarge#" GenPrimOp+   a_levpoly -> Int#+   { Used internally to implement @dataToTag#@: Use that function instead!+     This one offers /no advantage/ and comes with no stability+     guarantees: it may change its type, its name, or its behavior+     with /no warning/ between compiler releases.++     It is expected that this function will be un-exposed in a future+     release of ghc.++     For more details, look at @Note [DataToTag overview]@+     in GHC.Tc.Instance.Class in the source code for+     /the specific compiler version you are using./+   }+   with+   deprecated_msg = { Use dataToTag# from \"GHC.Magic\" instead. }+   strictness = { \ _arity -> mkClosedDmdSig [evalDmd] topDiv }+   effect = ThrowsException+   cheap = True++primop  TagToEnumOp "tagToEnum#" GenPrimOp+   Int# -> a+   with+   effect = CanFail++------------------------------------------------------------------------+section "Bytecode operations"+        {Support for manipulating bytecode objects used by the interpreter and+        linker.++        Bytecode objects are heap objects which represent top-level bindings and+        contain a list of instructions and data needed by these instructions.}+------------------------------------------------------------------------++primtype BCO+   { Primitive bytecode type. }++primop   AddrToAnyOp "addrToAny#" GenPrimOp+   Addr# -> (# a_levpoly #)+   { Convert an 'Addr#' to a followable Any type. }+   with+   code_size = 0++primop   AnyToAddrOp "anyToAddr#" GenPrimOp+   a -> State# RealWorld -> (# State# RealWorld, Addr# #)+   { Retrieve the address of any Haskell value. This is+     essentially an 'unsafeCoerce#', but if implemented as such+     the core lint pass complains and fails to compile.+     As a primop, it is opaque to core/stg, and only appears+     in cmm (where the copy propagation pass will get rid of it).+     Note that "a" must be a value, not a thunk! It's too late+     for strictness analysis to enforce this, so you're on your+     own to guarantee this. Also note that 'Addr#' is not a GC+     pointer - up to you to guarantee that it does not become+     a dangling pointer immediately after you get it.}+   with+   code_size = 0++primop   MkApUpd0_Op "mkApUpd0#" GenPrimOp+   BCO -> (# a #)+   { Wrap a BCO in a @AP_UPD@ thunk which will be updated with the value of+     the BCO when evaluated. }+   with+   out_of_line = True++primop  NewBCOOp "newBCO#" GenPrimOp+   ByteArray# -> ByteArray# -> Array# a -> Int# -> ByteArray# -> State# s -> (# State# s, BCO #)+   { @'newBCO#' instrs lits ptrs arity bitmap@ creates a new bytecode object. The+     resulting object encodes a function of the given arity with the instructions+     encoded in @instrs@, and a static reference table usage bitmap given by+     @bitmap@. }+   with+   effect = ReadWriteEffect+   out_of_line      = True++primop  UnpackClosureOp "unpackClosure#" GenPrimOp+   a -> (# Addr#, ByteArray#, Array# b #)+   { @'unpackClosure#' closure@ copies the closure and pointers in the+     payload of the given closure into two new arrays, and returns a pointer to+     the first word of the closure's info table, a non-pointer array for the raw+     bytes of the closure, and a pointer array for the pointers in the payload. }+   with+   out_of_line = True++primop  ClosureSizeOp "closureSize#" GenPrimOp+   a -> Int#+   { @'closureSize#' closure@ returns the size of the given closure in+     machine words. }+   with+   out_of_line = True++primop  GetApStackValOp "getApStackVal#" GenPrimOp+   a -> Int# -> (# Int#, b #)+   with+   out_of_line = True++------------------------------------------------------------------------+section "Misc"+        {These aren't nearly as wired in as Etc...}+------------------------------------------------------------------------++primop  GetCCSOfOp "getCCSOf#" GenPrimOp+   a -> State# s -> (# State# s, Addr# #)++primop  GetCurrentCCSOp "getCurrentCCS#" GenPrimOp+   a -> State# s -> (# State# s, Addr# #)+   { Returns the current 'CostCentreStack' (value is @NULL@ if+     not profiling).  Takes a dummy argument which can be used to+     avoid the call to 'getCurrentCCS#' being floated out by the+     simplifier, which would result in an uninformative stack+     ("CAF"). }++primop  ClearCCSOp "clearCCS#" GenPrimOp+   (State# s -> (# State# s, a #)) -> State# s -> (# State# s, a #)+   { Run the supplied IO action with an empty CCS.  For example, this+     is used by the interpreter to run an interpreted computation+     without the call stack showing that it was invoked from GHC. }+   with+   out_of_line = True++------------------------------------------------------------------------+section "Annotating call stacks"+------------------------------------------------------------------------++primop AnnotateStackOp "annotateStack#" GenPrimOp+   b -> (State# s -> (# State# s, a_reppoly #)) -> State# s -> (# State# s, a_reppoly #)+   { Pushes an annotation frame to the stack which can be reported by backtraces. }+   with+   out_of_line = True++------------------------------------------------------------------------+section "Info Table Origin"+------------------------------------------------------------------------+primop WhereFromOp "whereFrom#" GenPrimOp+   a -> Addr# -> State# s -> (# State# s, Int# #)+   { Fills the given buffer with the @InfoProvEnt@ for the info table of the+     given object. Returns @1#@ on success and @0#@ otherwise.}+   with+   out_of_line = True++------------------------------------------------------------------------+section "Etc"+        {Miscellaneous built-ins}+------------------------------------------------------------------------++primtype FUN m a b+  {The builtin function type, written in infix form as @a % m -> b@.+   Values of this type are functions taking inputs of type @a@ and+   producing outputs of type @b@. The multiplicity of the input is+   @m@.++   Note that @'FUN' m a b@ permits representation polymorphism in both+   @a@ and @b@, so that types like @'Int#' -> 'Int#'@ can still be+   well-kinded.+  }++pseudoop "realWorld#"+   State# RealWorld+   { The token used in the implementation of the IO monad as a state monad.+     It does not pass any information at runtime.+     See also 'GHC.Magic.runRW#'. }++pseudoop "void#"+   (# #)+   { This is an alias for the unboxed unit tuple constructor.+     In earlier versions of GHC, 'void#' was a value+     of the primitive type 'Void#', which is now defined to be @(# #)@.+   }+   with deprecated_msg = { Use an unboxed unit tuple instead }++primtype Proxy# a+   { The type constructor 'Proxy#' is used to bear witness to some+   type variable. It's used when you want to pass around proxy values+   for doing things like modelling type applications. A 'Proxy#'+   is not only unboxed, it also has a polymorphic kind, and has no+   runtime representation, being totally free. }++pseudoop "proxy#"+   Proxy# a+   { Witness for an unboxed 'Proxy#' value, which has no runtime+   representation. }++pseudoop   "seq"+   a -> b_reppoly -> b_reppoly+   { The value of @'seq' a b@ is bottom if @a@ is bottom, and+     otherwise equal to @b@. In other words, it evaluates the first+     argument @a@ to weak head normal form (WHNF). 'seq' is usually+     introduced to improve performance by avoiding unneeded laziness.++     A note on evaluation order: the expression @'seq' a b@ does+     /not/ guarantee that @a@ will be evaluated before @b@.+     The only guarantee given by 'seq' is that the both @a@+     and @b@ will be evaluated before 'seq' returns a value.+     In particular, this means that @b@ may be evaluated before+     @a@. If you need to guarantee a specific order of evaluation,+     you must use the function 'pseq' from the "parallel" package. }+   with fixity = infixr 0+         -- This fixity is only the one picked up by Haddock. If you+         -- change this, do update 'ghcPrimIface' in 'GHC.Iface.Load'.++primop  TraceEventOp "traceEvent#" GenPrimOp+   Addr# -> State# s -> State# s+   { Emits an event via the RTS tracing framework.  The contents+     of the event is the zero-terminated byte string passed as the first+     argument.  The event will be emitted either to the @.eventlog@ file,+     or to stderr, depending on the runtime RTS flags. }+   with+   effect = ReadWriteEffect+   out_of_line      = True++primop  TraceEventBinaryOp "traceBinaryEvent#" GenPrimOp+   Addr# -> Int# -> State# s -> State# s+   { Emits an event via the RTS tracing framework.  The contents+     of the event is the binary object passed as the first argument with+     the given length passed as the second argument. The event will be+     emitted to the @.eventlog@ file. }+   with+   effect = ReadWriteEffect+   out_of_line      = True++primop  TraceMarkerOp "traceMarker#" GenPrimOp+   Addr# -> State# s -> State# s+   { Emits a marker event via the RTS tracing framework.  The contents+     of the event is the zero-terminated byte string passed as the first+     argument.  The event will be emitted either to the @.eventlog@ file,+     or to stderr, depending on the runtime RTS flags. }+   with+   effect = ReadWriteEffect+   out_of_line      = True++primop  SetThreadAllocationCounter "setThreadAllocationCounter#" GenPrimOp+   Int64# -> State# RealWorld -> State# RealWorld+   { Sets the allocation counter for the current thread to the given value. }+   with+   effect = ReadWriteEffect+   out_of_line      = True++primop  SetOtherThreadAllocationCounter "setOtherThreadAllocationCounter#" GenPrimOp+   Int64# -> ThreadId# -> State# RealWorld -> State# RealWorld+   { Sets the allocation counter for the another thread to the given value.+     This doesn't take allocations into the current nursery chunk into account.+     Therefore it is only accurate if the other thread is not currently running. }+   with+   effect = ReadWriteEffect+   out_of_line      = True++primtype StackSnapshot#+   { Haskell representation of a @StgStack*@ that was created (cloned)+     with a function in "GHC.Stack.CloneStack". Please check the+     documentation in that module for more detailed explanations. }++------------------------------------------------------------------------+section "Safe coercions"+------------------------------------------------------------------------++pseudoop   "coerce"+   Coercible a b => a -> b+   { The function 'coerce' allows you to safely convert between values of+     types that have the same representation with no run-time overhead. In the+     simplest case you can use it instead of a newtype constructor, to go from+     the newtype's concrete type to the abstract type. But it also works in+     more complicated settings, e.g. converting a list of newtypes to a list of+     concrete types.++     When used in conversions involving a newtype wrapper,+     make sure the newtype constructor is in scope.++     This function is representation-polymorphic, but the+     'RuntimeRep' type argument is marked as 'Inferred', meaning+     that it is not available for visible type application. This means+     the typechecker will accept @'coerce' \@'Int' \@Age 42@.++     === __Examples__++     >>> newtype TTL = TTL Int deriving (Eq, Ord, Show)+     >>> newtype Age = Age Int deriving (Eq, Ord, Show)+     >>> coerce (Age 42) :: TTL+     TTL 42+     >>> coerce (+ (1 :: Int)) (Age 42) :: TTL+     TTL 43+     >>> coerce (map (+ (1 :: Int))) [Age 42, Age 24] :: [TTL]+     [TTL 43,TTL 25]++   }++------------------------------------------------------------------------+section "SIMD Vectors"+        {Operations on SIMD vectors.}+------------------------------------------------------------------------++#define ALL_VECTOR_TYPES \+  [<Int8,Int8#,16>,<Int16,Int16#,8>,<Int32,Int32#,4>,<Int64,Int64#,2> \+  ,<Int8,Int8#,32>,<Int16,Int16#,16>,<Int32,Int32#,8>,<Int64,Int64#,4> \+  ,<Int8,Int8#,64>,<Int16,Int16#,32>,<Int32,Int32#,16>,<Int64,Int64#,8> \+  ,<Word8,Word8#,16>,<Word16,Word16#,8>,<Word32,Word32#,4>,<Word64,Word64#,2> \+  ,<Word8,Word8#,32>,<Word16,Word16#,16>,<Word32,Word32#,8>,<Word64,Word64#,4> \+  ,<Word8,Word8#,64>,<Word16,Word16#,32>,<Word32,Word32#,16>,<Word64,Word64#,8> \+  ,<Float,Float#,4>,<Double,Double#,2> \+  ,<Float,Float#,8>,<Double,Double#,4> \+  ,<Float,Float#,16>,<Double,Double#,8>]++#define SIGNED_VECTOR_TYPES \+  [<Int8,Int8#,16>,<Int16,Int16#,8>,<Int32,Int32#,4>,<Int64,Int64#,2> \+  ,<Int8,Int8#,32>,<Int16,Int16#,16>,<Int32,Int32#,8>,<Int64,Int64#,4> \+  ,<Int8,Int8#,64>,<Int16,Int16#,32>,<Int32,Int32#,16>,<Int64,Int64#,8> \+  ,<Float,Float#,4>,<Double,Double#,2> \+  ,<Float,Float#,8>,<Double,Double#,4> \+  ,<Float,Float#,16>,<Double,Double#,8>]++#define FLOAT_VECTOR_TYPES \+  [<Float,Float#,4>,<Double,Double#,2> \+  ,<Float,Float#,8>,<Double,Double#,4> \+  ,<Float,Float#,16>,<Double,Double#,8>]++#define INT_VECTOR_TYPES \+  [<Int8,Int8#,16>,<Int16,Int16#,8>,<Int32,Int32#,4>,<Int64,Int64#,2> \+  ,<Int8,Int8#,32>,<Int16,Int16#,16>,<Int32,Int32#,8>,<Int64,Int64#,4> \+  ,<Int8,Int8#,64>,<Int16,Int16#,32>,<Int32,Int32#,16>,<Int64,Int64#,8> \+  ,<Word8,Word8#,16>,<Word16,Word16#,8>,<Word32,Word32#,4>,<Word64,Word64#,2> \+  ,<Word8,Word8#,32>,<Word16,Word16#,16>,<Word32,Word32#,8>,<Word64,Word64#,4> \+  ,<Word8,Word8#,64>,<Word16,Word16#,32>,<Word32,Word32#,16>,<Word64,Word64#,8>]++primtype VECTOR+   with vector = ALL_VECTOR_TYPES++primop VecBroadcastOp "broadcast#" GenPrimOp+   SCALAR -> VECTOR+   { Broadcast a scalar to all elements of a vector. }+   with vector = ALL_VECTOR_TYPES++primop VecPackOp "pack#" GenPrimOp+   VECTUPLE -> VECTOR+   { Pack the elements of an unboxed tuple into a vector. }+   with vector = ALL_VECTOR_TYPES++primop VecUnpackOp "unpack#" GenPrimOp+   VECTOR -> VECTUPLE+   { Unpack the elements of a vector into an unboxed tuple. }+   with vector = ALL_VECTOR_TYPES++primop VecInsertOp "insert#" GenPrimOp+   VECTOR -> SCALAR -> Int# -> VECTOR+   { Insert a scalar at the given position in a vector.+     The position must be a compile-time constant. }+   with effect = CanFail+        vector = ALL_VECTOR_TYPES++primop VecAddOp "plus#" GenPrimOp+   VECTOR -> VECTOR -> VECTOR+   { Add two vectors element-wise. }+   with commutable = True+        vector = ALL_VECTOR_TYPES++primop VecSubOp "minus#" GenPrimOp+   VECTOR -> VECTOR -> VECTOR+   { Subtract two vectors element-wise. }+   with vector = ALL_VECTOR_TYPES++primop VecMulOp "times#" GenPrimOp+   VECTOR -> VECTOR -> VECTOR+   { Multiply two vectors element-wise. }+   with commutable = True+        vector = ALL_VECTOR_TYPES++primop VecDivOp "divide#" GenPrimOp+   VECTOR -> VECTOR -> VECTOR+   { Divide two vectors element-wise. }+   with effect = CanFail+        vector = FLOAT_VECTOR_TYPES++primop VecQuotOp "quot#" GenPrimOp+   VECTOR -> VECTOR -> VECTOR+   { Rounds towards zero element-wise.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. }+   with effect = CanFail+        vector = INT_VECTOR_TYPES+        div_like = True++primop VecRemOp "rem#" GenPrimOp+   VECTOR -> VECTOR -> VECTOR+   { Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@.++     Note: Most CPU ISAs do not contain any SIMD integer division instructions.+     Do not expect high performance. }+   with effect = CanFail+        vector = INT_VECTOR_TYPES+        div_like = True+++primop VecNegOp "negate#" GenPrimOp+   VECTOR -> VECTOR+   { Negate element-wise. }+   with vector = SIGNED_VECTOR_TYPES++primop VecIndexByteArrayOp "indexArray#" GenPrimOp+   ByteArray# -> Int# -> VECTOR+   { Read a vector from the specified index of an immutable array.+     The index is counted in units of SIMD vectors (not scalar elements). }+   with effect = CanFail+        vector = ALL_VECTOR_TYPES++primop VecReadByteArrayOp "readArray#" GenPrimOp+   MutableByteArray# s -> Int# -> State# s -> (# State# s, VECTOR #)+   { Read a vector from the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). }+   with effect = ReadWriteEffect+        can_fail_warning = YesWarnCanFail+        vector = ALL_VECTOR_TYPES++primop VecWriteByteArrayOp "writeArray#" GenPrimOp+   MutableByteArray# s -> Int# -> VECTOR -> State# s -> State# s+   { Write a vector to the specified index of a mutable array.+     The index is counted in units of SIMD vectors (not scalar elements). }+   with effect = ReadWriteEffect+        can_fail_warning = YesWarnCanFail+        vector = ALL_VECTOR_TYPES++primop VecIndexOffAddrOp "indexOffAddr#" GenPrimOp+   Addr# -> Int# -> VECTOR+   { Reads vector; offset in units of SIMD vectors (not scalar elements). }+   with effect = CanFail+        vector = ALL_VECTOR_TYPES++primop VecReadOffAddrOp "readOffAddr#" GenPrimOp+   Addr# -> Int# -> State# s -> (# State# s, VECTOR #)+   { Reads vector; offset in units of SIMD vectors (not scalar elements). }+   with effect = ReadWriteEffect+        can_fail_warning = YesWarnCanFail+        vector = ALL_VECTOR_TYPES++primop VecWriteOffAddrOp "writeOffAddr#" GenPrimOp+   Addr# -> Int# -> VECTOR -> State# s -> State# s+   { Write vector; offset in units of SIMD vectors (not scalar elements). }+   with effect = ReadWriteEffect+        can_fail_warning = YesWarnCanFail+        vector = ALL_VECTOR_TYPES+++primop VecIndexScalarByteArrayOp "indexArrayAs#" GenPrimOp+   ByteArray# -> Int# -> VECTOR+   { Read a vector from specified index of immutable array of scalars; offset is in scalar elements. }+   with effect = CanFail+        vector = ALL_VECTOR_TYPES++primop VecReadScalarByteArrayOp "readArrayAs#" GenPrimOp+   MutableByteArray# s -> Int# -> State# s -> (# State# s, VECTOR #)+   { Read a vector from specified index of mutable array of scalars; offset is in scalar elements. }+   with effect = ReadWriteEffect+        can_fail_warning = YesWarnCanFail+        vector = ALL_VECTOR_TYPES++primop VecWriteScalarByteArrayOp "writeArrayAs#" GenPrimOp+   MutableByteArray# s -> Int# -> VECTOR -> State# s -> State# s+   { Write a vector to specified index of mutable array of scalars; offset is in scalar elements. }+   with effect = ReadWriteEffect+        can_fail_warning = YesWarnCanFail+        vector = ALL_VECTOR_TYPES++primop VecIndexScalarOffAddrOp "indexOffAddrAs#" GenPrimOp+   Addr# -> Int# -> VECTOR+   { Reads vector; offset in scalar elements. }+   with effect = CanFail+        vector = ALL_VECTOR_TYPES++primop VecReadScalarOffAddrOp "readOffAddrAs#" GenPrimOp+   Addr# -> Int# -> State# s -> (# State# s, VECTOR #)+   { Reads vector; offset in scalar elements. }+   with effect = ReadWriteEffect+        can_fail_warning = YesWarnCanFail+        vector = ALL_VECTOR_TYPES++primop VecWriteScalarOffAddrOp "writeOffAddrAs#" GenPrimOp+   Addr# -> Int# -> VECTOR -> State# s -> State# s+   { Write vector; offset in scalar elements. }+   with effect = ReadWriteEffect+        can_fail_warning = YesWarnCanFail+        vector = ALL_VECTOR_TYPES++primop   VecFMAdd   "fmadd#" GenPrimOp+   VECTOR -> VECTOR -> VECTOR -> VECTOR+   {Fused multiply-add operation @x*y+z@. See "GHC.Prim#fma".}+   with+      vector = FLOAT_VECTOR_TYPES+primop   VecFMSub   "fmsub#" GenPrimOp+   VECTOR -> VECTOR -> VECTOR -> VECTOR+   {Fused multiply-subtract operation @x*y-z@. See "GHC.Prim#fma".}+   with+      vector = FLOAT_VECTOR_TYPES+primop   VecFNMAdd   "fnmadd#" GenPrimOp+   VECTOR -> VECTOR -> VECTOR -> VECTOR+   {Fused negate-multiply-add operation @-x*y+z@. See "GHC.Prim#fma".}+   with+      vector = FLOAT_VECTOR_TYPES+primop   VecFNMSub   "fnmsub#" GenPrimOp+   VECTOR -> VECTOR -> VECTOR -> VECTOR+   {Fused negate-multiply-subtract operation @-x*y-z@. See "GHC.Prim#fma".}+   with+      vector = FLOAT_VECTOR_TYPES++primop VecShuffleOp "shuffle#" GenPrimOp+  VECTOR -> VECTOR -> INTVECTUPLE -> VECTOR+  {Shuffle elements of the concatenation of the input two vectors+  into the result vector. The indices must be compile-time constants.}+   with vector = ALL_VECTOR_TYPES++primop VecMinOp "min#" GenPrimOp+   VECTOR -> VECTOR -> VECTOR+   {Component-wise minimum of two vectors.}+   with+      vector = ALL_VECTOR_TYPES++primop VecMaxOp "max#" GenPrimOp+   VECTOR -> VECTOR -> VECTOR+   {Component-wise maximum of two vectors.}+   with+      vector = ALL_VECTOR_TYPES++------------------------------------------------------------------------++section "Prefetch"+        {Prefetch operations: Note how every prefetch operation has a name+  with the pattern prefetch*N#, where N is either 0,1,2, or 3.++  This suffix number, N, is the "locality level" of the prefetch, following the+  convention in GCC and other compilers.+  Higher locality numbers correspond to the memory being loaded in more+  levels of the cpu cache, and being retained after initial use. The naming+  convention follows the naming convention of the prefetch intrinsic found+  in the GCC and Clang C compilers.++  On the LLVM backend, prefetch*N# uses the LLVM prefetch intrinsic+  with locality level N. The code generated by LLVM is target architecture+  dependent, but should agree with the GHC NCG on x86 systems.++  On the PPC native backend, prefetch*N is a No-Op.++  On the x86 NCG, N=0 will generate prefetchNTA,+  N=1 generates prefetcht2, N=2 generates prefetcht1, and+  N=3 generates prefetcht0.++  For streaming workloads, the prefetch*0 operations are recommended.+  For workloads which do many reads or writes to a memory location in a short period of time,+  prefetch*3 operations are recommended.++  For further reading about prefetch and associated systems performance optimization,+  the instruction set and optimization manuals by Intel and other CPU vendors are+  excellent starting place.+++  The "Intel 64 and IA-32 Architectures Optimization Reference Manual" is+  especially a helpful read, even if your software is meant for other CPU+  architectures or vendor hardware. The manual can be found at+  http://www.intel.com/content/www/us/en/architecture-and-technology/64-ia-32-architectures-optimization-manual.html .++  The @prefetch*@ family of operations has the order of operations+  determined by passing around the 'State#' token.++  To get a "pure" version of these operations, use 'inlinePerformIO' which is quite safe in this context.++  It is important to note that while the prefetch operations will never change the+  answer to a pure computation, They CAN change the memory locations resident+  in a CPU cache and that may change the performance and timing characteristics+  of an application. The prefetch operations are marked as ReadWriteEffect+  to reflect that these operations have side effects with respect to the runtime+  performance characteristics of the resulting code. Additionally, if the prefetchValue+  operations did not have this attribute, GHC does a float out transformation that+  results in a let-can-float invariant violation, at least with the current design.+  }++++------------------------------------------------------------------------+++--- the Int# argument for prefetch is the byte offset on the byteArray or  Addr#++---+primop PrefetchByteArrayOp3 "prefetchByteArray3#" GenPrimOp+  ByteArray# -> Int# ->  State# s -> State# s+  with effect = ReadWriteEffect++primop PrefetchMutableByteArrayOp3 "prefetchMutableByteArray3#" GenPrimOp+  MutableByteArray# s -> Int# -> State# s -> State# s+  with effect = ReadWriteEffect++primop PrefetchAddrOp3 "prefetchAddr3#" GenPrimOp+  Addr# -> Int# -> State# s -> State# s+  with effect = ReadWriteEffect++primop PrefetchValueOp3 "prefetchValue3#" GenPrimOp+   a -> State# s -> State# s+   with effect = ReadWriteEffect+----++primop PrefetchByteArrayOp2 "prefetchByteArray2#" GenPrimOp+  ByteArray# -> Int# ->  State# s -> State# s+  with effect = ReadWriteEffect++primop PrefetchMutableByteArrayOp2 "prefetchMutableByteArray2#" GenPrimOp+  MutableByteArray# s -> Int# -> State# s -> State# s+  with effect = ReadWriteEffect++primop PrefetchAddrOp2 "prefetchAddr2#" GenPrimOp+  Addr# -> Int# ->  State# s -> State# s+  with effect = ReadWriteEffect++primop PrefetchValueOp2 "prefetchValue2#" GenPrimOp+   a ->  State# s -> State# s+   with effect = ReadWriteEffect+----++primop PrefetchByteArrayOp1 "prefetchByteArray1#" GenPrimOp+   ByteArray# -> Int# -> State# s -> State# s+   with effect = ReadWriteEffect++primop PrefetchMutableByteArrayOp1 "prefetchMutableByteArray1#" GenPrimOp+  MutableByteArray# s -> Int# -> State# s -> State# s+  with effect = ReadWriteEffect++primop PrefetchAddrOp1 "prefetchAddr1#" GenPrimOp+  Addr# -> Int# -> State# s -> State# s+  with effect = ReadWriteEffect++primop PrefetchValueOp1 "prefetchValue1#" GenPrimOp+   a -> State# s -> State# s+   with effect = ReadWriteEffect+----++primop PrefetchByteArrayOp0 "prefetchByteArray0#" GenPrimOp+  ByteArray# -> Int# ->  State# s -> State# s+  with effect = ReadWriteEffect++primop PrefetchMutableByteArrayOp0 "prefetchMutableByteArray0#" GenPrimOp+  MutableByteArray# s -> Int# -> State# s -> State# s+  with effect = ReadWriteEffect++primop PrefetchAddrOp0 "prefetchAddr0#" GenPrimOp+  Addr# -> Int# -> State# s -> State# s+  with effect = ReadWriteEffect++primop PrefetchValueOp0 "prefetchValue0#" GenPrimOp+   a -> State# s -> State# s+   with effect = ReadWriteEffect+++-- Note [RuntimeRep polymorphism in continuation-style primops]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--  See below.++section "RuntimeRep polymorphism in continuation-style primops"+  {+  Several primops provided by GHC accept continuation arguments with highly polymorphic+  arguments. For instance, consider the type of `catch#`:++    catch# :: forall (r_rep :: RuntimeRep) (r :: TYPE r_rep) w.+              (State# RealWorld -> (# State# RealWorld, r #) )+           -> (w -> State# RealWorld -> (# State# RealWorld, r #) )+           -> State# RealWorld+           -> (# State# RealWorld, r #)++  This type suggests that we could instantiate `catch#` continuation argument+  (namely, the first argument) with something like,++    f :: State# RealWorld -> (# State# RealWorld, (# Int, String, Int8# #) #)++  However, sadly the type does not capture an important limitation of the+  primop. Specifically, due to the operational behavior of `catch#` the result+  type must be representable with a single machine word. In a future GHC+  release we may improve the precision of this type to capture this limitation.++  See #21868.+  }  ------------------------------------------------------------------------ ---                                                                  ---
GHC/ByteCode/Asm.hs view
@@ -1,649 +1,1044 @@ {-# LANGUAGE CPP             #-} {-# LANGUAGE DeriveFunctor   #-} {-# LANGUAGE RecordWildCards #-}-{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-}------  (c) The University of Glasgow 2002-2006------- | Bytecode assembler and linker-module GHC.ByteCode.Asm (-        assembleBCOs, assembleOneBCO,-        bcoFreeNames,-        SizedSeq, sizeSS, ssElts,-        iNTERP_STACK_CHECK_THRESH,-        mkTupleInfoLit-  ) where--import GHC.Prelude--import GHC.ByteCode.Instr-import GHC.ByteCode.InfoTable-import GHC.ByteCode.Types-import GHCi.RemoteTypes-import GHC.Runtime.Interpreter-import GHC.Runtime.Heap.Layout hiding ( WordOff )--import GHC.Types.Name-import GHC.Types.Name.Set-import GHC.Types.Literal-import GHC.Types.Unique-import GHC.Types.Unique.DSet--import GHC.Utils.Outputable-import GHC.Utils.Panic-import GHC.Utils.Panic.Plain--import GHC.Core.TyCon-import GHC.Data.FastString-import GHC.Data.SizedSeq--import GHC.StgToCmm.Layout     ( ArgRep(..) )-import GHC.Cmm.Expr-import GHC.Cmm.CallConv        ( tupleRegsCover )-import GHC.Platform-import GHC.Platform.Profile--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 hiding (shiftL, shiftR)-import Data.Char        ( ord )-import Data.List        ( genericLength )-import Data.Map.Strict (Map)-import Data.Maybe (fromMaybe)-import qualified Data.Map.Strict 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-  :: Interp-  -> Profile-  -> [ProtoBCO Name]-  -> [TyCon]-  -> [RemotePtr ()]-  -> Maybe ModBreaks-  -> IO CompiledByteCode-assembleBCOs interp profile proto_bcos tycons top_strs modbreaks = do-  -- TODO: the profile should be bundled with the interpreter: the rts ways are-  -- fixed for an interpreter-  itblenv <- mkITbls interp profile tycons-  bcos    <- mapM (assembleBCO (profilePlatform profile)) proto_bcos-  (bcos',ptrs) <- mallocStrings interp bcos-  return CompiledByteCode-    { bc_bcos = bcos'-    , bc_itbls =  itblenv-    , bc_ffis = concatMap 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 :: Interp -> [UnlinkedBCO] -> IO ([UnlinkedBCO], [RemotePtr ()])-mallocStrings interp ulbcos = do-  let bytestrings = reverse (execState (mapM_ collect ulbcos) [])-  ptrs <- interpCmd interp (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-    rptrs <- get-    case rptrs of-      (RemotePtr p : rest) -> do-        put rest-        return (BCONPtrWord (fromIntegral p))-      _ -> panic "mallocStrings:spliceLit"-  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 :: Interp -> Profile -> ProtoBCO Name -> IO UnlinkedBCO-assembleOneBCO interp profile pbco = do-  -- TODO: the profile should be bundled with the interpreter: the rts ways are-  -- fixed for an interpreter-  ubco <- assembleBCO (profilePlatform profile) pbco-  ([ubco'], _ptrs) <- mallocStrings interp [ubco]-  return ubco'--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 asm = mapM_ (assembleI platform) 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 platform False initial_offset asm-      ((n_insns, lbl_map), long_jumps)-        | isLarge (fromIntegral $ Map.size lbl_map0)-          || isLarge n_insns0-                    = (inspectAsm platform True initial_offset asm, True)-        | otherwise = ((n_insns0, lbl_map0), False)--      env :: LocalLabel -> 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 platform long_jumps env asm--  -- precomputed size should be equal to final size-  massert (n_insns == sizeSS final_insns)--  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 Word64--- 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 LocalLabel--- (unused)  | LargeOp Word--data Assembler a-  = AllocPtr (IO BCOPtr) (Word -> Assembler a)-  | AllocLit [BCONPtr] (Word -> Assembler a)-  | AllocLabel LocalLabel (Assembler a)-  | Emit Word16 [Operand] (Assembler a)-  | NullAsm a-  deriving (Functor)--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 :: LocalLabel -> Assembler ()-label w = AllocLabel w (return ())--emit :: Word16 -> [Operand] -> Assembler ()-emit w ops = Emit w ops (return ())--type LabelEnv = LocalLabel -> Word--largeOp :: Bool -> Operand -> Bool-largeOp long_jumps op = case op of-   SmallOp _ -> False-   Op w      -> isLarge w-   LabelOp _ -> long_jumps--- LargeOp _ -> True--runAsm :: Platform -> Bool -> LabelEnv -> Assembler a -> StateT AsmState IO a-runAsm platform 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 platform w else [fromIntegral w]---        expand (LargeOp w) = largeArg platform 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 LocalLabel Word--data InspectState = InspectState-  { instrCount :: !Word-  , ptrCount :: !Word-  , litCount :: !Word-  , lblEnv :: LabelEnvMap-  }--inspectAsm :: Platform -> Bool -> Word -> Assembler a -> (Word, LabelEnvMap)-inspectAsm platform 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 platform else 1---      count (LargeOp _) = largeArg16s platform---- Bring in all the bci_ bytecode constants.-#include "Bytecodes.h"--largeArgInstr :: Word16 -> Word16-largeArgInstr bci = bci_FLAG_LARGE_ARGS .|. bci--largeArg :: Platform -> Word -> [Word16]-largeArg platform w = case platformWordSize platform of-   PW8 -> [fromIntegral (w `shiftR` 48),-           fromIntegral (w `shiftR` 32),-           fromIntegral (w `shiftR` 16),-           fromIntegral w]-   PW4 -> [fromIntegral (w `shiftR` 16),-           fromIntegral w]--largeArg16s :: Platform -> Word-largeArg16s platform = case platformWordSize platform of-   PW8 -> 4-   PW4 -> 2--assembleI :: Platform-          -> BCInstr-          -> Assembler ()-assembleI platform 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]-  PUSH8 o1                 -> emit bci_PUSH8 [SmallOp o1]-  PUSH16 o1                -> emit bci_PUSH16 [SmallOp o1]-  PUSH32 o1                -> emit bci_PUSH32 [SmallOp o1]-  PUSH8_W o1               -> emit bci_PUSH8_W [SmallOp o1]-  PUSH16_W o1              -> emit bci_PUSH16_W [SmallOp o1]-  PUSH32_W o1              -> emit bci_PUSH32_W [SmallOp 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          -> do let ul_bco = assembleBCO platform proto-                                 p <- ioptr (liftM BCOPtrBCO ul_bco)-                                 emit bci_PUSH_ALTS [Op p]-  PUSH_ALTS_UNLIFTED 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 tuple_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 <- int (fromIntegral $-                                              mkTupleInfoSig platform tuple_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, 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_UNLIFTED rep      -> emit (return_unlifted rep) []-  RETURN_TUPLE             -> emit bci_RETURN_T []-  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 (LitLabel fs (Just sz) _)-     | platformOS platform == 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 (LitLabel fs _ _) = litlabel fs-    literal LitNullAddr       = int 0-    literal (LitFloat r)      = float (fromRational r)-    literal (LitDouble r)     = double (fromRational r)-    literal (LitChar c)       = int (ord c)-    literal (LitString bs)    = lit [BCONPtrStr bs]-       -- LitString requires a zero-terminator when emitted-    literal (LitNumber nt i) = case nt of-      LitNumInt     -> int (fromIntegral i)-      LitNumWord    -> int (fromIntegral i)-      LitNumInt8    -> int8 (fromIntegral i)-      LitNumWord8   -> int8 (fromIntegral i)-      LitNumInt16   -> int16 (fromIntegral i)-      LitNumWord16  -> int16 (fromIntegral i)-      LitNumInt32   -> int32 (fromIntegral i)-      LitNumWord32  -> int32 (fromIntegral i)-      LitNumInt64   -> int64 (fromIntegral i)-      LitNumWord64  -> int64 (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 {}) = int 0--    litlabel fs = lit [BCONPtrLbl fs]-    addr (RemotePtr a) = words [fromIntegral a]-    float = words . mkLitF platform-    double = words . mkLitD platform-    int = words . mkLitI-    int8 = words . mkLitI64 platform-    int16 = words . mkLitI64 platform-    int32 = words . mkLitI64 platform-    int64 = words . mkLitI64 platform-    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_unlifted :: ArgRep -> Word16-return_unlifted V   = bci_RETURN_V-return_unlifted P   = bci_RETURN_P-return_unlifted N   = bci_RETURN_N-return_unlifted L   = bci_RETURN_L-return_unlifted F   = bci_RETURN_F-return_unlifted D   = bci_RETURN_D-return_unlifted V16 = error "return_unlifted: vector"-return_unlifted V32 = error "return_unlifted: vector"-return_unlifted V64 = error "return_unlifted: 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-  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).-- -}-maxTupleNativeStackSize :: WordOff-maxTupleNativeStackSize = 62--{--  Construct the tuple_info word that stg_ctoi_t and stg_ret_t use-  to convert a tuple between the native calling convention and the-  interpreter.--  See Note [GHCi tuple layout] for more information.- -}-mkTupleInfoSig :: Platform -> TupleInfo -> Word32-mkTupleInfoSig platform TupleInfo{..}-  | tupleNativeStackSize > maxTupleNativeStackSize-  = pprPanic "mkTupleInfoSig: tuple too big for the bytecode compiler"-             (ppr tupleNativeStackSize <+> text "stack words." <+>-              text "Use -fobject-code to get around this limit"-             )-  | otherwise-  = assert (length regs <= 24) {- 24 bits for bitmap -}-    assert (tupleNativeStackSize < 255) {- 8 bits for stack size -}-    assert (all (`elem` regs) (regSetToList tupleRegs)) {- all regs accounted for -}-    foldl' reg_bit 0 (zip regs [0..]) .|.-      (fromIntegral tupleNativeStackSize `shiftL` 24)-  where-    reg_bit :: Word32 -> (GlobalReg, Int) -> Word32-    reg_bit x (r, n)-      | r `elemRegSet` tupleRegs = x .|. 1 `shiftL` n-      | otherwise                = x-    regs = tupleRegsCover platform--mkTupleInfoLit :: Platform -> TupleInfo -> Literal-mkTupleInfoLit platform tuple_info =-  mkLitWord platform . fromIntegral $ mkTupleInfoSig platform tuple_info---- 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   :: Platform -> Float  -> [Word]-mkLitD   :: Platform -> Double -> [Word]-mkLitI64 :: Platform -> Int64  -> [Word]--mkLitF platform f = case platformWordSize platform of-  PW4 -> runST $ do-        arr <- newArray_ ((0::Int),0)-        writeArray arr 0 f-        f_arr <- castSTUArray arr-        w0 <- readArray f_arr 0-        return [w0 :: Word]--  PW8 -> runST $ do-        arr <- newArray_ ((0::Int),1)-        writeArray arr 0 f-        -- on 64-bit architectures we read two (32-bit) Float cells when we read-        -- a (64-bit) Word: so we write a dummy value in the second cell to-        -- avoid an out-of-bound read.-        writeArray arr 1 0.0-        f_arr <- castSTUArray arr-        w0 <- readArray f_arr 0-        return [w0 :: Word]--mkLitD platform d = case platformWordSize platform of-   PW4 -> runST (do-        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]-     )-   PW8 -> runST (do-        arr <- newArray_ ((0::Int),0)-        writeArray arr 0 d-        d_arr <- castSTUArray arr-        w0 <- readArray d_arr 0-        return [w0 :: Word]-     )--mkLitI64 platform ii = case platformWordSize platform of-   PW4 -> 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]-     )-   PW8 -> runST (do-        arr <- newArray_ ((0::Int),0)-        writeArray arr 0 ii-        d_arr <- castSTUArray arr-        w0 <- readArray d_arr 0-        return [w0 :: Word]-     )--mkLitI i = [fromIntegral i :: Word]+{-# LANGUAGE MagicHash       #-}+{-# LANGUAGE UnboxedTuples   #-}+{-# LANGUAGE PatternSynonyms   #-}+{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-}+--+--+--  (c) The University of Glasgow 2002-2006+--++-- | Bytecode assembler and linker+module GHC.ByteCode.Asm (+        assembleBCOs,+        bcoFreeNames,+        SizedSeq, sizeSS, ssElts,+        iNTERP_STACK_CHECK_THRESH,+        mkNativeCallInfoLit,++        -- * For testing+        assembleBCO+  ) where++import GHC.Prelude hiding ( any )+++import GHC.ByteCode.Instr+import GHC.ByteCode.InfoTable+import GHC.ByteCode.Types+import GHC.Runtime.Heap.Layout ( fromStgWord, StgWord )++import GHC.Types.Name+import GHC.Types.Name.Set+import GHC.Types.Literal+import GHC.Types.Unique.DSet+import GHC.Types.SptEntry+import GHC.Types.Unique.FM+import GHC.Unit.Types++import GHC.Utils.Outputable+import GHC.Utils.Panic++import GHC.Core.TyCon+import GHC.Data.SizedSeq+import GHC.Data.SmallArray++import GHC.StgToCmm.Layout     ( ArgRep(..) )+import GHC.Cmm.Expr+import GHC.Cmm.Reg             ( GlobalArgRegs(..) )+import GHC.Cmm.CallConv        ( allArgRegsCover )+import GHC.Platform+import GHC.Platform.Profile+import Language.Haskell.Syntax.Module.Name++import Control.Monad+import qualified Control.Monad.Trans.State.Strict as MTL++import qualified Data.Array.Unboxed as Array+import qualified Data.Array.IO as Array+import Data.Array.Base  ( UArray(..), numElements, unsafeFreeze )++#if ! defined(DEBUG)+import Data.Array.Base  ( unsafeWrite )+#endif++import Foreign hiding (shiftL, shiftR)+import Data.ByteString (ByteString)+import Data.Char  (ord)+import Data.Maybe (fromMaybe)+import GHC.Float (castFloatToWord32, castDoubleToWord64)++import qualified Data.List as List ( any )+import GHC.Exts+++-- -----------------------------------------------------------------------------+-- Unlinked BCOs++-- CompiledByteCode represents the result of byte-code+-- compiling a bunch of functions and data types++-- | Finds external references.  Remember to remove the names+-- defined by this group of BCOs themselves+bcoFreeNames :: UnlinkedBCO -> UniqDSet Name+bcoFreeNames bco+  = bco_refs bco `uniqDSetMinusUniqSet` mkNameSet [unlinkedBCOName bco]+  where+    bco_refs (UnlinkedBCO _ _ _ _ nonptrs ptrs)+        = unionManyUniqDSets (+             mkUniqDSet [ n | BCOPtrName n <- elemsFlatBag ptrs ] :+             mkUniqDSet [ n | BCONPtrItbl n <- elemsFlatBag nonptrs ] :+             map bco_refs [ bco | BCOPtrBCO bco <- elemsFlatBag ptrs ]+          )++-- -----------------------------------------------------------------------------+-- The bytecode assembler++-- The object format for bytecodes is: 16 bits for the opcode, and 16+-- for each field -- so the code can be considered a sequence of+-- 16-bit ints.  Each field denotes either a stack offset or number of+-- items on the stack (eg SLIDE), and index into the pointer table (eg+-- PUSH_G), an index into the literal table (eg PUSH_I/D/L), or a+-- bytecode address in this BCO.++-- Top level assembler fn.+assembleBCOs+  :: Profile+  -> FlatBag (ProtoBCO Name)+  -> [TyCon]+  -> [(Name, ByteString)]+  -> Maybe InternalModBreaks+  -> [SptEntry]+  -> IO CompiledByteCode+assembleBCOs profile proto_bcos tycons top_strs modbreaks spt_entries = do+  -- TODO: the profile should be bundled with the interpreter: the rts ways are+  -- fixed for an interpreter+  let itbls = mkITbls profile tycons+  bcos    <- mapM (assembleBCO (profilePlatform profile)) proto_bcos+  return CompiledByteCode+    { bc_bcos = bcos+    , bc_itbls = itbls+    , bc_strs = top_strs+    , bc_breaks = modbreaks+    , bc_spt_entries = spt_entries+    }++-- Note [Allocating string literals]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- Our strategy for handling top-level string literal bindings is described in+-- Note [Generating code for top-level string literal bindings] in GHC.StgToByteCode,+-- but not all Addr# literals in a program are guaranteed to be lifted to the+-- top level. Our strategy for handling local Addr# literals is somewhat simpler:+-- after assembling, we find all the BCONPtrStr arguments in the program, malloc+-- memory for them, and bake the resulting addresses into the instruction stream+-- in the form of BCONPtrWord arguments.+--+-- We used to allocate remote buffers for BCONPtrStr ByteStrings when+-- assembling, but this gets in the way of bytecode serialization: we+-- want the ability to serialize and reload assembled bytecode, so+-- it's better to preserve BCONPtrStr as-is, and only perform the+-- actual allocation at link-time.+--+-- Note that, as with top-level string literal bindings, this memory is never+-- freed, so it just leaks if the BCO is unloaded. See Note [Generating code for+-- top-level string literal bindings] in GHC.StgToByteCode for some discussion+-- about why.+--++data RunAsmReader = RunAsmReader { isn_array :: {-# UNPACK #-} !(Array.IOUArray Int Word16)+                                  , ptr_array :: {-# UNPACK #-} !(SmallMutableArrayIO BCOPtr)+                                  , lit_array :: {-# UNPACK #-} !(SmallMutableArrayIO BCONPtr )+                                  }++data RunAsmResult = RunAsmResult { final_isn_array :: !(Array.UArray Int Word16)+                                 , final_ptr_array :: !(SmallArray BCOPtr)+                                 , final_lit_array :: !(SmallArray BCONPtr) }++-- How many words we have written so far.+data AsmState = AsmState { nisn :: !Int, nptr :: !Int, nlit :: !Int }+++{-# NOINLINE inspectInstrs #-}+-- | Perform analysis of the bytecode to determine+--  1. How many instructions we will produce+--  2. If we are going to need long jumps.+--  3. The offsets that labels refer to+inspectInstrs :: Platform -> Bool -> Word -> [BCInstr] -> InspectState+inspectInstrs platform long_jump e instrs =+  inspectAsm long_jump e (mapM_ (assembleInspectAsm platform) instrs)++{-# NOINLINE runInstrs #-}+-- | Assemble the bytecode from the instructions.+runInstrs ::  Platform -> Bool -> InspectState -> [BCInstr] -> IO RunAsmResult+runInstrs platform long_jumps is_state instrs = do+  -- Produce arrays of exactly the right size, corresponding to the result of inspectInstrs.+  isn_array <- Array.newArray_ (0, (fromIntegral $ instrCount is_state) - 1)+  ptr_array <- newSmallArrayIO (fromIntegral $ ptrCount is_state) undefined+  lit_array <- newSmallArrayIO (fromIntegral $ litCount is_state) undefined+  let env :: LocalLabel -> Word+      env lbl = fromMaybe+        (pprPanic "assembleBCO.findLabel" (ppr lbl))+        (lookupUFM (lblEnv is_state) lbl)+  let initial_state  = AsmState 0 0 0+  let initial_reader = RunAsmReader{..}+  runAsm long_jumps env initial_reader initial_state (mapM_ (\i -> assembleRunAsm platform i) instrs)+  final_isn_array <- unsafeFreeze isn_array+  final_ptr_array <- unsafeFreezeSmallArrayIO ptr_array+  final_lit_array <- unsafeFreezeSmallArrayIO lit_array+  return $ RunAsmResult {..}++assembleRunAsm :: Platform -> BCInstr -> RunAsm ()+assembleRunAsm p i = assembleI @RunAsm p i++assembleInspectAsm :: Platform -> BCInstr -> InspectAsm ()+assembleInspectAsm p i = assembleI @InspectAsm p i++assembleBCO :: Platform -> ProtoBCO Name -> IO UnlinkedBCO+assembleBCO platform+            (ProtoBCO { protoBCOName       = nm+                      , protoBCOInstrs     = instrs+                      , protoBCOBitmap     = bitmap+                      , protoBCOBitmapSize = bsize+                      , protoBCOArity      = arity }) = do+  -- pass 1: collect up the offsets of the local labels.+  let initial_offset = 0++      -- Jump instructions are variable-sized, there are long and short variants+      -- depending on the magnitude of the offset.  However, we can't tell what+      -- size instructions we will need until we have calculated the offsets of+      -- the labels, which depends on the size of the instructions...  So we+      -- first create the label environment assuming that all jumps are short,+      -- and if the final size is indeed small enough for short jumps, we are+      -- done.  Otherwise, we repeat the calculation, and we force all jumps in+      -- this BCO to be long.+      is0 = inspectInstrs platform False initial_offset instrs+      (is1, long_jumps)+        | isLargeInspectState is0+                    = (inspectInstrs platform True initial_offset instrs, True)+        | otherwise = (is0, False)+++  -- pass 2: run assembler and generate instructions, literals and pointers+  RunAsmResult{..} <- runInstrs platform long_jumps is1 instrs++  -- precomputed size should be equal to final size+  massertPpr (fromIntegral (instrCount is1) == numElements final_isn_array+              && fromIntegral (ptrCount is1) == sizeofSmallArray final_ptr_array+              && fromIntegral (litCount is1) == sizeofSmallArray final_lit_array)+             (text "bytecode instruction count mismatch")++  let !insns_arr =  mkBCOByteArray $ final_isn_array+      !bitmap_arr = mkBCOByteArray $ mkBitmapArray bsize bitmap+      ul_bco = UnlinkedBCO { unlinkedBCOName = nm+                           , unlinkedBCOArity = arity+                           , unlinkedBCOInstrs = insns_arr+                           , unlinkedBCOBitmap = bitmap_arr+                           , unlinkedBCOLits = fromSmallArray final_lit_array+                           , unlinkedBCOPtrs = fromSmallArray final_ptr_array+                           }++  -- 8 Aug 01: Finalisers aren't safe when attached to non-primitive+  -- objects, since they might get run too early.  Disable this until+  -- we figure out what to do.+  -- when (notNull malloced) (addFinalizer ul_bco (mapM_ zonk malloced))++  return ul_bco++-- | Construct a word-array containing an @StgLargeBitmap@.+mkBitmapArray :: Word -> [StgWord] -> UArray Int Word+-- Here the return type must be an array of Words, not StgWords,+-- because the underlying ByteArray# will end up as a component+-- of a BCO object.+mkBitmapArray bsize bitmap+  = Array.listArray (0, length bitmap) $+      fromIntegral bsize : map (fromInteger . fromStgWord) bitmap+++data Operand+  = Op Word+  | IOp Int+  | SmallOp Word16+  | LabelOp LocalLabel++wOp :: WordOff -> Operand+wOp = Op . fromIntegral++bOp :: ByteOff -> Operand+bOp = Op . fromIntegral++truncHalfWord :: Platform -> HalfWord -> Operand+truncHalfWord platform w = case platformWordSize platform of+  PW4 | w <= 65535      -> Op (fromIntegral w)+  PW8 | w <= 4294967295 -> Op (fromIntegral w)+  _ -> pprPanic "GHC.ByteCode.Asm.truncHalfWord" (ppr w)+++ptr :: MonadAssembler m => BCOPtr -> m Word+ptr = ioptr . return++type LabelEnv = LocalLabel -> Word++largeOp :: Bool -> Operand -> Bool+largeOp long_jumps op = case op of+   SmallOp _ -> False+   Op w      -> isLargeW w+   IOp i     -> isLargeI i+   LabelOp _ -> long_jumps++newtype RunAsm a = RunAsm' { runRunAsm :: Bool+                                       -> LabelEnv+                                       -> RunAsmReader+                                       -> AsmState+                                       -> IO (AsmState, a) }++pattern RunAsm :: (Bool -> LabelEnv -> RunAsmReader -> AsmState -> IO (AsmState, a))+                  -> RunAsm a+pattern RunAsm m <- RunAsm' m+  where+    RunAsm m = RunAsm' (oneShot $ \a -> oneShot $ \b -> oneShot $ \c -> oneShot $ \d -> m a b c d)+{-# COMPLETE RunAsm #-}++instance Functor RunAsm where+  fmap f (RunAsm x) = RunAsm (\a b c !s -> fmap (fmap f) (x a b c s))++instance Applicative RunAsm where+  pure x = RunAsm $ \_ _ _ !s -> pure (s, x)+  (RunAsm f) <*> (RunAsm x) = RunAsm $ \a b c !s -> do+                                  (!s', f') <- f a b c s+                                  (!s'', x') <- x a b c s'+                                  return (s'', f' x')+  {-# INLINE (<*>) #-}+++instance Monad RunAsm where+  return  = pure+  (RunAsm m) >>= f = RunAsm $ \a b c !s -> m a b c s >>= \(s', r) -> runRunAsm (f r) a b c s'+  {-# INLINE (>>=) #-}++runAsm :: Bool -> LabelEnv -> RunAsmReader -> AsmState -> RunAsm a -> IO a+runAsm long_jumps e r s (RunAsm'{runRunAsm}) = fmap snd $ runRunAsm long_jumps e r s++expand :: PlatformWordSize -> Bool -> Operand -> RunAsm ()+expand word_size largeArgs o = do+  e <- askEnv+  case o of+    (SmallOp w) -> writeIsn w+    (LabelOp w) -> let !r = e w in handleLargeArg r+    (Op w) -> handleLargeArg w+    (IOp i) -> handleLargeArg i++  where+    handleLargeArg :: Integral a => a -> RunAsm ()+    handleLargeArg w  =+      if largeArgs+        then largeArg word_size (fromIntegral w)+        else writeIsn (fromIntegral w)++lift :: IO a -> RunAsm a+lift io = RunAsm $ \_ _ _ s -> io >>= \a -> pure (s, a)++askLongJumps :: RunAsm Bool+askLongJumps = RunAsm $ \a _ _ s -> pure (s, a)++askEnv :: RunAsm LabelEnv+askEnv = RunAsm $ \_ b _ s -> pure (s, b)++writePtr :: BCOPtr -> RunAsm Word+writePtr w+            = RunAsm $ \_ _ (RunAsmReader{..}) asm -> do+              writeSmallArrayIO ptr_array (nptr asm) w+              let !n' = nptr asm + 1+              let !asm' = asm { nptr = n' }+              return (asm', fromIntegral (nptr asm))++writeLit :: BCONPtr -> RunAsm Word+writeLit w = RunAsm $ \_ _ (RunAsmReader{..}) asm -> do+              writeSmallArrayIO lit_array (nlit asm) w+              let !n' = nlit asm + 1+              let !asm' = asm { nlit = n' }+              return (asm', fromIntegral (nlit asm))++writeLits :: OneOrTwo BCONPtr -> RunAsm Word+writeLits (OnlyOne l) = writeLit l+writeLits (OnlyTwo l1 l2) = writeLit l1 <* writeLit l2++writeIsn :: Word16 -> RunAsm ()+writeIsn w = RunAsm $ \_ _ (RunAsmReader{..}) asm -> do+#if defined(DEBUG)+              Array.writeArray isn_array (nisn asm) w+#else+              unsafeWrite isn_array (nisn asm) w+#endif+              let !n' = nisn asm + 1+              let !asm' = asm { nisn = n' }+              return (asm', ())++{-# INLINE any #-}+-- Any is unrolled manually so that the call in `emit` can be eliminated without+-- relying on SpecConstr (which does not work across modules).+any :: (a -> Bool) -> [a] -> Bool+any _ [] = False+any f [x] = f x+any f [x,y] = f x || f y+any f [x,y,z] = f x || f y || f z+any f [x1,x2,x3,x4] = f x1 || f x2 || f x3 || f x4+any f [x1,x2,x3,x4, x5] = f x1 || f x2 || f x3 || f x4 || f x5+any f [x1,x2,x3,x4,x5,x6] = f x1 || f x2 || f x3 || f x4 || f x5 || f x6+any f xs = List.any f xs++{-# INLINE mapM6_ #-}+mapM6_ :: Monad m => (a -> m b) -> [a] -> m ()+mapM6_ _ [] = return ()+mapM6_ f [x] = () <$ f x+mapM6_ f [x,y] = () <$ f x <* f y+mapM6_ f [x,y,z] = () <$ f x <* f y <* f z+mapM6_ f [a1,a2,a3,a4] = () <$ f a1 <* f a2 <* f a3 <* f a4+mapM6_ f [a1,a2,a3,a4,a5] = () <$ f a1 <* f a2 <* f a3 <* f a4 <* f a5+mapM6_ f [a1,a2,a3,a4,a5,a6] = () <$ f a1 <* f a2 <* f a3 <* f a4 <* f a5 <* f a6+mapM6_ f xs = mapM_ f xs++instance MonadAssembler RunAsm where+  ioptr p_io = do+    p <- lift p_io+    writePtr p+  lit lits = writeLits lits++  label _ = return ()++  emit pwordsize w ops = do+    long_jumps <- askLongJumps+    -- See the definition of `any` above+    let largeArgs = any (largeOp long_jumps) ops+    let opcode+          | largeArgs = largeArgInstr w+          | otherwise = w+    writeIsn opcode+    mapM6_ (expand pwordsize largeArgs) ops++  {-# INLINE emit #-}+  {-# INLINE label #-}+  {-# INLINE lit #-}+  {-# INLINE ioptr #-}++type LabelEnvMap = UniqFM LocalLabel Word++data InspectState = InspectState+  { instrCount :: !Word+  , ptrCount :: !Word+  , litCount :: !Word+  , lblEnv :: LabelEnvMap+  }++instance Outputable InspectState where+  ppr (InspectState i p l m) = text "InspectState" <+> ppr [ppr i, ppr p, ppr l, ppr (sizeUFM m)]++isLargeInspectState :: InspectState -> Bool+isLargeInspectState InspectState{..} =+  isLargeW (fromIntegral $ sizeUFM lblEnv)+    || isLargeW instrCount++newtype InspectEnv = InspectEnv { _inspectLongJumps :: Bool+                                }++newtype InspectAsm a = InspectAsm' { runInspectAsm :: InspectEnv -> InspectState -> (# InspectState,  a #) }++pattern InspectAsm :: (InspectEnv -> InspectState -> (# InspectState, a #))+                   -> InspectAsm a+pattern InspectAsm m <- InspectAsm' m+  where+    InspectAsm m = InspectAsm' (oneShot $ \a -> oneShot $ \b -> m a b)+{-# COMPLETE InspectAsm #-}++instance Functor InspectAsm where+  fmap f (InspectAsm k) = InspectAsm $ \a b -> case k a b of+                                                  (# b', c #) -> (# b', f c #)++instance Applicative InspectAsm where+  pure x = InspectAsm $ \_ s -> (# s, x #)+  (InspectAsm f) <*> (InspectAsm x) = InspectAsm $ \a b -> case f a b of+                                                              (# s', f' #) ->+                                                                case x a s' of+                                                                  (# s'', x' #) -> (# s'', f' x' #)++instance Monad InspectAsm where+  return = pure+  (InspectAsm m) >>= f = InspectAsm $ \ a b -> case m a b of+                                                (# s', a' #) -> runInspectAsm (f a') a s'++get_ :: InspectAsm InspectState+get_ = InspectAsm $ \_ b -> (# b, b #)++put_ :: InspectState -> InspectAsm ()+put_ !s = InspectAsm $ \_ _ -> (# s, () #)++modify_ :: (InspectState -> InspectState) -> InspectAsm ()+modify_ f = InspectAsm $ \_ s -> let !s' = f s in (# s', () #)++ask_ :: InspectAsm InspectEnv+ask_ = InspectAsm $ \a b -> (# b, a #)++inspectAsm :: Bool -> Word -> InspectAsm () -> InspectState+inspectAsm long_jumps initial_offset (InspectAsm s) =+  case s (InspectEnv long_jumps) (InspectState initial_offset 0 0 emptyUFM) of+    (# res, () #) -> res+{-# INLINE inspectAsm #-}++++instance MonadAssembler InspectAsm where+  ioptr _ = do+    s <- get_+    let n = ptrCount s+    put_ (s { ptrCount = n + 1 })+    return n++  lit ls = do+    s <- get_+    let n = litCount s+    put_ (s { litCount = n + oneTwoLength ls })+    return n++  label lbl = modify_ (\s -> let !count = instrCount s in let !env' = addToUFM (lblEnv s) lbl count in s { lblEnv = env' })++  emit pwordsize _ ops = do+    InspectEnv long_jumps <- ask_+    -- Size is written in this way as `mapM6_` is also used by RunAsm, and guaranteed+    -- to unroll for arguments up to size 6.+    let size = (MTL.execState (mapM6_ (\x -> MTL.modify (count' x +)) ops) 0) + 1+        largeOps = any (largeOp long_jumps) ops+        bigSize = largeArg16s pwordsize+        count' = if largeOps then countLarge bigSize else countSmall bigSize++    s <- get_+    put_ (s { instrCount = instrCount s + size })++  {-# INLINE emit #-}+  {-# INLINE label #-}+  {-# INLINE lit #-}+  {-# INLINE ioptr #-}++count :: Word -> Bool -> Operand -> Word+count _ _ (SmallOp _)          = 1+count big largeOps (LabelOp _) = if largeOps then big else 1+count big largeOps (Op _)      = if largeOps then big else 1+count big largeOps (IOp _)     = if largeOps then big else 1+{-# INLINE count #-}++countSmall, countLarge :: Word -> Operand -> Word+countLarge big x = count big True x+countSmall big x = count big False x+++-- Bring in all the bci_ bytecode constants.+#include "Bytecodes.h"++largeArgInstr :: Word16 -> Word16+largeArgInstr bci = bci_FLAG_LARGE_ARGS .|. bci++{-# INLINE largeArg #-}+largeArg :: PlatformWordSize -> Word64 -> RunAsm ()+largeArg wsize w = case wsize of+   PW8 ->  do writeIsn (fromIntegral (w `shiftR` 48))+              writeIsn (fromIntegral (w `shiftR` 32))+              writeIsn (fromIntegral (w `shiftR` 16))+              writeIsn (fromIntegral w)+   PW4 -> assertPpr (w < fromIntegral (maxBound :: Word32))+                    (text "largeArg too big:" <+> ppr w) $ do+          writeIsn (fromIntegral (w `shiftR` 16))+          writeIsn (fromIntegral w)++largeArg16s :: PlatformWordSize -> Word+largeArg16s pwordsize = case pwordsize of+   PW8 -> 4+   PW4 -> 2++data OneOrTwo a = OnlyOne a | OnlyTwo a a deriving (Functor)++oneTwoLength :: OneOrTwo a -> Word+oneTwoLength (OnlyOne {}) = 1+oneTwoLength (OnlyTwo {}) = 2++class Monad m => MonadAssembler m where+  ioptr :: IO BCOPtr -> m Word+  lit :: OneOrTwo BCONPtr -> m Word+  label :: LocalLabel -> m ()+  emit :: PlatformWordSize -> Word16 -> [Operand] -> m ()++lit1 :: MonadAssembler m => BCONPtr -> m Word+lit1 p = lit (OnlyOne p)++{-# SPECIALISE assembleI :: Platform -> BCInstr -> InspectAsm () #-}+{-# SPECIALISE assembleI :: Platform -> BCInstr -> RunAsm () #-}++assembleI :: forall m . MonadAssembler m+          => Platform+          -> BCInstr+          -> m ()+assembleI platform i = case i of+  STKCHECK n               -> emit_ bci_STKCHECK [Op n]+  PUSH_L o1                -> emit_ bci_PUSH_L [wOp o1]+  PUSH_LL o1 o2            -> emit_ bci_PUSH_LL [wOp o1, wOp o2]+  PUSH_LLL o1 o2 o3        -> emit_ bci_PUSH_LLL [wOp o1, wOp o2, wOp o3]+  PUSH8 o1                 -> emit_ bci_PUSH8 [bOp o1]+  PUSH16 o1                -> emit_ bci_PUSH16 [bOp o1]+  PUSH32 o1                -> emit_ bci_PUSH32 [bOp o1]+  PUSH8_W o1               -> emit_ bci_PUSH8_W [bOp o1]+  PUSH16_W o1              -> emit_ bci_PUSH16_W [bOp o1]+  PUSH32_W o1              -> emit_ bci_PUSH32_W [bOp o1]+  PUSH_G nm                -> do p <- ptr (BCOPtrName nm)+                                 emit_ bci_PUSH_G [Op p]+  PUSH_PRIMOP op           -> do p <- ptr (BCOPtrPrimOp op)+                                 emit_ bci_PUSH_G [Op p]+  PUSH_BCO proto           -> do let ul_bco = assembleBCO platform proto+                                 p <- ioptr (liftM BCOPtrBCO ul_bco)+                                 emit_ bci_PUSH_G [Op p]+  PUSH_ALTS proto pk+                           -> do let ul_bco = assembleBCO platform proto+                                 p <- ioptr (liftM BCOPtrBCO ul_bco)+                                 emit_ (push_alts pk) [Op p]+  PUSH_ALTS_TUPLE proto call_info tuple_proto+                           -> do let ul_bco = assembleBCO platform proto+                                     ul_tuple_bco = assembleBCO platform+                                                                tuple_proto+                                 p <- ioptr (liftM BCOPtrBCO ul_bco)+                                 p_tup <- ioptr (liftM BCOPtrBCO ul_tuple_bco)+                                 info <- word (fromIntegral $+                                              mkNativeCallInfoSig platform call_info)+                                 emit_ bci_PUSH_ALTS_T+                                      [Op p, Op info, Op p_tup]+  PUSH_PAD8                -> emit_ bci_PUSH_PAD8 []+  PUSH_PAD16               -> emit_ bci_PUSH_PAD16 []+  PUSH_PAD32               -> emit_ bci_PUSH_PAD32 []+  PUSH_UBX8 lit            -> do np <- literal lit+                                 emit_ bci_PUSH_UBX8 [Op np]+  PUSH_UBX16 lit           -> do np <- literal lit+                                 emit_ bci_PUSH_UBX16 [Op np]+  PUSH_UBX32 lit           -> do np <- literal lit+                                 emit_ bci_PUSH_UBX32 [Op np]+  PUSH_UBX lit nws         -> do np <- literal lit+                                 emit_ bci_PUSH_UBX [Op np, wOp nws]+  -- see Note [Generating code for top-level string literal bindings] in GHC.StgToByteCode+  PUSH_ADDR nm             -> do np <- lit1 (BCONPtrAddr nm)+                                 emit_ bci_PUSH_UBX [Op np, SmallOp 1]++  PUSH_APPLY_N             -> emit_ bci_PUSH_APPLY_N []+  PUSH_APPLY_V             -> emit_ bci_PUSH_APPLY_V []+  PUSH_APPLY_F             -> emit_ bci_PUSH_APPLY_F []+  PUSH_APPLY_D             -> emit_ bci_PUSH_APPLY_D []+  PUSH_APPLY_L             -> emit_ bci_PUSH_APPLY_L []+  PUSH_APPLY_P             -> emit_ bci_PUSH_APPLY_P []+  PUSH_APPLY_PP            -> emit_ bci_PUSH_APPLY_PP []+  PUSH_APPLY_PPP           -> emit_ bci_PUSH_APPLY_PPP []+  PUSH_APPLY_PPPP          -> emit_ bci_PUSH_APPLY_PPPP []+  PUSH_APPLY_PPPPP         -> emit_ bci_PUSH_APPLY_PPPPP []+  PUSH_APPLY_PPPPPP        -> emit_ bci_PUSH_APPLY_PPPPPP []++  SLIDE     n by           -> emit_ bci_SLIDE [wOp n, wOp by]+  ALLOC_AP  n              -> emit_ bci_ALLOC_AP [truncHalfWord platform n]+  ALLOC_AP_NOUPD n         -> emit_ bci_ALLOC_AP_NOUPD [truncHalfWord platform n]+  ALLOC_PAP arity n        -> emit_ bci_ALLOC_PAP [truncHalfWord platform arity, truncHalfWord platform n]+  MKAP      off sz         -> emit_ bci_MKAP [wOp off, truncHalfWord platform sz]+  MKPAP     off sz         -> emit_ bci_MKPAP [wOp off, truncHalfWord platform sz]+  UNPACK    n              -> emit_ bci_UNPACK [wOp n]+  PACK      dcon sz        -> do itbl_no <- lit1 (BCONPtrItbl (getName dcon))+                                 emit_ bci_PACK [Op itbl_no, wOp sz]+  LABEL     lbl            -> label lbl+  TESTLT_I  i l            -> do np <- int i+                                 emit_ bci_TESTLT_I [Op np, LabelOp l]+  TESTEQ_I  i l            -> do np <- int i+                                 emit_ bci_TESTEQ_I [Op np, LabelOp l]+  TESTLT_W  w l            -> do np <- word w+                                 emit_ bci_TESTLT_W [Op np, LabelOp l]+  TESTEQ_W  w l            -> do np <- word w+                                 emit_ bci_TESTEQ_W [Op np, LabelOp l]+  TESTLT_I64  i l          -> do np <- word64 (fromIntegral i)+                                 emit_ bci_TESTLT_I64 [Op np, LabelOp l]+  TESTEQ_I64  i l          -> do np <- word64 (fromIntegral i)+                                 emit_ bci_TESTEQ_I64 [Op np, LabelOp l]+  TESTLT_I32  i l          -> do np <- word (fromIntegral i)+                                 emit_ bci_TESTLT_I32 [Op np, LabelOp l]+  TESTEQ_I32 i l           -> do np <- word (fromIntegral i)+                                 emit_ bci_TESTEQ_I32 [Op np, LabelOp l]+  TESTLT_I16  i l          -> do np <- word (fromIntegral i)+                                 emit_ bci_TESTLT_I16 [Op np, LabelOp l]+  TESTEQ_I16 i l           -> do np <- word (fromIntegral i)+                                 emit_ bci_TESTEQ_I16 [Op np, LabelOp l]+  TESTLT_I8  i l           -> do np <- word (fromIntegral i)+                                 emit_ bci_TESTLT_I8 [Op np, LabelOp l]+  TESTEQ_I8 i l            -> do np <- word (fromIntegral i)+                                 emit_ bci_TESTEQ_I8 [Op np, LabelOp l]+  TESTLT_W64  w l          -> do np <- word64 w+                                 emit_ bci_TESTLT_W64 [Op np, LabelOp l]+  TESTEQ_W64  w l          -> do np <- word64 w+                                 emit_ bci_TESTEQ_W64 [Op np, LabelOp l]+  TESTLT_W32  w l          -> do np <- word (fromIntegral w)+                                 emit_ bci_TESTLT_W32 [Op np, LabelOp l]+  TESTEQ_W32  w l          -> do np <- word (fromIntegral w)+                                 emit_ bci_TESTEQ_W32 [Op np, LabelOp l]+  TESTLT_W16  w l          -> do np <- word (fromIntegral w)+                                 emit_ bci_TESTLT_W16 [Op np, LabelOp l]+  TESTEQ_W16  w l          -> do np <- word (fromIntegral w)+                                 emit_ bci_TESTEQ_W16 [Op np, LabelOp l]+  TESTLT_W8  w l           -> do np <- word (fromIntegral w)+                                 emit_ bci_TESTLT_W8 [Op np, LabelOp l]+  TESTEQ_W8  w l           -> do np <- word (fromIntegral w)+                                 emit_ bci_TESTEQ_W8 [Op np, LabelOp l]+  TESTLT_F  f l            -> do np <- float f+                                 emit_ bci_TESTLT_F [Op np, LabelOp l]+  TESTEQ_F  f l            -> do np <- float f+                                 emit_ bci_TESTEQ_F [Op np, LabelOp l]+  TESTLT_D  d l            -> do np <- double d+                                 emit_ bci_TESTLT_D [Op np, LabelOp l]+  TESTEQ_D  d l            -> do np <- double d+                                 emit_ bci_TESTEQ_D [Op np, LabelOp l]+  TESTLT_P  i l            -> emit_ bci_TESTLT_P [SmallOp i, LabelOp l]+  TESTEQ_P  i l            -> emit_ bci_TESTEQ_P [SmallOp i, LabelOp l]+  CASEFAIL                 -> emit_ bci_CASEFAIL []+  SWIZZLE   stkoff n       -> emit_ bci_SWIZZLE [wOp stkoff, IOp n]+  JMP       l              -> emit_ bci_JMP [LabelOp l]+  ENTER                    -> emit_ bci_ENTER []+  RETURN rep               -> emit_ (return_non_tuple rep) []+  RETURN_TUPLE             -> emit_ bci_RETURN_T []+  CCALL off ffi i          -> do np <- lit1 $ BCONPtrFFIInfo ffi+                                 emit_ bci_CCALL [wOp off, Op np, SmallOp i]+  PRIMCALL                 -> emit_ bci_PRIMCALL []++  OP_ADD w -> case w of+    W64                   -> emit_ bci_OP_ADD_64 []+    W32                   -> emit_ bci_OP_ADD_32 []+    W16                   -> emit_ bci_OP_ADD_16 []+    W8                    -> emit_ bci_OP_ADD_08 []+    _                     -> unsupported_width+  OP_SUB w -> case w of+    W64                   -> emit_ bci_OP_SUB_64 []+    W32                   -> emit_ bci_OP_SUB_32 []+    W16                   -> emit_ bci_OP_SUB_16 []+    W8                    -> emit_ bci_OP_SUB_08 []+    _                     -> unsupported_width+  OP_AND w -> case w of+    W64                   -> emit_ bci_OP_AND_64 []+    W32                   -> emit_ bci_OP_AND_32 []+    W16                   -> emit_ bci_OP_AND_16 []+    W8                    -> emit_ bci_OP_AND_08 []+    _                     -> unsupported_width+  OP_XOR w -> case w of+    W64                   -> emit_ bci_OP_XOR_64 []+    W32                   -> emit_ bci_OP_XOR_32 []+    W16                   -> emit_ bci_OP_XOR_16 []+    W8                    -> emit_ bci_OP_XOR_08 []+    _                     -> unsupported_width+  OP_OR w -> case w of+    W64                    -> emit_ bci_OP_OR_64 []+    W32                    -> emit_ bci_OP_OR_32 []+    W16                    -> emit_ bci_OP_OR_16 []+    W8                     -> emit_ bci_OP_OR_08 []+    _                      -> unsupported_width+  OP_NOT w -> case w of+    W64                   -> emit_ bci_OP_NOT_64 []+    W32                   -> emit_ bci_OP_NOT_32 []+    W16                   -> emit_ bci_OP_NOT_16 []+    W8                    -> emit_ bci_OP_NOT_08 []+    _                     -> unsupported_width+  OP_NEG w -> case w of+    W64                   -> emit_ bci_OP_NEG_64 []+    W32                   -> emit_ bci_OP_NEG_32 []+    W16                   -> emit_ bci_OP_NEG_16 []+    W8                    -> emit_ bci_OP_NEG_08 []+    _                     -> unsupported_width+  OP_MUL w -> case w of+    W64                   -> emit_ bci_OP_MUL_64 []+    W32                   -> emit_ bci_OP_MUL_32 []+    W16                   -> emit_ bci_OP_MUL_16 []+    W8                    -> emit_ bci_OP_MUL_08 []+    _                     -> unsupported_width+  OP_SHL w -> case w of+    W64                   -> emit_ bci_OP_SHL_64 []+    W32                   -> emit_ bci_OP_SHL_32 []+    W16                   -> emit_ bci_OP_SHL_16 []+    W8                    -> emit_ bci_OP_SHL_08 []+    _                     -> unsupported_width+  OP_ASR w -> case w of+    W64                   -> emit_ bci_OP_ASR_64 []+    W32                   -> emit_ bci_OP_ASR_32 []+    W16                   -> emit_ bci_OP_ASR_16 []+    W8                    -> emit_ bci_OP_ASR_08 []+    _                     -> unsupported_width+  OP_LSR w -> case w of+    W64                   -> emit_ bci_OP_LSR_64 []+    W32                   -> emit_ bci_OP_LSR_32 []+    W16                   -> emit_ bci_OP_LSR_16 []+    W8                    -> emit_ bci_OP_LSR_08 []+    _                     -> unsupported_width++  OP_NEQ w -> case w of+    W64                   -> emit_ bci_OP_NEQ_64 []+    W32                   -> emit_ bci_OP_NEQ_32 []+    W16                   -> emit_ bci_OP_NEQ_16 []+    W8                    -> emit_ bci_OP_NEQ_08 []+    _                     -> unsupported_width+  OP_EQ w -> case w of+    W64                    -> emit_ bci_OP_EQ_64 []+    W32                    -> emit_ bci_OP_EQ_32 []+    W16                    -> emit_ bci_OP_EQ_16 []+    W8                     -> emit_ bci_OP_EQ_08 []+    _                      -> unsupported_width++  OP_U_LT w -> case w of+    W64                  -> emit_ bci_OP_U_LT_64 []+    W32                  -> emit_ bci_OP_U_LT_32 []+    W16                  -> emit_ bci_OP_U_LT_16 []+    W8                   -> emit_ bci_OP_U_LT_08 []+    _                    -> unsupported_width+  OP_S_LT w -> case w of+    W64                  -> emit_ bci_OP_S_LT_64 []+    W32                  -> emit_ bci_OP_S_LT_32 []+    W16                  -> emit_ bci_OP_S_LT_16 []+    W8                   -> emit_ bci_OP_S_LT_08 []+    _                    -> unsupported_width+  OP_U_GE w -> case w of+    W64                  -> emit_ bci_OP_U_GE_64 []+    W32                  -> emit_ bci_OP_U_GE_32 []+    W16                  -> emit_ bci_OP_U_GE_16 []+    W8                   -> emit_ bci_OP_U_GE_08 []+    _                    -> unsupported_width+  OP_S_GE w -> case w of+    W64                  -> emit_ bci_OP_S_GE_64 []+    W32                  -> emit_ bci_OP_S_GE_32 []+    W16                  -> emit_ bci_OP_S_GE_16 []+    W8                   -> emit_ bci_OP_S_GE_08 []+    _                    -> unsupported_width+  OP_U_GT w -> case w of+    W64                  -> emit_ bci_OP_U_GT_64 []+    W32                  -> emit_ bci_OP_U_GT_32 []+    W16                  -> emit_ bci_OP_U_GT_16 []+    W8                   -> emit_ bci_OP_U_GT_08 []+    _                    -> unsupported_width+  OP_S_GT w -> case w of+    W64                  -> emit_ bci_OP_S_GT_64 []+    W32                  -> emit_ bci_OP_S_GT_32 []+    W16                  -> emit_ bci_OP_S_GT_16 []+    W8                   -> emit_ bci_OP_S_GT_08 []+    _                    -> unsupported_width+  OP_U_LE w -> case w of+    W64                  -> emit_ bci_OP_U_LE_64 []+    W32                  -> emit_ bci_OP_U_LE_32 []+    W16                  -> emit_ bci_OP_U_LE_16 []+    W8                   -> emit_ bci_OP_U_LE_08 []+    _                    -> unsupported_width+  OP_S_LE w -> case w of+    W64                  -> emit_ bci_OP_S_LE_64 []+    W32                  -> emit_ bci_OP_S_LE_32 []+    W16                  -> emit_ bci_OP_S_LE_16 []+    W8                   -> emit_ bci_OP_S_LE_08 []+    _                    -> unsupported_width++  OP_INDEX_ADDR w -> case w of+    W64                  -> emit_ bci_OP_INDEX_ADDR_64 []+    W32                  -> emit_ bci_OP_INDEX_ADDR_32 []+    W16                  -> emit_ bci_OP_INDEX_ADDR_16 []+    W8                   -> emit_ bci_OP_INDEX_ADDR_08 []+    _                    -> unsupported_width++  BRK_FUN ibi@(InternalBreakpointId info_mod infox) -> do+    p1 <- ptr $ BCOPtrBreakArray info_mod+    let -- cast that checks that round-tripping through Word32 doesn't change the value+        infoW32 = let r = fromIntegral infox :: Word32+                   in if fromIntegral r == infox+                    then r+                    else pprPanic "schemeER_wrk: breakpoint tick/info index too large!" (ppr infox)+        ix_hi = fromIntegral (infoW32 `shiftR` 16)+        ix_lo = fromIntegral (infoW32 .&. 0xffff)+    info_addr        <- lit1 $ BCONPtrFS $ moduleNameFS $ moduleName info_mod+    info_unitid_addr <- lit1 $ BCONPtrFS $ unitIdFS     $ moduleUnitId info_mod+    np               <- lit1 $ BCONPtrCostCentre ibi+    emit_ bci_BRK_FUN [ Op p1, Op info_addr, Op info_unitid_addr+                      , SmallOp ix_hi, SmallOp ix_lo, Op np ]++#if MIN_VERSION_rts(1,0,3)+  BCO_NAME name            -> do np <- lit1 (BCONPtrStr name)+                                 emit_ bci_BCO_NAME [Op np]+#endif++++  where+    unsupported_width = panic "GHC.ByteCode.Asm: Unsupported Width"+    emit_ = emit word_size++    literal :: Literal -> m Word+    literal (LitLabel fs _)   = litlabel fs+    literal LitNullAddr       = word 0+    literal (LitFloat r)      = float (fromRational r)+    literal (LitDouble r)     = double (fromRational r)+    literal (LitChar c)       = int (ord c)+    literal (LitString bs)    = lit1 (BCONPtrStr bs)+       -- LitString requires a zero-terminator when emitted+    literal (LitNumber nt i) = case nt of+      LitNumInt     -> word (fromIntegral i)+      LitNumWord    -> word (fromIntegral i)+      LitNumInt8    -> word8 (fromIntegral i)+      LitNumWord8   -> word8 (fromIntegral i)+      LitNumInt16   -> word16 (fromIntegral i)+      LitNumWord16  -> word16 (fromIntegral i)+      LitNumInt32   -> word32 (fromIntegral i)+      LitNumWord32  -> word32 (fromIntegral i)+      LitNumInt64   -> word64 (fromIntegral i)+      LitNumWord64  -> word64 (fromIntegral i)+      LitNumBigNat  -> panic "GHC.ByteCode.Asm.literal: LitNumBigNat"++    -- We can lower 'LitRubbish' to an arbitrary constant, but @NULL@ is most+    -- likely to elicit a crash (rather than corrupt memory) in case absence+    -- analysis messed up.+    literal (LitRubbish {}) = word 0++    litlabel fs = lit1 (BCONPtrLbl fs)+    words ws = lit (fmap BCONPtrWord ws)+    word w = words (OnlyOne w)+    word2 w1 w2 = words (OnlyTwo w1 w2)+    word_size  = platformWordSize platform+    word_size_bits = platformWordSizeInBits platform++    -- Make lists of host-sized words for literals, so that when the+    -- words are placed in memory at increasing addresses, the+    -- bit pattern is correct for the host's word size and endianness.+    --+    -- Note that we only support host endianness == target endianness for now,+    -- even with the external interpreter. This would need to be fixed to+    -- support host endianness /= target endianness+    int :: Int -> m Word+    int  i = word (fromIntegral i)++    float :: Float -> m Word+    float f = word32 (castFloatToWord32 f)++    double :: Double -> m Word+    double d = word64 (castDoubleToWord64 d)++    word64 :: Word64 -> m Word+    word64 ww = case word_size of+       PW4 ->+        let !wl = fromIntegral ww+            !wh = fromIntegral (ww `unsafeShiftR` 32)+        in case platformByteOrder platform of+            LittleEndian -> word2 wl wh+            BigEndian    -> word2 wh wl+       PW8 -> word (fromIntegral ww)++    word8 :: Word8 -> m Word+    word8  x = case platformByteOrder platform of+      LittleEndian -> word (fromIntegral x)+      BigEndian    -> word (fromIntegral x `unsafeShiftL` (word_size_bits - 8))++    word16 :: Word16 -> m Word+    word16 x = case platformByteOrder platform of+      LittleEndian -> word (fromIntegral x)+      BigEndian    -> word (fromIntegral x `unsafeShiftL` (word_size_bits - 16))++    word32 :: Word32 -> m Word+    word32 x = case platformByteOrder platform of+      LittleEndian -> word (fromIntegral x)+      BigEndian    -> case word_size of+        PW4 -> word (fromIntegral x)+        PW8 -> word (fromIntegral x `unsafeShiftL` 32)+++isLargeW :: Word -> Bool+isLargeW n = n > 65535++isLargeI :: Int -> Bool+isLargeI n = n > 32767 || n < -32768++push_alts :: ArgRep -> Word16+push_alts V   = bci_PUSH_ALTS_V+push_alts P   = bci_PUSH_ALTS_P+push_alts N   = bci_PUSH_ALTS_N+push_alts L   = bci_PUSH_ALTS_L+push_alts F   = bci_PUSH_ALTS_F+push_alts D   = bci_PUSH_ALTS_D+push_alts V16 = error "push_alts: vector"+push_alts V32 = error "push_alts: vector"+push_alts V64 = error "push_alts: vector"++return_non_tuple :: ArgRep -> Word16+return_non_tuple V   = bci_RETURN_V+return_non_tuple P   = bci_RETURN_P+return_non_tuple N   = bci_RETURN_N+return_non_tuple L   = bci_RETURN_L+return_non_tuple F   = bci_RETURN_F+return_non_tuple D   = bci_RETURN_D+return_non_tuple V16 = error "return_non_tuple: vector"+return_non_tuple V32 = error "return_non_tuple: vector"+return_non_tuple V64 = error "return_non_tuple: vector"++{-+  we can only handle up to a fixed number of words on the stack,+  because we need a stg_ctoi_tN stack frame for each size N. See+  Note [unboxed tuple bytecodes and tuple_BCO].++  If needed, you can support larger tuples by adding more in+  Jumps.cmm, StgMiscClosures.cmm, Interpreter.c and MiscClosures.h and+  raising this limit.++  Note that the limit is the number of words passed on the stack.+  If the calling convention passes part of the tuple in registers, the+  maximum number of tuple elements may be larger. Elements can also+  take multiple words on the stack (for example Double# on a 32 bit+  platform).+ -}+maxTupleReturnNativeStackSize :: WordOff+maxTupleReturnNativeStackSize = 62++{-+  Construct the call_info word that stg_ctoi_t, stg_ret_t and stg_primcall+  use to convert arguments between the native calling convention and the+  interpreter.++  See Note [GHCi and native call registers] for more information.+ -}+mkNativeCallInfoSig :: Platform -> NativeCallInfo -> Word32+mkNativeCallInfoSig platform NativeCallInfo{..}+  | nativeCallType == NativeTupleReturn && nativeCallStackSpillSize > maxTupleReturnNativeStackSize+  = pprPanic "mkNativeCallInfoSig: tuple too big for the bytecode compiler"+             (ppr nativeCallStackSpillSize <+> text "stack words." <+>+              text "Use -fobject-code to get around this limit"+             )+  | otherwise+  = -- 24 bits for register bitmap+    assertPpr (length argRegs <= 24) (text "too many registers for bitmap:" <+> ppr (length argRegs))++    -- 8 bits for continuation offset (only for NativeTupleReturn)+    assertPpr (cont_offset < 255) (text "continuation offset too large:" <+> ppr cont_offset)++    -- all regs accounted for+    assertPpr (all (`elem` (map fst argRegs)) (regSetToList nativeCallRegs))+      ( vcat+        [ text "not all registers accounted for"+        , text "argRegs:" <+> ppr argRegs+        , text "nativeCallRegs:" <+> ppr nativeCallRegs+        ] ) $+      -- SIMD GHCi TODO: the above assertion doesn't account for register overlap;+      -- it will need to be adjusted for SIMD vector support in the bytecode interpreter.++    foldl' reg_bit 0 argRegs .|. (cont_offset `shiftL` 24)+  where+    cont_offset :: Word32+    cont_offset+      | nativeCallType == NativeTupleReturn = fromIntegral nativeCallStackSpillSize+      | otherwise                           = 0 -- there is no continuation for primcalls++    reg_bit :: Word32 -> (GlobalReg, Int) -> Word32+    reg_bit x (r, n)+      | r `elemRegSet` nativeCallRegs = x .|. 1 `shiftL` n+      | otherwise                     = x+    argRegs = zip (allArgRegsCover platform SCALAR_ARG_REGS) [0..]+      -- The bytecode interpreter does not (currently) handle vector registers,+      -- so we only use the scalar argument-passing registers here.++mkNativeCallInfoLit :: Platform -> NativeCallInfo -> Literal+mkNativeCallInfoLit platform call_info =+  mkLitWord platform . fromIntegral $ mkNativeCallInfoSig platform call_info  iNTERP_STACK_CHECK_THRESH :: Int iNTERP_STACK_CHECK_THRESH = INTERP_STACK_CHECK_THRESH
+ GHC/ByteCode/Breakpoints.hs view
@@ -0,0 +1,299 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE DerivingStrategies #-}++-- | Breakpoint information constructed during ByteCode generation.+--+-- Specifically, code-generation breakpoints are referred to as "internal+-- breakpoints", the internal breakpoint data for a module is stored in+-- 'InternalModBreaks', and is uniquely identified at runtime by an+-- 'InternalBreakpointId'.+--+-- See Note [ModBreaks vs InternalModBreaks] and Note [Breakpoint identifiers]+module GHC.ByteCode.Breakpoints+  ( -- * Internal Mod Breaks+    InternalModBreaks(..), CgBreakInfo(..)+  , mkInternalModBreaks, imodBreaks_module++    -- ** Internal breakpoint identifier+  , InternalBreakpointId(..), BreakInfoIndex+  , InternalBreakLoc(..)++    -- * Operations++    -- ** Internal-level operations+  , getInternalBreak++    -- ** Source-level information operations+  , getBreakLoc, getBreakVars, getBreakDecls, getBreakCCS+  , getBreakSourceId, getBreakSourceMod++    -- * Utils+  , seqInternalModBreaks++  )+  where++import GHC.Prelude+import GHC.Types.SrcLoc+import GHC.Types.Name.Occurrence+import Control.DeepSeq+import Data.IntMap.Strict (IntMap)+import qualified Data.IntMap.Strict as IM++import GHC.HsToCore.Breakpoints+import GHC.Iface.Syntax++import GHC.Unit.Module (Module)+import GHC.Utils.Outputable+import GHC.Utils.Panic+import Data.Array++{-+Note [ModBreaks vs InternalModBreaks]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+'ModBreaks' and 'BreakpointId's must not to be confused with+'InternalModBreaks' and 'InternalBreakId's.++'ModBreaks' is constructed once during HsToCore from the information attached+to source-level breakpoint ticks and is never changed afterwards. A 'ModBreaks'+can be queried using 'BreakpointId's, which uniquely identifies a breakpoint+within the list of breakpoint information for a given module's 'ModBreaks'.++'InternalModBreaks' are constructed during bytecode generation and are indexed+by a 'InternalBreakpointId'. They contain all the information relevant to a+breakpoint for code generation that can be accessed during runtime execution+(such as a 'BreakArray' for triggering breakpoints). 'InternalBreakpointId's+are used at runtime to trigger and inspect breakpoints -- a 'BRK_FUN'+instruction receives 'InternalBreakpointId' as an argument.++We keep a mapping from 'InternalModBreaks' to a 'BreakpointId', which can then be used+to get source-level information about a breakpoint via the corresponding 'ModBreaks'.++Notably, 'InternalModBreaks' can contain entries for so-called internal+breakpoints, which do not necessarily have a source-level location attached to+it (i.e. do not have a matching entry in 'ModBreaks'). We may leverage this to+introduce breakpoints during code generation for features such as stepping-out.++Note [Breakpoint identifiers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Before optimization a breakpoint is identified uniquely with a tick module+and a tick index. See 'BreakpointId'. A tick module contains an array, indexed+with the tick indexes, which indicates breakpoint status.++When we generate ByteCode, we collect information for every breakpoint at+their *occurrence sites* (see CgBreakInfo) and these info+are stored in the ModIface of the occurrence module. Because of inlining, we+can't reuse the tick index to uniquely identify an occurrence; because of+cross-module inlining, we can't assume that the occurrence module is the same+as the tick module (#24712).++So every breakpoint occurrence gets assigned a module-unique *info index* and+we store it alongside the occurrence module (*info module*) in the+'InternalBreakpointId' datatype. This is the index that we use at runtime to+identify a breakpoint.++When the internal breakpoint has a matching tick-level breakpoint we can fetch+the related tick-level information by first looking up a mapping+@'InternalBreakpointId' -> 'BreakpointId'@ in @'CgBreakInfo'@.+-}++--------------------------------------------------------------------------------+-- * Internal breakpoint identifiers+--------------------------------------------------------------------------------++-- | Internal breakpoint info index+type BreakInfoIndex = Int++-- | Internal breakpoint identifier+--+-- Indexes into the structures in the @'InternalModBreaks'@ produced during ByteCode generation.+-- See Note [Breakpoint identifiers]+data InternalBreakpointId = InternalBreakpointId+  { ibi_info_mod   :: !Module         -- ^ Breakpoint info module+  , ibi_info_index :: !BreakInfoIndex -- ^ Breakpoint info index+  }+  deriving (Eq, Ord)++--------------------------------------------------------------------------------+-- * Internal Mod Breaks+--------------------------------------------------------------------------------++-- | Internal mod breaks store the runtime-relevant information of breakpoints.+--+-- Importantly, it maps 'InternalBreakpointId's to 'CgBreakInfo'.+--+-- 'InternalModBreaks' are constructed during bytecode generation and stored in+-- 'CompiledByteCode' afterwards.+data InternalModBreaks = InternalModBreaks+      { imodBreaks_breakInfo :: !(IntMap CgBreakInfo)+        -- ^ Access code-gen time information about a breakpoint, indexed by+        -- 'InternalBreakpointId'.++      , imodBreaks_modBreaks :: !ModBreaks+        -- ^ Store the ModBreaks for this module+        --+        -- Recall Note [Breakpoint identifiers]: for some module A, an+        -- *occurrence* of a breakpoint in A may have been inlined from some+        -- breakpoint *defined* in module B.+        --+        -- This 'ModBreaks' contains information regarding all the breakpoints+        -- defined in the module this 'InternalModBreaks' corresponds to. It+        -- /does not/ necessarily have information regarding all the breakpoint+        -- occurrences registered in 'imodBreaks_breakInfo'. Some of those+        -- occurrences may refer breakpoints inlined from other modules.+      }++-- | Construct an 'InternalModBreaks'.+--+-- INVARIANT: The given 'ModBreaks' correspond to the same module as this+-- 'InternalModBreaks' module (the first argument) and its breakpoint infos+-- (the @IntMap CgBreakInfo@ argument)+mkInternalModBreaks :: Module -> IntMap CgBreakInfo -> ModBreaks -> InternalModBreaks+mkInternalModBreaks mod im mbs =+  assertPpr (mod == modBreaks_module mbs)+    (text "Constructing InternalModBreaks with the ModBreaks of a different module!") $+      InternalModBreaks im mbs++-- | Get the module to which these 'InternalModBreaks' correspond+imodBreaks_module :: InternalModBreaks -> Module+imodBreaks_module = modBreaks_module . imodBreaks_modBreaks++-- | Information about a breakpoint that we know at code-generation time+-- In order to be used, this needs to be hydrated relative to the current HscEnv by+-- 'hydrateCgBreakInfo'. Everything here can be fully forced and that's critical for+-- preventing space leaks (see #22530)+data CgBreakInfo+   = CgBreakInfo+   { cgb_tyvars  :: ![IfaceTvBndr] -- ^ Type variables in scope at the breakpoint+   , cgb_vars    :: ![Maybe (IfaceIdBndr, Word)]+   , cgb_resty   :: !IfaceType+   , cgb_tick_id :: !(Either InternalBreakLoc BreakpointId)+     -- ^ This field records the original breakpoint tick identifier for this+     -- internal breakpoint info. It is used to convert a breakpoint+     -- *occurrence* index ('InternalBreakpointId') into a *definition* index+     -- ('BreakpointId').+     --+     -- The modules of breakpoint occurrence and breakpoint definition are not+     -- necessarily the same: See Note [Breakpoint identifiers].+     --+     -- If there is no original tick identifier (that is, the breakpoint was+     -- created during code generation), we re-use the BreakpointId of something else.+     -- It would also be reasonable to have an @Either something BreakpointId@+     -- for @cgb_tick_id@, but currently we can always re-use a source-level BreakpointId.+     -- In the case of step-out, see Note [Debugger: Stepout internal break locs]+   }+-- See Note [Syncing breakpoint info] in GHC.Runtime.Eval++-- | Breakpoints created during code generation don't have a source-level tick+-- location. Instead, we re-use an existing one.+newtype InternalBreakLoc = InternalBreakLoc { internalBreakLoc :: BreakpointId }+  deriving newtype (Eq, NFData, Outputable)++-- | Get an internal breakpoint info by 'InternalBreakpointId'+getInternalBreak :: InternalBreakpointId -> InternalModBreaks -> CgBreakInfo+getInternalBreak (InternalBreakpointId mod ix) imbs =+  assert_modules_match mod (imodBreaks_module imbs) $+    imodBreaks_breakInfo imbs IM.! ix++-- | Assert that the module in the 'InternalBreakpointId' and in+-- 'InternalModBreaks' match.+assert_modules_match :: Module -> Module -> a -> a+assert_modules_match ibi_mod imbs_mod =+  assertPpr (ibi_mod == imbs_mod)+    (text "Tried to query the InternalModBreaks of module" <+> ppr imbs_mod+        <+> text "with an InternalBreakpointId for module" <+> ppr ibi_mod)++--------------------------------------------------------------------------------+-- Tick-level Breakpoint information+--------------------------------------------------------------------------------++-- | Get the source module and tick index for this breakpoint+-- (as opposed to the module where this breakpoint occurs, which is in 'InternalBreakpointId')+getBreakSourceId :: InternalBreakpointId -> InternalModBreaks -> BreakpointId+getBreakSourceId (InternalBreakpointId ibi_mod ibi_ix) imbs =+  assert_modules_match ibi_mod (imodBreaks_module imbs) $+    let cgb = imodBreaks_breakInfo imbs IM.! ibi_ix+     in either internalBreakLoc id (cgb_tick_id cgb)++-- | Get the source module for this breakpoint (where the breakpoint is defined)+getBreakSourceMod :: InternalBreakpointId -> InternalModBreaks -> Module+getBreakSourceMod (InternalBreakpointId ibi_mod ibi_ix) imbs =+  assert_modules_match ibi_mod (imodBreaks_module imbs) $+    let cgb = imodBreaks_breakInfo imbs IM.! ibi_ix+     in either (bi_tick_mod . internalBreakLoc) bi_tick_mod (cgb_tick_id cgb)++-- | Get the source span for this breakpoint+getBreakLoc :: (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO SrcSpan+getBreakLoc = getBreakXXX modBreaks_locs++-- | Get the vars for this breakpoint+getBreakVars :: (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO [OccName]+getBreakVars = getBreakXXX modBreaks_vars++-- | Get the decls for this breakpoint+getBreakDecls :: (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO [String]+getBreakDecls = getBreakXXX modBreaks_decls++-- | Get the decls for this breakpoint+getBreakCCS :: (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO ((String, String))+getBreakCCS = getBreakXXX modBreaks_ccs++-- | Internal utility to access a ModBreaks field at a particular breakpoint index+--+-- Recall Note [Breakpoint identifiers]: the internal breakpoint module (the+-- *occurrence* module) doesn't necessarily match the module where the+-- tick breakpoint was defined with the relevant 'ModBreaks'.+--+-- When the tick module is the same as the internal module, we use the stored+-- 'ModBreaks'. When the tick module is different, we need to look up the+-- 'ModBreaks' in the HUG for that other module.+--+-- When there is no tick module (the breakpoint was generated at codegen), use+-- the function on internal mod breaks.+--+-- To avoid cyclic dependencies, we instead receive a function that looks up+-- the 'ModBreaks' given a 'Module'+getBreakXXX :: (ModBreaks -> Array BreakTickIndex a) -> (Module -> IO ModBreaks) -> InternalBreakpointId -> InternalModBreaks -> IO a+getBreakXXX view lookupModule (InternalBreakpointId ibi_mod ibi_ix) imbs =+  assert_modules_match ibi_mod (imodBreaks_module imbs) $ do+    let cgb = imodBreaks_breakInfo imbs IM.! ibi_ix+    case either internalBreakLoc id (cgb_tick_id cgb) of+      BreakpointId{bi_tick_mod, bi_tick_index}+        | bi_tick_mod == ibi_mod+        -> do+          let these_mbs = imodBreaks_modBreaks imbs+          return $ view these_mbs ! bi_tick_index+        | otherwise+        -> do+          other_mbs <- lookupModule bi_tick_mod+          return $ view other_mbs ! bi_tick_index++--------------------------------------------------------------------------------+-- Instances+--------------------------------------------------------------------------------++-- | Fully force an 'InternalModBreaks' value+seqInternalModBreaks :: InternalModBreaks -> ()+seqInternalModBreaks InternalModBreaks{..} =+    rnf (fmap seqCgBreakInfo imodBreaks_breakInfo)+  where+    seqCgBreakInfo :: CgBreakInfo -> ()+    seqCgBreakInfo CgBreakInfo{..} =+        rnf cgb_tyvars `seq`+        rnf cgb_vars `seq`+        rnf cgb_resty `seq`+        rnf cgb_tick_id++instance Outputable InternalBreakpointId where+  ppr InternalBreakpointId{..} =+    text "InternalBreakpointId" <+> ppr ibi_info_mod <+> ppr ibi_info_index++instance NFData InternalBreakpointId where+  rnf InternalBreakpointId{..} =+    rnf ibi_info_mod `seq` rnf ibi_info_index++instance Outputable CgBreakInfo where+   ppr info = text "CgBreakInfo" <+>+              parens (ppr (cgb_vars info) <+>+                      ppr (cgb_resty info) <+>+                      ppr (cgb_tick_id info))
GHC/ByteCode/InfoTable.hs view
@@ -13,19 +13,17 @@ import GHC.Platform import GHC.Platform.Profile -import GHC.ByteCode.Types-import GHC.Runtime.Interpreter+import GHCi.Message  import GHC.Types.Name       ( Name, getName )-import GHC.Types.Name.Env import GHC.Types.RepType  import GHC.Core.DataCon     ( DataCon, dataConRepArgTys, dataConIdentity )-import GHC.Core.TyCon       ( TyCon, tyConFamilySize, isDataTyCon, tyConDataCons )+import GHC.Core.TyCon       ( TyCon, tyConFamilySize, isBoxedDataTyCon, tyConDataCons ) import GHC.Core.Multiplicity     ( scaledThing )  import GHC.StgToCmm.Layout  ( mkVirtConstrSizes )-import GHC.StgToCmm.Closure ( tagForCon, NonVoid (..) )+import GHC.StgToCmm.Closure ( tagForCon )  import GHC.Utils.Misc import GHC.Utils.Panic@@ -35,33 +33,38 @@ -}  -- Make info tables for the data decls in this module-mkITbls :: Interp -> Profile -> [TyCon] -> IO ItblEnv-mkITbls interp profile tcs =-  foldr plusNameEnv emptyNameEnv <$>-    mapM mkITbl (filter isDataTyCon tcs)+mkITbls :: Profile -> [TyCon] -> [(Name, ConInfoTable)]+mkITbls profile tcs = concatMap mkITbl (filter isBoxedDataTyCon tcs)  where-  mkITbl :: TyCon -> IO ItblEnv+  mkITbl :: TyCon -> [(Name, ConInfoTable)]   mkITbl tc     | dcs `lengthIs` n -- paranoia; this is an assertion.-    = make_constr_itbls interp profile dcs+    = make_constr_itbls profile 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 :: Interp -> Profile -> [DataCon] -> IO ItblEnv-make_constr_itbls interp profile cons =+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-  mkItblEnv <$> mapM (uncurry mk_itbl) (zip cons [0..])- where-  mk_itbl :: DataCon -> Int -> IO (Name,ItblPtr)-  mk_itbl dcon conNo = do-     let rep_args = [ NonVoid prim_rep+  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) ] @@ -79,7 +82,3 @@          platform = profilePlatform profile          constants = platformConstants platform          tables_next_to_code = platformTablesNextToCode platform--     r <- interpCmd interp (MkConInfoTable tables_next_to_code ptrs' nptrs_really-                              conNo (tagForCon platform dcon) descr)-     return (getName dcon, ItblPtr r)
GHC/ByteCode/Instr.hs view
@@ -1,5 +1,6 @@-+{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-} {-# OPTIONS_GHC -funbox-strict-fields #-} -- --  (c) The University of Glasgow 2002-2006@@ -13,20 +14,24 @@ import GHC.Prelude  import GHC.ByteCode.Types-import GHCi.RemoteTypes-import GHCi.FFI (C_ffi_cif)+import GHC.Cmm.Type (Width) import GHC.StgToCmm.Layout     ( ArgRep(..) ) import GHC.Utils.Outputable import GHC.Types.Name-import GHC.Types.Unique import GHC.Types.Literal+import GHC.Types.Unique import GHC.Core.DataCon import GHC.Builtin.PrimOps-import GHC.Runtime.Heap.Layout+import GHC.Runtime.Heap.Layout ( StgWord ) +import Data.Int import Data.Word-import GHC.Stack.CCS (CostCentre) +#if MIN_VERSION_rts(1,0,3)+import Data.ByteString (ByteString)+#endif++ import GHC.Stg.Syntax  -- ----------------------------------------------------------------------------@@ -38,57 +43,58 @@         protoBCOInstrs     :: [BCInstr],  -- instrs         -- arity and GC info         protoBCOBitmap     :: [StgWord],-        protoBCOBitmapSize :: Word16,+        protoBCOBitmapSize :: Word,         protoBCOArity      :: Int,         -- what the BCO came from, for debugging only-        protoBCOExpr       :: Either [CgStgAlt] CgStgRhs,-        -- malloc'd pointers-        protoBCOFFIs       :: [FFIInfo]+        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+   = 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_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  !Word16-   | PUSH16 !Word16-   | PUSH32 !Word16+   | PUSH8  !ByteOff+   | PUSH16 !ByteOff+   | PUSH32 !ByteOff -   -- Push the specifiec local as a 8, 16, 32 bit value onto the stack, but the+   -- 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 constracting new data types, in+   -- the ones used for PACK (i.e., actually constructing new data types, in    -- which case we use PUSH{8,16,32})-   | PUSH8_W  !Word16-   | PUSH16_W !Word16-   | PUSH32_W !Word16+   | PUSH8_W  !ByteOff+   | PUSH16_W !ByteOff+   | PUSH32_W !ByteOff -   -- Push a ptr  (these all map to PUSH_G really)+   -- 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)-   | PUSH_ALTS_UNLIFTED (ProtoBCO Name) ArgRep+   | PUSH_ALTS          (ProtoBCO Name) ArgRep    | PUSH_ALTS_TUPLE    (ProtoBCO Name) -- continuation-                        !TupleInfo+                        !NativeCallInfo                         (ProtoBCO Name) -- tuple return BCO     -- Pushing 8, 16 and 32 bits of padding (for constructors).@@ -100,8 +106,8 @@    | PUSH_UBX8  Literal    | PUSH_UBX16 Literal    | PUSH_UBX32 Literal-   | PUSH_UBX   Literal Word16-        -- push this int/float/double/addr, on the stack. Word16+   | 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@@ -110,6 +116,10 @@         -- 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@@ -123,42 +133,77 @@    | PUSH_APPLY_PPPPP    | PUSH_APPLY_PPPPPP -   | SLIDE     Word16{-this many-} Word16{-down by this much-}+   -- | 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  !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+   | 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_F  Float  LocalLabel-   | TESTEQ_F  Float  LocalLabel-   | TESTLT_D  Double LocalLabel-   | TESTEQ_D  Double 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.-   | TESTLT_P  Word16 LocalLabel-   | TESTEQ_P  Word16 LocalLabel +   -- | 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            Word16    -- stack frame size-                      (RemotePtr C_ffi_cif) -- addr of the glue code-                      Word16    -- flags.+   | CCALL            !WordOff  -- stack frame size+                      !FFIInfo  -- libffi ffi_cif function prototype+                      !Word16   -- flags.                                 --                                 -- 0x1: call is interruptible                                 -- 0x2: call is unsafe@@ -166,19 +211,71 @@                                 -- (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          Word16 -- to the ptr N words down the stack,-                      Word16 -- add M (interpreted as a signed 16-bit entity)+   | SWIZZLE          !WordOff -- to the ptr N words down the stack,+                      !Int     -- add M     -- To Infinity And Beyond    | ENTER-   | RETURN                 -- return a lifted value-   | RETURN_UNLIFTED ArgRep -- return an unlifted value, here's its rep-   | RETURN_TUPLE           -- return an unboxed tuple (info already on stack)+   | 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          Word16 Unique (RemotePtr CostCentre)+   | 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 @@ -188,10 +285,9 @@                  , protoBCOBitmap     = bitmap                  , protoBCOBitmapSize = bsize                  , protoBCOArity      = arity-                 , protoBCOExpr       = origin-                 , protoBCOFFIs       = ffis })+                 , protoBCOExpr       = origin })       = (text "ProtoBCO" <+> ppr name <> char '#' <> int arity-                <+> text (show ffis) <> colon)+                <> colon)         $$ nest 3 (case origin of                       Left alts ->                         vcat (zipWith (<+>) (char '{' : repeat (char ';'))@@ -227,7 +323,7 @@   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) =+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@@ -249,10 +345,9 @@                                                <> 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_ALTS_TUPLE bco tuple_info tuple_bco) =-                               hang (text "PUSH_ALTS_TUPLE" <+> ppr tuple_info)+   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) @@ -264,6 +359,7 @@    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"@@ -291,6 +387,22 @@    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@@ -299,20 +411,52 @@    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 flags) = text "CCALL   " <+> ppr off-                                                <+> text "marshall code at"-                                               <+> text (show marshall_addr)+   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                = text "RETURN"-   ppr (RETURN_UNLIFTED pk)  = text "RETURN_UNLIFTED  " <+> ppr pk+   ppr (RETURN pk)           = text "RETURN  " <+> ppr pk    ppr (RETURN_TUPLE)        = text "RETURN_TUPLE"-   ppr (BRK_FUN index uniq _cc) = text "BRK_FUN" <+> ppr index <+> ppr uniq <+> text "<cc>"+   ppr (BRK_FUN (InternalBreakpointId info_mod infox))+                             = text "BRK_FUN" <+> text "<breakarray>"+                               <+> ppr info_mod <+> ppr infox+                               <+> text "<cc>"+#if MIN_VERSION_rts(1,0,3)+   ppr (BCO_NAME nm)         = text "BCO_NAME" <+> text (show nm)+#endif   @@ -343,16 +487,14 @@ bciStackUse PUSH_G{}              = 1 bciStackUse PUSH_PRIMOP{}         = 1 bciStackUse PUSH_BCO{}            = 1-bciStackUse (PUSH_ALTS bco)       = 2 {- profiling only, restore CCCS -} ++bciStackUse (PUSH_ALTS bco _)     = 2 {- profiling only, restore CCCS -} +                                     3 + protoBCOStackUse bco-bciStackUse (PUSH_ALTS_UNLIFTED bco _) = 2 {- profiling only, restore CCCS -} +-                                         4 + protoBCOStackUse bco bciStackUse (PUSH_ALTS_TUPLE bco info _) =-   -- (tuple_bco, tuple_info word, cont_bco, stg_ctoi_t)+   -- (tuple_bco, call_info word, cont_bco, stg_ctoi_t)    -- tuple-   -- (tuple_info, tuple_bco, stg_ret_t)+   -- (call_info, tuple_bco, stg_ret_t)    1 {- profiling only -} +-   7 + fromIntegral (tupleSize info) + protoBCOStackUse bco+   7 + fromIntegral (nativeCallSize info) + protoBCOStackUse bco bciStackUse (PUSH_PAD8)           = 1  -- overapproximation bciStackUse (PUSH_PAD16)          = 1  -- overapproximation bciStackUse (PUSH_PAD32)          = 1  -- overapproximation on 64bit arch@@ -360,6 +502,7 @@ 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@@ -380,6 +523,22 @@ 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@@ -389,10 +548,35 @@ bciStackUse CASEFAIL{}            = 0 bciStackUse JMP{}                 = 0 bciStackUse ENTER{}               = 0-bciStackUse RETURN{}              = 0-bciStackUse RETURN_UNLIFTED{}     = 1 -- pushes stg_ret_X for some X+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 @@ -402,3 +586,6 @@ bciStackUse MKAP{}                = 0 bciStackUse MKPAP{}               = 0 bciStackUse PACK{}                = 1 -- worst case is PACK 0 words+#if MIN_VERSION_rts(1,0,3)+bciStackUse BCO_NAME{}            = 0+#endif
GHC/ByteCode/Linker.hs view
@@ -1,6 +1,9 @@ {-# 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@@ -8,13 +11,9 @@  -- | Bytecode assembler and linker module GHC.ByteCode.Linker-  ( ClosureEnv-  , emptyClosureEnv-  , extendClosureEnv-  , linkBCO+  ( linkBCO   , lookupStaticPtr   , lookupIE-  , nameToCLabel   , linkFail   ) where@@ -25,23 +24,26 @@ import GHC.ByteCode.Types import GHCi.RemoteTypes import GHCi.ResolvedBCO-import GHCi.BreakArray  import GHC.Builtin.PrimOps-import GHC.Builtin.Names+import GHC.Builtin.PrimOps.Ids +import GHC.Unit.Module.Env import GHC.Unit.Types-import GHC.Unit.Module.Name  import GHC.Data.FastString+import GHC.Data.Maybe import GHC.Data.SizedSeq +import GHC.Linker.Types+ import GHC.Utils.Panic-import GHC.Utils.Panic.Plain 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@@ -52,125 +54,169 @@   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   :: Interp-  -> ItblEnv-  -> ClosureEnv+  -> PkgsLoaded+  -> LinkerEnv+  -> LinkedBreaks   -> NameEnv Int-  -> RemoteRef BreakArray   -> UnlinkedBCO   -> IO ResolvedBCO-linkBCO interp ie ce bco_ix breakarray+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 <- mapM (fmap fromIntegral . lookupLiteral interp ie) (ssElts lits0)-  ptrs <- mapM (resolvePtr interp ie ce bco_ix breakarray) (ssElts ptrs0)-  return (ResolvedBCO isLittleEndian arity insns bitmap-              (listArray (0, fromIntegral (sizeSS lits0)-1) lits)-              (addListToSS emptySS ptrs))+  (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 -> ItblEnv -> BCONPtr -> IO Word-lookupLiteral interp ie ptr = case ptr of+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 ie nm+    Ptr a# <- lookupIE interp pkgs_loaded (itbl_env le) nm     return (W# (int2Word# (addr2Int# a#)))-  BCONPtrStr _ ->-    -- should be eliminated during assembleBCOs-    panic "lookupLiteral: BCONPtrStr"+  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 addr_of_label_string+  m <- lookupSymbol interp (IFaststringSymbol addr_of_label_string)   case m of     Just ptr -> return ptr     Nothing  -> linkFail "GHC.ByteCode.Linker: can't find label"-                  (unpackFS addr_of_label_string)+                  (ppr addr_of_label_string) -lookupIE :: Interp -> ItblEnv -> Name -> IO (Ptr ())-lookupIE interp ie con_nm =+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 = nameToCLabel con_nm "con_info"-       m <- lookupSymbol interp sym_to_find1+       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 = nameToCLabel con_nm "static_info"-                   n <- lookupSymbol interp sym_to_find2+                   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"-                                      (unpackFS sym_to_find1 ++ " or " ++-                                       unpackFS sym_to_find2)+                                      (ppr sym_to_find1 <> " or " <>+                                       ppr sym_to_find2) -lookupPrimOp :: Interp -> PrimOp -> IO (RemotePtr ())-lookupPrimOp interp primop = do+-- 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 <- lookupSymbol interp (mkFastString sym_to_find)+  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)" sym_to_find+    Nothing -> linkFail "GHC.ByteCode.Linker.lookupCE(primop)" (text sym_to_find)  resolvePtr   :: Interp-  -> ItblEnv-  -> ClosureEnv+  -> PkgsLoaded+  -> LinkerEnv+  -> LinkedBreaks   -> NameEnv Int-  -> RemoteRef BreakArray   -> BCOPtr   -> IO ResolvedBCOPtr-resolvePtr interp ie ce bco_ix breakarray ptr = case ptr of+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 ce nm+    | Just (_, rhv) <- lookupNameEnv (closure_env le) nm     -> return (ResolvedBCOPtr (unsafeForeignRefToRemoteRef rhv))      | otherwise     -> assertPpr (isExternalName nm) (ppr nm) $        do-          let sym_to_find = nameToCLabel nm "closure"-          m <- lookupSymbol interp sym_to_find+          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" (unpackFS sym_to_find)+            Nothing -> linkFail "GHC.ByteCode.Linker.lookupCE" (ppr sym_to_find)    BCOPtrPrimOp op-    -> ResolvedBCOStaticPtr <$> lookupPrimOp interp op+    -> ResolvedBCOStaticPtr <$> lookupPrimOp interp pkgs_loaded op    BCOPtrBCO bco-    -> ResolvedBCOPtrBCO <$> linkBCO interp ie ce bco_ix breakarray bco+    -> ResolvedBCOPtrBCO <$> linkBCO interp pkgs_loaded le lb bco_ix bco -  BCOPtrBreakArray-    -> return (ResolvedBCOPtrBreakArray breakarray)+  BCOPtrBreakArray tick_mod ->+    withForeignRef (expectJust (lookupModuleEnv (breakarray_env lb) tick_mod)) $+      \ba -> pure $ ResolvedBCOPtrBreakArray ba -linkFail :: String -> String -> IO a+-- | 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:"-                , ' ' : ' ' : what+                , ' ' : ' ' : 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"@@ -181,31 +227,14 @@                 ])  -nameToCLabel :: Name -> String -> FastString-nameToCLabel n suffix = mkFastString label-  where-    encodeZ = zString . 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 (occNameFS (nameOccName n)) -    label = concat-        [ if pkgKey == mainUnit then "" else packagePart ++ "_"-        , modulePart-        , '_':occPart-        , '_':suffix-        ]  + -- See Note [Primop wrappers] in GHC.Builtin.PrimOps primopToCLabel :: PrimOp -> String -> String primopToCLabel primop suffix = concat-    [ "ghczmprim_GHCziPrimopWrappers_"+    [ "ghczminternal_GHCziInternalziPrimopWrappers_"     , zString (zEncodeFS (occNameFS (primOpOcc primop)))     , '_':suffix     ]
GHC/ByteCode/Types.hs view
@@ -1,5 +1,9 @@+{-# LANGUAGE CPP                        #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RecordWildCards            #-}+{-# LANGUAGE TypeApplications           #-}+{-# LANGUAGE MagicHash                  #-}+{-# LANGUAGE UnliftedNewtypes           #-} -- --  (c) The University of Glasgow 2002-2006 --@@ -7,71 +11,91 @@ -- | Bytecode assembler types module GHC.ByteCode.Types   ( CompiledByteCode(..), seqCompiledByteCode+  , BCOByteArray(..), mkBCOByteArray   , FFIInfo(..)   , RegBitmap(..)-  , TupleInfo(..), voidTupleInfo-  , ByteOff(..), WordOff(..)+  , NativeCallType(..), NativeCallInfo(..), voidTupleReturnInfo, voidPrimCallInfo+  , ByteOff(..), WordOff(..), HalfWord(..)   , UnlinkedBCO(..), BCOPtr(..), BCONPtr(..)   , ItblEnv, ItblPtr(..)-  , CgBreakInfo(..)-  , ModBreaks (..), BreakIndex, emptyModBreaks-  , CCostCentre+  , 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.SizedSeq-import GHC.Types.Id+import GHC.Data.FlatBag import GHC.Types.Name import GHC.Types.Name.Env import GHC.Utils.Outputable import GHC.Builtin.PrimOps-import GHC.Core.Type-import GHC.Types.SrcLoc-import GHCi.BreakArray+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.Array-import Data.Array.Base  ( UArray(..) ) import Data.ByteString (ByteString)-import Data.IntMap (IntMap)-import qualified Data.IntMap as IntMap-import Data.Maybe (catMaybes) import qualified GHC.Exts.Heap as Heap-import GHC.Stack.CCS import GHC.Cmm.Expr ( GlobalRegSet, emptyRegSet, regSetToList )+import GHC.Unit.Module  -- ----------------------------------------------------------------------------- -- 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)+  { 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".   }-                -- ToDo: we're not tracking strings that we malloc'd-newtype FFIInfo = FFIInfo (RemotePtr C_ffi_cif)-  deriving (Show, NFData) +-- | A libffi ffi_cif function prototype.+data FFIInfo = FFIInfo { ffiInfoArgs :: ![FFIType], ffiInfoRet :: !FFIType }+  deriving (Show)+ instance Outputable CompiledByteCode where-  ppr CompiledByteCode{..} = ppr bc_bcos+  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`-  seqEltsNameEnv rnf bc_itbls `seq`-  rnf bc_ffis `seq`+  rnf bc_itbls `seq`   rnf bc_strs `seq`-  rnf (fmap seqModBreaks bc_breaks)+  case bc_breaks of+    Nothing -> ()+    Just ibks -> seqInternalModBreaks ibks  newtype ByteOff = ByteOff Int     deriving (Enum, Eq, Show, Integral, Num, Ord, Real, Outputable)@@ -79,6 +103,12 @@ 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) @@ -104,38 +134,125 @@     See GHC.StgToByteCode.layoutTuple for more details. -}-data TupleInfo = TupleInfo-  { tupleSize            :: !WordOff   -- total size of tuple in words-  , tupleRegs            :: !GlobalRegSet-  , tupleNativeStackSize :: !WordOff {- words spilled on the stack by-                                        GHCs native calling convention -}-  } deriving (Show) -instance Outputable TupleInfo where-  ppr TupleInfo{..} = text "<size" <+> ppr tupleSize <+>-                      text "stack" <+> ppr tupleNativeStackSize <+>-                      text "regs"  <+>-                      ppr (map (text.show) $ regSetToList tupleRegs) <>-                      char '>'+data NativeCallType = NativePrimCall+                    | NativeTupleReturn+  deriving (Eq) -voidTupleInfo :: TupleInfo-voidTupleInfo = TupleInfo 0 emptyRegSet 0+data NativeCallInfo = NativeCallInfo+  { nativeCallType           :: !NativeCallType+  , nativeCallSize           :: !WordOff   -- total size of arguments in words+  , nativeCallRegs           :: !GlobalRegSet+  , nativeCallStackSpillSize :: !WordOff {- words spilled on the stack by+                                            GHCs native calling convention -}+  } +instance Outputable NativeCallInfo where+  ppr NativeCallInfo{..} = text "<arg_size" <+> ppr nativeCallSize <+>+                           text "stack" <+> ppr nativeCallStackSpillSize <+>+                           text "regs"  <+>+                           ppr (map (text @SDoc . show) $ regSetToList nativeCallRegs) <>+                           char '>'+++voidTupleReturnInfo :: NativeCallInfo+voidTupleReturnInfo = NativeCallInfo NativeTupleReturn 0 emptyRegSet 0++voidPrimCallInfo :: NativeCallInfo+voidPrimCallInfo = NativeCallInfo NativePrimCall 0 emptyRegSet 0+ type ItblEnv = NameEnv (Name, ItblPtr)+type AddrEnv = NameEnv (Name, AddrPtr)         -- We need the Name in the range so we know which         -- elements to filter out when unloading a module  newtype ItblPtr = ItblPtr (RemotePtr Heap.StgInfoTable)   deriving (Show, NFData)+newtype AddrPtr = AddrPtr (RemotePtr ())+  deriving (NFData) +{-+--------------------------------------------------------------------------------+-- * Byte Code Objects (BCOs)+--------------------------------------------------------------------------------++Note [Case continuation BCOs]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++A stack with a BCO stack frame at the top looks like:++                                      (an StgBCO)+         |       ...        |      +---> +---------[1]--++         +------------------+      |     | info_tbl_ptr | ------++         |    OTHER FRAME   |      |     +--------------+       |+         +------------------+      |     | StgArrBytes* | <--- the byte code+         |       ...        |      |     +--------------+       |+         +------------------+      |     |     ...      |       |+         |       fvs1       |      |                            |+         +------------------+      |                            |+         |       ...        |      |        (StgInfoTable)      |+         +------------------+      |           +----------+ <---++         |      args1       |      |           |    ...   |+         +------------------+      |           +----------++         |   some StgBCO*   | -----+           | type=BCO |+         +------------------+                  +----------++      Sp | stg_apply_interp | -----+           |   ...    |+         +------------------+      |+                                   |+                                   |   (StgInfoTable)+                                   +----> +--------------++                                          |     ...      |+                                          +--------------++                                          | type=RET_BCO |+                                          +--------------++                                          |     ...      |+++In the case of bytecode objects found on the heap (e.g. thunks and functions),+the bytecode may refer to free variables recorded in the BCO closure itself.+By contrast, in /case continuation/ BCOs the code may additionally refer to free+variables in their stack frame. These are references by way of statically known+stack offsets (tracked using `BCEnv` in `StgToByteCode`).++For instance, consider the function:++    f x y = case y of ... -> g x++Here the RHS of the alternative refers to `x`, which will be recorded in the+continuation stack frame of the `case`.++Even less obvious is that case continuation BCOs may also refer to free+variables in *parent* stack frames. For instance,++    f x y = case y of+      ... -> case g x of+        ... -> x++Here, the RHS of the first alternative still refers to the `x` in the stack+frame of the `case`. Additionally, the RHS of the second alternative also+refers to `x` but it must traverse to its case's *parent* stack frame to find `x`.++However, in /case continuation/ BCOs, the code may additionally refer to free+variables that are outside of that BCO's stack frame -- some free variables of a+case continuation BCO may only be found in the stack frame of a parent BCO.++Yet, references to these out-of-frame variables are also done in terms of stack+offsets. Thus, they rely on the position of /another frame/ to be fixed. (See+Note [PUSH_L underflow] for more information about references to previous+frames and nested BCOs)++This makes case continuation BCOs special: unlike normal BCOs, case cont BCO+frames cannot be moved on the stack independently from their parent BCOs.+-}+ data UnlinkedBCO    = UnlinkedBCO {         unlinkedBCOName   :: !Name,         unlinkedBCOArity  :: {-# UNPACK #-} !Int,-        unlinkedBCOInstrs :: !(UArray Int Word16),      -- insns-        unlinkedBCOBitmap :: !(UArray Int Word64),      -- bitmap-        unlinkedBCOLits   :: !(SizedSeq BCONPtr),       -- non-ptrs-        unlinkedBCOPtrs   :: !(SizedSeq BCOPtr)         -- ptrs+        unlinkedBCOInstrs :: !(BCOByteArray Word16),      -- insns+        unlinkedBCOBitmap :: !(BCOByteArray Word),      -- bitmap+        unlinkedBCOLits   :: !(FlatBag BCONPtr),       -- non-ptrs+        unlinkedBCOPtrs   :: !(FlatBag BCOPtr)         -- ptrs    }  instance NFData UnlinkedBCO where@@ -147,7 +264,8 @@   = BCOPtrName   !Name   | BCOPtrPrimOp !PrimOp   | BCOPtrBCO    !UnlinkedBCO-  | BCOPtrBreakArray  -- a pointer to this module's BreakArray+  | BCOPtrBreakArray !Module+    -- ^ Converted to the actual 'BreakArray' remote pointer at link-time  instance NFData BCOPtr where   rnf (BCOPtrBCO bco) = rnf bco@@ -157,90 +275,25 @@   = 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` () --- | Information about a breakpoint that we know at code-generation time-data CgBreakInfo-   = CgBreakInfo-   { cgb_vars   :: [Maybe (Id,Word16)]-   , cgb_resty  :: Type-   }--- See Note [Syncing breakpoint info] in GHC.Runtime.Eval---- Not a real NFData instance because we can't rnf Id or Type-seqCgBreakInfo :: CgBreakInfo -> ()-seqCgBreakInfo CgBreakInfo{..} =-  rnf (map snd (catMaybes (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.-        -- See Note [Field modBreaks_decls]-   , 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-   }+             ppr (sizeFlatBag lits), text "lits",+             ppr (sizeFlatBag ptrs), text "ptrs" ] -{--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".--}
GHC/Cmm.hs view
@@ -6,34 +6,48 @@ {-# 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, CmmDeclSRTs, GenCmmDecl(..),-     CmmGraph, GenCmmGraph(..),+     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-     CmmTopInfo(..), CmmStackInfo(..), CmmInfoTable(..), topInfoTable,+     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@@ -42,11 +56,14 @@ import GHC.Runtime.Heap.Layout import GHC.Cmm.Expr import GHC.Cmm.Dataflow.Block-import GHC.Cmm.Dataflow.Collections 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@@ -63,6 +80,8 @@ 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@@ -89,7 +108,7 @@   = 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+     [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@@ -102,9 +121,22 @@    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@@ -116,19 +148,67 @@ -----------------------------------------------------------------------------  type CmmGraph = GenCmmGraph CmmNode-data GenCmmGraph n = CmmGraph { g_entry :: BlockId, g_graph :: Graph n C C }+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 CmmTopInfo   = TopInfo { info_tbls  :: LabelMap CmmInfoTable-                            , stack_info :: CmmStackInfo }+data GenCmmTopInfo f = TopInfo { info_tbls  :: f CmmInfoTable+                               , stack_info :: CmmStackInfo } -topInfoTable :: GenCmmDecl a CmmTopInfo (GenCmmGraph n) -> Maybe CmmInfoTable+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 @@ -145,6 +225,13 @@                -- 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 {@@ -167,12 +254,16 @@         -- place to convey this information from the code generator to         -- where we build the static closures in         -- GHC.Cmm.Info.Build.doSRTs.-    } deriving Eq+    } deriving (Eq, Ord) +instance OutputableP Platform CmmInfoTable where+    pdoc = pprInfoTable+ data ProfilingInfo   = NoProfilingInfo   | ProfilingInfo ByteString ByteString -- closure_type, closure_desc-  deriving Eq+  deriving (Eq, Ord)+ ----------------------------------------------------------------------------- --              Static Data -----------------------------------------------------------------------------@@ -183,7 +274,6 @@   | ReadOnlyData   | RelocatableReadOnlyData   | UninitialisedData-  | ReadOnlyData16      -- .rodata.cst16 on x86_64, 16-byte aligned     -- See Note [Initializers and finalizers in Cmm] in GHC.Cmm.InitFini   | InitArray           -- .init_array on ELF, .ctor on Windows   | FiniArray           -- .fini_array on ELF, .dtor on Windows@@ -203,7 +293,6 @@     Text                    -> ReadOnlySection     ReadOnlyData            -> ReadOnlySection     RelocatableReadOnlyData -> WriteProtectedSection-    ReadOnlyData16          -> ReadOnlySection     InitArray               -> ReadOnlySection     FiniArray               -> ReadOnlySection     CString                 -> ReadOnlySection@@ -230,22 +319,28 @@         -- ^ uninitialised data, N bytes long   | CmmString ByteString         -- ^ string of 8-bit values only, not zero terminated.-  | CmmFileEmbed FilePath-        -- ^ an embedded binary file+  | 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+  ppr (CmmFileEmbed fp _) = text "CmmFileEmbed" <+> text fp --- Static data before SRT generation+-- | 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@@ -254,9 +349,67 @@       -> [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 @@ -293,3 +446,115 @@ pprBBlock :: Outputable stmt => GenBasicBlock stmt -> SDoc pprBBlock (BasicBlock ident stmts) =     hang (ppr ident <> colon) 4 (vcat (map ppr stmts))+++-- --------------------------------------------------------------------------+-- Pretty-printing Cmm+-- --------------------------------------------------------------------------+--+-- This is where we walk over Cmm emitting an external representation,+-- suitable for parsing, in a syntax strongly reminiscent of C--. This+-- is the "External Core" for the Cmm layer.+--+-- As such, this should be a well-defined syntax: we want it to look nice.+-- Thus, we try wherever possible to use syntax defined in [1],+-- "The C-- Reference Manual", http://www.cs.tufts.edu/~nr/c--/index.html. We+-- differ slightly, in some cases. For one, we use I8 .. I64 for types, rather+-- than C--'s bits8 .. bits64.+--+-- We try to ensure that all information available in the abstract+-- syntax is reproduced, or reproducible, in the concrete syntax.+-- Data that is not in printed out can be reconstructed according to+-- conventions used in the pretty printer. There are at least two such+-- cases:+--      1) if a value has wordRep type, the type is not appended in the+--      output.+--      2) MachOps that operate over wordRep type are printed in a+--      C-style, rather than as their internal MachRep name.+--+-- These conventions produce much more readable Cmm output.++pprCmmGroup :: (OutputableP Platform d, OutputableP Platform info, OutputableP Platform g)+            => Platform -> GenCmmGroup d info g -> SDoc+pprCmmGroup platform tops+    = vcat $ intersperse blankLine $ map (pprTop platform) tops++-- --------------------------------------------------------------------------+-- Top level `procedure' blocks.+--++pprTop :: (OutputableP Platform d, OutputableP Platform info, OutputableP Platform i)+       => Platform -> GenCmmDecl d info i -> SDoc++pprTop platform (CmmProc info lbl live graph)++  = vcat [ pdoc platform lbl <> lparen <> rparen <+> lbrace <+> text "// " <+> ppr live+         , nest 8 $ lbrace <+> pdoc platform info $$ rbrace+         , nest 4 $ pdoc platform graph+         , rbrace ]++-- --------------------------------------------------------------------------+-- We follow [1], 4.5+--+--      section "data" { ... }+--++pprTop platform (CmmData section ds) =+    (hang (pprSection platform section <+> lbrace) 4 (pdoc platform ds))+    $$ rbrace++-- --------------------------------------------------------------------------+-- Pretty-printing info tables+-- --------------------------------------------------------------------------++pprInfoTable :: Platform -> CmmInfoTable -> SDoc+pprInfoTable platform (CmmInfoTable { cit_lbl = lbl, cit_rep = rep+                           , cit_prof = prof_info+                           , cit_srt = srt })+  = vcat [ text "label: " <> pdoc platform lbl+         , text "rep: " <> ppr rep+         , case prof_info of+             NoProfilingInfo -> empty+             ProfilingInfo ct cd ->+               vcat [ text "type: " <> text (show (BS.unpack ct))+                    , text "desc: " <> text (show (BS.unpack cd)) ]+         , text "srt: " <> pdoc platform srt ]++-- --------------------------------------------------------------------------+-- Static data.+--      Strings are printed as C strings, and we print them as I8[],+--      following C--+--++pprStatics :: Platform -> GenCmmStatics a -> SDoc+pprStatics platform (CmmStatics lbl itbl ccs payload extras) =+  pdoc platform lbl <> colon <+> pdoc platform itbl <+> ppr ccs <+> pdoc platform payload <+> ppr extras+pprStatics platform (CmmStaticsRaw lbl ds) = vcat ((pdoc platform lbl <> colon) : map (pprStatic platform) ds)++pprStatic :: Platform -> CmmStatic -> SDoc+pprStatic platform s = case s of+    CmmStaticLit lit   -> nest 4 $ text "const" <+> pdoc platform lit <> semi+    CmmUninitialised i -> nest 4 $ text "I8" <> brackets (int i)+    CmmString s'       -> nest 4 $ text "I8[]" <+> text (show s')+    CmmFileEmbed path _ -> nest 4 $ text "incbin " <+> text (show path)++-- --------------------------------------------------------------------------+-- data sections+--+pprSection :: Platform -> Section -> SDoc+pprSection platform (Section t suffix) =+  section <+> doubleQuotes (pprSectionType t <+> char '.' <+> pdoc platform suffix)+  where+    section = text "section"++pprSectionType :: SectionType -> SDoc+pprSectionType s = doubleQuotes $ case s of+  Text                    -> text "text"+  Data                    -> text "data"+  ReadOnlyData            -> text "readonly"+  RelocatableReadOnlyData -> text "relreadonly"+  UninitialisedData       -> text "uninitialised"+  InitArray               -> text "initarray"+  FiniArray               -> text "finiarray"+  CString                 -> text "cstring"+  OtherSection s'         -> text s'
GHC/Cmm/BlockId.hs view
@@ -11,10 +11,11 @@ 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 GHC.Types.Unique.Supply+import qualified GHC.Types.Unique.DSM as DSM  import GHC.Cmm.Dataflow.Label (Label, mkHooplLabel) @@ -35,12 +36,16 @@ mkBlockId :: Unique -> BlockId mkBlockId unique = mkHooplLabel $ getKey unique -newBlockId :: MonadUnique m => m BlockId-newBlockId = mkBlockId <$> getUniqueM+-- 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) "block") NoCafRefs+  = mkBlockInfoTableLabel (mkFCallName (getUnique label) (fsLit "block")) NoCafRefs
GHC/Cmm/CLabel.hs view
@@ -1,16 +1,13 @@+{-# LANGUAGE LambdaCase #-}+ ----------------------------------------------------------------------------- ----- Object-file symbols (called CLabel for histerical raisins).+-- Object-file symbols (called CLabel for historical reasons). -- -- (c) The University of Glasgow 2004-2006 -- ----------------------------------------------------------------------------- -{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}-- module GHC.Cmm.CLabel (         CLabel, -- abstract type         NeedExternDecl (..),@@ -53,6 +50,7 @@         mkDirty_MUT_VAR_Label,         mkMUT_VAR_CLEAN_infoLabel,         mkNonmovingWriteBarrierEnabledLabel,+        mkOrigThunkInfoLabel,         mkUpdInfoLabel,         mkBHUpdInfoLabel,         mkIndStaticInfoLabel,@@ -65,6 +63,7 @@         mkSMAP_DIRTY_infoLabel,         mkBadAlignmentLabel,         mkOutOfBoundsAccessLabel,+        mkMemcpyRangeOverlapLabel,         mkArrWords_infoLabel,         mkSRTInfoLabel, @@ -72,6 +71,8 @@         mkCAFBlackHoleInfoTableLabel,         mkRtsPrimOpLabel,         mkRtsSlowFastTickyCtrLabel,+        mkRtsUnpackCStringLabel,+        mkRtsUnpackCStringUtf8Label,          mkSelectorInfoLabel,         mkSelectorEntryLabel,@@ -101,13 +102,14 @@         needsCDecl,         maybeLocalBlockLabel,         externallyVisibleCLabel,-        isMathFun,+        isLibcFun,         isCFunctionLabel,         isGcPtrLabel,         labelDynamic,         isLocalCLabel,         mayRedirectTo,         isInfoTableLabel,+        isCmmInfoTableLabel,         isConInfoTableLabel,         isIdLabel,         isTickyLabel,@@ -123,17 +125,21 @@         toSlowEntryLbl,         toEntryLbl,         toInfoLbl,+        toProcDelimiterLbl,          -- * Pretty-printing         LabelStyle (..),         pprDebugCLabel,         pprCLabel,+        pprAsmLabel,         ppInternalProcLabel,          -- * Others         dynamicLinkerLabelInfo,-        addLabelSize,-        foreignLabelStdcallInfo+        CStubLabel (..),+        cStubLabel,+        fromCStubLabel,+        mapInternalNonDetUniques     ) where  import GHC.Prelude@@ -148,14 +154,14 @@ import GHC.Types.CostCentre import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Utils.Panic.Plain import GHC.Data.FastString import GHC.Platform import GHC.Types.Unique.Set-import GHC.Utils.Misc import GHC.Core.Ppr ( {- instances -} ) import GHC.Types.SrcLoc +import qualified Data.Semigroup as S+ -- ----------------------------------------------------------------------------- -- The CLabel type @@ -234,10 +240,6 @@   | 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@@ -294,21 +296,22 @@ instance Show CLabel where   show = showPprUnsafe . pprDebugCLabel genericPlatform -instance Outputable CLabel where-  ppr = text . show- data ModuleLabelKind-    = MLK_Initializer String+    = MLK_Initializer LexicalFastString     | MLK_InitializerArray-    | MLK_Finalizer String+    | MLK_Finalizer LexicalFastString     | MLK_FinalizerArray+    | MLK_IPEBuffer     deriving (Eq, Ord) -instance Outputable ModuleLabelKind where-    ppr MLK_InitializerArray = text "init_arr"-    ppr (MLK_Initializer s)  = text ("init__" ++ s)-    ppr MLK_FinalizerArray   = text "fini_arr"-    ppr (MLK_Finalizer s)    = text ("fini__" ++ s)+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@@ -339,32 +342,43 @@    deriving (Ord,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]+-- 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) =-    compare a1 a2 `thenCmp`-    compare b1 b2 `thenCmp`+    -- 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 `thenCmp`-    compare b1 b2 `thenCmp`-    -- This non-determinism is "safe" in the sense that it only affects object code,-    -- which is currently not covered by GHC's determinism guarantees. See #12935.-    uniqCompareFS c1 c2 `thenCmp`+    compare 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 d1) (ForeignLabel a2 b2 c2 d2) =-    uniqCompareFS a1 a2 `thenCmp`-    compare b1 b2 `thenCmp`-    compare c1 c2 `thenCmp`-    compare d1 d2+  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 `thenCmp`+    compare a1 a2 S.<>     lexicalCompareFS b1 b2   compare (StringLitLabel u1) (StringLitLabel u2) =     nonDetCmpUnique u1 u2@@ -375,10 +389,10 @@   compare (IPE_Label a1) (IPE_Label a2) =     compare a1 a2   compare (ModuleLabel m1 k1) (ModuleLabel m2 k2) =-    compare m1 m2 `thenCmp`+    compare m1 m2 S.<>     compare k1 k2   compare (DynamicLinkerLabel a1 b1) (DynamicLinkerLabel a2 b2) =-    compare a1 a2 `thenCmp`+    compare a1 a2 S.<>     compare b1 b2   compare PicBaseLabel PicBaseLabel = EQ   compare (DeadStripPreventer a1) (DeadStripPreventer a2) =@@ -451,7 +465,7 @@ --      The regular Outputable instance only shows the label name, and not its other info. -- pprDebugCLabel :: Platform -> CLabel -> SDoc-pprDebugCLabel platform lbl = pprCLabel platform AsmStyle lbl <> parens extra+pprDebugCLabel platform lbl = pprAsmLabel platform lbl <> parens extra    where       extra = case lbl of          IdLabel _ _ info@@ -463,8 +477,8 @@          RtsLabel{}             -> text "RtsLabel" -         ForeignLabel _name mSuffix src funOrData-             -> text "ForeignLabel" <+> ppr mSuffix <+> ppr src <+> ppr funOrData+         ForeignLabel _name src funOrData+             -> text "ForeignLabel" <+> ppr src <+> ppr funOrData           _  -> text "other CLabel" @@ -560,6 +574,8 @@   | 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@@ -614,7 +630,7 @@ mkConInfoTableLabel         :: Name -> ConInfoTableLocation -> CLabel mkBytesLabel                :: Name -> CLabel mkClosureLabel name         c     = IdLabel name c Closure--- | Decicdes between external and local labels based on the names externality.+-- | 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@@ -632,7 +648,7 @@ -- Constructing Cmm Labels mkDirty_MUT_VAR_Label,     mkNonmovingWriteBarrierEnabledLabel,-    mkUpdInfoLabel,+    mkOrigThunkInfoLabel, mkUpdInfoLabel,     mkBHUpdInfoLabel, mkIndStaticInfoLabel, mkMainCapabilityLabel,     mkMAP_FROZEN_CLEAN_infoLabel, mkMAP_FROZEN_DIRTY_infoLabel,     mkMAP_DIRTY_infoLabel,@@ -641,10 +657,12 @@     mkCAFBlackHoleInfoTableLabel,     mkSMAP_FROZEN_CLEAN_infoLabel, mkSMAP_FROZEN_DIRTY_infoLabel,     mkSMAP_DIRTY_infoLabel, mkBadAlignmentLabel,-    mkOutOfBoundsAccessLabel, mkMUT_VAR_CLEAN_infoLabel :: CLabel-mkDirty_MUT_VAR_Label           = mkForeignLabel (fsLit "dirty_MUT_VAR") Nothing ForeignLabelInExternalPackage IsFunction+    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@@ -659,7 +677,8 @@ 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") Nothing ForeignLabelInExternalPackage IsFunction+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@@ -732,7 +751,6 @@    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)@@ -744,21 +762,12 @@ -- | Make a foreign label mkForeignLabel         :: FastString           -- name-        -> Maybe Int            -- size prefix         -> ForeignLabelSource   -- what package it's in         -> FunctionOrData         -> CLabel  mkForeignLabel = ForeignLabel ---- | 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@@ -766,7 +775,7 @@  -- | Whether label is a non-haskell label (defined in C code) isForeignLabel :: CLabel -> Bool-isForeignLabel (ForeignLabel _ _ _ _) = True+isForeignLabel (ForeignLabel _ _ _) = True isForeignLabel _lbl = False  -- | Whether label is a static closure label (can come from haskell or cmm)@@ -787,6 +796,7 @@ 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@@ -795,19 +805,19 @@ 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 --- | Get the label size field from a ForeignLabel-foreignLabelStdcallInfo :: CLabel -> Maybe Int-foreignLabelStdcallInfo (ForeignLabel _ info _ _) = info-foreignLabelStdcallInfo _lbl = Nothing-- -- Constructing Large*Labels mkBitmapLabel   :: Unique -> CLabel mkBitmapLabel   uniq            = LargeBitmapLabel uniq@@ -823,17 +833,20 @@                                -- The rendered Haskell type of the closure the table represents                                , infoProvModule :: !Module                                -- Origin module-                               , infoTableProv :: !(Maybe (RealSrcSpan, String)) }+                               , 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 :: InfoProvEnt -> CLabel+mkIPELabel :: Module          -> CLabel mkCCLabel           cc          = CC_Label cc mkCCSLabel          ccs         = CCS_Label ccs-mkIPELabel          ipe         = IPE_Label ipe+mkIPELabel          mod         = ModuleLabel mod MLK_IPEBuffer  mkRtsApFastLabel :: FastString -> CLabel mkRtsApFastLabel str = RtsLabel (RtsApFast (NonDetFastString str))@@ -841,6 +854,11 @@ 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@@ -866,15 +884,15 @@ mkStringLitLabel :: Unique -> CLabel mkStringLitLabel                = StringLitLabel -mkInitializerStubLabel :: Module -> String -> CLabel-mkInitializerStubLabel mod s    = ModuleLabel mod (MLK_Initializer s)+mkInitializerStubLabel :: Module -> FastString -> CLabel+mkInitializerStubLabel mod s    = ModuleLabel mod (MLK_Initializer (LexicalFastString s))  mkInitializerArrayLabel :: Module -> CLabel mkInitializerArrayLabel mod     = ModuleLabel mod MLK_InitializerArray  -mkFinalizerStubLabel :: Module -> String -> CLabel-mkFinalizerStubLabel mod s      = ModuleLabel mod (MLK_Finalizer s)+mkFinalizerStubLabel :: Module -> FastString -> CLabel+mkFinalizerStubLabel mod s      = ModuleLabel mod (MLK_Finalizer (LexicalFastString s))  mkFinalizerArrayLabel :: Module -> CLabel mkFinalizerArrayLabel mod       = ModuleLabel mod MLK_FinalizerArray@@ -924,6 +942,16 @@    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@@ -947,6 +975,9 @@ 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]@@ -997,7 +1028,7 @@         -- For other labels we inline one into the HC file directly.         | otherwise                     = True -needsCDecl l@(ForeignLabel{})           = not (isMathFun l)+needsCDecl l@(ForeignLabel{})           = not (isLibcFun l) needsCDecl (CC_Label _)                 = True needsCDecl (CCS_Label _)                = True needsCDecl (IPE_Label {})               = True@@ -1011,6 +1042,7 @@ -- 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@@ -1023,15 +1055,19 @@   -- | 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.-isMathFun :: CLabel -> Bool-isMathFun (ForeignLabel fs _ _ _)       = fs `elementOfUniqSet` math_funs-isMathFun _ = False+-- 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 -math_funs :: UniqSet FastString-math_funs = mkUniqSet [+libc_funs :: UniqSet FastString+libc_funs = mkUniqSet [+        ---------------------+        -- Math functions+        ---------------------+         -- _ISOC99_SOURCE         (fsLit "acos"),         (fsLit "acosf"),        (fsLit "acosh"),         (fsLit "acoshf"),       (fsLit "acoshl"),       (fsLit "acosl"),@@ -1181,13 +1217,19 @@ 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 _)                          = DataLabel+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 (ForeignLabel _ _ IsFunction)         = CodeLabel+labelType (ForeignLabel _ _ IsData)             = DataLabel labelType (AsmTempLabel _)                      = panic "labelType(AsmTempLabel)" labelType (AsmTempDerivedLabel _ _)             = panic "labelType(AsmTempDerivedLabel)" labelType (StringLitLabel _)                    = DataLabel@@ -1208,6 +1250,7 @@     MLK_InitializerArray -> DataLabel     MLK_Finalizer _      -> CodeLabel     MLK_FinalizerArray   -> DataLabel+    MLK_IPEBuffer        -> DataLabel  idInfoLabelType :: IdLabelInfo -> CLabelType idInfoLabelType info =@@ -1265,7 +1308,7 @@     LocalBlockLabel _    -> False -   ForeignLabel _ _ source _  ->+   ForeignLabel _ source _  ->        if os == OSMinGW32        then case source of             -- Foreign label is in some un-named foreign package (or DLL).@@ -1352,6 +1395,7 @@                    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@@ -1389,49 +1433,78 @@  -} +-- | 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 ->-                        let !sty = case pp_sty of-                                    PprCode sty -> sty-                                    _           -> CStyle-                        in pprCLabel platform sty lbl+                        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 -pprCLabel :: Platform -> LabelStyle -> CLabel -> SDoc-pprCLabel !platform !sty lbl = -- see Note [Bangs in CLabel]+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 :: SDoc -> SDoc+    maybe_underscore :: doc -> doc     maybe_underscore doc = case sty of       AsmStyle | use_leading_underscores -> pp_cSEP <> doc       _                                  -> doc -    tempLabelPrefixOrUnderscore :: Platform -> SDoc-    tempLabelPrefixOrUnderscore platform = case sty of+    tempLabelPrefixOrUnderscore :: doc+    tempLabelPrefixOrUnderscore = case sty of       AsmStyle -> asmTempLabelPrefix platform       CStyle   -> char '_'     in case lbl of    LocalBlockLabel u -> case sty of-      AsmStyle -> tempLabelPrefixOrUnderscore platform <> pprUniqueAlways u-      CStyle   -> tempLabelPrefixOrUnderscore platform <> text "blk_" <> pprUniqueAlways u+      AsmStyle -> tempLabelPrefixOrUnderscore <> pprUniqueAlways u+      CStyle   -> tempLabelPrefixOrUnderscore <> text "blk_" <> pprUniqueAlways u     AsmTempLabel u-      -> tempLabelPrefixOrUnderscore platform <> pprUniqueAlways u+      -> tempLabelPrefixOrUnderscore <> pprUniqueAlways u     AsmTempDerivedLabel l suf-      -> asmTempLabelPrefix platform-         <> case l of AsmTempLabel u    -> pprUniqueAlways u-                      LocalBlockLabel u -> pprUniqueAlways u-                      _other            -> pprCLabel platform sty l+         -- 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 (pprCLabel platform AsmStyle lbl)+      -> pprDynamicLinkerAsmLabel platform info (pprAsmLabel platform lbl)     PicBaseLabel       -> text "1b"@@ -1444,86 +1517,83 @@          optional `_` (underscore) because this is how you mark non-temp symbols          on some platforms (Darwin)       -}-      maybe_underscore $ text "dsp_" <> pprCLabel platform sty lbl <> text "_dsp"+      maybe_underscore $ text "dsp_" <> pprCLabelStyle platform sty lbl <> text "_dsp"     StringLitLabel u       -> maybe_underscore $ pprUniqueAlways u <> text "_str" -   ForeignLabel fs (Just sz) _ _-      | AsmStyle <- sty-      , OSMinGW32 <- platformOS platform-      -> -- In asm mode, we need to put the suffix on a stdcall ForeignLabel.-         -- (The C compiler does this itself).-         maybe_underscore $ ftext fs <> char '@' <> int sz--   ForeignLabel fs _ _ _+   ForeignLabel fs _ _       -> maybe_underscore $ ftext fs -    IdLabel name _cafs flavor -> case sty of-      AsmStyle -> maybe_underscore $ internalNamePrefix <> ppr name <> ppIdFlavor flavor+      AsmStyle -> maybe_underscore $ internalNamePrefix <> pprName name <> ppIdFlavor flavor                    where                       isRandomGenerated = not (isExternalName name)                       internalNamePrefix =                          if isRandomGenerated                             then asmTempLabelPrefix platform                             else empty-      CStyle   -> ppr name <> ppIdFlavor flavor+      CStyle   -> pprName name <> ppIdFlavor flavor     SRTLabel u-      -> maybe_underscore $ tempLabelPrefixOrUnderscore platform <> pprUniqueAlways u <> pp_cSEP <> text "srt"+      -> 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_", text (show 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_", text (show 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_", text (show 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_", text (show 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_" <> ppr 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 platform+      -> 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_"  <> ppr mod <> text "_hpc"+      -> maybe_underscore $ text "_hpc_tickboxes_"  <> pprModule mod <> text "_hpc" -   CC_Label cc   -> maybe_underscore $ ppr cc-   CCS_Label ccs -> maybe_underscore $ ppr ccs-   IPE_Label (InfoProvEnt l _ _ m _) -> maybe_underscore $ (pprCode CStyle (pdoc platform l) <> text "_" <> ppr m <> text "_ipe")-   ModuleLabel mod kind        -> maybe_underscore $ ppr mod <> text "_" <> ppr kind+   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@@ -1533,6 +1603,8 @@    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] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1553,21 +1625,24 @@ -- | Generate a label for a procedure internal to a module (if -- 'Opt_ExposeAllSymbols' is enabled). -- See Note [Internal proc labels].-ppInternalProcLabel :: Module     -- ^ the current module+ppInternalProcLabel :: IsLine doc+                    => Module     -- ^ the current module                     -> CLabel-                    -> Maybe SDoc -- ^ the internal proc label+                    -> Maybe doc -- ^ the internal proc label ppInternalProcLabel this_mod (IdLabel nm _ flavour)   | isInternalName nm   = Just-     $ text "_" <> ppr this_mod+     $ 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 :: IdLabelInfo -> SDoc+ppIdFlavor :: IsLine doc => IdLabelInfo -> doc ppIdFlavor x = pp_cSEP <> case x of    Closure          -> text "closure"    InfoTable        -> text "info"@@ -1578,22 +1653,22 @@    IdTickyInfo TickyRednCounts       -> text "ct"    IdTickyInfo (TickyInferedTag unique)-      -> text "ct_inf_tag" <> char '_' <> ppr unique+      -> text "ct_inf_tag" <> char '_' <> pprUniqueAlways unique    ConEntry loc      ->       case loc of         DefinitionSite -> text "con_entry"         UsageSite m n ->-          ppr m <> pp_cSEP <> ppr n <> pp_cSEP <> text "con_entry"+          pprModule m <> pp_cSEP <> int n <> pp_cSEP <> text "con_entry"    ConInfoTable k   ->     case k of       DefinitionSite -> text "con_info"       UsageSite m n ->-        ppr m <> pp_cSEP <> ppr n <> pp_cSEP <> text "con_info"+        pprModule m <> pp_cSEP <> int n <> pp_cSEP <> text "con_info"    ClosureTable     -> text "closure_tbl"    Bytes            -> text "bytes"    BlockInfoTable   -> text "info" -pp_cSEP :: SDoc+pp_cSEP :: IsLine doc => doc pp_cSEP = char '_'  @@ -1607,13 +1682,13 @@ -- ----------------------------------------------------------------------------- -- Machine-dependent knowledge about labels. -asmTempLabelPrefix :: Platform -> SDoc  -- for formatting 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 :: Platform -> DynamicLinkerLabelInfo -> SDoc -> SDoc+pprDynamicLinkerAsmLabel :: IsLine doc => Platform -> DynamicLinkerLabelInfo -> doc -> doc pprDynamicLinkerAsmLabel !platform dllInfo ppLbl =     case platformOS platform of       OSDarwin@@ -1624,11 +1699,7 @@             GotSymbolPtr    -> ppLbl <> text "@GOTPCREL"             GotSymbolOffset -> ppLbl         | platformArch platform == ArchAArch64 -> ppLbl-        | otherwise ->-          case dllInfo of-            CodeStub  -> char 'L' <> ppLbl <> text "$stub"-            SymbolPtr -> char 'L' <> ppLbl <> text "$non_lazy_ptr"-            _         -> panic "pprDynamicLinkerAsmLabel"+        | otherwise -> panic "pprDynamicLinkerAsmLabel"        OSAIX ->           case dllInfo of@@ -1655,7 +1726,12 @@       | platformArch platform == ArchAArch64       = ppLbl +      | platformArch platform == ArchRISCV64+      = ppLbl +      | platformArch platform == ArchLoongArch64+      = ppLbl+       | platformArch platform == ArchX86_64       = case dllInfo of           CodeStub        -> ppLbl <> text "@plt"@@ -1813,3 +1889,74 @@      T15155.a_closure `mayRedirectTo` a1_rXq_closure+1 returns True. -}++-- | This type encodes the subset of 'CLabel' that occurs in C stubs of foreign+-- declarations for the purpose of serializing to interface files.+--+-- See Note [Foreign stubs and TH bytecode linking]+data CStubLabel =+  CStubLabel {+    csl_is_initializer :: Bool,+    csl_module :: Module,+    csl_name :: FastString+  }++instance Outputable CStubLabel where+  ppr CStubLabel {csl_is_initializer, csl_module, csl_name} =+    text ini <+> ppr csl_module <> colon <> text (unpackFS csl_name)+    where+      ini = if csl_is_initializer then "initializer" else "finalizer"++-- | Project the constructor 'ModuleLabel' out of 'CLabel' if it is an+-- initializer or finalizer.+cStubLabel :: CLabel -> Maybe CStubLabel+cStubLabel = \case+  ModuleLabel csl_module label_kind -> do+    (csl_is_initializer, csl_name) <- case label_kind of+      MLK_Initializer (LexicalFastString s) -> Just (True, s)+      MLK_Finalizer (LexicalFastString s) -> Just (False, s)+      _ -> Nothing+    Just (CStubLabel {csl_is_initializer, csl_module, csl_name})+  _ -> Nothing++-- | Inject a 'CStubLabel' into a 'CLabel' as a 'ModuleLabel'.+fromCStubLabel :: CStubLabel -> CLabel+fromCStubLabel (CStubLabel {csl_is_initializer, csl_module, csl_name}) =+  ModuleLabel csl_module (label_kind (LexicalFastString csl_name))+  where+    label_kind =+      if csl_is_initializer+      then MLK_Initializer+      else MLK_Finalizer++-- | A utility for renaming uniques in CLabels to produce deterministic object.+-- Note that not all Uniques are mapped over. Only those that can be safely alpha+-- renamed, e.g. uniques of local symbols, but not of external ones.+-- See Note [Renaming uniques deterministically].+mapInternalNonDetUniques :: Applicative m => (Unique -> m Unique) -> CLabel -> m CLabel+-- todo: Can we do less work here, e.g., do we really need to rename AsmTempLabel, LocalBlockLabel?+mapInternalNonDetUniques f x = case x of+  IdLabel name cafInfo idLabelInfo+    | not (isExternalName name) -> IdLabel . setNameUnique name <$> f (nameUnique name) <*> pure cafInfo <*> pure idLabelInfo+    | otherwise -> pure x+  cl@CmmLabel{} -> pure cl+  RtsLabel rtsLblInfo -> pure $ RtsLabel rtsLblInfo+  LocalBlockLabel unique -> LocalBlockLabel <$> f unique+  fl@ForeignLabel{} -> pure fl+  AsmTempLabel unique -> AsmTempLabel <$> f unique+  AsmTempDerivedLabel clbl fs -> AsmTempDerivedLabel <$> mapInternalNonDetUniques f clbl <*> pure fs+  StringLitLabel unique -> StringLitLabel <$> f unique+  CC_Label  cc -> pure $ CC_Label cc+  CCS_Label ccs -> pure $ CCS_Label ccs+  IPE_Label ipe@InfoProvEnt{infoTablePtr} ->+    (\cl' -> IPE_Label ipe{infoTablePtr = cl'}) <$> mapInternalNonDetUniques f infoTablePtr+  ml@ModuleLabel{} -> pure ml+  DynamicLinkerLabel dlli clbl -> DynamicLinkerLabel dlli <$> mapInternalNonDetUniques f clbl+  PicBaseLabel -> pure PicBaseLabel+  DeadStripPreventer clbl -> DeadStripPreventer <$> mapInternalNonDetUniques f clbl+  HpcTicksLabel mod -> pure $ HpcTicksLabel mod+  SRTLabel unique -> SRTLabel <$> f unique+  LargeBitmapLabel unique -> LargeBitmapLabel <$> f unique+-- This is called *a lot* if renaming Cmm uniques, and won't specialise without this pragma:+{-# INLINABLE mapInternalNonDetUniques #-}+
GHC/Cmm/CLabel.hs-boot view
@@ -5,5 +5,4 @@  data CLabel -pprCLabel :: Platform -> LabelStyle -> CLabel -> SDoc-+pprCLabel :: IsLine doc => Platform -> CLabel -> doc
GHC/Cmm/CallConv.hs view
@@ -3,22 +3,25 @@   assignArgumentsPos,   assignStack,   realArgRegsCover,-  tupleRegsCover+  allArgRegsCover ) where  import GHC.Prelude-import Data.List (nub)  import GHC.Cmm.Expr+import GHC.Cmm.Reg (GlobalArgRegs(..)) import GHC.Runtime.Heap.Layout import GHC.Cmm (Convention(..))-import GHC.Cmm.Ppr () -- For Outputable instances  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. @@ -68,43 +71,48 @@       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 profile -> k (RegisterParam (XmmReg s), (vs, fs, ds, ls, ss))-                      (W256, (vs, fs, ds, ls, s:ss))-                          | passVectorInReg W256 profile -> k (RegisterParam (YmmReg s), (vs, fs, ds, ls, ss))-                      (W512, (vs, fs, ds, ls, s:ss))-                          | passVectorInReg W512 profile -> k (RegisterParam (ZmmReg s), (vs, fs, ds, ls, ss))-                      _ -> (assts, (r:rs))+        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, (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))+                        (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"-                      (_, (v:vs, fs, ds, ls, ss)) | widthInBits w <= widthInBits (wordWidth platform)-                          -> k (RegisterParam (v gcp), (vs, fs, ds, ls, ss))-                      (_, (vs, fs, ds, l:ls, ss)) | widthInBits w > widthInBits (wordWidth platform)-                          -> k (RegisterParam l, (vs, fs, ds, ls, ss))+                      (_, 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-              !gcp | isGcPtrType ty = VGcPtr-                   | otherwise      = VNonGcPtr               passFloatInXmm = passFloatArgsInXmm platform  passFloatArgsInXmm :: Platform -> Bool-passFloatArgsInXmm platform = case platformArch platform of-                              ArchX86_64 -> True-                              ArchX86    -> False-                              _          -> False+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@@ -132,13 +140,24 @@ ----------------------------------------------------------------------------- -- 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)-                 )+-- | 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. --@@ -147,24 +166,26 @@  getRegsWithoutNode, getRegsWithNode :: Platform -> AvailRegs getRegsWithoutNode platform =-  ( filter (\r -> r VGcPtr /= node) (realVanillaRegs platform)-  , realFloatRegs platform-  , realDoubleRegs platform-  , realLongRegs platform-  , realXmmRegNos 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 =-  ( if null (realVanillaRegs platform)-    then [VanillaReg 1]-    else realVanillaRegs platform-  , realFloatRegs platform-  , realDoubleRegs platform-  , realLongRegs platform-  , realXmmRegNos 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 -> [VGcPtr -> GlobalReg]+allVanillaRegs :: Platform -> [GlobalReg] allXmmRegs :: Platform -> [Int]  allVanillaRegs platform = map VanillaReg $ regList (pc_MAX_Vanilla_REG (platformConstants platform))@@ -174,7 +195,7 @@ allXmmRegs     platform =                  regList (pc_MAX_XMM_REG     (platformConstants platform))  realFloatRegs, realDoubleRegs, realLongRegs :: Platform -> [GlobalReg]-realVanillaRegs :: Platform -> [VGcPtr -> 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))@@ -183,50 +204,121 @@  realXmmRegNos :: Platform -> [Int] realXmmRegNos platform-    | isSse2Enabled platform = regList (pc_MAX_Real_XMM_REG (platformConstants platform))-    | otherwise              = []+    | 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 = ( allVanillaRegs platform-                   , allFloatRegs   platform-                   , allDoubleRegs  platform-                   , allLongRegs    platform-                   , allXmmRegs     platform-                   )+allRegs platform =+  AvailRegs+   { availVanillaRegs = allVanillaRegs platform+   , availFloatRegs   = allFloatRegs   platform+   , availDoubleRegs  = allDoubleRegs  platform+   , availLongRegs    = allLongRegs    platform+   , availXMMRegs     = allXmmRegs     platform }  nodeOnly :: AvailRegs-nodeOnly = ([VanillaReg 1], [], [], [], [])+nodeOnly = noAvailRegs { availVanillaRegs = [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 :: Platform -> [GlobalReg]-realArgRegsCover platform-    | passFloatArgsInXmm platform-    = map ($ VGcPtr) (realVanillaRegs platform) ++-      realLongRegs platform ++-      realDoubleRegs platform -- we only need to save the low Double part of XMM registers.-                              -- Moreover, the NCG can't load/store full XMM-                              -- registers for now...+-- | 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 ] -    | otherwise-    = map ($ VGcPtr) (realVanillaRegs platform) ++-      realFloatRegs  platform ++-      realDoubleRegs platform ++-      realLongRegs   platform-      -- we don't save XMM registers if they are not used for parameter passing+  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. This covers the real--- and virtual registers used for unboxed tuples.+-- | Like "realArgRegsCover", but always includes the node. ----- Note: if anything changes in how registers for unboxed tuples overlap,---       make sure to also update GHC.StgToByteCode.layoutTuple.+-- 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 -tupleRegsCover :: Platform -> [GlobalReg]-tupleRegsCover platform =-  nub (VanillaReg 1 VGcPtr : realArgRegsCover platform)+{- Note [realArgRegsCover]+~~~~~~~~~~~~~~~~~~~~~~~~~~+In low-level Cmm, jumps must be annotated with a set of live registers,+allowing precise control of global STG register contents across function calls.+However, in some places (in particular in the RTS), the registers we want to+preserve depend on the *caller*. For example, if we intercept a function call+via a stack underflow frame, we want to preserve exactly those registers+containing function arguments.+Since we can't know exactly how many arguments the caller passed, we settle on+simply preserving all global regs which might be used for argument passing.+To do this, we specify a collection of registers that *covers* all the registers+we want to preserve; this is done by "realArgRegsCover".++The situation is made somewhat tricky by the need to handle vector registers.+For example, on X86_64, the F, D, XMM, YMM, ZMM overlap in the following way+          ┌─┬─┬───┬───────┬───────────────┐+          │F┆D┆XMM┆  YMM  ┆     ZMM       │+          └─┴─┴───┴───────┴───────────────┘+where each register extends all the way to the left.++Based on this register architecture, on X86_64 we might want to annotate a jump+in which we (might) want to preserve the contents of all argument-passing+registers with [R1, ..., R6, ZMM1, ..., ZMM6]. This, however, is not possible+in general, because preserving e.g. a ZMM register across a C call requires the+availability of the AVX-512F instruction set. If we did this, the RTS would+crash at runtime with an "invalid instruction" error on X86_64 machines which+do not support AVX-512F.++Instead, we parametrise "realArgRegsCover" on the 'GlobalArgRegs' datatype, which+specifies which registers it is sufficient to preserve. For example, it might+suffice to only preserve general-purpose registers, or to only preserve up to+XMM (not YMM or ZMM).++Then, to handle certain functions in the RTS such as "stack_underflow_frame", we+proceed by defining 4 variants, stack_underflow_frame_{d,v16,v32,v64}, which+respectively annotate the jump at the end of the function with SCALAR_ARG_REGS,+V16_ARG_REGS, V32_ARG_REGS and V64_ARG_REGS. Compiling these variants, in effect,+amounts to compiling "stack_underflow_frame" four times, once for each level of+vector support. Then, in the RTS, we dispatch at runtime based on the support+for vectors provided by the architecture on the current machine (see e.g.+'threadStackOverflow' and its 'switch (vectorSupportGlobalVar)'.)++Note that, like in Note [AutoApply.cmm for vectors], it is **critical** that we+compile e.g. stack_underflow_frame_v64 with -mavx512f. If we don't, the LLVM+backend is liable to compile code using e.g. the ZMM1 STG register to uses of+X86 machine registers xmm1, xmm2, xmm3, xmm4, instead of just zmm1. This would+mean that LLVM produces ABI-incompatible code that would result in segfaults in+the RTS.+-}
GHC/Cmm/CommonBlockElim.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE GADTs, BangPatterns, ScopedTypeVariables #-}+{-# LANGUAGE GADTs #-}  module GHC.Cmm.CommonBlockElim   ( elimCommonBlocks@@ -17,17 +17,18 @@ import GHC.Cmm.Dataflow.Block import GHC.Cmm.Dataflow.Graph import GHC.Cmm.Dataflow.Label-import GHC.Cmm.Dataflow.Collections+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 GHC.Utils.Outputable-import GHC.Utils.Panic 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@@ -81,7 +82,7 @@     | mapNull new_substs = subst     | otherwise = iterate subst' updated_blocks   where-    grouped_blocks :: [[(Key, [DistinctBlocks])]]+    grouped_blocks :: [[(Key, NonEmpty DistinctBlocks)]]     grouped_blocks = map groupByLabel blocks      merged_blocks :: [[(Key, DistinctBlocks)]]@@ -106,9 +107,8 @@         -- 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+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@@ -182,8 +182,10 @@          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 = cvt . getKey . getUnique+        hash_unique = truncateWord64ToWord32 . getKey . getUnique  -- | Ignore these node types for equality dont_care :: CmmNode O x -> Bool@@ -214,7 +216,7 @@   = eqExprWith eqBid l1 l2 && eqExprWith eqBid r1 r2 eqMiddleWith eqBid (CmmUnsafeForeignCall t1 r1 a1)                    (CmmUnsafeForeignCall t2 r2 a2)-  = t1 == t2 && r1 == r2 && eqListWith (eqExprWith eqBid) a1 a2+  = t1 == t2 && r1 == r2 && liftEq (eqExprWith eqBid) a1 a2 eqMiddleWith _ _ _ = False  eqExprWith :: (BlockId -> BlockId -> Bool)@@ -225,12 +227,10 @@   CmmLoad e1 t1 a1   `eq` CmmLoad e2 t2 a2   = t1 `cmmEqType` t2 && e1 `eq` e2 && a1==a2   CmmReg r1          `eq` CmmReg r2          = r1==r2   CmmRegOff r1 i1    `eq` CmmRegOff r2 i2    = r1==r2 && i1==i2-  CmmMachOp op1 es1  `eq` CmmMachOp op2 es2  = op1==op2 && es1 `eqs` es2+  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 -  xs `eqs` ys = eqListWith eq xs ys-   eqLit (CmmBlock id1) (CmmBlock id2) = eqBid id1 id2   eqLit l1 l2 = l1 == l2 @@ -252,7 +252,7 @@         (_,m',l') = blockSplit block'         nodes'    = filter (not . dont_care) (blockToList m') -        equal = eqListWith (eqMiddleWith eqBid) nodes nodes' &&+        equal = liftEq (eqMiddleWith eqBid) nodes nodes' &&                 eqLastWith eqBid l l'  @@ -261,21 +261,11 @@ 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+  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 -eqMaybeWith :: (a -> b -> Bool) -> Maybe a -> Maybe b -> Bool-eqMaybeWith eltEq (Just e) (Just e') = eltEq e e'-eqMaybeWith _ Nothing Nothing = True-eqMaybeWith _ _ _ = False--eqListWith :: (a -> b -> Bool) -> [a] -> [b] -> Bool-eqListWith f (a : as) (b : bs) = f a b && eqListWith f as bs-eqListWith _ []       []       = True-eqListWith _ _        _        = 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@@ -301,15 +291,15 @@  -- Group by [Label] -- See Note [Compressed TrieMap] in GHC.Core.Map.Expr about the usage of GenMap.-groupByLabel :: [(Key, DistinctBlocks)] -> [(Key, [DistinctBlocks])]+groupByLabel :: [(Key, DistinctBlocks)] -> [(Key, NonEmpty DistinctBlocks)] groupByLabel =-  go (TM.emptyTM :: TM.ListMap (TM.GenMap LabelMap) (Key, [DistinctBlocks]))+  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,[v])-              adjust (Just (_,vs)) = Just (k,v:vs)+              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
GHC/Cmm/Config.hs view
@@ -19,6 +19,7 @@   , 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
GHC/Cmm/ContFlowOpt.hs view
@@ -1,7 +1,4 @@ {-# LANGUAGE GADTs #-}-{-# LANGUAGE BangPatterns #-}-{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}-{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} module GHC.Cmm.ContFlowOpt     ( cmmCfgOpts     , cmmCfgOptsProc@@ -12,8 +9,7 @@  import GHC.Prelude hiding (succ, unzip, zip) -import GHC.Cmm.Dataflow.Block-import GHC.Cmm.Dataflow.Collections+import GHC.Cmm.Dataflow.Block hiding (blockConcat) import GHC.Cmm.Dataflow.Graph import GHC.Cmm.Dataflow.Label import GHC.Cmm.BlockId@@ -21,8 +17,10 @@ import GHC.Cmm.Utils import GHC.Cmm.Switch (mapSwitchTargets, switchTargetsToList) import GHC.Data.Maybe-import GHC.Utils.Panic+import GHC.Platform import GHC.Utils.Misc+import GHC.Utils.Outputable+import GHC.Utils.Panic  import Control.Monad @@ -334,7 +332,7 @@   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 thats not taken. However I haven't tested this and as of early+  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. -} @@ -422,9 +420,9 @@     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)+-- 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@@ -446,3 +444,5 @@       used_lbls :: LabelSet      used_lbls = setFromList $ map entryLabel used_blocks+removeUnreachableBlocksProc platform data'@(CmmData _ _) =+    pprPanic "removeUnreachableBlocksProc: passed data declaration instead of procedure" (pdoc platform data')
GHC/Cmm/Dataflow.hs view
@@ -1,9 +1,5 @@-{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-}-{-# LANGUAGE MultiParamTypeClasses  #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-}  --@@ -14,7 +10,7 @@ -- -- 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.+-- specialised to the UniqDSM monad. --  module GHC.Cmm.Dataflow@@ -37,7 +33,7 @@ import GHC.Prelude  import GHC.Cmm-import GHC.Types.Unique.Supply+import GHC.Types.Unique.DSM  import Data.Array import Data.Maybe@@ -47,7 +43,6 @@  import GHC.Cmm.Dataflow.Block import GHC.Cmm.Dataflow.Graph-import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Label  type family   Fact (x :: Extensibility) f :: Type@@ -87,17 +82,17 @@     Block n C C -> FactBase f -> FactBase f  --- | Function for rewrtiting and analysis combined. To be used with+-- | Function for rewriting and analysis combined. To be used with -- @rewriteCmm@. ----- Currently set to work with @UniqSM@ monad, but we could probably abstract+-- 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 -> UniqSM (CmmBlock, FactBase f)+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 -> UniqSM (Block n C C, FactBase f)+    Block n C C -> FactBase f -> UniqDSM (Block n C C, FactBase f)  analyzeCmmBwd, analyzeCmmFwd     :: (NonLocal node)@@ -172,7 +167,7 @@     -> RewriteFun' node f     -> GenCmmGraph node     -> FactBase f-    -> UniqSM (GenCmmGraph node, FactBase f)+    -> UniqDSM (GenCmmGraph node, FactBase f) rewriteCmmBwd = rewriteCmm Bwd  rewriteCmm@@ -182,7 +177,7 @@     -> RewriteFun' node f     -> GenCmmGraph node     -> FactBase f-    -> UniqSM (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@@ -202,7 +197,7 @@     -> Label     -> LabelMap (Block node C C)     -> FactBase f-    -> UniqSM (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@@ -221,7 +216,7 @@         :: IntHeap                    -- Worklist, i.e., blocks to process         -> LabelMap (Block node C C)  -- Rewritten blocks.         -> FactBase f                 -- Current facts.-        -> UniqSM (LabelMap (Block node C C), FactBase f)+        -> 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.@@ -427,10 +422,10 @@ -- Strict in both accumulated parts. foldRewriteNodesBwdOO     :: forall f node.-       (node O O -> f -> UniqSM (Block node O O, f))+       (node O O -> f -> UniqDSM (Block node O O, f))     -> Block node O O     -> f-    -> UniqSM (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
GHC/Cmm/Dataflow/Block.hs view
@@ -14,6 +14,7 @@     , IndexedCO     , Block(..)     , blockAppend+    , blockConcat     , blockCons     , blockFromList     , blockJoin@@ -136,6 +137,8 @@ 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
− GHC/Cmm/Dataflow/Collections.hs 
@@ -1,178 +0,0 @@-{-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE TypeFamilies #-}--module GHC.Cmm.Dataflow.Collections-    ( IsSet(..)-    , setInsertList, setDeleteList, setUnions-    , IsMap(..)-    , mapInsertList, mapDeleteList, mapUnions-    , UniqueMap, UniqueSet-    ) where--import GHC.Prelude--import qualified Data.IntMap.Strict as M-import qualified Data.IntSet as S--import Data.List (foldl1')--class IsSet set where-  type ElemOf set--  setNull :: set -> Bool-  setSize :: set -> Int-  setMember :: ElemOf set -> set -> Bool--  setEmpty :: set-  setSingleton :: ElemOf set -> set-  setInsert :: ElemOf set -> set -> set-  setDelete :: ElemOf set -> set -> set--  setUnion :: set -> set -> set-  setDifference :: set -> set -> set-  setIntersection :: set -> set -> set-  setIsSubsetOf :: set -> set -> Bool-  setFilter :: (ElemOf set -> Bool) -> set -> set--  setFoldl :: (b -> ElemOf set -> b) -> b -> set -> b-  setFoldr :: (ElemOf set -> b -> b) -> b -> set -> b--  setElems :: set -> [ElemOf set]-  setFromList :: [ElemOf set] -> set---- Helper functions for IsSet class-setInsertList :: IsSet set => [ElemOf set] -> set -> set-setInsertList keys set = foldl' (flip setInsert) set keys--setDeleteList :: IsSet set => [ElemOf set] -> set -> set-setDeleteList keys set = foldl' (flip setDelete) set keys--setUnions :: IsSet set => [set] -> set-setUnions [] = setEmpty-setUnions sets = foldl1' setUnion sets---class IsMap map where-  type KeyOf map--  mapNull :: map a -> Bool-  mapSize :: map a -> Int-  mapMember :: KeyOf map -> map a -> Bool-  mapLookup :: KeyOf map -> map a -> Maybe a-  mapFindWithDefault :: a -> KeyOf map -> map a -> a--  mapEmpty :: map a-  mapSingleton :: KeyOf map -> a -> map a-  mapInsert :: KeyOf map -> a -> map a -> map a-  mapInsertWith :: (a -> a -> a) -> KeyOf map -> a -> map a -> map a-  mapDelete :: KeyOf map -> map a -> map a-  mapAlter :: (Maybe a -> Maybe a) -> KeyOf map -> map a -> map a-  mapAdjust :: (a -> a) -> KeyOf map -> map a -> map a--  mapUnion :: map a -> map a -> map a-  mapUnionWithKey :: (KeyOf map -> a -> a -> a) -> map a -> map a -> map a-  mapDifference :: map a -> map a -> map a-  mapIntersection :: map a -> map a -> map a-  mapIsSubmapOf :: Eq a => map a -> map a -> Bool--  mapMap :: (a -> b) -> map a -> map b-  mapMapWithKey :: (KeyOf map -> a -> b) -> map a -> map b-  mapFoldl :: (b -> a -> b) -> b -> map a -> b-  mapFoldr :: (a -> b -> b) -> b -> map a -> b-  mapFoldlWithKey :: (b -> KeyOf map -> a -> b) -> b -> map a -> b-  mapFoldMapWithKey :: Monoid m => (KeyOf map -> a -> m) -> map a -> m-  mapFilter :: (a -> Bool) -> map a -> map a-  mapFilterWithKey :: (KeyOf map -> a -> Bool) -> map a -> map a---  mapElems :: map a -> [a]-  mapKeys :: map a -> [KeyOf map]-  mapToList :: map a -> [(KeyOf map, a)]-  mapFromList :: [(KeyOf map, a)] -> map a-  mapFromListWith :: (a -> a -> a) -> [(KeyOf map,a)] -> map a---- Helper functions for IsMap class-mapInsertList :: IsMap map => [(KeyOf map, a)] -> map a -> map a-mapInsertList assocs map = foldl' (flip (uncurry mapInsert)) map assocs--mapDeleteList :: IsMap map => [KeyOf map] -> map a -> map a-mapDeleteList keys map = foldl' (flip mapDelete) map keys--mapUnions :: IsMap map => [map a] -> map a-mapUnions [] = mapEmpty-mapUnions maps = foldl1' mapUnion maps---------------------------------------------------------------------------------- Basic instances--------------------------------------------------------------------------------newtype UniqueSet = US S.IntSet deriving (Eq, Ord, Show, Semigroup, Monoid)--instance IsSet UniqueSet where-  type ElemOf UniqueSet = Int--  setNull (US s) = S.null s-  setSize (US s) = S.size s-  setMember k (US s) = S.member k s--  setEmpty = US S.empty-  setSingleton k = US (S.singleton k)-  setInsert k (US s) = US (S.insert k s)-  setDelete k (US s) = US (S.delete k s)--  setUnion (US x) (US y) = US (S.union x y)-  setDifference (US x) (US y) = US (S.difference x y)-  setIntersection (US x) (US y) = US (S.intersection x y)-  setIsSubsetOf (US x) (US y) = S.isSubsetOf x y-  setFilter f (US s) = US (S.filter f s)--  setFoldl k z (US s) = S.foldl' k z s-  setFoldr k z (US s) = S.foldr k z s--  setElems (US s) = S.elems s-  setFromList ks = US (S.fromList ks)--newtype UniqueMap v = UM (M.IntMap v)-  deriving (Eq, Ord, Show, Functor, Foldable, Traversable)--instance IsMap UniqueMap where-  type KeyOf UniqueMap = Int--  mapNull (UM m) = M.null m-  mapSize (UM m) = M.size m-  mapMember k (UM m) = M.member k m-  mapLookup k (UM m) = M.lookup k m-  mapFindWithDefault def k (UM m) = M.findWithDefault def k m--  mapEmpty = UM M.empty-  mapSingleton k v = UM (M.singleton k v)-  mapInsert k v (UM m) = UM (M.insert k v m)-  mapInsertWith f k v (UM m) = UM (M.insertWith f k v m)-  mapDelete k (UM m) = UM (M.delete k m)-  mapAlter f k (UM m) = UM (M.alter f k m)-  mapAdjust f k (UM m) = UM (M.adjust f k m)--  mapUnion (UM x) (UM y) = UM (M.union x y)-  mapUnionWithKey f (UM x) (UM y) = UM (M.unionWithKey f x y)-  mapDifference (UM x) (UM y) = UM (M.difference x y)-  mapIntersection (UM x) (UM y) = UM (M.intersection x y)-  mapIsSubmapOf (UM x) (UM y) = M.isSubmapOf x y--  mapMap f (UM m) = UM (M.map f m)-  mapMapWithKey f (UM m) = UM (M.mapWithKey f m)-  mapFoldl k z (UM m) = M.foldl' k z m-  mapFoldr k z (UM m) = M.foldr k z m-  mapFoldlWithKey k z (UM m) = M.foldlWithKey' k z m-  mapFoldMapWithKey f (UM m) = M.foldMapWithKey f m-  {-# INLINEABLE mapFilter #-}-  mapFilter f (UM m) = UM (M.filter f m)-  {-# INLINEABLE mapFilterWithKey #-}-  mapFilterWithKey f (UM m) = UM (M.filterWithKey f m)--  mapElems (UM m) = M.elems m-  mapKeys (UM m) = M.keys m-  {-# INLINEABLE mapToList #-}-  mapToList (UM m) = M.toList m-  mapFromList assocs = UM (M.fromList assocs)-  mapFromListWith f assocs = UM (M.fromListWith f assocs)
GHC/Cmm/Dataflow/Graph.hs view
@@ -1,9 +1,5 @@-{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} module GHC.Cmm.Dataflow.Graph     ( Body@@ -12,6 +8,7 @@     , NonLocal(..)     , addBlock     , bodyList+    , bodyToBlockList     , emptyBody     , labelsDefined     , mapGraph@@ -25,15 +22,14 @@  import GHC.Cmm.Dataflow.Label import GHC.Cmm.Dataflow.Block-import GHC.Cmm.Dataflow.Collections  import Data.Kind  -- | A (possibly empty) collection of closed/closed blocks-type Body n = LabelMap (Block n C C)+type Body s n = Body' s Block n  -- | @Body@ abstracted over @block@-type Body' block (n :: Extensibility -> Extensibility -> Type) = LabelMap (block n C C)+type Body' s block (n :: Extensibility -> Extensibility -> Type) = s (block n C C)  ------------------------------- -- | Gives access to the anchor points for@@ -50,12 +46,15 @@   successors (BlockCC _ _ n) = successors n  -emptyBody :: Body' block n+emptyBody :: Body' LabelMap block n emptyBody = mapEmpty -bodyList :: Body' block n -> [(Label,block n C C)]+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)@@ -73,18 +72,18 @@ -- 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' Block+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' block (n :: Extensibility -> Extensibility -> Type) e x where-  GNil  :: Graph' block n O O-  GUnit :: block n O O -> Graph' block n O O+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' block n+        -> Body' s block n         -> MaybeO x (block n C O)-        -> Graph' block n e x+        -> Graph' s block n e x   -- -----------------------------------------------------------------------------@@ -92,31 +91,32 @@  -- | 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 (mapBlock f)+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 block n block' n' e x .-                  (forall e x . block n e x -> block' n' e x)-               -> (Graph' block n e x -> Graph' block' n' e x)+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 = map-  where map :: Graph' block n e x -> Graph' 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 (f b)-        map (GMany e b x) = GMany (fmap f e) (mapMap f b) (fmap f x)+        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' block n e x+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 -> ElemOf LabelSet -> a -> LabelSet+  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
GHC/Cmm/Dataflow/Label.hs view
@@ -1,8 +1,10 @@-{-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DeriveTraversable  #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleInstances  #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -Wno-unused-top-binds #-}  module GHC.Cmm.Dataflow.Label     ( Label@@ -11,34 +13,94 @@     , 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 --- TODO: This should really just use GHC's Unique and Uniq{Set,FM}-import GHC.Cmm.Dataflow.Collections+import GHC.Types.Unique (Uniquable(..), mkUniqueGrimily) -import GHC.Types.Unique (Uniquable(..))+-- 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 :: Int }-  deriving (Eq, Ord)+newtype Label = Label { lblToUnique :: Word64 }+  deriving newtype (Eq, Ord) -mkHooplLabel :: Int -> Label+mkHooplLabel :: Word64 -> Label mkHooplLabel = Label  instance Show Label where   show (Label n) = "L" ++ show n  instance Uniquable Label where-  getUnique label = getUnique (lblToUnique label)+  getUnique label = mkUniqueGrimily (lblToUnique label)  instance Outputable Label where   ppr label = ppr (getUnique label)@@ -49,79 +111,179 @@ ----------------------------------------------------------------------------- -- LabelSet -newtype LabelSet = LS UniqueSet deriving (Eq, Ord, Show, Monoid, Semigroup)+newtype LabelSet = LS Word64Set+  deriving newtype (Eq, Ord, Show, Monoid, Semigroup) -instance IsSet LabelSet where-  type ElemOf LabelSet = Label+setNull :: LabelSet -> Bool+setNull (LS s) = S.null s -  setNull (LS s) = setNull s-  setSize (LS s) = setSize s-  setMember (Label k) (LS s) = setMember k s+setSize :: LabelSet -> Int+setSize (LS s) = S.size s -  setEmpty = LS setEmpty-  setSingleton (Label k) = LS (setSingleton k)-  setInsert (Label k) (LS s) = LS (setInsert k s)-  setDelete (Label k) (LS s) = LS (setDelete k s)+setMember :: Label -> LabelSet -> Bool+setMember (Label k) (LS s) = S.member k s -  setUnion (LS x) (LS y) = LS (setUnion x y)-  setDifference (LS x) (LS y) = LS (setDifference x y)-  setIntersection (LS x) (LS y) = LS (setIntersection x y)-  setIsSubsetOf (LS x) (LS y) = setIsSubsetOf x y-  setFilter f (LS s) = LS (setFilter (f . mkHooplLabel) s)-  setFoldl k z (LS s) = setFoldl (\a v -> k a (mkHooplLabel v)) z s-  setFoldr k z (LS s) = setFoldr (\v a -> k (mkHooplLabel v) a) z s+setEmpty :: LabelSet+setEmpty = LS S.empty -  setElems (LS s) = map mkHooplLabel (setElems s)-  setFromList ks = LS (setFromList (map lblToUnique ks))+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 (UniqueMap v)-  deriving (Eq, Ord, Show, Functor, Foldable, Traversable)+newtype LabelMap v = LM (Word64Map v)+  deriving newtype (Eq, Ord, Show, Functor, Foldable)+  deriving stock   Traversable -instance IsMap LabelMap where-  type KeyOf LabelMap = Label+mapNull :: LabelMap a -> Bool+mapNull (LM m) = M.null m -  mapNull (LM m) = mapNull m-  mapSize (LM m) = mapSize m-  mapMember (Label k) (LM m) = mapMember k m-  mapLookup (Label k) (LM m) = mapLookup k m-  mapFindWithDefault def (Label k) (LM m) = mapFindWithDefault def k m+{-# INLINE mapSize #-}+mapSize :: LabelMap a -> Int+mapSize (LM m) = M.size m -  mapEmpty = LM mapEmpty-  mapSingleton (Label k) v = LM (mapSingleton k v)-  mapInsert (Label k) v (LM m) = LM (mapInsert k v m)-  mapInsertWith f (Label k) v (LM m) = LM (mapInsertWith f k v m)-  mapDelete (Label k) (LM m) = LM (mapDelete k m)-  mapAlter f (Label k) (LM m) = LM (mapAlter f k m)-  mapAdjust f (Label k) (LM m) = LM (mapAdjust f k m)+mapMember :: Label -> LabelMap a -> Bool+mapMember (Label k) (LM m) = M.member k m -  mapUnion (LM x) (LM y) = LM (mapUnion x y)-  mapUnionWithKey f (LM x) (LM y) = LM (mapUnionWithKey (f . mkHooplLabel) x y)-  mapDifference (LM x) (LM y) = LM (mapDifference x y)-  mapIntersection (LM x) (LM y) = LM (mapIntersection x y)-  mapIsSubmapOf (LM x) (LM y) = mapIsSubmapOf x y+mapLookup :: Label -> LabelMap a -> Maybe a+mapLookup (Label k) (LM m) = M.lookup k m -  mapMap f (LM m) = LM (mapMap f m)-  mapMapWithKey f (LM m) = LM (mapMapWithKey (f . mkHooplLabel) m)-  mapFoldl k z (LM m) = mapFoldl k z m-  mapFoldr k z (LM m) = mapFoldr k z m-  mapFoldlWithKey k z (LM m) =-      mapFoldlWithKey (\a v -> k a (mkHooplLabel v)) z m-  mapFoldMapWithKey f (LM m) = mapFoldMapWithKey (\k v -> f (mkHooplLabel k) v) m-  {-# INLINEABLE mapFilter #-}-  mapFilter f (LM m) = LM (mapFilter f m)-  {-# INLINEABLE mapFilterWithKey #-}-  mapFilterWithKey f (LM m) = LM (mapFilterWithKey (f . mkHooplLabel) m)+mapFindWithDefault :: a -> Label -> LabelMap a -> a+mapFindWithDefault def (Label k) (LM m) = M.findWithDefault def k m -  mapElems (LM m) = mapElems m-  mapKeys (LM m) = map mkHooplLabel (mapKeys m)-  {-# INLINEABLE mapToList #-}-  mapToList (LM m) = [(mkHooplLabel k, v) | (k, v) <- mapToList m]-  mapFromList assocs = LM (mapFromList [(lblToUnique k, v) | (k, v) <- assocs])-  mapFromListWith f assocs = LM (mapFromListWith f [(lblToUnique k, v) | (k, v) <- assocs])+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 @@ -136,12 +298,12 @@  instance TrieMap LabelMap where   type Key LabelMap = Label-  emptyTM = mapEmpty-  lookupTM k m = mapLookup k m+  emptyTM       = mapEmpty+  lookupTM k m  = mapLookup k m   alterTM k f m = mapAlter f k m-  foldTM k m z = mapFoldr k z m-  mapTM f m = mapMap f m-  filterTM f m = mapFilter f m+  foldTM k m z  = mapFoldr k z m+  filterTM f    = mapFilter f+  mapMaybeTM f  = mapMapMaybe f  ----------------------------------------------------------------------------- -- FactBase
GHC/Cmm/DebugBlock.hs view
@@ -6,9 +6,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE LambdaCase #-}---{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+{-# LANGUAGE EmptyCase #-}  ----------------------------------------------------------------------------- --@@ -29,7 +27,8 @@    -- * Unwinding information   UnwindTable, UnwindPoint(..),-  UnwindExpr(..), toUnwindExpr+  UnwindExpr(..), toUnwindExpr,+  pprUnwindTable   ) where  import GHC.Prelude@@ -38,26 +37,29 @@ 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 ( nilFS, mkFastString )+import GHC.Data.FastString ( LexicalFastString, nilFS, mkFastString ) import GHC.Unit.Module import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Cmm.Ppr.Expr ( pprExpr ) import GHC.Types.SrcLoc import GHC.Types.Tickish import GHC.Utils.Misc      ( seqList )  import GHC.Cmm.Dataflow.Block-import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Graph import GHC.Cmm.Dataflow.Label  import Data.Maybe-import Data.List     ( minimumBy, nubBy )+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.Either   ( partitionEithers )+import Data.Foldable ( toList )+import Data.Either ( partitionEithers )+import Data.Void  -- | Debug information about a block of code. Ticks scope over nested -- blocks.@@ -78,7 +80,7 @@   , dblBlocks     :: ![DebugBlock] -- ^ Nested blocks   } -instance OutputableP env CLabel => OutputableP env DebugBlock where+instance OutputableP Platform DebugBlock where   pdoc env blk =             (if | dblProcedure blk == dblLabel blk                 -> text "proc"@@ -86,7 +88,7 @@                 -> text "pp-blk"                 | otherwise                 -> text "blk") <+>-            ppr (dblLabel blk) <+> parens (pdoc env (dblCLabel blk)) <+>+            ppr (dblLabel blk) <+> parens (pprAsmLabel env (dblCLabel blk)) <+>             (maybe empty ppr (dblSourceTick blk)) <+>             (maybe (text "removed") ((text "pos " <>) . ppr)                    (dblPosition blk)) <+>@@ -95,34 +97,40 @@  -- | Intermediate data structure holding debug-relevant context information -- about a block.-type BlockContext = (CmmBlock, RawCmmDecl)+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 -> RawCmmGroup -> [DebugBlock]+cmmDebugGen :: ModLocation -> [RawCmmDecl] -> [DebugBlock] cmmDebugGen modLoc decls = map (blocksForScope Nothing) topScopes   where-      blockCtxs :: Map.Map CmmTickScope [BlockContext]+      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 (\a -> findP a a) $ Map.keys blockCtxs+        = partitionEithers $ map (\(k, a) -> findP (k, a) k) $ Map.toList blockCtxs+       findP tsc GlobalScope = Left tsc -- top scope-      findP tsc scp | scp' `Map.member` blockCtxs = Right (scp', tsc)+      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'-#if __GLASGOW_HASKELL__ < 901-                   | otherwise                   = panic "findP impossible"-#endif -      scopeMap = foldr (uncurry insertMulti) Map.empty childScopes+      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@@ -141,7 +149,7 @@                    | 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+                where ticks = bCtxsTicks $ maybe [] toList $ Map.lookup s blockCtxs       ticksToCopy _ = []       bCtxsTicks = concatMap (blockTicks . fst) @@ -151,41 +159,37 @@       -- (if we generated one, we probably want debug information to       -- refer to it).       bestSrcTick = minimumBy (comparing rangeRating)-      rangeRating (SourceNote span _)+      rangeRating (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) +++      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       = case info of-                                 Just (CmmStaticsRaw infoLbl _) -> infoLbl-                                 Nothing-                                   | g_entry graph == label -> entryLbl-                                   | otherwise              -> blockLbl label+                             , dblCLabel       = blockLbl label                              , dblHasInfoTbl   = isJust info                              , dblParent       = Nothing                              , dblTicks        = ticks                              , dblPosition     = Nothing -- see cmmDebugLink-                             , dblSourceTick   = stick+                             , dblSourceTick   = uncurry SourceNote <$> stick                              , dblBlocks       = blocks                              , dblUnwind       = []                              }-                where (CmmProc infos entryLbl _ graph) = prc+                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@@ -193,26 +197,26 @@                -- A source tick scopes over all nested blocks. However               -- their source ticks might take priority.-              isSourceTick SourceNote {} = True-              isSourceTick _             = False+              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 filter isSourceTick ticks of-                []     -> cstick-                sticks -> Just $! bestSrcTick (sticks ++ maybeToList cstick)+              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 :: 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]+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@@ -221,29 +225,30 @@                 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 :: 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)-          | lbl `setMember` visited-          = walkBlock prc blocks (visited, m)-          | otherwise-          = walkBlock prc blocks $-            walkBlock prc succs-              (lbl `setInsert` visited,-               insertMulti scope (block, prc) m)+        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-                (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+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).         --@@ -251,7 +256,7 @@         -- 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+        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@@ -260,14 +265,18 @@ -- native generated code. cmmDebugLink :: [Label] -> LabelMap [UnwindPoint]              -> [DebugBlock] -> [DebugBlock]-cmmDebugLink labels unwindPts blocks = map link blocks+cmmDebugLink labels unwindPts blocks = mapMaybe 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-                           }+        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@@ -496,9 +505,9 @@ -- | A label associated with an 'UnwindTable' data UnwindPoint = UnwindPoint !CLabel !UnwindTable -instance OutputableP env CLabel => OutputableP env UnwindPoint where+instance OutputableP Platform UnwindPoint where   pdoc env (UnwindPoint lbl uws) =-      braces $ pdoc env lbl <> colon+      braces $ pprAsmLabel env lbl <> colon       <+> hsep (punctuate comma $ map pprUw $ Map.toList uws)     where       pprUw (g, expr) = ppr g <> char '=' <> pdoc env expr@@ -512,7 +521,7 @@  -- | Expressions, used for unwind information data UnwindExpr = UwConst !Int                  -- ^ literal value-                | UwReg !GlobalReg !Int         -- ^ register plus offset+                | UwReg !GlobalRegUse !Int      -- ^ register plus offset                 | UwDeref UnwindExpr            -- ^ pointer dereferencing                 | UwLabel CLabel                 | UwPlus UnwindExpr UnwindExpr@@ -520,16 +529,24 @@                 | UwTimes UnwindExpr UnwindExpr                 deriving (Eq) -instance OutputableP env CLabel => OutputableP env UnwindExpr where+instance OutputableP Platform UnwindExpr where   pdoc = pprUnwindExpr 0 -pprUnwindExpr :: OutputableP env CLabel => Rational -> env -> UnwindExpr -> SDoc+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     -> ppr i-  UwReg g 0     -> ppr g+  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     -> pdoc env l+  UwLabel l     -> pprAsmLabel env l   UwPlus e0 e1    | p <= 0     -> pprUnwindExpr 0 env e0 <> char '+' <> pprUnwindExpr 0 env e1   UwMinus e0 e1@@ -537,6 +554,8 @@   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@@ -559,6 +578,6 @@     (MO_Sub{}, u1,        u2       ) -> UwMinus u1 u2     (MO_Mul{}, u1,        u2       ) -> UwTimes u1 u2     _otherwise -> pprPanic "Unsupported operator in unwind expression!"-                           (pprExpr platform e)+                           (pdoc platform e) toUnwindExpr platform e   = pprPanic "Unsupported unwind expression!" (pdoc platform e)
+ GHC/Cmm/Dominators.hs view
@@ -0,0 +1,217 @@+{-# LANGUAGE GADTs #-}++module GHC.Cmm.Dominators+  (+  -- * Dominator analysis and representation of results+    DominatorSet(..)+  , GraphWithDominators(..)+  , RPNum+  , graphWithDominators++  -- * Utility functions on graphs or graphs-with-dominators+  , graphMap+  , gwdRPNumber+  , gwdDominatorsOf+  , gwdDominatorTree++  -- * Utility functions on dominator sets+  , dominatorsMember+  , intersectDominators+  )+where++import GHC.Prelude++import Data.Array.IArray+import qualified Data.Tree as Tree++import Data.Word++import qualified GHC.CmmToAsm.CFG.Dominators as LT++import GHC.Cmm.Dataflow+import GHC.Cmm.Dataflow.Block+import GHC.Cmm.Dataflow.Graph+import GHC.Cmm.Dataflow.Label+import GHC.Cmm++import GHC.Utils.Outputable( Outputable(..), text, int, hcat, (<+>))+import GHC.Utils.Misc+import GHC.Utils.Panic+import GHC.Utils.Word64 (intToWord64)+import qualified GHC.Data.Word64Map as WM+import qualified GHC.Data.Word64Set as WS+++-- | =Dominator sets+--+-- Node X dominates node Y if and only if every path from the entry to+-- Y includes X.  Node Y technically dominates itself, but it is+-- never included in the *representation* of its dominator set.+--+-- A dominator set is represented as a linked list in which each node+-- points to its *immediate* dominator, which is its parent in the+-- dominator tree.  In many circumstances the immediate dominator+-- will be the only dominator of interest.++data DominatorSet = ImmediateDominator { ds_label  :: Label -- ^ Label of the immediate dominator.+                                       , ds_parent :: DominatorSet -- ^ Set of nodes dominating the immediate dominator.+                                       }+                  | EntryNode+  deriving (Eq)++instance Outputable DominatorSet where+  ppr EntryNode = text "entry"+  ppr (ImmediateDominator l parent) = ppr l <+> text "->" <+> ppr parent++++-- | Reverse postorder number of a node in a CFG+newtype RPNum = RPNum Int+  deriving (Eq, Ord)+-- in reverse postorder, nodes closer to the entry have smaller numbers++instance Show RPNum where+  show (RPNum i) = "RP" ++ show i++instance Outputable RPNum where+  ppr (RPNum i) = hcat [text "RP", int i]+   -- using `(<>)` would conflict with Semigroup++++dominatorsMember :: Label -> DominatorSet -> Bool+-- ^ Use to tell if the given label is in the given+-- dominator set.  Which is to say, does the bloc+-- with with given label _properly_ and _non-vacuously_+-- dominate the node whose dominator set this is?+--+-- Takes linear time in the height of the dominator tree,+-- but uses space efficiently.+dominatorsMember lbl (ImmediateDominator l p) = l == lbl || dominatorsMember lbl p+dominatorsMember _   EntryNode = False+++-- | Intersect two dominator sets to produce a third dominator set.+-- This function takes time linear in the size of the sets.+-- As such it is inefficient and should be used only for things+-- like visualizations or linters.+intersectDominators :: DominatorSet -> DominatorSet -> DominatorSet+intersectDominators ds ds' = commonPrefix (revDoms ds []) (revDoms ds' []) EntryNode+  where revDoms EntryNode prev = prev+        revDoms (ImmediateDominator lbl doms) prev = revDoms doms (lbl:prev)+        commonPrefix (a:as) (b:bs) doms+            | a == b = commonPrefix as bs (ImmediateDominator a doms)+        commonPrefix _ _ doms = doms+++-- | The result of dominator analysis.  Also includes a reverse+-- postorder numbering, which is needed for dominator analysis+-- and for other (downstream) analyses.+--+-- Invariant: Dominators, graph, and RP numberings include only *reachable* blocks.+data GraphWithDominators node =+    GraphWithDominators { gwd_graph :: GenCmmGraph node+                        , gwd_dominators :: LabelMap DominatorSet+                        , gwd_rpnumbering :: LabelMap RPNum+                        }+++-- | Call this function with a `CmmGraph` to get back the results of a+-- dominator analysis of that graph (as well as a reverse postorder+-- numbering).  The result also includes the subgraph of the original+-- graph that contains only the reachable blocks.+graphWithDominators :: forall node .+       (NonLocal node, HasDebugCallStack)+       => GenCmmGraph node+       -> GraphWithDominators node++-- The implementation uses the Lengauer-Tarjan algorithm from the x86+-- back end.++-- Technically, we do not need Word64 here, however the dominators code+-- has to accomodate Word64 for other uses.++graphWithDominators g = GraphWithDominators (reachable rpblocks g) dmap rpmap+      where rpblocks = revPostorderFrom (graphMap g) (g_entry g)+            rplabels' = map entryLabel rpblocks+            rplabels :: Array Word64 Label+            rplabels = listArray bounds rplabels'++            rpmap :: LabelMap RPNum+            rpmap = mapFromList $ zipWith kvpair rpblocks [0..]+              where kvpair block i = (entryLabel block, RPNum i)++            labelIndex :: Label -> Word64+            labelIndex = flip findLabelIn imap+              where imap :: LabelMap Word64+                    imap = mapFromList $ zip rplabels' [0..]+            blockIndex = labelIndex . entryLabel++            bounds :: (Word64, Word64)+            bounds = (0, intToWord64 (length rpblocks - 1))++            ltGraph :: [Block node C C] -> LT.Graph+            ltGraph [] = WM.empty+            ltGraph (block:blocks) =+                WM.insert+                      (blockIndex block)+                      (WS.fromList $ map labelIndex $ successors block)+                      (ltGraph blocks)++            idom_array :: Array Word64 LT.Node+            idom_array = array bounds $ LT.idom (0, ltGraph rpblocks)++            domSet 0 = EntryNode+            domSet i = ImmediateDominator (rplabels ! d) (doms ! d)+                where d = idom_array ! i+            doms = tabulate bounds domSet++            dmap = mapFromList $ zipWith (\lbl i -> (lbl, domSet i)) rplabels' [0..]++reachable :: NonLocal node => [Block node C C] -> GenCmmGraph node -> GenCmmGraph node+reachable blocks g = g { g_graph = GMany NothingO blockmap NothingO }+  where blockmap = mapFromList [(entryLabel b, b) | b <- blocks]+++-- | =Utility functions++-- | Call `graphMap` to get the mapping from `Label` to `Block` that+-- is embedded in every `CmmGraph`.+graphMap :: GenCmmGraph n -> LabelMap (Block n C C)+graphMap (CmmGraph { g_graph = GMany NothingO blockmap NothingO }) = blockmap++-- | Use `gwdRPNumber` on the result of the dominator analysis to get+-- a mapping from the `Label` of each reachable block to the reverse+-- postorder number of that block.+gwdRPNumber :: HasDebugCallStack => GraphWithDominators node -> Label -> RPNum+gwdRPNumber g l = findLabelIn l (gwd_rpnumbering g)++findLabelIn :: HasDebugCallStack => Label -> LabelMap a -> a+findLabelIn lbl = mapFindWithDefault failed lbl+  where failed =+            pprPanic "label not found in result of analysis" (ppr lbl)++-- | Use `gwdDominatorsOf` on the result of the dominator analysis to get+-- a mapping from the `Label` of each reachable block to the dominator+-- set (and the immediate dominator) of that block.  The+-- implementation is space-efficient: intersecting dominator+-- sets share the representation of their intersection.++gwdDominatorsOf :: HasDebugCallStack => GraphWithDominators node -> Label -> DominatorSet+gwdDominatorsOf g lbl = findLabelIn lbl (gwd_dominators g)++gwdDominatorTree :: GraphWithDominators node -> Tree.Tree Label+gwdDominatorTree gwd = subtreeAt (g_entry (gwd_graph gwd))+  where subtreeAt label = Tree.Node label $ map subtreeAt $ children label+        children l = mapFindWithDefault [] l child_map+        child_map :: LabelMap [Label]+        child_map = mapFoldlWithKey addParent mapEmpty $ gwd_dominators gwd+          where addParent cm _ EntryNode = cm+                addParent cm lbl (ImmediateDominator p _) =+                    mapInsertWith (++) p [lbl] cm+++-- | Turn a function into an array.  Inspired by SML's `Array.tabulate`+tabulate :: (Ix i) => (i, i) -> (i -> e) -> Array i e+tabulate b f = listArray b $ map f $ range b
GHC/Cmm/Expr.hs view
@@ -1,8 +1,4 @@-{-# LANGUAGE BangPatterns #-} {-# LANGUAGE LambdaCase #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-}  module GHC.Cmm.Expr@@ -10,12 +6,13 @@     , CmmReg(..), cmmRegType, cmmRegWidth     , CmmLit(..), cmmLitType     , AlignmentSpec(..)+      -- TODO: Remove:     , LocalReg(..), localRegType-    , GlobalReg(..), isArgReg, globalRegType+    , GlobalReg(..), isArgReg, globalRegSpillType+    , GlobalRegUse(..)     , spReg, hpReg, spLimReg, hpLimReg, nodeReg     , currentTSOReg, currentNurseryReg, hpAllocReg, cccsReg     , node, baseReg-    , VGcPtr(..)      , DefinerOfRegs, UserOfRegs     , foldRegsDefd, foldRegsUsed@@ -26,6 +23,11 @@     , plusRegSet, minusRegSet, timesRegSet, sizeRegSet, nullRegSet     , regSetToList +    , isTrivialCmmExpr+    , hasNoGlobalRegs+    , isLit+    , isComparisonExpr+     , Area(..)     , module GHC.Cmm.MachOp     , module GHC.Cmm.Type@@ -39,12 +41,14 @@ 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 GHC.Types.Unique +import Data.Maybe import Data.Set (Set) import qualified Data.Set as Set+import Numeric ( fromRat )  import GHC.Types.Basic (Alignment, mkAlignment, alignmentOf) @@ -78,14 +82,12 @@   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) -data CmmReg-  = CmmLocal  {-# UNPACK #-} !LocalReg-  | CmmGlobal GlobalReg-  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@@ -94,6 +96,14 @@                    -- 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@@ -217,6 +227,9 @@                      -- 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@@ -231,9 +244,9 @@ cmmExprType platform = \case    (CmmLit lit)        -> cmmLitType platform lit    (CmmLoad _ rep _)   -> rep-   (CmmReg reg)        -> cmmRegType platform reg+   (CmmReg reg)        -> cmmRegType reg    (CmmMachOp op args) -> machOpResultType platform op (map (cmmExprType platform) args)-   (CmmRegOff reg _)   -> cmmRegType platform reg+   (CmmRegOff reg _)   -> cmmRegType reg    (CmmStackSlot _ _)  -> bWord platform -- an address    -- Careful though: what is stored at the stack slot may be bigger than    -- an address@@ -276,39 +289,35 @@                                             return (CmmMachOp op' args) maybeInvertCmmExpr _ = Nothing ---------------------------------------------------------------------------------              Local registers------------------------------------------------------------------------------+---------------------------------------------------+--         CmmExpr predicates+--------------------------------------------------- -data LocalReg-  = LocalReg {-# UNPACK #-} !Unique !CmmType-    -- ^ Parameters:-    --   1. Identifier-    --   2. Type-  deriving Show+isTrivialCmmExpr :: CmmExpr -> Bool+isTrivialCmmExpr (CmmLoad _ _ _)    = False+isTrivialCmmExpr (CmmMachOp _ _)    = False+isTrivialCmmExpr (CmmLit _)         = True+isTrivialCmmExpr (CmmReg _)         = True+isTrivialCmmExpr (CmmRegOff _ _)    = True+isTrivialCmmExpr (CmmStackSlot _ _) = panic "isTrivialCmmExpr CmmStackSlot" -instance Eq LocalReg where-  (LocalReg u1 _) == (LocalReg u2 _) = u1 == u2+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 --- 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+isLit :: CmmExpr -> Bool+isLit (CmmLit _) = True+isLit _          = False -instance Uniquable LocalReg where-  getUnique (LocalReg uniq _) = uniq+isComparisonExpr :: CmmExpr -> Bool+isComparisonExpr (CmmMachOp op _) = isComparisonMachOp op+isComparisonExpr _                = False -cmmRegType :: Platform -> CmmReg -> CmmType-cmmRegType _        (CmmLocal  reg) = localRegType reg-cmmRegType platform (CmmGlobal reg) = globalRegType platform reg -cmmRegWidth :: Platform -> CmmReg -> Width-cmmRegWidth platform = typeWidth . cmmRegType platform--localRegType :: LocalReg -> CmmType-localRegType (LocalReg _ rep) = rep- ----------------------------------------------------------------------------- --    Register-use information for expressions and other types -----------------------------------------------------------------------------@@ -372,10 +381,18 @@ instance UserOfRegs GlobalReg CmmReg where     {-# INLINEABLE foldRegsUsed #-}     foldRegsUsed _ _ z (CmmLocal _)    = z-    foldRegsUsed _ f z (CmmGlobal reg) = f z reg+    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@@ -404,241 +421,161 @@   foldRegsDefd platform f set as = foldl' (foldRegsDefd platform 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).+-- --------------------------------------------------------------------------+-- Pretty-printing expressions+-- -------------------------------------------------------------------------- -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.+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 -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!--}+-- Here's the precedence table from GHC.Cmm.Parser:+-- %nonassoc '>=' '>' '<=' '<' '!=' '=='+-- %left '|'+-- %left '^'+-- %left '&'+-- %left '>>' '<<'+-- %left '-' '+'+-- %left '/' '*' '%'+-- %right '~' -data GlobalReg-  -- Argument and return registers-  = VanillaReg                  -- pointers, unboxed ints and chars-        {-# UNPACK #-} !Int     -- its number-        VGcPtr+-- We just cope with the common operators for now, the rest will get+-- a default conservative behaviour. -  | FloatReg            -- single-precision floating-point registers-        {-# UNPACK #-} !Int     -- its number+-- %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 -  | DoubleReg           -- double-precision floating-point registers-        {-# UNPACK #-} !Int     -- its number+infixMachOp1, infixMachOp7, infixMachOp8 :: MachOp -> Maybe SDoc -  | LongReg             -- long int registers (64-bit, really)-        {-# UNPACK #-} !Int     -- its number+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 -  | XmmReg                      -- 128-bit SIMD vector register-        {-# UNPACK #-} !Int     -- its number+-- %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 -  | YmmReg                      -- 256-bit SIMD vector register-        {-# UNPACK #-} !Int     -- its number+infixMachOp7 (MO_Add _)  = Just (char '+')+infixMachOp7 (MO_Sub _)  = Just (char '-')+infixMachOp7 _           = Nothing -  | ZmmReg                      -- 512-bit SIMD vector register-        {-# UNPACK #-} !Int     -- its number+-- %left '/' '*' '%'+pprExpr8 platform (CmmMachOp op [x,y])+   | Just doc <- infixMachOp8 op+   = pprExpr8 platform x <+> doc <+> pprExpr9 platform y+pprExpr8 platform e = pprExpr9 platform e -  -- 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+infixMachOp8 (MO_U_Quot _) = Just (char '/')+infixMachOp8 (MO_Mul _)    = Just (char '*')+infixMachOp8 (MO_U_Rem _)  = Just (char '%')+infixMachOp8 _             = Nothing -                -- 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+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 -  -- 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+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 -  -- 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+        -- unary+        [x]   -> doc <> pprExpr9 platform x -  -- The is a dummy register used to indicate to the stack unwinder where-  -- a routine would return to.-  | UnwindReturnReg+        _     -> pprTrace "GHC.Cmm.Expr.genMachOp: machop with strange number of args"+                          (pprMachOp mop <+>+                            parens (hcat $ punctuate comma (map (pprExpr platform) args)))+                          empty -  -- 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+   | isJust (infixMachOp1 mop)+   || isJust (infixMachOp7 mop)+   || isJust (infixMachOp8 mop)  = parens (pprExpr platform (CmmMachOp mop args)) -  deriving( Show )+   | 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, -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-   -- NOTE: XMM, YMM, ZMM registers actually are the same registers-   -- at least with respect to store at YMM i and then read from XMM i-   -- and similarly for ZMM etc.-   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+--+-- 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 --- NOTE: this Ord instance affects the tuple layout in GHCi, see---       Note [GHCi tuple layout]-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+-- --------------------------------------------------------------------------+-- 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+-- -------------------------------------------------------------------------- --- convenient aliases-baseReg, spReg, hpReg, spLimReg, hpLimReg, nodeReg,-  currentTSOReg, currentNurseryReg, hpAllocReg, cccsReg  :: CmmReg-baseReg = CmmGlobal BaseReg-spReg = CmmGlobal Sp-hpReg = CmmGlobal Hp-hpLimReg = CmmGlobal HpLim-spLimReg = CmmGlobal SpLim-nodeReg = CmmGlobal node-currentTSOReg = CmmGlobal CurrentTSO-currentNurseryReg = CmmGlobal CurrentNursery-hpAllocReg = CmmGlobal HpAlloc-cccsReg = CmmGlobal CCCS+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 ] -node :: GlobalReg-node = VanillaReg 1 VGcPtr+    CmmFloat f rep     -> hsep [ double (fromRat f), dcolon, ppr rep ]+    CmmVec lits        -> char '<' <> commafy (map (pprLit platform) lits) <> char '>'+    CmmLabel clbl      -> pdoc platform clbl+    CmmLabelOff clbl i -> pdoc platform clbl <> ppr_offset i+    CmmLabelDiffOff clbl1 clbl2 i _ -> pdoc platform clbl1 <> char '-'+                                       <> pdoc platform clbl2 <> ppr_offset i+    CmmBlock id        -> ppr id+    CmmHighStackMark -> text "<highSp>" -globalRegType :: Platform -> GlobalReg -> CmmType-globalRegType platform = \case-   (VanillaReg _ VGcPtr)    -> gcWord platform-   (VanillaReg _ VNonGcPtr) -> bWord 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)+pprLit1 :: Platform -> CmmLit -> SDoc+pprLit1 platform lit@(CmmLabelOff {}) = parens (pprLit platform lit)+pprLit1 platform lit                  = pprLit platform lit -   Hp         -> gcWord platform -- The initialiser for all-                                 -- dynamically allocated closures-   _          -> bWord platform+ppr_offset :: Int -> SDoc+ppr_offset i+    | i==0      = empty+    | i>=0      = char '+' <> int i+    | otherwise = char '-' <> int (-i) -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+commafy :: [SDoc] -> SDoc+commafy xs = fsep $ punctuate comma xs
+ GHC/Cmm/GenericOpt.hs view
@@ -0,0 +1,212 @@+-- -----------------------------------------------------------------------------+--+-- (c) The University of Glasgow 1993-2004+--+--+-- -----------------------------------------------------------------------------++{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE UnboxedTuples #-}++module GHC.Cmm.GenericOpt+   ( cmmToCmm+   )+where++import GHC.Prelude hiding (head)+import GHC.Platform+import GHC.CmmToAsm.PIC+import GHC.CmmToAsm.Config+import GHC.CmmToAsm.Types+import GHC.Cmm.BlockId+import GHC.Cmm+import GHC.Cmm.Utils+import GHC.Cmm.Dataflow.Block+import GHC.Cmm.Opt           ( cmmMachOpFold )+import GHC.Cmm.CLabel+import GHC.Data.FastString+import GHC.Unit+import Control.Monad.Trans.Reader+import GHC.Utils.Monad.State.Strict as Strict++-- -----------------------------------------------------------------------------+-- Generic Cmm optimiser++{-+Here we do:++  (a) Constant folding+  (c) Position independent code and dynamic linking+        (i)  introduce the appropriate indirections+             and position independent refs+        (ii) compile a list of imported symbols+  (d) Some arch-specific optimizations++(a) will be moving to the new Hoopl pipeline, however, (c) and+(d) are only needed by the native backend and will continue to live+here.++Ideas for other things we could do (put these in Hoopl please!):++  - shortcut jumps-to-jumps+  - simple CSE: if an expr is assigned to a temp, then replace later occs of+    that expr with the temp, until the expr is no longer valid (can push through+    temp assignments, and certain assigns to mem...)+-}++cmmToCmm :: NCGConfig -> RawCmmDecl -> (RawCmmDecl, [CLabel])+cmmToCmm _ top@(CmmData _ _) = (top, [])+cmmToCmm config (CmmProc info lbl live graph)+    = runCmmOpt config $+      do blocks' <- mapM cmmBlockConFold (toBlockList graph)+         return $ CmmProc info lbl live (ofBlockList (g_entry graph) blocks')++type OptMResult a = (# a, [CLabel] #)++pattern OptMResult :: a -> b -> (# a, b #)+pattern OptMResult x y = (# x, y #)+{-# COMPLETE OptMResult #-}++newtype CmmOptM a = CmmOptM (NCGConfig -> [CLabel] -> OptMResult a)+    deriving (Functor, Applicative, Monad) via (ReaderT NCGConfig (Strict.State [CLabel]))++instance CmmMakeDynamicReferenceM CmmOptM where+    addImport = addImportCmmOpt++addImportCmmOpt :: CLabel -> CmmOptM ()+addImportCmmOpt lbl = CmmOptM $ \_ imports -> OptMResult () (lbl:imports)++getCmmOptConfig :: CmmOptM NCGConfig+getCmmOptConfig = CmmOptM $ \config imports -> OptMResult config imports++runCmmOpt :: NCGConfig -> CmmOptM a -> (a, [CLabel])+runCmmOpt config (CmmOptM f) =+  case f config [] of+    OptMResult result imports -> (result, imports)++cmmBlockConFold :: CmmBlock -> CmmOptM CmmBlock+cmmBlockConFold block = do+  let (entry, middle, last) = blockSplit block+      stmts = blockToList middle+  stmts' <- mapM cmmStmtConFold stmts+  last' <- cmmStmtConFold last+  return $ blockJoin entry (blockFromList stmts') last'++-- This does three optimizations, but they're very quick to check, so we don't+-- bother turning them off even when the Hoopl code is active.  Since+-- this is on the old Cmm representation, we can't reuse the code either:+--  * reg = reg      --> nop+--  * if 0 then jump --> nop+--  * if 1 then jump --> jump+-- We might be tempted to skip this step entirely of not Opt_PIC, but+-- there is some PowerPC code for the non-PIC case, which would also+-- have to be separated.+cmmStmtConFold :: CmmNode e x -> CmmOptM (CmmNode e x)+cmmStmtConFold stmt+   = case stmt of+        CmmAssign reg src+           -> do src' <- cmmExprConFold DataReference src+                 return $ case src' of+                   CmmReg reg' | reg == reg' -> CmmComment (fsLit "nop")+                   new_src -> CmmAssign reg new_src++        CmmStore addr src align+           -> do addr' <- cmmExprConFold DataReference addr+                 src'  <- cmmExprConFold DataReference src+                 return $ CmmStore addr' src' align++        CmmCall { cml_target = addr }+           -> do addr' <- cmmExprConFold JumpReference addr+                 return $ stmt { cml_target = addr' }++        CmmUnsafeForeignCall target regs args+           -> do target' <- case target of+                              ForeignTarget e conv -> do+                                e' <- cmmExprConFold CallReference e+                                return $ ForeignTarget e' conv+                              PrimTarget _ ->+                                return target+                 args' <- mapM (cmmExprConFold DataReference) args+                 return $ CmmUnsafeForeignCall target' regs args'++        CmmCondBranch test true false likely+           -> do test' <- cmmExprConFold DataReference test+                 return $ case test' of+                   CmmLit (CmmInt 0 _) -> CmmBranch false+                   CmmLit (CmmInt _ _) -> CmmBranch true+                   _other -> CmmCondBranch test' true false likely++        CmmSwitch expr ids+           -> do expr' <- cmmExprConFold DataReference expr+                 return $ CmmSwitch expr' ids++        other+           -> return other++cmmExprConFold :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr+cmmExprConFold referenceKind expr = do+    config <- getCmmOptConfig++    let expr' = if not (ncgDoConstantFolding config)+                    then expr+                    else cmmExprCon config expr++    cmmExprNative referenceKind expr'++cmmExprCon :: NCGConfig -> CmmExpr -> CmmExpr+cmmExprCon config (CmmLoad addr rep align) = CmmLoad (cmmExprCon config addr) rep align+cmmExprCon config (CmmMachOp mop args)+    = cmmMachOpFold (ncgPlatform config) mop (map (cmmExprCon config) args)+cmmExprCon _ other = other++-- handles both PIC and non-PIC cases... a very strange mixture+-- of things to do.+cmmExprNative :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr+cmmExprNative referenceKind expr = do+     config <- getCmmOptConfig+     let platform = ncgPlatform config+         arch = platformArch platform+     case expr of+        CmmLoad addr rep align+          -> do addr' <- cmmExprNative DataReference addr+                return $ CmmLoad addr' rep align++        CmmMachOp mop args+          -> do args' <- mapM (cmmExprNative DataReference) args+                return $ CmmMachOp mop args'++        CmmLit (CmmBlock id)+          -> cmmExprNative referenceKind (CmmLit (CmmLabel (infoTblLbl id)))+          -- we must convert block Ids to CLabels here, because we+          -- might have to do the PIC transformation.  Hence we must+          -- not modify BlockIds beyond this point.++        CmmLit (CmmLabel lbl)+          -> cmmMakeDynamicReference config referenceKind lbl+        CmmLit (CmmLabelOff lbl off)+          -> do dynRef <- cmmMakeDynamicReference config referenceKind lbl+                -- need to optimize here, since it's late+                return $ cmmMachOpFold platform (MO_Add (wordWidth platform)) [+                    dynRef,+                    (CmmLit $ CmmInt (fromIntegral off) (wordWidth platform))+                  ]++        -- On powerpc (non-PIC), it's easier to jump directly to a label than+        -- to use the register table, so we replace these registers+        -- with the corresponding labels:+        CmmReg (CmmGlobal (GlobalRegUse EagerBlackholeInfo _))+          | arch == ArchPPC && not (ncgPIC config)+          -> cmmExprNative referenceKind $+             CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId (fsLit "__stg_EAGER_BLACKHOLE_info")))+        CmmReg (CmmGlobal (GlobalRegUse GCEnter1 _))+          | arch == ArchPPC && not (ncgPIC config)+          -> cmmExprNative referenceKind $+             CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId (fsLit "__stg_gc_enter_1")))+        CmmReg (CmmGlobal (GlobalRegUse GCFun _))+          | arch == ArchPPC && not (ncgPIC config)+          -> cmmExprNative referenceKind $+             CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId (fsLit "__stg_gc_fun")))++        other+           -> return other
GHC/Cmm/Graph.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE BangPatterns, GADTs #-}+{-# LANGUAGE GADTs #-}  module GHC.Cmm.Graph   ( CmmAGraph, CmmAGraphScoped, CgStmt(..)@@ -37,9 +37,9 @@ import GHC.Types.ForeignCall import GHC.Data.OrdList import GHC.Runtime.Heap.Layout (ByteOff)-import GHC.Types.Unique.Supply-import GHC.Utils.Panic+import GHC.Types.Unique.DSM import GHC.Utils.Constants (debugIsOn)+import GHC.Utils.Panic   -----------------------------------------------------------------------------@@ -73,12 +73,12 @@   | CgLast  (CmmNode O C)   | CgFork  BlockId CmmAGraph CmmTickScope -flattenCmmAGraph :: BlockId -> CmmAGraphScoped -> CmmGraph+flattenCmmAGraph :: BlockId -> CmmAGraphScoped -> DCmmGraph 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 []+  body = DWrap [(entryLabel b, b) | b <- flatten id stmts_t tscope [] ]    --   -- flatten: given an entry label and a CmmAGraph, make a list of blocks.@@ -169,13 +169,13 @@ outOfLine l (c,s) = unitOL (CgFork l c s)  -- | allocate a fresh label for the entry point-lgraphOfAGraph :: CmmAGraphScoped -> UniqSM CmmGraph+lgraphOfAGraph :: CmmAGraphScoped -> UniqDSM DCmmGraph lgraphOfAGraph g = do-  u <- getUniqueM+  u <- getUniqueDSM   return (labelAGraph (mkBlockId u) g)  -- | use the given BlockId as the label of the entry point-labelAGraph    :: BlockId -> CmmAGraphScoped -> CmmGraph+labelAGraph    :: BlockId -> CmmAGraphScoped -> DCmmGraph labelAGraph lbl ag = flattenCmmAGraph lbl ag  ---------- No-ops@@ -208,7 +208,7 @@  -- | A jump where the caller says what the live GlobalRegs are.  Used -- for low-level hand-written Cmm.-mkRawJump       :: Profile -> CmmExpr -> UpdFrameOffset -> [GlobalReg]+mkRawJump       :: Profile -> CmmExpr -> UpdFrameOffset -> [GlobalRegUse]                 -> CmmAGraph mkRawJump profile e updfr_off vols =   lastWithArgs profile Jump Old NativeNodeCall [] updfr_off $@@ -297,7 +297,7 @@ copyInOflow  :: Profile -> Convention -> Area              -> [CmmFormal]              -> [CmmFormal]-             -> (Int, [GlobalReg], CmmAGraph)+             -> (Int, [GlobalRegUse], CmmAGraph)  copyInOflow profile conv area formals extra_stk   = (offset, gregs, catAGraphs $ map mkMiddle nodes)@@ -308,35 +308,41 @@ copyIn :: Profile -> Convention -> Area        -> [CmmFormal]        -> [CmmFormal]-       -> (ByteOff, [GlobalReg], [CmmNode O O])+       -> (ByteOff, [GlobalRegUse], [CmmNode O O]) copyIn profile conv area formals extra_stk-  = (stk_size, [r | (_, RegisterParam r) <- args], map ci (stk_args ++ args))+  = (stk_size, [GlobalRegUse r (localRegType lr)| (lr, RegisterParam r) <- args], map ci (stk_args ++ args))   where     platform = profilePlatform profile-    -- See Note [Width of parameters]++    ci :: (LocalReg, ParamLocation) -> CmmNode O O     ci (reg, RegisterParam r@(VanillaReg {})) =         let local = CmmLocal reg-            global = CmmReg (CmmGlobal r)-            width = cmmRegWidth platform local-            expr-                | width == wordWidth platform = global-                | width < wordWidth platform =-                    CmmMachOp (MO_XX_Conv (wordWidth platform) width) [global]-                | otherwise = panic "Parameter width greater than word width"+            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 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 platform local+          width = cmmRegWidth local           expr  = CmmMachOp (MO_XX_Conv (wordWidth platform) width) [stack_slot]         in CmmAssign local expr @@ -359,7 +365,7 @@ copyOutOflow :: Profile -> Convention -> Transfer -> Area -> [CmmExpr]              -> UpdFrameOffset              -> [CmmExpr] -- extra stack args-             -> (Int, [GlobalReg], CmmAGraph)+             -> (Int, [GlobalRegUse], CmmAGraph)  -- Generate code to move the actual parameters into the locations -- required by the calling convention.  This includes a store for the@@ -376,25 +382,30 @@     platform = profilePlatform profile     (regs, graph) = foldr co ([], mkNop) (setRA ++ args ++ stack_params) -    -- See Note [Width of parameters]+    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 (r:rs, mkAssign (CmmGlobal r) value <*> ms)+        in (ru:rs, mkAssign (CmmGlobal ru) value <*> ms)      -- Non VanillaRegs     co (v, RegisterParam r) (rs, ms) =-        (r:rs, mkAssign (CmmGlobal r) v <*> ms)+      let ru = GlobalRegUse r (cmmExprType platform v)+      in (ru:rs, mkAssign (CmmGlobal ru) v <*> ms) -    -- See Note [Width of parameters]     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@@ -427,19 +438,18 @@  -- Note [Width of parameters] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~+-- -- Consider passing a small (< word width) primitive like Int8# to a function. -- It's actually non-trivial to do this without extending/narrowing:--- * Global registers are considered to have native word width (i.e., 64-bits on---   x86-64), so CmmLint would complain if we assigned an 8-bit parameter to a---   global register.--- * Same problem exists with LLVM IR.--- * Lowering gets harder since on x86-32 not every register exposes its lower+-- * 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@@ -453,13 +463,13 @@   mkCallEntry :: Profile -> Convention -> [CmmFormal] -> [CmmFormal]-            -> (Int, [GlobalReg], CmmAGraph)+            -> (Int, [GlobalRegUse], CmmAGraph) mkCallEntry profile conv formals extra_stk   = copyInOflow profile conv Old formals extra_stk  lastWithArgs :: Profile -> Transfer -> Area -> Convention -> [CmmExpr]              -> UpdFrameOffset-             -> (ByteOff -> [GlobalReg] -> CmmAGraph)+             -> (ByteOff -> [GlobalRegUse] -> CmmAGraph)              -> CmmAGraph lastWithArgs profile transfer area conv actuals updfr_off last =   lastWithArgsAndExtraStack profile transfer area conv actuals@@ -468,7 +478,7 @@ lastWithArgsAndExtraStack :: Profile              -> Transfer -> Area -> Convention -> [CmmExpr]              -> UpdFrameOffset -> [CmmExpr]-             -> (ByteOff -> [GlobalReg] -> CmmAGraph)+             -> (ByteOff -> [GlobalRegUse] -> CmmAGraph)              -> CmmAGraph lastWithArgsAndExtraStack profile transfer area conv actuals updfr_off                           extra_stack last =@@ -482,7 +492,7 @@ noExtraStack = []  toCall :: CmmExpr -> Maybe BlockId -> UpdFrameOffset -> ByteOff-       -> ByteOff -> [GlobalReg]+       -> ByteOff -> [GlobalRegUse]        -> CmmAGraph toCall e cont updfr_off res_space arg_space regs =   mkLast $ CmmCall e cont regs arg_space res_space updfr_off
GHC/Cmm/Info.hs view
@@ -36,23 +36,22 @@ 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 GHC.Data.Stream (Stream) import qualified GHC.Data.Stream as Stream-import GHC.Cmm.Dataflow.Collections+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.Panic.Plain-import GHC.Types.Unique.Supply 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) @@ -65,19 +64,15 @@                  , cit_srt  = Nothing                  , cit_clo  = Nothing } -cmmToRawCmm :: Logger -> Profile -> Stream IO CmmGroupSRTs a-            -> IO (Stream IO RawCmmGroup a)+cmmToRawCmm :: Logger -> Profile -> CgStream CmmGroupSRTs a+            -> IO (CgStream RawCmmGroup a) cmmToRawCmm logger profile cmms-  = do {-       ; let do_one :: [CmmDeclSRTs] -> IO [RawCmmDecl]-             do_one cmm = do-               uniqs <- mkSplitUniqSupply 'i'+  = 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 ())-                  -- TODO: It might be better to make `mkInfoTable` run in-                  -- IO as well so we don't have to pass around-                  -- a UniqSupply (see #16843)-                 (return $ initUs_ uniqs $ concatMapM (mkInfoTable profile) cmm)+               withTimingSilent logger (text "Cmm -> Raw Cmm") (\x -> seqList x ()) $ do+                 liftUniqDSM $+                   concatMapM (mkInfoTable profile) cmm        ; return (Stream.mapM do_one cmms)        } @@ -115,7 +110,7 @@ -- --  * The SRT slot is only there if there is SRT info to record -mkInfoTable :: Profile -> CmmDeclSRTs -> UniqSM [RawCmmDecl]+mkInfoTable :: Profile -> CmmDeclSRTs -> UniqDSM [RawCmmDecl] mkInfoTable _ (CmmData sec dat) = return [CmmData sec dat]  mkInfoTable profile proc@(CmmProc infos entry_lbl live blocks)@@ -178,7 +173,7 @@ mkInfoTableContents :: Profile                     -> CmmInfoTable                     -> Maybe Int               -- Override default RTS type tag?-                    -> UniqSM ([RawCmmDecl],             -- Auxiliary top decls+                    -> UniqDSM ([RawCmmDecl],             -- Auxiliary top decls                                InfoTableContents)       -- Info tbl + extra bits  mkInfoTableContents profile@@ -219,10 +214,10 @@   where     platform = profilePlatform profile     mk_pieces :: ClosureTypeInfo -> [CmmLit]-              -> UniqSM ( 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+              -> 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)@@ -339,14 +334,14 @@ -- The head of the stack layout is the top of the stack and -- the least-significant bit. -mkLivenessBits :: Platform -> Liveness -> UniqSM (CmmLit, [RawCmmDecl])+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 <- getUniqueM+  = do { uniq <- getUniqueDSM        ; let bitmap_lbl = mkBitmapLabel uniq        ; return (CmmLabel bitmap_lbl,                  [mkRODataLits bitmap_lbl lits]) }@@ -413,16 +408,16 @@ -- ------------------------------------------------------------------------- -mkProfLits :: Platform -> ProfilingInfo -> UniqSM ((CmmLit,CmmLit), [RawCmmDecl])+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 -> UniqSM (CmmLit, GenCmmDecl RawCmmStatics info stmt)+newStringLit :: ByteString -> UniqDSM (CmmLit, GenCmmDecl RawCmmStatics info stmt) newStringLit bytes-  = do { uniq <- getUniqueM+  = do { uniq <- getUniqueDSM        ; return (mkByteStringCLit (mkStringLitLabel uniq) bytes) }  @@ -450,7 +445,7 @@ -- | Takes a closure pointer and returns the info table pointer closureInfoPtr :: Platform -> DoAlignSanitisation -> CmmExpr -> CmmExpr closureInfoPtr platform align_check e =-    cmmLoadBWord platform (wordAligned 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
GHC/Cmm/Info/Build.hs view
@@ -1,11 +1,7 @@-{-# LANGUAGE GADTs, BangPatterns, RecordWildCards,-    GeneralizedNewtypeDeriving, NondecreasingIndentation, TupleSections,-    ScopedTypeVariables, OverloadedStrings, LambdaCase #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE GADTs, RecordWildCards,+    NondecreasingIndentation,+    OverloadedStrings, LambdaCase #-} {-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UndecidableInstances #-}  @@ -27,7 +23,6 @@ import GHC.Cmm.Dataflow.Block import GHC.Cmm.Dataflow.Graph import GHC.Cmm.Dataflow.Label-import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow import GHC.Unit.Module import GHC.Data.Graph.Directed@@ -38,7 +33,6 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Runtime.Heap.Layout-import GHC.Types.Unique.Supply import GHC.Types.CostCentre import GHC.StgToCmm.Heap @@ -52,6 +46,7 @@ import Data.List (unzip4)  import GHC.Types.Name.Set+import GHC.Types.Unique.DSM  {- Note [SRTs]    ~~~~~~~~~~~@@ -113,55 +108,70 @@ - Static thunks (THUNK), ie. CAFs - Continuations (RET_SMALL, etc.) -In each case, the info table points to the SRT.  There are three ways which we-may encode the location of the SRT in the info table, described below.+In each case, the info table points to the SRT, if there is one. -USE_SRT_OFFSET----------------In this case we use the info->srt to encode whether or not there is an-SRT and if so encode the offset to its location in info->f.srt_offset:+- info->srt is 0 if there's no SRT+- otherwise, there are three ways which we may encode the location of the SRT in+  the info table, described below. -- info->srt is 0 if there's no SRT, otherwise,-- info->srt == 1 and info->f.srt_offset points to the SRT+USE_SRT_POINTER+---------------+Most general implementation. Can always be used, but other ways are more efficient. -e.g. for a FUN with an SRT:+- info->srt is a pointer -StgFunInfoTable       +------+-  info->f.srt_offset  |  ------------> offset to SRT object-StgStdInfoTable       +------++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           |  1   |+  info->srt           |  ------------> pointer to SRT object   info->type          | ...  |                       |------| -USE_SRT_POINTER-----------------When tables-next-to-code isn't in use we rather encode an absolute pointer to-the SRT in info->srt. e.g. for a FUN with an SRT:+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  |  ------------> pointer to SRT object-StgStdInfoTable       +------++  info->f.srt_offset  |  ------------> offset to SRT object+StgInfoTable          +------+   info->layout.ptrs   | ...  |   info->layout.nptrs  | ...  |   info->srt           |  1   |   info->type          | ...  |                       |------|+ USE_INLINE_SRT_FIELD ---------------------When using TNTC on x86_64 (and other platforms using the small memory model),-we optimise the info table representation further.  The offset to the SRT can+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. -On x86_64 with TABLES_NEXT_TO_CODE (except on MachO, due to #15169):--- info->srt is zero if there's no SRT, otherwise:+- 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 -StgStdInfoTable       +------++StgInfoTable          +------+   info->layout.ptrs   |      |   info->layout.nptrs  |      |   info->srt           |  ------------> offset to SRT object@@ -561,7 +571,7 @@   -> CAFSet cafAnalData platform st = case st of    CmmStaticsRaw _lbl _data           -> Set.empty-   CmmStatics _lbl _itbl _ccs payload ->+   CmmStatics _lbl _itbl _ccs payload _extras ->        foldl' analyzeStatic Set.empty payload      where        analyzeStatic s lit =@@ -726,7 +736,9 @@ getLabelledBlocks :: Platform -> CmmDecl -> [(SomeLabel, CAFfyLabel)] getLabelledBlocks platform decl = case decl of    CmmData _ (CmmStaticsRaw _ _)    -> []-   CmmData _ (CmmStatics lbl _ _ _) -> [ (DeclLabel lbl, mkCAFfyLabel platform lbl) ]+   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@@ -771,29 +783,49 @@   graph :: [SCC (SomeLabel, CAFfyLabel, Set CAFfyLabel)]   graph = stronglyConnCompFromEdgedVerticesOrd nodes --- | Get @(Label, CAFfyLabel, Set CAFfyLabel)@ for each CAF block.--- The @Set CafLabel@ represents the set of CAFfy things which this CAF's code+-- | 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. ----- CAFs are treated differently from other labelled blocks:+--  - 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] -> [(Label, CAFfyLabel, Set CAFfyLabel)]-getCAFs platform cafEnv decls =-  [ (g_entry g, mkCAFfyLabel platform topLbl, cafs)-  | CmmProc top_info topLbl _ g <- decls-  , Just info <- [mapLookup (g_entry g) (info_tbls top_info)]-  , let rep = cit_rep info-  , isStaticRep rep && isThunkRep rep-  , Just cafs <- [mapLookup (g_entry g) cafEnv]-  ]+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]@@ -846,33 +878,34 @@ doSRTs   :: CmmConfig   -> ModuleSRTInfo+  -> DUniqSupply   -> [(CAFEnv, [CmmDecl])]   -- ^ 'CAFEnv's and 'CmmDecl's for code blocks-  -> [(CAFSet, CmmDecl)]     -- ^ static data decls and their 'CAFSet's-  -> IO (ModuleSRTInfo, [CmmDeclSRTs])+  -> [(CAFSet, CmmDataDecl)]     -- ^ static data decls and their 'CAFSet's+  -> IO (ModuleSRTInfo, DUniqSupply, [CmmDeclSRTs]) -doSRTs cfg moduleSRTInfo procs data_ = do-  us <- mkSplitUniqSupply 'u'+doSRTs cfg moduleSRTInfo dus0 procs data_ = do -  let profile = cmmProfile cfg+  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.-  let static_data_env :: DataCAFEnv+      static_data_env :: DataCAFEnv       static_data_env =         Map.fromList $         flip map data_ $         \(set, decl) ->           case decl of-            CmmProc{} ->-              pprPanic "doSRTs" (text "Proc in static data list:" <+> pdoc platform decl)+            CmmProc void _ _ _ -> case void of             CmmData _ static ->               case static of-                CmmStatics lbl _ _ _ -> (lbl, set)+                CmmStatics lbl _ _ _ _ -> (lbl, set)                 CmmStaticsRaw lbl _ -> (lbl, set)        (proc_envs, procss) = unzip procs       cafEnv = mapUnions proc_envs-      decls = map snd data_ ++ concat procss+      decls = map (cmmDataDeclCmmDecl . snd) data_ ++ concat procss       staticFuns = mapFromList (getStaticFuns decls)        platform = cmmPlatform cfg@@ -887,7 +920,7 @@     sccs :: [SCC (SomeLabel, CAFfyLabel, Set CAFfyLabel)]     sccs = {-# SCC depAnalSRTs #-} depAnalSRTs platform cafEnv static_data_env decls -    cafsWithSRTs :: [(Label, CAFfyLabel, Set CAFfyLabel)]+    cafsWithSRTs :: [(Maybe Label, CAFfyLabel, Set CAFfyLabel)]     cafsWithSRTs = getCAFs platform cafEnv decls    srtTraceM "doSRTs" (text "data:"            <+> pdoc platform data_ $$@@ -905,12 +938,12 @@           , CafInfo                -- Whether the group has CAF references           ) ] -      (result, moduleSRTInfo') =-        initUs_ us $+      ((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 [BlockLabel l] [cafLbl]+            oneSRT cfg staticFuns (map BlockLabel (maybeToList l)) [cafLbl]                    True{-is a CAF-} cafs static_data_env           return (nonCAFs ++ cAFs) @@ -943,11 +976,10 @@                       | otherwise ->                           -- Not an IdLabel, ignore                           srtMap-                    CmmProc{} ->-                      pprPanic "doSRTs" (text "Found Proc in static data list:" <+> pdoc platform decl))+                    CmmProc void _ _ _ -> case void of)                (moduleSRTMap moduleSRTInfo') data_--  return (moduleSRTInfo'{ moduleSRTMap = srtMap_w_raws }, srt_decls ++ decls')+      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.@@ -956,7 +988,7 @@   -> LabelMap CLabel -- ^ which blocks are static function entry points   -> DataCAFEnv      -- ^ static data   -> SCC (SomeLabel, CAFfyLabel, Set CAFfyLabel)-  -> StateT ModuleSRTInfo UniqSM+  -> StateT ModuleSRTInfo UniqDSM         ( [CmmDeclSRTs]          -- generated SRTs         , [(Label, CLabel)]      -- SRT fields for info tables         , [(Label, [SRTEntry])]  -- SRTs to attach to static functions@@ -1011,7 +1043,7 @@   -> Bool                       -- ^ True <=> this SRT is for a CAF   -> Set CAFfyLabel             -- ^ SRT for this set   -> DataCAFEnv                 -- Static data labels in this group-  -> StateT ModuleSRTInfo UniqSM+  -> StateT ModuleSRTInfo UniqDSM        ( [CmmDeclSRTs]                -- SRT objects we built        , [(Label, CLabel)]            -- SRT fields for these blocks' itbls        , [(Label, [SRTEntry])]        -- SRTs to attach to static functions@@ -1078,7 +1110,7 @@     -- 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 UniqSM ()+    updateSRTMap :: Maybe SRTEntry -> StateT ModuleSRTInfo UniqDSM ()     updateSRTMap srtEntry =       srtTrace "updateSRTMap"         (pdoc platform srtEntry <+> "isCAF:" <+> ppr isCAF <+>@@ -1137,7 +1169,8 @@           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.+          -- 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 @@ -1201,27 +1234,27 @@ buildSRTChain    :: Profile    -> [SRTEntry]-   -> UniqSM+   -> UniqDSM         ( [CmmDeclSRTs] -- The SRT object(s)         , SRTEntry      -- label to use in the info table         )-buildSRTChain _ [] = panic "buildSRT: empty" buildSRTChain profile cafSet =   case splitAt mAX_SRT_SIZE cafSet of+    ([], _) -> panic "buildSRT: empty"     (these, []) -> do       (decl,lbl) <- buildSRT profile these       return ([decl], lbl)-    (these,those) -> do-      (rest, rest_lbl) <- buildSRTChain profile (head these : those)-      (decl,lbl) <- buildSRT profile (rest_lbl : tail these)+    (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] -> UniqSM (CmmDeclSRTs, SRTEntry)+buildSRT :: Profile -> [SRTEntry] -> UniqDSM (CmmDeclSRTs, SRTEntry) buildSRT profile refs = do-  id <- getUniqueM+  id <- getUniqueDSM   let     lbl = mkSRTLabel id     platform = profilePlatform profile@@ -1232,6 +1265,7 @@         [] -- 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@@ -1247,10 +1281,10 @@ updInfoSRTs _ _ _ _ (CmmData s (CmmStaticsRaw lbl statics))   = [CmmData s (CmmStaticsRaw lbl statics)] -updInfoSRTs profile _ _ caffy (CmmData s (CmmStatics lbl itbl ccs payload))+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+    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 ]@@ -1280,7 +1314,7 @@             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+          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
GHC/Cmm/LRegSet.hs view
@@ -3,7 +3,6 @@  module GHC.Cmm.LRegSet (     LRegSet,-    LRegKey,      emptyLRegSet,     nullLRegSet,@@ -13,41 +12,52 @@     deleteFromLRegSet,     sizeLRegSet, -    plusLRegSet,+    unionLRegSet,+    unionsLRegSet,     elemsLRegSet   ) where  import GHC.Prelude import GHC.Types.Unique+import GHC.Types.Unique.Set import GHC.Cmm.Expr -import Data.IntSet as IntSet- -- Compact sets for membership tests of local variables. -type LRegSet = IntSet.IntSet-type LRegKey = Int+type LRegSet = UniqueSet +{-# INLINE emptyLRegSet #-} emptyLRegSet :: LRegSet-emptyLRegSet = IntSet.empty+emptyLRegSet = emptyUniqueSet +{-# INLINE nullLRegSet #-} nullLRegSet :: LRegSet -> Bool-nullLRegSet = IntSet.null+nullLRegSet = nullUniqueSet +{-# INLINE insertLRegSet #-} insertLRegSet :: LocalReg -> LRegSet -> LRegSet-insertLRegSet l = IntSet.insert (getKey (getUnique l))+insertLRegSet l = insertUniqueSet (getUnique l) +{-# INLINE elemLRegSet #-} elemLRegSet :: LocalReg -> LRegSet -> Bool-elemLRegSet l = IntSet.member (getKey (getUnique l))+elemLRegSet l = memberUniqueSet (getUnique l) +{-# INLINE deleteFromLRegSet #-} deleteFromLRegSet :: LRegSet -> LocalReg -> LRegSet-deleteFromLRegSet set reg = IntSet.delete (getKey . getUnique $ reg) set+deleteFromLRegSet set reg = deleteUniqueSet (getUnique reg) set -sizeLRegSet :: IntSet -> Int-sizeLRegSet = IntSet.size+{-# INLINE sizeLRegSet #-}+sizeLRegSet :: LRegSet -> Int+sizeLRegSet = sizeUniqueSet -plusLRegSet :: IntSet -> IntSet -> IntSet-plusLRegSet = IntSet.union+{-# INLINE unionLRegSet #-}+unionLRegSet :: LRegSet -> LRegSet -> LRegSet+unionLRegSet = unionUniqueSet -elemsLRegSet :: IntSet -> [Int]-elemsLRegSet = IntSet.toList+{-# INLINE unionsLRegSet #-}+unionsLRegSet :: [LRegSet] -> LRegSet+unionsLRegSet = unionsUniqueSet++{-# INLINE elemsLRegSet #-}+elemsLRegSet :: LRegSet -> [Unique]+elemsLRegSet = elemsUniqueSet
GHC/Cmm/LayoutStack.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE BangPatterns, RecordWildCards, GADTs #-}+{-# LANGUAGE RecordWildCards, GADTs #-} module GHC.Cmm.LayoutStack (        cmmLayoutStack, setInfoTableStackMap   ) where@@ -8,7 +8,7 @@ import GHC.Platform import GHC.Platform.Profile -import GHC.StgToCmm.Monad      ( newTemp  ) -- XXX layering violation+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 @@ -21,14 +21,13 @@ import GHC.Cmm.Liveness import GHC.Cmm.ProcPoint import GHC.Runtime.Heap.Layout-import GHC.Cmm.Dataflow.Block-import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow+import GHC.Cmm.Dataflow.Block import GHC.Cmm.Dataflow.Graph import GHC.Cmm.Dataflow.Label-import GHC.Types.Unique.Supply import GHC.Data.Maybe import GHC.Types.Unique.FM+import GHC.Types.Unique.DSM import GHC.Utils.Misc  import GHC.Utils.Outputable hiding ( isEmpty )@@ -37,6 +36,7 @@ import Control.Monad.Fix import Data.Array as Array import Data.List (nub)+import Data.List.NonEmpty ( NonEmpty (..) )  {- Note [Stack Layout]    ~~~~~~~~~~~~~~~~~~~@@ -236,7 +236,7 @@   cmmLayoutStack :: CmmConfig -> ProcPointSet -> ByteOff -> CmmGraph-               -> UniqSM (CmmGraph, LabelMap StackMap)+               -> UniqDSM (CmmGraph, LabelMap StackMap) cmmLayoutStack cfg procpoints entry_args                graph@(CmmGraph { g_entry = entry })   = do@@ -272,7 +272,7 @@         -> [CmmBlock]                    -- [in] blocks -       -> UniqSM+       -> UniqDSM           ( LabelMap StackMap           -- [out] stack maps           , ByteOff                     -- [out] Sp high water mark           , [CmmBlock]                  -- [out] new blocks@@ -283,12 +283,18 @@   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-                                               }+    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) @@ -341,7 +347,7 @@            this_sp_hwm | isGcJump last0 = 0                        | otherwise      = sp0 - sp_off -           hwm' = maximum (acc_hwm : this_sp_hwm : map sm_sp (mapElems out))+           hwm' = maximum (acc_hwm :| this_sp_hwm : map sm_sp (mapElems out))         go bs acc_stackmaps' hwm' (final_blocks ++ acc_blocks) @@ -350,7 +356,7 @@  -- Not foolproof, but GCFun is the culprit we most want to catch isGcJump :: CmmNode O C -> Bool-isGcJump (CmmCall { cml_target = CmmReg (CmmGlobal l) })+isGcJump (CmmCall { cml_target = CmmReg (CmmGlobal (GlobalRegUse l _)) })   = l == GCFun || l == GCEnter1 isGcJump _something_else = False @@ -368,7 +374,7 @@  collectContInfo :: [CmmBlock] -> (ByteOff, LabelMap ByteOff) collectContInfo blocks-  = (maximum ret_offs, mapFromList (catMaybes mb_argss))+  = (maximum (expectNonEmpty ret_offs), mapFromList (catMaybes mb_argss))  where   (mb_argss, ret_offs) = mapAndUnzip get_cont blocks @@ -437,7 +443,7 @@    -> LabelMap StackMap -> StackMap -> CmmTickScope    -> Block CmmNode O O    -> CmmNode O C-   -> UniqSM+   -> UniqDSM       ( [CmmNode O O]      -- nodes to go *before* the Sp adjustment       , ByteOff            -- amount to adjust Sp       , CmmNode O C        -- new last node@@ -503,7 +509,7 @@      -- proc point, we have to set up the stack to match what the proc      -- point is expecting.      ---     handleBranches :: UniqSM ( [CmmNode O O]+     handleBranches :: UniqDSM ( [CmmNode O O]                                 , ByteOff                                 , CmmNode O C                                 , [CmmBlock]@@ -536,7 +542,7 @@                  , mapFromList [ (l, sm) | (l,_,sm,_) <- pps ] )       -- For each successor of this block-     handleBranch :: BlockId -> UniqSM (BlockId, BlockId, StackMap, [CmmBlock])+     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.@@ -571,7 +577,7 @@  makeFixupBlock :: CmmConfig -> ByteOff -> Label -> StackMap                -> CmmTickScope -> [CmmNode O O]-               -> UniqSM (Label, [CmmBlock])+               -> UniqDSM (Label, [CmmBlock]) makeFixupBlock cfg sp0 l stack tscope assigs   | null assigs && sp0 == sm_sp stack = return (l, [])   | otherwise = do@@ -875,7 +881,7 @@     do_stk_unwinding_gen = cmmGenStackUnwindInstr cfg     adj block       | sp_off /= 0-      = block `blockSnoc` CmmAssign spReg (cmmOffset platform spExpr sp_off)+      = 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@@ -884,7 +890,7 @@       = CmmUnwind [(Sp, Just sp_unwind)] `blockCons` block       | otherwise       = block-      where sp_unwind = CmmRegOff spReg (sp0 - platformWordSizeInBytes platform)+      where sp_unwind = CmmRegOff (spReg platform) (sp0 - platformWordSizeInBytes platform)      -- Add unwind pseudo-instruction right after the Sp adjustment     -- if there is one.@@ -894,7 +900,7 @@       = block `blockSnoc` CmmUnwind [(Sp, Just sp_unwind)]       | otherwise       = block-      where sp_unwind = CmmRegOff spReg (sp0 - platformWordSizeInBytes platform - sp_off)+      where sp_unwind = CmmRegOff (spReg platform) (sp0 - platformWordSizeInBytes platform - sp_off)  {- Note [SP old/young offsets]    ~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -917,7 +923,7 @@ areaToSp :: Platform -> ByteOff -> ByteOff -> (Area -> StackLoc) -> CmmExpr -> CmmExpr  areaToSp platform sp_old _sp_hwm area_off (CmmStackSlot area n)-  = cmmOffset platform spExpr (sp_old - area_off 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)@@ -939,9 +945,9 @@ -- | Determine whether a stack check cannot fail. falseStackCheck :: [CmmExpr] -> Bool falseStackCheck [ CmmMachOp (MO_Sub _)-                      [ CmmRegOff (CmmGlobal Sp) x_off+                      [ CmmRegOff (CmmGlobal (GlobalRegUse Sp _)) x_off                       , CmmLit (CmmInt y_lit _)]-                , CmmReg (CmmGlobal SpLim)]+                , CmmReg (CmmGlobal (GlobalRegUse SpLim _))]   = fromIntegral x_off >= y_lit falseStackCheck _ = False @@ -1048,7 +1054,7 @@     -> LabelMap StackMap     -> BlockId     -> [CmmBlock]-    -> UniqSM [CmmBlock]+    -> UniqDSM [CmmBlock] insertReloadsAsNeeded platform procpoints final_stackmaps entry blocks =     toBlockList . fst <$>         rewriteCmmBwd liveLattice rewriteCC (ofBlockList entry blocks) mapEmpty@@ -1087,7 +1093,7 @@      [ CmmAssign (CmmLocal reg)                  -- This cmmOffset basically corresponds to manifesting                  -- @CmmStackSlot Old sp_off@, see Note [SP old/young offsets]-                 (CmmLoad (cmmOffset platform spExpr (sp_off - reg_off))+                 (CmmLoad (cmmOffset platform (spExpr platform) (sp_off - reg_off))                           (localRegType reg)                           NaturallyAligned)      | (reg, reg_off) <- stackSlotRegs stackmap@@ -1134,7 +1140,7 @@ that safe foreign call is replace by an unsafe one in the Cmm graph. -} -lowerSafeForeignCall :: Profile -> CmmBlock -> UniqSM CmmBlock+lowerSafeForeignCall :: Profile -> CmmBlock -> UniqDSM CmmBlock lowerSafeForeignCall profile block   | (entry@(CmmEntry _ tscp), middle, CmmForeignCall { .. }) <- blockSplit block   = do@@ -1142,7 +1148,7 @@     -- 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 platform baseReg)+    new_base <- newTemp (cmmRegType $ baseReg platform)     let (caller_save, caller_load) = callerSaveVolatileRegs platform     save_state_code <- saveThreadState profile     load_state_code <- loadThreadState profile@@ -1153,7 +1159,7 @@         resume  = mkMiddle (callResumeThread new_base id) <*>                   -- Assign the result to BaseReg: we                   -- might now have a different Capability!-                  mkAssign baseReg (CmmReg (CmmLocal new_base)) <*>+                  mkAssign (baseReg platform) (CmmReg (CmmLocal new_base)) <*>                   caller_load <*>                   load_state_code @@ -1168,7 +1174,7 @@         -- 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+                                         cmmLoadBWord platform (spExpr platform)                        , cml_cont      = Just succ                        , cml_args_regs = regs                        , cml_args      = widthInBytes (wordWidth platform)@@ -1181,7 +1187,7 @@                                copyout <*>                                mkLast jump, tscp) -    case toBlockList graph' of+    case toBlockList (removeDetermGraph graph') of       [one] -> let (_, middle', last) = blockSplit one                in return (blockJoin entry (middle `blockAppend` middle') last)       _ -> panic "lowerSafeForeignCall0"@@ -1193,7 +1199,7 @@ callSuspendThread :: Platform -> LocalReg -> Bool -> CmmNode O O callSuspendThread platform id intrbl =   CmmUnsafeForeignCall (PrimTarget MO_SuspendThread)-       [id] [baseExpr, mkIntExpr platform (fromEnum intrbl)]+       [id] [baseExpr platform, mkIntExpr platform (fromEnum intrbl)]  callResumeThread :: LocalReg -> LocalReg -> CmmNode O O callResumeThread new_base id =
GHC/Cmm/Lexer.hs view
@@ -1,886 +1,1087 @@ {-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-missing-signatures #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-}-{-# LINE 13 "_build/source-dist/ghc-9.4.2-src/ghc-9.4.2/compiler/GHC/Cmm/Lexer.x" #-}-module GHC.Cmm.Lexer (-   CmmToken(..), cmmlex,-  ) where--import GHC.Prelude--import GHC.Cmm.Expr--import GHC.Parser.Lexer-import GHC.Cmm.Parser.Monad-import GHC.Types.SrcLoc-import GHC.Types.Unique.FM-import GHC.Data.StringBuffer-import GHC.Data.FastString-import GHC.Parser.CharClass-import GHC.Parser.Errors.Types-import GHC.Parser.Errors.Ppr ()-import GHC.Utils.Error-import GHC.Utils.Misc---import TRACE--import Data.Word-import Data.Char-#if __GLASGOW_HASKELL__ >= 603-#include "ghcconfig.h"-#elif defined(__GLASGOW_HASKELL__)-#include "config.h"-#endif-#if __GLASGOW_HASKELL__ >= 503-import Data.Array-#else-import Array-#endif-#if __GLASGOW_HASKELL__ >= 503-import Data.Array.Base (unsafeAt)-import GHC.Exts-#else-import GlaExts-#endif-alex_tab_size :: Int-alex_tab_size = 8-alex_base :: AlexAddr-alex_base = AlexA#-  "\x01\x00\x00\x00\xc9\x00\x00\x00\x4e\x00\x00\x00\xb9\x00\x00\x00\x03\x01\x00\x00\xd6\x01\x00\x00\x88\xff\xff\xff\x00\x00\x00\x00\xdf\xff\xff\xff\x00\x00\x00\x00\xe8\xff\xff\xff\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\xa9\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x00\x00\x59\x00\x00\x00\xc2\x00\x00\x00\x56\x00\x00\x00\x60\x00\x00\x00\x62\x00\x00\x00\x6a\x00\x00\x00\x6f\x00\x00\x00\x6e\x00\x00\x00\x68\x00\x00\x00\x7c\x03\x00\x00\x4f\x04\x00\x00\x22\x05\x00\x00\xf5\x05\x00\x00\x3e\x00\x00\x00\xd1\x00\x00\x00\x00\x00\x00\x00\x3a\x01\x00\x00\x42\x00\x00\x00\xf6\xff\xff\xff\xe9\xff\xff\xff\xea\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\xc8\x06\x00\x00\x9b\x07\x00\x00\x6e\x08\x00\x00\x41\x09\x00\x00\x14\x0a\x00\x00\xe7\x0a\x00\x00\xba\x0b\x00\x00\x8d\x0c\x00\x00\x60\x0d\x00\x00\x33\x0e\x00\x00\x06\x0f\x00\x00\xd9\x0f\x00\x00\xac\x10\x00\x00\x7f\x11\x00\x00\x52\x12\x00\x00\x25\x13\x00\x00\xf8\x13\x00\x00\xcb\x14\x00\x00\x9e\x15\x00\x00\x71\x16\x00\x00\xf3\xff\xff\xff\x06\x00\x00\x00\x44\x01\x00\x00\x39\x17\x00\x00\x02\x00\x00\x00\xfb\xff\xff\xff\x0a\x00\x00\x00\x19\x17\x00\x00\x65\x00\x00\x00\x00\x00\x00\x00\x28\x01\x00\x00\xd3\x00\x00\x00\x00\x00\x00\x00\x9f\x17\x00\x00\xc0\x17\x00\x00\xbe\x17\x00\x00\x07\x02\x00\x00\x15\x02\x00\x00\xdd\x02\x00\x00\xf7\x17\x00\x00\x0e\x18\x00\x00\x30\x18\x00\x00\x48\x18\x00\x00\x81\x18\x00\x00\xc2\x18\x00\x00\x95\x19\x00\x00\x68\x1a\x00\x00\x3b\x1b\x00\x00\x0e\x1c\x00\x00\xe1\x1c\x00\x00\xb4\x1d\x00\x00\x87\x1e\x00\x00\x5a\x1f\x00\x00\x2d\x20\x00\x00\x00\x21\x00\x00\xd3\x21\x00\x00\xa6\x22\x00\x00\x79\x23\x00\x00\x4c\x24\x00\x00\x1f\x25\x00\x00\xf2\x25\x00\x00\xc5\x26\x00\x00\x98\x27\x00\x00\x6b\x28\x00\x00\x3e\x29\x00\x00\x11\x2a\x00\x00\xe4\x2a\x00\x00\xb7\x2b\x00\x00\x8a\x2c\x00\x00\x5d\x2d\x00\x00\x30\x2e\x00\x00\x03\x2f\x00\x00\xd6\x2f\x00\x00\xa9\x30\x00\x00\x7c\x31\x00\x00\x4f\x32\x00\x00\x17\x33\x00\x00\x16\x34\x00\x00\x16\x35\x00\x00\xe9\x35\x00\x00\xbc\x36\x00\x00\x8f\x37\x00\x00\x62\x38\x00\x00\x35\x39\x00\x00\x08\x3a\x00\x00\xdb\x3a\x00\x00\xae\x3b\x00\x00\x81\x3c\x00\x00\x54\x3d\x00\x00\x27\x3e\x00\x00\xfa\x3e\x00\x00\xcd\x3f\x00\x00\xa0\x40\x00\x00\x73\x41\x00\x00\x46\x42\x00\x00\x19\x43\x00\x00\xec\x43\x00\x00\xb4\x44\x00\x00\xb3\x45\x00\x00\xb2\x46\x00\x00\xb1\x47\x00\x00\xb0\x48\x00\x00\xaf\x49\x00\x00\xae\x4a\x00\x00\xad\x4b\x00\x00\xad\x4c\x00\x00\x80\x4d\x00\x00"#--alex_table :: AlexAddr-alex_table = AlexA#-  "\x00\x00\xff\xff\x5a\x00\xff\xff\x07\x00\x09\x00\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\x18\x00\x4f\x00\x4f\x00\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\x0a\x00\x52\x00\x2c\x00\x0b\x00\x17\x00\x08\x00\xff\xff\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x17\x00\x7c\x00\x17\x00\x5b\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x14\x00\x17\x00\x10\x00\x0c\x00\x12\x00\xff\xff\x0d\x00\x15\x00\x38\x00\x76\x00\x95\x00\x4e\x00\x7d\x00\xff\xff\x8f\x00\x11\x00\x0e\x00\xff\xff\x93\x00\x23\x00\x0f\x00\x13\x00\x7e\x00\x2e\x00\x98\x00\x77\x00\x6a\x00\x72\x00\x4f\x00\x2f\x00\x4f\x00\x4f\x00\x4f\x00\x17\x00\xff\xff\x17\x00\x17\x00\xff\xff\x17\x00\x2d\x00\xff\xff\x30\x00\x46\x00\x45\x00\x49\x00\x4b\x00\x4a\x00\xff\xff\x4d\x00\xff\xff\x40\x00\x4f\x00\x4e\x00\x50\x00\x2c\x00\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\x00\x00\x00\x00\x17\x00\x06\x00\x17\x00\x17\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1e\x00\x1b\x00\xff\xff\x1b\x00\x1b\x00\x1b\x00\x28\x00\x1d\x00\x1f\x00\x2a\x00\x1b\x00\xff\xff\x1b\x00\x1b\x00\x1b\x00\x19\x00\x1a\x00\x4f\x00\x00\x00\x4f\x00\x4f\x00\x4f\x00\x20\x00\xff\xff\x1b\x00\x22\x00\xff\xff\x21\x00\xff\xff\x1c\x00\x00\x00\x00\x00\x00\x00\x1b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4f\x00\x00\x00\x00\x00\x2c\x00\x00\x00\x4f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x29\x00\x00\x00\x00\x00\xff\xff\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\x4f\x00\x4f\x00\x4f\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2a\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x48\x00\x00\x00\x00\x00\x4f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1b\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x05\x00\x4f\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x2a\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x56\x00\x00\x00\x00\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x25\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x26\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x32\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x33\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x34\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x86\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x37\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x9b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x39\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x3d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x85\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9a\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x48\x00\x52\x00\x00\x00\x00\x00\x00\x00\x00\x00\x52\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x52\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x52\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x48\x00\x00\x00\x00\x00\x52\x00\x00\x00\x00\x00\x00\x00\x00\x00\x52\x00\x52\x00\x00\x00\x00\x00\x57\x00\x52\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x52\x00\x00\x00\x00\x00\x00\x00\x52\x00\x00\x00\x52\x00\x00\x00\x00\x00\x00\x00\x54\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x53\x00\xff\xff\x51\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x51\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x58\x00\x00\x00\x00\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4c\x00\x00\x00\x00\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x53\x00\x00\x00\x00\x00\x58\x00\x58\x00\x58\x00\x58\x00\x58\x00\x58\x00\x58\x00\x58\x00\x58\x00\x58\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x58\x00\x58\x00\x58\x00\x58\x00\x58\x00\x58\x00\x58\x00\x58\x00\x58\x00\x58\x00\x58\x00\x58\x00\x58\x00\x58\x00\x58\x00\x00\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x58\x00\x58\x00\x58\x00\x58\x00\x58\x00\x00\x00\x00\x00\x00\x00\x58\x00\x58\x00\x58\x00\x58\x00\x58\x00\x58\x00\x47\x00\x00\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x58\x00\x58\x00\x58\x00\x58\x00\x58\x00\x57\x00\x47\x00\x00\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5a\x00\x5a\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x00\x00\x47\x00\x00\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5a\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\x57\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x57\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x62\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x82\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x66\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x67\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x69\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x68\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x71\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x65\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x73\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x74\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x79\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x75\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x91\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x89\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x96\x00\x00\x00\x5d\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\xff\xff\x96\x00\x96\x00\x96\x00\x96\x00\x96\x00\x96\x00\x96\x00\x96\x00\x96\x00\x96\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x35\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x99\x00\x00\x00\x5d\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x83\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x87\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x31\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x92\x00\x00\x00\x5d\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\xff\xff\x92\x00\x92\x00\x92\x00\x92\x00\x92\x00\x92\x00\x92\x00\x92\x00\x92\x00\x92\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x92\x00\x00\x00\x5d\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x92\x00\x92\x00\x92\x00\x92\x00\x92\x00\x92\x00\x92\x00\x92\x00\x92\x00\x92\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x94\x00\x00\x00\x5d\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x94\x00\x00\x00\x5d\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x96\x00\x00\x00\x5d\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x96\x00\x96\x00\x96\x00\x96\x00\x96\x00\x96\x00\x96\x00\x96\x00\x96\x00\x96\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x97\x00\x00\x00\x5d\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x97\x00\x97\x00\x97\x00\x97\x00\x97\x00\x97\x00\x97\x00\x97\x00\x97\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x97\x00\x00\x00\x5d\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x97\x00\x97\x00\x97\x00\x97\x00\x97\x00\x97\x00\x97\x00\x97\x00\x97\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x99\x00\x00\x00\x5d\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x00\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"#--alex_check :: AlexAddr-alex_check = AlexA#-  "\xff\xff\x00\x00\x01\x00\x02\x00\x7c\x00\x26\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x3d\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x3d\x00\x3a\x00\x42\x00\x43\x00\x44\x00\x0a\x00\x46\x00\x0a\x00\x48\x00\x3c\x00\x3d\x00\x0a\x00\x4c\x00\x4d\x00\x3d\x00\x3e\x00\x50\x00\x69\x00\x52\x00\x53\x00\x54\x00\x55\x00\x09\x00\x6e\x00\x0b\x00\x0c\x00\x0d\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x0a\x00\x60\x00\x6c\x00\x0a\x00\x65\x00\x72\x00\x70\x00\x61\x00\x6d\x00\x67\x00\x0a\x00\x61\x00\x0a\x00\x6c\x00\x20\x00\x0a\x00\x22\x00\x23\x00\x0a\x00\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\x0a\x00\x0a\x00\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\x61\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x6e\x00\x72\x00\x67\x00\x01\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x61\x00\x69\x00\x09\x00\xff\xff\x0b\x00\x0c\x00\x0d\x00\x6d\x00\xd7\x00\x20\x00\x6c\x00\x0a\x00\x23\x00\x0a\x00\x70\x00\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\x23\x00\xff\xff\xa0\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x22\x00\xff\xff\xff\xff\xf7\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x00\x00\xff\xff\x02\x00\xff\xff\xff\xff\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x09\x00\x2f\x00\x0b\x00\x0c\x00\x0d\x00\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\x01\x00\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xa0\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xa0\x00\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xa0\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xa0\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\x01\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x01\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x2b\x00\x60\x00\x2d\x00\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\x63\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x53\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\x63\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x67\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x79\x00\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\x22\x00\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd7\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf7\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\x62\x00\xff\xff\xff\xff\x45\x00\x66\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\x72\x00\xff\xff\x74\x00\xff\xff\xff\xff\xff\xff\x78\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x01\x00\x00\x00\x22\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\xff\xff\xff\xff\x22\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x01\x00\xff\xff\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x01\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x01\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\xff\xff\xff\xff\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x45\x00\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x01\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x78\x00\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\x45\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x65\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x54\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\x64\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x77\x00\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\x43\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x53\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\x43\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x53\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xf7\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x00\x00\xff\xff\x02\x00\xff\xff\xff\xff\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x67\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x79\x00\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xf7\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x00\x00\xff\xff\x02\x00\xff\xff\xff\xff\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"#--alex_deflt :: AlexAddr-alex_deflt = AlexA#-  "\x5d\x00\xff\xff\xff\xff\x27\x00\x5d\x00\x5d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5d\x00\xff\xff\xff\xff\x19\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x27\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x27\x00\x27\x00\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\x50\x00\xff\xff\x52\x00\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\xff\xff\xff\xff\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\x5d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5d\x00\x5d\x00"#--alex_accept = listArray (0 :: Int, 155)-  [ AlexAccNone-  , AlexAccNone-  , AlexAccNone-  , AlexAcc 132-  , AlexAcc 131-  , AlexAcc 130-  , AlexAcc 129-  , AlexAcc 128-  , AlexAcc 127-  , AlexAcc 126-  , AlexAcc 125-  , AlexAcc 124-  , AlexAcc 123-  , AlexAcc 122-  , AlexAcc 121-  , AlexAcc 120-  , AlexAcc 119-  , AlexAcc 118-  , AlexAcc 117-  , AlexAcc 116-  , AlexAcc 115-  , AlexAcc 114-  , AlexAcc 113-  , AlexAcc 112-  , AlexAccSkip-  , AlexAcc 111-  , AlexAcc 110-  , AlexAccSkip-  , AlexAcc 109-  , AlexAcc 108-  , AlexAcc 107-  , AlexAcc 106-  , AlexAcc 105-  , AlexAccPred 104 (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAcc 103)-  , AlexAcc 102-  , AlexAcc 101-  , AlexAcc 100-  , AlexAcc 99-  , AlexAcc 98-  , AlexAcc 97-  , AlexAcc 96-  , AlexAcc 95-  , AlexAcc 94-  , AlexAccPred 93 (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAcc 92)-  , AlexAccPred 91 (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAccNone)-  , AlexAccNone-  , AlexAccNone-  , AlexAccNone-  , AlexAccPred 90 (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAccNone)-  , AlexAcc 89-  , AlexAcc 88-  , AlexAcc 87-  , AlexAcc 86-  , AlexAcc 85-  , AlexAcc 84-  , AlexAcc 83-  , AlexAcc 82-  , AlexAcc 81-  , AlexAcc 80-  , AlexAcc 79-  , AlexAcc 78-  , AlexAcc 77-  , AlexAcc 76-  , AlexAcc 75-  , AlexAcc 74-  , AlexAcc 73-  , AlexAcc 72-  , AlexAcc 71-  , AlexAcc 70-  , AlexAccNone-  , AlexAccNone-  , AlexAccNone-  , AlexAcc 69-  , AlexAccNone-  , AlexAccNone-  , AlexAccNone-  , AlexAccNone-  , AlexAccNone-  , AlexAccSkipPred (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAccNone)-  , AlexAccSkip-  , AlexAccNone-  , AlexAcc 68-  , AlexAccNone-  , AlexAccNone-  , AlexAccNone-  , AlexAcc 67-  , AlexAccNone-  , AlexAccNone-  , AlexAcc 66-  , AlexAccNone-  , AlexAcc 65-  , AlexAcc 64-  , AlexAcc 63-  , AlexAcc 62-  , AlexAcc 61-  , AlexAcc 60-  , AlexAcc 59-  , AlexAcc 58-  , AlexAcc 57-  , AlexAcc 56-  , AlexAcc 55-  , AlexAcc 54-  , AlexAcc 53-  , AlexAcc 52-  , AlexAcc 51-  , AlexAcc 50-  , AlexAcc 49-  , AlexAcc 48-  , AlexAcc 47-  , AlexAcc 46-  , AlexAcc 45-  , AlexAcc 44-  , AlexAcc 43-  , AlexAcc 42-  , AlexAcc 41-  , AlexAcc 40-  , AlexAcc 39-  , AlexAcc 38-  , AlexAcc 37-  , AlexAcc 36-  , AlexAcc 35-  , AlexAcc 34-  , AlexAcc 33-  , AlexAcc 32-  , AlexAcc 31-  , AlexAcc 30-  , AlexAcc 29-  , AlexAcc 28-  , AlexAcc 27-  , AlexAcc 26-  , AlexAcc 25-  , AlexAcc 24-  , AlexAcc 23-  , AlexAcc 22-  , AlexAcc 21-  , AlexAcc 20-  , AlexAcc 19-  , AlexAcc 18-  , AlexAcc 17-  , AlexAcc 16-  , AlexAcc 15-  , AlexAcc 14-  , AlexAcc 13-  , AlexAcc 12-  , AlexAcc 11-  , AlexAcc 10-  , AlexAcc 9-  , AlexAcc 8-  , AlexAcc 7-  , AlexAcc 6-  , AlexAcc 5-  , AlexAcc 4-  , AlexAcc 3-  , AlexAcc 2-  , AlexAcc 1-  , AlexAcc 0-  ]--alex_actions = array (0 :: Int, 133)-  [ (132,alex_action_5)-  , (131,alex_action_37)-  , (130,alex_action_18)-  , (129,alex_action_7)-  , (128,alex_action_17)-  , (127,alex_action_7)-  , (126,alex_action_16)-  , (125,alex_action_7)-  , (124,alex_action_15)-  , (123,alex_action_7)-  , (122,alex_action_14)-  , (121,alex_action_13)-  , (120,alex_action_12)-  , (119,alex_action_7)-  , (118,alex_action_11)-  , (117,alex_action_7)-  , (116,alex_action_10)-  , (115,alex_action_7)-  , (114,alex_action_9)-  , (113,alex_action_8)-  , (112,alex_action_7)-  , (111,alex_action_5)-  , (110,alex_action_5)-  , (109,alex_action_5)-  , (108,alex_action_5)-  , (107,alex_action_5)-  , (106,alex_action_5)-  , (105,alex_action_5)-  , (104,alex_action_2)-  , (103,alex_action_5)-  , (102,alex_action_5)-  , (101,alex_action_37)-  , (100,alex_action_37)-  , (99,alex_action_37)-  , (98,alex_action_37)-  , (97,alex_action_5)-  , (96,alex_action_5)-  , (95,alex_action_4)-  , (94,alex_action_3)-  , (93,alex_action_2)-  , (92,alex_action_5)-  , (91,alex_action_2)-  , (90,alex_action_2)-  , (89,alex_action_37)-  , (88,alex_action_37)-  , (87,alex_action_37)-  , (86,alex_action_37)-  , (85,alex_action_37)-  , (84,alex_action_37)-  , (83,alex_action_37)-  , (82,alex_action_37)-  , (81,alex_action_37)-  , (80,alex_action_37)-  , (79,alex_action_37)-  , (78,alex_action_37)-  , (77,alex_action_37)-  , (76,alex_action_37)-  , (75,alex_action_37)-  , (74,alex_action_37)-  , (73,alex_action_37)-  , (72,alex_action_37)-  , (71,alex_action_37)-  , (70,alex_action_37)-  , (69,alex_action_41)-  , (68,alex_action_42)-  , (67,alex_action_41)-  , (66,alex_action_40)-  , (65,alex_action_39)-  , (64,alex_action_39)-  , (63,alex_action_38)-  , (62,alex_action_37)-  , (61,alex_action_37)-  , (60,alex_action_37)-  , (59,alex_action_37)-  , (58,alex_action_37)-  , (57,alex_action_37)-  , (56,alex_action_37)-  , (55,alex_action_37)-  , (54,alex_action_37)-  , (53,alex_action_37)-  , (52,alex_action_37)-  , (51,alex_action_37)-  , (50,alex_action_37)-  , (49,alex_action_37)-  , (48,alex_action_37)-  , (47,alex_action_37)-  , (46,alex_action_37)-  , (45,alex_action_37)-  , (44,alex_action_37)-  , (43,alex_action_37)-  , (42,alex_action_37)-  , (41,alex_action_37)-  , (40,alex_action_37)-  , (39,alex_action_37)-  , (38,alex_action_37)-  , (37,alex_action_37)-  , (36,alex_action_37)-  , (35,alex_action_37)-  , (34,alex_action_37)-  , (33,alex_action_37)-  , (32,alex_action_37)-  , (31,alex_action_37)-  , (30,alex_action_37)-  , (29,alex_action_37)-  , (28,alex_action_36)-  , (27,alex_action_37)-  , (26,alex_action_37)-  , (25,alex_action_37)-  , (24,alex_action_35)-  , (23,alex_action_37)-  , (22,alex_action_34)-  , (21,alex_action_33)-  , (20,alex_action_32)-  , (19,alex_action_37)-  , (18,alex_action_31)-  , (17,alex_action_30)-  , (16,alex_action_29)-  , (15,alex_action_37)-  , (14,alex_action_37)-  , (13,alex_action_28)-  , (12,alex_action_37)-  , (11,alex_action_27)-  , (10,alex_action_26)-  , (9,alex_action_25)-  , (8,alex_action_37)-  , (7,alex_action_24)-  , (6,alex_action_37)-  , (5,alex_action_23)-  , (4,alex_action_22)-  , (3,alex_action_37)-  , (2,alex_action_21)-  , (1,alex_action_20)-  , (0,alex_action_19)-  ]--{-# LINE 129 "_build/source-dist/ghc-9.4.2-src/ghc-9.4.2/compiler/GHC/Cmm/Lexer.x" #-}-data CmmToken-  = CmmT_SpecChar  Char-  | CmmT_DotDot-  | CmmT_DoubleColon-  | CmmT_Shr-  | CmmT_Shl-  | CmmT_Ge-  | CmmT_Le-  | CmmT_Eq-  | CmmT_Ne-  | CmmT_BoolAnd-  | CmmT_BoolOr-  | CmmT_CLOSURE-  | CmmT_INFO_TABLE-  | CmmT_INFO_TABLE_RET-  | CmmT_INFO_TABLE_FUN-  | CmmT_INFO_TABLE_CONSTR-  | CmmT_INFO_TABLE_SELECTOR-  | CmmT_else-  | CmmT_export-  | CmmT_section-  | CmmT_goto-  | CmmT_if-  | CmmT_call-  | CmmT_jump-  | CmmT_foreign-  | CmmT_never-  | CmmT_prim-  | CmmT_reserve-  | CmmT_return-  | CmmT_returns-  | CmmT_import-  | CmmT_switch-  | CmmT_case-  | CmmT_default-  | CmmT_push-  | CmmT_unwind-  | CmmT_bits8-  | CmmT_bits16-  | CmmT_bits32-  | CmmT_bits64-  | CmmT_bits128-  | CmmT_bits256-  | CmmT_bits512-  | CmmT_float32-  | CmmT_float64-  | CmmT_gcptr-  | CmmT_GlobalReg GlobalReg-  | CmmT_Name      FastString-  | CmmT_String    String-  | CmmT_Int       Integer-  | CmmT_Float     Rational-  | CmmT_EOF-  | CmmT_False-  | CmmT_True-  | CmmT_likely-  deriving (Show)---- -------------------------------------------------------------------------------- Lexer actions--type Action = PsSpan -> StringBuffer -> Int -> PD (PsLocated CmmToken)--begin :: Int -> Action-begin code _span _str _len = do liftP (pushLexState code); lexToken--pop :: Action-pop _span _buf _len = liftP popLexState >> lexToken--special_char :: Action-special_char span buf _len = return (L span (CmmT_SpecChar (currentChar buf)))--kw :: CmmToken -> Action-kw tok span _buf _len = return (L span tok)--global_regN :: (Int -> GlobalReg) -> Action-global_regN con span buf len-  = return (L span (CmmT_GlobalReg (con (fromIntegral n))))-  where buf' = stepOn buf-        n = parseUnsignedInteger buf' (len-1) 10 octDecDigit--global_reg :: GlobalReg -> Action-global_reg r span _buf _len = return (L span (CmmT_GlobalReg r))--strtoken :: (String -> CmmToken) -> Action-strtoken f span buf len =-  return (L span $! (f $! lexemeToString buf len))--name :: Action-name span buf len =-  case lookupUFM reservedWordsFM fs of-        Just tok -> return (L span tok)-        Nothing  -> return (L span (CmmT_Name fs))-  where-        fs = lexemeToFastString buf len--reservedWordsFM = listToUFM $-        map (\(x, y) -> (mkFastString x, y)) [-        ( "CLOSURE",            CmmT_CLOSURE ),-        ( "INFO_TABLE",         CmmT_INFO_TABLE ),-        ( "INFO_TABLE_RET",     CmmT_INFO_TABLE_RET ),-        ( "INFO_TABLE_FUN",     CmmT_INFO_TABLE_FUN ),-        ( "INFO_TABLE_CONSTR",  CmmT_INFO_TABLE_CONSTR ),-        ( "INFO_TABLE_SELECTOR",CmmT_INFO_TABLE_SELECTOR ),-        ( "else",               CmmT_else ),-        ( "export",             CmmT_export ),-        ( "section",            CmmT_section ),-        ( "goto",               CmmT_goto ),-        ( "if",                 CmmT_if ),-        ( "call",               CmmT_call ),-        ( "jump",               CmmT_jump ),-        ( "foreign",            CmmT_foreign ),-        ( "never",              CmmT_never ),-        ( "prim",               CmmT_prim ),-        ( "reserve",            CmmT_reserve ),-        ( "return",             CmmT_return ),-        ( "returns",            CmmT_returns ),-        ( "import",             CmmT_import ),-        ( "switch",             CmmT_switch ),-        ( "case",               CmmT_case ),-        ( "default",            CmmT_default ),-        ( "push",               CmmT_push ),-        ( "unwind",             CmmT_unwind ),-        ( "bits8",              CmmT_bits8 ),-        ( "bits16",             CmmT_bits16 ),-        ( "bits32",             CmmT_bits32 ),-        ( "bits64",             CmmT_bits64 ),-        ( "bits128",            CmmT_bits128 ),-        ( "bits256",            CmmT_bits256 ),-        ( "bits512",            CmmT_bits512 ),-        ( "float32",            CmmT_float32 ),-        ( "float64",            CmmT_float64 ),--- New forms-        ( "b8",                 CmmT_bits8 ),-        ( "b16",                CmmT_bits16 ),-        ( "b32",                CmmT_bits32 ),-        ( "b64",                CmmT_bits64 ),-        ( "b128",               CmmT_bits128 ),-        ( "b256",               CmmT_bits256 ),-        ( "b512",               CmmT_bits512 ),-        ( "f32",                CmmT_float32 ),-        ( "f64",                CmmT_float64 ),-        ( "gcptr",              CmmT_gcptr ),-        ( "likely",             CmmT_likely),-        ( "True",               CmmT_True  ),-        ( "False",              CmmT_False )-        ]--tok_decimal span buf len-  = return (L span (CmmT_Int  $! parseUnsignedInteger buf len 10 octDecDigit))--tok_octal span buf len-  = return (L span (CmmT_Int  $! parseUnsignedInteger (offsetBytes 1 buf) (len-1) 8 octDecDigit))--tok_hexadecimal span buf len-  = return (L span (CmmT_Int  $! parseUnsignedInteger (offsetBytes 2 buf) (len-2) 16 hexDigit))--tok_float str = CmmT_Float $! readRational str--tok_string str = CmmT_String (read str)-                 -- urk, not quite right, but it'll do for now---- -------------------------------------------------------------------------------- Line pragmas--setLine :: Int -> Action-setLine code (PsSpan span _) buf len = do-  let line = parseUnsignedInteger buf len 10 octDecDigit-  liftP $ do-    setSrcLoc (mkRealSrcLoc (srcSpanFile span) (fromIntegral line - 1) 1)-          -- subtract one: the line number refers to the *following* line-    -- trace ("setLine "  ++ show line) $ do-    popLexState >> pushLexState code-  lexToken--setFile :: Int -> Action-setFile code (PsSpan span _) buf len = do-  let file = lexemeToFastString (stepOn buf) (len-2)-  liftP $ do-    setSrcLoc (mkRealSrcLoc file (srcSpanEndLine span) (srcSpanEndCol span))-    popLexState >> pushLexState code-  lexToken---- -------------------------------------------------------------------------------- This is the top-level function: called from the parser each time a--- new token is to be read from the input.--cmmlex :: (Located CmmToken -> PD a) -> PD a-cmmlex cont = do-  (L span tok) <- lexToken-  --trace ("token: " ++ show tok) $ do-  cont (L (mkSrcSpanPs span) tok)--lexToken :: PD (PsLocated CmmToken)-lexToken = do-  inp@(loc1,buf) <- getInput-  sc <- liftP getLexState-  case alexScan inp sc of-    AlexEOF -> do let span = mkPsSpan loc1 loc1-                  liftP (setLastToken span 0)-                  return (L span CmmT_EOF)-    AlexError (loc2,_) ->-      let msg srcLoc = mkPlainErrorMsgEnvelope srcLoc PsErrCmmLexer-      in liftP $ failLocMsgP (psRealLoc loc1) (psRealLoc loc2) msg-    AlexSkip inp2 _ -> do-        setInput inp2-        lexToken-    AlexToken inp2@(end,_buf2) len t -> do-        setInput inp2-        let span = mkPsSpan loc1 end-        span `seq` liftP (setLastToken span len)-        t span buf len---- -------------------------------------------------------------------------------- Monad stuff---- Stuff that Alex needs to know about our input type:-type AlexInput = (PsLoc,StringBuffer)--alexInputPrevChar :: AlexInput -> Char-alexInputPrevChar (_,s) = prevChar s '\n'---- backwards compatibility for Alex 2.x-alexGetChar :: AlexInput -> Maybe (Char,AlexInput)-alexGetChar inp = case alexGetByte inp of-                    Nothing    -> Nothing-                    Just (b,i) -> c `seq` Just (c,i)-                       where c = chr $ fromIntegral b--alexGetByte :: AlexInput -> Maybe (Word8,AlexInput)-alexGetByte (loc,s)-  | atEnd s   = Nothing-  | otherwise = b `seq` loc' `seq` s' `seq` Just (b, (loc', s'))-  where c    = currentChar s-        b    = fromIntegral $ ord $ c-        loc' = advancePsLoc loc c-        s'   = stepOn s--getInput :: PD AlexInput-getInput = PD $ \_ _ s@PState{ loc=l, buffer=b } -> POk s (l,b)--setInput :: AlexInput -> PD ()-setInput (l,b) = PD $ \_ _ s -> POk s{ loc=l, buffer=b } ()--line_prag,line_prag1,line_prag2 :: Int-line_prag = 1-line_prag1 = 2-line_prag2 = 3-alex_action_2 = begin line_prag-alex_action_3 = setLine line_prag1-alex_action_4 = setFile line_prag2-alex_action_5 = pop-alex_action_7 = special_char-alex_action_8 = kw CmmT_DotDot-alex_action_9 = kw CmmT_DoubleColon-alex_action_10 = kw CmmT_Shr-alex_action_11 = kw CmmT_Shl-alex_action_12 = kw CmmT_Ge-alex_action_13 = kw CmmT_Le-alex_action_14 = kw CmmT_Eq-alex_action_15 = kw CmmT_Ne-alex_action_16 = kw CmmT_BoolAnd-alex_action_17 = kw CmmT_BoolOr-alex_action_18 = kw CmmT_True-alex_action_19 = kw CmmT_False-alex_action_20 = kw CmmT_likely-alex_action_21 = global_regN (\n -> VanillaReg n VGcPtr)-alex_action_22 = global_regN (\n -> VanillaReg n VNonGcPtr)-alex_action_23 = global_regN FloatReg-alex_action_24 = global_regN DoubleReg-alex_action_25 = global_regN LongReg-alex_action_26 = global_reg Sp-alex_action_27 = global_reg SpLim-alex_action_28 = global_reg Hp-alex_action_29 = global_reg HpLim-alex_action_30 = global_reg CCCS-alex_action_31 = global_reg CurrentTSO-alex_action_32 = global_reg CurrentNursery-alex_action_33 = global_reg HpAlloc-alex_action_34 = global_reg BaseReg-alex_action_35 = global_reg MachSp-alex_action_36 = global_reg UnwindReturnReg-alex_action_37 = name-alex_action_38 = tok_octal-alex_action_39 = tok_decimal-alex_action_40 = tok_hexadecimal-alex_action_41 = strtoken tok_float-alex_action_42 = strtoken tok_string--#define ALEX_GHC 1-#define ALEX_LATIN1 1--- -------------------------------------------------------------------------------- ALEX TEMPLATE------ This code is in the PUBLIC DOMAIN; you may copy it freely and use--- it for any purpose whatsoever.---- -------------------------------------------------------------------------------- INTERNALS and main scanner engine--#ifdef ALEX_GHC-#  define ILIT(n) n#-#  define IBOX(n) (I# (n))-#  define FAST_INT Int#--- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex.-#  if __GLASGOW_HASKELL__ > 706-#    define GTE(n,m) (tagToEnum# (n >=# m))-#    define EQ(n,m) (tagToEnum# (n ==# m))-#  else-#    define GTE(n,m) (n >=# m)-#    define EQ(n,m) (n ==# m)-#  endif-#  define PLUS(n,m) (n +# m)-#  define MINUS(n,m) (n -# m)-#  define TIMES(n,m) (n *# m)-#  define NEGATE(n) (negateInt# (n))-#  define IF_GHC(x) (x)-#else-#  define ILIT(n) (n)-#  define IBOX(n) (n)-#  define FAST_INT Int-#  define GTE(n,m) (n >= m)-#  define EQ(n,m) (n == m)-#  define PLUS(n,m) (n + m)-#  define MINUS(n,m) (n - m)-#  define TIMES(n,m) (n * m)-#  define NEGATE(n) (negate (n))-#  define IF_GHC(x)-#endif--#ifdef ALEX_GHC-data AlexAddr = AlexA# Addr#--- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex.-#if __GLASGOW_HASKELL__ < 503-uncheckedShiftL# = shiftL#-#endif--{-# INLINE alexIndexInt16OffAddr #-}-alexIndexInt16OffAddr :: AlexAddr -> Int# -> Int#-alexIndexInt16OffAddr (AlexA# arr) off =-#ifdef WORDS_BIGENDIAN-  narrow16Int# i-  where-        i    = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low)-        high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#)))-        low  = int2Word# (ord# (indexCharOffAddr# arr off'))-        off' = off *# 2#-#else-#if __GLASGOW_HASKELL__ >= 901-  int16ToInt#-#endif-    (indexInt16OffAddr# arr off)-#endif-#else-alexIndexInt16OffAddr arr off = arr ! off-#endif--#ifdef ALEX_GHC-{-# INLINE alexIndexInt32OffAddr #-}-alexIndexInt32OffAddr :: AlexAddr -> Int# -> Int#-alexIndexInt32OffAddr (AlexA# arr) off =-#ifdef WORDS_BIGENDIAN-  narrow32Int# i-  where-   i    = word2Int# ((b3 `uncheckedShiftL#` 24#) `or#`-                     (b2 `uncheckedShiftL#` 16#) `or#`-                     (b1 `uncheckedShiftL#` 8#) `or#` b0)-   b3   = int2Word# (ord# (indexCharOffAddr# arr (off' +# 3#)))-   b2   = int2Word# (ord# (indexCharOffAddr# arr (off' +# 2#)))-   b1   = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#)))-   b0   = int2Word# (ord# (indexCharOffAddr# arr off'))-   off' = off *# 4#-#else-#if __GLASGOW_HASKELL__ >= 901-  int32ToInt#-#endif-    (indexInt32OffAddr# arr off)-#endif-#else-alexIndexInt32OffAddr arr off = arr ! off-#endif--#ifdef ALEX_GHC--#if __GLASGOW_HASKELL__ < 503-quickIndex arr i = arr ! i-#else--- GHC >= 503, unsafeAt is available from Data.Array.Base.-quickIndex = unsafeAt-#endif-#else-quickIndex arr i = arr ! i-#endif---- -------------------------------------------------------------------------------- Main lexing routines--data AlexReturn a-  = AlexEOF-  | AlexError  !AlexInput-  | AlexSkip   !AlexInput !Int-  | AlexToken  !AlexInput !Int a---- alexScan :: AlexInput -> StartCode -> AlexReturn a-alexScan input__ IBOX(sc)-  = alexScanUser undefined input__ IBOX(sc)--alexScanUser user__ input__ IBOX(sc)-  = case alex_scan_tkn user__ input__ ILIT(0) input__ sc AlexNone of-  (AlexNone, input__') ->-    case alexGetByte input__ of-      Nothing ->-#ifdef ALEX_DEBUG-                                   trace ("End of input.") $-#endif-                                   AlexEOF-      Just _ ->-#ifdef ALEX_DEBUG-                                   trace ("Error.") $-#endif-                                   AlexError input__'--  (AlexLastSkip input__'' len, _) ->-#ifdef ALEX_DEBUG-    trace ("Skipping.") $-#endif-    AlexSkip input__'' len--  (AlexLastAcc k input__''' len, _) ->-#ifdef ALEX_DEBUG-    trace ("Accept.") $-#endif-    AlexToken input__''' len (alex_actions ! k)----- Push the input through the DFA, remembering the most recent accepting--- state it encountered.--alex_scan_tkn user__ orig_input len input__ s last_acc =-  input__ `seq` -- strict in the input-  let-  new_acc = (check_accs (alex_accept `quickIndex` IBOX(s)))-  in-  new_acc `seq`-  case alexGetByte input__ of-     Nothing -> (new_acc, input__)-     Just (c, new_input) ->-#ifdef ALEX_DEBUG-      trace ("State: " ++ show IBOX(s) ++ ", char: " ++ show c) $-#endif-      case fromIntegral c of { IBOX(ord_c) ->-        let-                base   = alexIndexInt32OffAddr alex_base s-                offset = PLUS(base,ord_c)-                check  = alexIndexInt16OffAddr alex_check offset--                new_s = if GTE(offset,ILIT(0)) && EQ(check,ord_c)-                          then alexIndexInt16OffAddr alex_table offset-                          else alexIndexInt16OffAddr alex_deflt s-        in-        case new_s of-            ILIT(-1) -> (new_acc, input__)-                -- on an error, we want to keep the input *before* the-                -- character that failed, not after.-            _ -> alex_scan_tkn user__ orig_input-#ifdef ALEX_LATIN1-                   PLUS(len,ILIT(1))-                   -- issue 119: in the latin1 encoding, *each* byte is one character-#else-                   (if c < 0x80 || c >= 0xC0 then PLUS(len,ILIT(1)) else len)-                   -- note that the length is increased ONLY if this is the 1st byte in a char encoding)-#endif-                   new_input new_s new_acc-      }-  where-        check_accs (AlexAccNone) = last_acc-        check_accs (AlexAcc a  ) = AlexLastAcc a input__ IBOX(len)-        check_accs (AlexAccSkip) = AlexLastSkip  input__ IBOX(len)-#ifndef ALEX_NOPRED-        check_accs (AlexAccPred a predx rest)-           | predx user__ orig_input IBOX(len) input__-           = AlexLastAcc a input__ IBOX(len)-           | otherwise-           = check_accs rest-        check_accs (AlexAccSkipPred predx rest)-           | predx user__ orig_input IBOX(len) input__-           = AlexLastSkip input__ IBOX(len)-           | otherwise-           = check_accs rest-#endif--data AlexLastAcc-  = AlexNone-  | AlexLastAcc !Int !AlexInput !Int-  | AlexLastSkip     !AlexInput !Int--data AlexAcc user-  = AlexAccNone-  | AlexAcc Int-  | AlexAccSkip-#ifndef ALEX_NOPRED-  | AlexAccPred Int (AlexAccPred user) (AlexAcc user)-  | AlexAccSkipPred (AlexAccPred user) (AlexAcc user)--type AlexAccPred user = user -> AlexInput -> Int -> AlexInput -> Bool---- -------------------------------------------------------------------------------- Predicates on a rule--alexAndPred p1 p2 user__ in1 len in2-  = p1 user__ in1 len in2 && p2 user__ in1 len in2----alexPrevCharIsPred :: Char -> AlexAccPred _-alexPrevCharIs c _ input__ _ _ = c == alexInputPrevChar input__--alexPrevCharMatches f _ input__ _ _ = f (alexInputPrevChar input__)----alexPrevCharIsOneOfPred :: Array Char Bool -> AlexAccPred _-alexPrevCharIsOneOf arr _ input__ _ _ = arr ! alexInputPrevChar input__----alexRightContext :: Int -> AlexAccPred _-alexRightContext IBOX(sc) user__ _ _ input__ =-     case alex_scan_tkn user__ input__ ILIT(0) input__ sc AlexNone of-          (AlexNone, _) -> False-          _ -> True-        -- TODO: there's no need to find the longest-        -- match when checking the right context, just-        -- the first match will do.-#endif+{-# LINE 13 "_build/source-dist/ghc-9.14.1-src/ghc-9.14.1/compiler/GHC/Cmm/Lexer.x" #-}+module GHC.Cmm.Lexer (+   CmmToken(..), cmmlex,+  ) where++import GHC.Prelude++import GHC.Cmm.Expr+import GHC.Cmm.Reg (GlobalArgRegs(..))++import GHC.Parser.Lexer+import GHC.Cmm.Parser.Monad+import GHC.Types.SrcLoc+import GHC.Types.Unique.FM+import GHC.Data.StringBuffer+import GHC.Data.FastString+import GHC.Parser.CharClass+import GHC.Parser.Errors.Types+import GHC.Parser.Errors.Ppr ()+import GHC.Platform+import GHC.Utils.Error+import GHC.Utils.Misc+--import TRACE++import Data.Word+import Data.Char+#if __GLASGOW_HASKELL__ >= 603+#include "ghcconfig.h"+#elif defined(__GLASGOW_HASKELL__)+#include "config.h"+#endif+#if __GLASGOW_HASKELL__ >= 503+import Data.Array+#else+import Array+#endif+#if __GLASGOW_HASKELL__ >= 503+import Data.Array.Base (unsafeAt)+import GHC.Exts+#else+import GlaExts+#endif+alex_tab_size :: Int+alex_tab_size = 8+alex_base :: AlexAddr+alex_base = AlexA#+  "\x01\x00\x00\x00\xc9\x00\x00\x00\x57\x00\x00\x00\xb9\x00\x00\x00\x2a\x01\x00\x00\x29\x02\x00\x00\x28\x03\x00\x00\x27\x04\x00\x00\x26\x05\x00\x00\x25\x06\x00\x00\x25\x07\x00\x00\xf8\x07\x00\x00\xcb\x08\x00\x00\x9e\x09\x00\x00\x93\xff\xff\xff\xa6\xff\xff\xff\xc2\xff\xff\xff\xce\xff\xff\xff\xd2\xff\xff\xff\x00\x00\x00\x00\xe1\xff\xff\xff\xd7\xff\xff\xff\xe6\xff\xff\xff\x00\x00\x00\x00\xe9\xff\xff\xff\xde\xff\xff\xff\xdb\xff\xff\xff\xef\xff\xff\xff\xe0\xff\xff\xff\x02\x00\x00\x00\x00\x00\x00\x00\x68\x00\x00\x00\x03\x00\x00\x00\xf9\xff\xff\xff\x05\x00\x00\x00\xf1\xff\xff\xff\x06\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\xf2\xff\xff\xff\x00\x00\x00\x00\x49\x00\x00\x00\x00\x00\x00\x00\x33\x00\x00\x00\x00\x00\x00\x00\x34\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x00\x00\x00\x00\x00\x00\x37\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x71\x0a\x00\x00\x00\x00\x00\x00\xd6\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x71\x00\x00\x00\xc4\x00\x00\x00\xb7\x00\x00\x00\xbd\x00\x00\x00\xbe\x00\x00\x00\xc2\x00\x00\x00\xc1\x00\x00\x00\xd3\x00\x00\x00\xd4\x00\x00\x00\x44\x0b\x00\x00\x17\x0c\x00\x00\xea\x0c\x00\x00\xbd\x0d\x00\x00\x90\x0e\x00\x00\x63\x0f\x00\x00\x36\x10\x00\x00\x09\x11\x00\x00\xdc\x11\x00\x00\xaf\x12\x00\x00\x82\x13\x00\x00\x55\x14\x00\x00\x28\x15\x00\x00\xfb\x15\x00\x00\xce\x16\x00\x00\xa1\x17\x00\x00\x74\x18\x00\x00\x47\x19\x00\x00\x1a\x1a\x00\x00\xd7\x00\x00\x00\xd9\x00\x00\x00\xe1\x00\x00\x00\x00\x00\x00\x00\xe4\x00\x00\x00\xd8\x00\x00\x00\x7a\x00\x00\x00\x6a\x00\x00\x00\x72\x00\x00\x00\x82\x00\x00\x00\xed\x1a\x00\x00\xc0\x1b\x00\x00\x93\x1c\x00\x00\x66\x1d\x00\x00\x39\x1e\x00\x00\x0c\x1f\x00\x00\xdf\x1f\x00\x00\xb2\x20\x00\x00\x85\x21\x00\x00\x58\x22\x00\x00\x2b\x23\x00\x00\xfe\x23\x00\x00\xd1\x24\x00\x00\xa4\x25\x00\x00\x77\x26\x00\x00\x4a\x27\x00\x00\x1d\x28\x00\x00\xf0\x28\x00\x00\xc3\x29\x00\x00\x96\x2a\x00\x00\x00\x00\x00\x00\x76\x00\x00\x00\x8c\x00\x00\x00\x03\x01\x00\x00\x84\x01\x00\x00\x87\x00\x00\x00\x83\x00\x00\x00\x8e\x00\x00\x00\x34\x2b\x00\x00\xe7\x00\x00\x00\x00\x00\x00\x00\x46\x01\x00\x00\x8d\x00\x00\x00\x00\x00\x00\x00\xa4\x02\x00\x00\xa3\x03\x00\x00\x7d\x2b\x00\x00\xa4\x01\x00\x00\x00\x02\x00\x00\x81\x04\x00\x00\xa1\x04\x00\x00\x96\x2b\x00\x00\xbc\x2b\x00\x00\xfd\x04\x00\x00\xd5\x2b\x00\x00\x80\x05\x00\x00\x49\x2c\x00\x00\x1c\x2d\x00\x00\xef\x2d\x00\x00\xc2\x2e\x00\x00\x95\x2f\x00\x00\x68\x30\x00\x00\x3b\x31\x00\x00\x0e\x32\x00\x00\xe1\x32\x00\x00\xb4\x33\x00\x00\x87\x34\x00\x00\x5a\x35\x00\x00\x2d\x36\x00\x00\x00\x37\x00\x00\xd3\x37\x00\x00\xa6\x38\x00\x00\x79\x39\x00\x00\x4c\x3a\x00\x00\x1f\x3b\x00\x00\xf2\x3b\x00\x00\xc5\x3c\x00\x00\x98\x3d\x00\x00\x6b\x3e\x00\x00\x3e\x3f\x00\x00\x11\x40\x00\x00\xe4\x40\x00\x00\xb7\x41\x00\x00\x8a\x42\x00\x00\x5d\x43\x00\x00\x30\x44\x00\x00\x03\x45\x00\x00\xd6\x45\x00\x00\x9e\x46\x00\x00\x9d\x47\x00\x00\x9d\x48\x00\x00\x70\x49\x00\x00\x43\x4a\x00\x00\x16\x4b\x00\x00\xe9\x4b\x00\x00\xbc\x4c\x00\x00\x8f\x4d\x00\x00\x62\x4e\x00\x00\x35\x4f\x00\x00\x08\x50\x00\x00\xdb\x50\x00\x00\xae\x51\x00\x00\x81\x52\x00\x00\x54\x53\x00\x00\x27\x54\x00\x00\xfa\x54\x00\x00\xcd\x55\x00\x00\xa0\x56\x00\x00\x73\x57\x00\x00\x46\x58\x00\x00\x19\x59\x00\x00\xec\x59\x00\x00\xbf\x5a\x00\x00\x92\x5b\x00\x00\x65\x5c\x00\x00\x38\x5d\x00\x00\x0b\x5e\x00\x00\xde\x5e\x00\x00\xb1\x5f\x00\x00\x84\x60\x00\x00\x57\x61\x00\x00\x2a\x62\x00\x00\xfd\x62\x00\x00\xd0\x63\x00\x00\xa3\x64\x00\x00\x76\x65\x00\x00\x49\x66\x00\x00\x1c\x67\x00\x00\xef\x67\x00\x00\xc2\x68\x00\x00\x95\x69\x00\x00\x68\x6a\x00\x00\x3b\x6b\x00\x00\x0e\x6c\x00\x00\xe1\x6c\x00\x00\xb4\x6d\x00\x00\x87\x6e\x00\x00\x5a\x6f\x00\x00\x2d\x70\x00\x00\x00\x71\x00\x00\xd3\x71\x00\x00\xa6\x72\x00\x00\x79\x73\x00\x00\x4c\x74\x00\x00\x1f\x75\x00\x00\xf2\x75\x00\x00\xc5\x76\x00\x00\x98\x77\x00\x00\x6b\x78\x00\x00\x3e\x79\x00\x00\x11\x7a\x00\x00\xe4\x7a\x00\x00\xb7\x7b\x00\x00\x8a\x7c\x00\x00\x5d\x7d\x00\x00\x25\x7e\x00\x00\x24\x7f\x00\x00\x24\x80\x00\x00\xf7\x80\x00\x00\xbf\x81\x00\x00\xbe\x82\x00\x00\xbe\x83\x00\x00\x91\x84\x00\x00\x59\x85\x00\x00\x58\x86\x00\x00\x57\x87\x00\x00\x56\x88\x00\x00"#++alex_table :: AlexAddr+alex_table = AlexA#+  "\x00\x00\xff\xff\x8d\x00\xff\xff\x0f\x00\x10\x00\xff\xff\xff\xff\xff\xff\xff\xff\x81\x00\x3a\x00\x81\x00\x81\x00\x81\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x81\x00\x2b\x00\x84\x00\x5e\x00\x11\x00\x1f\x00\x29\x00\xff\xff\x38\x00\x38\x00\x38\x00\x38\x00\x38\x00\x39\x00\xaf\x00\x38\x00\x8e\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x35\x00\x38\x00\x31\x00\x2d\x00\x33\x00\xff\xff\x12\x00\x15\x00\x69\x00\xa9\x00\xb1\x00\x13\x00\xb0\x00\xb4\x00\xaa\x00\x16\x00\x17\x00\x19\x00\xfe\x00\x45\x00\x1a\x00\x1b\x00\x08\x00\x1d\x00\x06\x00\x4b\x00\x9d\x00\xa5\x00\xb6\x00\x1c\x00\xb3\x00\xfa\x00\xf6\x00\x38\x00\xff\xff\x38\x00\x38\x00\x81\x00\x38\x00\x81\x00\x81\x00\x81\x00\x22\x00\x23\x00\x1e\x00\x21\x00\x24\x00\x14\x00\x25\x00\x26\x00\x71\x00\x28\x00\x2a\x00\x2c\x00\x2e\x00\x32\x00\x2f\x00\x30\x00\x34\x00\x36\x00\x81\x00\x80\x00\x5a\x00\x5e\x00\xff\xff\x38\x00\x27\x00\x38\x00\x38\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x81\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3d\x00\xff\xff\x3d\x00\x3d\x00\x3d\x00\xff\xff\xff\xff\x18\x00\x5c\x00\xff\xff\xff\xff\x3d\x00\xff\xff\x3d\x00\x3d\x00\x3d\x00\x81\x00\x60\x00\x81\x00\x81\x00\x81\x00\x89\x00\xff\xff\x3d\x00\x20\x00\x82\x00\x43\x00\xff\xff\xff\xff\x59\x00\x61\x00\xff\xff\xff\xff\xff\xff\x3d\x00\x5c\x00\x5f\x00\x76\x00\x78\x00\x81\x00\x77\x00\xff\xff\x5e\x00\x7b\x00\x7c\x00\x7f\x00\x7d\x00\x80\x00\x0e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\x00\xff\xff\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5b\x00\x7a\x00\x00\x00\x89\x00\x89\x00\x89\x00\x89\x00\x89\x00\x89\x00\x89\x00\x89\x00\x89\x00\x89\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x40\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x41\x00\x00\x00\x00\x00\x00\x00\x3f\x00\x00\x00\x04\x00\x00\x00\x90\x00\x90\x00\x42\x00\x00\x00\x00\x00\x00\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x3c\x00\x5d\x00\x44\x00\x00\x00\x00\x00\x00\x00\x3e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x81\x00\x00\x00\x81\x00\x81\x00\x81\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x3d\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x3d\x00\x00\x00\x81\x00\x00\x00\x00\x00\x81\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x7a\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x87\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x7a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x87\x00\x87\x00\x87\x00\x87\x00\x87\x00\x87\x00\x87\x00\x87\x00\x87\x00\x87\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\x00\x00\x00\x00\x00\x8a\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x87\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x05\x00\x00\x00\x90\x00\x90\x00\x00\x00\x00\x00\x87\x00\x87\x00\x87\x00\x87\x00\x87\x00\x87\x00\x87\x00\x87\x00\x87\x00\x87\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x83\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x7e\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x07\x00\x00\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x83\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x7e\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x07\x00\x00\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x89\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x87\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x79\x00\x00\x00\x89\x00\x89\x00\x89\x00\x89\x00\x89\x00\x89\x00\x89\x00\x89\x00\x89\x00\x89\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x00\x00\x00\x88\x00\x00\x00\x00\x00\x87\x00\x87\x00\x87\x00\x87\x00\x87\x00\x87\x00\x87\x00\x87\x00\x87\x00\x87\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8a\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x8d\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x09\x00\x00\x00\x90\x00\x90\x00\x79\x00\x00\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x8d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x00\x00\x00\x00\x8a\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x8d\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x79\x00\x00\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8d\x00\x8d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8a\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x09\x00\x00\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x46\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x47\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x48\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\xca\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x4f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xde\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x51\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x52\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x53\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x55\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x65\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\xe8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x67\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x68\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x6a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x72\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x73\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x74\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x75\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x84\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x84\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x85\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x84\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x84\x00\x8b\x00\x00\x00\x00\x00\x84\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x00\x00\x00\x00\x00\x00\x84\x00\x00\x00\x84\x00\x00\x00\x00\x00\x00\x00\x86\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8b\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x00\x00\x00\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8d\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x00\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x85\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x00\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x79\x00\x00\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8d\x00\x8d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8a\x00\x00\x00\x00\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\x8c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xea\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x91\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x92\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x93\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x94\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x95\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x96\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x9e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x98\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\xac\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xec\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xeb\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xad\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x37\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x05\x00\x00\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\xff\xff\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x66\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x04\x00\x00\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x50\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x4a\x00\x00\x00\x49\x00\x00\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xbb\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xbe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xbf\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xc5\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xc8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xc9\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcb\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xce\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xcf\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xd2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xd3\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xd9\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xda\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdb\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xdc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xdd\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\xe2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe9\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xed\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xee\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x62\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xef\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf3\x00\x00\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\xff\xff\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\xf3\x00\x00\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\xf3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf7\x00\x00\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\xff\xff\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\xf7\x00\x00\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\xf7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfb\x00\x00\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\xff\xff\xfb\x00\xfb\x00\xfb\x00\xfb\x00\xfb\x00\xfb\x00\xfb\x00\xfb\x00\xfb\x00\xfb\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\xfb\x00\x00\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\xfb\x00\xfb\x00\xfb\x00\xfb\x00\xfb\x00\xfb\x00\xfb\x00\xfb\x00\xfb\x00\xfb\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\xfd\x00\x00\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\xfd\x00\x00\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00"#++alex_check :: AlexAddr+alex_check = AlexA#+  "\xff\xff\x00\x00\x01\x00\x02\x00\x71\x00\x5f\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x63\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x73\x00\x61\x00\x42\x00\x43\x00\x44\x00\x74\x00\x46\x00\x47\x00\x48\x00\x73\x00\x65\x00\x63\x00\x4c\x00\x4d\x00\x71\x00\x75\x00\x50\x00\x72\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x69\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x09\x00\x60\x00\x0b\x00\x0c\x00\x0d\x00\x6c\x00\x61\x00\x65\x00\x65\x00\x78\x00\x65\x00\x65\x00\x64\x00\x6c\x00\x7c\x00\x26\x00\x3d\x00\x3d\x00\x3c\x00\x3d\x00\x3d\x00\x3e\x00\x3a\x00\x20\x00\x0a\x00\x22\x00\x23\x00\x0a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\x0a\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0a\x00\x0a\x00\x61\x00\x01\x00\x0a\x00\x0a\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x09\x00\x69\x00\x0b\x00\x0c\x00\x0d\x00\x01\x00\xd7\x00\x20\x00\x72\x00\x73\x00\x23\x00\x0a\x00\x0a\x00\x6e\x00\x6e\x00\x0a\x00\x0a\x00\x0a\x00\x20\x00\x01\x00\x6c\x00\x65\x00\x72\x00\x20\x00\x70\x00\x0a\x00\x23\x00\x61\x00\x67\x00\x61\x00\x6d\x00\x0a\x00\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xa0\x00\xf7\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x22\x00\x01\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x61\x00\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\xff\xff\x67\x00\xff\xff\xff\xff\xff\xff\x72\x00\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\x6d\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x69\x00\x65\x00\x6c\x00\xff\xff\xff\xff\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\x09\x00\xff\xff\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xa0\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xa0\x00\xff\xff\x20\x00\xff\xff\xff\xff\xa0\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x01\x00\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xa0\x00\xff\xff\xff\xff\x65\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x01\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x00\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\xff\xff\xff\xff\x22\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x5c\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x00\x00\xff\xff\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\xff\xff\xff\xff\x22\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x5c\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x01\x00\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2b\x00\xff\xff\x2d\x00\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\x01\x00\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x01\x00\xff\xff\x03\x00\x04\x00\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x01\x00\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x00\x00\xff\xff\x02\x00\xff\xff\xff\xff\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\x63\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x53\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\x32\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x36\x00\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\x43\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x47\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x47\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\x63\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\x61\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x67\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x79\x00\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\x22\x00\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\xff\xff\xd7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xf7\x00\xff\xff\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\x62\x00\x01\x00\xff\xff\xff\xff\x66\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\x72\x00\xff\xff\x74\x00\xff\xff\xff\xff\xff\xff\x78\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x45\x00\xff\xff\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\x78\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x54\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x74\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\x64\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x77\x00\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x72\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\x43\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x53\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\x43\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x53\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xf7\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x00\x00\xff\xff\x02\x00\xff\xff\xff\xff\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\x31\x00\xff\xff\x33\x00\xff\xff\xff\xff\x36\x00\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x53\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x47\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x47\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x53\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x47\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x47\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x53\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x47\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x47\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x53\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x47\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x47\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x53\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x67\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x70\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x79\x00\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xf7\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x00\x00\xff\xff\x02\x00\xff\xff\xff\xff\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xf7\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x00\x00\xff\xff\x02\x00\xff\xff\xff\xff\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xff\xff\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\xff\xff\x02\x00\xff\xff\xd7\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\xf7\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\xff\xff\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5b\x00\x5c\x00\x5d\x00\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x86\x00\x87\x00\x88\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x9f\x00\xa0\x00\xa1\x00\xa2\x00\xa3\x00\xa4\x00\xa5\x00\xa6\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xac\x00\xad\x00\xae\x00\xaf\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xf7\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00\x01\x00\xff\xff\x03\x00\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\xd4\x00\xd5\x00\xd6\x00\xff\xff\xd8\x00\xd9\x00\xda\x00\xdb\x00\xdc\x00\xdd\x00\xde\x00\xdf\x00\xe0\x00\xe1\x00\xe2\x00\xe3\x00\xe4\x00\xe5\x00\xe6\x00\xe7\x00\xe8\x00\xe9\x00\xea\x00\xeb\x00\xec\x00\xed\x00\xee\x00\xef\x00\xf0\x00\xf1\x00\xf2\x00\xf3\x00\xf4\x00\xf5\x00\xf6\x00\xff\xff\xf8\x00\xf9\x00\xfa\x00\xfb\x00\xfc\x00\xfd\x00\xfe\x00\xff\x00"#++alex_deflt :: AlexAddr+alex_deflt = AlexA#+  "\x90\x00\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x90\x00\x90\x00\x90\x00\x90\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x90\x00\xff\xff\xff\xff\xff\xff\x3b\x00\x58\x00\x58\x00\x58\x00\x58\x00\x58\x00\x58\x00\x58\x00\x58\x00\x58\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x58\x00\x58\x00\x5a\x00\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x84\x00\x84\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\xff\xff\xff\xff\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\xff\xff\xff\xff\x90\x00\x90\x00\xff\xff\xff\xff\x90\x00\x90\x00\xff\xff\xff\xff\xff\xff\xff\xff"#++alex_accept = listArray (0 :: Int, 254)+  [ AlexAccNone+  , AlexAccNone+  , AlexAccNone+  , AlexAcc 209+  , AlexAcc 208+  , AlexAcc 207+  , AlexAcc 206+  , AlexAcc 205+  , AlexAcc 204+  , AlexAcc 203+  , AlexAcc 202+  , AlexAcc 201+  , AlexAcc 200+  , AlexAcc 199+  , AlexAccNone+  , AlexAccNone+  , AlexAccNone+  , AlexAccNone+  , AlexAccNone+  , AlexAcc 198+  , AlexAccNone+  , AlexAccNone+  , AlexAccNone+  , AlexAcc 197+  , AlexAccNone+  , AlexAccNone+  , AlexAccNone+  , AlexAccNone+  , AlexAccNone+  , AlexAccNone+  , AlexAcc 196+  , AlexAcc 195+  , AlexAccNone+  , AlexAccNone+  , AlexAccNone+  , AlexAccNone+  , AlexAccNone+  , AlexAccNone+  , AlexAcc 194+  , AlexAcc 193+  , AlexAcc 192+  , AlexAcc 191+  , AlexAcc 190+  , AlexAcc 189+  , AlexAcc 188+  , AlexAcc 187+  , AlexAcc 186+  , AlexAcc 185+  , AlexAcc 184+  , AlexAcc 183+  , AlexAcc 182+  , AlexAcc 181+  , AlexAcc 180+  , AlexAcc 179+  , AlexAcc 178+  , AlexAcc 177+  , AlexAcc 176+  , AlexAcc 175+  , AlexAccSkip+  , AlexAcc 174+  , AlexAcc 173+  , AlexAccSkip+  , AlexAcc 172+  , AlexAcc 171+  , AlexAcc 170+  , AlexAcc 169+  , AlexAcc 168+  , AlexAccPred 167 (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAcc 166)+  , AlexAcc 165+  , AlexAcc 164+  , AlexAcc 163+  , AlexAcc 162+  , AlexAcc 161+  , AlexAcc 160+  , AlexAcc 159+  , AlexAcc 158+  , AlexAcc 157+  , AlexAcc 156+  , AlexAcc 155+  , AlexAcc 154+  , AlexAcc 153+  , AlexAcc 152+  , AlexAcc 151+  , AlexAcc 150+  , AlexAcc 149+  , AlexAcc 148+  , AlexAcc 147+  , AlexAcc 146+  , AlexAcc 145+  , AlexAcc 144+  , AlexAccNone+  , AlexAcc 143+  , AlexAcc 142+  , AlexAccPred 141 (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAcc 140)+  , AlexAccPred 139 (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAccNone)+  , AlexAccNone+  , AlexAccNone+  , AlexAccNone+  , AlexAcc 138+  , AlexAcc 137+  , AlexAcc 136+  , AlexAcc 135+  , AlexAcc 134+  , AlexAcc 133+  , AlexAcc 132+  , AlexAcc 131+  , AlexAcc 130+  , AlexAcc 129+  , AlexAcc 128+  , AlexAcc 127+  , AlexAcc 126+  , AlexAcc 125+  , AlexAcc 124+  , AlexAcc 123+  , AlexAcc 122+  , AlexAcc 121+  , AlexAcc 120+  , AlexAcc 119+  , AlexAccPred 118 (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAccNone)+  , AlexAccNone+  , AlexAccNone+  , AlexAccNone+  , AlexAcc 117+  , AlexAccNone+  , AlexAccNone+  , AlexAccNone+  , AlexAccNone+  , AlexAccNone+  , AlexAccSkipPred (alexPrevCharMatches(\c -> c >= '\n' && c <= '\n' || False))(AlexAccNone)+  , AlexAccSkip+  , AlexAccNone+  , AlexAcc 116+  , AlexAccNone+  , AlexAccNone+  , AlexAccNone+  , AlexAcc 115+  , AlexAccNone+  , AlexAccNone+  , AlexAccNone+  , AlexAcc 114+  , AlexAccNone+  , AlexAcc 113+  , AlexAcc 112+  , AlexAcc 111+  , AlexAcc 110+  , AlexAcc 109+  , AlexAcc 108+  , AlexAcc 107+  , AlexAcc 106+  , AlexAcc 105+  , AlexAcc 104+  , AlexAcc 103+  , AlexAcc 102+  , AlexAcc 101+  , AlexAcc 100+  , AlexAcc 99+  , AlexAcc 98+  , AlexAcc 97+  , AlexAcc 96+  , AlexAcc 95+  , AlexAcc 94+  , AlexAcc 93+  , AlexAcc 92+  , AlexAcc 91+  , AlexAcc 90+  , AlexAcc 89+  , AlexAcc 88+  , AlexAcc 87+  , AlexAcc 86+  , AlexAcc 85+  , AlexAcc 84+  , AlexAcc 83+  , AlexAcc 82+  , AlexAcc 81+  , AlexAcc 80+  , AlexAcc 79+  , AlexAcc 78+  , AlexAcc 77+  , AlexAcc 76+  , AlexAcc 75+  , AlexAcc 74+  , AlexAcc 73+  , AlexAcc 72+  , AlexAcc 71+  , AlexAcc 70+  , AlexAcc 69+  , AlexAcc 68+  , AlexAcc 67+  , AlexAcc 66+  , AlexAcc 65+  , AlexAcc 64+  , AlexAcc 63+  , AlexAcc 62+  , AlexAcc 61+  , AlexAcc 60+  , AlexAcc 59+  , AlexAcc 58+  , AlexAcc 57+  , AlexAcc 56+  , AlexAcc 55+  , AlexAcc 54+  , AlexAcc 53+  , AlexAcc 52+  , AlexAcc 51+  , AlexAcc 50+  , AlexAcc 49+  , AlexAcc 48+  , AlexAcc 47+  , AlexAcc 46+  , AlexAcc 45+  , AlexAcc 44+  , AlexAcc 43+  , AlexAcc 42+  , AlexAcc 41+  , AlexAcc 40+  , AlexAcc 39+  , AlexAcc 38+  , AlexAcc 37+  , AlexAcc 36+  , AlexAcc 35+  , AlexAcc 34+  , AlexAcc 33+  , AlexAcc 32+  , AlexAcc 31+  , AlexAcc 30+  , AlexAcc 29+  , AlexAcc 28+  , AlexAcc 27+  , AlexAcc 26+  , AlexAcc 25+  , AlexAcc 24+  , AlexAcc 23+  , AlexAcc 22+  , AlexAcc 21+  , AlexAcc 20+  , AlexAcc 19+  , AlexAcc 18+  , AlexAcc 17+  , AlexAcc 16+  , AlexAcc 15+  , AlexAcc 14+  , AlexAcc 13+  , AlexAcc 12+  , AlexAcc 11+  , AlexAcc 10+  , AlexAcc 9+  , AlexAcc 8+  , AlexAcc 7+  , AlexAcc 6+  , AlexAcc 5+  , AlexAcc 4+  , AlexAcc 3+  , AlexAcc 2+  , AlexAcc 1+  , AlexAcc 0+  ]++alex_actions = array (0 :: Int, 210)+  [ (209,alex_action_5)+  , (208,alex_action_28)+  , (207,alex_action_27)+  , (206,alex_action_49)+  , (205,alex_action_26)+  , (204,alex_action_49)+  , (203,alex_action_25)+  , (202,alex_action_24)+  , (201,alex_action_23)+  , (200,alex_action_49)+  , (199,alex_action_22)+  , (198,alex_action_21)+  , (197,alex_action_20)+  , (196,alex_action_19)+  , (195,alex_action_7)+  , (194,alex_action_18)+  , (193,alex_action_7)+  , (192,alex_action_17)+  , (191,alex_action_7)+  , (190,alex_action_16)+  , (189,alex_action_7)+  , (188,alex_action_15)+  , (187,alex_action_7)+  , (186,alex_action_14)+  , (185,alex_action_13)+  , (184,alex_action_12)+  , (183,alex_action_7)+  , (182,alex_action_11)+  , (181,alex_action_7)+  , (180,alex_action_10)+  , (179,alex_action_7)+  , (178,alex_action_9)+  , (177,alex_action_8)+  , (176,alex_action_7)+  , (175,alex_action_7)+  , (174,alex_action_5)+  , (173,alex_action_5)+  , (172,alex_action_5)+  , (171,alex_action_5)+  , (170,alex_action_5)+  , (169,alex_action_5)+  , (168,alex_action_5)+  , (167,alex_action_2)+  , (166,alex_action_5)+  , (165,alex_action_5)+  , (164,alex_action_49)+  , (163,alex_action_49)+  , (162,alex_action_49)+  , (161,alex_action_49)+  , (160,alex_action_49)+  , (159,alex_action_49)+  , (158,alex_action_49)+  , (157,alex_action_49)+  , (156,alex_action_49)+  , (155,alex_action_49)+  , (154,alex_action_49)+  , (153,alex_action_49)+  , (152,alex_action_49)+  , (151,alex_action_49)+  , (150,alex_action_49)+  , (149,alex_action_49)+  , (148,alex_action_49)+  , (147,alex_action_49)+  , (146,alex_action_49)+  , (145,alex_action_5)+  , (144,alex_action_5)+  , (143,alex_action_4)+  , (142,alex_action_3)+  , (141,alex_action_2)+  , (140,alex_action_5)+  , (139,alex_action_2)+  , (138,alex_action_49)+  , (137,alex_action_49)+  , (136,alex_action_49)+  , (135,alex_action_49)+  , (134,alex_action_49)+  , (133,alex_action_49)+  , (132,alex_action_49)+  , (131,alex_action_49)+  , (130,alex_action_49)+  , (129,alex_action_49)+  , (128,alex_action_49)+  , (127,alex_action_49)+  , (126,alex_action_49)+  , (125,alex_action_49)+  , (124,alex_action_49)+  , (123,alex_action_49)+  , (122,alex_action_49)+  , (121,alex_action_49)+  , (120,alex_action_49)+  , (119,alex_action_49)+  , (118,alex_action_2)+  , (117,alex_action_53)+  , (116,alex_action_54)+  , (115,alex_action_53)+  , (114,alex_action_52)+  , (113,alex_action_51)+  , (112,alex_action_51)+  , (111,alex_action_50)+  , (110,alex_action_49)+  , (109,alex_action_49)+  , (108,alex_action_49)+  , (107,alex_action_49)+  , (106,alex_action_49)+  , (105,alex_action_49)+  , (104,alex_action_49)+  , (103,alex_action_49)+  , (102,alex_action_49)+  , (101,alex_action_49)+  , (100,alex_action_49)+  , (99,alex_action_49)+  , (98,alex_action_49)+  , (97,alex_action_49)+  , (96,alex_action_49)+  , (95,alex_action_49)+  , (94,alex_action_49)+  , (93,alex_action_49)+  , (92,alex_action_49)+  , (91,alex_action_49)+  , (90,alex_action_49)+  , (89,alex_action_49)+  , (88,alex_action_49)+  , (87,alex_action_49)+  , (86,alex_action_49)+  , (85,alex_action_49)+  , (84,alex_action_49)+  , (83,alex_action_49)+  , (82,alex_action_49)+  , (81,alex_action_49)+  , (80,alex_action_49)+  , (79,alex_action_49)+  , (78,alex_action_49)+  , (77,alex_action_49)+  , (76,alex_action_49)+  , (75,alex_action_49)+  , (74,alex_action_49)+  , (73,alex_action_49)+  , (72,alex_action_49)+  , (71,alex_action_48)+  , (70,alex_action_49)+  , (69,alex_action_49)+  , (68,alex_action_49)+  , (67,alex_action_49)+  , (66,alex_action_49)+  , (65,alex_action_49)+  , (64,alex_action_49)+  , (63,alex_action_49)+  , (62,alex_action_49)+  , (61,alex_action_47)+  , (60,alex_action_49)+  , (59,alex_action_49)+  , (58,alex_action_49)+  , (57,alex_action_49)+  , (56,alex_action_49)+  , (55,alex_action_49)+  , (54,alex_action_49)+  , (53,alex_action_49)+  , (52,alex_action_49)+  , (51,alex_action_46)+  , (50,alex_action_49)+  , (49,alex_action_49)+  , (48,alex_action_49)+  , (47,alex_action_49)+  , (46,alex_action_49)+  , (45,alex_action_49)+  , (44,alex_action_49)+  , (43,alex_action_49)+  , (42,alex_action_49)+  , (41,alex_action_45)+  , (40,alex_action_49)+  , (39,alex_action_49)+  , (38,alex_action_49)+  , (37,alex_action_49)+  , (36,alex_action_49)+  , (35,alex_action_49)+  , (34,alex_action_49)+  , (33,alex_action_49)+  , (32,alex_action_49)+  , (31,alex_action_44)+  , (30,alex_action_49)+  , (29,alex_action_43)+  , (28,alex_action_49)+  , (27,alex_action_49)+  , (26,alex_action_49)+  , (25,alex_action_42)+  , (24,alex_action_49)+  , (23,alex_action_41)+  , (22,alex_action_40)+  , (21,alex_action_39)+  , (20,alex_action_49)+  , (19,alex_action_38)+  , (18,alex_action_37)+  , (17,alex_action_36)+  , (16,alex_action_49)+  , (15,alex_action_49)+  , (14,alex_action_35)+  , (13,alex_action_34)+  , (12,alex_action_33)+  , (11,alex_action_32)+  , (10,alex_action_49)+  , (9,alex_action_49)+  , (8,alex_action_49)+  , (7,alex_action_31)+  , (6,alex_action_49)+  , (5,alex_action_49)+  , (4,alex_action_49)+  , (3,alex_action_30)+  , (2,alex_action_49)+  , (1,alex_action_29)+  , (0,alex_action_49)+  ]+++line_prag,line_prag1,line_prag2 :: Int+line_prag = 1+line_prag1 = 2+line_prag2 = 3+alex_action_2 = begin line_prag+alex_action_3 = setLine line_prag1+alex_action_4 = setFile line_prag2+alex_action_5 = pop+alex_action_7 = special_char+alex_action_8 = kw CmmT_DotDot+alex_action_9 = kw CmmT_DoubleColon+alex_action_10 = kw CmmT_Shr+alex_action_11 = kw CmmT_Shl+alex_action_12 = kw CmmT_Ge+alex_action_13 = kw CmmT_Le+alex_action_14 = kw CmmT_Eq+alex_action_15 = kw CmmT_Ne+alex_action_16 = kw CmmT_BoolAnd+alex_action_17 = kw CmmT_BoolOr+alex_action_18 = kw CmmT_Relaxed+alex_action_19 = kw CmmT_Acquire+alex_action_20 = kw CmmT_Release+alex_action_21 = kw CmmT_SeqCst+alex_action_22 = kw CmmT_True+alex_action_23 = kw CmmT_False+alex_action_24 = kw CmmT_likely+alex_action_25 = global_regN 1 VanillaReg      gcWord+alex_action_26 = global_regN 1 VanillaReg       bWord+alex_action_27 = global_regN 1 FloatReg  (const $ cmmFloat W32)+alex_action_28 = global_regN 1 DoubleReg (const $ cmmFloat W64)+alex_action_29 = global_regN 1 LongReg   (const $ cmmBits  W64)+alex_action_30 = global_regN 3 XmmReg    (const $ cmmVec 2 (cmmFloat W64))+alex_action_31 = global_regN 3 YmmReg    (const $ cmmVec 4 (cmmFloat W64))+alex_action_32 = global_regN 3 ZmmReg    (const $ cmmVec 8 (cmmFloat W64))+alex_action_33 = global_reg  Sp               bWord+alex_action_34 = global_reg  SpLim            bWord+alex_action_35 = global_reg  Hp              gcWord+alex_action_36 = global_reg  HpLim            bWord+alex_action_37 = global_reg  CCCS             bWord+alex_action_38 = global_reg  CurrentTSO       bWord+alex_action_39 = global_reg  CurrentNursery   bWord+alex_action_40 = global_reg  HpAlloc          bWord+alex_action_41 = global_reg  BaseReg          bWord+alex_action_42 = global_reg  MachSp           bWord+alex_action_43 = global_reg  UnwindReturnReg  bWord+alex_action_44 = kw (CmmT_GlobalArgRegs GP_ARG_REGS)+alex_action_45 = kw (CmmT_GlobalArgRegs SCALAR_ARG_REGS)+alex_action_46 = kw (CmmT_GlobalArgRegs V16_ARG_REGS)+alex_action_47 = kw (CmmT_GlobalArgRegs V32_ARG_REGS)+alex_action_48 = kw (CmmT_GlobalArgRegs V64_ARG_REGS)+alex_action_49 = name+alex_action_50 = tok_octal+alex_action_51 = tok_decimal+alex_action_52 = tok_hexadecimal+alex_action_53 = strtoken tok_float+alex_action_54 = strtoken tok_string++#define ALEX_GHC 1+#define ALEX_LATIN1 1+-- -----------------------------------------------------------------------------+-- ALEX TEMPLATE+--+-- This code is in the PUBLIC DOMAIN; you may copy it freely and use+-- it for any purpose whatsoever.++-- -----------------------------------------------------------------------------+-- INTERNALS and main scanner engine++#ifdef ALEX_GHC+#  define ILIT(n) n#+#  define IBOX(n) (I# (n))+#  define FAST_INT Int#+-- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex.+#  if __GLASGOW_HASKELL__ > 706+#    define GTE(n,m) (tagToEnum# (n >=# m))+#    define EQ(n,m) (tagToEnum# (n ==# m))+#  else+#    define GTE(n,m) (n >=# m)+#    define EQ(n,m) (n ==# m)+#  endif+#  define PLUS(n,m) (n +# m)+#  define MINUS(n,m) (n -# m)+#  define TIMES(n,m) (n *# m)+#  define NEGATE(n) (negateInt# (n))+#  define IF_GHC(x) (x)+#else+#  define ILIT(n) (n)+#  define IBOX(n) (n)+#  define FAST_INT Int+#  define GTE(n,m) (n >= m)+#  define EQ(n,m) (n == m)+#  define PLUS(n,m) (n + m)+#  define MINUS(n,m) (n - m)+#  define TIMES(n,m) (n * m)+#  define NEGATE(n) (negate (n))+#  define IF_GHC(x)+#endif++#ifdef ALEX_GHC+data AlexAddr = AlexA# Addr#+-- Do not remove this comment. Required to fix CPP parsing when using GCC and a clang-compiled alex.+#if __GLASGOW_HASKELL__ < 503+uncheckedShiftL# = shiftL#+#endif++{-# INLINE alexIndexInt16OffAddr #-}+alexIndexInt16OffAddr :: AlexAddr -> Int# -> Int#+alexIndexInt16OffAddr (AlexA# arr) off =+#ifdef WORDS_BIGENDIAN+  narrow16Int# i+  where+        i    = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low)+        high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#)))+        low  = int2Word# (ord# (indexCharOffAddr# arr off'))+        off' = off *# 2#+#else+#if __GLASGOW_HASKELL__ >= 901+  int16ToInt#+#endif+    (indexInt16OffAddr# arr off)+#endif+#else+alexIndexInt16OffAddr arr off = arr ! off+#endif++#ifdef ALEX_GHC+{-# INLINE alexIndexInt32OffAddr #-}+alexIndexInt32OffAddr :: AlexAddr -> Int# -> Int#+alexIndexInt32OffAddr (AlexA# arr) off =+#ifdef WORDS_BIGENDIAN+  narrow32Int# i+  where+   i    = word2Int# ((b3 `uncheckedShiftL#` 24#) `or#`+                     (b2 `uncheckedShiftL#` 16#) `or#`+                     (b1 `uncheckedShiftL#` 8#) `or#` b0)+   b3   = int2Word# (ord# (indexCharOffAddr# arr (off' +# 3#)))+   b2   = int2Word# (ord# (indexCharOffAddr# arr (off' +# 2#)))+   b1   = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#)))+   b0   = int2Word# (ord# (indexCharOffAddr# arr off'))+   off' = off *# 4#+#else+#if __GLASGOW_HASKELL__ >= 901+  int32ToInt#+#endif+    (indexInt32OffAddr# arr off)+#endif+#else+alexIndexInt32OffAddr arr off = arr ! off+#endif++#ifdef ALEX_GHC++#if __GLASGOW_HASKELL__ < 503+quickIndex arr i = arr ! i+#else+-- GHC >= 503, unsafeAt is available from Data.Array.Base.+quickIndex = unsafeAt+#endif+#else+quickIndex arr i = arr ! i+#endif++-- -----------------------------------------------------------------------------+-- Main lexing routines++data AlexReturn a+  = AlexEOF+  | AlexError  !AlexInput+  | AlexSkip   !AlexInput !Int+  | AlexToken  !AlexInput !Int a++-- alexScan :: AlexInput -> StartCode -> AlexReturn a+alexScan input__ IBOX(sc)+  = alexScanUser undefined input__ IBOX(sc)++alexScanUser user__ input__ IBOX(sc)+  = case alex_scan_tkn user__ input__ ILIT(0) input__ sc AlexNone of+  (AlexNone, input__') ->+    case alexGetByte input__ of+      Nothing ->+#ifdef ALEX_DEBUG+                                   trace ("End of input.") $+#endif+                                   AlexEOF+      Just _ ->+#ifdef ALEX_DEBUG+                                   trace ("Error.") $+#endif+                                   AlexError input__'++  (AlexLastSkip input__'' len, _) ->+#ifdef ALEX_DEBUG+    trace ("Skipping.") $+#endif+    AlexSkip input__'' len++  (AlexLastAcc k input__''' len, _) ->+#ifdef ALEX_DEBUG+    trace ("Accept.") $+#endif+    AlexToken input__''' len (alex_actions ! k)+++-- Push the input through the DFA, remembering the most recent accepting+-- state it encountered.++alex_scan_tkn user__ orig_input len input__ s last_acc =+  input__ `seq` -- strict in the input+  let+  new_acc = (check_accs (alex_accept `quickIndex` IBOX(s)))+  in+  new_acc `seq`+  case alexGetByte input__ of+     Nothing -> (new_acc, input__)+     Just (c, new_input) ->+#ifdef ALEX_DEBUG+      trace ("State: " ++ show IBOX(s) ++ ", char: " ++ show c) $+#endif+      case fromIntegral c of { IBOX(ord_c) ->+        let+                base   = alexIndexInt32OffAddr alex_base s+                offset = PLUS(base,ord_c)++                new_s = if GTE(offset,ILIT(0))+                          && let check  = alexIndexInt16OffAddr alex_check offset+                             in  EQ(check,ord_c)+                          then alexIndexInt16OffAddr alex_table offset+                          else alexIndexInt16OffAddr alex_deflt s+        in+        case new_s of+            ILIT(-1) -> (new_acc, input__)+                -- on an error, we want to keep the input *before* the+                -- character that failed, not after.+            _ -> alex_scan_tkn user__ orig_input+#ifdef ALEX_LATIN1+                   PLUS(len,ILIT(1))+                   -- issue 119: in the latin1 encoding, *each* byte is one character+#else+                   (if c < 0x80 || c >= 0xC0 then PLUS(len,ILIT(1)) else len)+                   -- note that the length is increased ONLY if this is the 1st byte in a char encoding)+#endif+                   new_input new_s new_acc+      }+  where+        check_accs (AlexAccNone) = last_acc+        check_accs (AlexAcc a  ) = AlexLastAcc a input__ IBOX(len)+        check_accs (AlexAccSkip) = AlexLastSkip  input__ IBOX(len)+#ifndef ALEX_NOPRED+        check_accs (AlexAccPred a predx rest)+           | predx user__ orig_input IBOX(len) input__+           = AlexLastAcc a input__ IBOX(len)+           | otherwise+           = check_accs rest+        check_accs (AlexAccSkipPred predx rest)+           | predx user__ orig_input IBOX(len) input__+           = AlexLastSkip input__ IBOX(len)+           | otherwise+           = check_accs rest+#endif++data AlexLastAcc+  = AlexNone+  | AlexLastAcc !Int !AlexInput !Int+  | AlexLastSkip     !AlexInput !Int++data AlexAcc user+  = AlexAccNone+  | AlexAcc Int+  | AlexAccSkip+#ifndef ALEX_NOPRED+  | AlexAccPred Int (AlexAccPred user) (AlexAcc user)+  | AlexAccSkipPred (AlexAccPred user) (AlexAcc user)++type AlexAccPred user = user -> AlexInput -> Int -> AlexInput -> Bool++-- -----------------------------------------------------------------------------+-- Predicates on a rule++alexAndPred p1 p2 user__ in1 len in2+  = p1 user__ in1 len in2 && p2 user__ in1 len in2++--alexPrevCharIsPred :: Char -> AlexAccPred _+alexPrevCharIs c _ input__ _ _ = c == alexInputPrevChar input__++alexPrevCharMatches f _ input__ _ _ = f (alexInputPrevChar input__)++--alexPrevCharIsOneOfPred :: Array Char Bool -> AlexAccPred _+alexPrevCharIsOneOf arr _ input__ _ _ = arr ! alexInputPrevChar input__++--alexRightContext :: Int -> AlexAccPred _+alexRightContext IBOX(sc) user__ _ _ input__ =+     case alex_scan_tkn user__ input__ ILIT(0) input__ sc AlexNone of+          (AlexNone, _) -> False+          _ -> True+        -- TODO: there's no need to find the longest+        -- match when checking the right context, just+        -- the first match will do.+#endif+{-# LINE 144 "_build/source-dist/ghc-9.14.1-src/ghc-9.14.1/compiler/GHC/Cmm/Lexer.x" #-}+data CmmToken+  = CmmT_SpecChar  Char+  | CmmT_DotDot+  | CmmT_DoubleColon+  | CmmT_Shr+  | CmmT_Shl+  | CmmT_Ge+  | CmmT_Le+  | CmmT_Eq+  | CmmT_Ne+  | CmmT_BoolAnd+  | CmmT_BoolOr+  | CmmT_CLOSURE+  | CmmT_INFO_TABLE+  | CmmT_INFO_TABLE_RET+  | CmmT_INFO_TABLE_FUN+  | CmmT_INFO_TABLE_CONSTR+  | CmmT_INFO_TABLE_SELECTOR+  | CmmT_else+  | CmmT_export+  | CmmT_section+  | CmmT_goto+  | CmmT_if+  | CmmT_call+  | CmmT_jump+  | CmmT_foreign+  | CmmT_never+  | CmmT_prim+  | CmmT_reserve+  | CmmT_return+  | CmmT_returns+  | CmmT_import+  | CmmT_switch+  | CmmT_case+  | CmmT_default+  | CmmT_push+  | CmmT_unwind+  | CmmT_bits8+  | CmmT_bits16+  | CmmT_bits32+  | CmmT_bits64+  | CmmT_vec128+  | CmmT_vec256+  | CmmT_vec512+  | CmmT_float32+  | CmmT_float64+  | CmmT_gcptr+  | CmmT_GlobalReg     GlobalRegUse+  | CmmT_GlobalArgRegs GlobalArgRegs+  | CmmT_Name          FastString+  | CmmT_String        String+  | CmmT_Int           Integer+  | CmmT_Float         Rational+  | CmmT_EOF+  | CmmT_False+  | CmmT_True+  | CmmT_likely+  | CmmT_Relaxed+  | CmmT_Acquire+  | CmmT_Release+  | CmmT_SeqCst+  deriving (Show)++-- -----------------------------------------------------------------------------+-- Lexer actions++type Action = PsSpan -> StringBuffer -> Int -> PD (PsLocated CmmToken)++begin :: Int -> Action+begin code _span _str _len = do liftP (pushLexState code); lexToken++pop :: Action+pop _span _buf _len = liftP popLexState >> lexToken++special_char :: Action+special_char span buf _len = return (L span (CmmT_SpecChar (currentChar buf)))++kw :: CmmToken -> Action+kw tok span _buf _len = return (L span tok)++global_regN :: Int -> (Int -> GlobalReg) -> (Platform -> CmmType) -> Action+global_regN ident_nb_chars con ty_fn span buf len+  = do { platform <- getPlatform+       ; let reg = con (fromIntegral n)+             ty = ty_fn platform+       ; return (L span (CmmT_GlobalReg (GlobalRegUse reg ty))) }+  where buf' = go ident_nb_chars buf+          where go 0 b = b+                go i b = go (i-1) (stepOn b)+        n = parseUnsignedInteger buf' (len-ident_nb_chars) 10 octDecDigit++global_reg :: GlobalReg -> (Platform -> CmmType) -> Action+global_reg reg ty_fn span _buf _len+  = do { platform <- getPlatform+       ; let ty = ty_fn platform+       ; return (L span (CmmT_GlobalReg (GlobalRegUse reg ty))) }++strtoken :: (String -> CmmToken) -> Action+strtoken f span buf len =+  return (L span $! (f $! lexemeToString buf len))++name :: Action+name span buf len =+  case lookupUFM reservedWordsFM fs of+        Just tok -> return (L span tok)+        Nothing  -> return (L span (CmmT_Name fs))+  where+        fs = lexemeToFastString buf len++reservedWordsFM = listToUFM $+        map (\(x, y) -> (mkFastString x, y)) [+        ( "CLOSURE",            CmmT_CLOSURE ),+        ( "INFO_TABLE",         CmmT_INFO_TABLE ),+        ( "INFO_TABLE_RET",     CmmT_INFO_TABLE_RET ),+        ( "INFO_TABLE_FUN",     CmmT_INFO_TABLE_FUN ),+        ( "INFO_TABLE_CONSTR",  CmmT_INFO_TABLE_CONSTR ),+        ( "INFO_TABLE_SELECTOR",CmmT_INFO_TABLE_SELECTOR ),+        ( "else",               CmmT_else ),+        ( "export",             CmmT_export ),+        ( "section",            CmmT_section ),+        ( "goto",               CmmT_goto ),+        ( "if",                 CmmT_if ),+        ( "call",               CmmT_call ),+        ( "jump",               CmmT_jump ),+        ( "foreign",            CmmT_foreign ),+        ( "never",              CmmT_never ),+        ( "prim",               CmmT_prim ),+        ( "reserve",            CmmT_reserve ),+        ( "return",             CmmT_return ),+        ( "returns",            CmmT_returns ),+        ( "import",             CmmT_import ),+        ( "switch",             CmmT_switch ),+        ( "case",               CmmT_case ),+        ( "default",            CmmT_default ),+        ( "push",               CmmT_push ),+        ( "unwind",             CmmT_unwind ),+        ( "bits8",              CmmT_bits8 ),+        ( "bits16",             CmmT_bits16 ),+        ( "bits32",             CmmT_bits32 ),+        ( "bits64",             CmmT_bits64 ),+        ( "vec128",             CmmT_vec128 ),+        ( "vec256",             CmmT_vec256 ),+        ( "vec512",             CmmT_vec512 ),+        ( "float32",            CmmT_float32 ),+        ( "float64",            CmmT_float64 ),+-- New forms+        ( "b8",                 CmmT_bits8 ),+        ( "b16",                CmmT_bits16 ),+        ( "b32",                CmmT_bits32 ),+        ( "b64",                CmmT_bits64 ),+        ( "f32",                CmmT_float32 ),+        ( "f64",                CmmT_float64 ),+        ( "gcptr",              CmmT_gcptr ),+        ( "likely",             CmmT_likely),+        ( "True",               CmmT_True  ),+        ( "False",              CmmT_False )+        ]++tok_decimal span buf len+  = return (L span (CmmT_Int  $! parseUnsignedInteger buf len 10 octDecDigit))++tok_octal span buf len+  = return (L span (CmmT_Int  $! parseUnsignedInteger (offsetBytes 1 buf) (len-1) 8 octDecDigit))++tok_hexadecimal span buf len+  = return (L span (CmmT_Int  $! parseUnsignedInteger (offsetBytes 2 buf) (len-2) 16 hexDigit))++tok_float str = CmmT_Float $! readRational str++tok_string str = CmmT_String (read str)+                 -- urk, not quite right, but it'll do for now++-- -----------------------------------------------------------------------------+-- Line pragmas++setLine :: Int -> Action+setLine code (PsSpan span _) buf len = do+  let line = parseUnsignedInteger buf len 10 octDecDigit+  liftP $ do+    setSrcLoc (mkRealSrcLoc (srcSpanFile span) (fromIntegral line - 1) 1)+          -- subtract one: the line number refers to the *following* line+    -- trace ("setLine "  ++ show line) $ do+    popLexState >> pushLexState code+  lexToken++setFile :: Int -> Action+setFile code (PsSpan span _) buf len = do+  let file = lexemeToFastString (stepOn buf) (len-2)+  liftP $ do+    setSrcLoc (mkRealSrcLoc file (srcSpanEndLine span) (srcSpanEndCol span))+    popLexState >> pushLexState code+  lexToken++-- -----------------------------------------------------------------------------+-- This is the top-level function: called from the parser each time a+-- new token is to be read from the input.++cmmlex :: (Located CmmToken -> PD a) -> PD a+cmmlex cont = do+  (L span tok) <- lexToken+  --trace ("token: " ++ show tok) $ do+  cont (L (mkSrcSpanPs span) tok)++lexToken :: PD (PsLocated CmmToken)+lexToken = do+  inp@(loc1,buf) <- getInput+  sc <- liftP getLexState+  case alexScan inp sc of+    AlexEOF -> do let span = mkPsSpan loc1 loc1+                  liftP (setLastToken span 0)+                  return (L span CmmT_EOF)+    AlexError (loc2,_) ->+      let msg srcLoc = mkPlainErrorMsgEnvelope srcLoc PsErrCmmLexer+      in liftP $ failLocMsgP (psRealLoc loc1) (psRealLoc loc2) msg+    AlexSkip inp2 _ -> do+        setInput inp2+        lexToken+    AlexToken inp2@(end,_buf2) len t -> do+        setInput inp2+        let span = mkPsSpan loc1 end+        span `seq` liftP (setLastToken span len)+        t span buf len++-- -----------------------------------------------------------------------------+-- Monad stuff++-- Stuff that Alex needs to know about our input type:+type AlexInput = (PsLoc,StringBuffer)++alexInputPrevChar :: AlexInput -> Char+alexInputPrevChar (_,s) = prevChar s '\n'++-- backwards compatibility for Alex 2.x+alexGetChar :: AlexInput -> Maybe (Char,AlexInput)+alexGetChar inp = case alexGetByte inp of+                    Nothing    -> Nothing+                    Just (b,i) -> c `seq` Just (c,i)+                       where c = chr $ fromIntegral b++alexGetByte :: AlexInput -> Maybe (Word8,AlexInput)+alexGetByte (loc,s)+  | atEnd s   = Nothing+  | otherwise = b `seq` loc' `seq` s' `seq` Just (b, (loc', s'))+  where c    = currentChar s+        b    = fromIntegral $ ord $ c+        loc' = advancePsLoc loc c+        s'   = stepOn s++getInput :: PD AlexInput+getInput = PD $ \_ _ s@PState{ loc=l, buffer=b } -> POk s (l,b)++setInput :: AlexInput -> PD ()+setInput (l,b) = PD $ \_ _ s -> POk s{ loc=l, buffer=b } ()
GHC/Cmm/Lint.hs view
@@ -6,6 +6,7 @@ -- ----------------------------------------------------------------------------- {-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} module GHC.Cmm.Lint (@@ -17,17 +18,18 @@ import GHC.Platform import GHC.Platform.Regs (callerSaves) import GHC.Cmm.Dataflow.Block-import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Graph import GHC.Cmm.Dataflow.Label import GHC.Cmm-import GHC.Cmm.Utils import GHC.Cmm.Liveness import GHC.Cmm.Switch (switchTargetsToList)-import GHC.Cmm.Ppr () -- For Outputable instances+import GHC.Cmm.CLabel (pprDebugCLabel) import GHC.Utils.Outputable -import Control.Monad (ap, unless)+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)@@ -47,7 +49,8 @@ runCmmLint :: OutputableP Platform a => Platform -> (a -> CmmLint b) -> a -> Maybe SDoc runCmmLint platform l p =    case unCL (l p) platform of-     Left err -> Just (vcat [text "Cmm lint error:",+     Left err -> Just (withPprStyle defaultDumpStyle $ vcat+                            [text "Cmm lint error:",                              nest 2 err,                              text "Program was:",                              nest 2 (pdoc platform p)])@@ -57,7 +60,7 @@ lintCmmDecl (CmmProc _ lbl _ g)   = do     platform <- getPlatform-    addLintInfo (text "in proc " <> pdoc platform lbl) $ lintCmmGraph g+    addLintInfo (text "in proc " <> pprDebugCLabel platform lbl) $ lintCmmGraph g lintCmmDecl (CmmData {})   = return () @@ -99,12 +102,13 @@   platform <- getPlatform   tys <- mapM lintCmmExpr args   lintShiftOp op (zip args tys)-  if map (typeWidth . cmmExprType platform) args == machOpArgReps platform op-        then cmmCheckMachOp op args tys-        else cmmLintMachOpErr expr (map (cmmExprType platform) args) (machOpArgReps platform op)+  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 platform <- getPlatform-       let rep = typeWidth (cmmRegType platform reg)+  = do let rep = typeWidth (cmmRegType reg)        lintCmmExpr (CmmMachOp (MO_Add rep)                 [CmmReg reg, CmmLit (CmmInt (fromIntegral offset) rep)]) lintCmmExpr expr =@@ -167,12 +171,10 @@   CmmUnwind{}  -> return ()    CmmAssign reg expr -> do-            platform <- getPlatform             erep <- lintCmmExpr expr-            let reg_ty = cmmRegType platform reg-            if (erep `cmmEqType_ignoring_ptrhood` reg_ty)-                then return ()-                else cmmLintAssignErr (CmmAssign reg expr) erep reg_ty+            let reg_ty = cmmRegType reg+            unless (erep `cmmCompatType` reg_ty) $+              cmmLintAssignErr (CmmAssign reg expr) erep reg_ty    CmmStore l r _alignment -> do             _ <- lintCmmExpr l@@ -180,14 +182,13 @@             return ()    CmmUnsafeForeignCall target _formals actuals -> do-            lintTarget target             let lintArg expr = do                   -- Arguments can't mention caller-saved                   -- registers. See Note [Register parameter passing].                   mayNotMentionCallerSavedRegs (text "foreign call argument") expr                   lintCmmExpr expr--            mapM_ lintArg actuals+            arg_tys <- mapM lintArg actuals+            lintTarget arg_tys target   lintCmmLast :: LabelSet -> CmmNode O C -> CmmLint ()@@ -213,7 +214,6 @@           maybe (return ()) checkTarget cont    CmmForeignCall tgt _ args succ _ _ _ -> do-          lintTarget tgt           let lintArg expr = do                 -- Arguments can't mention caller-saved                 -- registers. See Note [Register@@ -223,19 +223,24 @@                 -- places in caller-saved registers.                 mayNotMentionCallerSavedRegs (text "foreign call argument") expr                 lintCmmExpr expr-          mapM_ lintArg args+          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 :: ForeignTarget -> CmmLint ()-lintTarget (ForeignTarget e _) = do+lintTarget :: [CmmType] -> ForeignTarget -> CmmLint ()+lintTarget _arg_tys (ForeignTarget e _) = do     mayNotMentionCallerSavedRegs (text "foreign target") e     _ <- lintCmmExpr e     return ()-lintTarget (PrimTarget {})     = 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@@ -262,17 +267,8 @@ -- just a basic error monad:  newtype CmmLint a = CmmLint { unCL :: Platform -> Either SDoc a }-    deriving (Functor)--instance Applicative CmmLint where-      pure a = CmmLint (\_ -> Right a)-      (<*>) = ap--instance Monad CmmLint where-  CmmLint m >>= k = CmmLint $ \platform ->-                                case m platform of-                                Left e -> Left e-                                Right a -> unCL (k a) platform+  deriving stock (Functor)+  deriving (Applicative, Monad) via ReaderT Platform (Except SDoc)  getPlatform :: CmmLint Platform getPlatform = CmmLint $ \platform -> Right platform@@ -294,6 +290,13 @@                    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
GHC/Cmm/Liveness.hs view
@@ -1,7 +1,4 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-}-{-# LANGUAGE ScopedTypeVariables #-}  module GHC.Cmm.Liveness     ( CmmLocalLive@@ -20,9 +17,7 @@ import GHC.Platform import GHC.Cmm.BlockId import GHC.Cmm-import GHC.Cmm.Ppr.Expr () -- For Outputable instances import GHC.Cmm.Dataflow.Block-import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow import GHC.Cmm.Dataflow.Label import GHC.Cmm.LRegSet@@ -31,8 +26,6 @@ import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Types.Unique- ----------------------------------------------------------------------------- -- Calculating what variables are live on entry to a basic block -----------------------------------------------------------------------------@@ -64,9 +57,9 @@   where     entry = g_entry graph     check facts =-        noLiveOnEntry entry (expectJust "check" $ mapLookup entry facts) facts+        noLiveOnEntry entry (expectJust $ mapLookup entry facts) facts -cmmGlobalLiveness :: Platform -> CmmGraph -> BlockEntryLiveness GlobalReg+cmmGlobalLiveness :: Platform -> CmmGraph -> BlockEntryLiveness GlobalRegUse cmmGlobalLiveness platform graph =     analyzeCmmBwd liveLattice (xferLive platform) graph mapEmpty @@ -99,12 +92,12 @@         !result = foldNodesBwdOO (gen_kill platform) middle joined     in mapSingleton (entryLabel eNode) result {-# SPECIALIZE xferLive :: Platform -> TransferFun (CmmLive LocalReg) #-}-{-# SPECIALIZE xferLive :: Platform -> TransferFun (CmmLive GlobalReg) #-}+{-# SPECIALIZE xferLive :: Platform -> TransferFun (CmmLive GlobalRegUse) #-}  ----------------------------------------------------------------------------- -- | Specialization that only retains the keys for local variables. ----- Local variablas are mostly glorified Ints, and some parts of the compiler+-- 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.@@ -117,7 +110,7 @@ liveLatticeL = DataflowLattice emptyLRegSet add   where     add (OldFact old) (NewFact new) =-        let !join = plusLRegSet old new+        let !join = unionLRegSet old new         in changedIf (sizeLRegSet join > sizeLRegSet old) join  @@ -127,7 +120,7 @@   where     entry = g_entry graph     check facts =-        noLiveOnEntryL entry (expectJust "check" $ mapLookup entry facts) 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@@ -137,7 +130,7 @@     where         -- We convert the int's to uniques so that the printing matches that         -- of registers.-        reg_uniques = map mkUniqueGrimily $ elemsLRegSet in_fact+        reg_uniques = elemsLRegSet in_fact   @@ -161,5 +154,4 @@     let joined = gen_killL platform xNode $! joinOutFacts liveLatticeL xNode fBase         !result = foldNodesBwdOO (gen_killL platform) middle joined     in mapSingleton (entryLabel eNode) result-
GHC/Cmm/MachOp.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+{-# LANGUAGE LambdaCase #-}  module GHC.Cmm.MachOp     ( MachOp(..)@@ -22,9 +22,14 @@     , CallishMachOp(..), callishMachOpHints     , pprCallishMachOp     , machOpMemcpyishAlign+    , callishMachOpArgTys      -- Atomic read-modify-write+    , MemoryOrdering(..)     , AtomicMachOp(..)++    -- Fused multiply-add+    , FMASign(..), pprFMASign    ) where @@ -33,7 +38,10 @@ import GHC.Platform import GHC.Cmm.Type import GHC.Utils.Outputable+import GHC.Utils.Misc (expectNonEmpty) +import Data.List.NonEmpty (NonEmpty (..))+ ----------------------------------------------------------------------------- --              MachOp -----------------------------------------------------------------------------@@ -50,6 +58,25 @@ 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@@ -59,13 +86,13 @@   | MO_Mul Width                -- low word of multiply    -- Signed multiply/divide-  | MO_S_MulMayOflo Width       -- nonzero if signed multiply overflows+  | 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_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) @@ -88,6 +115,10 @@   | 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@@ -96,6 +127,9 @@   | 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@@ -110,8 +144,8 @@    -- 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_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@@ -122,29 +156,30 @@                                 -- 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_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_Insert  Length Width   -- Insert scalar into vector-  | MO_V_Extract Length Width   -- Extract scalar from vector+  | 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--  -- 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+  -- Vector shuffles+  | MO_V_Shuffle  Length Width [Int]+  | MO_VF_Shuffle Length Width [Int]    -- Floating 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+  | 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@@ -153,6 +188,18 @@   | 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)@@ -160,7 +207,30 @@ 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@@ -251,12 +321,13 @@         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+        MO_F_Min {}             -> True+        MO_F_Max {}             -> True         _other                  -> False  -- ----------------------------------------------------------------------------@@ -351,16 +422,16 @@ 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)+        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  -- ----------------------------------------------------------------------------@@ -374,14 +445,13 @@   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_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@@ -395,11 +465,16 @@     MO_U_Gt {}          -> comparisonResultRep platform     MO_U_Lt {}          -> comparisonResultRep platform -    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_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@@ -410,18 +485,21 @@     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_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_Conv _ to     -> cmmBits to-    MO_SF_Conv _ to     -> cmmFloat 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 @@ -429,13 +507,17 @@     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_VS_Min  l w      -> cmmVec l (cmmBits w)+    MO_VS_Max  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_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 @@ -444,10 +526,13 @@     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:_) = tys+    ty1:|_ = expectNonEmpty tys  comparisonResultRep :: Platform -> CmmType comparisonResultRep = bWord  -- is it?@@ -464,81 +549,98 @@ machOpArgReps :: Platform -> MachOp -> [Width] machOpArgReps platform 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_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 r           -> [r,r]-    MO_S_Le r           -> [r,r]-    MO_S_Gt r           -> [r,r]-    MO_S_Lt r           -> [r,r]+    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 r           -> [r,r]-    MO_U_Le r           -> [r,r]-    MO_U_Gt r           -> [r,r]-    MO_U_Lt r           -> [r,r]+    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 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_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_And   r          -> [r,r]-    MO_Or    r          -> [r,r]-    MO_Xor   r          -> [r,r]-    MO_Not   r          -> [r]-    MO_Shl   r          -> [r, wordWidth platform]-    MO_U_Shr r          -> [r, wordWidth platform]-    MO_S_Shr r          -> [r, wordWidth platform]+    MO_FMA _ l w        -> [vecwidth l w, vecwidth l w, vecwidth l w] -    MO_SS_Conv from _   -> [from]-    MO_UU_Conv from _   -> [from]-    MO_XX_Conv from _   -> [from]-    MO_SF_Conv from _   -> [from]-    MO_FS_Conv from _   -> [from]-    MO_FF_Conv from _   -> [from]+    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_V_Insert  l r    -> [typeWidth (vec l (cmmBits r)),r,wordWidth platform]-    MO_V_Extract l r    -> [typeWidth (vec l (cmmBits r)),wordWidth platform]+    MO_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_V_Add _ r        -> [r,r]-    MO_V_Sub _ r        -> [r,r]-    MO_V_Mul _ r        -> [r,r]+    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_VS_Quot _ r      -> [r,r]-    MO_VS_Rem  _ r      -> [r,r]-    MO_VS_Neg  _ r      -> [r]+    MO_V_Shuffle  l w _ -> [vecwidth l w, vecwidth l w]+    MO_VF_Shuffle l w _ -> [vecwidth l w, vecwidth l w] -    MO_VU_Quot _ r      -> [r,r]-    MO_VU_Rem  _ r      -> [r,r]+    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_VF_Insert  l r   -> [typeWidth (vec l (cmmFloat r)),r,wordWidth platform]-    MO_VF_Extract l r   -> [typeWidth (vec l (cmmFloat r)),wordWidth platform]+    MO_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_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]+    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_AlignmentCheck _ r -> [r]+    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 -----------------------------------------------------------------------------@@ -635,8 +737,20 @@   | MO_SubIntC   Width   | MO_U_Mul2    Width -  | MO_ReadBarrier-  | MO_WriteBarrier+  -- 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@@ -666,10 +780,16 @@   | MO_BSwap Width   | MO_BRev Width -  -- Atomic read-modify-write.+  | MO_AcquireFence+  | MO_ReleaseFence+  | MO_SeqCstFence++  -- | Atomic read-modify-write. Arguments are @[dest, n]@.   | MO_AtomicRMW Width AtomicMachOp-  | MO_AtomicRead Width-  | MO_AtomicWrite Width+  -- | 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?@@ -684,6 +804,14 @@   | 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@@ -717,3 +845,144 @@   MO_Memmove align -> Just align   MO_Memcmp  align -> Just align   _                -> Nothing++-- | Like 'machOpArgReps', but for 'CallishMachOp'.+--+-- Used only in Cmm lint.+callishMachOpArgTys :: Platform -> CallishMachOp -> [CmmType]+callishMachOpArgTys platform = \case+  MO_F64_Pwr -> [f64, f64]+  MO_F64_Sin -> [f64]+  MO_F64_Cos -> [f64]+  MO_F64_Tan -> [f64]+  MO_F64_Sinh -> [f64]+  MO_F64_Cosh -> [f64]+  MO_F64_Tanh -> [f64]+  MO_F64_Asin -> [f64]+  MO_F64_Acos -> [f64]+  MO_F64_Atan -> [f64]+  MO_F64_Asinh -> [f64]+  MO_F64_Acosh -> [f64]+  MO_F64_Atanh -> [f64]+  MO_F64_Log -> [f64]+  MO_F64_Log1P -> [f64]+  MO_F64_Exp -> [f64]+  MO_F64_ExpM1 -> [f64]+  MO_F64_Fabs -> [f64]+  MO_F64_Sqrt -> [f64]+  MO_F32_Pwr -> [f32, f32]+  MO_F32_Sin -> [f32]+  MO_F32_Cos -> [f32]+  MO_F32_Tan -> [f32]+  MO_F32_Sinh -> [f32]+  MO_F32_Cosh -> [f32]+  MO_F32_Tanh -> [f32]+  MO_F32_Asin -> [f32]+  MO_F32_Acos -> [f32]+  MO_F32_Atan -> [f32]+  MO_F32_Asinh -> [f32]+  MO_F32_Acosh -> [f32]+  MO_F32_Atanh -> [f32]+  MO_F32_Log -> [f32]+  MO_F32_Log1P -> [f32]+  MO_F32_Exp -> [f32]+  MO_F32_ExpM1 -> [f32]+  MO_F32_Fabs -> [f32]+  MO_F32_Sqrt -> [f32]+  MO_I64_ToI -> [b64]+  MO_I64_FromI -> [bWord platform]+  MO_W64_ToW -> [b64]+  MO_W64_FromW -> [bWord platform]+  MO_x64_Neg -> [b64]+  MO_x64_Add -> [b64]+  MO_x64_Sub -> [b64]+  MO_x64_Mul -> [b64]+  MO_I64_Quot -> [b64,b64]+  MO_I64_Rem -> [b64,b64]+  MO_W64_Quot -> [b64,b64]+  MO_W64_Rem -> [b64,b64]+  MO_x64_And -> [b64,b64]+  MO_x64_Or -> [b64,b64]+  MO_x64_Xor -> [b64,b64]+  MO_x64_Not -> [b64]+  MO_x64_Shl -> [b64,b64]+  MO_I64_Shr -> [b64,b64]+  MO_W64_Shr -> [b64,b64]+  MO_x64_Eq -> [b64,b64]+  MO_x64_Ne -> [b64,b64]+  MO_I64_Ge -> [b64,b64]+  MO_I64_Gt -> [b64,b64]+  MO_I64_Le -> [b64,b64]+  MO_I64_Lt -> [b64,b64]+  MO_W64_Ge -> [b64,b64]+  MO_W64_Gt -> [b64,b64]+  MO_W64_Le -> [b64,b64]+  MO_W64_Lt -> [b64,b64]+  MO_UF_Conv _w -> [bWord platform] -- Word to Float/Double+  MO_S_Mul2    w -> [cmmBits w, cmmBits w]+  MO_S_QuotRem w -> [cmmBits w, cmmBits w]+  MO_U_QuotRem w -> [cmmBits w, cmmBits w]+  MO_U_QuotRem2 w -> [cmmBits w, cmmBits w]+  MO_Add2      w -> [cmmBits w, cmmBits w]+  MO_AddWordC  w -> [cmmBits w, cmmBits w]+  MO_SubWordC  w -> [cmmBits w, cmmBits w]+  MO_AddIntC   w -> [cmmBits w, cmmBits w]+  MO_SubIntC   w -> [cmmBits w, cmmBits w]+  MO_U_Mul2    w -> [cmmBits w, cmmBits w]+  MO_VS_Quot l w -> [cmmVec l (cmmBits w), cmmVec l (cmmBits w)]+  MO_VS_Rem  l w -> [cmmVec l (cmmBits w), cmmVec l (cmmBits w)]+  MO_VU_Quot l w -> [cmmVec l (cmmBits w), cmmVec l (cmmBits w)]+  MO_VU_Rem  l w -> [cmmVec l (cmmBits w), cmmVec l (cmmBits w)]+  MO_I64X2_Min -> [cmmVec 2 (cmmBits W64), cmmVec 2 (cmmBits W64)]+  MO_I64X2_Max -> [cmmVec 2 (cmmBits W64), cmmVec 2 (cmmBits W64)]+  MO_W64X2_Min -> [cmmVec 2 (cmmBits W64), cmmVec 2 (cmmBits W64)]+  MO_W64X2_Max -> [cmmVec 2 (cmmBits W64), cmmVec 2 (cmmBits W64)]+  MO_Touch -> [gcWord platform]+  MO_Prefetch_Data _n -> [addr]+  MO_Memcpy _align -> [addr, addr, bWord platform]+  MO_Memset _align ->+    [ addr+    , bWord platform -- byte to set: supplied as an int, converted to a byte+    , bWord platform]+  MO_Memmove _align -> [addr, addr, bWord platform]+  MO_Memcmp _align -> [addr, addr, bWord platform]+  MO_PopCnt w ->+    case w of+      W64 -> [cmmBits W64]+      _   -> [bWord platform]+  MO_Pdep w ->+    case w of+      W64 -> [cmmBits W64, cmmBits W64]+      _   -> [bWord platform, bWord platform]+  MO_Pext w ->+    case w of+      W64 -> [cmmBits W64, cmmBits W64]+      _   -> [bWord platform, bWord platform]+  MO_Clz w ->+    case w of+      W64 -> [cmmBits W64]+      _   -> [bWord platform]+  MO_Ctz w ->+    case w of+      W64 -> [cmmBits W64]+      _   -> [bWord platform]+  MO_BSwap w ->+    case w of+      W64 -> [cmmBits W64]+      _   -> [bWord platform]+  MO_BRev w ->+    case w of+      W64 -> [cmmBits W64]+      _   -> [bWord platform]+  MO_AcquireFence -> []+  MO_ReleaseFence -> []+  MO_SeqCstFence -> []+  MO_AtomicRMW w _op -> [addr, cmmBits w]+  MO_AtomicRead _w _mem_ordering -> [addr]+  MO_AtomicWrite w _mem_ordering -> [addr, cmmBits w]+  MO_Cmpxchg w -> [addr, cmmBits w, cmmBits w]+  MO_Xchg w -> [addr, cmmBits w]+  MO_SuspendThread -> []+  MO_ResumeThread -> []+  where+    addr = bWord platform
GHC/Cmm/Node.hs view
@@ -1,15 +1,7 @@-{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-}--{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}+{-# LANGUAGE LambdaCase #-}  -- CmmNode type for representation using Hoopl graphs. @@ -28,23 +20,28 @@ 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.Collections 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.Misc+import GHC.Utils.Constants (debugIsOn)   ------------------------@@ -121,7 +118,7 @@           -- occur in CmmExprs, namely as (CmmLit (CmmBlock b)) or           -- (CmmStackSlot (Young b) _). -      cml_args_regs :: [GlobalReg],+      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@@ -165,6 +162,177 @@       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;@@ -291,11 +459,25 @@         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@@ -304,6 +486,35 @@         CallishMachOp            -- Which one   deriving Eq +instance OutputableP Platform ForeignTarget where+    pdoc = pprForeignTarget++pprForeignTarget :: Platform -> ForeignTarget -> SDoc+pprForeignTarget platform (ForeignTarget fn c) =+    ppr c <+> ppr_target fn+  where+    ppr_target :: CmmExpr -> SDoc+    ppr_target t@(CmmLit _) = pdoc platform t+    ppr_target fn'          = parens (pdoc platform fn')+pprForeignTarget platform (PrimTarget op)+ -- HACK: We're just using a ForeignLabel to get this printed, the label+ --       might not really be foreign.+ = pdoc platform+               (mkForeignLabel+                          (mkFastString (show op))+                          ForeignLabelInThisPackage IsFunction)++instance Outputable Convention where+  ppr = pprConvention++pprConvention :: Convention -> SDoc+pprConvention (NativeNodeCall   {}) = text "<native-node-call-convention>"+pprConvention (NativeDirectCall {}) = text "<native-direct-call-convention>"+pprConvention (NativeReturn {})     = text "<native-ret-convention>"+pprConvention  Slow                 = text "<slow-convention>"+pprConvention  GC                   = text "<gc-convention>"++ foreignTargetHints :: ForeignTarget -> ([ForeignHint], [ForeignHint]) foreignTargetHints target   = ( res_hints ++ repeat NoHint@@ -333,7 +544,7 @@                => (b -> LocalReg -> b) -> b -> a -> b           fold f z n = foldRegsUsed platform f z n -instance UserOfRegs GlobalReg (CmmNode e x) where+instance UserOfRegs GlobalRegUse (CmmNode e x) where   {-# INLINEABLE foldRegsUsed #-}   foldRegsUsed platform f !z n = case n of     CmmAssign _ expr -> fold f z expr@@ -344,10 +555,9 @@     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+    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@@ -366,7 +576,7 @@                => (b -> LocalReg -> b) -> b -> a -> b           fold f z n = foldRegsDefd platform f z n -instance DefinerOfRegs GlobalReg (CmmNode e x) where+instance DefinerOfRegs GlobalRegUse (CmmNode e x) where   {-# INLINEABLE foldRegsDefd #-}   foldRegsDefd platform f !z n = case n of     CmmAssign lhs _ -> fold f z lhs@@ -375,12 +585,13 @@     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+    where fold :: forall a b. DefinerOfRegs GlobalRegUse a+               => (b -> GlobalRegUse -> b) -> b -> a -> b           fold f z n = foldRegsDefd platform f z n -          activeRegs = activeStgRegs platform-          activeCallerSavesRegs = filter (callerSaves platform) activeRegs+          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@@ -505,7 +716,7 @@ 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)   = (\[addr', e'] -> CmmStore addr' e' align) `fmap` mapListM f [addr, 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@@ -693,7 +904,7 @@   compare GlobalScope    _               = LT   compare _              GlobalScope     = GT   compare (SubScope u _) (SubScope u' _) = nonDetCmpUnique u u'-  compare scope scope'                   = cmpList nonDetCmpUnique+  compare scope scope'                   = liftCompare nonDetCmpUnique      (sortBy nonDetCmpUnique $ scopeUniques scope)      (sortBy nonDetCmpUnique $ scopeUniques scope')
GHC/Cmm/Opt.hs view
@@ -5,7 +5,6 @@ -- (c) The University of Glasgow 2006 -- ------------------------------------------------------------------------------ module GHC.Cmm.Opt (         constantFoldNode,         constantFoldExpr,@@ -20,9 +19,11 @@ 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@@ -55,22 +56,60 @@     -> 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 (-x) rep)+      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_Conv _from to -> CmmLit (CmmFloat (fromInteger x) to)+      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 _)]@@ -135,9 +174,9 @@         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 (x + y) r)-        MO_Sub r -> Just $! CmmLit (CmmInt (x - y) r)-        MO_Mul r -> Just $! CmmLit (CmmInt (x * y) r)+        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)@@ -147,7 +186,7 @@         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_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) @@ -213,23 +252,33 @@   = Just $! CmmMachOp op [pic, CmmLit $ cmmOffsetLit lit off ]   where off = fromIntegral (narrowS rep n) --- Make a RegOff if we can+-- 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))))  @@ -410,6 +459,13 @@  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@@ -420,10 +476,9 @@ That's what the constant-folding operations on comparison operators do above. -} - -- ----------------------------------------------------------------------------- -- Utils  isPicReg :: CmmExpr -> Bool-isPicReg (CmmReg (CmmGlobal PicBaseReg)) = True+isPicReg (CmmReg (CmmGlobal (GlobalRegUse PicBaseReg _))) = True isPicReg _ = False
GHC/Cmm/Parser.hs view
@@ -5,3374 +5,3566 @@ #endif {-# LANGUAGE TupleSections #-} -module GHC.Cmm.Parser ( parseCmmFile ) where--import GHC.Prelude-import qualified Prelude -- for happy-generated code--import GHC.Driver.Session-import GHC.Driver.Ppr-import GHC.Driver.Config.Parser (initParserOpts)-import GHC.Driver.Config.StgToCmm--import GHC.Platform-import GHC.Platform.Profile--import GHC.StgToCmm.ExtCode-import GHC.StgToCmm.Heap-import GHC.StgToCmm.Monad hiding ( getCode, getCodeR, getCodeScoped, emitLabel, emit-                                 , emitStore, emitAssign, emitOutOfLine, withUpdFrameOff-                                 , getUpdFrameOff, getProfile, getPlatform, getContext)-import qualified GHC.StgToCmm.Monad as F-import GHC.StgToCmm.Utils-import GHC.StgToCmm.Foreign-import GHC.StgToCmm.Expr-import GHC.StgToCmm.Lit-import GHC.StgToCmm.Closure-import GHC.StgToCmm.Config-import GHC.StgToCmm.Layout     hiding (ArgRep(..))-import GHC.StgToCmm.Ticky-import GHC.StgToCmm.Prof-import GHC.StgToCmm.Bind  ( emitBlackHoleCode, emitUpdateFrame )--import GHC.Cmm.Opt-import GHC.Cmm.Graph-import GHC.Cmm-import GHC.Cmm.Utils-import GHC.Cmm.Switch     ( mkSwitchTargets )-import GHC.Cmm.Info-import GHC.Cmm.BlockId-import GHC.Cmm.Lexer-import GHC.Cmm.CLabel-import GHC.Cmm.Parser.Monad hiding (getPlatform, getProfile)-import qualified GHC.Cmm.Parser.Monad as PD-import GHC.Cmm.CallConv-import GHC.Runtime.Heap.Layout-import GHC.Parser.Lexer-import GHC.Parser.Errors.Types-import GHC.Parser.Errors.Ppr--import GHC.Types.CostCentre-import GHC.Types.ForeignCall-import GHC.Unit.Module-import GHC.Unit.Home-import GHC.Types.Literal-import GHC.Types.Unique-import GHC.Types.Unique.FM-import GHC.Types.SrcLoc-import GHC.Types.Tickish  ( GenTickish(SourceNote) )-import GHC.Utils.Error-import GHC.Data.StringBuffer-import GHC.Data.FastString-import GHC.Utils.Panic-import GHC.Settings.Constants-import GHC.Utils.Outputable-import GHC.Types.Basic-import GHC.Data.Bag     ( Bag, emptyBag, unitBag, isEmptyBag )-import GHC.Types.Var--import Control.Monad-import Data.Array-import Data.Char        ( ord )-import System.Exit-import Data.Maybe-import qualified Data.Map as M-import qualified Data.ByteString.Char8 as BS8-import qualified Data.Array as Happy_Data_Array-import qualified Data.Bits as Bits-import qualified GHC.Exts as Happy_GHC_Exts-import Control.Applicative(Applicative(..))-import Control.Monad (ap)---- parser produced by Happy Version 1.20.0--newtype HappyAbsSyn  = HappyAbsSyn HappyAny-#if __GLASGOW_HASKELL__ >= 607-type HappyAny = Happy_GHC_Exts.Any-#else-type HappyAny = forall a . a-#endif-newtype HappyWrap4 = HappyWrap4 (CmmParse ())-happyIn4 :: (CmmParse ()) -> (HappyAbsSyn )-happyIn4 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap4 x)-{-# INLINE happyIn4 #-}-happyOut4 :: (HappyAbsSyn ) -> HappyWrap4-happyOut4 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut4 #-}-newtype HappyWrap5 = HappyWrap5 (CmmParse ())-happyIn5 :: (CmmParse ()) -> (HappyAbsSyn )-happyIn5 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap5 x)-{-# INLINE happyIn5 #-}-happyOut5 :: (HappyAbsSyn ) -> HappyWrap5-happyOut5 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut5 #-}-newtype HappyWrap6 = HappyWrap6 (CmmParse ())-happyIn6 :: (CmmParse ()) -> (HappyAbsSyn )-happyIn6 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap6 x)-{-# INLINE happyIn6 #-}-happyOut6 :: (HappyAbsSyn ) -> HappyWrap6-happyOut6 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut6 #-}-newtype HappyWrap7 = HappyWrap7 (CmmParse CLabel)-happyIn7 :: (CmmParse CLabel) -> (HappyAbsSyn )-happyIn7 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap7 x)-{-# INLINE happyIn7 #-}-happyOut7 :: (HappyAbsSyn ) -> HappyWrap7-happyOut7 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut7 #-}-newtype HappyWrap8 = HappyWrap8 ([CmmParse [CmmStatic]])-happyIn8 :: ([CmmParse [CmmStatic]]) -> (HappyAbsSyn )-happyIn8 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap8 x)-{-# INLINE happyIn8 #-}-happyOut8 :: (HappyAbsSyn ) -> HappyWrap8-happyOut8 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut8 #-}-newtype HappyWrap9 = HappyWrap9 (CmmParse [CmmStatic])-happyIn9 :: (CmmParse [CmmStatic]) -> (HappyAbsSyn )-happyIn9 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap9 x)-{-# INLINE happyIn9 #-}-happyOut9 :: (HappyAbsSyn ) -> HappyWrap9-happyOut9 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut9 #-}-newtype HappyWrap10 = HappyWrap10 ([CmmParse CmmExpr])-happyIn10 :: ([CmmParse CmmExpr]) -> (HappyAbsSyn )-happyIn10 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap10 x)-{-# INLINE happyIn10 #-}-happyOut10 :: (HappyAbsSyn ) -> HappyWrap10-happyOut10 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut10 #-}-newtype HappyWrap11 = HappyWrap11 (CmmParse ())-happyIn11 :: (CmmParse ()) -> (HappyAbsSyn )-happyIn11 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap11 x)-{-# INLINE happyIn11 #-}-happyOut11 :: (HappyAbsSyn ) -> HappyWrap11-happyOut11 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut11 #-}-newtype HappyWrap12 = HappyWrap12 (Convention)-happyIn12 :: (Convention) -> (HappyAbsSyn )-happyIn12 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap12 x)-{-# INLINE happyIn12 #-}-happyOut12 :: (HappyAbsSyn ) -> HappyWrap12-happyOut12 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut12 #-}-newtype HappyWrap13 = HappyWrap13 (CmmParse ())-happyIn13 :: (CmmParse ()) -> (HappyAbsSyn )-happyIn13 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap13 x)-{-# INLINE happyIn13 #-}-happyOut13 :: (HappyAbsSyn ) -> HappyWrap13-happyOut13 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut13 #-}-newtype HappyWrap14 = HappyWrap14 (CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]))-happyIn14 :: (CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg])) -> (HappyAbsSyn )-happyIn14 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap14 x)-{-# INLINE happyIn14 #-}-happyOut14 :: (HappyAbsSyn ) -> HappyWrap14-happyOut14 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut14 #-}-newtype HappyWrap15 = HappyWrap15 (CmmParse ())-happyIn15 :: (CmmParse ()) -> (HappyAbsSyn )-happyIn15 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap15 x)-{-# INLINE happyIn15 #-}-happyOut15 :: (HappyAbsSyn ) -> HappyWrap15-happyOut15 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut15 #-}-newtype HappyWrap16 = HappyWrap16 (CmmParse ())-happyIn16 :: (CmmParse ()) -> (HappyAbsSyn )-happyIn16 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap16 x)-{-# INLINE happyIn16 #-}-happyOut16 :: (HappyAbsSyn ) -> HappyWrap16-happyOut16 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut16 #-}-newtype HappyWrap17 = HappyWrap17 ([(FastString, CLabel)])-happyIn17 :: ([(FastString, CLabel)]) -> (HappyAbsSyn )-happyIn17 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap17 x)-{-# INLINE happyIn17 #-}-happyOut17 :: (HappyAbsSyn ) -> HappyWrap17-happyOut17 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut17 #-}-newtype HappyWrap18 = HappyWrap18 ((FastString,  CLabel))-happyIn18 :: ((FastString,  CLabel)) -> (HappyAbsSyn )-happyIn18 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap18 x)-{-# INLINE happyIn18 #-}-happyOut18 :: (HappyAbsSyn ) -> HappyWrap18-happyOut18 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut18 #-}-newtype HappyWrap19 = HappyWrap19 ([FastString])-happyIn19 :: ([FastString]) -> (HappyAbsSyn )-happyIn19 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap19 x)-{-# INLINE happyIn19 #-}-happyOut19 :: (HappyAbsSyn ) -> HappyWrap19-happyOut19 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut19 #-}-newtype HappyWrap20 = HappyWrap20 (CmmParse ())-happyIn20 :: (CmmParse ()) -> (HappyAbsSyn )-happyIn20 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap20 x)-{-# INLINE happyIn20 #-}-happyOut20 :: (HappyAbsSyn ) -> HappyWrap20-happyOut20 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut20 #-}-newtype HappyWrap21 = HappyWrap21 (CmmParse [(GlobalReg, Maybe CmmExpr)])-happyIn21 :: (CmmParse [(GlobalReg, Maybe CmmExpr)]) -> (HappyAbsSyn )-happyIn21 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap21 x)-{-# INLINE happyIn21 #-}-happyOut21 :: (HappyAbsSyn ) -> HappyWrap21-happyOut21 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut21 #-}-newtype HappyWrap22 = HappyWrap22 (CmmParse (Maybe CmmExpr))-happyIn22 :: (CmmParse (Maybe CmmExpr)) -> (HappyAbsSyn )-happyIn22 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap22 x)-{-# INLINE happyIn22 #-}-happyOut22 :: (HappyAbsSyn ) -> HappyWrap22-happyOut22 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut22 #-}-newtype HappyWrap23 = HappyWrap23 (CmmParse CmmExpr)-happyIn23 :: (CmmParse CmmExpr) -> (HappyAbsSyn )-happyIn23 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap23 x)-{-# INLINE happyIn23 #-}-happyOut23 :: (HappyAbsSyn ) -> HappyWrap23-happyOut23 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut23 #-}-newtype HappyWrap24 = HappyWrap24 (CmmReturnInfo)-happyIn24 :: (CmmReturnInfo) -> (HappyAbsSyn )-happyIn24 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap24 x)-{-# INLINE happyIn24 #-}-happyOut24 :: (HappyAbsSyn ) -> HappyWrap24-happyOut24 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut24 #-}-newtype HappyWrap25 = HappyWrap25 (CmmParse BoolExpr)-happyIn25 :: (CmmParse BoolExpr) -> (HappyAbsSyn )-happyIn25 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap25 x)-{-# INLINE happyIn25 #-}-happyOut25 :: (HappyAbsSyn ) -> HappyWrap25-happyOut25 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut25 #-}-newtype HappyWrap26 = HappyWrap26 (CmmParse BoolExpr)-happyIn26 :: (CmmParse BoolExpr) -> (HappyAbsSyn )-happyIn26 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap26 x)-{-# INLINE happyIn26 #-}-happyOut26 :: (HappyAbsSyn ) -> HappyWrap26-happyOut26 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut26 #-}-newtype HappyWrap27 = HappyWrap27 (Safety)-happyIn27 :: (Safety) -> (HappyAbsSyn )-happyIn27 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap27 x)-{-# INLINE happyIn27 #-}-happyOut27 :: (HappyAbsSyn ) -> HappyWrap27-happyOut27 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut27 #-}-newtype HappyWrap28 = HappyWrap28 ([GlobalReg])-happyIn28 :: ([GlobalReg]) -> (HappyAbsSyn )-happyIn28 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap28 x)-{-# INLINE happyIn28 #-}-happyOut28 :: (HappyAbsSyn ) -> HappyWrap28-happyOut28 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut28 #-}-newtype HappyWrap29 = HappyWrap29 ([GlobalReg])-happyIn29 :: ([GlobalReg]) -> (HappyAbsSyn )-happyIn29 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap29 x)-{-# INLINE happyIn29 #-}-happyOut29 :: (HappyAbsSyn ) -> HappyWrap29-happyOut29 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut29 #-}-newtype HappyWrap30 = HappyWrap30 (Maybe (Integer,Integer))-happyIn30 :: (Maybe (Integer,Integer)) -> (HappyAbsSyn )-happyIn30 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap30 x)-{-# INLINE happyIn30 #-}-happyOut30 :: (HappyAbsSyn ) -> HappyWrap30-happyOut30 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut30 #-}-newtype HappyWrap31 = HappyWrap31 ([CmmParse ([Integer],Either BlockId (CmmParse ()))])-happyIn31 :: ([CmmParse ([Integer],Either BlockId (CmmParse ()))]) -> (HappyAbsSyn )-happyIn31 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap31 x)-{-# INLINE happyIn31 #-}-happyOut31 :: (HappyAbsSyn ) -> HappyWrap31-happyOut31 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut31 #-}-newtype HappyWrap32 = HappyWrap32 (CmmParse ([Integer],Either BlockId (CmmParse ())))-happyIn32 :: (CmmParse ([Integer],Either BlockId (CmmParse ()))) -> (HappyAbsSyn )-happyIn32 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap32 x)-{-# INLINE happyIn32 #-}-happyOut32 :: (HappyAbsSyn ) -> HappyWrap32-happyOut32 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut32 #-}-newtype HappyWrap33 = HappyWrap33 (CmmParse (Either BlockId (CmmParse ())))-happyIn33 :: (CmmParse (Either BlockId (CmmParse ()))) -> (HappyAbsSyn )-happyIn33 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap33 x)-{-# INLINE happyIn33 #-}-happyOut33 :: (HappyAbsSyn ) -> HappyWrap33-happyOut33 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut33 #-}-newtype HappyWrap34 = HappyWrap34 ([Integer])-happyIn34 :: ([Integer]) -> (HappyAbsSyn )-happyIn34 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap34 x)-{-# INLINE happyIn34 #-}-happyOut34 :: (HappyAbsSyn ) -> HappyWrap34-happyOut34 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut34 #-}-newtype HappyWrap35 = HappyWrap35 (Maybe (CmmParse ()))-happyIn35 :: (Maybe (CmmParse ())) -> (HappyAbsSyn )-happyIn35 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap35 x)-{-# INLINE happyIn35 #-}-happyOut35 :: (HappyAbsSyn ) -> HappyWrap35-happyOut35 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut35 #-}-newtype HappyWrap36 = HappyWrap36 (CmmParse ())-happyIn36 :: (CmmParse ()) -> (HappyAbsSyn )-happyIn36 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap36 x)-{-# INLINE happyIn36 #-}-happyOut36 :: (HappyAbsSyn ) -> HappyWrap36-happyOut36 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut36 #-}-newtype HappyWrap37 = HappyWrap37 (Maybe Bool)-happyIn37 :: (Maybe Bool) -> (HappyAbsSyn )-happyIn37 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap37 x)-{-# INLINE happyIn37 #-}-happyOut37 :: (HappyAbsSyn ) -> HappyWrap37-happyOut37 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut37 #-}-newtype HappyWrap38 = HappyWrap38 (CmmParse CmmExpr)-happyIn38 :: (CmmParse CmmExpr) -> (HappyAbsSyn )-happyIn38 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap38 x)-{-# INLINE happyIn38 #-}-happyOut38 :: (HappyAbsSyn ) -> HappyWrap38-happyOut38 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut38 #-}-newtype HappyWrap39 = HappyWrap39 (CmmParse CmmExpr)-happyIn39 :: (CmmParse CmmExpr) -> (HappyAbsSyn )-happyIn39 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap39 x)-{-# INLINE happyIn39 #-}-happyOut39 :: (HappyAbsSyn ) -> HappyWrap39-happyOut39 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut39 #-}-newtype HappyWrap40 = HappyWrap40 (CmmParse (AlignmentSpec, CmmExpr))-happyIn40 :: (CmmParse (AlignmentSpec, CmmExpr)) -> (HappyAbsSyn )-happyIn40 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap40 x)-{-# INLINE happyIn40 #-}-happyOut40 :: (HappyAbsSyn ) -> HappyWrap40-happyOut40 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut40 #-}-newtype HappyWrap41 = HappyWrap41 (CmmType)-happyIn41 :: (CmmType) -> (HappyAbsSyn )-happyIn41 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap41 x)-{-# INLINE happyIn41 #-}-happyOut41 :: (HappyAbsSyn ) -> HappyWrap41-happyOut41 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut41 #-}-newtype HappyWrap42 = HappyWrap42 ([CmmParse (CmmExpr, ForeignHint)])-happyIn42 :: ([CmmParse (CmmExpr, ForeignHint)]) -> (HappyAbsSyn )-happyIn42 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap42 x)-{-# INLINE happyIn42 #-}-happyOut42 :: (HappyAbsSyn ) -> HappyWrap42-happyOut42 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut42 #-}-newtype HappyWrap43 = HappyWrap43 ([CmmParse (CmmExpr, ForeignHint)])-happyIn43 :: ([CmmParse (CmmExpr, ForeignHint)]) -> (HappyAbsSyn )-happyIn43 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap43 x)-{-# INLINE happyIn43 #-}-happyOut43 :: (HappyAbsSyn ) -> HappyWrap43-happyOut43 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut43 #-}-newtype HappyWrap44 = HappyWrap44 (CmmParse (CmmExpr, ForeignHint))-happyIn44 :: (CmmParse (CmmExpr, ForeignHint)) -> (HappyAbsSyn )-happyIn44 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap44 x)-{-# INLINE happyIn44 #-}-happyOut44 :: (HappyAbsSyn ) -> HappyWrap44-happyOut44 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut44 #-}-newtype HappyWrap45 = HappyWrap45 ([CmmParse CmmExpr])-happyIn45 :: ([CmmParse CmmExpr]) -> (HappyAbsSyn )-happyIn45 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap45 x)-{-# INLINE happyIn45 #-}-happyOut45 :: (HappyAbsSyn ) -> HappyWrap45-happyOut45 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut45 #-}-newtype HappyWrap46 = HappyWrap46 ([CmmParse CmmExpr])-happyIn46 :: ([CmmParse CmmExpr]) -> (HappyAbsSyn )-happyIn46 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap46 x)-{-# INLINE happyIn46 #-}-happyOut46 :: (HappyAbsSyn ) -> HappyWrap46-happyOut46 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut46 #-}-newtype HappyWrap47 = HappyWrap47 (CmmParse CmmExpr)-happyIn47 :: (CmmParse CmmExpr) -> (HappyAbsSyn )-happyIn47 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap47 x)-{-# INLINE happyIn47 #-}-happyOut47 :: (HappyAbsSyn ) -> HappyWrap47-happyOut47 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut47 #-}-newtype HappyWrap48 = HappyWrap48 ([CmmParse (LocalReg, ForeignHint)])-happyIn48 :: ([CmmParse (LocalReg, ForeignHint)]) -> (HappyAbsSyn )-happyIn48 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap48 x)-{-# INLINE happyIn48 #-}-happyOut48 :: (HappyAbsSyn ) -> HappyWrap48-happyOut48 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut48 #-}-newtype HappyWrap49 = HappyWrap49 ([CmmParse (LocalReg, ForeignHint)])-happyIn49 :: ([CmmParse (LocalReg, ForeignHint)]) -> (HappyAbsSyn )-happyIn49 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap49 x)-{-# INLINE happyIn49 #-}-happyOut49 :: (HappyAbsSyn ) -> HappyWrap49-happyOut49 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut49 #-}-newtype HappyWrap50 = HappyWrap50 (CmmParse (LocalReg, ForeignHint))-happyIn50 :: (CmmParse (LocalReg, ForeignHint)) -> (HappyAbsSyn )-happyIn50 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap50 x)-{-# INLINE happyIn50 #-}-happyOut50 :: (HappyAbsSyn ) -> HappyWrap50-happyOut50 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut50 #-}-newtype HappyWrap51 = HappyWrap51 (CmmParse LocalReg)-happyIn51 :: (CmmParse LocalReg) -> (HappyAbsSyn )-happyIn51 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap51 x)-{-# INLINE happyIn51 #-}-happyOut51 :: (HappyAbsSyn ) -> HappyWrap51-happyOut51 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut51 #-}-newtype HappyWrap52 = HappyWrap52 (CmmParse CmmReg)-happyIn52 :: (CmmParse CmmReg) -> (HappyAbsSyn )-happyIn52 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap52 x)-{-# INLINE happyIn52 #-}-happyOut52 :: (HappyAbsSyn ) -> HappyWrap52-happyOut52 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut52 #-}-newtype HappyWrap53 = HappyWrap53 (Maybe [CmmParse LocalReg])-happyIn53 :: (Maybe [CmmParse LocalReg]) -> (HappyAbsSyn )-happyIn53 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap53 x)-{-# INLINE happyIn53 #-}-happyOut53 :: (HappyAbsSyn ) -> HappyWrap53-happyOut53 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut53 #-}-newtype HappyWrap54 = HappyWrap54 ([CmmParse LocalReg])-happyIn54 :: ([CmmParse LocalReg]) -> (HappyAbsSyn )-happyIn54 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap54 x)-{-# INLINE happyIn54 #-}-happyOut54 :: (HappyAbsSyn ) -> HappyWrap54-happyOut54 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut54 #-}-newtype HappyWrap55 = HappyWrap55 ([CmmParse LocalReg])-happyIn55 :: ([CmmParse LocalReg]) -> (HappyAbsSyn )-happyIn55 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap55 x)-{-# INLINE happyIn55 #-}-happyOut55 :: (HappyAbsSyn ) -> HappyWrap55-happyOut55 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut55 #-}-newtype HappyWrap56 = HappyWrap56 (CmmParse LocalReg)-happyIn56 :: (CmmParse LocalReg) -> (HappyAbsSyn )-happyIn56 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap56 x)-{-# INLINE happyIn56 #-}-happyOut56 :: (HappyAbsSyn ) -> HappyWrap56-happyOut56 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut56 #-}-newtype HappyWrap57 = HappyWrap57 (CmmType)-happyIn57 :: (CmmType) -> (HappyAbsSyn )-happyIn57 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap57 x)-{-# INLINE happyIn57 #-}-happyOut57 :: (HappyAbsSyn ) -> HappyWrap57-happyOut57 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut57 #-}-newtype HappyWrap58 = HappyWrap58 (CmmType)-happyIn58 :: (CmmType) -> (HappyAbsSyn )-happyIn58 x = Happy_GHC_Exts.unsafeCoerce# (HappyWrap58 x)-{-# INLINE happyIn58 #-}-happyOut58 :: (HappyAbsSyn ) -> HappyWrap58-happyOut58 x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOut58 #-}-happyInTok :: (Located CmmToken) -> (HappyAbsSyn )-happyInTok x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyInTok #-}-happyOutTok :: (HappyAbsSyn ) -> (Located CmmToken)-happyOutTok x = Happy_GHC_Exts.unsafeCoerce# x-{-# INLINE happyOutTok #-}---happyExpList :: HappyAddr-happyExpList = HappyA# "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x6f\x00\x82\xff\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf8\x0d\x40\xf0\xbf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x18\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x30\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\xc0\xff\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x01\x00\x00\x00\xa0\xc7\xe6\xff\x07\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\xe8\xb1\xf9\xff\x01\x00\x00\x00\x00\x00\x00\x00\x21\x00\x00\x00\x00\xf4\xd8\xfc\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\xff\x0d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x40\x64\x40\x00\x00\x00\x00\xe0\xff\x0f\x00\x00\x00\x00\x00\x00\x00\x20\x32\x00\x00\x00\x00\x00\xf0\xff\x07\x00\x00\x00\x00\x00\x00\x00\x10\x19\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x88\x0c\x00\x00\x00\x00\x00\xfc\xff\x01\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfc\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\xff\x03\x00\x00\x00\x00\x00\x00\x00\x08\x91\x01\x00\x00\x00\x00\x80\xff\x3f\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x10\xc0\xff\xf0\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x19\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x88\x0c\x00\x00\x00\x00\x00\xfc\xff\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x22\x03\x00\x00\x00\x00\x00\xff\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf0\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x06\x00\x00\x00\x00\x00\xfe\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\xc8\x00\x00\x00\x00\x00\xc0\xff\x1f\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x19\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x88\x0c\x00\x00\x00\x00\x00\xfc\xff\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x22\x03\x00\x00\x00\x00\x00\xff\x7f\x00\x00\x00\x00\x00\x00\x00\x00\xe4\x7f\xf8\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa0\xf0\x3f\xfc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\xf8\x1f\x7e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\xc0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xc3\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x06\x04\x00\x00\x00\x00\xfe\xff\x00\x00\x00\x00\x00\x00\x00\x00\x22\x03\x02\x00\x00\x00\x00\xff\x7f\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x22\x03\x00\x00\x00\x00\x00\xff\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x80\xff\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x08\xe0\x7f\xf8\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\xf0\x3f\xfc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\xf8\x1f\x7e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x32\x00\x00\x00\x00\x00\xf0\xff\x07\x00\x00\x00\x00\x00\x00\x00\x10\x19\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x88\x0c\x00\x00\x00\x00\x00\xfc\xff\x01\x00\x00\x00\x00\x00\x00\x00\x44\x06\x00\x00\x00\x00\x00\xfe\xff\x00\x00\x00\x00\x00\x00\x00\x00\x22\x03\x00\x00\x00\x00\x00\xff\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x80\xff\x3f\x00\x00\x00\x00\x00\x00\x00\x80\xc8\x00\x00\x00\x00\x00\xc0\xff\x1f\x00\x00\x00\x00\x00\x00\x00\x40\x64\x00\x00\x00\x00\x00\xe0\xff\x0f\x00\x00\x00\x00\x00\x00\x00\x20\x32\x00\x00\x00\x00\x00\xf0\xff\x07\x00\x00\x00\x00\x00\x00\x00\x10\x19\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x88\x0c\x00\x00\x00\x00\x00\xfc\xff\x01\x00\x00\x00\x00\x00\x00\x00\x44\x06\x00\x00\x00\x00\x00\xfe\xff\x00\x00\x00\x00\x00\x00\x00\x00\x22\x03\x00\x00\x00\x00\x00\xff\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x80\xff\x3f\x00\x00\x00\x00\x00\x00\x00\x80\xc8\x00\x00\x00\x00\x00\xc0\xff\x1f\x00\x00\x00\x00\x00\x00\x00\x40\x64\x00\x00\x00\x00\x00\xe0\xff\x0f\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x0c\x08\x00\x00\x00\x00\xfc\xff\x01\x00\x00\x00\x00\x00\x00\x00\x44\x06\x04\x00\x00\x00\x00\xfe\xff\x00\x00\x00\x00\x00\x00\x00\x00\x22\x03\x00\x00\x00\x00\x00\xff\x7f\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x20\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x40\x64\x00\x00\x00\x00\x00\xe0\xff\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfe\x8f\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\xe0\x7f\xf8\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x64\x00\x00\x00\x00\x20\xe0\xff\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xc7\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfc\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\xf8\x1f\x7e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x19\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\xc8\x00\x00\x00\x00\x00\xc0\xff\x1f\x00\x00\x00\x00\x00\x00\x00\x20\xf8\x1f\x7e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x19\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xff\xf0\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x0c\x00\x00\x00\x00\x00\xfc\xff\x01\x00\x00\x00\x00\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\xe8\xb1\xf9\xff\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfe\x81\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xc0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x7f\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x3f\x30\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf0\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf8\x07\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfc\x03\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfe\x80\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3f\xc0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x0f\x60\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x0c\x00\x00\x00\x00\x00\xfc\xff\x01\x00\x00\x00\x00\x00\x00\x00\x44\x06\x00\x00\x00\x00\x00\xfe\xff\x00\x00\x00\x00\x00\x00\x00\x00\x22\x03\x00\x00\x00\x00\x00\xff\x7f\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x80\xff\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\xf0\x3f\xfc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x20\x00\x00\x00\x00\x00\xe0\xff\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x06\x00\x00\x00\x00\x00\xfe\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\xfe\x87\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\xff\xc3\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\xff\xe1\x07\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x19\x00\x00\x00\x00\x00\xf8\xff\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x91\x01\x00\x00\x00\x00\x80\xff\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x21\x00\x00\x00\x00\xf4\xd8\xfc\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x04\x00\x00\x00\x80\x1e\x9b\xff\x1f\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x01\x00\x00\x00\xa0\xc7\xe6\xff\x07\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"#--{-# NOINLINE happyExpListPerState #-}-happyExpListPerState st =-    token_strs_expected-  where token_strs = ["error","%dummy","%start_cmmParse","cmm","cmmtop","cmmdata","data_label","statics","static","lits","cmmproc","maybe_conv","maybe_body","info","body","decl","importNames","importName","names","stmt","unwind_regs","expr_or_unknown","foreignLabel","opt_never_returns","bool_expr","bool_op","safety","vols","globals","maybe_range","arms","arm","arm_body","ints","default","else","cond_likely","expr","expr0","dereference","maybe_ty","cmm_hint_exprs0","cmm_hint_exprs","cmm_hint_expr","exprs0","exprs","reg","foreign_results","foreign_formals","foreign_formal","local_lreg","lreg","maybe_formals","formals0","formals","formal","type","typenot8","':'","';'","'{'","'}'","'['","']'","'('","')'","'='","'`'","'~'","'/'","'*'","'%'","'-'","'+'","'&'","'^'","'|'","'>'","'<'","','","'!'","'..'","'::'","'>>'","'<<'","'>='","'<='","'=='","'!='","'&&'","'||'","'True'","'False'","'likely'","'CLOSURE'","'INFO_TABLE'","'INFO_TABLE_RET'","'INFO_TABLE_FUN'","'INFO_TABLE_CONSTR'","'INFO_TABLE_SELECTOR'","'else'","'export'","'section'","'goto'","'if'","'call'","'jump'","'foreign'","'never'","'prim'","'reserve'","'return'","'returns'","'import'","'switch'","'case'","'default'","'push'","'unwind'","'bits8'","'bits16'","'bits32'","'bits64'","'bits128'","'bits256'","'bits512'","'float32'","'float64'","'gcptr'","GLOBALREG","NAME","STRING","INT","FLOAT","%eof"]-        bit_start = st Prelude.* 135-        bit_end = (st Prelude.+ 1) Prelude.* 135-        read_bit = readArrayBit happyExpList-        bits = Prelude.map read_bit [bit_start..bit_end Prelude.- 1]-        bits_indexed = Prelude.zip bits [0..134]-        token_strs_expected = Prelude.concatMap f bits_indexed-        f (Prelude.False, _) = []-        f (Prelude.True, nr) = [token_strs Prelude.!! nr]--happyActOffsets :: HappyAddr-happyActOffsets = HappyA# "\x24\x01\x00\x00\xcb\xff\x24\x01\x00\x00\x00\x00\xe5\xff\x00\x00\xe1\xff\x00\x00\x29\x00\x35\x00\x64\x00\x78\x00\x98\x00\xbb\x00\x83\x00\x84\x00\xef\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf8\x00\xeb\x00\xb6\x00\x00\x00\xbe\x00\x12\x01\x1d\x01\x14\x01\xd8\x00\xdb\x00\x06\x01\x11\x01\x16\x01\x23\x01\x2a\x01\x27\x01\x00\x00\x00\x00\x1c\x00\x5e\x04\x00\x00\x32\x01\x64\x01\x6d\x01\x6f\x01\x71\x01\x73\x01\x44\x01\x00\x00\x57\x01\x00\x00\x00\x00\xef\xff\x00\x00\x00\x00\xfe\x00\xa5\x01\x00\x00\x5c\x01\x6e\x01\x81\x01\x83\x01\x94\x01\x84\x01\x9a\x01\x00\x00\x92\x01\x98\x01\x00\x00\x00\x00\x20\x00\xb4\x01\x20\x00\x20\x00\xf2\xff\xb1\x01\x23\x00\x00\x00\x51\x04\x99\x01\x63\x00\x72\x00\x72\x00\x72\x00\xec\x01\xef\x01\xee\x01\xae\x01\x00\x00\x16\x00\x00\x00\x5e\x04\x00\x00\xe8\x01\xea\x01\x0a\x00\xeb\x01\xed\x01\xf9\x01\x00\x00\xfe\x01\xfe\x00\xff\xff\x09\x02\x0a\x02\x0b\x02\x02\x00\xd0\x01\xcf\x01\xa1\x01\x11\x02\x00\x00\x11\x00\x00\x00\x72\x00\x72\x00\xd3\x01\x72\x00\x00\x00\x00\x00\x00\x00\x04\x02\x04\x02\x00\x00\x00\x00\xde\x01\xdf\x01\xe0\x01\x00\x00\x5e\x04\xe9\x01\x20\x02\x72\x00\x00\x00\x00\x00\x72\x00\x31\x02\x2d\x02\x72\x00\x72\x00\xf7\x01\x72\x00\xa7\x02\xf8\x01\x5f\x02\x0c\x00\x00\x00\x3b\x04\x63\x00\x63\x00\x33\x02\x2f\x02\x2e\x02\x00\x00\x3b\x02\x00\x00\xfc\x01\x72\x00\x72\x00\x03\x02\x40\x02\x00\x00\x00\x00\x00\x00\x06\x02\x07\x02\xb5\x01\x12\x02\x00\x00\x48\x02\x26\x00\x53\x02\x00\x00\x00\x00\x57\x00\x55\x02\x90\x02\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x08\x00\x3a\x02\x63\x00\x63\x00\x72\x00\x5d\x02\x25\x00\x72\x00\x7f\x00\x13\x04\x60\x02\x00\x00\x4f\x02\xdd\x01\x61\x02\x4c\x00\x00\x00\x62\x02\x27\x04\x73\x02\x6a\x02\x6e\x02\x6b\x02\x6c\x02\x6d\x02\x00\x00\x5e\x04\x00\x00\x77\x00\x70\x02\x00\x00\x90\x02\x00\x00\x72\x00\x89\x02\x47\x02\x00\x00\x72\x02\x79\x02\x50\x02\x8b\x02\x97\x02\x99\x02\x9e\x02\xa6\x02\x9d\x02\x72\x00\x2c\x02\x00\x00\x72\x00\x00\x00\x67\x02\x5e\x02\x74\x02\x00\x00\x75\x02\x00\x00\x00\x00\xb0\x02\xb3\x02\x3b\x04\x00\x00\xe9\x00\x83\x02\x81\x02\xbc\x02\x72\x00\xe9\x00\x00\x00\xc5\x02\xce\x02\x00\x00\xcf\x02\xc0\x02\x00\x00\xd4\x02\xd6\x00\xb7\x02\xe1\x02\x20\x00\x9a\x02\x4f\x04\x4f\x04\x4f\x04\x4f\x04\x8e\x00\x8e\x00\x4f\x04\x4f\x04\x63\x04\x6a\x04\x73\x04\x77\x00\x77\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x02\xdc\x02\x00\x00\xec\x02\x00\x00\xed\x02\x72\x00\x72\x00\x72\x00\x72\x00\x00\x00\xe4\x02\x0e\x01\xf3\x02\xae\x02\x00\x00\x00\x00\x1a\x00\x00\x00\x00\x00\x00\x00\xf5\x02\xc6\x02\xc8\x02\xb8\x02\x00\x00\xbf\x02\x00\x00\xee\x02\xfc\x02\xfd\x02\xff\x02\x0c\x03\x00\x00\x46\x02\x92\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcc\x02\xdf\x02\xcd\x02\xd0\x02\x00\x00\x1e\x03\x15\x03\x00\x00\x2a\x03\x2b\x03\x00\x00\x00\x00\x72\x00\x00\x00\x00\x00\x27\x03\x35\x03\x07\x03\x78\x02\xc9\x01\xd3\x00\x37\x03\x00\x00\x2d\x03\x38\x03\x3f\x03\x72\x00\x08\x03\x00\x00\x00\x00\x72\x00\x00\x00\x42\x03\x00\x00\x00\x00\x3e\x03\x44\x03\x00\x00\x09\x03\x09\x00\x46\x03\x4a\x03\x4b\x03\x4d\x03\x00\x00\x0e\x03\x10\x03\x11\x03\x00\x00\x20\x00\x24\x03\x00\x00\x20\x00\x6d\x03\x20\x00\x69\x03\x2f\x03\x00\x00\x00\x00\x00\x00\x70\x03\x3c\x03\x73\x03\x72\x03\x00\x00\x80\x03\x84\x03\x83\x03\x82\x03\x61\x03\x76\x03\x4f\x03\x3d\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x85\x03\x86\x03\x00\x00\x00\x00\x00\x00"#--happyGotoOffsets :: HappyAddr-happyGotoOffsets = HappyA# "\xbf\x00\x00\x00\x00\x00\xc3\x00\x00\x00\x00\x00\x93\x03\x00\x00\x8d\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x92\x03\x00\x00\x39\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x03\x00\x00\x00\x00\x99\x03\xde\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x94\x03\x00\x00\xa4\x03\x00\x00\x00\x00\x4b\x01\x00\x00\x00\x00\xfe\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf9\xff\x00\x00\x05\x00\xf0\x00\x00\x00\x00\x00\x9a\x03\x00\x00\xe1\x03\x00\x00\x59\x01\x53\x00\xe3\x00\x02\x03\x00\x00\x8e\x03\x00\x00\xa3\x03\x00\x00\x00\x00\x00\x00\x43\x01\x00\x00\xb0\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe5\x00\x13\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x95\x03\x00\x00\x17\x03\x19\x03\x00\x00\x28\x03\x00\x00\x00\x00\x00\x00\x97\x03\x98\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x01\x00\x00\x00\x00\x2e\x03\x00\x00\x00\x00\xa5\x02\x00\x00\x00\x00\xa8\x02\x34\x03\x00\x00\xb6\x02\x00\x00\xa0\x03\x00\x00\x9d\x03\x00\x00\x00\x00\x5b\x01\x5d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8b\x03\x43\x03\x45\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x03\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x49\x03\x5a\x03\x5e\x03\x60\x03\x6f\x03\x75\x03\x7b\x03\x8a\x03\x8c\x03\x90\x03\xa1\x03\xa5\x03\xa7\x03\xb6\x03\xbc\x03\xc2\x03\x00\x00\x00\x00\x5f\x01\x76\x01\xc4\x02\x00\x00\xb4\x03\xc7\x02\x9e\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe1\x00\x00\x00\x00\x00\xc9\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x28\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd1\x03\x00\x00\x00\x00\x00\x00\x00\x00\xcb\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd3\x03\x00\x00\x00\x00\xd5\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xca\x03\x82\x01\x00\x00\x00\x00\x51\x00\xcc\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x02\x74\x01\xd7\x03\xe8\x03\x00\x00\x00\x00\x00\x00\x00\x00\xbb\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc1\x03\x89\x01\xc4\x03\x00\x00\xd2\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe4\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe6\x02\x00\x00\x00\x00\x00\x00\x00\x00\xc6\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfb\x02\xd8\x03\x00\x00\x00\x00\xfe\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd0\x03\xcd\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfd\x00\x00\x00\x00\x00\xff\x00\x00\x00\x2b\x01\x00\x00\xd4\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"#--happyAdjustOffset :: Happy_GHC_Exts.Int# -> Happy_GHC_Exts.Int#-happyAdjustOffset off = off--happyDefActions :: HappyAddr-happyDefActions = HappyA# "\xfe\xff\x00\x00\x00\x00\xfe\xff\xfb\xff\xfc\xff\xeb\xff\xfa\xff\x00\x00\x5d\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5e\xff\x5c\xff\x5b\xff\x5a\xff\x59\xff\x58\xff\x57\xff\x56\xff\x55\xff\x54\xff\xe7\xff\x00\x00\xda\xff\x00\x00\xd8\xff\x00\x00\x00\x00\x00\x00\xd5\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x66\xff\xea\xff\xfd\xff\x00\x00\x64\xff\xdd\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdb\xff\x00\x00\xd6\xff\xd7\xff\x00\x00\xdc\xff\xd9\xff\xf6\xff\x00\x00\xd4\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x63\xff\x61\xff\x00\x00\xec\xff\xe9\xff\xe0\xff\x00\x00\xe0\xff\xe0\xff\x00\x00\x00\x00\x00\x00\xd3\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaa\xff\x00\x00\x00\x00\x67\xff\x68\xff\x5f\xff\x62\xff\x65\xff\xee\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf7\xff\x00\x00\xf6\xff\x00\x00\x5d\xff\x00\x00\x5e\xff\x00\x00\x00\x00\x00\x00\x00\x00\x88\xff\x84\xff\x00\x00\xf3\xff\x00\x00\x00\x00\x00\x00\x00\x00\x71\xff\x72\xff\x85\xff\x7e\xff\x7e\xff\xf5\xff\xf8\xff\x00\x00\x00\x00\x00\x00\xe2\xff\x64\xff\x00\x00\x00\x00\x00\x00\x60\xff\xd2\xff\x76\xff\x00\x00\x00\x00\x76\xff\x00\x00\x00\x00\x76\xff\x00\x00\x00\x00\x00\x00\x9c\xff\xb8\xff\xb7\xff\x00\x00\x00\x00\x00\x00\x00\x00\x6e\xff\x6b\xff\x00\x00\x69\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xde\xff\xdf\xff\xe8\xff\x00\x00\x00\x00\x00\x00\x00\x00\x6a\xff\x00\x00\x6d\xff\x00\x00\xcb\xff\xb4\xff\x00\x00\xb8\xff\xb7\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x76\xff\x00\x00\x00\x00\x76\xff\x00\x00\x74\xff\x00\x00\x75\xff\x00\x00\x00\x00\x00\x00\x00\x00\xc0\xff\x00\x00\xee\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x86\xff\x00\x00\x87\xff\x8a\xff\x00\x00\x8b\xff\x00\x00\x83\xff\x00\x00\x00\x00\x00\x00\xf4\xff\x00\x00\xee\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\xff\x76\xff\x7d\xff\x00\x00\x00\x00\x00\x00\xe1\xff\x00\x00\xf9\xff\xed\xff\x00\x00\xbe\xff\xbc\xff\xbd\xff\x00\x00\xa9\xff\x00\x00\x00\x00\x00\x00\x00\x00\x68\xff\x00\x00\x00\x00\xb0\xff\x00\x00\xad\xff\xc9\xff\x00\x00\xb5\xff\xb6\xff\x00\x00\xe0\xff\x00\x00\x8d\xff\x8c\xff\x8f\xff\x91\xff\x95\xff\x96\xff\x8e\xff\x90\xff\x92\xff\x93\xff\x94\xff\x97\xff\x98\xff\x99\xff\x9a\xff\x9b\xff\xb3\xff\x6f\xff\x6c\xff\x00\x00\x00\x00\xd1\xff\x00\x00\xbb\xff\x00\x00\x76\xff\x7c\xff\x00\x00\x00\x00\xc4\xff\x00\x00\x00\x00\x00\x00\x00\x00\xaf\xff\xae\xff\x00\x00\xc1\xff\x73\xff\xca\xff\x00\x00\xa1\xff\xa9\xff\x00\x00\xc2\xff\x00\x00\xcd\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7f\xff\x00\x00\x00\x00\xf0\xff\xef\xff\xf2\xff\xf1\xff\x89\xff\x80\xff\x82\xff\x00\x00\x00\x00\x00\x00\x00\x00\xbf\xff\x00\x00\xa4\xff\xa8\xff\x00\x00\x00\x00\xab\xff\xc8\xff\x76\xff\xac\xff\xc6\xff\x00\x00\x00\x00\xa0\xff\x00\x00\x00\x00\x78\xff\x00\x00\x7b\xff\x7a\xff\x00\x00\x00\x00\x00\x00\xb2\xff\x77\xff\xd0\xff\x76\xff\xc3\xff\x00\x00\x9d\xff\x9e\xff\x00\x00\x00\x00\xcc\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\xff\x00\x00\x00\x00\x00\x00\xa7\xff\xe0\xff\x00\x00\xa3\xff\xe0\xff\x00\x00\xe0\xff\x00\x00\xba\xff\xb1\xff\x79\xff\xce\xff\x00\x00\x00\x00\x00\x00\x00\x00\xc7\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe6\xff\xa6\xff\xa5\xff\xa2\xff\x9f\xff\xc5\xff\xb9\xff\xcf\xff\x00\x00\x00\x00\xe4\xff\xe5\xff"#--happyCheck :: HappyAddr-happyCheck = HappyA# "\xff\xff\x02\x00\x04\x00\x05\x00\x0b\x00\x0c\x00\x07\x00\x23\x00\x06\x00\x10\x00\x0b\x00\x03\x00\x03\x00\x0e\x00\x0f\x00\x2b\x00\x0b\x00\x0c\x00\x08\x00\x07\x00\x25\x00\x10\x00\x05\x00\x01\x00\x4d\x00\x35\x00\x36\x00\x36\x00\x02\x00\x07\x00\x02\x00\x03\x00\x16\x00\x07\x00\x02\x00\x12\x00\x32\x00\x2c\x00\x34\x00\x07\x00\x05\x00\x30\x00\x49\x00\x06\x00\x20\x00\x21\x00\x35\x00\x36\x00\x07\x00\x2c\x00\x0d\x00\x35\x00\x36\x00\x30\x00\x2e\x00\x2e\x00\x49\x00\x4a\x00\x35\x00\x36\x00\x07\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x2c\x00\x4b\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x07\x00\x34\x00\x35\x00\x36\x00\x0b\x00\x38\x00\x39\x00\x0e\x00\x0f\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x07\x00\x07\x00\x49\x00\x48\x00\x0b\x00\x49\x00\x4a\x00\x0e\x00\x0f\x00\x22\x00\x23\x00\x22\x00\x23\x00\x20\x00\x21\x00\x07\x00\x17\x00\x2a\x00\x2b\x00\x0b\x00\x2b\x00\x07\x00\x0e\x00\x0f\x00\x36\x00\x0c\x00\x0d\x00\x0e\x00\x35\x00\x36\x00\x35\x00\x36\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x07\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x07\x00\x0e\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x00\x00\x01\x00\x02\x00\x07\x00\x00\x00\x01\x00\x02\x00\x07\x00\x48\x00\x49\x00\x0a\x00\x07\x00\x0c\x00\x49\x00\x0a\x00\x4a\x00\x0c\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x04\x00\x05\x00\x02\x00\x03\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x12\x00\x35\x00\x36\x00\x20\x00\x21\x00\x35\x00\x36\x00\x02\x00\x0b\x00\x0c\x00\x0b\x00\x0c\x00\x49\x00\x10\x00\x16\x00\x10\x00\x22\x00\x23\x00\x22\x00\x23\x00\x49\x00\x0b\x00\x0c\x00\x0b\x00\x0c\x00\x2b\x00\x10\x00\x2b\x00\x10\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x03\x00\x35\x00\x36\x00\x35\x00\x36\x00\x35\x00\x36\x00\x2c\x00\x4a\x00\x2c\x00\x02\x00\x30\x00\x49\x00\x30\x00\x25\x00\x49\x00\x35\x00\x36\x00\x35\x00\x36\x00\x2c\x00\x16\x00\x2c\x00\x02\x00\x30\x00\x07\x00\x30\x00\x22\x00\x23\x00\x35\x00\x36\x00\x35\x00\x36\x00\x0b\x00\x0c\x00\x2d\x00\x2e\x00\x2f\x00\x10\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x0d\x00\x0e\x00\x16\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x49\x00\x2c\x00\x2d\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x2c\x00\x0d\x00\x0e\x00\x49\x00\x30\x00\x38\x00\x35\x00\x36\x00\x49\x00\x35\x00\x36\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x49\x00\x49\x00\x15\x00\x16\x00\x15\x00\x16\x00\x15\x00\x16\x00\x15\x00\x16\x00\x33\x00\x34\x00\x35\x00\x36\x00\x16\x00\x22\x00\x23\x00\x22\x00\x23\x00\x22\x00\x23\x00\x22\x00\x23\x00\x16\x00\x2b\x00\x16\x00\x2b\x00\x16\x00\x2b\x00\x16\x00\x2b\x00\x15\x00\x16\x00\x49\x00\x35\x00\x36\x00\x35\x00\x36\x00\x35\x00\x36\x00\x35\x00\x36\x00\x22\x00\x23\x00\x22\x00\x23\x00\x26\x00\x27\x00\x28\x00\x1b\x00\x1c\x00\x2b\x00\x49\x00\x2b\x00\x08\x00\x02\x00\x1b\x00\x1c\x00\x01\x00\x4b\x00\x16\x00\x35\x00\x36\x00\x35\x00\x36\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x02\x00\x04\x00\x4b\x00\x09\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x02\x00\x4b\x00\x49\x00\x4b\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x4b\x00\x03\x00\x49\x00\x49\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x07\x00\x05\x00\x07\x00\x48\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x05\x00\x16\x00\x07\x00\x16\x00\x16\x00\x04\x00\x16\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x05\x00\x16\x00\x05\x00\x07\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x06\x00\x49\x00\x4b\x00\x0a\x00\x49\x00\x19\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x08\x00\x4b\x00\x4b\x00\x4b\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x06\x00\x02\x00\x4b\x00\x02\x00\x09\x00\x08\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x4b\x00\x08\x00\x16\x00\x49\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x06\x00\x4a\x00\x0e\x00\x49\x00\x49\x00\x09\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x09\x00\x08\x00\x24\x00\x02\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x07\x00\x18\x00\x08\x00\x08\x00\x08\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x02\x00\x08\x00\x07\x00\x06\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x07\x00\x16\x00\x16\x00\x16\x00\x16\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x05\x00\x16\x00\x49\x00\x06\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x08\x00\x02\x00\x4a\x00\x02\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x08\x00\x0a\x00\x02\x00\x4b\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x09\x00\x4a\x00\x02\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x3a\x00\x02\x00\x4b\x00\x4b\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x22\x00\x23\x00\x16\x00\x22\x00\x23\x00\x4b\x00\x08\x00\x29\x00\x2a\x00\x2b\x00\x29\x00\x2a\x00\x2b\x00\x06\x00\x06\x00\x16\x00\x20\x00\x22\x00\x23\x00\x35\x00\x36\x00\x08\x00\x35\x00\x36\x00\x29\x00\x2a\x00\x2b\x00\x01\x00\x49\x00\x30\x00\x09\x00\x22\x00\x23\x00\x04\x00\x22\x00\x23\x00\x35\x00\x36\x00\x29\x00\x2a\x00\x2b\x00\x29\x00\x2a\x00\x2b\x00\x07\x00\x07\x00\x02\x00\x48\x00\x22\x00\x23\x00\x35\x00\x36\x00\x06\x00\x35\x00\x36\x00\x29\x00\x2a\x00\x2b\x00\x3b\x00\x3a\x00\x4b\x00\x16\x00\x22\x00\x23\x00\x48\x00\x22\x00\x23\x00\x35\x00\x36\x00\x29\x00\x2a\x00\x2b\x00\x29\x00\x2a\x00\x2b\x00\x16\x00\x16\x00\x08\x00\x16\x00\x4a\x00\x4a\x00\x35\x00\x36\x00\x4a\x00\x35\x00\x36\x00\x22\x00\x23\x00\x01\x00\x22\x00\x23\x00\x27\x00\x28\x00\x22\x00\x23\x00\x2b\x00\x29\x00\x2a\x00\x2b\x00\x4b\x00\x16\x00\x01\x00\x2b\x00\x04\x00\x08\x00\x35\x00\x36\x00\x2b\x00\x35\x00\x36\x00\x22\x00\x23\x00\x35\x00\x36\x00\x22\x00\x23\x00\x22\x00\x23\x00\x08\x00\x2b\x00\x08\x00\x08\x00\x02\x00\x2b\x00\x16\x00\x2b\x00\x03\x00\x08\x00\x03\x00\x35\x00\x36\x00\x22\x00\x23\x00\x35\x00\x36\x00\x35\x00\x36\x00\x22\x00\x23\x00\x4a\x00\x2b\x00\x4b\x00\x08\x00\x22\x00\x23\x00\x4a\x00\x2b\x00\x4a\x00\x4a\x00\x16\x00\x35\x00\x36\x00\x2b\x00\x16\x00\x16\x00\x33\x00\x35\x00\x36\x00\x22\x00\x23\x00\x22\x00\x23\x00\x35\x00\x36\x00\x22\x00\x23\x00\x49\x00\x2b\x00\x02\x00\x2b\x00\x08\x00\x02\x00\x37\x00\x2b\x00\x02\x00\x04\x00\x16\x00\x35\x00\x36\x00\x35\x00\x36\x00\x22\x00\x23\x00\x35\x00\x36\x00\x22\x00\x23\x00\x22\x00\x23\x00\x04\x00\x2b\x00\x02\x00\x04\x00\x4b\x00\x2b\x00\x08\x00\x2b\x00\x16\x00\x08\x00\x08\x00\x35\x00\x36\x00\x22\x00\x23\x00\x35\x00\x36\x00\x35\x00\x36\x00\x22\x00\x23\x00\x4a\x00\x2b\x00\x08\x00\x0f\x00\x22\x00\x23\x00\x31\x00\x2b\x00\x0f\x00\x09\x00\x0f\x00\x35\x00\x36\x00\x2b\x00\x03\x00\x1a\x00\x0f\x00\x35\x00\x36\x00\x22\x00\x23\x00\x22\x00\x23\x00\x35\x00\x36\x00\x22\x00\x23\x00\x11\x00\x2b\x00\x06\x00\x2b\x00\x18\x00\x24\x00\x2f\x00\x2b\x00\x25\x00\x25\x00\x21\x00\x35\x00\x36\x00\x35\x00\x36\x00\x22\x00\x23\x00\x35\x00\x36\x00\x22\x00\x23\x00\x22\x00\x23\x00\x13\x00\x2b\x00\x19\x00\x30\x00\x06\x00\x2b\x00\x06\x00\x2b\x00\x09\x00\x19\x00\x09\x00\x35\x00\x36\x00\x22\x00\x23\x00\x35\x00\x36\x00\x35\x00\x36\x00\x22\x00\x23\x00\x1f\x00\x2b\x00\x1e\x00\x11\x00\x22\x00\x23\x00\x20\x00\x2b\x00\x14\x00\xff\xff\x1d\x00\x35\x00\x36\x00\x2b\x00\x1e\x00\x17\x00\xff\xff\x35\x00\x36\x00\x22\x00\x23\x00\x22\x00\x23\x00\x35\x00\x36\x00\x22\x00\x23\x00\xff\xff\x2b\x00\xff\xff\x2b\x00\xff\xff\xff\xff\xff\xff\x2b\x00\xff\xff\xff\xff\xff\xff\x35\x00\x36\x00\x35\x00\x36\x00\x22\x00\x23\x00\x35\x00\x36\x00\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\x2b\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x35\x00\x36\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\xff\xff\x1a\x00\x1b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x1a\x00\x1b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\xff\xff\x49\x00\x4a\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"#--happyTable :: HappyAddr-happyTable = HappyA# "\x00\x00\x7c\x00\x6e\x00\x6f\x00\x51\x00\x52\x00\x7d\x00\x57\x01\xf3\x00\x53\x00\x7e\x00\x1b\x01\x8c\x01\x7f\x00\x80\x00\x79\x00\xac\x00\x52\x00\x8b\x00\xcd\x00\x21\x00\x53\x00\xed\x00\x91\x00\xff\xff\x7a\x00\x09\x00\x2f\x00\x66\x01\x92\x00\x50\x00\x51\x00\x8c\x00\x67\x01\x58\x00\xee\x00\xaa\x00\x54\x00\xab\x00\x59\x00\xa8\x00\x55\x00\x26\x00\x13\x01\xce\x00\xcf\x00\x56\x00\x09\x00\x2c\x00\x54\x00\x14\x01\x70\x00\x71\x00\x55\x00\x1c\x01\x8d\x01\x22\x00\x23\x00\x56\x00\x09\x00\x2b\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x11\x00\xf4\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x70\xff\x7d\x00\x70\xff\x5e\x00\x5f\x00\x7e\x00\x13\x00\x60\x00\x7f\x00\x80\x00\x61\x00\x62\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x63\x00\x64\x00\x9f\x00\x2a\x00\x26\x00\x15\x01\x7e\x00\xa6\x00\xa7\x00\x7f\x00\x80\x00\xd4\x00\x78\x00\x9a\x00\x78\x00\xce\x00\xcf\x00\x7d\x00\xa0\x00\x42\x01\x79\x00\x7e\x00\x79\x00\x29\x00\x7f\x00\x80\x00\x09\x01\xbc\x00\xbd\x00\xbe\x00\x7a\x00\x09\x00\x7a\x00\x09\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x7d\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\x28\x00\x7f\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x02\x00\x03\x00\x04\x00\x27\x00\x2f\x00\x03\x00\x04\x00\x05\x00\x63\x00\x10\x01\x06\x00\x05\x00\x07\x00\x26\x00\x06\x00\x24\x00\x07\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\x85\x00\x6f\x00\x50\x00\x51\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\x06\x01\x08\x00\x09\x00\xce\x00\xcf\x00\x08\x00\x09\x00\x40\x00\xab\x00\x52\x00\x3a\x01\x52\x00\x3e\x00\x53\x00\x3f\x00\x53\x00\x07\x01\x78\x00\x99\x00\x78\x00\x3d\x00\x9d\x01\x52\x00\x9b\x01\x52\x00\x79\x00\x53\x00\x79\x00\x53\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x09\x00\x3c\x00\x7a\x00\x09\x00\x7a\x00\x09\x00\x70\x00\x71\x00\x54\x00\x77\x01\x54\x00\x3b\x00\x55\x00\x39\x00\x55\x00\x73\x00\x38\x00\x56\x00\x09\x00\x56\x00\x09\x00\x54\x00\x3a\x00\x54\x00\x33\x00\x55\x00\x32\x00\x55\x00\x6a\x01\x6b\x01\x56\x00\x09\x00\x56\x00\x09\x00\x99\x01\x52\x00\x2e\x01\xa2\x00\xa3\x00\x53\x00\x74\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x4a\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x37\x00\x11\x00\x12\x00\xe0\x00\x4b\x00\x4c\x00\x4d\x00\x09\x00\x54\x00\x40\x00\x1f\x00\x36\x00\x55\x00\x13\x00\xfd\x00\x09\x00\x35\x00\x56\x00\x09\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x34\x00\x1e\x00\x9b\x00\x9c\x00\xb8\x00\xb9\x00\xb7\x00\x9c\x00\x18\x01\x9c\x00\x8f\x00\x4c\x00\x4d\x00\x09\x00\x49\x00\x9d\x00\x78\x00\xba\x00\x78\x00\x9d\x00\x78\x00\x9d\x00\x78\x00\x48\x00\x79\x00\x47\x00\x79\x00\x46\x00\x79\x00\x45\x00\x79\x00\x17\x01\x9c\x00\x26\x00\x7a\x00\x09\x00\x7a\x00\x09\x00\x7a\x00\x09\x00\x7a\x00\x09\x00\x6e\x01\x78\x00\x9d\x00\x78\x00\x6f\x01\x70\x01\x71\x01\x45\x01\x46\x01\x79\x00\x43\x00\x79\x00\x67\x00\xf0\x00\x61\x01\x46\x01\x6e\x00\x6d\x00\x66\x00\x7a\x00\x09\x00\x7a\x00\x09\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\x32\x01\xae\x00\x6c\x00\xa9\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\x78\x01\x6b\x00\x68\x00\x6a\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\x69\x00\x0b\x01\x65\x00\xa1\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\x98\x00\x97\x00\x95\x00\x94\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xd2\x00\x8f\x00\xd3\x00\x8d\x00\x8a\x00\x87\x00\x89\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\x77\x00\x88\x00\x75\x00\x76\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\x31\x01\xf2\x00\xf1\x00\xef\x00\xe9\x00\xe6\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xdf\x00\xe4\x00\xe3\x00\xe2\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\x51\x01\xdc\x00\xe0\x00\xb7\x00\xdb\x00\xb6\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xd8\x00\xb4\x00\xb5\x00\xa6\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\x59\x01\xb0\x00\xaf\x00\x35\x01\x34\x01\x30\x01\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\x2e\x01\x2d\x01\x1a\x01\x16\x01\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xd0\x00\x0c\x01\x0d\x01\x0a\x01\x06\x01\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\x04\x01\x02\x01\xfd\x00\xf8\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\x79\x01\x03\x01\x01\x01\x00\x01\xff\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\xfa\x00\x8f\x00\xf9\x00\xf5\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xfc\x00\x57\x01\xf6\x00\x56\x01\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\x55\x01\x53\x01\x54\x01\x4e\x01\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xd4\x00\x4f\x01\x4b\x01\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\x48\x01\x44\x01\x4d\x01\x4c\x01\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xd4\x00\x78\x00\x4a\x01\xd4\x00\x78\x00\x45\x01\x41\x01\xdc\x00\xd6\x00\x79\x00\xd9\x00\xd6\x00\x79\x00\x40\x01\x3f\x01\x3e\x01\xce\x00\xd4\x00\x78\x00\x7a\x00\x09\x00\x3d\x01\x7a\x00\x09\x00\xd5\x00\xd6\x00\x79\x00\x3c\x01\x3a\x01\x39\x01\x38\x01\xd4\x00\x78\x00\x6c\x01\xd4\x00\x78\x00\x7a\x00\x09\x00\x16\x01\xd6\x00\x79\x00\x10\x01\xd6\x00\x79\x00\x37\x01\x36\x01\x69\x01\x15\x01\xd4\x00\x78\x00\x7a\x00\x09\x00\x65\x01\x7a\x00\x09\x00\x4f\x01\xd6\x00\x79\x00\x64\x01\x48\x01\x61\x01\x5e\x01\xd4\x00\x78\x00\x94\x00\xd4\x00\x78\x00\x7a\x00\x09\x00\x72\x01\xd6\x00\x79\x00\x7d\x01\xd6\x00\x79\x00\x5d\x01\x5c\x01\x5a\x01\x5b\x01\x86\x01\x84\x01\x7a\x00\x09\x00\x83\x01\x7a\x00\x09\x00\x6e\x01\x78\x00\x82\x01\xd4\x00\x78\x00\x94\x01\x71\x01\x98\x00\x78\x00\x79\x00\x91\x01\xd6\x00\x79\x00\x85\x01\x81\x01\x7f\x01\x79\x00\x80\x01\x7d\x01\x7a\x00\x09\x00\x7b\x01\x7a\x00\x09\x00\x77\x00\x78\x00\x7a\x00\x09\x00\xea\x00\x78\x00\xe9\x00\x78\x00\x7c\x01\x79\x00\x76\x01\x74\x01\x96\x01\x79\x00\x75\x01\x79\x00\x91\x01\x90\x01\x8f\x01\x7a\x00\x09\x00\xe7\x00\x78\x00\x7a\x00\x09\x00\x7a\x00\x09\x00\xdd\x00\x78\x00\x94\x01\x79\x00\x61\x01\x87\x01\xd8\x00\x78\x00\xa1\x01\x79\x00\xa0\x01\x9f\x01\x8a\x01\x7a\x00\x09\x00\x79\x00\x89\x01\x88\x01\x98\x01\x7a\x00\x09\x00\xb1\x00\x78\x00\xb0\x00\x78\x00\x7a\x00\x09\x00\x2b\x01\x78\x00\x9d\x01\x79\x00\x9b\x01\x79\x00\x99\x01\xab\x01\xaa\x01\x79\x00\xa9\x01\xa8\x01\xa3\x01\x7a\x00\x09\x00\x7a\x00\x09\x00\x2a\x01\x78\x00\x7a\x00\x09\x00\x29\x01\x78\x00\x28\x01\x78\x00\xa7\x01\x79\x00\xa6\x01\xa5\x01\xac\x01\x79\x00\xa4\x01\x79\x00\xa2\x01\xaf\x01\xae\x01\x7a\x00\x09\x00\x27\x01\x78\x00\x7a\x00\x09\x00\x7a\x00\x09\x00\x26\x01\x78\x00\xad\x01\x79\x00\x2d\x00\x2c\x00\x25\x01\x78\x00\x30\x00\x79\x00\x24\x00\x4e\x00\x43\x00\x7a\x00\x09\x00\x79\x00\x41\x00\x95\x00\x2c\x00\x7a\x00\x09\x00\x24\x01\x78\x00\x23\x01\x78\x00\x7a\x00\x09\x00\x22\x01\x78\x00\x92\x00\x79\x00\x8d\x00\x79\x00\xd0\x00\xeb\x00\xb2\x00\x79\x00\xe6\x00\xe4\x00\xcb\x00\x7a\x00\x09\x00\x7a\x00\x09\x00\x21\x01\x78\x00\x7a\x00\x09\x00\x20\x01\x78\x00\x1f\x01\x78\x00\x32\x01\x79\x00\x11\x01\x0e\x01\x04\x01\x79\x00\xf6\x00\x79\x00\x48\x01\x67\x01\x41\x01\x7a\x00\x09\x00\x1e\x01\x78\x00\x7a\x00\x09\x00\x7a\x00\x09\x00\x1d\x01\x78\x00\x62\x01\x79\x00\x5f\x01\x5e\x01\x1c\x01\x78\x00\x79\x01\x79\x00\x96\x01\x00\x00\x8a\x01\x7a\x00\x09\x00\x79\x00\x8d\x01\x92\x01\x00\x00\x7a\x00\x09\x00\xfa\x00\x78\x00\x51\x01\x78\x00\x7a\x00\x09\x00\x6d\x01\x78\x00\x00\x00\x79\x00\x00\x00\x79\x00\x00\x00\x00\x00\x00\x00\x79\x00\x00\x00\x00\x00\x00\x00\x7a\x00\x09\x00\x7a\x00\x09\x00\x6c\x01\x78\x00\x7a\x00\x09\x00\xa1\x00\xa2\x00\xa3\x00\x00\x00\x00\x00\x79\x00\xa4\x00\x4c\x00\x4d\x00\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7a\x00\x09\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\x0e\x01\x00\x00\x00\x00\x00\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\x8f\x00\x00\x00\x00\x00\x00\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc6\x00\xc7\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc1\x00\x00\x00\xc6\x00\xc7\x00\xbc\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xc6\x00\xc7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc6\x00\xc7\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x00\x00\xa6\x00\xa7\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"#--happyReduceArr = Happy_Data_Array.array (1, 171) [-	(1 , happyReduce_1),-	(2 , happyReduce_2),-	(3 , happyReduce_3),-	(4 , happyReduce_4),-	(5 , happyReduce_5),-	(6 , happyReduce_6),-	(7 , happyReduce_7),-	(8 , happyReduce_8),-	(9 , happyReduce_9),-	(10 , happyReduce_10),-	(11 , happyReduce_11),-	(12 , happyReduce_12),-	(13 , happyReduce_13),-	(14 , happyReduce_14),-	(15 , happyReduce_15),-	(16 , happyReduce_16),-	(17 , happyReduce_17),-	(18 , happyReduce_18),-	(19 , happyReduce_19),-	(20 , happyReduce_20),-	(21 , happyReduce_21),-	(22 , happyReduce_22),-	(23 , happyReduce_23),-	(24 , happyReduce_24),-	(25 , happyReduce_25),-	(26 , happyReduce_26),-	(27 , happyReduce_27),-	(28 , happyReduce_28),-	(29 , happyReduce_29),-	(30 , happyReduce_30),-	(31 , happyReduce_31),-	(32 , happyReduce_32),-	(33 , happyReduce_33),-	(34 , happyReduce_34),-	(35 , happyReduce_35),-	(36 , happyReduce_36),-	(37 , happyReduce_37),-	(38 , happyReduce_38),-	(39 , happyReduce_39),-	(40 , happyReduce_40),-	(41 , happyReduce_41),-	(42 , happyReduce_42),-	(43 , happyReduce_43),-	(44 , happyReduce_44),-	(45 , happyReduce_45),-	(46 , happyReduce_46),-	(47 , happyReduce_47),-	(48 , happyReduce_48),-	(49 , happyReduce_49),-	(50 , happyReduce_50),-	(51 , happyReduce_51),-	(52 , happyReduce_52),-	(53 , happyReduce_53),-	(54 , happyReduce_54),-	(55 , happyReduce_55),-	(56 , happyReduce_56),-	(57 , happyReduce_57),-	(58 , happyReduce_58),-	(59 , happyReduce_59),-	(60 , happyReduce_60),-	(61 , happyReduce_61),-	(62 , happyReduce_62),-	(63 , happyReduce_63),-	(64 , happyReduce_64),-	(65 , happyReduce_65),-	(66 , happyReduce_66),-	(67 , happyReduce_67),-	(68 , happyReduce_68),-	(69 , happyReduce_69),-	(70 , happyReduce_70),-	(71 , happyReduce_71),-	(72 , happyReduce_72),-	(73 , happyReduce_73),-	(74 , happyReduce_74),-	(75 , happyReduce_75),-	(76 , happyReduce_76),-	(77 , happyReduce_77),-	(78 , happyReduce_78),-	(79 , happyReduce_79),-	(80 , happyReduce_80),-	(81 , happyReduce_81),-	(82 , happyReduce_82),-	(83 , happyReduce_83),-	(84 , happyReduce_84),-	(85 , happyReduce_85),-	(86 , happyReduce_86),-	(87 , happyReduce_87),-	(88 , happyReduce_88),-	(89 , happyReduce_89),-	(90 , happyReduce_90),-	(91 , happyReduce_91),-	(92 , happyReduce_92),-	(93 , happyReduce_93),-	(94 , happyReduce_94),-	(95 , happyReduce_95),-	(96 , happyReduce_96),-	(97 , happyReduce_97),-	(98 , happyReduce_98),-	(99 , happyReduce_99),-	(100 , happyReduce_100),-	(101 , happyReduce_101),-	(102 , happyReduce_102),-	(103 , happyReduce_103),-	(104 , happyReduce_104),-	(105 , happyReduce_105),-	(106 , happyReduce_106),-	(107 , happyReduce_107),-	(108 , happyReduce_108),-	(109 , happyReduce_109),-	(110 , happyReduce_110),-	(111 , happyReduce_111),-	(112 , happyReduce_112),-	(113 , happyReduce_113),-	(114 , happyReduce_114),-	(115 , happyReduce_115),-	(116 , happyReduce_116),-	(117 , happyReduce_117),-	(118 , happyReduce_118),-	(119 , happyReduce_119),-	(120 , happyReduce_120),-	(121 , happyReduce_121),-	(122 , happyReduce_122),-	(123 , happyReduce_123),-	(124 , happyReduce_124),-	(125 , happyReduce_125),-	(126 , happyReduce_126),-	(127 , happyReduce_127),-	(128 , happyReduce_128),-	(129 , happyReduce_129),-	(130 , happyReduce_130),-	(131 , happyReduce_131),-	(132 , happyReduce_132),-	(133 , happyReduce_133),-	(134 , happyReduce_134),-	(135 , happyReduce_135),-	(136 , happyReduce_136),-	(137 , happyReduce_137),-	(138 , happyReduce_138),-	(139 , happyReduce_139),-	(140 , happyReduce_140),-	(141 , happyReduce_141),-	(142 , happyReduce_142),-	(143 , happyReduce_143),-	(144 , happyReduce_144),-	(145 , happyReduce_145),-	(146 , happyReduce_146),-	(147 , happyReduce_147),-	(148 , happyReduce_148),-	(149 , happyReduce_149),-	(150 , happyReduce_150),-	(151 , happyReduce_151),-	(152 , happyReduce_152),-	(153 , happyReduce_153),-	(154 , happyReduce_154),-	(155 , happyReduce_155),-	(156 , happyReduce_156),-	(157 , happyReduce_157),-	(158 , happyReduce_158),-	(159 , happyReduce_159),-	(160 , happyReduce_160),-	(161 , happyReduce_161),-	(162 , happyReduce_162),-	(163 , happyReduce_163),-	(164 , happyReduce_164),-	(165 , happyReduce_165),-	(166 , happyReduce_166),-	(167 , happyReduce_167),-	(168 , happyReduce_168),-	(169 , happyReduce_169),-	(170 , happyReduce_170),-	(171 , happyReduce_171)-	]--happy_n_terms = 78 :: Prelude.Int-happy_n_nonterms = 55 :: Prelude.Int--happyReduce_1 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_1 = happySpecReduce_0  0# happyReduction_1-happyReduction_1  =  happyIn4-		 (return ()-	)--happyReduce_2 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_2 = happySpecReduce_2  0# happyReduction_2-happyReduction_2 happy_x_2-	happy_x_1-	 =  case happyOut5 happy_x_1 of { (HappyWrap5 happy_var_1) -> -	case happyOut4 happy_x_2 of { (HappyWrap4 happy_var_2) -> -	happyIn4-		 (do happy_var_1; happy_var_2-	)}}--happyReduce_3 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_3 = happySpecReduce_1  1# happyReduction_3-happyReduction_3 happy_x_1-	 =  case happyOut11 happy_x_1 of { (HappyWrap11 happy_var_1) -> -	happyIn5-		 (happy_var_1-	)}--happyReduce_4 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_4 = happySpecReduce_1  1# happyReduction_4-happyReduction_4 happy_x_1-	 =  case happyOut6 happy_x_1 of { (HappyWrap6 happy_var_1) -> -	happyIn5-		 (happy_var_1-	)}--happyReduce_5 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_5 = happySpecReduce_1  1# happyReduction_5-happyReduction_5 happy_x_1-	 =  case happyOut16 happy_x_1 of { (HappyWrap16 happy_var_1) -> -	happyIn5-		 (happy_var_1-	)}--happyReduce_6 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_6 = happyMonadReduce 8# 1# happyReduction_6-happyReduction_6 (happy_x_8 `HappyStk`-	happy_x_7 `HappyStk`-	happy_x_6 `HappyStk`-	happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest) tk-	 = happyThen ((case happyOutTok happy_x_3 of { (L _ (CmmT_Name        happy_var_3)) -> -	case happyOutTok happy_x_5 of { (L _ (CmmT_Name        happy_var_5)) -> -	case happyOut10 happy_x_6 of { (HappyWrap10 happy_var_6) -> -	( do-                      home_unit_id <- getHomeUnitId-                      liftP $ pure $ do-                        lits <- sequence happy_var_6;-                        staticClosure home_unit_id happy_var_3 happy_var_5 (map getLit lits))}}})-	) (\r -> happyReturn (happyIn5 r))--happyReduce_7 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_7 = happyReduce 6# 2# happyReduction_7-happyReduction_7 (happy_x_6 `HappyStk`-	happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOutTok happy_x_2 of { (L _ (CmmT_String      happy_var_2)) -> -	case happyOut7 happy_x_4 of { (HappyWrap7 happy_var_4) -> -	case happyOut8 happy_x_5 of { (HappyWrap8 happy_var_5) -> -	happyIn6-		 (do lbl <- happy_var_4;-                     ss <- sequence happy_var_5;-                     code (emitDecl (CmmData (Section (section happy_var_2) lbl) (CmmStaticsRaw lbl (concat ss))))-	) `HappyStk` happyRest}}}--happyReduce_8 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_8 = happyMonadReduce 2# 3# happyReduction_8-happyReduction_8 (happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest) tk-	 = happyThen ((case happyOutTok happy_x_1 of { (L _ (CmmT_Name        happy_var_1)) -> -	( do-                   home_unit_id <- getHomeUnitId-                   liftP $ pure $ do-                     pure (mkCmmDataLabel home_unit_id (NeedExternDecl False) happy_var_1))})-	) (\r -> happyReturn (happyIn7 r))--happyReduce_9 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_9 = happySpecReduce_0  4# happyReduction_9-happyReduction_9  =  happyIn8-		 ([]-	)--happyReduce_10 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_10 = happySpecReduce_2  4# happyReduction_10-happyReduction_10 happy_x_2-	happy_x_1-	 =  case happyOut9 happy_x_1 of { (HappyWrap9 happy_var_1) -> -	case happyOut8 happy_x_2 of { (HappyWrap8 happy_var_2) -> -	happyIn8-		 (happy_var_1 : happy_var_2-	)}}--happyReduce_11 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_11 = happySpecReduce_3  5# happyReduction_11-happyReduction_11 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut38 happy_x_2 of { (HappyWrap38 happy_var_2) -> -	happyIn9-		 (do e <- happy_var_2;-                             return [CmmStaticLit (getLit e)]-	)}--happyReduce_12 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_12 = happySpecReduce_2  5# happyReduction_12-happyReduction_12 happy_x_2-	happy_x_1-	 =  case happyOut57 happy_x_1 of { (HappyWrap57 happy_var_1) -> -	happyIn9-		 (return [CmmUninitialised-                                                        (widthInBytes (typeWidth happy_var_1))]-	)}--happyReduce_13 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_13 = happyReduce 5# 5# happyReduction_13-happyReduction_13 (happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOutTok happy_x_4 of { (L _ (CmmT_String      happy_var_4)) -> -	happyIn9-		 (return [mkString happy_var_4]-	) `HappyStk` happyRest}--happyReduce_14 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_14 = happyReduce 5# 5# happyReduction_14-happyReduction_14 (happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOutTok happy_x_3 of { (L _ (CmmT_Int         happy_var_3)) -> -	happyIn9-		 (return [CmmUninitialised-                                                        (fromIntegral happy_var_3)]-	) `HappyStk` happyRest}--happyReduce_15 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_15 = happyReduce 5# 5# happyReduction_15-happyReduction_15 (happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut58 happy_x_1 of { (HappyWrap58 happy_var_1) -> -	case happyOutTok happy_x_3 of { (L _ (CmmT_Int         happy_var_3)) -> -	happyIn9-		 (return [CmmUninitialised-                                                (widthInBytes (typeWidth happy_var_1) *-                                                        fromIntegral happy_var_3)]-	) `HappyStk` happyRest}}--happyReduce_16 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_16 = happyReduce 5# 5# happyReduction_16-happyReduction_16 (happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOutTok happy_x_3 of { (L _ (CmmT_Name        happy_var_3)) -> -	case happyOut10 happy_x_4 of { (HappyWrap10 happy_var_4) -> -	happyIn9-		 (do { lits <- sequence happy_var_4-                ; profile <- getProfile-                     ; return $ map CmmStaticLit $-                        mkStaticClosure profile (mkForeignLabel happy_var_3 Nothing ForeignLabelInExternalPackage IsData)-                         -- mkForeignLabel because these are only used-                         -- for CHARLIKE and INTLIKE closures in the RTS.-                        dontCareCCS (map getLit lits) [] [] [] }-	) `HappyStk` happyRest}}--happyReduce_17 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_17 = happySpecReduce_0  6# happyReduction_17-happyReduction_17  =  happyIn10-		 ([]-	)--happyReduce_18 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_18 = happySpecReduce_3  6# happyReduction_18-happyReduction_18 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut38 happy_x_2 of { (HappyWrap38 happy_var_2) -> -	case happyOut10 happy_x_3 of { (HappyWrap10 happy_var_3) -> -	happyIn10-		 (happy_var_2 : happy_var_3-	)}}--happyReduce_19 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_19 = happyReduce 4# 7# happyReduction_19-happyReduction_19 (happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut14 happy_x_1 of { (HappyWrap14 happy_var_1) -> -	case happyOut12 happy_x_2 of { (HappyWrap12 happy_var_2) -> -	case happyOut53 happy_x_3 of { (HappyWrap53 happy_var_3) -> -	case happyOut13 happy_x_4 of { (HappyWrap13 happy_var_4) -> -	happyIn11-		 (do ((entry_ret_label, info, stk_formals, formals), agraph) <--                       getCodeScoped $ loopDecls $ do {-                         (entry_ret_label, info, stk_formals) <- happy_var_1;-                         platform <- getPlatform;-                         ctx      <- getContext;-                         formals <- sequence (fromMaybe [] happy_var_3);-                         withName (renderWithContext ctx (pdoc platform entry_ret_label))-                           happy_var_4;-                         return (entry_ret_label, info, stk_formals, formals) }-                     let do_layout = isJust happy_var_3-                     code (emitProcWithStackFrame happy_var_2 info-                                entry_ret_label stk_formals formals agraph-                                do_layout )-	) `HappyStk` happyRest}}}}--happyReduce_20 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_20 = happySpecReduce_0  8# happyReduction_20-happyReduction_20  =  happyIn12-		 (NativeNodeCall-	)--happyReduce_21 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_21 = happySpecReduce_1  8# happyReduction_21-happyReduction_21 happy_x_1-	 =  happyIn12-		 (NativeReturn-	)--happyReduce_22 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_22 = happySpecReduce_1  9# happyReduction_22-happyReduction_22 happy_x_1-	 =  happyIn13-		 (return ()-	)--happyReduce_23 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_23 = happySpecReduce_3  9# happyReduction_23-happyReduction_23 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOutTok happy_x_1 of { happy_var_1 -> -	case happyOut15 happy_x_2 of { (HappyWrap15 happy_var_2) -> -	case happyOutTok happy_x_3 of { happy_var_3 -> -	happyIn13-		 (withSourceNote happy_var_1 happy_var_3 happy_var_2-	)}}}--happyReduce_24 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_24 = happyMonadReduce 1# 10# happyReduction_24-happyReduction_24 (happy_x_1 `HappyStk`-	happyRest) tk-	 = happyThen ((case happyOutTok happy_x_1 of { (L _ (CmmT_Name        happy_var_1)) -> -	( do-                     home_unit_id <- getHomeUnitId-                     liftP $ pure $ do-                       newFunctionName happy_var_1 home_unit_id-                       return (mkCmmCodeLabel home_unit_id happy_var_1, Nothing, []))})-	) (\r -> happyReturn (happyIn14 r))--happyReduce_25 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_25 = happyMonadReduce 14# 10# happyReduction_25-happyReduction_25 (happy_x_14 `HappyStk`-	happy_x_13 `HappyStk`-	happy_x_12 `HappyStk`-	happy_x_11 `HappyStk`-	happy_x_10 `HappyStk`-	happy_x_9 `HappyStk`-	happy_x_8 `HappyStk`-	happy_x_7 `HappyStk`-	happy_x_6 `HappyStk`-	happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest) tk-	 = happyThen ((case happyOutTok happy_x_3 of { (L _ (CmmT_Name        happy_var_3)) -> -	case happyOutTok happy_x_5 of { (L _ (CmmT_Int         happy_var_5)) -> -	case happyOutTok happy_x_7 of { (L _ (CmmT_Int         happy_var_7)) -> -	case happyOutTok happy_x_9 of { (L _ (CmmT_Int         happy_var_9)) -> -	case happyOutTok happy_x_11 of { (L _ (CmmT_String      happy_var_11)) -> -	case happyOutTok happy_x_13 of { (L _ (CmmT_String      happy_var_13)) -> -	( do-                      home_unit_id <- getHomeUnitId-                      liftP $ pure $ do-                        profile <- getProfile-                        let prof = profilingInfo profile happy_var_11 happy_var_13-                            rep  = mkRTSRep (fromIntegral happy_var_9) $-                                     mkHeapRep profile False (fromIntegral happy_var_5)-                                                     (fromIntegral happy_var_7) Thunk-                                -- not really Thunk, but that makes the info table-                                -- we want.-                        return (mkCmmEntryLabel home_unit_id happy_var_3,-                                Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel home_unit_id happy_var_3-                                             , cit_rep = rep-                                             , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },-                                []))}}}}}})-	) (\r -> happyReturn (happyIn14 r))--happyReduce_26 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_26 = happyMonadReduce 16# 10# happyReduction_26-happyReduction_26 (happy_x_16 `HappyStk`-	happy_x_15 `HappyStk`-	happy_x_14 `HappyStk`-	happy_x_13 `HappyStk`-	happy_x_12 `HappyStk`-	happy_x_11 `HappyStk`-	happy_x_10 `HappyStk`-	happy_x_9 `HappyStk`-	happy_x_8 `HappyStk`-	happy_x_7 `HappyStk`-	happy_x_6 `HappyStk`-	happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest) tk-	 = happyThen ((case happyOutTok happy_x_3 of { (L _ (CmmT_Name        happy_var_3)) -> -	case happyOutTok happy_x_5 of { (L _ (CmmT_Int         happy_var_5)) -> -	case happyOutTok happy_x_7 of { (L _ (CmmT_Int         happy_var_7)) -> -	case happyOutTok happy_x_9 of { (L _ (CmmT_Int         happy_var_9)) -> -	case happyOutTok happy_x_11 of { (L _ (CmmT_String      happy_var_11)) -> -	case happyOutTok happy_x_13 of { (L _ (CmmT_String      happy_var_13)) -> -	case happyOutTok happy_x_15 of { (L _ (CmmT_Int         happy_var_15)) -> -	( do-                      home_unit_id <- getHomeUnitId-                      liftP $ pure $ do-                        profile <- getProfile-                        let prof = profilingInfo profile happy_var_11 happy_var_13-                            ty   = Fun 0 (ArgSpec (fromIntegral happy_var_15))-                                  -- Arity zero, arg_type happy_var_15-                            rep = mkRTSRep (fromIntegral happy_var_9) $-                                      mkHeapRep profile False (fromIntegral happy_var_5)-                                                      (fromIntegral happy_var_7) ty-                        return (mkCmmEntryLabel home_unit_id happy_var_3,-                                Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel home_unit_id happy_var_3-                                             , cit_rep = rep-                                             , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },-                                []))}}}}}}})-	) (\r -> happyReturn (happyIn14 r))--happyReduce_27 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_27 = happyMonadReduce 16# 10# happyReduction_27-happyReduction_27 (happy_x_16 `HappyStk`-	happy_x_15 `HappyStk`-	happy_x_14 `HappyStk`-	happy_x_13 `HappyStk`-	happy_x_12 `HappyStk`-	happy_x_11 `HappyStk`-	happy_x_10 `HappyStk`-	happy_x_9 `HappyStk`-	happy_x_8 `HappyStk`-	happy_x_7 `HappyStk`-	happy_x_6 `HappyStk`-	happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest) tk-	 = happyThen ((case happyOutTok happy_x_3 of { (L _ (CmmT_Name        happy_var_3)) -> -	case happyOutTok happy_x_5 of { (L _ (CmmT_Int         happy_var_5)) -> -	case happyOutTok happy_x_7 of { (L _ (CmmT_Int         happy_var_7)) -> -	case happyOutTok happy_x_9 of { (L _ (CmmT_Int         happy_var_9)) -> -	case happyOutTok happy_x_11 of { (L _ (CmmT_Int         happy_var_11)) -> -	case happyOutTok happy_x_13 of { (L _ (CmmT_String      happy_var_13)) -> -	case happyOutTok happy_x_15 of { (L _ (CmmT_String      happy_var_15)) -> -	( do-                      home_unit_id <- getHomeUnitId-                      liftP $ pure $ do-                        profile <- getProfile-                        let prof = profilingInfo profile happy_var_13 happy_var_15-                            ty  = Constr (fromIntegral happy_var_9)  -- Tag-                                         (BS8.pack happy_var_13)-                            rep = mkRTSRep (fromIntegral happy_var_11) $-                                    mkHeapRep profile False (fromIntegral happy_var_5)-                                                    (fromIntegral happy_var_7) ty-                        return (mkCmmEntryLabel home_unit_id happy_var_3,-                                Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel home_unit_id happy_var_3-                                             , cit_rep = rep-                                             , cit_prof = prof, cit_srt = Nothing,cit_clo = Nothing },-                                []))}}}}}}})-	) (\r -> happyReturn (happyIn14 r))--happyReduce_28 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_28 = happyMonadReduce 12# 10# happyReduction_28-happyReduction_28 (happy_x_12 `HappyStk`-	happy_x_11 `HappyStk`-	happy_x_10 `HappyStk`-	happy_x_9 `HappyStk`-	happy_x_8 `HappyStk`-	happy_x_7 `HappyStk`-	happy_x_6 `HappyStk`-	happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest) tk-	 = happyThen ((case happyOutTok happy_x_3 of { (L _ (CmmT_Name        happy_var_3)) -> -	case happyOutTok happy_x_5 of { (L _ (CmmT_Int         happy_var_5)) -> -	case happyOutTok happy_x_7 of { (L _ (CmmT_Int         happy_var_7)) -> -	case happyOutTok happy_x_9 of { (L _ (CmmT_String      happy_var_9)) -> -	case happyOutTok happy_x_11 of { (L _ (CmmT_String      happy_var_11)) -> -	( do-                      home_unit_id <- getHomeUnitId-                      liftP $ pure $ do-                        profile <- getProfile-                        let prof = profilingInfo profile happy_var_9 happy_var_11-                            ty  = ThunkSelector (fromIntegral happy_var_5)-                            rep = mkRTSRep (fromIntegral happy_var_7) $-                                     mkHeapRep profile False 0 0 ty-                        return (mkCmmEntryLabel home_unit_id happy_var_3,-                                Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel home_unit_id happy_var_3-                                             , cit_rep = rep-                                             , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },-                                []))}}}}})-	) (\r -> happyReturn (happyIn14 r))--happyReduce_29 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_29 = happyMonadReduce 6# 10# happyReduction_29-happyReduction_29 (happy_x_6 `HappyStk`-	happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest) tk-	 = happyThen ((case happyOutTok happy_x_3 of { (L _ (CmmT_Name        happy_var_3)) -> -	case happyOutTok happy_x_5 of { (L _ (CmmT_Int         happy_var_5)) -> -	( do-                      home_unit_id <- getHomeUnitId-                      liftP $ pure $ do-                        let prof = NoProfilingInfo-                            rep  = mkRTSRep (fromIntegral happy_var_5) $ mkStackRep []-                        return (mkCmmRetLabel home_unit_id happy_var_3,-                                Just $ CmmInfoTable { cit_lbl = mkCmmRetInfoLabel home_unit_id happy_var_3-                                             , cit_rep = rep-                                             , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },-                                []))}})-	) (\r -> happyReturn (happyIn14 r))--happyReduce_30 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_30 = happyMonadReduce 8# 10# happyReduction_30-happyReduction_30 (happy_x_8 `HappyStk`-	happy_x_7 `HappyStk`-	happy_x_6 `HappyStk`-	happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest) tk-	 = happyThen ((case happyOutTok happy_x_3 of { (L _ (CmmT_Name        happy_var_3)) -> -	case happyOutTok happy_x_5 of { (L _ (CmmT_Int         happy_var_5)) -> -	case happyOut54 happy_x_7 of { (HappyWrap54 happy_var_7) -> -	( do-                      home_unit_id <- getHomeUnitId-                      liftP $ pure $ do-                        platform <- getPlatform-                        live <- sequence happy_var_7-                        let prof = NoProfilingInfo-                            -- drop one for the info pointer-                            bitmap = mkLiveness platform (drop 1 live)-                            rep  = mkRTSRep (fromIntegral happy_var_5) $ mkStackRep bitmap-                        return (mkCmmRetLabel home_unit_id happy_var_3,-                                Just $ CmmInfoTable { cit_lbl = mkCmmRetInfoLabel home_unit_id happy_var_3-                                             , cit_rep = rep-                                             , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },-                                live))}}})-	) (\r -> happyReturn (happyIn14 r))--happyReduce_31 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_31 = happySpecReduce_0  11# happyReduction_31-happyReduction_31  =  happyIn15-		 (return ()-	)--happyReduce_32 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_32 = happySpecReduce_2  11# happyReduction_32-happyReduction_32 happy_x_2-	happy_x_1-	 =  case happyOut16 happy_x_1 of { (HappyWrap16 happy_var_1) -> -	case happyOut15 happy_x_2 of { (HappyWrap15 happy_var_2) -> -	happyIn15-		 (do happy_var_1; happy_var_2-	)}}--happyReduce_33 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_33 = happySpecReduce_2  11# happyReduction_33-happyReduction_33 happy_x_2-	happy_x_1-	 =  case happyOut20 happy_x_1 of { (HappyWrap20 happy_var_1) -> -	case happyOut15 happy_x_2 of { (HappyWrap15 happy_var_2) -> -	happyIn15-		 (do happy_var_1; happy_var_2-	)}}--happyReduce_34 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_34 = happySpecReduce_3  12# happyReduction_34-happyReduction_34 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut57 happy_x_1 of { (HappyWrap57 happy_var_1) -> -	case happyOut19 happy_x_2 of { (HappyWrap19 happy_var_2) -> -	happyIn16-		 (mapM_ (newLocal happy_var_1) happy_var_2-	)}}--happyReduce_35 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_35 = happySpecReduce_3  12# happyReduction_35-happyReduction_35 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut17 happy_x_2 of { (HappyWrap17 happy_var_2) -> -	happyIn16-		 (mapM_ newImport happy_var_2-	)}--happyReduce_36 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_36 = happySpecReduce_3  12# happyReduction_36-happyReduction_36 happy_x_3-	happy_x_2-	happy_x_1-	 =  happyIn16-		 (return ()-	)--happyReduce_37 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_37 = happySpecReduce_1  13# happyReduction_37-happyReduction_37 happy_x_1-	 =  case happyOut18 happy_x_1 of { (HappyWrap18 happy_var_1) -> -	happyIn17-		 ([happy_var_1]-	)}--happyReduce_38 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_38 = happySpecReduce_3  13# happyReduction_38-happyReduction_38 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut18 happy_x_1 of { (HappyWrap18 happy_var_1) -> -	case happyOut17 happy_x_3 of { (HappyWrap17 happy_var_3) -> -	happyIn17-		 (happy_var_1 : happy_var_3-	)}}--happyReduce_39 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_39 = happySpecReduce_1  14# happyReduction_39-happyReduction_39 happy_x_1-	 =  case happyOutTok happy_x_1 of { (L _ (CmmT_Name        happy_var_1)) -> -	happyIn18-		 ((happy_var_1, mkForeignLabel happy_var_1 Nothing ForeignLabelInExternalPackage IsFunction)-	)}--happyReduce_40 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_40 = happySpecReduce_2  14# happyReduction_40-happyReduction_40 happy_x_2-	happy_x_1-	 =  case happyOutTok happy_x_2 of { (L _ (CmmT_Name        happy_var_2)) -> -	happyIn18-		 ((happy_var_2, mkForeignLabel happy_var_2 Nothing ForeignLabelInExternalPackage IsData)-	)}--happyReduce_41 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_41 = happySpecReduce_2  14# happyReduction_41-happyReduction_41 happy_x_2-	happy_x_1-	 =  case happyOutTok happy_x_1 of { (L _ (CmmT_String      happy_var_1)) -> -	case happyOutTok happy_x_2 of { (L _ (CmmT_Name        happy_var_2)) -> -	happyIn18-		 ((happy_var_2, mkCmmCodeLabel (UnitId (mkFastString happy_var_1)) happy_var_2)-	)}}--happyReduce_42 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_42 = happySpecReduce_1  15# happyReduction_42-happyReduction_42 happy_x_1-	 =  case happyOutTok happy_x_1 of { (L _ (CmmT_Name        happy_var_1)) -> -	happyIn19-		 ([happy_var_1]-	)}--happyReduce_43 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_43 = happySpecReduce_3  15# happyReduction_43-happyReduction_43 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOutTok happy_x_1 of { (L _ (CmmT_Name        happy_var_1)) -> -	case happyOut19 happy_x_3 of { (HappyWrap19 happy_var_3) -> -	happyIn19-		 (happy_var_1 : happy_var_3-	)}}--happyReduce_44 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_44 = happySpecReduce_1  16# happyReduction_44-happyReduction_44 happy_x_1-	 =  happyIn20-		 (return ()-	)--happyReduce_45 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_45 = happySpecReduce_2  16# happyReduction_45-happyReduction_45 happy_x_2-	happy_x_1-	 =  case happyOutTok happy_x_1 of { (L _ (CmmT_Name        happy_var_1)) -> -	happyIn20-		 (do l <- newLabel happy_var_1; emitLabel l-	)}--happyReduce_46 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_46 = happyReduce 4# 16# happyReduction_46-happyReduction_46 (happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut52 happy_x_1 of { (HappyWrap52 happy_var_1) -> -	case happyOutTok happy_x_2 of { happy_var_2 -> -	case happyOut38 happy_x_3 of { (HappyWrap38 happy_var_3) -> -	case happyOutTok happy_x_4 of { happy_var_4 -> -	happyIn20-		 (do reg <- happy_var_1; e <- happy_var_3; withSourceNote happy_var_2 happy_var_4 (emitAssign reg e)-	) `HappyStk` happyRest}}}}--happyReduce_47 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_47 = happyReduce 7# 16# happyReduction_47-happyReduction_47 (happy_x_7 `HappyStk`-	happy_x_6 `HappyStk`-	happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut57 happy_x_1 of { (HappyWrap57 happy_var_1) -> -	case happyOutTok happy_x_2 of { happy_var_2 -> -	case happyOut38 happy_x_3 of { (HappyWrap38 happy_var_3) -> -	case happyOut38 happy_x_6 of { (HappyWrap38 happy_var_6) -> -	case happyOutTok happy_x_7 of { happy_var_7 -> -	happyIn20-		 (withSourceNote happy_var_2 happy_var_7 (doStore happy_var_1 happy_var_3 happy_var_6)-	) `HappyStk` happyRest}}}}}--happyReduce_48 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_48 = happyMonadReduce 10# 16# happyReduction_48-happyReduction_48 (happy_x_10 `HappyStk`-	happy_x_9 `HappyStk`-	happy_x_8 `HappyStk`-	happy_x_7 `HappyStk`-	happy_x_6 `HappyStk`-	happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest) tk-	 = happyThen ((case happyOut48 happy_x_1 of { (HappyWrap48 happy_var_1) -> -	case happyOutTok happy_x_3 of { (L _ (CmmT_String      happy_var_3)) -> -	case happyOut23 happy_x_4 of { (HappyWrap23 happy_var_4) -> -	case happyOut42 happy_x_6 of { (HappyWrap42 happy_var_6) -> -	case happyOut27 happy_x_8 of { (HappyWrap27 happy_var_8) -> -	case happyOut24 happy_x_9 of { (HappyWrap24 happy_var_9) -> -	( foreignCall happy_var_3 happy_var_1 happy_var_4 happy_var_6 happy_var_8 happy_var_9)}}}}}})-	) (\r -> happyReturn (happyIn20 r))--happyReduce_49 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_49 = happyMonadReduce 8# 16# happyReduction_49-happyReduction_49 (happy_x_8 `HappyStk`-	happy_x_7 `HappyStk`-	happy_x_6 `HappyStk`-	happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest) tk-	 = happyThen ((case happyOut48 happy_x_1 of { (HappyWrap48 happy_var_1) -> -	case happyOutTok happy_x_4 of { (L _ (CmmT_Name        happy_var_4)) -> -	case happyOut45 happy_x_6 of { (HappyWrap45 happy_var_6) -> -	( primCall happy_var_1 happy_var_4 happy_var_6)}}})-	) (\r -> happyReturn (happyIn20 r))--happyReduce_50 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_50 = happyMonadReduce 5# 16# happyReduction_50-happyReduction_50 (happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest) tk-	 = happyThen ((case happyOutTok happy_x_1 of { (L _ (CmmT_Name        happy_var_1)) -> -	case happyOut45 happy_x_3 of { (HappyWrap45 happy_var_3) -> -	( stmtMacro happy_var_1 happy_var_3)}})-	) (\r -> happyReturn (happyIn20 r))--happyReduce_51 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_51 = happyReduce 7# 16# happyReduction_51-happyReduction_51 (happy_x_7 `HappyStk`-	happy_x_6 `HappyStk`-	happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut30 happy_x_2 of { (HappyWrap30 happy_var_2) -> -	case happyOut38 happy_x_3 of { (HappyWrap38 happy_var_3) -> -	case happyOut31 happy_x_5 of { (HappyWrap31 happy_var_5) -> -	case happyOut35 happy_x_6 of { (HappyWrap35 happy_var_6) -> -	happyIn20-		 (do as <- sequence happy_var_5; doSwitch happy_var_2 happy_var_3 as happy_var_6-	) `HappyStk` happyRest}}}}--happyReduce_52 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_52 = happySpecReduce_3  16# happyReduction_52-happyReduction_52 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOutTok happy_x_2 of { (L _ (CmmT_Name        happy_var_2)) -> -	happyIn20-		 (do l <- lookupLabel happy_var_2; emit (mkBranch l)-	)}--happyReduce_53 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_53 = happyReduce 5# 16# happyReduction_53-happyReduction_53 (happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut45 happy_x_3 of { (HappyWrap45 happy_var_3) -> -	happyIn20-		 (doReturn happy_var_3-	) `HappyStk` happyRest}--happyReduce_54 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_54 = happyReduce 4# 16# happyReduction_54-happyReduction_54 (happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut38 happy_x_2 of { (HappyWrap38 happy_var_2) -> -	case happyOut28 happy_x_3 of { (HappyWrap28 happy_var_3) -> -	happyIn20-		 (doRawJump happy_var_2 happy_var_3-	) `HappyStk` happyRest}}--happyReduce_55 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_55 = happyReduce 6# 16# happyReduction_55-happyReduction_55 (happy_x_6 `HappyStk`-	happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut38 happy_x_2 of { (HappyWrap38 happy_var_2) -> -	case happyOut45 happy_x_4 of { (HappyWrap45 happy_var_4) -> -	happyIn20-		 (doJumpWithStack happy_var_2 [] happy_var_4-	) `HappyStk` happyRest}}--happyReduce_56 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_56 = happyReduce 9# 16# happyReduction_56-happyReduction_56 (happy_x_9 `HappyStk`-	happy_x_8 `HappyStk`-	happy_x_7 `HappyStk`-	happy_x_6 `HappyStk`-	happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut38 happy_x_2 of { (HappyWrap38 happy_var_2) -> -	case happyOut45 happy_x_4 of { (HappyWrap45 happy_var_4) -> -	case happyOut45 happy_x_7 of { (HappyWrap45 happy_var_7) -> -	happyIn20-		 (doJumpWithStack happy_var_2 happy_var_4 happy_var_7-	) `HappyStk` happyRest}}}--happyReduce_57 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_57 = happyReduce 6# 16# happyReduction_57-happyReduction_57 (happy_x_6 `HappyStk`-	happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut38 happy_x_2 of { (HappyWrap38 happy_var_2) -> -	case happyOut45 happy_x_4 of { (HappyWrap45 happy_var_4) -> -	happyIn20-		 (doCall happy_var_2 [] happy_var_4-	) `HappyStk` happyRest}}--happyReduce_58 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_58 = happyReduce 10# 16# happyReduction_58-happyReduction_58 (happy_x_10 `HappyStk`-	happy_x_9 `HappyStk`-	happy_x_8 `HappyStk`-	happy_x_7 `HappyStk`-	happy_x_6 `HappyStk`-	happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut55 happy_x_2 of { (HappyWrap55 happy_var_2) -> -	case happyOut38 happy_x_6 of { (HappyWrap38 happy_var_6) -> -	case happyOut45 happy_x_8 of { (HappyWrap45 happy_var_8) -> -	happyIn20-		 (doCall happy_var_6 happy_var_2 happy_var_8-	) `HappyStk` happyRest}}}--happyReduce_59 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_59 = happyReduce 5# 16# happyReduction_59-happyReduction_59 (happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut25 happy_x_2 of { (HappyWrap25 happy_var_2) -> -	case happyOut37 happy_x_3 of { (HappyWrap37 happy_var_3) -> -	case happyOutTok happy_x_5 of { (L _ (CmmT_Name        happy_var_5)) -> -	happyIn20-		 (do l <- lookupLabel happy_var_5; cmmRawIf happy_var_2 l happy_var_3-	) `HappyStk` happyRest}}}--happyReduce_60 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_60 = happyReduce 7# 16# happyReduction_60-happyReduction_60 (happy_x_7 `HappyStk`-	happy_x_6 `HappyStk`-	happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut25 happy_x_2 of { (HappyWrap25 happy_var_2) -> -	case happyOut37 happy_x_3 of { (HappyWrap37 happy_var_3) -> -	case happyOutTok happy_x_4 of { happy_var_4 -> -	case happyOut15 happy_x_5 of { (HappyWrap15 happy_var_5) -> -	case happyOutTok happy_x_6 of { happy_var_6 -> -	case happyOut36 happy_x_7 of { (HappyWrap36 happy_var_7) -> -	happyIn20-		 (cmmIfThenElse happy_var_2 (withSourceNote happy_var_4 happy_var_6 happy_var_5) happy_var_7 happy_var_3-	) `HappyStk` happyRest}}}}}}--happyReduce_61 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_61 = happyReduce 5# 16# happyReduction_61-happyReduction_61 (happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut45 happy_x_3 of { (HappyWrap45 happy_var_3) -> -	case happyOut13 happy_x_5 of { (HappyWrap13 happy_var_5) -> -	happyIn20-		 (pushStackFrame happy_var_3 happy_var_5-	) `HappyStk` happyRest}}--happyReduce_62 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_62 = happyReduce 5# 16# happyReduction_62-happyReduction_62 (happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut38 happy_x_2 of { (HappyWrap38 happy_var_2) -> -	case happyOut52 happy_x_4 of { (HappyWrap52 happy_var_4) -> -	case happyOut13 happy_x_5 of { (HappyWrap13 happy_var_5) -> -	happyIn20-		 (reserveStackFrame happy_var_2 happy_var_4 happy_var_5-	) `HappyStk` happyRest}}}--happyReduce_63 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_63 = happySpecReduce_3  16# happyReduction_63-happyReduction_63 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut21 happy_x_2 of { (HappyWrap21 happy_var_2) -> -	happyIn20-		 (happy_var_2 >>= code . emitUnwind-	)}--happyReduce_64 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_64 = happyReduce 5# 17# happyReduction_64-happyReduction_64 (happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOutTok happy_x_1 of { (L _ (CmmT_GlobalReg   happy_var_1)) -> -	case happyOut22 happy_x_3 of { (HappyWrap22 happy_var_3) -> -	case happyOut21 happy_x_5 of { (HappyWrap21 happy_var_5) -> -	happyIn21-		 (do e <- happy_var_3; rest <- happy_var_5; return ((happy_var_1, e) : rest)-	) `HappyStk` happyRest}}}--happyReduce_65 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_65 = happySpecReduce_3  17# happyReduction_65-happyReduction_65 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOutTok happy_x_1 of { (L _ (CmmT_GlobalReg   happy_var_1)) -> -	case happyOut22 happy_x_3 of { (HappyWrap22 happy_var_3) -> -	happyIn21-		 (do e <- happy_var_3; return [(happy_var_1, e)]-	)}}--happyReduce_66 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_66 = happySpecReduce_1  18# happyReduction_66-happyReduction_66 happy_x_1-	 =  happyIn22-		 (do return Nothing-	)--happyReduce_67 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_67 = happySpecReduce_1  18# happyReduction_67-happyReduction_67 happy_x_1-	 =  case happyOut38 happy_x_1 of { (HappyWrap38 happy_var_1) -> -	happyIn22-		 (do e <- happy_var_1; return (Just e)-	)}--happyReduce_68 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_68 = happySpecReduce_1  19# happyReduction_68-happyReduction_68 happy_x_1-	 =  case happyOutTok happy_x_1 of { (L _ (CmmT_Name        happy_var_1)) -> -	happyIn23-		 (return (CmmLit (CmmLabel (mkForeignLabel happy_var_1 Nothing ForeignLabelInThisPackage IsFunction)))-	)}--happyReduce_69 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_69 = happySpecReduce_0  20# happyReduction_69-happyReduction_69  =  happyIn24-		 (CmmMayReturn-	)--happyReduce_70 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_70 = happySpecReduce_2  20# happyReduction_70-happyReduction_70 happy_x_2-	happy_x_1-	 =  happyIn24-		 (CmmNeverReturns-	)--happyReduce_71 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_71 = happySpecReduce_1  21# happyReduction_71-happyReduction_71 happy_x_1-	 =  case happyOut26 happy_x_1 of { (HappyWrap26 happy_var_1) -> -	happyIn25-		 (happy_var_1-	)}--happyReduce_72 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_72 = happySpecReduce_1  21# happyReduction_72-happyReduction_72 happy_x_1-	 =  case happyOut38 happy_x_1 of { (HappyWrap38 happy_var_1) -> -	happyIn25-		 (do e <- happy_var_1; return (BoolTest e)-	)}--happyReduce_73 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_73 = happySpecReduce_3  22# happyReduction_73-happyReduction_73 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut25 happy_x_1 of { (HappyWrap25 happy_var_1) -> -	case happyOut25 happy_x_3 of { (HappyWrap25 happy_var_3) -> -	happyIn26-		 (do e1 <- happy_var_1; e2 <- happy_var_3;-                                          return (BoolAnd e1 e2)-	)}}--happyReduce_74 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_74 = happySpecReduce_3  22# happyReduction_74-happyReduction_74 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut25 happy_x_1 of { (HappyWrap25 happy_var_1) -> -	case happyOut25 happy_x_3 of { (HappyWrap25 happy_var_3) -> -	happyIn26-		 (do e1 <- happy_var_1; e2 <- happy_var_3;-                                          return (BoolOr e1 e2)-	)}}--happyReduce_75 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_75 = happySpecReduce_2  22# happyReduction_75-happyReduction_75 happy_x_2-	happy_x_1-	 =  case happyOut25 happy_x_2 of { (HappyWrap25 happy_var_2) -> -	happyIn26-		 (do e <- happy_var_2; return (BoolNot e)-	)}--happyReduce_76 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_76 = happySpecReduce_3  22# happyReduction_76-happyReduction_76 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut26 happy_x_2 of { (HappyWrap26 happy_var_2) -> -	happyIn26-		 (happy_var_2-	)}--happyReduce_77 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_77 = happySpecReduce_0  23# happyReduction_77-happyReduction_77  =  happyIn27-		 (PlayRisky-	)--happyReduce_78 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_78 = happyMonadReduce 1# 23# happyReduction_78-happyReduction_78 (happy_x_1 `HappyStk`-	happyRest) tk-	 = happyThen ((case happyOutTok happy_x_1 of { (L _ (CmmT_String      happy_var_1)) -> -	( parseSafety happy_var_1)})-	) (\r -> happyReturn (happyIn27 r))--happyReduce_79 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_79 = happySpecReduce_2  24# happyReduction_79-happyReduction_79 happy_x_2-	happy_x_1-	 =  happyIn28-		 ([]-	)--happyReduce_80 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_80 = happyMonadReduce 3# 24# happyReduction_80-happyReduction_80 (happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest) tk-	 = happyThen ((( do platform <- PD.getPlatform-                                         ; return (realArgRegsCover platform)))-	) (\r -> happyReturn (happyIn28 r))--happyReduce_81 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_81 = happySpecReduce_3  24# happyReduction_81-happyReduction_81 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut29 happy_x_2 of { (HappyWrap29 happy_var_2) -> -	happyIn28-		 (happy_var_2-	)}--happyReduce_82 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_82 = happySpecReduce_1  25# happyReduction_82-happyReduction_82 happy_x_1-	 =  case happyOutTok happy_x_1 of { (L _ (CmmT_GlobalReg   happy_var_1)) -> -	happyIn29-		 ([happy_var_1]-	)}--happyReduce_83 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_83 = happySpecReduce_3  25# happyReduction_83-happyReduction_83 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOutTok happy_x_1 of { (L _ (CmmT_GlobalReg   happy_var_1)) -> -	case happyOut29 happy_x_3 of { (HappyWrap29 happy_var_3) -> -	happyIn29-		 (happy_var_1 : happy_var_3-	)}}--happyReduce_84 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_84 = happyReduce 5# 26# happyReduction_84-happyReduction_84 (happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOutTok happy_x_2 of { (L _ (CmmT_Int         happy_var_2)) -> -	case happyOutTok happy_x_4 of { (L _ (CmmT_Int         happy_var_4)) -> -	happyIn30-		 (Just (happy_var_2, happy_var_4)-	) `HappyStk` happyRest}}--happyReduce_85 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_85 = happySpecReduce_0  26# happyReduction_85-happyReduction_85  =  happyIn30-		 (Nothing-	)--happyReduce_86 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_86 = happySpecReduce_0  27# happyReduction_86-happyReduction_86  =  happyIn31-		 ([]-	)--happyReduce_87 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_87 = happySpecReduce_2  27# happyReduction_87-happyReduction_87 happy_x_2-	happy_x_1-	 =  case happyOut32 happy_x_1 of { (HappyWrap32 happy_var_1) -> -	case happyOut31 happy_x_2 of { (HappyWrap31 happy_var_2) -> -	happyIn31-		 (happy_var_1 : happy_var_2-	)}}--happyReduce_88 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_88 = happyReduce 4# 28# happyReduction_88-happyReduction_88 (happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut34 happy_x_2 of { (HappyWrap34 happy_var_2) -> -	case happyOut33 happy_x_4 of { (HappyWrap33 happy_var_4) -> -	happyIn32-		 (do b <- happy_var_4; return (happy_var_2, b)-	) `HappyStk` happyRest}}--happyReduce_89 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_89 = happySpecReduce_3  29# happyReduction_89-happyReduction_89 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOutTok happy_x_1 of { happy_var_1 -> -	case happyOut15 happy_x_2 of { (HappyWrap15 happy_var_2) -> -	case happyOutTok happy_x_3 of { happy_var_3 -> -	happyIn33-		 (return (Right (withSourceNote happy_var_1 happy_var_3 happy_var_2))-	)}}}--happyReduce_90 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_90 = happySpecReduce_3  29# happyReduction_90-happyReduction_90 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOutTok happy_x_2 of { (L _ (CmmT_Name        happy_var_2)) -> -	happyIn33-		 (do l <- lookupLabel happy_var_2; return (Left l)-	)}--happyReduce_91 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_91 = happySpecReduce_1  30# happyReduction_91-happyReduction_91 happy_x_1-	 =  case happyOutTok happy_x_1 of { (L _ (CmmT_Int         happy_var_1)) -> -	happyIn34-		 ([ happy_var_1 ]-	)}--happyReduce_92 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_92 = happySpecReduce_3  30# happyReduction_92-happyReduction_92 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOutTok happy_x_1 of { (L _ (CmmT_Int         happy_var_1)) -> -	case happyOut34 happy_x_3 of { (HappyWrap34 happy_var_3) -> -	happyIn34-		 (happy_var_1 : happy_var_3-	)}}--happyReduce_93 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_93 = happyReduce 5# 31# happyReduction_93-happyReduction_93 (happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOutTok happy_x_3 of { happy_var_3 -> -	case happyOut15 happy_x_4 of { (HappyWrap15 happy_var_4) -> -	case happyOutTok happy_x_5 of { happy_var_5 -> -	happyIn35-		 (Just (withSourceNote happy_var_3 happy_var_5 happy_var_4)-	) `HappyStk` happyRest}}}--happyReduce_94 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_94 = happySpecReduce_0  31# happyReduction_94-happyReduction_94  =  happyIn35-		 (Nothing-	)--happyReduce_95 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_95 = happySpecReduce_0  32# happyReduction_95-happyReduction_95  =  happyIn36-		 (return ()-	)--happyReduce_96 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_96 = happyReduce 4# 32# happyReduction_96-happyReduction_96 (happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOutTok happy_x_2 of { happy_var_2 -> -	case happyOut15 happy_x_3 of { (HappyWrap15 happy_var_3) -> -	case happyOutTok happy_x_4 of { happy_var_4 -> -	happyIn36-		 (withSourceNote happy_var_2 happy_var_4 happy_var_3-	) `HappyStk` happyRest}}}--happyReduce_97 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_97 = happyReduce 5# 33# happyReduction_97-happyReduction_97 (happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = happyIn37-		 (Just True-	) `HappyStk` happyRest--happyReduce_98 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_98 = happyReduce 5# 33# happyReduction_98-happyReduction_98 (happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = happyIn37-		 (Just False-	) `HappyStk` happyRest--happyReduce_99 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_99 = happySpecReduce_0  33# happyReduction_99-happyReduction_99  =  happyIn37-		 (Nothing-	)--happyReduce_100 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_100 = happySpecReduce_3  34# happyReduction_100-happyReduction_100 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut38 happy_x_1 of { (HappyWrap38 happy_var_1) -> -	case happyOut38 happy_x_3 of { (HappyWrap38 happy_var_3) -> -	happyIn38-		 (mkMachOp MO_U_Quot [happy_var_1,happy_var_3]-	)}}--happyReduce_101 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_101 = happySpecReduce_3  34# happyReduction_101-happyReduction_101 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut38 happy_x_1 of { (HappyWrap38 happy_var_1) -> -	case happyOut38 happy_x_3 of { (HappyWrap38 happy_var_3) -> -	happyIn38-		 (mkMachOp MO_Mul [happy_var_1,happy_var_3]-	)}}--happyReduce_102 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_102 = happySpecReduce_3  34# happyReduction_102-happyReduction_102 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut38 happy_x_1 of { (HappyWrap38 happy_var_1) -> -	case happyOut38 happy_x_3 of { (HappyWrap38 happy_var_3) -> -	happyIn38-		 (mkMachOp MO_U_Rem [happy_var_1,happy_var_3]-	)}}--happyReduce_103 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_103 = happySpecReduce_3  34# happyReduction_103-happyReduction_103 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut38 happy_x_1 of { (HappyWrap38 happy_var_1) -> -	case happyOut38 happy_x_3 of { (HappyWrap38 happy_var_3) -> -	happyIn38-		 (mkMachOp MO_Sub [happy_var_1,happy_var_3]-	)}}--happyReduce_104 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_104 = happySpecReduce_3  34# happyReduction_104-happyReduction_104 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut38 happy_x_1 of { (HappyWrap38 happy_var_1) -> -	case happyOut38 happy_x_3 of { (HappyWrap38 happy_var_3) -> -	happyIn38-		 (mkMachOp MO_Add [happy_var_1,happy_var_3]-	)}}--happyReduce_105 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_105 = happySpecReduce_3  34# happyReduction_105-happyReduction_105 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut38 happy_x_1 of { (HappyWrap38 happy_var_1) -> -	case happyOut38 happy_x_3 of { (HappyWrap38 happy_var_3) -> -	happyIn38-		 (mkMachOp MO_U_Shr [happy_var_1,happy_var_3]-	)}}--happyReduce_106 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_106 = happySpecReduce_3  34# happyReduction_106-happyReduction_106 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut38 happy_x_1 of { (HappyWrap38 happy_var_1) -> -	case happyOut38 happy_x_3 of { (HappyWrap38 happy_var_3) -> -	happyIn38-		 (mkMachOp MO_Shl [happy_var_1,happy_var_3]-	)}}--happyReduce_107 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_107 = happySpecReduce_3  34# happyReduction_107-happyReduction_107 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut38 happy_x_1 of { (HappyWrap38 happy_var_1) -> -	case happyOut38 happy_x_3 of { (HappyWrap38 happy_var_3) -> -	happyIn38-		 (mkMachOp MO_And [happy_var_1,happy_var_3]-	)}}--happyReduce_108 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_108 = happySpecReduce_3  34# happyReduction_108-happyReduction_108 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut38 happy_x_1 of { (HappyWrap38 happy_var_1) -> -	case happyOut38 happy_x_3 of { (HappyWrap38 happy_var_3) -> -	happyIn38-		 (mkMachOp MO_Xor [happy_var_1,happy_var_3]-	)}}--happyReduce_109 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_109 = happySpecReduce_3  34# happyReduction_109-happyReduction_109 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut38 happy_x_1 of { (HappyWrap38 happy_var_1) -> -	case happyOut38 happy_x_3 of { (HappyWrap38 happy_var_3) -> -	happyIn38-		 (mkMachOp MO_Or [happy_var_1,happy_var_3]-	)}}--happyReduce_110 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_110 = happySpecReduce_3  34# happyReduction_110-happyReduction_110 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut38 happy_x_1 of { (HappyWrap38 happy_var_1) -> -	case happyOut38 happy_x_3 of { (HappyWrap38 happy_var_3) -> -	happyIn38-		 (mkMachOp MO_U_Ge [happy_var_1,happy_var_3]-	)}}--happyReduce_111 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_111 = happySpecReduce_3  34# happyReduction_111-happyReduction_111 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut38 happy_x_1 of { (HappyWrap38 happy_var_1) -> -	case happyOut38 happy_x_3 of { (HappyWrap38 happy_var_3) -> -	happyIn38-		 (mkMachOp MO_U_Gt [happy_var_1,happy_var_3]-	)}}--happyReduce_112 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_112 = happySpecReduce_3  34# happyReduction_112-happyReduction_112 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut38 happy_x_1 of { (HappyWrap38 happy_var_1) -> -	case happyOut38 happy_x_3 of { (HappyWrap38 happy_var_3) -> -	happyIn38-		 (mkMachOp MO_U_Le [happy_var_1,happy_var_3]-	)}}--happyReduce_113 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_113 = happySpecReduce_3  34# happyReduction_113-happyReduction_113 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut38 happy_x_1 of { (HappyWrap38 happy_var_1) -> -	case happyOut38 happy_x_3 of { (HappyWrap38 happy_var_3) -> -	happyIn38-		 (mkMachOp MO_U_Lt [happy_var_1,happy_var_3]-	)}}--happyReduce_114 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_114 = happySpecReduce_3  34# happyReduction_114-happyReduction_114 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut38 happy_x_1 of { (HappyWrap38 happy_var_1) -> -	case happyOut38 happy_x_3 of { (HappyWrap38 happy_var_3) -> -	happyIn38-		 (mkMachOp MO_Ne [happy_var_1,happy_var_3]-	)}}--happyReduce_115 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_115 = happySpecReduce_3  34# happyReduction_115-happyReduction_115 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut38 happy_x_1 of { (HappyWrap38 happy_var_1) -> -	case happyOut38 happy_x_3 of { (HappyWrap38 happy_var_3) -> -	happyIn38-		 (mkMachOp MO_Eq [happy_var_1,happy_var_3]-	)}}--happyReduce_116 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_116 = happySpecReduce_2  34# happyReduction_116-happyReduction_116 happy_x_2-	happy_x_1-	 =  case happyOut38 happy_x_2 of { (HappyWrap38 happy_var_2) -> -	happyIn38-		 (mkMachOp MO_Not [happy_var_2]-	)}--happyReduce_117 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_117 = happySpecReduce_2  34# happyReduction_117-happyReduction_117 happy_x_2-	happy_x_1-	 =  case happyOut38 happy_x_2 of { (HappyWrap38 happy_var_2) -> -	happyIn38-		 (mkMachOp MO_S_Neg [happy_var_2]-	)}--happyReduce_118 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_118 = happyMonadReduce 5# 34# happyReduction_118-happyReduction_118 (happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest) tk-	 = happyThen ((case happyOut39 happy_x_1 of { (HappyWrap39 happy_var_1) -> -	case happyOutTok happy_x_3 of { (L _ (CmmT_Name        happy_var_3)) -> -	case happyOut39 happy_x_5 of { (HappyWrap39 happy_var_5) -> -	( do { mo <- nameToMachOp happy_var_3 ;-                                                return (mkMachOp mo [happy_var_1,happy_var_5]) })}}})-	) (\r -> happyReturn (happyIn38 r))--happyReduce_119 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_119 = happySpecReduce_1  34# happyReduction_119-happyReduction_119 happy_x_1-	 =  case happyOut39 happy_x_1 of { (HappyWrap39 happy_var_1) -> -	happyIn38-		 (happy_var_1-	)}--happyReduce_120 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_120 = happySpecReduce_2  35# happyReduction_120-happyReduction_120 happy_x_2-	happy_x_1-	 =  case happyOutTok happy_x_1 of { (L _ (CmmT_Int         happy_var_1)) -> -	case happyOut41 happy_x_2 of { (HappyWrap41 happy_var_2) -> -	happyIn39-		 (return (CmmLit (CmmInt happy_var_1 (typeWidth happy_var_2)))-	)}}--happyReduce_121 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_121 = happySpecReduce_2  35# happyReduction_121-happyReduction_121 happy_x_2-	happy_x_1-	 =  case happyOutTok happy_x_1 of { (L _ (CmmT_Float       happy_var_1)) -> -	case happyOut41 happy_x_2 of { (HappyWrap41 happy_var_2) -> -	happyIn39-		 (return (CmmLit (CmmFloat happy_var_1 (typeWidth happy_var_2)))-	)}}--happyReduce_122 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_122 = happySpecReduce_1  35# happyReduction_122-happyReduction_122 happy_x_1-	 =  case happyOutTok happy_x_1 of { (L _ (CmmT_String      happy_var_1)) -> -	happyIn39-		 (do s <- code (newStringCLit happy_var_1);-                                      return (CmmLit s)-	)}--happyReduce_123 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_123 = happySpecReduce_1  35# happyReduction_123-happyReduction_123 happy_x_1-	 =  case happyOut47 happy_x_1 of { (HappyWrap47 happy_var_1) -> -	happyIn39-		 (happy_var_1-	)}--happyReduce_124 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_124 = happySpecReduce_2  35# happyReduction_124-happyReduction_124 happy_x_2-	happy_x_1-	 =  case happyOut57 happy_x_1 of { (HappyWrap57 happy_var_1) -> -	case happyOut40 happy_x_2 of { (HappyWrap40 happy_var_2) -> -	happyIn39-		 (do (align, ptr) <- happy_var_2; return (CmmLoad ptr happy_var_1 align)-	)}}--happyReduce_125 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_125 = happyMonadReduce 5# 35# happyReduction_125-happyReduction_125 (happy_x_5 `HappyStk`-	happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest) tk-	 = happyThen ((case happyOutTok happy_x_2 of { (L _ (CmmT_Name        happy_var_2)) -> -	case happyOut45 happy_x_4 of { (HappyWrap45 happy_var_4) -> -	( exprOp happy_var_2 happy_var_4)}})-	) (\r -> happyReturn (happyIn39 r))--happyReduce_126 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_126 = happySpecReduce_3  35# happyReduction_126-happyReduction_126 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut38 happy_x_2 of { (HappyWrap38 happy_var_2) -> -	happyIn39-		 (happy_var_2-	)}--happyReduce_127 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_127 = happyReduce 4# 36# happyReduction_127-happyReduction_127 (happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut38 happy_x_3 of { (HappyWrap38 happy_var_3) -> -	happyIn40-		 (do ptr <- happy_var_3; return (Unaligned, ptr)-	) `HappyStk` happyRest}--happyReduce_128 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_128 = happySpecReduce_3  36# happyReduction_128-happyReduction_128 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut38 happy_x_2 of { (HappyWrap38 happy_var_2) -> -	happyIn40-		 (do ptr <- happy_var_2; return (NaturallyAligned, ptr)-	)}--happyReduce_129 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_129 = happyMonadReduce 0# 37# happyReduction_129-happyReduction_129 (happyRest) tk-	 = happyThen ((( do platform <- PD.getPlatform; return $ bWord platform))-	) (\r -> happyReturn (happyIn41 r))--happyReduce_130 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_130 = happySpecReduce_2  37# happyReduction_130-happyReduction_130 happy_x_2-	happy_x_1-	 =  case happyOut57 happy_x_2 of { (HappyWrap57 happy_var_2) -> -	happyIn41-		 (happy_var_2-	)}--happyReduce_131 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_131 = happySpecReduce_0  38# happyReduction_131-happyReduction_131  =  happyIn42-		 ([]-	)--happyReduce_132 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_132 = happySpecReduce_1  38# happyReduction_132-happyReduction_132 happy_x_1-	 =  case happyOut43 happy_x_1 of { (HappyWrap43 happy_var_1) -> -	happyIn42-		 (happy_var_1-	)}--happyReduce_133 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_133 = happySpecReduce_1  39# happyReduction_133-happyReduction_133 happy_x_1-	 =  case happyOut44 happy_x_1 of { (HappyWrap44 happy_var_1) -> -	happyIn43-		 ([happy_var_1]-	)}--happyReduce_134 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_134 = happySpecReduce_3  39# happyReduction_134-happyReduction_134 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut44 happy_x_1 of { (HappyWrap44 happy_var_1) -> -	case happyOut43 happy_x_3 of { (HappyWrap43 happy_var_3) -> -	happyIn43-		 (happy_var_1 : happy_var_3-	)}}--happyReduce_135 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_135 = happySpecReduce_1  40# happyReduction_135-happyReduction_135 happy_x_1-	 =  case happyOut38 happy_x_1 of { (HappyWrap38 happy_var_1) -> -	happyIn44-		 (do e <- happy_var_1;-                                             return (e, inferCmmHint e)-	)}--happyReduce_136 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_136 = happyMonadReduce 2# 40# happyReduction_136-happyReduction_136 (happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest) tk-	 = happyThen ((case happyOut38 happy_x_1 of { (HappyWrap38 happy_var_1) -> -	case happyOutTok happy_x_2 of { (L _ (CmmT_String      happy_var_2)) -> -	( do h <- parseCmmHint happy_var_2;-                                              return $ do-                                                e <- happy_var_1; return (e, h))}})-	) (\r -> happyReturn (happyIn44 r))--happyReduce_137 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_137 = happySpecReduce_0  41# happyReduction_137-happyReduction_137  =  happyIn45-		 ([]-	)--happyReduce_138 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_138 = happySpecReduce_1  41# happyReduction_138-happyReduction_138 happy_x_1-	 =  case happyOut46 happy_x_1 of { (HappyWrap46 happy_var_1) -> -	happyIn45-		 (happy_var_1-	)}--happyReduce_139 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_139 = happySpecReduce_1  42# happyReduction_139-happyReduction_139 happy_x_1-	 =  case happyOut38 happy_x_1 of { (HappyWrap38 happy_var_1) -> -	happyIn46-		 ([ happy_var_1 ]-	)}--happyReduce_140 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_140 = happySpecReduce_3  42# happyReduction_140-happyReduction_140 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut38 happy_x_1 of { (HappyWrap38 happy_var_1) -> -	case happyOut46 happy_x_3 of { (HappyWrap46 happy_var_3) -> -	happyIn46-		 (happy_var_1 : happy_var_3-	)}}--happyReduce_141 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_141 = happySpecReduce_1  43# happyReduction_141-happyReduction_141 happy_x_1-	 =  case happyOutTok happy_x_1 of { (L _ (CmmT_Name        happy_var_1)) -> -	happyIn47-		 (lookupName happy_var_1-	)}--happyReduce_142 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_142 = happySpecReduce_1  43# happyReduction_142-happyReduction_142 happy_x_1-	 =  case happyOutTok happy_x_1 of { (L _ (CmmT_GlobalReg   happy_var_1)) -> -	happyIn47-		 (return (CmmReg (CmmGlobal happy_var_1))-	)}--happyReduce_143 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_143 = happySpecReduce_0  44# happyReduction_143-happyReduction_143  =  happyIn48-		 ([]-	)--happyReduce_144 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_144 = happyReduce 4# 44# happyReduction_144-happyReduction_144 (happy_x_4 `HappyStk`-	happy_x_3 `HappyStk`-	happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest)-	 = case happyOut49 happy_x_2 of { (HappyWrap49 happy_var_2) -> -	happyIn48-		 (happy_var_2-	) `HappyStk` happyRest}--happyReduce_145 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_145 = happySpecReduce_1  45# happyReduction_145-happyReduction_145 happy_x_1-	 =  case happyOut50 happy_x_1 of { (HappyWrap50 happy_var_1) -> -	happyIn49-		 ([happy_var_1]-	)}--happyReduce_146 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_146 = happySpecReduce_2  45# happyReduction_146-happyReduction_146 happy_x_2-	happy_x_1-	 =  case happyOut50 happy_x_1 of { (HappyWrap50 happy_var_1) -> -	happyIn49-		 ([happy_var_1]-	)}--happyReduce_147 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_147 = happySpecReduce_3  45# happyReduction_147-happyReduction_147 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut50 happy_x_1 of { (HappyWrap50 happy_var_1) -> -	case happyOut49 happy_x_3 of { (HappyWrap49 happy_var_3) -> -	happyIn49-		 (happy_var_1 : happy_var_3-	)}}--happyReduce_148 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_148 = happySpecReduce_1  46# happyReduction_148-happyReduction_148 happy_x_1-	 =  case happyOut51 happy_x_1 of { (HappyWrap51 happy_var_1) -> -	happyIn50-		 (do e <- happy_var_1; return (e, inferCmmHint (CmmReg (CmmLocal e)))-	)}--happyReduce_149 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_149 = happyMonadReduce 2# 46# happyReduction_149-happyReduction_149 (happy_x_2 `HappyStk`-	happy_x_1 `HappyStk`-	happyRest) tk-	 = happyThen ((case happyOutTok happy_x_1 of { (L _ (CmmT_String      happy_var_1)) -> -	case happyOut51 happy_x_2 of { (HappyWrap51 happy_var_2) -> -	( do h <- parseCmmHint happy_var_1;-                                      return $ do-                                         e <- happy_var_2; return (e,h))}})-	) (\r -> happyReturn (happyIn50 r))--happyReduce_150 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_150 = happySpecReduce_1  47# happyReduction_150-happyReduction_150 happy_x_1-	 =  case happyOutTok happy_x_1 of { (L _ (CmmT_Name        happy_var_1)) -> -	happyIn51-		 (do e <- lookupName happy_var_1;-                                     return $-                                       case e of-                                        CmmReg (CmmLocal r) -> r-                                        other -> pprPanic "CmmParse:" (ftext happy_var_1 <> text " not a local register")-	)}--happyReduce_151 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_151 = happySpecReduce_1  48# happyReduction_151-happyReduction_151 happy_x_1-	 =  case happyOutTok happy_x_1 of { (L _ (CmmT_Name        happy_var_1)) -> -	happyIn52-		 (do e <- lookupName happy_var_1;-                                     return $-                                       case e of-                                        CmmReg r -> r-                                        other -> pprPanic "CmmParse:" (ftext happy_var_1 <> text " not a register")-	)}--happyReduce_152 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_152 = happySpecReduce_1  48# happyReduction_152-happyReduction_152 happy_x_1-	 =  case happyOutTok happy_x_1 of { (L _ (CmmT_GlobalReg   happy_var_1)) -> -	happyIn52-		 (return (CmmGlobal happy_var_1)-	)}--happyReduce_153 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_153 = happySpecReduce_0  49# happyReduction_153-happyReduction_153  =  happyIn53-		 (Nothing-	)--happyReduce_154 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_154 = happySpecReduce_3  49# happyReduction_154-happyReduction_154 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut54 happy_x_2 of { (HappyWrap54 happy_var_2) -> -	happyIn53-		 (Just happy_var_2-	)}--happyReduce_155 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_155 = happySpecReduce_0  50# happyReduction_155-happyReduction_155  =  happyIn54-		 ([]-	)--happyReduce_156 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_156 = happySpecReduce_1  50# happyReduction_156-happyReduction_156 happy_x_1-	 =  case happyOut55 happy_x_1 of { (HappyWrap55 happy_var_1) -> -	happyIn54-		 (happy_var_1-	)}--happyReduce_157 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_157 = happySpecReduce_2  51# happyReduction_157-happyReduction_157 happy_x_2-	happy_x_1-	 =  case happyOut56 happy_x_1 of { (HappyWrap56 happy_var_1) -> -	happyIn55-		 ([happy_var_1]-	)}--happyReduce_158 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_158 = happySpecReduce_1  51# happyReduction_158-happyReduction_158 happy_x_1-	 =  case happyOut56 happy_x_1 of { (HappyWrap56 happy_var_1) -> -	happyIn55-		 ([happy_var_1]-	)}--happyReduce_159 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_159 = happySpecReduce_3  51# happyReduction_159-happyReduction_159 happy_x_3-	happy_x_2-	happy_x_1-	 =  case happyOut56 happy_x_1 of { (HappyWrap56 happy_var_1) -> -	case happyOut55 happy_x_3 of { (HappyWrap55 happy_var_3) -> -	happyIn55-		 (happy_var_1 : happy_var_3-	)}}--happyReduce_160 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_160 = happySpecReduce_2  52# happyReduction_160-happyReduction_160 happy_x_2-	happy_x_1-	 =  case happyOut57 happy_x_1 of { (HappyWrap57 happy_var_1) -> -	case happyOutTok happy_x_2 of { (L _ (CmmT_Name        happy_var_2)) -> -	happyIn56-		 (newLocal happy_var_1 happy_var_2-	)}}--happyReduce_161 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_161 = happySpecReduce_1  53# happyReduction_161-happyReduction_161 happy_x_1-	 =  happyIn57-		 (b8-	)--happyReduce_162 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_162 = happySpecReduce_1  53# happyReduction_162-happyReduction_162 happy_x_1-	 =  case happyOut58 happy_x_1 of { (HappyWrap58 happy_var_1) -> -	happyIn57-		 (happy_var_1-	)}--happyReduce_163 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_163 = happySpecReduce_1  54# happyReduction_163-happyReduction_163 happy_x_1-	 =  happyIn58-		 (b16-	)--happyReduce_164 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_164 = happySpecReduce_1  54# happyReduction_164-happyReduction_164 happy_x_1-	 =  happyIn58-		 (b32-	)--happyReduce_165 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_165 = happySpecReduce_1  54# happyReduction_165-happyReduction_165 happy_x_1-	 =  happyIn58-		 (b64-	)--happyReduce_166 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_166 = happySpecReduce_1  54# happyReduction_166-happyReduction_166 happy_x_1-	 =  happyIn58-		 (b128-	)--happyReduce_167 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_167 = happySpecReduce_1  54# happyReduction_167-happyReduction_167 happy_x_1-	 =  happyIn58-		 (b256-	)--happyReduce_168 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_168 = happySpecReduce_1  54# happyReduction_168-happyReduction_168 happy_x_1-	 =  happyIn58-		 (b512-	)--happyReduce_169 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_169 = happySpecReduce_1  54# happyReduction_169-happyReduction_169 happy_x_1-	 =  happyIn58-		 (f32-	)--happyReduce_170 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_170 = happySpecReduce_1  54# happyReduction_170-happyReduction_170 happy_x_1-	 =  happyIn58-		 (f64-	)--happyReduce_171 :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )-happyReduce_171 = happyMonadReduce 1# 54# happyReduction_171-happyReduction_171 (happy_x_1 `HappyStk`-	happyRest) tk-	 = happyThen ((( do platform <- PD.getPlatform; return $ gcWord platform))-	) (\r -> happyReturn (happyIn58 r))--happyNewToken action sts stk-	= cmmlex(\tk -> -	let cont i = happyDoAction i tk action sts stk in-	case tk of {-	L _ CmmT_EOF -> happyDoAction 77# tk action sts stk;-	L _ (CmmT_SpecChar ':') -> cont 1#;-	L _ (CmmT_SpecChar ';') -> cont 2#;-	L _ (CmmT_SpecChar '{') -> cont 3#;-	L _ (CmmT_SpecChar '}') -> cont 4#;-	L _ (CmmT_SpecChar '[') -> cont 5#;-	L _ (CmmT_SpecChar ']') -> cont 6#;-	L _ (CmmT_SpecChar '(') -> cont 7#;-	L _ (CmmT_SpecChar ')') -> cont 8#;-	L _ (CmmT_SpecChar '=') -> cont 9#;-	L _ (CmmT_SpecChar '`') -> cont 10#;-	L _ (CmmT_SpecChar '~') -> cont 11#;-	L _ (CmmT_SpecChar '/') -> cont 12#;-	L _ (CmmT_SpecChar '*') -> cont 13#;-	L _ (CmmT_SpecChar '%') -> cont 14#;-	L _ (CmmT_SpecChar '-') -> cont 15#;-	L _ (CmmT_SpecChar '+') -> cont 16#;-	L _ (CmmT_SpecChar '&') -> cont 17#;-	L _ (CmmT_SpecChar '^') -> cont 18#;-	L _ (CmmT_SpecChar '|') -> cont 19#;-	L _ (CmmT_SpecChar '>') -> cont 20#;-	L _ (CmmT_SpecChar '<') -> cont 21#;-	L _ (CmmT_SpecChar ',') -> cont 22#;-	L _ (CmmT_SpecChar '!') -> cont 23#;-	L _ (CmmT_DotDot) -> cont 24#;-	L _ (CmmT_DoubleColon) -> cont 25#;-	L _ (CmmT_Shr) -> cont 26#;-	L _ (CmmT_Shl) -> cont 27#;-	L _ (CmmT_Ge) -> cont 28#;-	L _ (CmmT_Le) -> cont 29#;-	L _ (CmmT_Eq) -> cont 30#;-	L _ (CmmT_Ne) -> cont 31#;-	L _ (CmmT_BoolAnd) -> cont 32#;-	L _ (CmmT_BoolOr) -> cont 33#;-	L _ (CmmT_True ) -> cont 34#;-	L _ (CmmT_False) -> cont 35#;-	L _ (CmmT_likely) -> cont 36#;-	L _ (CmmT_CLOSURE) -> cont 37#;-	L _ (CmmT_INFO_TABLE) -> cont 38#;-	L _ (CmmT_INFO_TABLE_RET) -> cont 39#;-	L _ (CmmT_INFO_TABLE_FUN) -> cont 40#;-	L _ (CmmT_INFO_TABLE_CONSTR) -> cont 41#;-	L _ (CmmT_INFO_TABLE_SELECTOR) -> cont 42#;-	L _ (CmmT_else) -> cont 43#;-	L _ (CmmT_export) -> cont 44#;-	L _ (CmmT_section) -> cont 45#;-	L _ (CmmT_goto) -> cont 46#;-	L _ (CmmT_if) -> cont 47#;-	L _ (CmmT_call) -> cont 48#;-	L _ (CmmT_jump) -> cont 49#;-	L _ (CmmT_foreign) -> cont 50#;-	L _ (CmmT_never) -> cont 51#;-	L _ (CmmT_prim) -> cont 52#;-	L _ (CmmT_reserve) -> cont 53#;-	L _ (CmmT_return) -> cont 54#;-	L _ (CmmT_returns) -> cont 55#;-	L _ (CmmT_import) -> cont 56#;-	L _ (CmmT_switch) -> cont 57#;-	L _ (CmmT_case) -> cont 58#;-	L _ (CmmT_default) -> cont 59#;-	L _ (CmmT_push) -> cont 60#;-	L _ (CmmT_unwind) -> cont 61#;-	L _ (CmmT_bits8) -> cont 62#;-	L _ (CmmT_bits16) -> cont 63#;-	L _ (CmmT_bits32) -> cont 64#;-	L _ (CmmT_bits64) -> cont 65#;-	L _ (CmmT_bits128) -> cont 66#;-	L _ (CmmT_bits256) -> cont 67#;-	L _ (CmmT_bits512) -> cont 68#;-	L _ (CmmT_float32) -> cont 69#;-	L _ (CmmT_float64) -> cont 70#;-	L _ (CmmT_gcptr) -> cont 71#;-	L _ (CmmT_GlobalReg   happy_dollar_dollar) -> cont 72#;-	L _ (CmmT_Name        happy_dollar_dollar) -> cont 73#;-	L _ (CmmT_String      happy_dollar_dollar) -> cont 74#;-	L _ (CmmT_Int         happy_dollar_dollar) -> cont 75#;-	L _ (CmmT_Float       happy_dollar_dollar) -> cont 76#;-	_ -> happyError' (tk, [])-	})--happyError_ explist 77# tk = happyError' (tk, explist)-happyError_ explist _ tk = happyError' (tk, explist)--happyThen :: () => PD a -> (a -> PD b) -> PD b-happyThen = (>>=)-happyReturn :: () => a -> PD a-happyReturn = (return)-happyParse :: () => Happy_GHC_Exts.Int# -> PD (HappyAbsSyn )--happyNewToken :: () => Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )--happyDoAction :: () => Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn )--happyReduceArr :: () => Happy_Data_Array.Array Prelude.Int (Happy_GHC_Exts.Int# -> Located CmmToken -> Happy_GHC_Exts.Int# -> Happy_IntList -> HappyStk (HappyAbsSyn ) -> PD (HappyAbsSyn ))--happyThen1 :: () => PD a -> (a -> PD b) -> PD b-happyThen1 = happyThen-happyReturn1 :: () => a -> PD a-happyReturn1 = happyReturn-happyError' :: () => ((Located CmmToken), [Prelude.String]) -> PD a-happyError' tk = (\(tokens, explist) -> happyError) tk-cmmParse = happySomeParser where- happySomeParser = happyThen (happyParse 0#) (\x -> happyReturn (let {(HappyWrap4 x') = happyOut4 x} in x'))--happySeq = happyDoSeq---section :: String -> SectionType-section "text"      = Text-section "data"      = Data-section "rodata"    = ReadOnlyData-section "relrodata" = RelocatableReadOnlyData-section "bss"       = UninitialisedData-section s           = OtherSection s--mkString :: String -> CmmStatic-mkString s = CmmString (BS8.pack s)---- mkMachOp infers the type of the MachOp from the type of its first--- argument.  We assume that this is correct: for MachOps that don't have--- symmetrical args (e.g. shift ops), the first arg determines the type of--- the op.-mkMachOp :: (Width -> MachOp) -> [CmmParse CmmExpr] -> CmmParse CmmExpr-mkMachOp fn args = do-  platform <- getPlatform-  arg_exprs <- sequence args-  return (CmmMachOp (fn (typeWidth (cmmExprType platform (head arg_exprs)))) arg_exprs)--getLit :: CmmExpr -> CmmLit-getLit (CmmLit l) = l-getLit (CmmMachOp (MO_S_Neg _) [CmmLit (CmmInt i r)])  = CmmInt (negate i) r-getLit _ = panic "invalid literal" -- TODO messy failure--nameToMachOp :: FastString -> PD (Width -> MachOp)-nameToMachOp name =-  case lookupUFM machOps name of-        Nothing -> failMsgPD $ \span -> mkPlainErrorMsgEnvelope span $ PsErrCmmParser (CmmUnknownPrimitive name)-        Just m  -> return m--exprOp :: FastString -> [CmmParse CmmExpr] -> PD (CmmParse CmmExpr)-exprOp name args_code = do-  profile     <- PD.getProfile-  align_check <- gopt Opt_AlignmentSanitisation <$> getDynFlags-  case lookupUFM (exprMacros profile align_check) name of-     Just f  -> return $ do-        args <- sequence args_code-        return (f args)-     Nothing -> do-        mo <- nameToMachOp name-        return $ mkMachOp mo args_code--exprMacros :: Profile -> DoAlignSanitisation -> UniqFM FastString ([CmmExpr] -> CmmExpr)-exprMacros profile align_check = listToUFM [-  ( fsLit "ENTRY_CODE",   \ [x] -> entryCode platform x ),-  ( fsLit "INFO_PTR",     \ [x] -> closureInfoPtr platform align_check x ),-  ( fsLit "STD_INFO",     \ [x] -> infoTable    profile x ),-  ( fsLit "FUN_INFO",     \ [x] -> funInfoTable profile x ),-  ( fsLit "GET_ENTRY",    \ [x] -> entryCode platform   (closureInfoPtr platform align_check x) ),-  ( fsLit "GET_STD_INFO", \ [x] -> infoTable profile    (closureInfoPtr platform align_check x) ),-  ( fsLit "GET_FUN_INFO", \ [x] -> funInfoTable profile (closureInfoPtr platform align_check x) ),-  ( fsLit "INFO_TYPE",    \ [x] -> infoTableClosureType profile x ),-  ( fsLit "INFO_PTRS",    \ [x] -> infoTablePtrs profile x ),-  ( fsLit "INFO_NPTRS",   \ [x] -> infoTableNonPtrs profile x )-  ]-  where-    platform = profilePlatform profile---- we understand a subset of C-- primitives:-machOps = listToUFM $-        map (\(x, y) -> (mkFastString x, y)) [-        ( "add",        MO_Add ),-        ( "sub",        MO_Sub ),-        ( "eq",         MO_Eq ),-        ( "ne",         MO_Ne ),-        ( "mul",        MO_Mul ),-        ( "mulmayoflo",  MO_S_MulMayOflo ),-        ( "mulmayoflou", MO_U_MulMayOflo ),-        ( "neg",        MO_S_Neg ),-        ( "quot",       MO_S_Quot ),-        ( "rem",        MO_S_Rem ),-        ( "divu",       MO_U_Quot ),-        ( "modu",       MO_U_Rem ),--        ( "ge",         MO_S_Ge ),-        ( "le",         MO_S_Le ),-        ( "gt",         MO_S_Gt ),-        ( "lt",         MO_S_Lt ),--        ( "geu",        MO_U_Ge ),-        ( "leu",        MO_U_Le ),-        ( "gtu",        MO_U_Gt ),-        ( "ltu",        MO_U_Lt ),--        ( "and",        MO_And ),-        ( "or",         MO_Or ),-        ( "xor",        MO_Xor ),-        ( "com",        MO_Not ),-        ( "shl",        MO_Shl ),-        ( "shrl",       MO_U_Shr ),-        ( "shra",       MO_S_Shr ),--        ( "fadd",       MO_F_Add ),-        ( "fsub",       MO_F_Sub ),-        ( "fneg",       MO_F_Neg ),-        ( "fmul",       MO_F_Mul ),-        ( "fquot",      MO_F_Quot ),--        ( "feq",        MO_F_Eq ),-        ( "fne",        MO_F_Ne ),-        ( "fge",        MO_F_Ge ),-        ( "fle",        MO_F_Le ),-        ( "fgt",        MO_F_Gt ),-        ( "flt",        MO_F_Lt ),--        ( "lobits8",  flip MO_UU_Conv W8  ),-        ( "lobits16", flip MO_UU_Conv W16 ),-        ( "lobits32", flip MO_UU_Conv W32 ),-        ( "lobits64", flip MO_UU_Conv W64 ),--        ( "zx16",     flip MO_UU_Conv W16 ),-        ( "zx32",     flip MO_UU_Conv W32 ),-        ( "zx64",     flip MO_UU_Conv W64 ),--        ( "sx16",     flip MO_SS_Conv W16 ),-        ( "sx32",     flip MO_SS_Conv W32 ),-        ( "sx64",     flip MO_SS_Conv W64 ),--        ( "f2f32",    flip MO_FF_Conv W32 ),  -- TODO; rounding mode-        ( "f2f64",    flip MO_FF_Conv W64 ),  -- TODO; rounding mode-        ( "f2i8",     flip MO_FS_Conv W8 ),-        ( "f2i16",    flip MO_FS_Conv W16 ),-        ( "f2i32",    flip MO_FS_Conv W32 ),-        ( "f2i64",    flip MO_FS_Conv W64 ),-        ( "i2f32",    flip MO_SF_Conv W32 ),-        ( "i2f64",    flip MO_SF_Conv W64 )-        ]--callishMachOps :: Platform -> UniqFM FastString ([CmmExpr] -> (CallishMachOp, [CmmExpr]))-callishMachOps platform = listToUFM $-        map (\(x, y) -> (mkFastString x, y)) [--        ( "pow64f", (MO_F64_Pwr,) ),-        ( "sin64f", (MO_F64_Sin,) ),-        ( "cos64f", (MO_F64_Cos,) ),-        ( "tan64f", (MO_F64_Tan,) ),-        ( "sinh64f", (MO_F64_Sinh,) ),-        ( "cosh64f", (MO_F64_Cosh,) ),-        ( "tanh64f", (MO_F64_Tanh,) ),-        ( "asin64f", (MO_F64_Asin,) ),-        ( "acos64f", (MO_F64_Acos,) ),-        ( "atan64f", (MO_F64_Atan,) ),-        ( "asinh64f", (MO_F64_Asinh,) ),-        ( "acosh64f", (MO_F64_Acosh,) ),-        ( "log64f", (MO_F64_Log,) ),-        ( "log1p64f", (MO_F64_Log1P,) ),-        ( "exp64f", (MO_F64_Exp,) ),-        ( "expM164f", (MO_F64_ExpM1,) ),-        ( "fabs64f", (MO_F64_Fabs,) ),-        ( "sqrt64f", (MO_F64_Sqrt,) ),--        ( "pow32f", (MO_F32_Pwr,) ),-        ( "sin32f", (MO_F32_Sin,) ),-        ( "cos32f", (MO_F32_Cos,) ),-        ( "tan32f", (MO_F32_Tan,) ),-        ( "sinh32f", (MO_F32_Sinh,) ),-        ( "cosh32f", (MO_F32_Cosh,) ),-        ( "tanh32f", (MO_F32_Tanh,) ),-        ( "asin32f", (MO_F32_Asin,) ),-        ( "acos32f", (MO_F32_Acos,) ),-        ( "atan32f", (MO_F32_Atan,) ),-        ( "asinh32f", (MO_F32_Asinh,) ),-        ( "acosh32f", (MO_F32_Acosh,) ),-        ( "log32f", (MO_F32_Log,) ),-        ( "log1p32f", (MO_F32_Log1P,) ),-        ( "exp32f", (MO_F32_Exp,) ),-        ( "expM132f", (MO_F32_ExpM1,) ),-        ( "fabs32f", (MO_F32_Fabs,) ),-        ( "sqrt32f", (MO_F32_Sqrt,) ),--        ( "read_barrier", (MO_ReadBarrier,)),-        ( "write_barrier", (MO_WriteBarrier,)),-        ( "memcpy", memcpyLikeTweakArgs MO_Memcpy ),-        ( "memset", memcpyLikeTweakArgs MO_Memset ),-        ( "memmove", memcpyLikeTweakArgs MO_Memmove ),-        ( "memcmp", memcpyLikeTweakArgs MO_Memcmp ),--        ( "suspendThread", (MO_SuspendThread,) ),-        ( "resumeThread",  (MO_ResumeThread,) ),--        ("prefetch0", (MO_Prefetch_Data 0,)),-        ("prefetch1", (MO_Prefetch_Data 1,)),-        ("prefetch2", (MO_Prefetch_Data 2,)),-        ("prefetch3", (MO_Prefetch_Data 3,)),--        ( "popcnt8",  (MO_PopCnt W8,)),-        ( "popcnt16", (MO_PopCnt W16,)),-        ( "popcnt32", (MO_PopCnt W32,)),-        ( "popcnt64", (MO_PopCnt W64,)),--        ( "pdep8",  (MO_Pdep W8,)),-        ( "pdep16", (MO_Pdep W16,)),-        ( "pdep32", (MO_Pdep W32,)),-        ( "pdep64", (MO_Pdep W64,)),--        ( "pext8",  (MO_Pext W8,)),-        ( "pext16", (MO_Pext W16,)),-        ( "pext32", (MO_Pext W32,)),-        ( "pext64", (MO_Pext W64,)),--        ( "cmpxchg8",  (MO_Cmpxchg W8,)),-        ( "cmpxchg16", (MO_Cmpxchg W16,)),-        ( "cmpxchg32", (MO_Cmpxchg W32,)),-        ( "cmpxchg64", (MO_Cmpxchg W64,)),--        ( "xchg8",  (MO_Xchg W8,)),-        ( "xchg16", (MO_Xchg W16,)),-        ( "xchg32", (MO_Xchg W32,)),-        ( "xchg64", (MO_Xchg W64,))-    ]-  where-    memcpyLikeTweakArgs :: (Int -> CallishMachOp) -> [CmmExpr] -> (CallishMachOp, [CmmExpr])-    memcpyLikeTweakArgs op [] = pgmError "memcpy-like function requires at least one argument"-    memcpyLikeTweakArgs op args@(_:_) =-        (op align, args')-      where-        args' = init args-        align = case last args of-          CmmLit (CmmInt alignInteger _) -> fromInteger alignInteger-          e -> pgmErrorDoc "Non-constant alignment in memcpy-like function:" (pdoc platform e)-        -- The alignment of memcpy-ish operations must be a-        -- compile-time constant. We verify this here, passing it around-        -- in the MO_* constructor. In order to do this, however, we-        -- must intercept the arguments in primCall.--parseSafety :: String -> PD Safety-parseSafety "safe"   = return PlaySafe-parseSafety "unsafe" = return PlayRisky-parseSafety "interruptible" = return PlayInterruptible-parseSafety str      = failMsgPD $ \span -> mkPlainErrorMsgEnvelope span $-                                              PsErrCmmParser (CmmUnrecognisedSafety str)--parseCmmHint :: String -> PD ForeignHint-parseCmmHint "ptr"    = return AddrHint-parseCmmHint "signed" = return SignedHint-parseCmmHint str      = failMsgPD $ \span -> mkPlainErrorMsgEnvelope span $-                                               PsErrCmmParser (CmmUnrecognisedHint str)---- labels are always pointers, so we might as well infer the hint-inferCmmHint :: CmmExpr -> ForeignHint-inferCmmHint (CmmLit (CmmLabel _)) = AddrHint-inferCmmHint (CmmReg (CmmGlobal g)) | isPtrGlobalReg g = AddrHint-inferCmmHint _ = NoHint--isPtrGlobalReg Sp                    = True-isPtrGlobalReg SpLim                 = True-isPtrGlobalReg Hp                    = True-isPtrGlobalReg HpLim                 = True-isPtrGlobalReg CCCS                  = True-isPtrGlobalReg CurrentTSO            = True-isPtrGlobalReg CurrentNursery        = True-isPtrGlobalReg (VanillaReg _ VGcPtr) = True-isPtrGlobalReg _                     = False--happyError :: PD a-happyError = PD $ \_ _ s -> unP srcParseFail s---- -------------------------------------------------------------------------------- Statement-level macros--stmtMacro :: FastString -> [CmmParse CmmExpr] -> PD (CmmParse ())-stmtMacro fun args_code = do-  case lookupUFM stmtMacros fun of-    Nothing -> failMsgPD $ \span -> mkPlainErrorMsgEnvelope span $ PsErrCmmParser (CmmUnknownMacro fun)-    Just fcode -> return $ do-        args <- sequence args_code-        code (fcode args)--stmtMacros :: UniqFM FastString ([CmmExpr] -> FCode ())-stmtMacros = listToUFM [-  ( fsLit "CCS_ALLOC",             \[words,ccs]  -> profAlloc words ccs ),-  ( fsLit "ENTER_CCS_THUNK",       \[e] -> enterCostCentreThunk e ),--  ( fsLit "CLOSE_NURSERY",         \[]  -> emitCloseNursery ),-  ( fsLit "OPEN_NURSERY",          \[]  -> emitOpenNursery ),--  -- completely generic heap and stack checks, for use in high-level cmm.-  ( fsLit "HP_CHK_GEN",            \[bytes] ->-                                      heapStackCheckGen Nothing (Just bytes) ),-  ( fsLit "STK_CHK_GEN",           \[] ->-                                      heapStackCheckGen (Just (CmmLit CmmHighStackMark)) Nothing ),--  -- A stack check for a fixed amount of stack.  Sounds a bit strange, but-  -- we use the stack for a bit of temporary storage in a couple of primops-  ( fsLit "STK_CHK_GEN_N",         \[bytes] ->-                                      heapStackCheckGen (Just bytes) Nothing ),--  -- A stack check on entry to a thunk, where the argument is the thunk pointer.-  ( fsLit "STK_CHK_NP"   ,         \[node] -> entryHeapCheck' False node 0 [] (return ())),--  ( fsLit "LOAD_THREAD_STATE",     \[] -> emitLoadThreadState ),-  ( fsLit "SAVE_THREAD_STATE",     \[] -> emitSaveThreadState ),--  ( fsLit "SAVE_REGS",             \[] -> emitSaveRegs ),-  ( fsLit "RESTORE_REGS",          \[] -> emitRestoreRegs ),--  ( fsLit "PUSH_TUPLE_REGS",      \[live_regs] -> emitPushTupleRegs live_regs ),-  ( fsLit "POP_TUPLE_REGS",       \[live_regs] -> emitPopTupleRegs live_regs ),--  ( fsLit "LDV_ENTER",             \[e] -> ldvEnter e ),-  ( fsLit "LDV_RECORD_CREATE",     \[e] -> ldvRecordCreate e ),--  ( fsLit "PUSH_UPD_FRAME",        \[sp,e] -> emitPushUpdateFrame sp e ),-  ( fsLit "SET_HDR",               \[ptr,info,ccs] ->-                                        emitSetDynHdr ptr info ccs ),-  ( fsLit "TICK_ALLOC_PRIM",       \[hdr,goods,slop] ->-                                        tickyAllocPrim hdr goods slop ),-  ( fsLit "TICK_ALLOC_PAP",        \[goods,slop] ->-                                        tickyAllocPAP goods slop ),-  ( fsLit "TICK_ALLOC_UP_THK",     \[goods,slop] ->-                                        tickyAllocThunk goods slop ),-  ( fsLit "UPD_BH_UPDATABLE",      \[reg] -> emitBlackHoleCode reg )- ]--emitPushUpdateFrame :: CmmExpr -> CmmExpr -> FCode ()-emitPushUpdateFrame sp e = do-  emitUpdateFrame sp mkUpdInfoLabel e--pushStackFrame :: [CmmParse CmmExpr] -> CmmParse () -> CmmParse ()-pushStackFrame fields body = do-  profile <- getProfile-  exprs <- sequence fields-  updfr_off <- getUpdFrameOff-  let (new_updfr_off, _, g) = copyOutOflow profile NativeReturn Ret Old-                                           [] updfr_off exprs-  emit g-  withUpdFrameOff new_updfr_off body--reserveStackFrame-  :: CmmParse CmmExpr-  -> CmmParse CmmReg-  -> CmmParse ()-  -> CmmParse ()-reserveStackFrame psize preg body = do-  platform <- getPlatform-  old_updfr_off <- getUpdFrameOff-  reg <- preg-  esize <- psize-  let size = case constantFoldExpr platform esize of-               CmmLit (CmmInt n _) -> n-               _other -> pprPanic "CmmParse: not a compile-time integer: "-                            (pdoc platform esize)-  let frame = old_updfr_off + platformWordSizeInBytes platform * fromIntegral size-  emitAssign reg (CmmStackSlot Old frame)-  withUpdFrameOff frame body--profilingInfo profile desc_str ty_str-  = if not (profileIsProfiling profile)-    then NoProfilingInfo-    else ProfilingInfo (BS8.pack desc_str) (BS8.pack ty_str)--staticClosure :: UnitId -> FastString -> FastString -> [CmmLit] -> CmmParse ()-staticClosure pkg cl_label info payload-  = do profile <- getProfile-       let lits = mkStaticClosure profile (mkCmmInfoLabel pkg info) dontCareCCS payload [] [] []-       code $ emitDataLits (mkCmmDataLabel pkg (NeedExternDecl True) cl_label) lits--foreignCall-        :: String-        -> [CmmParse (LocalReg, ForeignHint)]-        -> CmmParse CmmExpr-        -> [CmmParse (CmmExpr, ForeignHint)]-        -> Safety-        -> CmmReturnInfo-        -> PD (CmmParse ())-foreignCall conv_string results_code expr_code args_code safety ret-  = do  conv <- case conv_string of-          "C"       -> return CCallConv-          "stdcall" -> return StdCallConv-          _         -> failMsgPD $ \span -> mkPlainErrorMsgEnvelope span $-                                              PsErrCmmParser (CmmUnknownCConv conv_string)-        return $ do-          platform <- getPlatform-          results <- sequence results_code-          expr <- expr_code-          args <- sequence args_code-          let-                  expr' = adjCallTarget platform conv expr args-                  (arg_exprs, arg_hints) = unzip args-                  (res_regs,  res_hints) = unzip results-                  fc = ForeignConvention conv arg_hints res_hints ret-                  target = ForeignTarget expr' fc-          _ <- code $ emitForeignCall safety res_regs target arg_exprs-          return ()---doReturn :: [CmmParse CmmExpr] -> CmmParse ()-doReturn exprs_code = do-  profile <- getProfile-  exprs <- sequence exprs_code-  updfr_off <- getUpdFrameOff-  emit (mkReturnSimple profile exprs updfr_off)--mkReturnSimple  :: Profile -> [CmmActual] -> UpdFrameOffset -> CmmAGraph-mkReturnSimple profile actuals updfr_off =-  mkReturn profile e actuals updfr_off-  where e = entryCode platform (cmmLoadGCWord platform (CmmStackSlot Old updfr_off))-        platform = profilePlatform profile--doRawJump :: CmmParse CmmExpr -> [GlobalReg] -> CmmParse ()-doRawJump expr_code vols = do-  profile <- getProfile-  expr <- expr_code-  updfr_off <- getUpdFrameOff-  emit (mkRawJump profile expr updfr_off vols)--doJumpWithStack :: CmmParse CmmExpr -> [CmmParse CmmExpr]-                -> [CmmParse CmmExpr] -> CmmParse ()-doJumpWithStack expr_code stk_code args_code = do-  profile <- getProfile-  expr <- expr_code-  stk_args <- sequence stk_code-  args <- sequence args_code-  updfr_off <- getUpdFrameOff-  emit (mkJumpExtra profile NativeNodeCall expr args updfr_off stk_args)--doCall :: CmmParse CmmExpr -> [CmmParse LocalReg] -> [CmmParse CmmExpr]-       -> CmmParse ()-doCall expr_code res_code args_code = do-  expr <- expr_code-  args <- sequence args_code-  ress <- sequence res_code-  updfr_off <- getUpdFrameOff-  c <- code $ mkCall expr (NativeNodeCall,NativeReturn) ress args updfr_off []-  emit c--adjCallTarget :: Platform -> CCallConv -> CmmExpr -> [(CmmExpr, ForeignHint) ]-              -> CmmExpr--- On Windows, we have to add the '@N' suffix to the label when making--- a call with the stdcall calling convention.-adjCallTarget platform StdCallConv (CmmLit (CmmLabel lbl)) args- | platformOS platform == OSMinGW32-  = CmmLit (CmmLabel (addLabelSize lbl (sum (map size args))))-  where size (e, _) = max (platformWordSizeInBytes platform) (widthInBytes (typeWidth (cmmExprType platform e)))-                 -- c.f. CgForeignCall.emitForeignCall-adjCallTarget _ _ expr _-  = expr--primCall-        :: [CmmParse (CmmFormal, ForeignHint)]-        -> FastString-        -> [CmmParse CmmExpr]-        -> PD (CmmParse ())-primCall results_code name args_code-  = do-    platform <- PD.getPlatform-    case lookupUFM (callishMachOps platform) name of-        Nothing -> failMsgPD $ \span -> mkPlainErrorMsgEnvelope span $ PsErrCmmParser (CmmUnknownPrimitive name)-        Just f  -> return $ do-                results <- sequence results_code-                args <- sequence args_code-                let (p, args') = f args-                code (emitPrimCall (map fst results) p args')--doStore :: CmmType -> CmmParse CmmExpr  -> CmmParse CmmExpr -> CmmParse ()-doStore rep addr_code val_code-  = do platform <- getPlatform-       addr <- addr_code-       val <- val_code-        -- if the specified store type does not match the type of the expr-        -- on the rhs, then we insert a coercion that will cause the type-        -- mismatch to be flagged by cmm-lint.  If we don't do this, then-        -- the store will happen at the wrong type, and the error will not-        -- be noticed.-       let val_width = typeWidth (cmmExprType platform val)-           rep_width = typeWidth rep-       let coerce_val-                | val_width /= rep_width = CmmMachOp (MO_UU_Conv val_width rep_width) [val]-                | otherwise              = val-       emitStore addr coerce_val---- -------------------------------------------------------------------------------- If-then-else and boolean expressions--data BoolExpr-  = BoolExpr `BoolAnd` BoolExpr-  | BoolExpr `BoolOr`  BoolExpr-  | BoolNot BoolExpr-  | BoolTest CmmExpr---- ToDo: smart constructors which simplify the boolean expression.--cmmIfThenElse cond then_part else_part likely = do-     then_id <- newBlockId-     join_id <- newBlockId-     c <- cond-     emitCond c then_id likely-     else_part-     emit (mkBranch join_id)-     emitLabel then_id-     then_part-     -- fall through to join-     emitLabel join_id--cmmRawIf cond then_id likely = do-    c <- cond-    emitCond c then_id likely---- 'emitCond cond true_id'  emits code to test whether the cond is true,--- branching to true_id if so, and falling through otherwise.-emitCond (BoolTest e) then_id likely = do-  else_id <- newBlockId-  emit (mkCbranch e then_id else_id likely)-  emitLabel else_id-emitCond (BoolNot (BoolTest (CmmMachOp op args))) then_id likely-  | Just op' <- maybeInvertComparison op-  = emitCond (BoolTest (CmmMachOp op' args)) then_id (not <$> likely)-emitCond (BoolNot e) then_id likely = do-  else_id <- newBlockId-  emitCond e else_id likely-  emit (mkBranch then_id)-  emitLabel else_id-emitCond (e1 `BoolOr` e2) then_id likely = do-  emitCond e1 then_id likely-  emitCond e2 then_id likely-emitCond (e1 `BoolAnd` e2) then_id likely = do-        -- we'd like to invert one of the conditionals here to avoid an-        -- extra branch instruction, but we can't use maybeInvertComparison-        -- here because we can't look too closely at the expression since-        -- we're in a loop.-  and_id <- newBlockId-  else_id <- newBlockId-  emitCond e1 and_id likely-  emit (mkBranch else_id)-  emitLabel and_id-  emitCond e2 then_id likely-  emitLabel else_id---- -------------------------------------------------------------------------------- Source code notes---- | Generate a source note spanning from "a" to "b" (inclusive), then--- proceed with parsing. This allows debugging tools to reason about--- locations in Cmm code.-withSourceNote :: Located a -> Located b -> CmmParse c -> CmmParse c-withSourceNote a b parse = do-  name <- getName-  case combineSrcSpans (getLoc a) (getLoc b) of-    RealSrcSpan span _ -> code (emitTick (SourceNote span name)) >> parse-    _other           -> parse---- -------------------------------------------------------------------------------- Table jumps---- We use a simplified form of C-- switch statements for now.  A--- switch statement always compiles to a table jump.  Each arm can--- specify a list of values (not ranges), and there can be a single--- default branch.  The range of the table is given either by the--- optional range on the switch (eg. switch [0..7] {...}), or by--- the minimum/maximum values from the branches.--doSwitch :: Maybe (Integer,Integer)-         -> CmmParse CmmExpr-         -> [([Integer],Either BlockId (CmmParse ()))]-         -> Maybe (CmmParse ()) -> CmmParse ()-doSwitch mb_range scrut arms deflt-   = do-        -- Compile code for the default branch-        dflt_entry <--                case deflt of-                  Nothing -> return Nothing-                  Just e  -> do b <- forkLabelledCode e; return (Just b)--        -- Compile each case branch-        table_entries <- mapM emitArm arms-        let table = M.fromList (concat table_entries)--        platform <- getPlatform-        let range = fromMaybe (0, platformMaxWord platform) mb_range--        expr <- scrut-        -- ToDo: check for out of range and jump to default if necessary-        emit $ mkSwitch expr (mkSwitchTargets False range dflt_entry table)-   where-        emitArm :: ([Integer],Either BlockId (CmmParse ())) -> CmmParse [(Integer,BlockId)]-        emitArm (ints,Left blockid) = return [ (i,blockid) | i <- ints ]-        emitArm (ints,Right code) = do-           blockid <- forkLabelledCode code-           return [ (i,blockid) | i <- ints ]--forkLabelledCode :: CmmParse () -> CmmParse BlockId-forkLabelledCode p = do-  (_,ag) <- getCodeScoped p-  l <- newBlockId-  emitOutOfLine l ag-  return l---- -------------------------------------------------------------------------------- Putting it all together---- The initial environment: we define some constants that the compiler--- knows about here.-initEnv :: Profile -> Env-initEnv profile = listToUFM [-  ( fsLit "SIZEOF_StgHeader",-    VarN (CmmLit (CmmInt (fromIntegral (fixedHdrSize profile)) (wordWidth platform)) )),-  ( fsLit "SIZEOF_StgInfoTable",-    VarN (CmmLit (CmmInt (fromIntegral (stdInfoTableSizeB profile)) (wordWidth platform)) ))-  ]-  where platform = profilePlatform profile---parseCmmFile :: DynFlags-             -> Module-             -> HomeUnit-             -> FilePath-             -> IO (Messages PsMessage, Messages PsMessage, Maybe (CmmGroup, [InfoProvEnt]))-parseCmmFile dflags this_mod home_unit filename = do-  buf <- hGetStringBuffer filename-  let-        init_loc = mkRealSrcLoc (mkFastString filename) 1 1-        opts       = initParserOpts dflags-        init_state = (initParserState opts buf init_loc) { lex_state = [0] }-                -- reset the lex_state: the Lexer monad leaves some stuff-                -- in there we don't want.-  case unPD cmmParse dflags home_unit init_state of-    PFailed pst -> do-        let (warnings,errors) = getPsMessages pst-        return (warnings, errors, Nothing)-    POk pst code -> do-        st <- initC-        let fstate = F.initFCodeState (profilePlatform $ targetProfile dflags)-        let fcode = do-              ((), cmm) <- getCmm $ unEC code "global" (initEnv (targetProfile dflags)) [] >> return ()-              -- See Note [Mapping Info Tables to Source Positions] (IPE Maps)-              let used_info = map (cmmInfoTableToInfoProvEnt this_mod)-                                              (mapMaybe topInfoTable cmm)-              ((), cmm2) <- getCmm $ mapM_ emitInfoTableProv used_info-              return (cmm ++ cmm2, used_info)-            (cmm, _) = runC (initStgToCmmConfig dflags no_module) fstate st fcode-            (warnings,errors) = getPsMessages pst-        if not (isEmptyMessages errors)-         then return (warnings, errors, Nothing)-         else return (warnings, errors, Just cmm)-  where-        no_module = panic "parseCmmFile: no module"+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 $
+ GHC/Cmm/Parser/Config.hs view
@@ -0,0 +1,24 @@+module GHC.Cmm.Parser.Config (+    PDConfig(..)+  , CmmParserConfig(..)+) where++import GHC.Prelude++import GHC.Platform.Profile++import GHC.StgToCmm.Config++import GHC.Parser.Lexer+++data PDConfig = PDConfig+  { pdProfile :: !Profile+  , pdSanitizeAlignment :: !Bool -- ^ Insert alignment checks (cf @-falignment-sanitisation@)+  }++data CmmParserConfig = CmmParserConfig+  { cmmpParserOpts :: !ParserOpts+  , cmmpPDConfig :: !PDConfig+  , cmmpStgToCmmConfig :: !StgToCmmConfig+  }
GHC/Cmm/Parser/Monad.hs view
@@ -11,19 +11,22 @@     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.Driver.Session import GHC.Parser.Lexer import GHC.Parser.Errors.Types import GHC.Types.Error ( MsgEnvelope )@@ -31,7 +34,7 @@ import GHC.Unit.Types import GHC.Unit.Home -newtype PD a = PD { unPD :: DynFlags -> HomeUnit -> PState -> ParseResult a }+newtype PD a = PD { unPD :: PDConfig -> HomeUnit -> PState -> ParseResult a }  instance Functor PD where   fmap = liftM@@ -58,11 +61,11 @@                 POk s1 a   -> unPD (k a) d hu s1                 PFailed s1 -> PFailed s1 -instance HasDynFlags PD where-   getDynFlags = PD $ \d _ s -> POk s d+getPDConfig :: PD PDConfig+getPDConfig = PD $ \pdc _ s -> POk s pdc  getProfile :: PD Profile-getProfile = targetProfile <$> getDynFlags+getProfile = PD $ \pdc _ s -> POk s (pdProfile pdc)  getPlatform :: PD Platform getPlatform = profilePlatform <$> getProfile
GHC/Cmm/Pipeline.hs view
@@ -1,62 +1,63 @@-{-# LANGUAGE BangPatterns #-}  module GHC.Cmm.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 ) 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.Collections+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.Driver.Session-import GHC.Driver.Config.Cmm+import GHC.Types.Unique.DSM+ import GHC.Utils.Error import GHC.Utils.Logger-import GHC.Driver.Env-import Control.Monad import GHC.Utils.Outputable+import GHC.Utils.Misc ( partitionWith )+ import GHC.Platform-import Data.Either (partitionEithers) +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- :: HscEnv -- Compilation env including-           -- dynamic flags: -dcmm-lint -ddump-cmm-cps+ :: Logger+ -> CmmConfig  -> ModuleSRTInfo        -- Info about SRTs generated so far  -> CmmGroup             -- Input C-- with Procedures- -> IO (ModuleSRTInfo, CmmGroupSRTs) -- Output CPS transformed C--+ -> DUniqSupply+ -> IO ((ModuleSRTInfo, CmmGroupSRTs), DUniqSupply) -- Output CPS transformed C-- -cmmPipeline hsc_env srtInfo prog = do-  let logger    = hsc_logger hsc_env-  let cmmConfig = initCmmConfig (hsc_dflags hsc_env)-  let forceRes (info, group) = info `seq` foldr seq () group-  let platform = cmmPlatform cmmConfig+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-     tops <- {-# SCC "tops" #-} mapM (cpsTop logger platform cmmConfig) prog--     let (procs, data_) = partitionEithers tops-     (srtInfo, cmms) <- {-# SCC "doSRTs" #-} doSRTs cmmConfig srtInfo procs data_+     (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)-+     return ((srtInfo, cmms), dus)  -- | The Cmm pipeline for a single 'CmmDecl'. Returns: --@@ -66,9 +67,10 @@ --     [SRTs]. -- --   - in the case of a `CmmData`, the unmodified 'CmmDecl' and a 'CAFSet' containing-cpsTop :: Logger -> Platform -> CmmConfig -> CmmDecl -> IO (Either (CAFEnv, [CmmDecl]) (CAFSet, CmmDecl))-cpsTop _logger platform _ p@(CmmData _ statics) = return (Right (cafAnalData platform statics, p))-cpsTop logger platform cfg proc =+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 ---------------------------------- @@ -78,7 +80,7 @@       --       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+      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@@ -92,33 +94,46 @@       -- elimCommonBlocks        ----------- Implement switches -------------------------------------------      g <- if cmmDoCmmSwitchPlans cfg+      (g, dus) <- if cmmDoCmmSwitchPlans cfg              then {-# SCC "createSwitchPlans" #-}-                  runUniqSM $ cmmImplementSwitchPlans platform g-             else pure g+                  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 <-+      (proc_points, dus) <-          if splitting_proc_points             then do-              pp <- {-# SCC "minimalProcPointSet" #-} runUniqSM $-                 minimalProcPointSet platform call_pps g+              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+              return (pp, dus')             else-              return call_pps+              return (call_pps, dus)        ----------- Layout the stack and manifest Sp -----------------------------      (g, stackmaps) <--           {-# SCC "layoutStack" #-}-           if do_layout-              then runUniqSM $ cmmLayoutStack cfg proc_points entry_off g-              else return (g, mapEmpty)+      ((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  --------------------------------@@ -130,21 +145,21 @@       let cafEnv = {-# SCC "cafAnal" #-} cafAnal platform call_pps l g       dumpWith logger Opt_D_dump_cmm_caf "CAFEnv" FormatText (pdoc platform cafEnv) -      g <- if splitting_proc_points+      (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 <- {-# SCC "splitAtProcPoints" #-} runUniqSM $+             (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+             return (g, dus)            else              -- attach info tables to return points-             return $ [attachContInfoTables call_pps (CmmProc h l v g)]+             return ([attachContInfoTables call_pps (CmmProc h l v g)], dus)        ------------- Populate info tables with stack info -----------------       g <- {-# SCC "setInfoTableStackMap" #-}@@ -156,11 +171,11 @@            return $ if cmmOptControlFlow cfg                     then map (cmmCfgOptsProc splitting_proc_points) g                     else g-      g <- return (map removeUnreachableBlocksProc g)+      g <- return $ map (removeUnreachableBlocksProc platform) g            -- See Note [unreachable blocks]-      dumps Opt_D_dump_cmm_cfg "Post control-flow optimisations" g+      dumps Opt_D_dump_cmm_cfg "Post control-flow optimisations (2)" g -      return (Left (cafEnv, g))+      return (dus, Left (cafEnv, g))    where dump = dumpGraph logger platform (cmmDoLinting cfg) @@ -343,12 +358,6 @@ generator later.  -}--runUniqSM :: UniqSM a -> IO a-runUniqSM m = do-  us <- mkSplitUniqSupply 'u'-  return (initUs_ us m)-  dumpGraph :: Logger -> Platform -> Bool -> DumpFlag -> String -> CmmGraph -> IO () dumpGraph logger platform do_linting flag name g = do
− GHC/Cmm/Ppr.hs 
@@ -1,319 +0,0 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE LambdaCase #-}--{-# 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.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.------ A useful example pass over Cmm is in nativeGen/MachCodeGen.hs--module GHC.Cmm.Ppr-  ( module GHC.Cmm.Ppr.Decl-  , module GHC.Cmm.Ppr.Expr-  )-where--import GHC.Prelude hiding (succ)--import GHC.Platform-import GHC.Cmm.CLabel-import GHC.Cmm-import GHC.Cmm.Utils-import GHC.Cmm.Switch-import GHC.Data.FastString-import GHC.Utils.Outputable-import GHC.Cmm.Ppr.Decl-import GHC.Cmm.Ppr.Expr-import GHC.Utils.Constants (debugIsOn)--import GHC.Types.Basic-import GHC.Cmm.Dataflow.Block-import GHC.Cmm.Dataflow.Graph------------------------------------------------------ Outputable instances-instance OutputableP Platform InfoProvEnt where-  pdoc platform (InfoProvEnt clabel _ _ _ _) = pdoc platform clabel--instance Outputable CmmStackInfo where-    ppr = pprStackInfo--instance OutputableP Platform CmmTopInfo where-    pdoc = pprTopInfo---instance OutputableP Platform (CmmNode e x) where-    pdoc = pprNode--instance Outputable Convention where-    ppr = pprConvention--instance Outputable ForeignConvention where-    ppr = pprForeignConvention--instance OutputableP Platform ForeignTarget where-    pdoc = pprForeignTarget--instance Outputable CmmReturnInfo where-    ppr = pprReturnInfo--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--instance OutputableP Platform CmmGraph where-    pdoc = pprCmmGraph--------------------------------------------------------------- Outputting types Cmm contains--pprStackInfo :: CmmStackInfo -> SDoc-pprStackInfo (StackInfo {arg_space=arg_space}) =-  text "arg_space: " <> ppr arg_space--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]--------------------------------------------------------------- Outputting blocks and graphs--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--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.-------------------------------------------------- Outputting CmmNode and types which it contains--pprConvention :: Convention -> SDoc-pprConvention (NativeNodeCall   {}) = text "<native-node-call-convention>"-pprConvention (NativeDirectCall {}) = text "<native-direct-call-convention>"-pprConvention (NativeReturn {})     = text "<native-ret-convention>"-pprConvention  Slow                 = text "<slow-convention>"-pprConvention  GC                   = text "<gc-convention>"--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 :: 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-               (CmmLabel (mkForeignLabel-                         (mkFastString (show op))-                         Nothing ForeignLabelInThisPackage IsFunction))--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 $ map 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
− GHC/Cmm/Ppr/Decl.hs 
@@ -1,172 +0,0 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-}------------------------------------------------------------------------------------- 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.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.------ A useful example pass over Cmm is in nativeGen/MachCodeGen.hs-----{-# OPTIONS_GHC -fno-warn-orphans #-}-module GHC.Cmm.Ppr.Decl-    ( pprCmms, pprCmmGroup, pprSection, pprStatic-    )-where--import GHC.Prelude--import GHC.Platform-import GHC.Cmm.Ppr.Expr-import GHC.Cmm--import GHC.Utils.Outputable--import Data.List (intersperse)--import qualified Data.ByteString as BS---pprCmms :: (OutputableP Platform info, OutputableP Platform g)-        => Platform -> [GenCmmGroup RawCmmStatics info g] -> SDoc-pprCmms platform cmms = pprCode CStyle (vcat (intersperse separator $ map (pdoc platform) cmms))-        where-          separator = space $$ text "-------------------" $$ space---------------------------------------------------------------------------------instance (OutputableP Platform d, OutputableP Platform info, OutputableP Platform i)-      => OutputableP Platform (GenCmmDecl d info i) where-    pdoc = pprTop--instance OutputableP Platform (GenCmmStatics a) where-    pdoc = pprStatics--instance OutputableP Platform CmmStatic where-    pdoc = pprStatic--instance OutputableP Platform CmmInfoTable where-    pdoc = pprInfoTable----------------------------------------------------------------------------------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---- ----------------------------------------------------------------------------- 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 ]--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 :: Platform -> GenCmmStatics a -> SDoc-pprStatics platform (CmmStatics lbl itbl ccs payload) =-  pdoc platform lbl <> colon <+> pdoc platform itbl <+> ppr ccs <+> pdoc platform payload-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" <+> pprLit 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"-  ReadOnlyData16          -> text "readonly16"-  RelocatableReadOnlyData -> text "relreadonly"-  UninitialisedData       -> text "uninitialised"-  InitArray               -> text "initarray"-  FiniArray               -> text "finiarray"-  CString                 -> text "cstring"-  OtherSection s'         -> text s'
− GHC/Cmm/Ppr/Expr.hs 
@@ -1,299 +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.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.------ A useful example pass over Cmm is in nativeGen/MachCodeGen.hs----{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}--{-# OPTIONS_GHC -fno-warn-orphans #-}--module GHC.Cmm.Ppr.Expr-    ( pprExpr, pprLit-    )-where--import GHC.Prelude--import GHC.Platform-import GHC.Cmm.Expr--import GHC.Utils.Outputable-import GHC.Utils.Trace--import Data.Maybe-import Numeric ( fromRat )---------------------------------------------------------------------------------instance OutputableP Platform CmmExpr where-    pdoc = pprExpr--instance Outputable CmmReg where-    ppr e = pprReg e--instance OutputableP Platform CmmLit where-    pdoc = pprLit--instance Outputable LocalReg where-    ppr e = pprLocalReg e--instance Outputable Area where-    ppr e = pprArea e--instance Outputable GlobalReg where-    ppr e = pprGlobalReg e--instance OutputableP env GlobalReg where-    pdoc _ = ppr---- ----------------------------------------------------------------------------- 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 platform 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 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.Ppr.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---- ----------------------------------------------------------------------------- Literals.---  To minimise line noise we adopt the convention that if the literal---  has the natural machine word size, we do not append the type----pprLit :: Platform -> CmmLit -> SDoc-pprLit platform lit = case lit of-    CmmInt i rep ->-        hcat [ (if i < 0 then parens else id)(integer i)-             , ppUnless (rep == wordWidth platform) $-               space <> dcolon <+> ppr rep ]--    CmmFloat f rep     -> hsep [ double (fromRat f), dcolon, ppr rep ]-    CmmVec lits        -> char '<' <> commafy (map (pprLit platform) lits) <> char '>'-    CmmLabel clbl      -> pdoc platform clbl-    CmmLabelOff clbl i -> pdoc platform clbl <> ppr_offset i-    CmmLabelDiffOff clbl1 clbl2 i _ -> pdoc platform clbl1 <> char '-'-                                       <> pdoc platform clbl2 <> ppr_offset i-    CmmBlock id        -> ppr id-    CmmHighStackMark -> text "<highSp>"--pprLit1 :: Platform -> CmmLit -> SDoc-pprLit1 platform lit@(CmmLabelOff {}) = parens (pprLit platform lit)-pprLit1 platform lit                  = pprLit platform lit--ppr_offset :: Int -> SDoc-ppr_offset i-    | i==0      = empty-    | i>=0      = char '+' <> int i-    | otherwise = char '-' <> int (-i)---- ----------------------------------------------------------------------------- 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 '_' <> 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---- 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 'GHC.Cmm.Expr.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
GHC/Cmm/ProcPoint.hs view
@@ -1,9 +1,6 @@-{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DisambiguateRecordFields #-} {-# LANGUAGE GADTs #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}- module GHC.Cmm.ProcPoint     ( ProcPointSet, Status(..)     , callProcPoints, minimalProcPointSet@@ -17,7 +14,6 @@ import GHC.Cmm.BlockId import GHC.Cmm.CLabel import GHC.Cmm-import GHC.Cmm.Ppr () -- For Outputable instances import GHC.Cmm.Utils import GHC.Cmm.Info import GHC.Cmm.Liveness@@ -28,9 +24,8 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Platform-import GHC.Types.Unique.Supply+import GHC.Types.Unique.DSM import GHC.Cmm.Dataflow.Block-import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow import GHC.Cmm.Dataflow.Graph import GHC.Cmm.Dataflow.Label@@ -190,14 +185,14 @@                       _ -> set  minimalProcPointSet :: Platform -> ProcPointSet -> CmmGraph-                    -> UniqSM ProcPointSet+                    -> 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 -> UniqSM ProcPointSet+    :: Platform -> CmmGraph -> [CmmBlock] -> ProcPointSet -> UniqDSM ProcPointSet extendPPSet platform g blocks procPoints =     let env = procPointAnalysis procPoints g         add pps block = let id = entryLabel block@@ -241,7 +236,7 @@ -- ToDo: use the _ret naming convention that the old code generator -- used. -- EZY splitAtProcPoints :: Platform -> CLabel -> ProcPointSet-> ProcPointSet -> LabelMap Status -> CmmDecl-                  -> UniqSM [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@@ -267,8 +262,8 @@     let liveness = cmmGlobalLiveness platform g-  let ppLiveness pp = filter isArgReg $ regSetToList $-                        expectJust "ppLiveness" $ mapLookup pp liveness+  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:@@ -291,9 +286,9 @@   -- 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])+                     -> UniqDSM (LabelMap Label, [CmmBlock])       add_jump_block (env, bs) (pp, l) = do-        bid <- liftM mkBlockId getUniqueM+        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@@ -322,7 +317,7 @@           CmmSwitch _ ids         -> foldr add_if_pp rst $ switchTargetsToList ids           _                       -> rst -  let add_jumps :: LabelMap CmmGraph -> (Label, LabelMap CmmBlock) -> UniqSM (LabelMap CmmGraph)+  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@@ -330,7 +325,7 @@         (jumpEnv, jumpBlocks) <-            foldM add_jump_block (mapEmpty, []) needed_jumps             -- update the entry block-        let b = expectJust "block in env" $ mapLookup ppId blockEnv+        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'@@ -348,7 +343,7 @@                                stack_info = stack_info})                      top_l live g'           | otherwise-          = case expectJust "pp label" $ mapLookup bid procLabels of+          = 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})@@ -382,8 +377,8 @@           foldl' add_block_num (0::Int, mapEmpty :: LabelMap Int)                 (revPostorder g)   let sort_fn (bid, _) (bid', _) =-        compare (expectJust "block_order" $ mapLookup bid  block_order)-                (expectJust "block_order" $ mapLookup bid' block_order)+        compare (expectJust $ mapLookup bid  block_order)+                (expectJust $ mapLookup bid' block_order)    return $ map to_proc $ sortBy sort_fn $ mapToList graphEnv
+ GHC/Cmm/Reducibility.hs view
@@ -0,0 +1,223 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE MultiParamTypeClasses #-}++{-|+Module      : GHC.Cmm.Reducibility+Description : Tell if a `CmmGraph` is reducible, or make it so++Test a Cmm control-flow graph for reducibility.  And provide a+function that, when given an arbitrary control-flow graph, returns an+equivalent, reducible control-flow graph.  The equivalent graph is+obtained by "splitting" (copying) nodes of the original graph.+The resulting equivalent graph has the same dynamic behavior as the+original, but it is larger.++Documentation uses the language of control-flow analysis, in which a+basic block is called a "node."  These "nodes" are `CmmBlock`s or+equivalent; they have nothing to do with a `CmmNode`.++For more on reducibility and related analyses and algorithms, see+Note [Reducibility resources]+-}++module GHC.Cmm.Reducibility+  ( Reducibility(..)+  , reducibility++  , asReducible+  )+where++import GHC.Prelude hiding (splitAt, succ)++import Control.Monad+import Data.List (nub)+import Data.Maybe+import Data.Semigroup+import qualified Data.Sequence as Seq++import GHC.Cmm+import GHC.Cmm.BlockId+import GHC.Cmm.Dataflow+import GHC.Cmm.Dataflow.Block+import GHC.Cmm.Dominators+import GHC.Cmm.Dataflow.Graph hiding (addBlock)+import GHC.Cmm.Dataflow.Label+import GHC.Data.Graph.Collapse+import GHC.Data.Graph.Inductive.Graph+import GHC.Data.Graph.Inductive.PatriciaTree+import GHC.Types.Unique.DSM+import GHC.Utils.Panic++-- | Represents the result of a reducibility analysis.+data Reducibility = Reducible | Irreducible+  deriving (Eq, Show)++-- | Given a graph, say whether the graph is reducible.  The graph must+-- be bundled with a dominator analysis and a reverse postorder+-- numbering, as these results are needed to perform the test.++reducibility :: NonLocal node+             => GraphWithDominators node+             -> Reducibility+reducibility gwd =+    if all goodBlock blockmap then Reducible else Irreducible+  where goodBlock b = all (goodEdge (entryLabel b)) (successors b)+        goodEdge from to = rpnum to > rpnum from || to `dominates` from+        rpnum = gwdRPNumber gwd+        blockmap = graphMap $ gwd_graph gwd+        dominators = gwdDominatorsOf gwd+        dominates lbl blockname =+            lbl == blockname || dominatorsMember lbl (dominators blockname)++-- | Given a graph, return an equivalent reducible graph, by+-- "splitting" (copying) nodes if necessary.  The input+-- graph must be bundled with a dominator analysis and a reverse+-- postorder numbering.  The computation is monadic because when a+-- node is split, the new copy needs a fresh label.+--+-- Use this function whenever a downstream algorithm needs a reducible+-- control-flow graph.++asReducible :: GraphWithDominators CmmNode+            -> UniqDSM (GraphWithDominators CmmNode)+asReducible gwd = case reducibility gwd of+                    Reducible -> return gwd+                    Irreducible -> assertReducible <$> nodeSplit gwd++assertReducible :: GraphWithDominators CmmNode -> GraphWithDominators CmmNode+assertReducible gwd = case reducibility gwd of+                        Reducible -> gwd+                        Irreducible -> panic "result not reducible"++----------------------------------------------------------------++-- | Split one or more nodes of the given graph, which must be+-- irreducible.++nodeSplit :: GraphWithDominators CmmNode+          -> UniqDSM (GraphWithDominators CmmNode)+nodeSplit gwd =+    graphWithDominators <$> inflate (g_entry g) <$> runNullCollapse collapsed+  where g = gwd_graph gwd+        collapsed :: NullCollapseViz (Gr CmmSuper ())+        collapsed = collapseInductiveGraph (cgraphOfCmm g)++type CGraph = Gr CmmSuper ()++-- | Turn a collapsed supernode back into a control-flow graph+inflate :: Label -> CGraph -> CmmGraph+inflate entry cg = CmmGraph entry graph+  where graph = GMany NothingO body NothingO+        body :: LabelMap CmmBlock+        body = foldl (\map block -> mapInsert (entryLabel block) block map) mapEmpty $+               blocks super+        super = case labNodes cg of+                  [(_, s)] -> s+                  _ -> panic "graph given to `inflate` is not singleton"+++-- | Convert a `CmmGraph` into an inductive graph.+-- (The function coalesces duplicate edges into a single edge.)+cgraphOfCmm :: CmmGraph -> CGraph+cgraphOfCmm g = foldl' addSuccEdges (mkGraph cnodes []) blocks+   where blocks = zip [0..] $ revPostorderFrom (graphMap g) (g_entry g)+         cnodes = [(k, super block) | (k, block) <- blocks]+          where super block = Nodes (entryLabel block) (Seq.singleton block)+         labelNumber = \lbl -> fromJust $ mapLookup lbl numbers+             where numbers :: LabelMap Int+                   numbers = mapFromList $ map swap blocks+                   swap (k, block) = (entryLabel block, k)+         addSuccEdges :: CGraph -> (Node, CmmBlock) -> CGraph+         addSuccEdges graph (k, block) =+             insEdges [(k, labelNumber lbl, ()) | lbl <- nub $ successors block] graph+{-+Note [Reducibility resources]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++*Flow Analysis of Computer Programs.* Matthew S. Hecht North Holland, 1977.+Available to borrow from archive.org.++Matthew S. Hecht and Jeffrey D. Ullman (1972).+Flow Graph Reducibility. SIAM J. Comput., 1(2), 188–202.+https://doi.org/10.1137/0201014++Johan Janssen and Henk Corporaal. 1997. Making graphs reducible with+controlled node splitting. ACM TOPLAS 19, 6 (Nov. 1997),+1031–1052. DOI:https://doi.org/10.1145/267959.269971++Sebastian Unger and Frank Mueller. 2002. Handling irreducible loops:+optimized node splitting versus DJ-graphs. ACM TOPLAS 24, 4 (July+2002), 299–333. https://doi.org/10.1145/567097.567098.  (This one+contains the most detailed account of how the Hecht/Ullman algorithm+is used to modify an actual control-flow graph.  But still not much detail.)++https://rgrig.blogspot.com/2009/10/dtfloatleftclearleft-summary-of-some.html+ (Nice summary of useful facts)++-}++++type Seq = Seq.Seq++-- | A "supernode" contains a single-entry, multiple-exit, reducible subgraph.+-- The entry point is the given label, and the block with that label+-- dominates all the other blocks in the supernode.  When an entire+-- graph is collapsed into a single supernode, the graph is reducible.+-- More detail can be found in "GHC.Data.Graph.Collapse".++data CmmSuper+    = Nodes { label :: Label+            , blocks :: Seq CmmBlock+            }++instance Semigroup CmmSuper where+  s <> s' = Nodes (label s) (blocks s <> blocks s')++instance PureSupernode CmmSuper where+  superLabel = label+  mapLabels = changeLabels++instance Supernode CmmSuper NullCollapseViz where+  freshen s = liftUniqDSM $ relabel s+++-- | Return all labels defined within a supernode.+definedLabels :: CmmSuper -> Seq Label+definedLabels = fmap entryLabel . blocks++++-- | Map the given function over every use and definition of a label+-- in the given supernode.+changeLabels :: (Label -> Label) -> (CmmSuper -> CmmSuper)+changeLabels f (Nodes l blocks) = Nodes (f l) (fmap (changeBlockLabels f) blocks)++-- | Map the given function over every use and definition of a label+-- in the given block.+changeBlockLabels :: (Label -> Label) -> CmmBlock -> CmmBlock+changeBlockLabels f block = blockJoin entry' middle exit'+  where (entry, middle, exit) = blockSplit block+        entry' = let CmmEntry l scope = entry+                 in  CmmEntry (f l) scope+        exit' = case exit of+                  -- unclear why mapSuccessors doesn't touch these+                  CmmCall { cml_cont = Just l } -> exit { cml_cont = Just (f l) }+                  CmmForeignCall { succ = l } -> exit { succ = f l }+                  _ -> mapSuccessors f exit+++-- | Within the given supernode, replace every defined label (and all+-- of its uses) with a fresh label.++relabel :: CmmSuper -> UniqDSM CmmSuper+relabel node = do+     finite_map <- foldM addPair mapEmpty $ definedLabels node+     return $ changeLabels (labelChanger finite_map) node+  where addPair :: LabelMap Label -> Label -> UniqDSM (LabelMap Label)+        addPair map old = do new <- newBlockId+                             return $ mapInsert old new map+        labelChanger :: LabelMap Label -> (Label -> Label)+        labelChanger mapping = \lbl -> mapFindWithDefault lbl lbl mapping
+ GHC/Cmm/Reg.hs view
@@ -0,0 +1,364 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module GHC.Cmm.Reg+    ( -- * Cmm Registers+      CmmReg(..)+    , cmmRegType+    , cmmRegWidth+      -- * Local registers+    , LocalReg(..)+    , localRegType+      -- * Global registers+    , GlobalReg(..), isArgReg, globalRegSpillType, pprGlobalReg+    , spReg, hpReg, spLimReg, hpLimReg, nodeReg+    , currentTSOReg, currentNurseryReg, hpAllocReg, cccsReg+    , node, baseReg+    , GlobalRegUse(..), pprGlobalRegUse++    , GlobalArgRegs(..)+    ) where++import GHC.Prelude++import GHC.Platform+import GHC.Utils.Outputable+import GHC.Types.Unique+import GHC.Cmm.Type++-----------------------------------------------------------------------------+--              Cmm registers+-----------------------------------------------------------------------------++{- Note [GlobalReg vs GlobalRegUse]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We distinguish GlobalReg, which describes registers in the STG abstract machine,+with GlobalRegUse, which describes an usage of such a register to store values+of a particular CmmType.++For example, we might want to load/store an 8-bit integer in a register that+can store 32-bit integers.++The width of the type must fit in the register, i.e. for a usage+@GlobalRegUse reg ty@ we must have that++  > typeWidth ty <= typeWidth (globalRegSpillType reg)++The restrictions about what categories of types can be stored in a given+register are less easily stated. Some examples are:++  - Vanilla registers can contain both pointers (gcWord) and non-pointers (bWord),+    as well as sub-word sized values (e.g. b16).+  - On x86_64, SIMD registers can be used to hold vectors of both floating+    and integral values (e.g. XmmReg may store 2 Double values or 4 Int32 values).+-}++-- | A use of a global register at a particular type.+--+-- While a 'GlobalReg' identifies a global register in the STG machine,+-- a 'GlobalRegUse' also contains information about the type we are storing+-- in the register.+--+-- See Note [GlobalReg vs GlobalRegUse] for more information.+data GlobalRegUse+  = GlobalRegUse+    { globalRegUse_reg  :: !GlobalReg+      -- ^ The underlying 'GlobalReg'+    , globalRegUse_type :: !CmmType+      -- ^ The 'CmmType' at which we are using the 'GlobalReg'.+      --+      -- Its width must be less than the width of the 'GlobalReg':+      --+      -- > typeWidth ty <= typeWidth (globalRegSpillType platform reg)+    }+  deriving Show++instance Outputable GlobalRegUse where+  ppr (GlobalRegUse reg _) = ppr reg++pprGlobalRegUse :: IsLine doc => GlobalRegUse -> doc+pprGlobalRegUse (GlobalRegUse reg _) = pprGlobalReg reg++-- TODO: these instances should be removed in favour+-- of more surgical uses of equality.+instance Eq GlobalRegUse where+  GlobalRegUse r1 _ == GlobalRegUse r2 _ = r1 == r2+instance Ord GlobalRegUse where+  GlobalRegUse r1 _ `compare` GlobalRegUse r2 _ = compare r1 r2++data CmmReg+  = CmmLocal  {-# UNPACK #-} !LocalReg+  | CmmGlobal GlobalRegUse+  deriving ( Eq, Ord, Show )++instance Outputable CmmReg where+    ppr e = pprReg e++pprReg :: CmmReg -> SDoc+pprReg r+   = case r of+        CmmLocal  local                   -> pprLocalReg  local+        CmmGlobal (GlobalRegUse global _) -> pprGlobalReg global++cmmRegType :: CmmReg -> CmmType+cmmRegType (CmmLocal  reg) = localRegType reg+cmmRegType (CmmGlobal reg) = globalRegUse_type reg++cmmRegWidth :: CmmReg -> Width+cmmRegWidth = typeWidth . cmmRegType++-----------------------------------------------------------------------------+--              Local registers+-----------------------------------------------------------------------------++data LocalReg+  = LocalReg {-# UNPACK #-} !Unique !CmmType+    -- ^ Parameters:+    --   1. Identifier+    --   2. Type+  deriving Show++instance Eq LocalReg where+  (LocalReg u1 _) == (LocalReg u2 _) = u1 == u2++instance Outputable LocalReg where+    ppr e = pprLocalReg e++-- This is non-deterministic but we do not currently support deterministic+-- code-generation. See Note [Unique Determinism and code generation]+-- See Note [No Ord for Unique]+instance Ord LocalReg where+  compare (LocalReg u1 _) (LocalReg u2 _) = nonDetCmpUnique u1 u2++instance Uniquable LocalReg where+  getUnique (LocalReg uniq _) = uniq++localRegType :: LocalReg -> CmmType+localRegType (LocalReg _ rep) = rep++--+-- We only print the type of the local reg if it isn't wordRep+--+pprLocalReg :: LocalReg -> SDoc+pprLocalReg (LocalReg uniq rep) =+--   = ppr rep <> char '_' <> ppr uniq+-- Temp Jan08+    char '_' <> pprUnique uniq <>+       (if isWord32 rep -- && not (isGcPtrType rep) -- Temp Jan08               -- sigh+                    then dcolon <> ptr <> ppr rep+                    else dcolon <> ptr <> ppr rep)+   where+     pprUnique unique = sdocOption sdocSuppressUniques $ \case+       True  -> text "_locVar_"+       False -> ppr unique+     ptr = empty+         --if isGcPtrType rep+         --      then doubleQuotes (text "ptr")+         --      else empty++-----------------------------------------------------------------------------+--              Global STG registers+-----------------------------------------------------------------------------+{-+Note [Overlapping global registers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The backend might not faithfully implement the abstraction of the STG+machine with independent registers for different values of type+GlobalReg. Specifically, certain pairs of registers (r1, r2) may+overlap in the sense that a store to r1 invalidates the value in r2,+and vice versa.++Currently this occurs only on the x86_64 architecture where FloatReg n+and DoubleReg n are assigned the same microarchitectural register, in+order to allow functions to receive more Float# or Double# arguments+in registers (as opposed to on the stack).++There are no specific rules about which registers might overlap with+which other registers, but presumably it's safe to assume that nothing+will overlap with special registers like Sp or BaseReg.++Use GHC.Cmm.Utils.regsOverlap to determine whether two GlobalRegs overlap+on a particular platform. The instance Eq GlobalReg is syntactic+equality of STG registers and does not take overlap into+account. However it is still used in UserOfRegs/DefinerOfRegs and+there are likely still bugs there, beware!+-}++-- | An abstract global register for the STG machine.+--+-- See also 'GlobalRegUse', which denotes a usage of a register at a particular+-- type (e.g. using a 32-bit wide register to store an 8-bit wide value), as per+-- Note [GlobalReg vs GlobalRegUse].+data GlobalReg+  -- Argument and return registers+  = VanillaReg                  -- pointers, unboxed ints and chars+        {-# UNPACK #-} !Int     -- its number++  | FloatReg            -- single-precision floating-point registers+        {-# UNPACK #-} !Int     -- its number++  | DoubleReg           -- double-precision floating-point registers+        {-# UNPACK #-} !Int     -- its number++  | LongReg             -- long int registers (64-bit, really)+        {-# UNPACK #-} !Int     -- its number++  -- I think we should redesign 'GlobalReg', for example instead of+  -- FloatReg/DoubleReg/XmmReg/YmmReg/ZmmReg we could have a single VecReg+  -- which also stores the type we are storing in it.+  --+  -- We might then be able to get rid of GlobalRegUse, as the type information+  -- would already be contained in a 'GlobalReg'.++  | XmmReg                      -- 128-bit SIMD vector register+        {-# UNPACK #-} !Int     -- its number++  | YmmReg                      -- 256-bit SIMD vector register+        {-# UNPACK #-} !Int     -- its number++  | ZmmReg                      -- 512-bit SIMD vector register+        {-# UNPACK #-} !Int     -- its number++  -- STG registers+  | Sp                  -- ^ Stack ptr; points to last occupied stack location.+  | SpLim               -- ^ Stack limit+  | Hp                  -- ^ Heap ptr; points to last occupied heap location.+  | HpLim               -- ^ Heap limit register+  | CCCS                -- ^ Current cost-centre stack+  | CurrentTSO          -- ^ pointer to current thread's TSO+  | CurrentNursery      -- ^ pointer to allocation area+  | HpAlloc             -- ^ allocation count for heap check failure++                -- We keep the address of some commonly-called+                -- functions in the register table, to keep code+                -- size down:+  | EagerBlackholeInfo  -- ^ address of stg_EAGER_BLACKHOLE_info+  | GCEnter1            -- ^ address of stg_gc_enter_1+  | GCFun               -- ^ address of stg_gc_fun++  -- | Base offset for the register table, used for accessing registers+  -- which do not have real registers assigned to them.  This register+  -- will only appear after we have expanded GlobalReg into memory accesses+  -- (where necessary) in the native code generator.+  | BaseReg++  -- | The register used by the platform for the C stack pointer. This is+  -- a break in the STG abstraction used exclusively to setup stack unwinding+  -- information.+  | MachSp++  -- | A dummy register used to indicate to the stack unwinder where+  -- a routine would return to.+  | UnwindReturnReg++  -- | Base Register for PIC (position-independent code) calculations.+  --+  -- Only used inside the native code generator. Its exact meaning differs+  -- from platform to platform (see module PositionIndependentCode).+  | PicBaseReg++  deriving( Eq, Ord, Show )+    -- NOTE: the Ord instance affects the tuple layout in GHCi, see+    --       Note [GHCi and native call registers]++instance Outputable GlobalReg where+    ppr e = pprGlobalReg e++instance OutputableP env GlobalReg where+    pdoc _ = ppr++pprGlobalReg :: IsLine doc => GlobalReg -> doc+pprGlobalReg gr+    = case gr of+        VanillaReg n   -> char 'R' <> int n+        FloatReg   n   -> char 'F' <> int n+        DoubleReg  n   -> char 'D' <> int n+        LongReg    n   -> char 'L' <> int n+        XmmReg     n   -> text "XMM" <> int n+        YmmReg     n   -> text "YMM" <> int n+        ZmmReg     n   -> text "ZMM" <> int n+        Sp             -> text "Sp"+        SpLim          -> text "SpLim"+        Hp             -> text "Hp"+        HpLim          -> text "HpLim"+        MachSp         -> text "MachSp"+        UnwindReturnReg-> text "UnwindReturnReg"+        CCCS           -> text "CCCS"+        CurrentTSO     -> text "CurrentTSO"+        CurrentNursery -> text "CurrentNursery"+        HpAlloc        -> text "HpAlloc"+        EagerBlackholeInfo -> text "stg_EAGER_BLACKHOLE_info"+        GCEnter1       -> text "stg_gc_enter_1"+        GCFun          -> text "stg_gc_fun"+        BaseReg        -> text "BaseReg"+        PicBaseReg     -> text "PicBaseReg"+{-# SPECIALIZE pprGlobalReg :: GlobalReg -> SDoc #-}+{-# SPECIALIZE pprGlobalReg :: GlobalReg -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable+++-- convenient aliases+baseReg, spReg, hpReg, spLimReg, hpLimReg, nodeReg,+  currentTSOReg, currentNurseryReg, hpAllocReg, cccsReg :: Platform -> CmmReg+baseReg           p = CmmGlobal (GlobalRegUse BaseReg        $ bWord p)+spReg             p = CmmGlobal (GlobalRegUse Sp             $ bWord p)+hpReg             p = CmmGlobal (GlobalRegUse Hp             $ gcWord p)+hpLimReg          p = CmmGlobal (GlobalRegUse HpLim          $ bWord p)+spLimReg          p = CmmGlobal (GlobalRegUse SpLim          $ bWord p)+nodeReg           p = CmmGlobal (GlobalRegUse (VanillaReg 1) $ gcWord p)+currentTSOReg     p = CmmGlobal (GlobalRegUse CurrentTSO     $ bWord p)+currentNurseryReg p = CmmGlobal (GlobalRegUse CurrentNursery $ bWord p)+hpAllocReg        p = CmmGlobal (GlobalRegUse HpAlloc        $ bWord p)+cccsReg           p = CmmGlobal (GlobalRegUse CCCS           $ bWord p)++node :: GlobalReg+node = VanillaReg 1++globalRegSpillType :: Platform -> GlobalReg -> CmmType+globalRegSpillType platform = \case+   VanillaReg _ -> gcWord platform+   FloatReg   _ -> cmmFloat W32+   DoubleReg  _ -> cmmFloat W64+   LongReg    _ -> cmmBits  W64++   -- TODO: improve the internal model of SIMD/vectorized registers+   -- the right design SHOULD improve handling of float and double code too.+   -- see remarks in Note [SIMD Design for the future] in GHC.StgToCmm.Prim+   XmmReg    _ -> cmmVec  4 (cmmBits W32)+   YmmReg    _ -> cmmVec  8 (cmmBits W32)+   ZmmReg    _ -> cmmVec 16 (cmmBits W32)++   Hp          -> gcWord platform -- The initialiser for all+                                  -- dynamically allocated closures+   _           -> bWord platform++isArgReg :: GlobalReg -> Bool+isArgReg (VanillaReg {}) = True+isArgReg (FloatReg {})   = True+isArgReg (DoubleReg {})  = True+isArgReg (LongReg {})    = True+isArgReg (XmmReg {})     = True+isArgReg (YmmReg {})     = True+isArgReg (ZmmReg {})     = True+isArgReg _               = False++-- --------------------------------------------------------------------------++-- | Global registers used for argument passing.+--+-- See Note [realArgRegsCover] in GHC.Cmm.CallConv.+data GlobalArgRegs+  -- | General-purpose (integer) argument-passing registers.+  = GP_ARG_REGS+  -- | Scalar (integer & floating-point) argument-passing registers.+  | SCALAR_ARG_REGS+  -- | 16 byte vector argument-passing registers, together with+  -- integer & floating-point argument-passing scalar registers.+  | V16_ARG_REGS+  -- | 32 byte vector argument-passing registers, together with+  -- integer & floating-point argument-passing scalar registers.+  | V32_ARG_REGS+  -- | 64 byte vector argument-passing registers, together with+  -- integer & floating-point argument-passing scalar registers.+  | V64_ARG_REGS+  deriving ( Show, Eq, Ord )
GHC/Cmm/Sink.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE MultiWayIf #-}  module GHC.Cmm.Sink (      cmmSink@@ -14,14 +15,12 @@ import GHC.Cmm.Utils import GHC.Cmm.Dataflow.Block import GHC.Cmm.Dataflow.Label-import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Graph import GHC.Platform.Regs  import GHC.Platform import GHC.Types.Unique.FM -import qualified Data.IntSet as IntSet import Data.List (partition) import Data.Maybe @@ -175,7 +174,7 @@       -- 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 = IntSet.unions (map getLive succs)+      live = unionsLRegSet (map getLive succs)       live_middle = gen_killL platform last live       ann_middles = annotate platform live_middle (blockToList middle) @@ -188,7 +187,7 @@       -- 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 = IntSet.unions (map getLive joins)+      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.@@ -215,7 +214,7 @@             live_sets' | should_drop = live_sets                        | otherwise   = map upd live_sets -            upd set | r `elemLRegSet` set = set `IntSet.union` live_rhs+            upd set | r `elemLRegSet` set = set `unionLRegSet` live_rhs                     | otherwise          = set              live_rhs = foldRegsUsed platform (flip insertLRegSet) emptyLRegSet rhs@@ -244,7 +243,7 @@ -- isTrivial :: Platform -> CmmExpr -> Bool isTrivial _ (CmmReg (CmmLocal _)) = True-isTrivial platform (CmmReg (CmmGlobal r)) = -- see Note [Inline GlobalRegs?]+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)@@ -268,7 +267,7 @@   all_succs = concatMap successors blocks    succ_counts :: LabelMap Int-  succ_counts = foldr (\l -> mapInsertWith (+) l 1) mapEmpty all_succs+  succ_counts = foldl' (\acc l -> mapInsertWith (+) l 1 acc) mapEmpty all_succs  -- -- filter the list of assignments to remove any assignments that@@ -360,7 +359,7 @@     * The assignment `_c3 = [R1 + 1]`; (R1 already inlined on pickup)       conflicts with R1 = R1, because it reads `R1` and the node writes       to R1-    * This is clearly no-sensical because `R1 = R1` doesn't affect R1's value.+    * 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@@ -490,7 +489,7 @@           where (final_node, rest') = go usages live' node' (insertLRegSet l skipped) rest                  -- Avoid discarding of assignments to vars on the rhs.-                -- See Note [Keeping assignemnts mentioned in skipped RHSs]+                -- 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)@@ -518,9 +517,9 @@         inl_exp (CmmMachOp op args) = cmmMachOpFold platform op args         inl_exp other = other -{- Note [Keeping assignemnts mentioned in skipped RHSs]+{- Note [Keeping assignments mentioned in skipped RHSs]    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-    If we have to assignments: [z = y, y = e1] and we skip+    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.@@ -593,7 +592,7 @@ -- Now we can go ahead and inline x. -- -- For now we do nothing, because this would require putting--- everything inside UniqSM.+-- everything inside UniqDSM. -- -- One more variant of this (#7366): --@@ -667,9 +666,9 @@   , 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 Hp) _ <- node        = True-  | StackMem   <- addr, CmmAssign (CmmGlobal Sp) _ <- node        = True-  | SpMem{}    <- addr, CmmAssign (CmmGlobal Sp) _ <- node        = True+  | 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@@ -703,9 +702,9 @@ -- Cmm expression globalRegistersConflict :: Platform -> CmmExpr -> CmmNode e x -> Bool globalRegistersConflict platform expr node =-    -- See Note [Inlining foldRegsDefd]-    inline foldRegsDefd platform (\b r -> b || regUsedIn platform (CmmGlobal r) expr)-                 False 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@@ -852,17 +851,17 @@ loadAddr :: Platform -> CmmExpr -> Width -> AbsMem loadAddr platform e w =   case e of-   CmmReg r       -> regAddr platform r 0 w-   CmmRegOff r i  -> regAddr platform r i w-   _other | regUsedIn platform spReg e -> StackMem-          | otherwise                  -> AnyMem+   CmmReg r       -> regAddr r 0 w+   CmmRegOff r i  -> regAddr r i w+   _other | regUsedIn platform (spReg platform) e -> StackMem+          | otherwise                             -> AnyMem -regAddr :: Platform -> 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 platform r _ _ | isGcPtrType (cmmRegType platform r) = HeapMem -- yay! GCPtr pays for itself-regAddr _      _ _ _ = 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?]
GHC/Cmm/Switch.hs view
@@ -4,15 +4,15 @@      SwitchTargets,      mkSwitchTargets,      switchTargetsCases, switchTargetsDefault, switchTargetsRange, switchTargetsSigned,-     mapSwitchTargets, switchTargetsToTable, switchTargetsFallThrough,+     mapSwitchTargets, mapSwitchTargetsA, switchTargetsToTable, switchTargetsFallThrough,      switchTargetsToList, eqSwitchTargetWith,       SwitchPlan(..),-     backendSupportsSwitch,+     backendHasNativeSwitch,      createSwitchPlan,   ) where -import GHC.Prelude+import GHC.Prelude hiding (head)  import GHC.Utils.Outputable import GHC.Driver.Backend@@ -20,8 +20,7 @@ import GHC.Cmm.Dataflow.Label (Label)  import Data.Maybe-import Data.List (groupBy)-import Data.Function (on)+import Data.List.NonEmpty (NonEmpty (..), groupWith, head) import qualified Data.Map as M  -- Note [Cmm Switches, the general plan]@@ -137,6 +136,11 @@ 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@@ -201,11 +205,11 @@  -- | 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 -> ([(NonEmpty Integer, Label)], Maybe Label) switchTargetsFallThrough (SwitchTargets _ _ mbdef branches) = (groups, mbdef)   where-    groups = map (\xs -> (map fst xs, snd (head xs))) $-             groupBy ((==) `on` snd) $+    groups = fmap (\xs -> (fmap fst xs, snd (head xs))) $+             groupWith snd $              M.toList branches  -- | Custom equality helper, needed for "GHC.Cmm.CommonBlockElim"@@ -312,13 +316,6 @@ -}  --- | Does the backend support switch out of the box? Then leave this to the--- backend!-backendSupportsSwitch :: Backend -> Bool-backendSupportsSwitch ViaC = True-backendSupportsSwitch LLVM = True-backendSupportsSwitch _    = False- -- | This function creates a SwitchPlan from a SwitchTargets value, breaking it -- down into smaller pieces suitable for code generation. createSwitchPlan :: SwitchTargets -> SwitchPlan@@ -372,7 +369,7 @@ ---  Step 3: Fill in the blanks --- --- | A FlatSwitchPlan is a list of SwitchPlans, with an integer inbetween every+-- | 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.
GHC/Cmm/Switch/Implement.hs view
@@ -12,8 +12,8 @@ import GHC.Cmm import GHC.Cmm.Utils import GHC.Cmm.Switch-import GHC.Types.Unique.Supply import GHC.Utils.Monad (concatMapM)+import GHC.Types.Unique.DSM  -- -- This module replaces Switch statements as generated by the Stg -> Cmm@@ -31,14 +31,14 @@  -- | Traverses the 'CmmGraph', making sure that 'CmmSwitch' are suitable for -- code generation.-cmmImplementSwitchPlans :: Platform -> CmmGraph -> UniqSM CmmGraph+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 -> UniqSM [CmmBlock]+visitSwitches :: Platform -> CmmBlock -> UniqDSM [CmmBlock] visitSwitches platform block   | (entry@(CmmEntry _ scope), middle, CmmSwitch vanillaExpr ids) <- blockSplit block   = do@@ -69,15 +69,15 @@ -- This happened in parts of the handwritten RTS Cmm code. See also #16933  -- See Note [Floating switch expressions]-floatSwitchExpr :: Platform -> CmmExpr -> UniqSM (Block CmmNode O O, CmmExpr)+floatSwitchExpr :: Platform -> CmmExpr -> UniqDSM (Block CmmNode O O, CmmExpr) floatSwitchExpr _        reg@(CmmReg {})  = return (emptyBlock, reg) floatSwitchExpr platform expr             = do-  (assign, expr') <- cmmMkAssign platform expr <$> getUniqueM+  (assign, expr') <- cmmMkAssign platform expr <$> getUniqueDSM   return (BMiddle assign, expr')   -- Implementing a switch plan (returning a tail block)-implementSwitchPlan :: Platform -> CmmTickScope -> CmmExpr -> SwitchPlan -> UniqSM (Block CmmNode O C, [CmmBlock])+implementSwitchPlan :: Platform -> CmmTickScope -> CmmExpr -> SwitchPlan -> UniqDSM (Block CmmNode O C, [CmmBlock]) implementSwitchPlan platform scope expr = go   where     width = typeWidth $ cmmExprType platform expr@@ -111,7 +111,7 @@       = return (l, [])     go' p       = do-        bid <- mkBlockId `fmap` getUniqueM+        bid <- mkBlockId `fmap` getUniqueDSM         (last, newBlocks) <- go p         let block = CmmEntry bid scope `blockJoinHead` last         return (bid, block: newBlocks)
+ GHC/Cmm/ThreadSanitizer.hs view
@@ -0,0 +1,299 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}++-- | Annotate a CmmGraph with ThreadSanitizer instrumentation calls.+module GHC.Cmm.ThreadSanitizer (annotateTSAN) where++import GHC.Prelude++import GHC.Platform+import GHC.Platform.Regs (activeStgRegs, callerSaves)+import GHC.Cmm+import GHC.Cmm.Utils+import GHC.Cmm.CLabel+import GHC.Cmm.Dataflow+import GHC.Cmm.Dataflow.Block+import GHC.Cmm.Dataflow.Graph+import GHC.Data.FastString+import GHC.Types.Basic+import GHC.Types.ForeignCall+import GHC.Types.Unique+import GHC.Types.Unique.Supply+import GHC.Cmm.Dataflow.Label++import Data.Maybe (fromMaybe)++data Env = Env { platform :: Platform+               , uniques :: UniqSupply+               }++annotateTSAN :: Platform -> CmmGraph -> UniqSM CmmGraph+annotateTSAN platform graph = do+    env <- Env platform <$> getUniqueSupplyM+    return $ modifyGraph (mapGraphBlocks mapMap (annotateBlock env)) graph++mapBlockList :: (forall e' x'. n e' x' -> Block n e' x')+             -> Block n e x -> Block n e x+mapBlockList f (BlockCO n rest  ) = f n `blockAppend` mapBlockList f rest+mapBlockList f (BlockCC n rest m) = f n `blockAppend` mapBlockList f rest `blockAppend` f m+mapBlockList f (BlockOC   rest m) = mapBlockList f rest `blockAppend` f m+mapBlockList _ BNil               = BNil+mapBlockList f (BMiddle blk)      = f blk+mapBlockList f (BCat a b)         = mapBlockList f a `blockAppend` mapBlockList f b+mapBlockList f (BSnoc a n)        = mapBlockList f a `blockAppend` f n+mapBlockList f (BCons n a)        = f n `blockAppend` mapBlockList f a++annotateBlock :: Env -> Block CmmNode e x -> Block CmmNode e x+annotateBlock env = mapBlockList (annotateNode env)++annotateNode :: Env -> CmmNode e x -> Block CmmNode e x+annotateNode env node =+    case node of+      CmmEntry{}              -> BlockCO node BNil+      CmmComment{}            -> BMiddle node+      CmmTick{}               -> BMiddle node+      CmmUnwind{}             -> BMiddle node+      CmmAssign{}             -> annotateNodeOO env node+      -- TODO: Track unaligned stores+      CmmStore _ _ Unaligned  -> annotateNodeOO env node+      CmmStore lhs rhs NaturallyAligned  ->+          let ty = cmmExprType (platform env) rhs+              rhs_nodes = annotateLoads env (collectExprLoads rhs)+              lhs_nodes = annotateLoads env (collectExprLoads lhs)+              st        = tsanStore env ty lhs+          in rhs_nodes `blockAppend` lhs_nodes `blockAppend` st `blockSnoc` node+      CmmUnsafeForeignCall (PrimTarget op) formals args ->+          let node' = fromMaybe (BMiddle node) (annotatePrim env op formals args)+              arg_nodes = blockConcat $ map (annotateExpr env) args+          in arg_nodes `blockAppend` node'+      CmmUnsafeForeignCall{}  -> annotateNodeOO env node+      CmmBranch{}             -> annotateNodeOC env node+      CmmCondBranch{}         -> annotateNodeOC env node+      CmmSwitch{}             -> annotateNodeOC env node+      CmmCall{}               -> annotateNodeOC env node+      CmmForeignCall{}        -> annotateNodeOC env node++annotateNodeOO :: Env -> CmmNode O O -> Block CmmNode O O+annotateNodeOO env node =+    annotateLoads env (collectLoadsNode node) `blockSnoc` node++annotateNodeOC :: Env -> CmmNode O C -> Block CmmNode O C+annotateNodeOC env node =+    annotateLoads env (collectLoadsNode node) `blockJoinTail` node++annotateExpr :: Env -> CmmExpr -> Block CmmNode O O+annotateExpr env expr =+    annotateLoads env (collectExprLoads expr)++-- | A load mentioned in a 'CmmExpr'.+data Load = Load CmmType AlignmentSpec CmmExpr++annotateLoads :: Env -> [Load] -> Block CmmNode O O+annotateLoads env loads =+    blockConcat+    [ tsanLoad env align ty addr+    | Load ty align addr <- loads+    ]++collectLoadsNode :: CmmNode e x -> [Load]+collectLoadsNode node =+    foldExp (\exp rest -> collectExprLoads exp ++ rest) node []++-- | Collect all of the memory locations loaded from by a 'CmmExpr'.+collectExprLoads :: CmmExpr -> [Load]+collectExprLoads (CmmLit _)           = []+collectExprLoads (CmmLoad e ty align) = [Load ty align e]+collectExprLoads (CmmReg _)           = []+-- N.B. we don't bother telling TSAN about MO_RelaxedReads+-- since doing so would be inconvenient and they by+-- definition can neither race nor introduce ordering.+collectExprLoads (CmmMachOp _op args) = foldMap collectExprLoads args+collectExprLoads (CmmStackSlot _ _)   = []+collectExprLoads (CmmRegOff _ _)      = []++-- | Generate TSAN instrumentation for a 'CallishMachOp' occurrence.+annotatePrim :: Env+             -> CallishMachOp   -- ^ the applied operation+             -> [CmmFormal]     -- ^ results+             -> [CmmActual]     -- ^ arguments+             -> Maybe (Block CmmNode O O)+                                -- ^ 'Just' a block of instrumentation, if applicable+annotatePrim env (MO_AtomicRMW w aop)    [dest]   [addr, val]  = Just $ tsanAtomicRMW env MemOrderSeqCst aop w addr val dest+annotatePrim env (MO_AtomicRead w mord)  [dest]   [addr]       = Just $ tsanAtomicLoad env mord w addr dest+annotatePrim env (MO_AtomicWrite w mord) []       [addr, val]  = Just $ tsanAtomicStore env mord w val addr+annotatePrim env (MO_Xchg w)             [dest]   [addr, val]  = Just $ tsanAtomicExchange env MemOrderSeqCst w val addr dest+annotatePrim env (MO_Cmpxchg w)          [dest]   [addr, expected, new]+                                                               = Just $ tsanAtomicCas env MemOrderSeqCst MemOrderSeqCst w addr expected new dest+annotatePrim _    _                       _        _           = Nothing++mkUnsafeCall :: Env+             -> ForeignTarget  -- ^ function+             -> [CmmFormal]    -- ^ results+             -> [CmmActual]    -- ^ arguments+             -> Block CmmNode O O+mkUnsafeCall env ftgt formals args =+    save `blockAppend`     -- save global registers+    bind_args `blockSnoc`  -- bind arguments to local registers+    call `blockAppend`     -- perform call+    restore                -- restore global registers+  where+    (save, restore) = saveRestoreCallerRegs gregs_us (platform env)++    (arg_us, gregs_us) = splitUniqSupply (uniques env)++    -- We also must be careful not to mention caller-saved registers in+    -- arguments as Cmm-Lint checks this. To accomplish this we instead bind+    -- the arguments to local registers.+    arg_regs :: [CmmReg]+    arg_regs = zipWith arg_reg (uniqsFromSupply arg_us) args+      where+        arg_reg :: Unique -> CmmExpr -> CmmReg+        arg_reg u expr = CmmLocal $ LocalReg u (cmmExprType (platform env) expr)++    bind_args :: Block CmmNode O O+    bind_args = blockConcat $ zipWith (\r e -> BMiddle $ CmmAssign r e) arg_regs args++    call = CmmUnsafeForeignCall ftgt formals (map CmmReg arg_regs)++-- | We save the contents of global registers in locals and allow the+-- register allocator to spill them to the stack around the call.+-- We cannot use the register table for this since we would interface+-- with {SAVE,RESTORE}_THREAD_STATE.+saveRestoreCallerRegs :: UniqSupply -> Platform+                      -> (Block CmmNode O O, Block CmmNode O O)+saveRestoreCallerRegs us platform =+    (save, restore)+  where+    regs_to_save :: [GlobalReg]+    regs_to_save = filter (callerSaves platform) (activeStgRegs platform)++    nodes :: [(CmmNode O O, CmmNode O O)]+    nodes =+        zipWith mk_reg regs_to_save (uniqsFromSupply us)+      where+        mk_reg :: GlobalReg -> Unique -> (CmmNode O O, CmmNode O O)+        mk_reg reg u =+            let ty = globalRegSpillType platform reg+                greg = CmmGlobal (GlobalRegUse reg ty)+                lreg = CmmLocal (LocalReg u ty)+                save = CmmAssign lreg (CmmReg greg)+                restore = CmmAssign greg (CmmReg lreg)+            in (save, restore)++    (save_nodes, restore_nodes) = unzip nodes+    save = blockFromList save_nodes+    restore = blockFromList restore_nodes++-- | Mirrors __tsan_memory_order+-- <https://github.com/llvm/llvm-project/blob/main/compiler-rt/include/sanitizer/tsan_interface_atomic.h#L34>+memoryOrderToTsanMemoryOrder :: Env -> MemoryOrdering -> CmmExpr+memoryOrderToTsanMemoryOrder env mord =+    mkIntExpr (platform env) n+  where+    n = case mord of+      MemOrderRelaxed -> 0+      MemOrderAcquire -> 2+      MemOrderRelease -> 3+      MemOrderSeqCst  -> 5++tsanTarget :: FastString     -- ^ function name+           -> [ForeignHint]  -- ^ formals+           -> [ForeignHint]  -- ^ arguments+           -> ForeignTarget+tsanTarget fn formals args =+    ForeignTarget (CmmLit (CmmLabel lbl)) conv+  where+    conv = ForeignConvention CCallConv args formals CmmMayReturn+    lbl = mkForeignLabel fn ForeignLabelInExternalPackage IsFunction++tsanStore :: Env+          -> CmmType -> CmmExpr+          -> Block CmmNode O O+tsanStore env ty addr+  | typeWidth ty < W128 = mkUnsafeCall env ftarget [] [addr]+  | otherwise           = emptyBlock+  where+    ftarget = tsanTarget fn [] [AddrHint]+    w = widthInBytes (typeWidth ty)+    fn = fsLit $ "__tsan_write" ++ show w++tsanLoad :: Env+         -> AlignmentSpec -> CmmType -> CmmExpr+         -> Block CmmNode O O+tsanLoad env align ty addr+  | typeWidth ty < W128  = mkUnsafeCall env ftarget [] [addr]+  | otherwise            = emptyBlock+  where+    ftarget = tsanTarget fn [] [AddrHint]+    w = widthInBytes (typeWidth ty)+    fn = case align of+           Unaligned+             | w > 1    -> fsLit $ "__tsan_unaligned_read" ++ show w+           _            -> fsLit $ "__tsan_read" ++ show w++tsanAtomicStore :: Env+                -> MemoryOrdering -> Width -> CmmExpr -> CmmExpr+                -> Block CmmNode O O+tsanAtomicStore env mord w val addr =+    mkUnsafeCall env ftarget [] [addr, val, mord']+  where+    mord' = memoryOrderToTsanMemoryOrder env mord+    ftarget = tsanTarget fn [] [AddrHint, NoHint, NoHint]+    fn = fsLit $ "__tsan_atomic" ++ show (widthInBits w) ++ "_store"++tsanAtomicLoad :: Env+               -> MemoryOrdering -> Width -> CmmExpr -> LocalReg+               -> Block CmmNode O O+tsanAtomicLoad env mord w addr dest =+    mkUnsafeCall env ftarget [dest] [addr, mord']+  where+    mord' = memoryOrderToTsanMemoryOrder env mord+    ftarget = tsanTarget fn [NoHint] [AddrHint, NoHint]+    fn = fsLit $ "__tsan_atomic" ++ show (widthInBits w) ++ "_load"++tsanAtomicExchange :: Env+                   -> MemoryOrdering -> Width -> CmmExpr -> CmmExpr -> LocalReg+                   -> Block CmmNode O O+tsanAtomicExchange env mord w val addr dest =+    mkUnsafeCall env ftarget [dest] [addr, val, mord']+  where+    mord' = memoryOrderToTsanMemoryOrder env mord+    ftarget = tsanTarget fn [NoHint] [AddrHint, NoHint, NoHint]+    fn = fsLit $ "__tsan_atomic" ++ show (widthInBits w) ++ "_exchange"++-- N.B. C11 CAS returns a boolean (to avoid the ABA problem) whereas Cmm's CAS+-- returns the expected value. We use define a shim in the RTS to provide+-- Cmm's semantics using the TSAN C11 primitive.+tsanAtomicCas :: Env+              -> MemoryOrdering  -- ^ success ordering+              -> MemoryOrdering  -- ^ failure ordering+              -> Width+              -> CmmExpr         -- ^ address+              -> CmmExpr         -- ^ expected value+              -> CmmExpr         -- ^ new value+              -> LocalReg        -- ^ result destination+              -> Block CmmNode O O+tsanAtomicCas env mord_success mord_failure w addr expected new dest =+    mkUnsafeCall env ftarget [dest] [addr, expected, new, mord_success', mord_failure']+  where+    mord_success' = memoryOrderToTsanMemoryOrder env mord_success+    mord_failure' = memoryOrderToTsanMemoryOrder env mord_failure+    ftarget = tsanTarget fn [NoHint] [AddrHint, NoHint, NoHint, NoHint, NoHint]+    fn = fsLit $ "ghc_tsan_atomic" ++ show (widthInBits w) ++ "_compare_exchange"++tsanAtomicRMW :: Env+              -> MemoryOrdering -> AtomicMachOp -> Width -> CmmExpr -> CmmExpr -> LocalReg+              -> Block CmmNode O O+tsanAtomicRMW env mord op w addr val dest =+    mkUnsafeCall env ftarget [dest] [addr, val, mord']+  where+    mord' = memoryOrderToTsanMemoryOrder env mord+    ftarget = tsanTarget fn [NoHint] [AddrHint, NoHint, NoHint]+    op' = case op of+           AMO_Add  -> "fetch_add"+           AMO_Sub  -> "fetch_sub"+           AMO_And  -> "fetch_and"+           AMO_Nand -> "fetch_nand"+           AMO_Or   -> "fetch_or"+           AMO_Xor  -> "fetch_xor"+    fn = fsLit $ "__tsan_atomic" ++ show (widthInBits w) ++ "_" ++ op'
GHC/Cmm/Type.hs view
@@ -3,7 +3,8 @@     , b8, b16, b32, b64, b128, b256, b512, f32, f64, bWord, bHalfWord, gcWord     , cInt     , cmmBits, cmmFloat-    , typeWidth, cmmEqType, cmmEqType_ignoring_ptrhood+    , typeWidth, setCmmTypeWidth+    , cmmEqType, cmmCompatType     , isFloatType, isGcPtrType, isBitsType     , isWordAny, isWord32, isWord64     , isFloat64, isFloat32@@ -56,12 +57,14 @@   deriving Show  data CmmCat                -- "Category" (not exported)-   = GcPtrCat              -- GC pointer-   | BitsCat               -- Non-pointer-   | FloatCat              -- Float-   | VecCat Length CmmCat  -- Vector+   = 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 )-        -- See Note [Signed vs unsigned] at the end  instance Outputable CmmType where   ppr (CmmType cat wid) = ppr cat <> ppr (widthInBits wid)@@ -86,26 +89,35 @@ 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+-- | 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 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+     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@@ -363,6 +375,14 @@   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")+  -------------------------------------------------------------------------
+ GHC/Cmm/UniqueRenamer.hs view
@@ -0,0 +1,280 @@+{-# LANGUAGE LambdaCase, RecordWildCards, MagicHash, UnboxedTuples, PatternSynonyms, ExplicitNamespaces #-}+module GHC.Cmm.UniqueRenamer+  ( detRenameCmmGroup+  , detRenameIPEMap+  , MonadGetUnique(..)++  -- Careful! Not for general use!+  , DetUniqFM, emptyDetUFM++  , module GHC.Types.Unique.DSM+  )+  where++import GHC.Prelude+import GHC.Utils.Monad.State.Strict+import Data.Tuple (swap)+import GHC.Word+import GHC.Cmm+import GHC.Cmm.CLabel+import GHC.Cmm.Dataflow.Block+import GHC.Cmm.Dataflow.Graph+import GHC.Cmm.Dataflow.Label+import GHC.Cmm.Switch+import GHC.Types.Unique+import GHC.Types.Unique.FM+import GHC.Types.Unique.DFM+import GHC.Utils.Outputable as Outputable+import GHC.Types.Id+import GHC.Types.Unique.DSM+import GHC.Types.Name hiding (varName)+import GHC.Types.Var+import GHC.Types.IPE++{-+Note [Renaming uniques deterministically]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+As mentioned by Note [Object determinism], a key step in producing+deterministic objects is to rename all existing uniques deterministically.++An important observation is that GHC already produces code in a deterministic+order, both declarations (say, A_closure always comes before B_closure) and the+instructions and data within.++We can leverage this /deterministic order/ to+rename all uniques deterministically, by traversing, specifically, Cmm code+fresh off of StgToCmm and assigning a new unique from a deterministic supply+(an incrementing counter) to every non-external unique in the order they are found.++Since the order is deterministic across runs, so will the renamed uniques.++This Cmm renaming pass is guarded by -fobject-determinism because it means the+compiler must do more work. However, performance profiling has shown the impact+to be small enough that we should consider enabling -fobject-determinism by+default instead eventually.+-}++-- | A mapping from non-deterministic uniques to deterministic uniques, to+-- rename local symbols with the end goal of producing deterministic object files.+-- See Note [Renaming uniques deterministically]+data DetUniqFM = DetUniqFM+  { mapping :: !(UniqFM Unique Unique)+  , supply  :: !Word64+  }++instance Outputable DetUniqFM where+  ppr DetUniqFM{mapping, supply} =+    ppr mapping $$+    text "supply:" Outputable.<> ppr supply++type DetRnM = State DetUniqFM++emptyDetUFM :: DetUniqFM+emptyDetUFM = DetUniqFM+  { mapping = emptyUFM+  -- NB: A lower initial value can get us label `Lsl` which is not parsed+  -- correctly in older versions of LLVM assembler (llvm-project#80571)+  -- So we use an `x` s.t. w64ToBase62 x > "R" > "L" > "r" > "l"+  , supply = 54+  }++renameDetUniq :: Unique -> DetRnM Unique+renameDetUniq uq = do+  m <- gets mapping+  case lookupUFM m uq of+    Nothing -> do+      new_w <- gets supply -- New deterministic unique in this `DetRnM`+      let --(_tag, _) = unpkUnique uq+          det_uniq = mkUnique 'Q' new_w+      modify (\DetUniqFM{mapping, supply} ->+        -- Update supply and mapping+        DetUniqFM+          { mapping = addToUFM mapping uq det_uniq+          , supply = supply + 1+          })+      return det_uniq+    Just det_uniq ->+      return det_uniq++-- The most important function here, which does the actual renaming.+detRenameCLabel :: CLabel -> DetRnM CLabel+detRenameCLabel = mapInternalNonDetUniques renameDetUniq++-- | We want to rename uniques in Ids, but ONLY internal ones.+detRenameId :: Id -> DetRnM Id+detRenameId i+  | isExternalName (varName i) = return i+  | otherwise = setIdUnique i <$> renameDetUniq (getUnique i)++-- | Similar to `detRenameId`, but for `Name`.+detRenameName :: Name -> DetRnM Name+detRenameName n+  | isExternalName n = return n+  | otherwise = setNameUnique n <$> renameDetUniq (getUnique n)++detRenameCmmGroup :: DetUniqFM -> DCmmGroup -> (DetUniqFM, CmmGroup)+detRenameCmmGroup dufm group = swap (runState (mapM detRenameCmmDecl group) dufm)+  where+    detRenameCmmDecl :: DCmmDecl -> DetRnM CmmDecl+    detRenameCmmDecl (CmmProc h lbl regs g)+      = do+        h' <- detRenameCmmTop h+        lbl' <- detRenameCLabel lbl+        regs' <- mapM detRenameGlobalRegUse regs+        g' <- detRenameCmmGraph g+        return (CmmProc h' lbl' regs' g')+    detRenameCmmDecl (CmmData sec d)+      = CmmData <$> detRenameSection sec <*> detRenameCmmStatics d++    detRenameCmmTop :: DCmmTopInfo -> DetRnM CmmTopInfo+    detRenameCmmTop (TopInfo (DWrap i) b)+      = TopInfo . mapFromList <$> mapM (detRenamePair detRenameLabel detRenameCmmInfoTable) i <*> pure b++    detRenameCmmGraph :: DCmmGraph -> DetRnM CmmGraph+    detRenameCmmGraph (CmmGraph entry bs)+      = CmmGraph <$> detRenameLabel entry <*> detRenameGraph bs++    detRenameGraph = \case+      GNil  -> pure GNil+      GUnit block -> GUnit <$> detRenameBlock block+      GMany m1 b m2 -> GMany <$> detRenameMaybeBlock m1 <*> detRenameBody b <*> detRenameMaybeBlock m2++    detRenameBody (DWrap b)+      = mapFromList <$> mapM (detRenamePair detRenameLabel detRenameBlock) b++    detRenameCmmStatics :: CmmStatics -> DetRnM CmmStatics+    detRenameCmmStatics+      (CmmStatics clbl info ccs lits1 lits2)+        = CmmStatics <$> detRenameCLabel clbl <*> detRenameCmmInfoTable info <*> pure ccs <*> mapM detRenameCmmLit lits1 <*> mapM detRenameCmmLit lits2+    detRenameCmmStatics+      (CmmStaticsRaw lbl sts)+        = CmmStaticsRaw <$> detRenameCLabel lbl <*> mapM detRenameCmmStatic sts++    detRenameCmmInfoTable :: CmmInfoTable -> DetRnM CmmInfoTable+    detRenameCmmInfoTable+      CmmInfoTable{cit_lbl, cit_rep, cit_prof, cit_srt, cit_clo}+        = CmmInfoTable <$> detRenameCLabel cit_lbl <*> pure cit_rep <*> pure cit_prof <*> detRenameMaybe detRenameCLabel cit_srt <*>+           (case cit_clo of+              Nothing -> pure Nothing+              Just (an_id, ccs) -> Just . (,ccs) <$> detRenameId an_id)++    detRenameCmmStatic :: CmmStatic -> DetRnM CmmStatic+    detRenameCmmStatic = \case+      CmmStaticLit l -> CmmStaticLit <$> detRenameCmmLit l+      CmmUninitialised x -> pure $ CmmUninitialised x+      CmmString x -> pure $ CmmString x+      CmmFileEmbed f i -> pure $ CmmFileEmbed f i++    detRenameCmmLit :: CmmLit -> DetRnM CmmLit+    detRenameCmmLit = \case+      CmmInt i w -> pure $ CmmInt i w+      CmmFloat r w -> pure $ CmmFloat r w+      CmmVec lits -> CmmVec <$> mapM detRenameCmmLit lits+      CmmLabel lbl -> CmmLabel <$> detRenameCLabel lbl+      CmmLabelOff lbl i -> CmmLabelOff <$> detRenameCLabel lbl <*> pure i+      CmmLabelDiffOff lbl1 lbl2 i w ->+        CmmLabelDiffOff <$> detRenameCLabel lbl1 <*> detRenameCLabel lbl2 <*> pure i <*> pure w+      CmmBlock bid -> CmmBlock <$> detRenameLabel bid+      CmmHighStackMark -> pure CmmHighStackMark++    detRenameMaybeBlock :: MaybeO n (Block CmmNode a b) -> DetRnM (MaybeO n (Block CmmNode a b))+    detRenameMaybeBlock (JustO x) = JustO <$> detRenameBlock x+    detRenameMaybeBlock NothingO = pure NothingO++    detRenameBlock :: Block CmmNode n m -> DetRnM (Block CmmNode n m)+    detRenameBlock = \case+      BlockCO n bn -> BlockCO <$> detRenameCmmNode n <*> detRenameBlock bn+      BlockCC n1 bn n2 -> BlockCC <$> detRenameCmmNode n1 <*> detRenameBlock bn <*> detRenameCmmNode n2+      BlockOC bn n -> BlockOC <$> detRenameBlock bn <*> detRenameCmmNode n+      BNil    -> pure BNil+      BMiddle n -> BMiddle <$> detRenameCmmNode n+      BCat    b1 b2 -> BCat <$> detRenameBlock b1 <*> detRenameBlock b2+      BSnoc   bn n -> BSnoc <$> detRenameBlock bn <*> detRenameCmmNode n+      BCons   n bn -> BCons <$> detRenameCmmNode n <*> detRenameBlock bn++    detRenameCmmNode :: CmmNode n m -> DetRnM (CmmNode n m)+    detRenameCmmNode = \case+      CmmEntry l t -> CmmEntry <$> detRenameLabel l <*> detRenameCmmTick t+      CmmComment fs -> pure $ CmmComment fs+      CmmTick tickish -> pure $ CmmTick tickish+      CmmUnwind xs -> CmmUnwind <$> mapM (detRenamePair detRenameGlobalReg (detRenameMaybe detRenameCmmExpr)) xs+      CmmAssign reg e -> CmmAssign <$> detRenameCmmReg reg <*> detRenameCmmExpr e+      CmmStore e1 e2 align -> CmmStore <$> detRenameCmmExpr e1 <*> detRenameCmmExpr e2 <*> pure align+      CmmUnsafeForeignCall ftgt cmmformal cmmactual ->+        CmmUnsafeForeignCall <$> detRenameForeignTarget ftgt <*> mapM detRenameLocalReg cmmformal <*> mapM detRenameCmmExpr cmmactual+      CmmBranch l -> CmmBranch <$> detRenameLabel l+      CmmCondBranch pred t f likely ->+        CmmCondBranch <$> detRenameCmmExpr pred <*> detRenameLabel t <*> detRenameLabel f <*> pure likely+      CmmSwitch e sts -> CmmSwitch <$> detRenameCmmExpr e <*> mapSwitchTargetsA detRenameLabel sts+      CmmCall tgt cont regs args retargs retoff ->+        CmmCall <$> detRenameCmmExpr tgt <*> detRenameMaybe detRenameLabel cont <*> mapM detRenameGlobalRegUse regs+                <*> pure args <*> pure retargs <*> pure retoff+      CmmForeignCall tgt res args succ retargs retoff intrbl ->+        CmmForeignCall <$> detRenameForeignTarget tgt <*> mapM detRenameLocalReg res <*> mapM detRenameCmmExpr args+                       <*> detRenameLabel succ <*> pure retargs <*> pure retoff <*> pure intrbl++    detRenameCmmExpr :: CmmExpr -> DetRnM CmmExpr+    detRenameCmmExpr = \case+      CmmLit l -> CmmLit <$> detRenameCmmLit l+      CmmLoad e t a -> CmmLoad <$> detRenameCmmExpr e <*> pure t <*> pure a+      CmmReg r -> CmmReg <$> detRenameCmmReg r+      CmmMachOp mop es -> CmmMachOp mop <$> mapM detRenameCmmExpr es+      CmmStackSlot a i -> CmmStackSlot <$> detRenameArea a <*> pure i+      CmmRegOff r i -> CmmRegOff <$> detRenameCmmReg r <*> pure i++    detRenameForeignTarget :: ForeignTarget -> DetRnM ForeignTarget+    detRenameForeignTarget = \case+        ForeignTarget e fc -> ForeignTarget <$> detRenameCmmExpr e <*> pure fc+        PrimTarget cmop -> pure $ PrimTarget cmop++    detRenameArea :: Area -> DetRnM Area+    detRenameArea Old = pure Old+    detRenameArea (Young l) = Young <$> detRenameLabel l++    detRenameLabel :: Label -> DetRnM Label+    detRenameLabel lbl+      = mkHooplLabel . getKey <$> renameDetUniq (getUnique lbl)++    detRenameSection :: Section -> DetRnM Section+    detRenameSection (Section ty lbl)+      = Section ty <$> detRenameCLabel lbl++    detRenameCmmReg :: CmmReg -> DetRnM CmmReg+    detRenameCmmReg = \case+      CmmLocal l -> CmmLocal <$> detRenameLocalReg l+      CmmGlobal x -> pure $ CmmGlobal x++    detRenameLocalReg :: LocalReg -> DetRnM LocalReg+    detRenameLocalReg (LocalReg uq t)+      = LocalReg <$> renameDetUniq uq <*> pure t++    -- Global registers don't need to be renamed.+    detRenameGlobalReg :: GlobalReg -> DetRnM GlobalReg+    detRenameGlobalReg = pure+    detRenameGlobalRegUse :: GlobalRegUse -> DetRnM GlobalRegUse+    detRenameGlobalRegUse = pure++    -- todo: We may have to change this to get deterministic objects with ticks.+    detRenameCmmTick :: CmmTickScope -> DetRnM CmmTickScope+    detRenameCmmTick = pure++    detRenameMaybe _ Nothing = pure Nothing+    detRenameMaybe f (Just x) = Just <$> f x++    detRenamePair f g (a, b) = (,) <$> f a <*> g b++detRenameIPEMap :: DetUniqFM -> InfoTableProvMap -> (DetUniqFM, InfoTableProvMap)+detRenameIPEMap dufm InfoTableProvMap{ provDC, provClosure, provInfoTables } =+    (dufm2, InfoTableProvMap { provDC, provClosure = cm, provInfoTables })+  where+    (cm, dufm2) = runState (detRenameClosureMap provClosure) dufm++    detRenameClosureMap :: ClosureMap -> DetRnM ClosureMap+    detRenameClosureMap m =+      -- `eltsUDFM` preserves the deterministic order, but it doesn't matter+      -- since we will rename all uniques deterministically, thus the+      -- reconstructed map will necessarily be deterministic too.+      listToUDFM <$> mapM (\(n,r) -> do+        n' <- detRenameName n+        return (n', (n', r))+        ) (eltsUDFM m)
GHC/Cmm/Utils.hs view
@@ -1,9 +1,6 @@-{-# LANGUAGE GADTs, RankNTypes #-}-{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}- ----------------------------------------------------------------------------- -- -- Cmm utilities.@@ -42,8 +39,6 @@          cmmMkAssign, -        isTrivialCmmExpr, hasNoGlobalRegs, isLit, isComparisonExpr,-         baseExpr, spExpr, hpExpr, spLimExpr, hpLimExpr,         currentTSOExpr, currentNurseryExpr, cccsExpr, @@ -52,7 +47,7 @@         cmmConstrTag1, mAX_PTR_TAG, tAG_MASK,          -- Overlap and usage-        regsOverlap, regUsedIn,+        regsOverlap, globalRegsOverlap, regUsedIn, globalRegUsedIn,          -- Liveness and bitmaps         mkLiveness,@@ -61,9 +56,9 @@         modifyGraph,          ofBlockMap, toBlockMap,-        ofBlockList, toBlockList, bodyToBlockList,+        ofBlockList, toBlockList,         toBlockListEntryFirst, toBlockListEntryFirstFalseFallthrough,-        foldlGraphBlocks, mapGraphNodes, revPostorder, mapGraphNodes1,+        foldlGraphBlocks, mapGraphNodes, mapGraphNodes1,          -- * Ticks         blockTicks@@ -72,7 +67,7 @@ import GHC.Prelude  import GHC.Core.TyCon     ( PrimRep(..), PrimElemRep(..) )-import GHC.Types.RepType  ( UnaryType, SlotTy (..), typePrimRep1 )+import GHC.Types.RepType  ( NvUnaryType, SlotTy (..), typePrimRepU )  import GHC.Platform import GHC.Runtime.Heap.Layout@@ -86,10 +81,10 @@  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-import GHC.Cmm.Dataflow.Collections  --------------------------------------------------- --@@ -99,9 +94,7 @@  primRepCmmType :: Platform -> PrimRep -> CmmType primRepCmmType platform = \case-   VoidRep          -> panic "primRepCmmType:VoidRep"-   LiftedRep        -> gcWord platform-   UnliftedRep      -> gcWord platform+   BoxedRep _       -> gcWord platform    IntRep           -> bWord platform    WordRep          -> bWord platform    Int8Rep          -> b8@@ -115,7 +108,7 @@    AddrRep          -> bWord platform    FloatRep         -> f32    DoubleRep        -> f64-   (VecRep len rep) -> vec len (primElemRepCmmType rep)+   VecRep len rep   -> vec len (primElemRepCmmType rep)  slotCmmType :: Platform -> SlotTy -> CmmType slotCmmType platform = \case@@ -125,6 +118,7 @@    Word64Slot      -> b64    FloatSlot       -> f32    DoubleSlot      -> f64+   VecSlot l e     -> vec l (primElemRepCmmType e)  primElemRepCmmType :: PrimElemRep -> CmmType primElemRepCmmType Int8ElemRep   = b8@@ -138,13 +132,11 @@ primElemRepCmmType FloatElemRep  = f32 primElemRepCmmType DoubleElemRep = f64 -typeCmmType :: Platform -> UnaryType -> CmmType-typeCmmType platform ty = primRepCmmType platform (typePrimRep1 ty)+typeCmmType :: Platform -> NvUnaryType -> CmmType+typeCmmType platform ty = primRepCmmType platform (typePrimRepU ty)  primRepForeignHint :: PrimRep -> ForeignHint-primRepForeignHint VoidRep      = panic "primRepForeignHint:VoidRep"-primRepForeignHint LiftedRep    = AddrHint-primRepForeignHint UnliftedRep  = AddrHint+primRepForeignHint (BoxedRep _) = AddrHint primRepForeignHint IntRep       = SignedHint primRepForeignHint Int8Rep      = SignedHint primRepForeignHint Int16Rep     = SignedHint@@ -160,8 +152,8 @@ primRepForeignHint DoubleRep    = NoHint primRepForeignHint (VecRep {})  = NoHint -typeForeignHint :: UnaryType -> ForeignHint-typeForeignHint = primRepForeignHint . typePrimRep1+typeForeignHint :: NvUnaryType -> ForeignHint+typeForeignHint = primRepForeignHint . typePrimRepU  --------------------------------------------------- --@@ -198,9 +190,9 @@  -- | We make a top-level decl for the embedded binary file, and return a label pointing to it mkFileEmbedLit-  :: CLabel -> FilePath -> (CmmLit, GenCmmDecl (GenCmmStatics raw) info stmt)-mkFileEmbedLit lbl path-  = (CmmLabel lbl, CmmData (Section ReadOnlyData lbl) (CmmStaticsRaw lbl [CmmFileEmbed path]))+  :: 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@@ -400,36 +392,6 @@  --------------------------------------------------- -----      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-------------------------------------------------------- --      Tagging -- ---------------------------------------------------@@ -468,13 +430,19 @@ -- 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 g) (CmmGlobal g')-  | Just real  <- globalRegMaybe platform g,-    Just real' <- globalRegMaybe platform g',-    real == real'-    = True+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.@@ -492,6 +460,27 @@   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@@ -525,25 +514,17 @@ 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} -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+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-    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@@ -554,13 +535,10 @@ -- of successors returned for CmmCondBranch by the NonLocal instance for CmmNode -- defined in "GHC.Cmm.Node". -GBM toBlockListEntryFirstFalseFallthrough :: CmmGraph -> [CmmBlock]-toBlockListEntryFirstFalseFallthrough g-  | mapNull m  = []-  | otherwise  = dfs setEmpty [entry_block]+toBlockListEntryFirstFalseFallthrough g = dfs setEmpty $ toList $ mapLookup entry_id m   where     m = toBlockMap g     entry_id = g_entry g-    Just entry_block = mapLookup entry_id m      dfs :: LabelSet -> [CmmBlock] -> [CmmBlock]     dfs _ [] = []@@ -578,9 +556,6 @@                                     , 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)@@ -596,10 +571,6 @@ foldlGraphBlocks :: (a -> CmmBlock -> a) -> a -> CmmGraph -> a foldlGraphBlocks k z g = mapFoldl k z $ toBlockMap g -revPostorder :: CmmGraph -> [CmmBlock]-revPostorder g = {-# SCC "revPostorder" #-}-    revPostorderFrom (toBlockMap g) (g_entry g)- ------------------------------------------------- -- Tick utilities @@ -615,12 +586,12 @@ -- Access to common global registers  baseExpr, spExpr, hpExpr, currentTSOExpr, currentNurseryExpr,-  spLimExpr, hpLimExpr, cccsExpr :: CmmExpr-baseExpr = CmmReg baseReg-spExpr = CmmReg spReg-spLimExpr = CmmReg spLimReg-hpExpr = CmmReg hpReg-hpLimExpr = CmmReg hpLimReg-currentTSOExpr = CmmReg currentTSOReg-currentNurseryExpr = CmmReg currentNurseryReg-cccsExpr = CmmReg cccsReg+  spLimExpr, hpLimExpr, cccsExpr :: Platform -> CmmExpr+baseExpr           p = CmmReg $ baseReg           p+spExpr             p = CmmReg $ spReg             p+spLimExpr          p = CmmReg $ spLimReg          p+hpExpr             p = CmmReg $ hpReg             p+hpLimExpr          p = CmmReg $ hpLimReg          p+currentTSOExpr     p = CmmReg $ currentTSOReg     p+currentNurseryExpr p = CmmReg $ currentNurseryReg p+cccsExpr           p = CmmReg $ cccsReg           p
GHC/CmmToAsm.hs view
@@ -5,19 +5,8 @@ -- -- ----------------------------------------------------------------------------- -{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE UnboxedTuples #-}--{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}---- | Native code generator+-- | Note [Native code generator]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- -- The native-code generator has machine-independent and -- machine-dependent modules.@@ -25,51 +14,45 @@ -- 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.+-- '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 machine-independent register allocator ('regAlloc') to rejoin+-- a (mostly) machine-independent register allocator to rejoin -- reality.  Obviously, 'regAlloc' has machine-specific helper--- functions (see about "RegAllocInfo" below).+-- 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 break down as follows:+-- The machine-dependent bits are generally contained under+--  GHC/CmmToAsm/<Arch>/* and generally breaks down as follows: -----   * ["MachRegs"]  Everything about the target platform's machine+--   * "Regs": 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+--   * "Instr":  Includes the 'Instr' datatype plus a miscellany of other things --     (e.g., 'targetDoubleSize', 'smStablePtrTable', ...) -----   * ["MachCodeGen"]  is where 'Cmm' stuff turns into+--   * "CodeGen":  is where 'Cmm' stuff turns into --     machine instructions. -----   * ["PprMach"] 'pprInstr' turns an 'Instr' into text (well, really+--   * "Ppr": '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.+-- The register allocators lives under GHC.CmmToAsm.Reg.*, there is both a Linear and a Graph+-- based register allocator. Both of which have their own notes describing them. They+-- are mostly platform independent but there are some platform specific files+-- encoding architecture details under Reg/<Allocator>/<Arch.hs> -----    * ["RegisterAlloc"] The (machine-independent) register allocator. -- -} -- module GHC.CmmToAsm    ( nativeCodeGen -   -- * Test-only exports: see trac #12744+   -- * Test-only exports: see #12744    -- used by testGraphNoSpills, which needs to access    -- the register allocator intermediate data structures    -- cmmNativeGen emits@@ -78,11 +61,14 @@    ) where -import GHC.Prelude+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@@ -111,22 +97,17 @@ import GHC.Cmm.BlockId import GHC.StgToCmm.CgUtils ( fixStgRegisters ) import GHC.Cmm-import GHC.Cmm.Utils-import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Label-import GHC.Cmm.Dataflow.Block-import GHC.Cmm.Opt           ( cmmMachOpFold )-import GHC.Cmm.Ppr+import GHC.Cmm.GenericOpt import GHC.Cmm.CLabel  import GHC.Types.Unique.FM-import GHC.Types.Unique.Supply-import GHC.Driver.Session+import GHC.Types.Unique.DSM+import GHC.Driver.DynFlags import GHC.Driver.Ppr import GHC.Utils.Misc import GHC.Utils.Logger -import qualified GHC.Utils.Ppr as Pretty import GHC.Utils.BufHandle import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic@@ -137,24 +118,28 @@ import GHC.Data.FastString import GHC.Types.Unique.Set import GHC.Unit-import GHC.Data.Stream (Stream)+import GHC.StgToCmm.CgUtils (CgStream)+import GHC.Data.Stream (liftIO) import qualified GHC.Data.Stream as Stream+import GHC.Settings -import Data.List (sortBy, groupBy)+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 -> NCGConfig -> ModLocation -> Handle -> UniqSupply-              -> Stream IO RawCmmGroup a-              -> IO a-nativeCodeGen logger config modLoc h us cmms+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 -> IO a-       nCG' ncgImpl = nativeCodeGen' logger config modLoc ncgImpl h us cmms+            => 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)@@ -166,9 +151,11 @@       ArchAlpha     -> panic "nativeCodeGen: No NCG for Alpha"       ArchMipseb    -> panic "nativeCodeGen: No NCG for mipseb"       ArchMipsel    -> panic "nativeCodeGen: No NCG for mipsel"-      ArchRISCV64   -> panic "nativeCodeGen: No NCG for RISCV64"+      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.@@ -219,19 +206,17 @@                -> ModLocation                -> NcgImpl statics instr jumpDest                -> Handle-               -> UniqSupply-               -> Stream IO RawCmmGroup a-               -> IO a-nativeCodeGen' logger config modLoc ncgImpl h us cmms+               -> 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 <- newBufHandle h+        bufh <- liftIO $ newBufHandle h         let ngs0 = NGS [] [] [] [] [] [] emptyUFM mapEmpty-        (ngs, us', a) <- cmmNativeGenStream logger config modLoc ncgImpl bufh us-                                         cmms ngs0-        _ <- finishNativeGen logger config modLoc bufh us' ngs+        (ngs, a) <- cmmNativeGenStream logger config modLoc ncgImpl bufh cmms ngs0+        _ <- finishNativeGen logger config modLoc bufh ngs         return a  finishNativeGen :: Instruction instr@@ -239,22 +224,24 @@                 -> NCGConfig                 -> ModLocation                 -> BufHandle-                -> UniqSupply                 -> NativeGenAcc statics instr-                -> IO UniqSupply-finishNativeGen logger config modLoc bufh@(BufHandle _ _ h) us ngs+                -> UniqDSMT IO ()+finishNativeGen logger config modLoc bufh ngs  = withTimingSilent logger (text "NCG") (`seq` ()) $ do-        -- Write debug data and finish-        us' <- if not (ncgDwarfEnabled config)-                  then return us-                  else do-                     (dwarf, us') <- dwarfGen config modLoc us (ngs_debug ngs)-                     emitNativeCode logger config bufh dwarf-                     return us'-        bFlush bufh+      -- 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@@ -265,7 +252,7 @@            dump_stats (Color.pprStats stats graphGlobal) -          let platform = ncgPlatform config+           putDumpFileMaybe logger                   Opt_D_dump_asm_conflicts "Register conflict graph"                   FormatText@@ -280,13 +267,14 @@         -- dump global NCG stats for linear allocator         let linearStats = concat (ngs_linearStats ngs)         unless (null linearStats) $-          dump_stats (Linear.pprStats (concat (ngs_natives ngs)) linearStats)+          dump_stats (Linear.pprStats platform (concat (ngs_natives ngs)) linearStats)          -- write out the imports         let ctx = ncgAsmContext config-        printSDocLn ctx Pretty.LeftMode h-                $ makeImportsDoc config (concat (ngs_imports ngs))-        return us'+        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"@@ -298,20 +286,18 @@               -> ModLocation               -> NcgImpl statics instr jumpDest               -> BufHandle-              -> UniqSupply-              -> Stream.Stream IO RawCmmGroup a+              -> CgStream RawCmmGroup a               -> NativeGenAcc statics instr-              -> IO (NativeGenAcc statics instr, UniqSupply, a)+              -> UniqDSMT IO (NativeGenAcc statics instr, a) -cmmNativeGenStream logger config modLoc ncgImpl h us cmm_stream ngs- = loop us (Stream.runStream cmm_stream) ngs+cmmNativeGenStream logger config modLoc ncgImpl h cmm_stream ngs+ = loop (Stream.runStream cmm_stream) ngs   where     ncglabel = text "NCG"-    loop :: UniqSupply-              -> Stream.StreamS IO RawCmmGroup a-              -> NativeGenAcc statics instr-              -> IO (NativeGenAcc statics instr, UniqSupply, a)-    loop us s ngs =+    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@@ -319,35 +305,33 @@                       , ngs_colorStats = reverse $ ngs_colorStats ngs                       , ngs_linearStats = reverse $ ngs_linearStats ngs                       },-                  us,                   a)-        Stream.Effect m -> m >>= \cmm_stream' -> loop us cmm_stream' ngs+        Stream.Effect m -> m >>= \cmm_stream' -> loop cmm_stream' ngs         Stream.Yield cmms cmm_stream' -> do-          (us', ngs'') <--            withTimingSilent logger-                ncglabel (\(a, b) -> a `seq` b `seq` ()) $ 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',us') <- cmmNativeGens logger config modLoc ncgImpl h-                                          dbgMap us cmms ngs 0+              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) $+              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 (us', ngs'')+              return ngs'' -          loop us' cmm_stream' ngs''+          loop cmm_stream' ngs''   -- | Do native code generation on all these cmms.@@ -356,30 +340,29 @@                  (OutputableP Platform statics, Outputable jumpDest, Instruction instr)               => Logger               -> NCGConfig-              -> ModLocation               -> NcgImpl statics instr jumpDest               -> BufHandle               -> LabelMap DebugBlock-              -> UniqSupply               -> [RawCmmDecl]               -> NativeGenAcc statics instr               -> Int-              -> IO (NativeGenAcc statics instr, UniqSupply)+              -> DUniqSupply+              -> IO (NativeGenAcc statics instr, DUniqSupply) -cmmNativeGens logger config modLoc ncgImpl h dbgMap = go+cmmNativeGens logger config ncgImpl h dbgMap = go   where-    go :: UniqSupply -> [RawCmmDecl]-       -> NativeGenAcc statics instr -> Int-       -> IO (NativeGenAcc statics instr, UniqSupply)+    go :: [RawCmmDecl]+       -> NativeGenAcc statics instr -> Int -> DUniqSupply+       -> IO (NativeGenAcc statics instr, DUniqSupply) -    go us [] ngs !_ =+    go [] ngs !_ !us =         return (ngs, us) -    go us (cmm : cmms) ngs count = do+    go (cmm : cmms) ngs count us = do         let fileIds = ngs_dwarfFiles ngs-        (us', fileIds', native, imports, colorStats, linearStats, unwinds)+        (us', fileIds', native, imports, colorStats, linearStats, unwinds, mcfg)           <- {-# SCC "cmmNativeGen" #-}-             cmmNativeGen logger modLoc ncgImpl us fileIds dbgMap+             cmmNativeGen logger ncgImpl us fileIds dbgMap                           cmm count          -- Generate .file directives for every new file that has been@@ -388,19 +371,30 @@         let newFileIds = sortBy (comparing snd) $                          nonDetEltsUFM $ fileIds' `minusUFM` fileIds             -- See Note [Unique Determinism and code generation]-            pprDecl (f,n) = text "\t.file " <> ppr n <+>-                            pprFilePathString (unpackFS f)+            pprDecl (f,n) = line $ text "\t.file " <> int n <+>+                                   pprFilePathString (unpackFS f) -        emitNativeCode logger config h $ vcat $-          map pprDecl newFileIds ++-          map (pprNatCmmDecl ncgImpl) native+        -- 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 (pdoc platform) imports) ()+        {-# SCC "seqString" #-} evaluate $ seqList (showSDocUnsafe $ vcat $ map (pprAsmLabel platform) imports) ()          let !labels' = if ncgDwarfEnabled config-                       then cmmDebugLabels isMetaInstr native else []+                       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 [] @@ -413,14 +407,14 @@                       , ngs_dwarfFiles  = fileIds'                       , ngs_unwinds     = ngs_unwinds ngs `mapUnion` unwinds                       }-        go us' cmms ngs' (count + 1)+        go cmms ngs' (count + 1) us'  -emitNativeCode :: Logger -> NCGConfig -> BufHandle -> SDoc -> IO ()-emitNativeCode logger config h sdoc = do-+-- 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" #-} bufLeftRenderSDoc ctx h sdoc+        {-# SCC "pprNativeCode" #-} bPutHDoc h ctx hdoc          -- dump native code         putDumpFileMaybe logger@@ -433,30 +427,30 @@ cmmNativeGen     :: forall statics instr jumpDest. (Instruction instr, OutputableP Platform statics, Outputable jumpDest)     => Logger-    -> ModLocation     -> NcgImpl statics instr jumpDest-        -> UniqSupply+        -> DUniqSupply         -> DwarfFiles         -> LabelMap DebugBlock         -> RawCmmDecl                                   -- ^ the cmm to generate code for         -> Int                                          -- ^ sequence number of this top thing-        -> IO   ( UniqSupply+        -> 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 modLoc ncgImpl us fileIds dbgMap cmm count+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 _ _) -> pdoc platform entry_label+                (CmmProc _ entry_label _ _) -> pprAsmLabel platform entry_label                 _                           -> text "DataChunk"          -- rewrite assignments to global regs@@ -479,13 +473,13 @@         -- generate native code from cmm         let ((native, lastMinuteImports, fileIds', nativeCfgWeights), usGen) =                 {-# SCC "genMachCode" #-}-                initUs us $ genMachCode config modLoc+                runUniqueDSM us $ genMachCode config                                         (cmmTopCodeGen ncgImpl)                                         fileIds dbgMap opt_cmm cmmCfg          putDumpFileMaybe logger                 Opt_D_dump_asm_native "Native code" FormatASM-                (vcat $ map (pprNatCmmDecl ncgImpl) native)+                (vcat $ map (pprNatCmmDeclS ncgImpl) native)          maybeDumpCfg logger (Just nativeCfgWeights) "CFG Weights - Native" proc_name @@ -497,7 +491,7 @@                                 else Nothing         let (withLiveness, usLive) =                 {-# SCC "regLiveness" #-}-                initUs usGen+                runUniqueDSM usGen                         $ mapM (cmmTopLiveness livenessCfg platform) native          putDumpFileMaybe logger@@ -510,7 +504,7 @@          if ( ncgRegsGraph config || ncgRegsIterative config )           then do                 -- the regs usable for allocation-                let (alloc_regs :: UniqFM RegClass (UniqSet RealReg))+                let alloc_regs :: UniqFM RegClass (UniqSet RealReg)                         = foldr (\r -> plusUFM_C unionUniqSets                                         $ unitUFM (targetClassOfRealReg platform r) (unitUniqSet r))                                 emptyUFM@@ -519,7 +513,7 @@                 -- do the graph coloring register allocation                 let ((alloced, maybe_more_stack, regAllocStats), usAlloc)                         = {-# SCC "RegAlloc-color" #-}-                          initUs usLive+                          runUniqueDSM usLive                           $ Color.regAlloc                                 config                                 alloc_regs@@ -529,20 +523,20 @@                                 livenessCfg                  let ((alloced', stack_updt_blks), usAlloc')-                        = initUs 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 )+                        = 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 (pprNatCmmDecl ncgImpl) alloced)+                        (vcat $ map (pprNatCmmDeclS ncgImpl) alloced)                  putDumpFileMaybe logger                         Opt_D_dump_asm_regalloc_stages "Build/spill stages"@@ -579,14 +573,14 @@                  let ((alloced, regAllocStats, stack_updt_blks), usAlloc)                         = {-# SCC "RegAlloc-linear" #-}-                          initUs usLive+                          runUniqueDSM usLive                           $ liftM unzip3                           $ mapM reg_alloc withLiveness                  putDumpFileMaybe logger                         Opt_D_dump_asm_regalloc "Registers allocated"                         FormatCMM-                        (vcat $ map (pprNatCmmDecl ncgImpl) alloced)+                        (vcat $ map (pprNatCmmDeclS ncgImpl) alloced)                  let mPprStats =                         if logHasDumpFlag logger Opt_D_dump_asm_stats@@ -648,14 +642,15 @@                                 text "cfg not in lockstep") ()          ---- sequence blocks-        let sequenced :: [NatCmmDecl statics instr]-            sequenced =-                checkLayout shorted $-                {-# SCC "sequenceBlocks" #-}-                map (BlockLayout.sequenceTop-                        ncgImpl optimizedCFG)-                    shorted+        -- 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" #-}@@ -677,13 +672,15 @@                 addUnwind acc proc =                     acc `mapUnion` computeUnwinding config ncgImpl proc -        return  ( usAlloc+        return  ( us_seq                 , fileIds'                 , branchOpt                 , lastMinuteImports ++ imports                 , ppr_raStatsColor                 , ppr_raStatsLinear-                , unwinds )+                , unwinds+                , optimizedCFG+                )  maybeDumpCfg :: Logger -> Maybe CFG -> String -> SDoc -> IO () maybeDumpCfg _logger Nothing _ _ = return ()@@ -697,10 +694,10 @@  -- | Make sure all blocks we want the layout algorithm to place have been placed. checkLayout :: [NatCmmDecl statics instr] -> [NatCmmDecl statics instr]-            -> [NatCmmDecl statics instr]+            -> Bool checkLayout procsUnsequenced procsSequenced =-        assertPpr (setNull diff) (ppr "Block sequencing dropped blocks:" <> ppr diff)-        procsSequenced+        assertPpr (setNull diff) (text "Block sequencing dropped blocks:" <> ppr diff)+        True   where         blocks1 = foldl' (setUnion) setEmpty $                         map getBlockIds procsUnsequenced :: LabelSet@@ -738,7 +735,7 @@  -- | Build a doc for all the imports. ---makeImportsDoc :: NCGConfig -> [CLabel] -> SDoc+makeImportsDoc :: NCGConfig -> [CLabel] -> HDoc makeImportsDoc config imports  = dyld_stubs imports             $$@@ -746,7 +743,7 @@             -- 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"+             then line $ text ".subsections_via_symbols"              else Outputable.empty)             $$                 -- On recent GNU ELF systems one can mark an object file@@ -756,14 +753,14 @@                 -- security. GHC generated code does not need an executable                 -- stack so add the note in:             (if platformHasGnuNonexecStack platform-             then text ".section .note.GNU-stack,\"\"," <> sectionType platform "progbits"+             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 text ".ident" <+> doubleQuotes compilerIdent+                   in line $ text ".ident" <+> doubleQuotes compilerIdent              else Outputable.empty)   where@@ -771,26 +768,23 @@          -- 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-}+        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 :) $-                        map ( pprImportedSymbol config . fst . head) $-                        groupBy (\(_,a) (_,b) -> a == b) $-                        sortBy (\(_,a) (_,b) -> compare a b) $+                        fmap (pprImportedSymbol config . fst . head) $+                        groupAllWith snd $                         map doPpr $                         imps                 | otherwise                 = Outputable.empty -        doPpr lbl = (lbl, renderWithContext+        doPpr lbl = (lbl, showSDocOneLine                               (ncgAsmContext config)-                              (pprCLabel platform AsmStyle lbl))+                              (pprAsmLabel platform lbl))  -- ----------------------------------------------------------------------------- -- Generate jump tables@@ -803,11 +797,24 @@ 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)+          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@@ -818,6 +825,8 @@  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@@ -903,222 +912,29 @@  genMachCode         :: NCGConfig-        -> ModLocation         -> (RawCmmDecl -> NatM [NatCmmDecl statics instr])         -> DwarfFiles         -> LabelMap DebugBlock         -> RawCmmDecl         -> CFG-        -> UniqSM+        -> UniqDSM                 ( [NatCmmDecl statics instr]                 , [CLabel]                 , DwarfFiles                 , CFG                 ) -genMachCode config modLoc cmmTopCodeGen fileIds dbgMap cmm_top cmm_cfg-  = do  { initial_us <- getUniqueSupplyM-        ; let initial_st           = mkNatM_State initial_us 0 config-                                                  modLoc 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 return (new_tops, final_imports-                      , natm_fileid final_st, final_cfg)-          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 :: 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)--instance Applicative CmmOptM where-    pure x = CmmOptM $ \_ imports -> OptMResult x imports-    (<*>) = ap--instance Monad CmmOptM where-  (CmmOptM f) >>= g =-    CmmOptM $ \config imports0 ->-                case f config imports0 of-                  OptMResult x imports1 ->-                    case g x of-                      CmmOptM g' -> g' config imports1--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 EagerBlackholeInfo)-          | arch == ArchPPC && not (ncgPIC config)-          -> cmmExprNative referenceKind $-             CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId (fsLit "__stg_EAGER_BLACKHOLE_info")))-        CmmReg (CmmGlobal GCEnter1)-          | arch == ArchPPC && not (ncgPIC config)-          -> cmmExprNative referenceKind $-             CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId (fsLit "__stg_gc_enter_1")))-        CmmReg (CmmGlobal GCFun)-          | arch == ArchPPC && not (ncgPIC config)-          -> cmmExprNative referenceKind $-             CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId (fsLit "__stg_gc_fun")))--        other-           -> return other+genMachCode config cmmTopCodeGen fileIds dbgMap cmm_top cmm_cfg+  = UDSM $ \initial_us -> do+      { let initial_st           = mkNatM_State initial_us 0 config+                                                fileIds dbgMap cmm_cfg+            (new_tops, final_st) = initNat initial_st (cmmTopCodeGen cmm_top)+            final_delta          = natm_delta final_st+            final_imports        = natm_imports final_st+            final_cfg            = natm_cfg final_st+      ; if   final_delta == 0+        then DUniqResult+              (new_tops, final_imports+                , natm_fileid final_st, final_cfg) (natm_us final_st)+        else DUniqResult (pprPanic "genMachCode: nonzero final delta" (int final_delta)) undefined+      }
GHC/CmmToAsm/AArch64.hs view
@@ -1,6 +1,6 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} --- | Native code generator for x86 and x86-64 architectures+-- | Native code generator for AArch64 architectures module GHC.CmmToAsm.AArch64    ( ncgAArch64 ) where@@ -11,6 +11,7 @@ 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@@ -28,13 +29,14 @@        ,canShortcut               = AArch64.canShortcut        ,shortcutStatics           = AArch64.shortcutStatics        ,shortcutJump              = AArch64.shortcutJump-       ,pprNatCmmDecl             = AArch64.pprNatCmmDecl config+       ,pprNatCmmDeclS            = AArch64.pprNatCmmDecl config+       ,pprNatCmmDeclH            = AArch64.pprNatCmmDecl config        ,maxSpillSlots             = AArch64.maxSpillSlots config        ,allocatableRegs           = AArch64.allocatableRegs platform        ,ncgAllocMoreStack         = AArch64.allocMoreStack platform-       ,ncgMakeFarBranches        = const id+       ,ncgMakeFarBranches        = AArch64.makeFarBranches        ,extractUnwindPoints       = const []-       ,invertCondBranches        = \_ _ -> id+       ,invertCondBranches        = \_ _ blocks -> blocks   }     where       platform = ncgPlatform config@@ -42,18 +44,19 @@ -- | Instruction instance for aarch64 instance Instruction AArch64.Instr where         regUsageOfInstr         = AArch64.regUsageOfInstr-        patchRegsOfInstr        = AArch64.patchRegsOfInstr+        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+        takeRegRegMoveInstr _   = AArch64.takeRegRegMoveInstr         mkJumpInstr             = AArch64.mkJumpInstr         mkStackAllocInstr       = AArch64.mkStackAllocInstr         mkStackDeallocInstr     = AArch64.mkStackDeallocInstr-        mkComment               = pure . AArch64.COMMENT+        mkComment               = pure . AArch64.COMMENT . ftext         pprInstr                = AArch64.pprInstr
GHC/CmmToAsm/AArch64/CodeGen.hs view
@@ -1,1714 +1,2577 @@-{-# language GADTs #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE BinaryLiterals #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE NumericUnderscores #-}-module GHC.CmmToAsm.AArch64.CodeGen (-      cmmTopCodeGen-    , generateJumpTableForInstr-)--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-   )--- 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.Graph-import GHC.Types.Tickish ( GenTickish(..) )-import GHC.Types.SrcLoc  ( srcSpanFile, srcSpanStartLine, srcSpanStartCol )---- The rest:-import GHC.Data.OrdList-import GHC.Utils.Outputable--import Control.Monad    ( mapAndUnzipM, foldM )-import Data.Maybe-import GHC.Float--import GHC.Types.Basic-import GHC.Types.ForeignCall-import GHC.Data.FastString-import GHC.Utils.Misc-import GHC.Utils.Panic---- Note [General layout of an NCG]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- @cmmTopCodeGen@ will be our main entry point to code gen.  Here we'll get--- @RawCmmDecl@; see GHC.Cmm------   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 = unitOL $ MULTILINE_COMMENT (-          text "-- --------------------------- basicBlockCodeGen --------------------------- --\n"-          $+$ pdoc (ncgPlatform config) block-          )-  -- Generate location directive-  dbg <- getDebugBlock (entryLabel block)-  loc_instrs <- case dblSourceTick =<< dbg of-    Just (SourceNote span name)-      -> do fileId <- getFileId (srcSpanFile span)-            let line = srcSpanStartLine span; col = srcSpanStartCol span-            return $ unitOL $ LOCATION fileId line col name-    _ -> return nilOL-  (mid_instrs,mid_bid) <- stmtsToInstrs id stmts-  (!tail_instrs,_) <- stmtToInstrs mid_bid tail-  let instrs = 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 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)----- -------------------------------------------------------------------------------- | 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 assmebly we see.  By having the verbatim AST printed--- we can simply check the patterns that were matched to arrive at the assmebly--- 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 labourous 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 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---- TODO jump tables would be a lot faster, but we'll use bare bones for now.--- this is usually done by sticking the jump table ids into an instruction--- and then have the @generateJumpTableForInstr@ callback produce the jump--- table as a static.------ See Ticket 19912------ data SwitchTargets =---    SwitchTargets---        Bool                       -- Signed values---        (Integer, Integer)         -- Range---        (Maybe Label)              -- Default value---        (M.Map Integer Label)      -- The branches------ Non Jumptable plan:--- xE <- expr----genSwitch :: CmmExpr -> SwitchTargets -> NatM InstrBlock-genSwitch expr targets = do -- pprPanic "genSwitch" (ppr expr)-  (reg, format, code) <- getSomeReg expr-  let w = formatToWidth format-  let mkbranch acc (key, bid) = do-        (keyReg, _format, code) <- getSomeReg (CmmLit (CmmInt key w))-        return $ code `appOL`-                 toOL [ CMP (OpReg w reg) (OpReg w keyReg)-                      , BCOND EQ (TBlock bid)-                      ] `appOL` acc-      def_code = case switchTargetsDefault targets of-        Just bid -> unitOL (B (TBlock bid))-        Nothing  -> nilOL--  switch_code <- foldM mkbranch nilOL (switchTargetsCases targets)-  return $ code `appOL` switch_code `appOL` def_code---- We don't do jump tables for now, see Ticket 19912-generateJumpTableForInstr :: NCGConfig -> Instr-  -> Maybe (NatCmmDecl RawCmmStatics Instr)-generateJumpTableForInstr _ _ = Nothing---- -------------------------------------------------------------------------------- Top-level of the instruction selector---- 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-  -- traceM $ "-- -------------------------- stmtToInstrs -------------------------- --\n"-  --     ++ showSDocUnsafe (ppr stmt)-  platform <- getPlatform-  case stmt of-    CmmUnsafeForeignCall target result_regs args-       -> genCCall target result_regs args bid--    _ -> (,Nothing) <$> 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 platform 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 bid true false arg--      CmmSwitch arg ids -> genSwitch 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 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 if it's not mapped to a registers something-        -- went wrong earlier in the pipeline.--- | Convert a BlockId to some CmmStatic data--- TODO: Add JumpTable Logic, see Ticket 19912--- 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---- | 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)---- TODO OPT: we might be able give getRegister---          a hint, what kind of register we want.-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)---- 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 PicBaseReg)-      -> pprPanic "getRegisterReg-memory" (ppr $ PicBaseReg)-    CmmLit lit-      -> case lit of--        -- TODO handle CmmInt 0 specially, use wzr or xzr.--        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 | 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-              -- width = typeWidth 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 plat 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 plat 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 plat reg)----    -- 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`-                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_Conv from to -> return $ Any (floatFormat to) (\dst -> code `snocOL` SCVTF (OpReg to dst) (OpReg from reg))  -- (Signed ConVerT Float)-        MO_FS_Conv 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))--        -- Conversions-        MO_XX_Conv _from to -> swizzleRegisterRep (intFormat to) <$> getRegister e--        _ -> pprPanic "getRegister' (monadic CmmMachOp):" (pdoc plat expr)-      where-        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-            return $ Any (intFormat w) $ \dst ->-                code `appOL`-                signExtendReg w w' reg `snocOL`-                NEG (OpReg w' dst) (OpReg w' reg) `appOL`-                truncateReg w' w dst--        ss_conv from to reg code =-            let w' = opRegWidth (max from to)-            in return $ Any (intFormat to) $ \dst ->-                code `snocOL`-                SBFM (OpReg w' dst) (OpReg w' reg) (OpImm (ImmInt 0)) (toImm (min from to)) `appOL`-                -- At this point an 8- or 16-bit value would be sign-extended-                -- to 32-bits. Truncate back down the final width.-                truncateReg w' to dst--    -- Dyadic machops:-    ---    -- The general idea is:-    -- compute x<i> <- x-    -- compute x<j> <- y-    -- OP x<r>, x<i>, x<j>-    ---    -- TODO: for now we'll only implement the 64bit versions. And rely on the-    --      fallthrough to alert us if things go wrong!-    -- OPTIMIZATION WARNING: Dyadic CmmMachOp destructuring-    -- 0. TODO This should not exist! Rewrite: Reg +- 0 -> Reg-    CmmMachOp (MO_Add _) [expr'@(CmmReg (CmmGlobal _r)), CmmLit (CmmInt 0 _)] -> getRegister' config plat expr'-    CmmMachOp (MO_Sub _) [expr'@(CmmReg (CmmGlobal _r)), CmmLit (CmmInt 0 _)] -> getRegister' config plat expr'-    -- 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 _)]-      | n > 0 && n < 4096 -> return $ Any (intFormat w) (\d -> unitOL $ annExpr expr (ADD (OpReg w d) (OpReg w' r') (OpImm (ImmInteger n))))-      -- TODO: 12bits lsl #12; e.g. lower 12 bits of n are 0; shift n >> 12, and set lsl to #12.-      where w' = formatToWidth (cmmTypeFormat (cmmRegType plat reg))-            r' = getRegisterReg plat reg-    CmmMachOp (MO_Sub w) [(CmmReg reg), CmmLit (CmmInt n _)]-      | n > 0 && n < 4096 -> return $ Any (intFormat w) (\d -> unitOL $ annExpr expr (SUB (OpReg w d) (OpReg w' r') (OpImm (ImmInteger n))))-      -- TODO: 12bits lsl #12; e.g. lower 12 bits of n are 0; shift n >> 12, and set lsl to #12.-      where w' = formatToWidth (cmmTypeFormat (cmmRegType plat reg))-            r' = getRegisterReg plat reg--    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, 0 <= n, n < 32 -> 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_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 (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)))))-    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)))--    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)))))-    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)))--    CmmMachOp (MO_S_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 (ASR (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n))))--    CmmMachOp (MO_S_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 (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, 0 <= n, n < 32 -> 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))))--    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 (LSR (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n))))--    -- 3. Logic &&, ||-    CmmMachOp (MO_And w) [(CmmReg reg), CmmLit (CmmInt n _)] | isBitMaskImmediate (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 plat reg))-            r' = getRegisterReg plat reg--    CmmMachOp (MO_Or w) [(CmmReg reg), CmmLit (CmmInt n _)] | isBitMaskImmediate (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 plat reg))-            r' = getRegisterReg plat reg--    -- Generic 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.-          bitOp w op = do-            -- compute x<m> <- x-            -- compute x<o> <- y-            -- <OP> x<n>, x<m>, x<o>-            (reg_x, format_x, code_x) <- getSomeReg x-            (reg_y, format_y, code_y) <- getSomeReg y-            massertPpr (isIntFormat format_x == isIntFormat format_y) $ text "bitOp: incompatible"-            return $ Any (intFormat w) (\dst ->-                code_x `appOL`-                code_y `appOL`-                op (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y))--          -- A (potentially signed) integer operation.-          -- In the case of 8- and 16-bit signed arithmetic we must first-          -- sign-extend both arguments to 32-bits.-          -- See Note [Signed arithmetic on AArch64].-          intOp is_signed w op = do-              -- compute x<m> <- x-              -- compute x<o> <- y-              -- <OP> x<n>, x<m>, x<o>-              (reg_x, format_x, code_x) <- getSomeReg x-              (reg_y, format_y, code_y) <- getSomeReg y-              massertPpr (isIntFormat format_x && isIntFormat format_y) $ text "intOp: non-int"-              -- This is the width of the registers on which the operation-              -- should be performed.-              let w' = opRegWidth w-                  signExt r-                    | not is_signed  = nilOL-                    | otherwise      = signExtendReg w w' r-              return $ Any (intFormat w) $ \dst ->-                  code_x `appOL`-                  code_y `appOL`-                  -- sign-extend both operands-                  signExt reg_x `appOL`-                  signExt reg_y `appOL`-                  op (OpReg w' dst) (OpReg w' reg_x) (OpReg w' reg_y) `appOL`-                  truncateReg w' w dst -- truncate back to the operand's original width--          floatOp w op = do-            (reg_fx, format_x, code_fx) <- getFloatReg x-            (reg_fy, format_y, code_fy) <- getFloatReg y-            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))--        -- 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     -> bitOp w (\d x y -> toOL [ CMP x y, CSET d EQ ])-        MO_Ne w     -> bitOp w (\d x y -> toOL [ CMP x y, CSET d NE ])--        -- 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_MulMayOflo _w -> unsupportedP plat expr-        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     -> intOp False w (\d x y -> toOL [ CMP x y, CSET d UGE ])-        MO_U_Le w     -> intOp False w (\d x y -> toOL [ CMP x y, CSET d ULE ])-        MO_U_Gt w     -> intOp False w (\d x y -> toOL [ CMP x y, CSET d UGT ])-        MO_U_Lt w     -> intOp False w (\d x y -> toOL [ CMP x y, CSET d ULT ])--        -- 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)--        -- 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 intutive. 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 -> bitOp w (\d x y -> unitOL $ AND d x y)-        MO_Or    w -> bitOp w (\d x y -> unitOL $ ORR d x y)-        MO_Xor   w -> bitOp w (\d x y -> unitOL $ EOR d x y)-        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)--        -- TODO--        op -> pprPanic "getRegister' (unhandled dyadic CmmMachOp): " $ (pprMachOp op) <+> text "in" <+> (pdoc plat expr)-    CmmMachOp _op _xs-      -> pprPanic "getRegister' (variadic CmmMachOp): " (pdoc plat expr)--  where-    unsupportedP :: OutputableP env a => env -> a -> b-    unsupportedP platform op = pprPanic "Unsupported op:" (pdoc platform op)--    isNbitEncodeable :: Int -> Integer -> Bool-    isNbitEncodeable n i = let shift = n - 1 in (-1 `shiftL` shift) <= i && i < (1 `shiftL` shift)-    -- This needs to check if n can be encoded as a bitmask immediate:-    ---    -- See https://stackoverflow.com/questions/30904718/range-of-immediate-values-in-armv8-a64-assembly-    ---    isBitMaskImmediate :: Integer -> Bool-    isBitMaskImmediate i = i `elem` [0b0000_0001, 0b0000_0010, 0b0000_0100, 0b0000_1000, 0b0001_0000, 0b0010_0000, 0b0100_0000, 0b1000_0000-                                    ,0b0000_0011, 0b0000_0110, 0b0000_1100, 0b0001_1000, 0b0011_0000, 0b0110_0000, 0b1100_0000-                                    ,0b0000_0111, 0b0000_1110, 0b0001_1100, 0b0011_1000, 0b0111_0000, 0b1110_0000-                                    ,0b0000_1111, 0b0001_1110, 0b0011_1100, 0b0111_1000, 0b1111_0000-                                    ,0b0001_1111, 0b0011_1110, 0b0111_1100, 0b1111_1000-                                    ,0b0011_1111, 0b0111_1110, 0b1111_1100-                                    ,0b0111_1111, 0b1111_1110-                                    ,0b1111_1111]--    -- N.B. MUL does not set the overflow flag.-    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 w x y = do-        (reg_x, _format_x, code_x) <- getSomeReg x-        (reg_y, _format_y, code_y) <- getSomeReg y-        let tmp_w = case w of-                      W32 -> W64-                      W16 -> W32-                      W8  -> W32-                      _   -> panic "do_mul_may_oflo: impossible"-        -- This will hold the product-        tmp <- getNewRegNat (intFormat tmp_w)-        let ext_mode = case w of-                         W32 -> ESXTW-                         W16 -> ESXTH-                         W8  -> ESXTB-                         _   -> panic "do_mul_may_oflo: impossible"-            mul = case w of-                    W32 -> SMULL-                    W16 -> MUL-                    W8  -> MUL-                    _   -> panic "do_mul_may_oflo: impossible"-        return $ Any (intFormat w) (\dst ->-            code_x `appOL`-            code_y `snocOL`-            mul (OpReg tmp_w tmp) (OpReg w reg_x) (OpReg w reg_y) `snocOL`-            CMP (OpReg tmp_w tmp) (OpRegExt tmp_w tmp ext_mode 0) `snocOL`-            CSET (OpReg w dst) NE)---- | Instructions to sign-extend the value in the given register from width @w@--- up to width @w'@.-signExtendReg :: Width -> Width -> Reg -> OrdList Instr-signExtendReg w w' r =-    case w of-      W64 -> nilOL-      W32-        | w' == W32 -> nilOL-        | otherwise -> unitOL $ SXTH (OpReg w' r) (OpReg w' r)-      W16           -> unitOL $ SXTH (OpReg w' r) (OpReg w' r)-      W8            -> unitOL $ SXTB (OpReg w' r) (OpReg w' r)-      _             -> panic "intOp"---- | 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:--- LDUR/STUR: imm9: -256 - 255-getAmode platform _ (CmmRegOff reg off) | -256 <= off, off <= 255-  = return $ Amode (AddrRegImm reg' off') nilOL-    where reg' = getRegisterReg platform reg-          off' = ImmInt off--- LDR/STR: imm12: if reg is 32bit: 0 -- 16380 in multiples of 4-getAmode platform W32 (CmmRegOff reg off)-  | 0 <= off, off <= 16380, off `mod` 4 == 0-  = return $ Amode (AddrRegImm reg' off') nilOL-    where reg' = getRegisterReg platform reg-          off' = ImmInt off--- LDR/STR: imm12: if reg is 64bit: 0 -- 32760 in multiples of 8-getAmode platform W64 (CmmRegOff reg off)-  | 0 <= off, off <= 32760, off `mod` 8 == 0-  = 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')])-  | -256 <= off, off <= 255-  = do (reg, _format, code) <- getSomeReg expr-       return $ Amode (AddrRegImm reg (ImmInteger off)) code--getAmode _platform _ (CmmMachOp (MO_Sub _w) [expr, CmmLit (CmmInt off _w')])-  | -256 <= -off, -off <= 255-  = 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))-  = return $ unitOL (annExpr expr (J (TLabel lbl)))--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)---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 _ true false expr = do-  b1 <- genCondJump true expr-  b2 <- genBranch false-  return (b1 `appOL` b2)---- --------------------------------------------------------------------------------  Generating C calls---- Now the biggest nightmare---calls.  Most of the nastiness is buried in--- @get_arg@, which moves the arguments to the correct registers/stack--- locations.  Apart from that, the code is easy.------ As per *convention*:--- x0-x7:   (volatile) argument registers--- x8:      (volatile) indirect result register / Linux syscall no--- x9-x15:  (volatile) caller saved regs--- x16,x17: (volatile) intra-procedure-call registers--- x18:     (volatile) platform register. don't use for portability--- x19-x28: (non-volatile) callee save regs--- x29:     (non-volatile) frame pointer--- x30:                    link register--- x31:                    stack pointer / zero reg------ Thus, this is what a c function will expect. Find the arguments in x0-x7,--- anything above that on the stack.  We'll ignore c functions with more than--- 8 arguments for now.  Sorry.------ We need to make sure we preserve x9-x15, don't want to touch x16, x17.---- Note [PLT vs GOT relocations]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- When linking objects together, we may need to lookup foreign references. That--- is symbolic references to functions or values in other objects. When--- compiling the object, we can not know where those elements will end up in--- memory (relative to the current location). Thus the use of symbols. There--- are two types of items we are interested, code segments we want to jump to--- and continue execution there (functions, ...), and data items we want to look--- up (strings, numbers, ...). For functions we can use the fact that we can use--- an intermediate jump without visibility to the programs execution.  If we--- want to jump to a function that is simply too far away to reach for the B/BL--- instruction, we can create a small piece of code that loads the full target--- address and jumps to that on demand. Say f wants to call g, however g is out--- of range for a direct jump, we can create a function h in range for f, that--- will load the address of g, and jump there. The area where we construct h--- is called the Procedure Linking Table (PLT), we have essentially replaced--- f -> g with f -> h -> g.  This is fine for function calls.  However if we--- want to lookup values, this trick doesn't work, so we need something else.--- We will instead reserve a slot in memory, and have a symbol pointing to that--- slot. Now what we essentially do is, we reference that slot, and expect that--- slot to hold the final resting address of the data we are interested in.--- Thus what that symbol really points to is the location of the final data.--- The block of memory where we hold all those slots is the Global Offset Table--- (GOT).  Instead of x <- $foo, we now do y <- $fooPtr, and x <- [$y].------ For JUMP/CALLs we have 26bits (+/- 128MB), for conditional branches we only--- have 19bits (+/- 1MB).  Symbol lookups are also within +/- 1MB, thus for most--- of the LOAD/STOREs we'd want to use adrp, and add to compute a value within--- 4GB of the PC, and load that.  For anything outside of that range, we'd have--- to go through the GOT.------  adrp x0, <symbol>---  add x0, :lo:<symbol>------ will compute the address of <symbol> int x0 if <symbol> is within 4GB of the--- PC.------ If we want to get the slot in the global offset table (GOT), we can do this:------   adrp x0, #:got:<symbol>---   ldr x0, [x0, #:got_lo12:<symbol>]------ this will compute the address anywhere in the addressable 64bit space into--- x0, by loading the address from the GOT slot.------ To actually get the value of <symbol>, we'd need to ldr x0, x0 still, which--- for the first case can be optimized to use ldr x0, [x0, #:lo12:<symbol>]--- instead of the add instruction.------ As the memory model for AArch64 for PIC is considered to be +/- 4GB, we do--- not need to go through the GOT, unless we want to address the full address--- range within 64bit.--genCCall-    :: ForeignTarget      -- function to call-    -> [CmmFormal]        -- where to put the result-    -> [CmmActual]        -- arguments (of mixed type)-    -> BlockId            -- The block we are in-    -> NatM (InstrBlock, Maybe BlockId)--- TODO: Specialize where we can.--- Generic impl-genCCall target dest_regs arg_regs bid = 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)--  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--      platform <- getPlatform-      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'--      (returnRegs, 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 returnRegs) -- branch and link.-            `appOL` readResultsCode           -- parse the results into registers-            `appOL` moveStackUp (stackSpace `div` 8)-      return (code, Nothing)--    PrimTarget MO_F32_Fabs-      | [arg_reg] <- arg_regs, [dest_reg] <- dest_regs ->-        unaryFloatOp W32 (\d x -> unitOL $ FABS d x) arg_reg dest_reg-    PrimTarget MO_F64_Fabs-      | [arg_reg] <- arg_regs, [dest_reg] <- dest_regs ->-        unaryFloatOp W64 (\d x -> unitOL $ FABS d x) arg_reg dest_reg--    -- 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"-        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)--        -- Arithmatic-        -- These are not supported on X86, so I doubt they are used much.-        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--        -- Memory Ordering-        -- TODO DMBSY is probably *way* too much!-        MO_ReadBarrier      ->  return (unitOL DMBSY, Nothing)-        MO_WriteBarrier     ->  return (unitOL DMBSY, Nothing)-        MO_Touch            ->  return (nilOL, Nothing) -- Keep variables live (when using interior pointers)-        -- Prefetch-        MO_Prefetch_Data _n -> return (nilOL, Nothing) -- 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_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_AtomicRMW w amop -> mkCCall (atomicRMWLabel w amop)-        MO_AtomicRead w     -> mkCCall (atomicReadLabel w)-        MO_AtomicWrite w    -> mkCCall (atomicWriteLabel w)-        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, Maybe BlockId)-    mkCCall name = do-      config <- getConfig-      target <- cmmMakeDynamicReference config CallReference $-          mkForeignLabel name Nothing ForeignLabelInThisPackage IsFunction-      let cconv = ForeignConvention CCallConv [NoHint] [NoHint] CmmMayReturn-      genCCall (ForeignTarget target cconv) dest_regs arg_regs bid--    -- TODO: Optimize using paired stores and loads (STP, LDP). It is-    -- automomatically 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 ([Reg], InstrBlock)-    readResults _ _ [] accumRegs accumCode = return (accumRegs, 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 platform (CmmLocal dst)-          format = cmmTypeFormat rep-          w   = cmmRegWidth platform (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, Nothing)+{-# language GADTs, LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++module GHC.CmmToAsm.AArch64.CodeGen (+      cmmTopCodeGen+    , generateJumpTableForInstr+    , makeFarBranches+)++where++-- NCG stuff:+import GHC.Prelude hiding (EQ)++import Data.Word++import GHC.Platform.Regs+import GHC.CmmToAsm.AArch64.Instr+import GHC.CmmToAsm.AArch64.Regs+import GHC.CmmToAsm.AArch64.Cond++import GHC.CmmToAsm.CPrim+import GHC.Cmm.DebugBlock+import GHC.CmmToAsm.Monad+   ( NatM, getNewRegNat+   , getPicBaseMaybeNat, getPlatform, getConfig+   , getDebugBlock, getFileId, getNewLabelNat, getThisModuleNat+   )+-- import GHC.CmmToAsm.Instr+import GHC.CmmToAsm.PIC+import GHC.CmmToAsm.Format+import GHC.CmmToAsm.Config+import GHC.CmmToAsm.Types+import GHC.Platform.Reg+import GHC.Platform++-- Our intermediate code:+import GHC.Cmm.BlockId+import GHC.Cmm+import GHC.Cmm.Utils+import GHC.Cmm.Switch+import GHC.Cmm.CLabel+import GHC.Cmm.Dataflow.Block+import GHC.Cmm.Dataflow.Label+import GHC.Cmm.Dataflow.Graph+import GHC.Types.Tickish ( GenTickish(..) )+import GHC.Types.SrcLoc  ( srcSpanFile, srcSpanStartLine, srcSpanStartCol )+import GHC.Types.Unique.DSM++-- The rest:+import GHC.Data.OrdList+import GHC.Utils.Outputable++import Control.Monad    ( mapAndUnzipM )+import GHC.Float++import GHC.Types.Basic+import GHC.Types.ForeignCall+import GHC.Data.FastString+import GHC.Utils.Misc+import GHC.Utils.Panic+import GHC.Utils.Constants (debugIsOn)+import GHC.Utils.Monad (mapAccumLM)++-- Note [General layout of an NCG]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- @cmmTopCodeGen@ will be our main entry point to code gen.  Here we'll get+-- @RawCmmDecl@; see GHC.Cmm+--+--   RawCmmDecl = GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph+--+--   GenCmmDecl d h g = CmmProc h CLabel [GlobalReg] g+--                    | CmmData Section d+--+-- As a result we want to transform this to a list of @NatCmmDecl@, which is+-- defined @GHC.CmmToAsm.Instr@ as+--+--   type NatCmmDecl statics instr+--        = GenCmmDecl statics (LabelMap RawCmmStatics) (ListGraph instr)+--+-- Thus well' turn+--   GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph+-- into+--   [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) (ListGraph Instr)]+--+-- where @CmmGraph@ is+--+--   type CmmGraph = GenCmmGraph CmmNode+--   data GenCmmGraph n = CmmGraph { g_entry :: BlockId, g_graph :: Graph n C C }+--   type CmmBlock = Block CmmNode C C+--+-- and @ListGraph Instr@ is+--+--   newtype ListGraph i = ListGraph [GenBasicBlock i]+--   data GenBasicBlock i = BasicBlock BlockId [i]++cmmTopCodeGen+    :: RawCmmDecl+    -> NatM [NatCmmDecl RawCmmStatics Instr]++-- Thus we'll have to deal with either CmmProc ...+cmmTopCodeGen _cmm@(CmmProc info lab live graph) = do+  -- do+  --   traceM $ "-- -------------------------- cmmTopGen (CmmProc) -------------------------- --\n"+  --         ++ showSDocUnsafe (ppr cmm)++  let blocks = toBlockListEntryFirst graph+  (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks+  picBaseMb <- getPicBaseMaybeNat++  let proc = CmmProc info lab live (ListGraph $ concat nat_blocks)+      tops = proc : concat statics++  case picBaseMb of+      Just _picBase -> panic "AArch64.cmmTopCodeGen: picBase not implemented"+      Nothing -> return tops++-- ... or CmmData.+cmmTopCodeGen _cmm@(CmmData sec dat) = do+  -- do+  --   traceM $ "-- -------------------------- cmmTopGen (CmmData) -------------------------- --\n"+  --         ++ showSDocUnsafe (ppr cmm)+  return [CmmData sec dat] -- no translation, we just use CmmStatic++basicBlockCodeGen+        :: Block CmmNode C C+        -> NatM ( [NatBasicBlock Instr]+                , [NatCmmDecl RawCmmStatics Instr])++basicBlockCodeGen block = do+  config <- getConfig+  -- do+  --   traceM $ "-- --------------------------- basicBlockCodeGen --------------------------- --\n"+  --         ++ showSDocUnsafe (ppr block)+  let (_, nodes, tail)  = blockSplit block+      id = entryLabel block+      stmts = blockToList nodes++      header_comment_instr | debugIsOn = unitOL $ MULTILINE_COMMENT (+          text "-- --------------------------- basicBlockCodeGen --------------------------- --\n"+          $+$ withPprStyle defaultDumpStyle (pdoc (ncgPlatform config) block)+          )+                           | otherwise = nilOL+  -- Generate location directive+  dbg <- getDebugBlock (entryLabel block)+  loc_instrs <- case dblSourceTick =<< dbg of+    Just (SourceNote span (LexicalFastString name))+      -> do fileId <- getFileId (srcSpanFile span)+            let line = srcSpanStartLine span; col = srcSpanStartCol span+            return $ unitOL $ LOCATION fileId line col (unpackFS name)+    _ -> return nilOL+  mid_instrs <- stmtsToInstrs stmts+  (!tail_instrs) <- stmtToInstrs tail+  let instrs = header_comment_instr `appOL` loc_instrs `appOL` mid_instrs `appOL` tail_instrs+  -- TODO: Then x86 backend run @verifyBasicBlock@ here and inserts+  --      unwinding info. See Ticket 19913+  -- code generation may introduce new basic block boundaries, which+  -- are indicated by the NEWBLOCK instruction.  We must split up the+  -- instruction stream into basic blocks again. Also, we may extract+  -- LDATAs here too (if they are implemented by AArch64 again - See+  -- PPC how to do that.)+  let+        (top,other_blocks,statics) = foldrOL mkBlocks ([],[],[]) instrs++  return (BasicBlock id top : other_blocks, statics)++mkBlocks :: Instr+          -> ([Instr], [GenBasicBlock Instr], [GenCmmDecl RawCmmStatics h g])+          -> ([Instr], [GenBasicBlock Instr], [GenCmmDecl RawCmmStatics h g])+mkBlocks (NEWBLOCK id) (instrs,blocks,statics)+  = ([], BasicBlock id instrs : blocks, statics)+mkBlocks instr (instrs,blocks,statics)+  = (instr:instrs, blocks, statics)+-- -----------------------------------------------------------------------------+-- | Utilities+ann :: SDoc -> Instr -> Instr+ann doc instr {- debugIsOn -} = ANN doc instr+-- ann _ instr = instr+{-# INLINE ann #-}++-- Using pprExpr will hide the AST, @ANN@ will end up in the assembly with+-- -dppr-debug.  The idea is that we can trivially see how a cmm expression+-- ended up producing the assembly we see.  By having the verbatim AST printed+-- we can simply check the patterns that were matched to arrive at the assembly+-- we generated.+--+-- pprExpr will hide a lot of noise of the underlying data structure and print+-- the expression into something that can be easily read by a human. However+-- going back to the exact CmmExpr representation can be laborious and adds+-- indirections to find the matches that lead to the assembly.+--+-- An improvement could be to have+--+--    (pprExpr genericPlatform e) <> parens (text. show e)+--+-- to have the best of both worlds.+--+-- Note: debugIsOn is too restrictive, it only works for debug compilers.+-- However, we do not only want to inspect this for debug compilers. Ideally+-- we'd have a check for -dppr-debug here already, such that we don't even+-- generate the ANN expressions. However, as they are lazy, they shouldn't be+-- forced until we actually force them, and without -dppr-debug they should+-- never end up being forced.+annExpr :: CmmExpr -> Instr -> Instr+annExpr e instr {- debugIsOn -} = ANN (text . show $ e) instr+-- annExpr e instr {- debugIsOn -} = ANN (pprExpr genericPlatform e) instr+-- annExpr _ instr = instr+{-# INLINE annExpr #-}++-- -----------------------------------------------------------------------------+-- Generating a table-branch++-- | Generate jump to jump table target+--+-- The index into the jump table is calulated by evaluating @expr@. The+-- corresponding table entry contains the relative address to jump to (relative+-- to the jump table's first entry / the table's own label).+genSwitch :: NCGConfig -> CmmExpr -> SwitchTargets -> NatM InstrBlock+genSwitch config expr targets = do+  (reg, fmt1, e_code) <- getSomeReg indexExpr+  let fmt = II64+  targetReg <- getNewRegNat fmt+  lbl <- getNewLabelNat+  dynRef <- cmmMakeDynamicReference config DataReference lbl+  (tableReg, fmt2, t_code) <- getSomeReg dynRef+  let code =+        toOL+          [ COMMENT (text "indexExpr" <+> (text . show) indexExpr),+            COMMENT (text "dynRef" <+> (text . show) dynRef)+          ]+          `appOL` e_code+          `appOL` t_code+          `appOL` toOL+            [ COMMENT (ftext "Jump table for switch"),+              -- index to offset into the table (relative to tableReg)+              annExpr expr (LSL (OpReg (formatToWidth fmt1) reg) (OpReg (formatToWidth fmt1) reg) (OpImm (ImmInt 3))),+              -- calculate table entry address+              ADD (OpReg W64 targetReg) (OpReg (formatToWidth fmt1) reg) (OpReg (formatToWidth fmt2) tableReg),+              -- load table entry (relative offset from tableReg (first entry) to target label)+              LDR II64 (OpReg W64 targetReg) (OpAddr (AddrRegImm targetReg (ImmInt 0))),+              -- calculate absolute address of the target label+              ADD (OpReg W64 targetReg) (OpReg W64 targetReg) (OpReg W64 tableReg),+              -- prepare jump to target label+              J_TBL ids (Just lbl) targetReg+            ]+  return code+  where+    -- See Note [Sub-word subtlety during jump-table indexing] in+    -- GHC.CmmToAsm.X86.CodeGen for why we must first offset, then widen.+    indexExpr0 = cmmOffset platform expr offset+    -- We widen to a native-width register to sanitize the high bits+    indexExpr =+      CmmMachOp+        (MO_UU_Conv expr_w (platformWordWidth platform))+        [indexExpr0]+    expr_w = cmmExprWidth platform expr+    (offset, ids) = switchTargetsToTable targets+    platform = ncgPlatform config++-- | Generate jump table data (if required)+--+-- The idea is to emit one table entry per case. The entry is the relative+-- address of the block to jump to (relative to the table's first entry /+-- table's own label.) The calculation itself is done by the linker.+generateJumpTableForInstr ::+  NCGConfig ->+  Instr ->+  Maybe (NatCmmDecl RawCmmStatics Instr)+generateJumpTableForInstr config (J_TBL ids (Just lbl) _) =+  let jumpTable =+        map jumpTableEntryRel ids+        where+          jumpTableEntryRel Nothing =+            CmmStaticLit (CmmInt 0 (ncgWordWidth config))+          jumpTableEntryRel (Just blockid) =+            CmmStaticLit+              ( CmmLabelDiffOff+                  blockLabel+                  lbl+                  0+                  (ncgWordWidth config)+              )+            where+              blockLabel = blockLbl blockid+      sectionType = case platformOS (ncgPlatform config) of+        -- Aarch64 Windows platform requires LLVM 20 to support .rodata+        OSMinGW32 -> Text+        _         -> ReadOnlyData+   in Just (CmmData (Section sectionType lbl) (CmmStaticsRaw lbl jumpTable))+generateJumpTableForInstr _ _ = Nothing++-- -----------------------------------------------------------------------------+-- Top-level of the instruction selector++stmtsToInstrs :: [CmmNode O O] -- ^ Cmm Statements+              -> NatM InstrBlock -- ^ Resulting instructions+stmtsToInstrs stmts =+    go stmts nilOL+  where+    go []        instrs = return instrs+    go (s:stmts) instrs = do+      instrs' <- stmtToInstrs s+      go stmts (instrs `appOL` instrs')++stmtToInstrs :: CmmNode e x -- ^ Cmm Statement+             -> NatM InstrBlock -- ^ Resulting Instructions+stmtToInstrs stmt = do+  -- traceM $ "-- -------------------------- stmtToInstrs -------------------------- --\n"+  --     ++ showSDocUnsafe (ppr stmt)+  config <- getConfig+  platform <- getPlatform+  case stmt of+    CmmUnsafeForeignCall target result_regs args+       -> genCCall target result_regs args++    _ -> case stmt of+      CmmComment s   -> return (unitOL (COMMENT (ftext s)))+      CmmTick {}     -> return nilOL++      CmmAssign reg src+        | isFloatType ty         -> assignReg_FltCode format reg src+        | otherwise              -> assignReg_IntCode format reg src+          where ty = cmmRegType reg+                format = cmmTypeFormat ty++      CmmStore addr src _alignment+        | isFloatType ty         -> assignMem_FltCode format addr src+        | otherwise              -> assignMem_IntCode format addr src+          where ty = cmmExprType platform src+                format = cmmTypeFormat ty++      CmmBranch id          -> genBranch id++      --We try to arrange blocks such that the likely branch is the fallthrough+      --in GHC.Cmm.ContFlowOpt. So we can assume the condition is likely false here.+      CmmCondBranch arg true false _prediction ->+          genCondBranch true false arg++      CmmSwitch arg ids -> genSwitch config arg ids++      CmmCall { cml_target = arg } -> genJump arg++      CmmUnwind _regs -> return nilOL++      _ -> pprPanic "stmtToInstrs: statement should have been cps'd away" (pdoc platform stmt)++--------------------------------------------------------------------------------+-- | 'InstrBlock's are the insn sequences generated by the insn selectors.+--      They are really trees of insns to facilitate fast appending, where a+--      left-to-right traversal yields the insns in the correct order.+--+type InstrBlock+        = OrdList Instr++-- | Register's passed up the tree.  If the stix code forces the register+--      to live in a pre-decided machine register, it comes out as @Fixed@;+--      otherwise, it comes out as @Any@, and the parent can decide which+--      register to put it in.+--+data Register+        = Fixed Format Reg InstrBlock+        | Any   Format (Reg -> InstrBlock)++-- | Sometimes we need to change the Format of a register. Primarily during+-- conversion.+swizzleRegisterRep :: Format -> Register -> Register+swizzleRegisterRep format (Fixed _ reg code) = Fixed format reg code+swizzleRegisterRep format (Any _ codefn)     = Any   format codefn++-- | Grab the Reg for a CmmReg+getRegisterReg :: Platform -> CmmReg -> Reg++getRegisterReg _ (CmmLocal (LocalReg u pk))+  = RegVirtual $ mkVirtualReg u (cmmTypeFormat pk)++getRegisterReg platform (CmmGlobal reg@(GlobalRegUse mid _))+  = case globalRegMaybe platform mid of+        Just reg -> RegReal reg+        Nothing  -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal reg)+        -- By this stage, the only MagicIds remaining should be the+        -- ones which map to a real machine register on this+        -- platform.  Hence if it's not mapped to a registers something+        -- went wrong earlier in the pipeline.++-- -----------------------------------------------------------------------------+-- General things for putting together code sequences++-- | The dual to getAnyReg: compute an expression into a register, but+--      we don't mind which one it is.+getSomeReg :: CmmExpr -> NatM (Reg, Format, InstrBlock)+getSomeReg expr = do+  r <- getRegister expr+  case r of+    Any rep code -> do+        tmp <- getNewRegNat rep+        return (tmp, rep, code tmp)+    Fixed rep reg code ->+        return (reg, rep, code)++{- Note [Aarch64 immediates]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Aarch64 with it's fixed width instruction encoding uses leftover space for+immediates.+If you want the full rundown consult the arch reference document:+"Arm® Architecture Reference Manual" - "C3.4 Data processing - immediate"++The gist of it is that different instructions allow for different immediate encodings.+The ones we care about for better code generation are:++* Simple but potentially repeated bit-patterns for logic instructions.+* 16bit numbers shifted by multiples of 16.+* 12 bit numbers optionally shifted by 12 bits.++It might seem like the ISA allows for 64bit immediates but this isn't the case.+Rather there are some instruction aliases which allow for large unencoded immediates+which will then be transalted to one of the immediate encodings implicitly.++For example mov x1, #0x10000 is allowed but will be assembled to movz x1, #0x1, lsl #16+-}++-- | Move (wide immediate)+-- Allows for 16bit immediate which can be shifted by 0/16/32/48 bits.+-- Used with MOVZ,MOVN, MOVK+-- See Note [Aarch64 immediates]+getMovWideImm :: Integer -> Width -> Maybe Operand+getMovWideImm n w+  -- TODO: Handle sign extension/negatives+  | n <= 0+  = Nothing+  -- Fits in 16 bits+  | sized_n < 2^(16 :: Int)+  = Just $ OpImm (ImmInteger truncated)++  -- 0x0000 0000 xxxx 0000+  | trailing_zeros >= 16 && sized_n < 2^(32 :: Int)+  = Just $ OpImmShift (ImmInteger $ truncated `shiftR` 16) SLSL 16++  -- 0x 0000 xxxx 0000 0000+  | trailing_zeros >= 32 && sized_n < 2^(48 :: Int)+  = Just $ OpImmShift (ImmInteger $ truncated `shiftR` 32) SLSL 32++  -- 0x xxxx 0000 0000 0000+  | trailing_zeros >= 48+  = Just $ OpImmShift (ImmInteger $ truncated `shiftR` 48) SLSL 48++  | otherwise+  = Nothing+  where+    truncated = narrowU w n+    sized_n = fromIntegral truncated :: Word64+    trailing_zeros = countTrailingZeros sized_n++-- | Arithmetic(immediate)+--  Allows for 12bit immediates which can be shifted by 0 or 12 bits.+-- Used with ADD, ADDS, SUB, SUBS, CMP+-- See Note [Aarch64 immediates]+getArithImm :: Integer -> Width -> Maybe Operand+getArithImm n w+  -- TODO: Handle sign extension+  | n <= 0+  = Nothing+  -- Fits in 16 bits+  -- Fits in 12 bits+  | sized_n < 2^(12::Int)+  = Just $ OpImm (ImmInteger truncated)++  -- 12 bits shifted by 12 places.+  | trailing_zeros >= 12 && sized_n < 2^(24::Int)+  = Just $ OpImmShift (ImmInteger $ truncated `shiftR` 12) SLSL 12++  | otherwise+  = Nothing+  where+    sized_n = fromIntegral truncated :: Word64+    truncated = narrowU w n+    trailing_zeros = countTrailingZeros sized_n++-- |  Logical (immediate)+-- Allows encoding of some repeated bitpatterns+-- Used with AND, EOR, ORR+-- and their aliases which includes at least MOV (bitmask immediate)+-- See Note [Aarch64 immediates]+getBitmaskImm :: Integer -> Width -> Maybe Operand+getBitmaskImm n w+  | isAArch64Bitmask (opRegWidth w) truncated = Just $ OpImm (ImmInteger truncated)+  | otherwise = Nothing+  where+    truncated = narrowU w n++-- | Load/store immediate.+-- Depends on the width of the store to some extent.+isOffsetImm :: Int -> Width -> Bool+isOffsetImm off w+  -- 8 bits + sign for unscaled offsets+  | -256 <= off, off <= 255 = True+  -- Offset using 12-bit positive immediate, scaled by width+  -- LDR/STR: imm12: if reg is 32bit: 0 -- 16380 in multiples of 4+  -- LDR/STR: imm12: if reg is 64bit: 0 -- 32760 in multiples of 8+  -- 16-bit: 0 .. 8188, 8-bit: 0 -- 4095+  | 0 <= off, off < 4096 * byte_width, off `mod` byte_width == 0 = True+  | otherwise = False+  where+    byte_width = widthInBytes w+++++-- TODO OPT: we might be able give getRegister+--          a hint, what kind of register we want.+getFloatReg :: HasDebugCallStack => CmmExpr -> NatM (Reg, Format, InstrBlock)+getFloatReg expr = do+  r <- getRegister expr+  case r of+    Any rep code | isFloatFormat rep -> do+      tmp <- getNewRegNat rep+      return (tmp, rep, code tmp)+    Any II32 code -> do+      tmp <- getNewRegNat FF32+      return (tmp, FF32, code tmp)+    Any II64 code -> do+      tmp <- getNewRegNat FF64+      return (tmp, FF64, code tmp)+    Any _w _code -> do+      config <- getConfig+      pprPanic "can't do getFloatReg on" (pdoc (ncgPlatform config) expr)+    -- can't do much for fixed.+    Fixed rep reg code ->+      return (reg, rep, code)++-- TODO: TODO, bounds. We can't put any immediate+-- value in. They are constrained.+-- See Ticket 19911+litToImm' :: CmmLit -> NatM (Operand, InstrBlock)+litToImm' lit = return (OpImm (litToImm lit), nilOL)++getRegister :: CmmExpr -> NatM Register+getRegister e = do+  config <- getConfig+  getRegister' config (ncgPlatform config) e++-- | The register width to be used for an operation on the given width+-- operand.+opRegWidth :: Width -> Width+opRegWidth W64 = W64  -- x+opRegWidth W32 = W32  -- w+opRegWidth W16 = W32  -- w+opRegWidth W8  = W32  -- w+opRegWidth w   = pprPanic "opRegWidth" (text "Unsupported width" <+> ppr w)++-- Note [Signed arithmetic on AArch64]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- Handling signed arithmetic on sub-word-size values on AArch64 is a bit+-- tricky as Cmm's type system does not capture signedness. While 32-bit values+-- are fairly easy to handle due to AArch64's 32-bit instruction variants+-- (denoted by use of %wN registers), 16- and 8-bit values require quite some+-- care.+--+-- We handle 16-and 8-bit values by using the 32-bit operations and+-- sign-/zero-extending operands and truncate results as necessary. For+-- simplicity we maintain the invariant that a register containing a+-- sub-word-size value always contains the zero-extended form of that value+-- in between operations.+--+-- For instance, consider the program,+--+--    test(bits64 buffer)+--      bits8 a = bits8[buffer];+--      bits8 b = %mul(a, 42);+--      bits8 c = %not(b);+--      bits8 d = %shrl(c, 4::bits8);+--      return (d);+--    }+--+-- This program begins by loading `a` from memory, for which we use a+-- zero-extended byte-size load.  We next sign-extend `a` to 32-bits, and use a+-- 32-bit multiplication to compute `b`, and truncate the result back down to+-- 8-bits.+--+-- Next we compute `c`: The `%not` requires no extension of its operands, but+-- we must still truncate the result back down to 8-bits. Finally the `%shrl`+-- requires no extension and no truncate since we can assume that+-- `c` is zero-extended.+--+-- TODO:+--   Don't use Width in Operands+--   Instructions should rather carry a RegWidth+--+-- Note [Handling PIC on AArch64]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- AArch64 does not have a special PIC register, the general approach is to+-- simply go through the GOT, and there is assembly support for this:+--+--   // Load the address of 'sym' from the GOT using ADRP and LDR (used for+--   // position-independent code on AArch64):+--   adrp x0, #:got:sym+--   ldr x0, [x0, #:got_lo12:sym]+--+-- See also: https://developer.arm.com/documentation/dui0774/i/armclang-integrated-assembler-directives/assembly-expressions+--+-- CmmGlobal @PicBaseReg@'s are generated in @GHC.CmmToAsm.PIC@ in the+-- @cmmMakePicReference@.  This is in turn called from @cmmMakeDynamicReference@+-- also in @Cmm.CmmToAsm.PIC@ from where it is also exported.  There are two+-- callsites for this. One is in this module to produce the @target@ in @genCCall@+-- the other is in @GHC.CmmToAsm@ in @cmmExprNative@.+--+-- Conceptually we do not want any special PicBaseReg to be used on AArch64. If+-- we want to distinguish between symbol loading, we need to address this through+-- the way we load it, not through a register.+--++getRegister' :: NCGConfig -> Platform -> CmmExpr -> NatM Register+-- OPTIMIZATION WARNING: CmmExpr rewrites+-- 1. Rewrite: Reg + (-n) => Reg - n+--    TODO: this expression shouldn't even be generated to begin with.+getRegister' config plat (CmmMachOp (MO_Add w0) [x, CmmLit (CmmInt i w1)]) | i < 0+  = getRegister' config plat (CmmMachOp (MO_Sub w0) [x, CmmLit (CmmInt (-i) w1)])++getRegister' config plat (CmmMachOp (MO_Sub w0) [x, CmmLit (CmmInt i w1)]) | i < 0+  = getRegister' config plat (CmmMachOp (MO_Add w0) [x, CmmLit (CmmInt (-i) w1)])+++-- Generic case.+getRegister' config plat expr+  = case expr of+    CmmReg (CmmGlobal (GlobalRegUse PicBaseReg _))+      -> pprPanic "getRegisterReg-memory" (ppr $ PicBaseReg)+    CmmLit lit+      -> case lit of++        -- Use wzr xzr for CmmInt 0 if the width matches up, otherwise do a move.+        -- TODO: Reenable after https://gitlab.haskell.org/ghc/ghc/-/issues/23632 is fixed.+        -- CmmInt 0 W32 -> do+        --   let format = intFormat W32+        --   return (Fixed format reg_zero (unitOL $ (COMMENT ((text . show $ expr))) ))+        -- CmmInt 0 W64 -> do+        --   let format = intFormat W64+        --   return (Fixed format reg_zero (unitOL $ (COMMENT ((text . show $ expr))) ))+        CmmInt i W8 | i >= 0 -> do+          return (Any (intFormat W8) (\dst -> unitOL $ annExpr expr (MOV (OpReg W8 dst) (OpImm (ImmInteger (narrowU W8 i))))))+        CmmInt i W16 | i >= 0 -> do+          return (Any (intFormat W16) (\dst -> unitOL $ annExpr expr (MOV (OpReg W16 dst) (OpImm (ImmInteger (narrowU W16 i))))))++        CmmInt i W8  -> do+          return (Any (intFormat W8) (\dst -> unitOL $ annExpr expr (MOV (OpReg W8 dst) (OpImm (ImmInteger (narrowU W8 i))))))+        CmmInt i W16 -> do+          return (Any (intFormat W16) (\dst -> unitOL $ annExpr expr (MOV (OpReg W16 dst) (OpImm (ImmInteger (narrowU W16 i))))))++        -- We need to be careful to not shorten this for negative literals.+        -- Those need the upper bits set. We'd either have to explicitly sign+        -- or figure out something smarter. Lowered to+        -- `MOV dst XZR`+        CmmInt i w | i >= 0+                   , Just imm_op <- getMovWideImm i w -> do+          return (Any (intFormat w) (\dst -> unitOL $ annExpr expr (MOVZ (OpReg w dst) imm_op)))++        CmmInt i w | isNbitEncodeable 16 i, i >= 0 -> do+          return (Any (intFormat w) (\dst -> unitOL $ annExpr expr (MOV (OpReg W16 dst) (OpImm (ImmInteger i)))))++        CmmInt i w | isNbitEncodeable 32 i, i >= 0 -> do+          let  half0 = fromIntegral (fromIntegral i :: Word16)+               half1 = fromIntegral (fromIntegral (i `shiftR` 16) :: Word16)+          return (Any (intFormat w) (\dst -> toOL [ annExpr expr+                                                  $ MOV (OpReg W32 dst) (OpImm (ImmInt half0))+                                                  , MOVK (OpReg W32 dst) (OpImmShift (ImmInt half1) SLSL 16)+                                                  ]))+        -- fallback for W32+        CmmInt i W32 -> do+          let  half0 = fromIntegral (fromIntegral i :: Word16)+               half1 = fromIntegral (fromIntegral (i `shiftR` 16) :: Word16)+          return (Any (intFormat W32) (\dst -> toOL [ annExpr expr+                                                    $ MOV (OpReg W32 dst) (OpImm (ImmInt half0))+                                                    , MOVK (OpReg W32 dst) (OpImmShift (ImmInt half1) SLSL 16)+                                                    ]))+        -- anything else+        CmmInt i W64 -> do+          let  half0 = fromIntegral (fromIntegral i :: Word16)+               half1 = fromIntegral (fromIntegral (i `shiftR` 16) :: Word16)+               half2 = fromIntegral (fromIntegral (i `shiftR` 32) :: Word16)+               half3 = fromIntegral (fromIntegral (i `shiftR` 48) :: Word16)+          return (Any (intFormat W64) (\dst -> toOL [ annExpr expr+                                                    $ MOV (OpReg W64 dst) (OpImm (ImmInt half0))+                                                    , MOVK (OpReg W64 dst) (OpImmShift (ImmInt half1) SLSL 16)+                                                    , MOVK (OpReg W64 dst) (OpImmShift (ImmInt half2) SLSL 32)+                                                    , MOVK (OpReg W64 dst) (OpImmShift (ImmInt half3) SLSL 48)+                                                    ]))+        CmmInt _i rep -> do+          (op, imm_code) <- litToImm' lit+          return (Any (intFormat rep) (\dst -> imm_code `snocOL` annExpr expr (MOV (OpReg rep dst) op)))++        -- floatToBytes (fromRational f)+        CmmFloat 0 w   -> do+          (op, imm_code) <- litToImm' lit+          return (Any (floatFormat w) (\dst -> imm_code `snocOL` annExpr expr (MOV (OpReg w dst) op)))++        CmmFloat _f W8  -> pprPanic "getRegister' (CmmLit:CmmFloat), no support for bytes" (pdoc plat expr)+        CmmFloat _f W16 -> pprPanic "getRegister' (CmmLit:CmmFloat), no support for halfs" (pdoc plat expr)+        CmmFloat f W32 -> do+          let word = castFloatToWord32 (fromRational f) :: Word32+              half0 = fromIntegral (fromIntegral word :: Word16)+              half1 = fromIntegral (fromIntegral (word `shiftR` 16) :: Word16)+          tmp <- getNewRegNat (intFormat W32)+          return (Any (floatFormat W32) (\dst -> toOL [ annExpr expr+                                                      $ MOV (OpReg W32 tmp) (OpImm (ImmInt half0))+                                                      , MOVK (OpReg W32 tmp) (OpImmShift (ImmInt half1) SLSL 16)+                                                      , MOV (OpReg W32 dst) (OpReg W32 tmp)+                                                      ]))+        CmmFloat f W64 -> do+          let word = castDoubleToWord64 (fromRational f) :: Word64+              half0 = fromIntegral (fromIntegral word :: Word16)+              half1 = fromIntegral (fromIntegral (word `shiftR` 16) :: Word16)+              half2 = fromIntegral (fromIntegral (word `shiftR` 32) :: Word16)+              half3 = fromIntegral (fromIntegral (word `shiftR` 48) :: Word16)+          tmp <- getNewRegNat (intFormat W64)+          return (Any (floatFormat W64) (\dst -> toOL [ annExpr expr+                                                      $ MOV (OpReg W64 tmp) (OpImm (ImmInt half0))+                                                      , MOVK (OpReg W64 tmp) (OpImmShift (ImmInt half1) SLSL 16)+                                                      , MOVK (OpReg W64 tmp) (OpImmShift (ImmInt half2) SLSL 32)+                                                      , MOVK (OpReg W64 tmp) (OpImmShift (ImmInt half3) SLSL 48)+                                                      , MOV (OpReg W64 dst) (OpReg W64 tmp)+                                                      ]))+        CmmFloat _f _w -> pprPanic "getRegister' (CmmLit:CmmFloat), unsupported float lit" (pdoc plat expr)+        CmmVec _ -> pprPanic "getRegister' (CmmLit:CmmVec): " (pdoc plat expr)+        CmmLabel _lbl -> do+          (op, imm_code) <- litToImm' lit+          let rep = cmmLitType plat lit+              format = cmmTypeFormat rep+          return (Any format (\dst -> imm_code `snocOL` (annExpr expr $ LDR format (OpReg (formatToWidth format) dst) op)))++        CmmLabelOff _lbl off | isNbitEncodeable 12 (fromIntegral off) -> do+          (op, imm_code) <- litToImm' lit+          let rep = cmmLitType plat lit+              format = cmmTypeFormat rep+          return (Any format (\dst -> imm_code `snocOL` LDR format (OpReg (formatToWidth format) dst) op))++        CmmLabelOff lbl off -> do+          (op, imm_code) <- litToImm' (CmmLabel lbl)+          let rep = cmmLitType plat lit+              format = cmmTypeFormat rep+              width = typeWidth rep+          (off_r, _off_format, off_code) <- getSomeReg $ CmmLit (CmmInt (fromIntegral off) width)+          return (Any format (\dst -> imm_code `appOL` off_code `snocOL` LDR format (OpReg (formatToWidth format) dst) op `snocOL` ADD (OpReg width dst) (OpReg width dst) (OpReg width off_r)))++        CmmLabelDiffOff _ _ _ _ -> pprPanic "getRegister' (CmmLit:CmmLabelOff): " (pdoc plat expr)+        CmmBlock _ -> pprPanic "getRegister' (CmmLit:CmmLabelOff): " (pdoc plat expr)+        CmmHighStackMark -> pprPanic "getRegister' (CmmLit:CmmLabelOff): " (pdoc plat expr)+    CmmLoad mem rep _ -> do+      Amode addr addr_code <- getAmode plat (typeWidth rep) mem+      let format = cmmTypeFormat rep+      return (Any format (\dst -> addr_code `snocOL` LDR format (OpReg (formatToWidth format) dst) (OpAddr addr)))+    CmmStackSlot _ _+      -> pprPanic "getRegister' (CmmStackSlot): " (pdoc plat expr)+    CmmReg reg+      -> return (Fixed (cmmTypeFormat (cmmRegType reg))+                       (getRegisterReg plat reg)+                       nilOL)+    CmmRegOff reg off ->+      -- If we got here we will load the address into a register either way. So we might as well just expand+      -- and re-use the existing code path to handle "reg + off".+      let !width = cmmRegWidth reg+      in getRegister' config plat (CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)])++    -- for MachOps, see GHC.Cmm.MachOp+    -- For CmmMachOp, see GHC.Cmm.Expr++    -- Handle MO_RelaxedRead as a normal CmmLoad, to allow+    -- non-trivial addressing modes to be used.+    CmmMachOp (MO_RelaxedRead w) [e] ->+      getRegister (CmmLoad e (cmmBits w) NaturallyAligned)++    CmmMachOp op [e] -> do+      (reg, _format, code) <- getSomeReg e+      case op of+        MO_Not w -> return $ Any (intFormat w) $ \dst ->+            let w' = opRegWidth w+             in code `snocOL`+                MVN (OpReg w' dst) (OpReg w' reg) `appOL`+                truncateReg w' w dst -- See Note [Signed arithmetic on AArch64]++        MO_S_Neg w -> negate code w reg+        MO_F_Neg w -> return $ Any (floatFormat w) (\dst -> code `snocOL` NEG (OpReg w dst) (OpReg w reg))++        MO_SF_Round    from to -> return $ Any (floatFormat to) (\dst -> code `snocOL` SCVTF (OpReg to dst) (OpReg from reg))  -- (Signed ConVerT Float)+        MO_FS_Truncate from to -> return $ Any (intFormat to) (\dst -> code `snocOL` FCVTZS (OpReg to dst) (OpReg from reg)) -- (float convert (-> zero) signed)++        -- TODO this is very hacky+        -- Note, UBFM and SBFM expect source and target register to be of the same size, so we'll use @max from to@+        -- UBFM will set the high bits to 0. SBFM will copy the sign (sign extend).+        MO_UU_Conv from to -> return $ Any (intFormat to) (\dst -> code `snocOL` UBFM (OpReg (max from to) dst) (OpReg (max from to) reg) (OpImm (ImmInt 0)) (toImm (min from to)))+        MO_SS_Conv from to -> ss_conv from to reg code+        MO_FF_Conv from to -> return $ Any (floatFormat to) (\dst -> code `snocOL` FCVT (OpReg to dst) (OpReg from reg))+        MO_WF_Bitcast w    -> return $ Any (floatFormat w)  (\dst -> code `snocOL` FMOV (OpReg w dst) (OpReg w reg))+        MO_FW_Bitcast w    -> return $ Any (intFormat w)    (\dst -> code `snocOL` FMOV (OpReg w dst) (OpReg w reg))++        -- Conversions+        MO_XX_Conv _from to -> swizzleRegisterRep (intFormat to) <$> getRegister e++        MO_Eq {} -> notUnary+        MO_Ne {} -> notUnary+        MO_Mul {} -> notUnary+        MO_S_MulMayOflo {} -> notUnary+        MO_S_Quot {} -> notUnary+        MO_S_Rem {} -> notUnary+        MO_U_Quot {} -> notUnary+        MO_U_Rem {} -> notUnary+        MO_S_Ge {} -> notUnary+        MO_S_Le {} -> notUnary+        MO_S_Gt {} -> notUnary+        MO_S_Lt {} -> notUnary+        MO_U_Ge {} -> notUnary+        MO_U_Le {} -> notUnary+        MO_U_Gt {} -> notUnary+        MO_U_Lt {} -> notUnary+        MO_F_Add {} -> notUnary+        MO_F_Sub {} -> notUnary+        MO_F_Mul {} -> notUnary+        MO_F_Quot {} -> notUnary+        MO_FMA {} -> notUnary+        MO_F_Eq {} -> notUnary+        MO_F_Ne {} -> notUnary+        MO_F_Ge {} -> notUnary+        MO_F_Le {} -> notUnary+        MO_F_Gt {} -> notUnary+        MO_F_Lt {} -> notUnary+        MO_And {} -> notUnary+        MO_Or {} -> notUnary+        MO_Xor {} -> notUnary+        MO_Shl {} -> notUnary+        MO_U_Shr {} -> notUnary+        MO_S_Shr {} -> notUnary+        MO_V_Insert {} -> notUnary+        MO_V_Extract {} -> notUnary+        MO_V_Add {} -> notUnary+        MO_V_Sub {} -> notUnary+        MO_V_Mul {} -> notUnary+        MO_VS_Neg {} -> notUnary+        MO_V_Shuffle {} -> notUnary+        MO_VF_Shuffle  {} -> notUnary+        MO_VF_Insert {} -> notUnary+        MO_VF_Extract {} -> notUnary+        MO_VF_Add {} -> notUnary+        MO_VF_Sub {} -> notUnary+        MO_VF_Mul {} -> notUnary+        MO_VF_Quot {} -> notUnary+        MO_Add {} -> notUnary+        MO_Sub {} -> notUnary++        MO_F_Min {} -> notUnary+        MO_F_Max {} -> notUnary+        MO_VU_Min {} -> notUnary+        MO_VU_Max {} -> notUnary+        MO_VS_Min {} -> notUnary+        MO_VS_Max {} -> notUnary+        MO_VF_Min {} -> notUnary+        MO_VF_Max {} -> notUnary++        MO_AlignmentCheck {} ->+          pprPanic "getRegister' (monadic CmmMachOp):" (pdoc plat expr)++        MO_V_Broadcast {} -> vectorsNeedLlvm+        MO_VF_Broadcast {} -> vectorsNeedLlvm+        MO_VF_Neg {} -> vectorsNeedLlvm+      where+        notUnary = pprPanic "getRegister' (non-unary CmmMachOp with 1 argument):" (pdoc plat expr)+        vectorsNeedLlvm =+            sorry "SIMD operations on AArch64 currently require the LLVM backend"+        toImm W8 =  (OpImm (ImmInt 7))+        toImm W16 = (OpImm (ImmInt 15))+        toImm W32 = (OpImm (ImmInt 31))+        toImm W64 = (OpImm (ImmInt 63))+        toImm W128 = (OpImm (ImmInt 127))+        toImm W256 = (OpImm (ImmInt 255))+        toImm W512 = (OpImm (ImmInt 511))++        -- In the case of 16- or 8-bit values we need to sign-extend to 32-bits+        -- See Note [Signed arithmetic on AArch64].+        negate code w reg = do+            let w' = opRegWidth w+            (reg', code_sx) <- signExtendReg w w' reg+            return $ Any (intFormat w) $ \dst ->+                code `appOL`+                code_sx `snocOL`+                NEG (OpReg w' dst) (OpReg w' reg') `appOL`+                truncateReg w' w dst++        ss_conv from to reg code =+            let w' = opRegWidth (max from to)+            in return $ Any (intFormat to) $ \dst ->+                code `snocOL`+                SBFM (OpReg w' dst) (OpReg w' reg) (OpImm (ImmInt 0)) (toImm (min from to)) `appOL`+                -- At this point an 8- or 16-bit value would be sign-extended+                -- to 32-bits. Truncate back down the final width.+                truncateReg w' to dst++    -- Dyadic machops:+    --+    -- The general idea is:+    -- compute x<i> <- x+    -- compute x<j> <- y+    -- OP x<r>, x<i>, x<j>+    --+    -- TODO: for now we'll only implement the 64bit versions. And rely on the+    --      fallthrough to alert us if things go wrong!+    -- OPTIMIZATION WARNING: Dyadic CmmMachOp destructuring+    -- 0. TODO This should not exist! Rewrite: Reg +- 0 -> Reg+    CmmMachOp (MO_Add _) [expr'@(CmmReg (CmmGlobal _r)), CmmLit (CmmInt 0 _)] -> getRegister' config plat expr'+    CmmMachOp (MO_Sub _) [expr'@(CmmReg (CmmGlobal _r)), CmmLit (CmmInt 0 _)] -> getRegister' config plat expr'+    -- Immediates are handled via `getArithImm` in the generic code path.++    CmmMachOp (MO_U_Quot w) [x, y] | w == W8 -> do+      (reg_x, _format_x, code_x) <- getSomeReg x+      (reg_y, _format_y, code_y) <- getSomeReg y+      return $ Any (intFormat w) (\dst -> code_x `appOL` code_y `snocOL` annExpr expr (UXTB (OpReg w reg_x) (OpReg w reg_x)) `snocOL`+                                                                        (UXTB (OpReg w reg_y) (OpReg w reg_y)) `snocOL`+                                                                        (UDIV (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y)))+    CmmMachOp (MO_U_Quot w) [x, y] | w == W16 -> do+      (reg_x, _format_x, code_x) <- getSomeReg x+      (reg_y, _format_y, code_y) <- getSomeReg y+      return $ Any (intFormat w) (\dst -> code_x `appOL` code_y `snocOL` annExpr expr (UXTH (OpReg w reg_x) (OpReg w reg_x)) `snocOL`+                                                                        (UXTH (OpReg w reg_y) (OpReg w reg_y)) `snocOL`+                                                                        (UDIV (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y)))++    -- 2. Shifts. x << n, x >> n.+    CmmMachOp (MO_Shl w) [x, (CmmLit (CmmInt n _))]+      | w == W32 || w == W64+      , 0 <= n, n < fromIntegral (widthInBits w) -> do+      (reg_x, _format_x, code_x) <- getSomeReg x+      return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (LSL (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n))))++    CmmMachOp (MO_S_Shr w) [x, (CmmLit (CmmInt n _))] | w == W8, 0 <= n, n < 8 -> do+      (reg_x, _format_x, code_x) <- getSomeReg x+      return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (SBFX (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)) (OpImm (ImmInteger (8-n))))+                                                 `snocOL` (UXTB (OpReg w dst) (OpReg w dst))) -- See Note [Signed arithmetic on AArch64]+    CmmMachOp (MO_S_Shr w) [x, y] | w == W8 -> do+      (reg_x, _format_x, code_x) <- getSomeReg x+      (reg_y, _format_y, code_y) <- getSomeReg y+      return $ Any (intFormat w) (\dst -> code_x `appOL` code_y `snocOL` annExpr expr (SXTB (OpReg w reg_x) (OpReg w reg_x)) `snocOL`+                                                                         (ASR (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y)) `snocOL`+                                                                         (UXTB (OpReg w dst) (OpReg w dst))) -- See Note [Signed arithmetic on AArch64]++    CmmMachOp (MO_S_Shr w) [x, (CmmLit (CmmInt n _))] | w == W16, 0 <= n, n < 16 -> do+      (reg_x, _format_x, code_x) <- getSomeReg x+      return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (SBFX (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)) (OpImm (ImmInteger (16-n))))+                                                 `snocOL` (UXTH (OpReg w dst) (OpReg w dst))) -- See Note [Signed arithmetic on AArch64]+    CmmMachOp (MO_S_Shr w) [x, y] | w == W16 -> do+      (reg_x, _format_x, code_x) <- getSomeReg x+      (reg_y, _format_y, code_y) <- getSomeReg y+      return $ Any (intFormat w) (\dst -> code_x `appOL` code_y `snocOL` annExpr expr (SXTH (OpReg w reg_x) (OpReg w reg_x)) `snocOL`+                                                                         (ASR (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y)) `snocOL`+                                                                         (UXTH (OpReg w dst) (OpReg w dst))) -- See Note [Signed arithmetic on AArch64]++    CmmMachOp (MO_S_Shr w) [x, (CmmLit (CmmInt n _))]+      | w == W32 || w == W64+      , 0 <= n, n < fromIntegral (widthInBits w) -> do+      (reg_x, _format_x, code_x) <- getSomeReg x+      return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (ASR (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n))))++    CmmMachOp (MO_U_Shr w) [x, (CmmLit (CmmInt n _))] | w == W8, 0 <= n, n < 8 -> do+      (reg_x, _format_x, code_x) <- getSomeReg x+      return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (UBFX (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)) (OpImm (ImmInteger (8-n)))))+    CmmMachOp (MO_U_Shr w) [x, y] | w == W8 -> do+      (reg_x, _format_x, code_x) <- getSomeReg x+      (reg_y, _format_y, code_y) <- getSomeReg y+      return $ Any (intFormat w) (\dst -> code_x `appOL` code_y `snocOL` annExpr expr (UXTB (OpReg w reg_x) (OpReg w reg_x)) `snocOL`+                                                                        (ASR (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y)))++    CmmMachOp (MO_U_Shr w) [x, (CmmLit (CmmInt n _))] | w == W16, 0 <= n, n < 16 -> do+      (reg_x, _format_x, code_x) <- getSomeReg x+      return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (UBFX (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)) (OpImm (ImmInteger (16-n)))))+    CmmMachOp (MO_U_Shr w) [x, y] | w == W16 -> do+      (reg_x, _format_x, code_x) <- getSomeReg x+      (reg_y, _format_y, code_y) <- getSomeReg y+      return $ Any (intFormat w) (\dst -> code_x `appOL` code_y `snocOL` annExpr expr (UXTH (OpReg w reg_x) (OpReg w reg_x))+                                                                `snocOL` (ASR (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y)))++    CmmMachOp (MO_U_Shr w) [x, (CmmLit (CmmInt n _))]+      | w == W32 || w == W64+      , 0 <= n, n < fromIntegral (widthInBits w) -> do+      (reg_x, _format_x, code_x) <- getSomeReg x+      return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (LSR (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n))))++    -- 3. Logic &&, ||+    CmmMachOp (MO_And w) [(CmmReg reg), CmmLit (CmmInt n _)] | isAArch64Bitmask (opRegWidth w') (fromIntegral n) ->+      return $ Any (intFormat w) (\d -> unitOL $ annExpr expr (AND (OpReg w d) (OpReg w' r') (OpImm (ImmInteger n))))+      where w' = formatToWidth (cmmTypeFormat (cmmRegType reg))+            r' = getRegisterReg plat reg++    CmmMachOp (MO_Or w) [(CmmReg reg), CmmLit (CmmInt n _)] | isAArch64Bitmask (opRegWidth w') (fromIntegral n) ->+      return $ Any (intFormat w) (\d -> unitOL $ annExpr expr (ORR (OpReg w d) (OpReg w' r') (OpImm (ImmInteger n))))+      where w' = formatToWidth (cmmTypeFormat (cmmRegType reg))+            r' = getRegisterReg plat reg++    -- Generic binary case.+    CmmMachOp op [x, y] -> do+      -- alright, so we have an operation, and two expressions. And we want to essentially do+      -- ensure we get float regs (TODO(Ben): What?)+      let withTempIntReg w op = OpReg w <$> getNewRegNat (intFormat w) >>= op+          -- withTempFloatReg w op = OpReg w <$> getNewRegNat (floatFormat w) >>= op++          -- A "plain" operation.+          bitOpImm w op encode_imm = do+            -- compute x<m> <- x+            -- compute x<o> <- y+            -- <OP> x<n>, x<m>, x<o>+            (reg_x, format_x, code_x) <- getSomeReg x+            (op_y, format_y, code_y) <- case y of+              CmmLit (CmmInt n w)+                | Just imm_operand_y <- encode_imm n w+                -> return (imm_operand_y, intFormat w, nilOL)+              _ -> do+                  (reg_y, format_y, code_y) <- getSomeReg y+                  return (OpReg w reg_y, format_y, code_y)+            massertPpr (isIntFormat format_x == isIntFormat format_y) $ text "bitOpImm: incompatible"+            return $ Any (intFormat w) (\dst ->+                code_x `appOL`+                code_y `appOL`+                op (OpReg w dst) (OpReg w reg_x) op_y)++          -- A (potentially signed) integer operation.+          -- In the case of 8- and 16-bit signed arithmetic we must first+          -- sign-extend both arguments to 32-bits.+          -- See Note [Signed arithmetic on AArch64].+          intOpImm :: Bool -> Width -> (Operand -> Operand -> Operand -> OrdList Instr) -> (Integer -> Width -> Maybe Operand) -> NatM (Register)+          intOpImm {- is signed -} True  w op _encode_imm = intOp True w op+          intOpImm                 False w op  encode_imm = do+              -- compute x<m> <- x+              -- compute x<o> <- y+              -- <OP> x<n>, x<m>, x<o>+              (reg_x, format_x, code_x) <- getSomeReg x+              (op_y, format_y, code_y) <- case y of+                CmmLit (CmmInt n w)+                  | Just imm_operand_y <- encode_imm n w+                  -> return (imm_operand_y, intFormat w, nilOL)+                _ -> do+                    (reg_y, format_y, code_y) <- getSomeReg y+                    return (OpReg w reg_y, format_y, code_y)+              massertPpr (isIntFormat format_x && isIntFormat format_y) $ text "intOp: non-int"+              -- This is the width of the registers on which the operation+              -- should be performed.+              let w' = opRegWidth w+              return $ Any (intFormat w) $ \dst ->+                  code_x `appOL`+                  code_y `appOL`+                  op (OpReg w' dst) (OpReg w' reg_x) (op_y) `appOL`+                  truncateReg w' w dst -- truncate back to the operand's original width++          -- A (potentially signed) integer operation.+          -- In the case of 8- and 16-bit signed arithmetic we must first+          -- sign-extend both arguments to 32-bits.+          -- See Note [Signed arithmetic on AArch64].+          intOp is_signed w op = do+              -- compute x<m> <- x+              -- compute x<o> <- y+              -- <OP> x<n>, x<m>, x<o>+              (reg_x, format_x, code_x) <- getSomeReg x+              (reg_y, format_y, code_y) <- getSomeReg y+              massertPpr (isIntFormat format_x && isIntFormat format_y) $ text "intOp: non-int"+              -- This is the width of the registers on which the operation+              -- should be performed.+              let w' = opRegWidth w+                  signExt r+                    | not is_signed  = return (r, nilOL)+                    | otherwise      = signExtendReg w w' r+              (reg_x_sx, code_x_sx) <- signExt reg_x+              (reg_y_sx, code_y_sx) <- signExt reg_y+              return $ Any (intFormat w) $ \dst ->+                  code_x `appOL`+                  code_y `appOL`+                  -- sign-extend both operands+                  code_x_sx `appOL`+                  code_y_sx `appOL`+                  op (OpReg w' dst) (OpReg w' reg_x_sx) (OpReg w' reg_y_sx) `appOL`+                  truncateReg w' w dst -- truncate back to the operand's original width++          floatOp w op = do+            (reg_fx, format_x, code_fx) <- getFloatReg x+            (reg_fy, format_y, code_fy) <- getFloatReg y+            massertPpr (isFloatFormat format_x && isFloatFormat format_y) $ text "floatOp: non-float"+            return $ Any (floatFormat w) (\dst -> code_fx `appOL` code_fy `appOL` op (OpReg w dst) (OpReg w reg_fx) (OpReg w reg_fy))++          -- need a special one for conditionals, as they return ints+          floatCond w op = do+            (reg_fx, format_x, code_fx) <- getFloatReg x+            (reg_fy, format_y, code_fy) <- getFloatReg y+            massertPpr (isFloatFormat format_x && isFloatFormat format_y) $ text "floatCond: non-float"+            return $ Any (intFormat w) (\dst -> code_fx `appOL` code_fy `appOL` op (OpReg w dst) (OpReg w reg_fx) (OpReg w reg_fy))++      case op of+        -- Integer operations+        -- Add/Sub should only be Integer Options.+        MO_Add w -> intOpImm False w (\d x y -> unitOL $ annExpr expr (ADD d x y)) getArithImm+        -- TODO: Handle sub-word case+        MO_Sub w -> intOpImm False w (\d x y -> unitOL $ annExpr expr (SUB d x y)) getArithImm++        -- Note [CSET]+        -- ~~~~~~~~~~~+        -- Setting conditional flags: the architecture internally knows the+        -- following flag bits.  And based on thsoe comparisons as in the+        -- table below.+        --+        --    31  30  29  28+        --  .---+---+---+---+-- - -+        --  | N | Z | C | V |+        --  '---+---+---+---+-- - -+        --  Negative+        --  Zero+        --  Carry+        --  oVerflow+        --+        --  .------+-------------------------------------+-----------------+----------.+        --  | Code | Meaning                             | Flags           | Encoding |+        --  |------+-------------------------------------+-----------------+----------|+        --  |  EQ  | Equal                               | Z = 1           | 0000     |+        --  |  NE  | Not Equal                           | Z = 0           | 0001     |+        --  |  HI  | Unsigned Higher                     | C = 1 && Z = 0  | 1000     |+        --  |  HS  | Unsigned Higher or Same             | C = 1           | 0010     |+        --  |  LS  | Unsigned Lower or Same              | C = 0 || Z = 1  | 1001     |+        --  |  LO  | Unsigned Lower                      | C = 0           | 0011     |+        --  |  GT  | Signed Greater Than                 | Z = 0 && N = V  | 1100     |+        --  |  GE  | Signed Greater Than or Equal        | N = V           | 1010     |+        --  |  LE  | Signed Less Than or Equal           | Z = 1 || N /= V | 1101     |+        --  |  LT  | Signed Less Than                    | N /= V          | 1011     |+        --  |  CS  | Carry Set (Unsigned Overflow)       | C = 1           | 0010     |+        --  |  CC  | Carry Clear (No Unsigned Overflow)  | C = 0           | 0011     |+        --  |  VS  | Signed Overflow                     | V = 1           | 0110     |+        --  |  VC  | No Signed Overflow                  | V = 0           | 0111     |+        --  |  MI  | Minus, Negative                     | N = 1           | 0100     |+        --  |  PL  | Plus, Positive or Zero (!)          | N = 0           | 0101     |+        --  |  AL  | Always                              | Any             | 1110     |+        --  |  NV  | Never                               | Any             | 1111     |+        --- '-------------------------------------------------------------------------'++        -- N.B. We needn't sign-extend sub-word size (in)equality comparisons+        -- since we don't care about ordering.+        MO_Eq w     -> bitOpImm w (\d x y -> toOL [ CMP x y, CSET d EQ ]) getArithImm+        MO_Ne w     -> bitOpImm w (\d x y -> toOL [ CMP x y, CSET d NE ]) getArithImm++        -- Signed multiply/divide+        MO_Mul w          -> intOp True w (\d x y -> unitOL $ MUL d x y)+        MO_S_MulMayOflo w -> do_mul_may_oflo w x y+        MO_S_Quot w       -> intOp True w (\d x y -> unitOL $ SDIV d x y)++        -- No native rem instruction. So we'll compute the following+        -- Rd  <- Rx / Ry             | 2 <- 7 / 3      -- SDIV Rd Rx Ry+        -- Rd' <- Rx - Rd * Ry        | 1 <- 7 - 2 * 3  -- MSUB Rd' Rd Ry Rx+        --        |     '---|----------------|---'   |+        --        |         '----------------|-------'+        --        '--------------------------'+        -- Note the swap in Rx and Ry.+        MO_S_Rem w -> withTempIntReg w $ \t ->+                      intOp True w (\d x y -> toOL [ SDIV t x y, MSUB d t y x ])++        -- Unsigned multiply/divide+        MO_U_Quot w -> intOp False w (\d x y -> unitOL $ UDIV d x y)+        MO_U_Rem w  -> withTempIntReg w $ \t ->+                       intOp False w (\d x y -> toOL [ UDIV t x y, MSUB d t y x ])++        -- Signed comparisons -- see Note [CSET]+        MO_S_Ge w     -> intOp True  w (\d x y -> toOL [ CMP x y, CSET d SGE ])+        MO_S_Le w     -> intOp True  w (\d x y -> toOL [ CMP x y, CSET d SLE ])+        MO_S_Gt w     -> intOp True  w (\d x y -> toOL [ CMP x y, CSET d SGT ])+        MO_S_Lt w     -> intOp True  w (\d x y -> toOL [ CMP x y, CSET d SLT ])++        -- Unsigned comparisons+        MO_U_Ge w     -> intOpImm False w (\d x y -> toOL [ CMP x y, CSET d UGE ]) getArithImm+        MO_U_Le w     -> intOpImm False w (\d x y -> toOL [ CMP x y, CSET d ULE ]) getArithImm+        MO_U_Gt w     -> intOpImm False w (\d x y -> toOL [ CMP x y, CSET d UGT ]) getArithImm+        MO_U_Lt w     -> intOpImm False w (\d x y -> toOL [ CMP x y, CSET d ULT ]) getArithImm++        -- Floating point arithmetic+        MO_F_Add w   -> floatOp w (\d x y -> unitOL $ ADD d x y)+        MO_F_Sub w   -> floatOp w (\d x y -> unitOL $ SUB d x y)+        MO_F_Mul w   -> floatOp w (\d x y -> unitOL $ MUL d x y)+        MO_F_Quot w  -> floatOp w (\d x y -> unitOL $ SDIV d x y)+        MO_F_Min w   -> floatOp w (\d x y -> unitOL $ FMIN d x y)+        MO_F_Max w   -> floatOp w (\d x y -> unitOL $ FMAX d x y)++        -- Floating point comparison+        MO_F_Eq w    -> floatCond w (\d x y -> toOL [ CMP x y, CSET d EQ ])+        MO_F_Ne w    -> floatCond w (\d x y -> toOL [ CMP x y, CSET d NE ])++        -- careful with the floating point operations.+        -- SLE is effectively LE or unordered (NaN)+        -- SLT is the same. ULE, and ULT will not return true for NaN.+        -- This is a bit counter-intuitive. Don't let yourself be fooled by+        -- the S/U prefix for floats, it's only meaningful for integers.+        MO_F_Ge w    -> floatCond w (\d x y -> toOL [ CMP x y, CSET d OGE ])+        MO_F_Le w    -> floatCond w (\d x y -> toOL [ CMP x y, CSET d OLE ]) -- x <= y <=> y > x+        MO_F_Gt w    -> floatCond w (\d x y -> toOL [ CMP x y, CSET d OGT ])+        MO_F_Lt w    -> floatCond w (\d x y -> toOL [ CMP x y, CSET d OLT ]) -- x < y <=> y >= x++        -- Bitwise operations+        MO_And   w -> bitOpImm w (\d x y -> unitOL $ AND d x y) getBitmaskImm+        MO_Or    w -> bitOpImm w (\d x y -> unitOL $ ORR d x y) getBitmaskImm+        MO_Xor   w -> bitOpImm w (\d x y -> unitOL $ EOR d x y) getBitmaskImm+        MO_Shl   w -> intOp False w (\d x y -> unitOL $ LSL d x y)+        MO_U_Shr w -> intOp False w (\d x y -> unitOL $ LSR d x y)+        MO_S_Shr w -> intOp True  w (\d x y -> unitOL $ ASR d x y)++        -- Non-dyadic MachOp with 2 arguments+        MO_S_Neg {} -> notDyadic+        MO_F_Neg {} -> notDyadic+        MO_FMA {} -> notDyadic+        MO_Not {} -> notDyadic+        MO_SF_Round {} -> notDyadic+        MO_FS_Truncate {} -> notDyadic+        MO_SS_Conv {} -> notDyadic+        MO_UU_Conv {} -> notDyadic+        MO_XX_Conv {} -> notDyadic+        MO_FF_Conv {} -> notDyadic+        MO_WF_Bitcast {} -> notDyadic+        MO_FW_Bitcast {} -> notDyadic+        MO_V_Broadcast {} -> notDyadic+        MO_VF_Broadcast {} -> notDyadic+        MO_V_Insert {} -> notDyadic+        MO_VF_Insert {} -> notDyadic+        MO_AlignmentCheck {} -> notDyadic+        MO_RelaxedRead {} -> notDyadic++        -- Vector operations: currently unsupported in the AArch64 NCG.+        MO_V_Extract {} -> vectorsNeedLlvm+        MO_V_Add {} -> vectorsNeedLlvm+        MO_V_Sub {} -> vectorsNeedLlvm+        MO_V_Mul {} -> vectorsNeedLlvm+        MO_VS_Neg {} -> vectorsNeedLlvm+        MO_VF_Extract {} -> vectorsNeedLlvm+        MO_VF_Add {} -> vectorsNeedLlvm+        MO_VF_Sub {} -> vectorsNeedLlvm+        MO_VF_Neg {} -> vectorsNeedLlvm+        MO_VF_Mul {} -> vectorsNeedLlvm+        MO_VF_Quot {} -> vectorsNeedLlvm+        MO_V_Shuffle {} -> vectorsNeedLlvm+        MO_VF_Shuffle {} -> vectorsNeedLlvm+        MO_VU_Min {} -> vectorsNeedLlvm+        MO_VU_Max {} -> vectorsNeedLlvm+        MO_VS_Min {} -> vectorsNeedLlvm+        MO_VS_Max {} -> vectorsNeedLlvm+        MO_VF_Min {} -> vectorsNeedLlvm+        MO_VF_Max {} -> vectorsNeedLlvm+        where+          notDyadic =+            pprPanic "getRegister' (non-dyadic CmmMachOp with 2 arguments): " $+              (pprMachOp op) <+> text "in" <+> (pdoc plat expr)+          vectorsNeedLlvm =+            sorry "SIMD operations on AArch64 currently require the LLVM backend"++    -- Generic ternary case.+    CmmMachOp op [x, y, z] ->++      case op of++        -- Floating-point fused multiply-add operations++        -- x86 fmadd    x * y + z <=> AArch64 fmadd : d =   r1 * r2 + r3+        -- x86 fmsub    x * y - z <=> AArch64 fnmsub: d =   r1 * r2 - r3+        -- x86 fnmadd - x * y + z <=> AArch64 fmsub : d = - r1 * r2 + r3+        -- x86 fnmsub - x * y - z <=> AArch64 fnmadd: d = - r1 * r2 - r3++        MO_FMA var l w+          | l == 1+          -> case var of+            FMAdd  -> float3Op w (\d n m a -> unitOL $ FMA FMAdd  d n m a)+            FMSub  -> float3Op w (\d n m a -> unitOL $ FMA FNMSub d n m a)+            FNMAdd -> float3Op w (\d n m a -> unitOL $ FMA FMSub  d n m a)+            FNMSub -> float3Op w (\d n m a -> unitOL $ FMA FNMAdd d n m a)+          | otherwise+          -> vectorsNeedLlvm++        MO_V_Insert {} -> vectorsNeedLlvm+        MO_VF_Insert {} -> vectorsNeedLlvm++        _ -> pprPanic "getRegister' (unhandled ternary CmmMachOp): " $+                (pprMachOp op) <+> text "in" <+> (pdoc plat expr)++      where+          vectorsNeedLlvm =+            sorry "SIMD operations on AArch64 currently require the LLVM backend"+          float3Op w op = do+            (reg_fx, format_x, code_fx) <- getFloatReg x+            (reg_fy, format_y, code_fy) <- getFloatReg y+            (reg_fz, format_z, code_fz) <- getFloatReg z+            massertPpr (isFloatFormat format_x && isFloatFormat format_y && isFloatFormat format_z) $+              text "float3Op: non-float"+            return $+              Any (floatFormat w) $ \ dst ->+                code_fx `appOL`+                code_fy `appOL`+                code_fz `appOL`+                op (OpReg w dst) (OpReg w reg_fx) (OpReg w reg_fy) (OpReg w reg_fz)++    CmmMachOp _op _xs+      -> pprPanic "getRegister' (variadic CmmMachOp): " (pdoc plat expr)++  where+    isNbitEncodeable :: Int -> Integer -> Bool+    isNbitEncodeable n_bits i = let shift = n_bits - 1 in (-1 `shiftL` shift) <= i && i < (1 `shiftL` shift)++    -- N.B. MUL does not set the overflow flag.+    -- These implementations are based on output from GCC 11.+    do_mul_may_oflo :: Width -> CmmExpr -> CmmExpr -> NatM Register+    do_mul_may_oflo w@W64 x y = do+        (reg_x, _format_x, code_x) <- getSomeReg x+        (reg_y, _format_y, code_y) <- getSomeReg y+        lo <- getNewRegNat II64+        hi <- getNewRegNat II64+        return $ Any (intFormat w) (\dst ->+            code_x `appOL`+            code_y `snocOL`+            MUL (OpReg w lo) (OpReg w reg_x) (OpReg w reg_y) `snocOL`+            SMULH (OpReg w hi) (OpReg w reg_x) (OpReg w reg_y) `snocOL`+            CMP (OpReg w hi) (OpRegShift w lo SASR 63) `snocOL`+            CSET (OpReg w dst) NE)++    do_mul_may_oflo W32 x y = do+        (reg_x, _format_x, code_x) <- getSomeReg x+        (reg_y, _format_y, code_y) <- getSomeReg y+        tmp1 <- getNewRegNat II64+        tmp2 <- getNewRegNat II64+        return $ Any (intFormat W32) (\dst ->+            code_x `appOL`+            code_y `snocOL`+            SMULL (OpReg W64 tmp1) (OpReg W32 reg_x) (OpReg W32 reg_y) `snocOL`+            ASR (OpReg W64 tmp2) (OpReg W64 tmp1) (OpImm (ImmInt 31)) `snocOL`+            CMP (OpReg W32 tmp2) (OpRegShift W32 tmp1 SASR 31) `snocOL`+            CSET (OpReg W32 dst) NE)++    do_mul_may_oflo w x y = do+        (reg_x, _format_x, code_x) <- getSomeReg x+        (reg_y, _format_y, code_y) <- getSomeReg y+        tmp1 <- getNewRegNat II32+        tmp2 <- getNewRegNat II32+        let extend dst arg =+              case w of+                W16 -> SXTH (OpReg W32 dst) (OpReg W32 arg)+                W8  -> SXTB (OpReg W32 dst) (OpReg W32 arg)+                _   -> panic "unreachable"+            cmp_ext_mode =+              case w of+                W16 -> EUXTH+                W8  -> EUXTB+                _   -> panic "unreachable"+            width = widthInBits w+            opInt = OpImm . ImmInt++        return $ Any (intFormat w) (\dst ->+            code_x `appOL`+            code_y `snocOL`+            extend tmp1 reg_x `snocOL`+            extend tmp2 reg_y `snocOL`+            MUL (OpReg W32 tmp1) (OpReg W32 tmp1) (OpReg W32 tmp2) `snocOL`+            SBFX (OpReg W64 tmp2) (OpReg W64 tmp1) (opInt $ width - 1) (opInt 1) `snocOL`+            UBFX (OpReg W32 tmp1) (OpReg W32 tmp1) (opInt width) (opInt width) `snocOL`+            CMP (OpReg W32 tmp1) (OpRegExt W32 tmp2 cmp_ext_mode 0) `snocOL`+            CSET (OpReg w dst) NE)++-- | Is a given number encodable as a bitmask immediate?+--+-- https://stackoverflow.com/questions/30904718/range-of-immediate-values-in-armv8-a64-assembly+isAArch64Bitmask :: Width -> Integer -> Bool+-- N.B. zero and ~0 are not encodable as bitmask immediates+isAArch64Bitmask width n =+  assert (width `elem` [W32,W64]) $+  case n of+    0 -> False+    _ | n == bit (widthInBits width) - 1+      -> False -- 1111...1111+      | otherwise+      -> (width == W64 && check 64) || check 32 || check 16 || check 8+  where+    -- Check whether @n@ can be represented as a subpattern of the given+    -- width.+    check width+      | hasOneRun subpat =+          let n' = fromIntegral (mkPat width subpat)+          in n == n'+      | otherwise = False+      where+        subpat :: Word64+        subpat = fromIntegral (n .&. (bit width - 1))++    -- Construct a bit-pattern from a repeated subpatterns the given width.+    mkPat :: Int -> Word64 -> Word64+    mkPat width subpat =+        foldl' (.|.) 0 [ subpat `shiftL` p | p <- [0, width..63] ]++    -- Does the given number's bit representation match the regular expression+    -- @0*1*0*@?+    hasOneRun :: Word64 -> Bool+    hasOneRun m =+        64 == popCount m + countLeadingZeros m + countTrailingZeros m++-- | Instructions to sign-extend the value in the given register from width @w@+-- up to width @w'@.+signExtendReg :: Width -> Width -> Reg -> NatM (Reg, OrdList Instr)+signExtendReg w w' r =+    case w of+      W64 -> noop+      W32+        | w' == W32 -> noop+        | otherwise -> extend SXTH+      W16           -> extend SXTH+      W8            -> extend SXTB+      _             -> panic "intOp"+  where+    noop = return (r, nilOL)+    extend instr = do+        r' <- getNewRegNat II64+        return (r', unitOL $ instr (OpReg w' r') (OpReg w' r))++-- | Instructions to truncate the value in the given register from width @w@+-- down to width @w'@.+truncateReg :: Width -> Width -> Reg -> OrdList Instr+truncateReg w w' r =+    case w of+      W64 -> nilOL+      W32+        | w' == W32 -> nilOL+      _   -> unitOL $ UBFM (OpReg w r)+                           (OpReg w r)+                           (OpImm (ImmInt 0))+                           (OpImm $ ImmInt $ widthInBits w' - 1)++-- -----------------------------------------------------------------------------+--  The 'Amode' type: Memory addressing modes passed up the tree.+data Amode = Amode AddrMode InstrBlock++getAmode :: Platform+         -> Width     -- ^ width of loaded value+         -> CmmExpr+         -> NatM Amode+-- TODO: Specialize stuff we can destructure here.++-- OPTIMIZATION WARNING: Addressing modes.+-- Addressing options:+getAmode platform w (CmmRegOff reg off)+  | isOffsetImm off w+  = return $ Amode (AddrRegImm reg' off') nilOL+    where reg' = getRegisterReg platform reg+          off' = ImmInt off++-- For Stores we often see something like this:+-- CmmStore (CmmMachOp (MO_Add w) [CmmLoad expr, CmmLit (CmmInt n w')]) (expr2)+-- E.g. a CmmStoreOff really. This can be translated to `str $expr2, [$expr, #n ]+-- for `n` in range.+getAmode _platform w (CmmMachOp (MO_Add _w) [expr, CmmLit (CmmInt off _w')])+  | isOffsetImm (fromIntegral off) w+  = do (reg, _format, code) <- getSomeReg expr+       return $ Amode (AddrRegImm reg (ImmInteger off)) code++getAmode _platform w (CmmMachOp (MO_Sub _w) [expr, CmmLit (CmmInt off _w')])+  | isOffsetImm (fromIntegral $ -off) w+  = do (reg, _format, code) <- getSomeReg expr+       return $ Amode (AddrRegImm reg (ImmInteger $ -off)) code++-- Generic case+getAmode _platform _ expr+  = do (reg, _format, code) <- getSomeReg expr+       return $ Amode (AddrReg reg) code++-- -----------------------------------------------------------------------------+-- Generating assignments++-- Assignments are really at the heart of the whole code generation+-- business.  Almost all top-level nodes of any real importance are+-- assignments, which correspond to loads, stores, or register+-- transfers.  If we're really lucky, some of the register transfers+-- will go away, because we can use the destination register to+-- complete the code generation for the right hand side.  This only+-- fails when the right hand side is forced into a fixed register+-- (e.g. the result of a call).++assignMem_IntCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock+assignReg_IntCode :: Format -> CmmReg  -> CmmExpr -> NatM InstrBlock++assignMem_FltCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock+assignReg_FltCode :: Format -> CmmReg  -> CmmExpr -> NatM InstrBlock++assignMem_IntCode rep addrE srcE+  = do+    (src_reg, _format, code) <- getSomeReg srcE+    platform <- getPlatform+    let w = formatToWidth rep+    Amode addr addr_code <- getAmode platform w addrE+    return $ COMMENT (text "CmmStore" <+> parens (text (show addrE)) <+> parens (text (show srcE)))+            `consOL` (code+            `appOL` addr_code+            `snocOL` STR rep (OpReg w src_reg) (OpAddr addr))++assignReg_IntCode _ reg src+  = do+    platform <- getPlatform+    let dst = getRegisterReg platform reg+    r <- getRegister src+    return $ case r of+      Any _ code              -> COMMENT (text "CmmAssign" <+> parens (text (show reg)) <+> parens (text (show src))) `consOL` code dst+      Fixed format freg fcode -> COMMENT (text "CmmAssign" <+> parens (text (show reg)) <+> parens (text (show src))) `consOL` (fcode `snocOL` MOV (OpReg (formatToWidth format) dst) (OpReg (formatToWidth format) freg))++-- Let's treat Floating point stuff+-- as integer code for now. Opaque.+assignMem_FltCode = assignMem_IntCode+assignReg_FltCode = assignReg_IntCode++-- -----------------------------------------------------------------------------+-- Jumps++genJump :: CmmExpr{-the branch target-} -> NatM InstrBlock+genJump expr@(CmmLit (CmmLabel lbl)) = do+  cur_mod <- getThisModuleNat+  !useFarJumps <- ncgEnableInterModuleFarJumps <$> getConfig+  let is_local = isLocalCLabel cur_mod lbl++  -- We prefer to generate a near jump using a simble `B` instruction+  -- with a range (+/-128MB). But if the target is outside the current module+  -- we might have to account for large code offsets. (#24648)+  if not useFarJumps || is_local+    then return $ unitOL (annExpr expr (J (TLabel lbl)))+    else do+      (target, _format, code) <- getSomeReg expr+      return (code `appOL` unitOL (annExpr expr (J (TReg target))))++genJump expr = do+    (target, _format, code) <- getSomeReg expr+    return (code `appOL` unitOL (annExpr expr (J (TReg target))))++-- -----------------------------------------------------------------------------+--  Unconditional branches+genBranch :: BlockId -> NatM InstrBlock+genBranch = return . toOL . mkJumpInstr++-- -----------------------------------------------------------------------------+-- Conditional branches+genCondJump+    :: BlockId+    -> CmmExpr+    -> NatM InstrBlock+genCondJump bid expr = do+    case expr of+      -- Optimized == 0 case.+      CmmMachOp (MO_Eq w) [x, CmmLit (CmmInt 0 _)] -> do+        (reg_x, _format_x, code_x) <- getSomeReg x+        return $ code_x `snocOL` (annExpr expr (CBZ (OpReg w reg_x) (TBlock bid)))++      -- Optimized /= 0 case.+      CmmMachOp (MO_Ne w) [x, CmmLit (CmmInt 0 _)] -> do+        (reg_x, _format_x, code_x) <- getSomeReg x+        return $ code_x `snocOL`  (annExpr expr (CBNZ (OpReg w reg_x) (TBlock bid)))++      -- Generic case.+      CmmMachOp mop [x, y] -> do++        let ubcond w cmp = do+                -- compute both sides.+                (reg_x, _format_x, code_x) <- getSomeReg x+                (reg_y, _format_y, code_y) <- getSomeReg y+                let x' = OpReg w reg_x+                    y' = OpReg w reg_y+                return $ case w of+                  W8  -> code_x `appOL` code_y `appOL` toOL [ UXTB x' x', UXTB y' y', CMP x' y', (annExpr expr (BCOND cmp (TBlock bid))) ]+                  W16 -> code_x `appOL` code_y `appOL` toOL [ UXTH x' x', UXTH y' y', CMP x' y', (annExpr expr (BCOND cmp (TBlock bid))) ]+                  _   -> code_x `appOL` code_y `appOL` toOL [                         CMP x' y', (annExpr expr (BCOND cmp (TBlock bid))) ]++            sbcond w cmp = do+                -- compute both sides.+                (reg_x, _format_x, code_x) <- getSomeReg x+                (reg_y, _format_y, code_y) <- getSomeReg y+                let x' = OpReg w reg_x+                    y' = OpReg w reg_y+                return $ case w of+                  W8  -> code_x `appOL` code_y `appOL` toOL [ SXTB x' x', SXTB y' y', CMP x' y', (annExpr expr (BCOND cmp (TBlock bid))) ]+                  W16 -> code_x `appOL` code_y `appOL` toOL [ SXTH x' x', SXTH y' y', CMP x' y', (annExpr expr (BCOND cmp (TBlock bid))) ]+                  _   -> code_x `appOL` code_y `appOL` toOL [                         CMP x' y', (annExpr expr (BCOND cmp (TBlock bid))) ]++            fbcond w cmp = do+              -- ensure we get float regs+              (reg_fx, _format_fx, code_fx) <- getFloatReg x+              (reg_fy, _format_fy, code_fy) <- getFloatReg y+              return $ code_fx `appOL` code_fy `snocOL` CMP (OpReg w reg_fx) (OpReg w reg_fy) `snocOL` (annExpr expr (BCOND cmp (TBlock bid)))++        case mop of+          MO_F_Eq w -> fbcond w EQ+          MO_F_Ne w -> fbcond w NE++          MO_F_Gt w -> fbcond w OGT+          MO_F_Ge w -> fbcond w OGE+          MO_F_Lt w -> fbcond w OLT+          MO_F_Le w -> fbcond w OLE++          MO_Eq w   -> sbcond w EQ+          MO_Ne w   -> sbcond w NE++          MO_S_Gt w -> sbcond w SGT+          MO_S_Ge w -> sbcond w SGE+          MO_S_Lt w -> sbcond w SLT+          MO_S_Le w -> sbcond w SLE+          MO_U_Gt w -> ubcond w UGT+          MO_U_Ge w -> ubcond w UGE+          MO_U_Lt w -> ubcond w ULT+          MO_U_Le w -> ubcond w ULE+          _ -> pprPanic "AArch64.genCondJump:case mop: " (text $ show expr)+      _ -> pprPanic "AArch64.genCondJump: " (text $ show expr)++-- A conditional jump with at least +/-128M jump range+genCondFarJump :: MonadGetUnique m => Cond -> Target -> m InstrBlock+genCondFarJump cond far_target = do+  skip_lbl_id <- newBlockId+  jmp_lbl_id <- newBlockId++  -- TODO: We can improve this by inverting the condition+  -- but it's not quite trivial since we don't know if we+  -- need to consider float orderings.+  -- So we take the hit of the additional jump in the false+  -- case for now.+  return $ toOL [ BCOND cond (TBlock jmp_lbl_id)+                , B (TBlock skip_lbl_id)+                , NEWBLOCK jmp_lbl_id+                , B far_target+                , NEWBLOCK skip_lbl_id]++genCondBranch :: BlockId      -- the true branch target+    -> BlockId      -- the false branch target+    -> CmmExpr      -- the condition on which to branch+    -> NatM InstrBlock -- Instructions++genCondBranch true false expr = do+  b1 <- genCondJump true expr+  b2 <- genBranch false+  return (b1 `appOL` b2)++-- -----------------------------------------------------------------------------+--  Generating C calls++-- Now the biggest nightmare---calls.  Most of the nastiness is buried in+-- @get_arg@, which moves the arguments to the correct registers/stack+-- locations.  Apart from that, the code is easy.+--+-- As per *convention*:+-- x0-x7:   (volatile) argument registers+-- x8:      (volatile) indirect result register / Linux syscall no+-- x9-x15:  (volatile) caller saved regs+-- x16,x17: (volatile) intra-procedure-call registers+-- x18:     (volatile) platform register. don't use for portability+-- x19-x28: (non-volatile) callee save regs+-- x29:     (non-volatile) frame pointer+-- x30:                    link register+-- x31:                    stack pointer / zero reg+--+-- Thus, this is what a c function will expect. Find the arguments in x0-x7,+-- anything above that on the stack.  We'll ignore c functions with more than+-- 8 arguments for now.  Sorry.+--+-- We need to make sure we preserve x9-x15, don't want to touch x16, x17.++-- Note [PLT vs GOT relocations]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- When linking objects together, we may need to lookup foreign references. That+-- is symbolic references to functions or values in other objects. When+-- compiling the object, we can not know where those elements will end up in+-- memory (relative to the current location). Thus the use of symbols. There+-- are two types of items we are interested, code segments we want to jump to+-- and continue execution there (functions, ...), and data items we want to look+-- up (strings, numbers, ...). For functions we can use the fact that we can use+-- an intermediate jump without visibility to the programs execution.  If we+-- want to jump to a function that is simply too far away to reach for the B/BL+-- instruction, we can create a small piece of code that loads the full target+-- address and jumps to that on demand. Say f wants to call g, however g is out+-- of range for a direct jump, we can create a function h in range for f, that+-- will load the address of g, and jump there. The area where we construct h+-- is called the Procedure Linking Table (PLT), we have essentially replaced+-- f -> g with f -> h -> g.  This is fine for function calls.  However if we+-- want to lookup values, this trick doesn't work, so we need something else.+-- We will instead reserve a slot in memory, and have a symbol pointing to that+-- slot. Now what we essentially do is, we reference that slot, and expect that+-- slot to hold the final resting address of the data we are interested in.+-- Thus what that symbol really points to is the location of the final data.+-- The block of memory where we hold all those slots is the Global Offset Table+-- (GOT).  Instead of x <- $foo, we now do y <- $fooPtr, and x <- [$y].+--+-- For JUMP/CALLs we have 26bits (+/- 128MB), for conditional branches we only+-- have 19bits (+/- 1MB).  Symbol lookups are also within +/- 1MB, thus for most+-- of the LOAD/STOREs we'd want to use adrp, and add to compute a value within+-- 4GB of the PC, and load that.  For anything outside of that range, we'd have+-- to go through the GOT.+--+--  adrp x0, <symbol>+--  add x0, :lo:<symbol>+--+-- will compute the address of <symbol> int x0 if <symbol> is within 4GB of the+-- PC.+--+-- If we want to get the slot in the global offset table (GOT), we can do this:+--+--   adrp x0, #:got:<symbol>+--   ldr x0, [x0, #:got_lo12:<symbol>]+--+-- this will compute the address anywhere in the addressable 64bit space into+-- x0, by loading the address from the GOT slot.+--+-- To actually get the value of <symbol>, we'd need to ldr x0, x0 still, which+-- for the first case can be optimized to use ldr x0, [x0, #:lo12:<symbol>]+-- instead of the add instruction.+--+-- As the memory model for AArch64 for PIC is considered to be +/- 4GB, we do+-- not need to go through the GOT, unless we want to address the full address+-- range within 64bit.++genCCall+    :: ForeignTarget      -- function to call+    -> [CmmFormal]        -- where to put the result+    -> [CmmActual]        -- arguments (of mixed type)+    -> NatM InstrBlock+-- TODO: Specialize where we can.+-- Generic impl+genCCall target dest_regs arg_regs = do+  -- we want to pass arg_regs into allArgRegs+  -- pprTraceM "genCCall target" (ppr target)+  -- pprTraceM "genCCall formal" (ppr dest_regs)+  -- pprTraceM "genCCall actual" (ppr arg_regs)+  platform <- getPlatform+  case target of+    -- The target :: ForeignTarget call can either+    -- be a foreign procedure with an address expr+    -- and a calling convention.+    ForeignTarget expr _cconv -> do+      (call_target, call_target_code) <- case expr of+        -- if this is a label, let's just directly to it.  This will produce the+        -- correct CALL relocation for BL...+        (CmmLit (CmmLabel lbl)) -> pure (TLabel lbl, nilOL)+        -- ... if it's not a label--well--let's compute the expression into a+        -- register and jump to that. See Note [PLT vs GOT relocations]+        _ -> do (reg, _format, reg_code) <- getSomeReg expr+                pure (TReg reg, reg_code)+      -- compute the code and register logic for all arg_regs.+      -- this will give us the format information to match on.+      arg_regs' <- mapM getSomeReg arg_regs++      -- Now this is stupid.  Our Cmm expressions doesn't carry the proper sizes+      -- so while in Cmm we might get W64 incorrectly for an int, that is W32 in+      -- STG; this thenn breaks packing of stack arguments, if we need to pack+      -- for the pcs, e.g. darwinpcs.  Option one would be to fix the Int type+      -- in Cmm proper. Option two, which we choose here is to use extended Hint+      -- information to contain the size information and use that when packing+      -- arguments, spilled onto the stack.+      let (_res_hints, arg_hints) = foreignTargetHints target+          arg_regs'' = zipWith (\(r, f, c) h -> (r,f,h,c)) arg_regs' arg_hints++      let packStack = platformOS platform == OSDarwin++      (stackSpace', passRegs, passArgumentsCode) <- passArguments packStack allGpArgRegs allFpArgRegs arg_regs'' 0 [] nilOL++      -- if we pack the stack, we may need to adjust to multiple of 8byte.+      -- if we don't pack the stack, it will always be multiple of 8.+      let stackSpace = if stackSpace' `mod` 8 /= 0+                       then 8 * (stackSpace' `div` 8 + 1)+                       else stackSpace'++      readResultsCode <- readResults allGpArgRegs allFpArgRegs dest_regs [] nilOL++      let moveStackDown 0 = toOL [ PUSH_STACK_FRAME+                                 , DELTA (-16) ]+          moveStackDown i | odd i = moveStackDown (i + 1)+          moveStackDown i = toOL [ PUSH_STACK_FRAME+                                 , SUB (OpReg W64 (regSingle 31)) (OpReg W64 (regSingle 31)) (OpImm (ImmInt (8 * i)))+                                 , DELTA (-8 * i - 16) ]+          moveStackUp 0 = toOL [ POP_STACK_FRAME+                               , DELTA 0 ]+          moveStackUp i | odd i = moveStackUp (i + 1)+          moveStackUp i = toOL [ ADD (OpReg W64 (regSingle 31)) (OpReg W64 (regSingle 31)) (OpImm (ImmInt (8 * i)))+                               , POP_STACK_FRAME+                               , DELTA 0 ]++      let code =    call_target_code          -- compute the label (possibly into a register)+            `appOL` moveStackDown (stackSpace `div` 8)+            `appOL` passArgumentsCode         -- put the arguments into x0, ...+            `appOL` (unitOL $ BL call_target passRegs) -- branch and link.+            `appOL` readResultsCode           -- parse the results into registers+            `appOL` moveStackUp (stackSpace `div` 8)+      return code++    PrimTarget MO_F32_Fabs+      | [arg_reg] <- arg_regs, [dest_reg] <- dest_regs ->+        unaryFloatOp W32 (\d x -> unitOL $ FABS d x) arg_reg dest_reg+      | otherwise -> panic "mal-formed MO_F32_Fabs"+    PrimTarget MO_F64_Fabs+      | [arg_reg] <- arg_regs, [dest_reg] <- dest_regs ->+        unaryFloatOp W64 (\d x -> unitOL $ FABS d x) arg_reg dest_reg+      | otherwise -> panic "mal-formed MO_F64_Fabs"+    PrimTarget MO_F32_Sqrt+      | [arg_reg] <- arg_regs, [dest_reg] <- dest_regs ->+        unaryFloatOp W32 (\d x -> unitOL $ FSQRT d x) arg_reg dest_reg+      | otherwise -> panic "mal-formed MO_F32_Sqrt"+    PrimTarget MO_F64_Sqrt+      | [arg_reg] <- arg_regs, [dest_reg] <- dest_regs ->+        unaryFloatOp W64 (\d x -> unitOL $ FSQRT d x) arg_reg dest_reg+      | otherwise -> panic "mal-formed MO_F64_Sqrt"+++    PrimTarget (MO_S_Mul2 w)+          -- Life is easier when we're working with word sized operands,+          -- we can use SMULH to compute the high 64 bits, and dst_needed+          -- checks if the high half's bits are all the same as the low half's+          -- top bit.+          | w == W64+          , [src_a, src_b] <- arg_regs+          -- dst_needed = did the result fit into just the low half+          , [dst_needed, dst_hi, dst_lo] <- dest_regs+            ->  do+              (reg_a, _format_x, code_x) <- getSomeReg src_a+              (reg_b, _format_y, code_y) <- getSomeReg src_b++              let lo = getRegisterReg platform (CmmLocal dst_lo)+                  hi = getRegisterReg platform (CmmLocal dst_hi)+                  nd = getRegisterReg platform (CmmLocal dst_needed)+              return $+                  code_x `appOL`+                  code_y `snocOL`+                  MUL   (OpReg W64 lo) (OpReg W64 reg_a) (OpReg W64 reg_b) `snocOL`+                  SMULH (OpReg W64 hi) (OpReg W64 reg_a) (OpReg W64 reg_b) `snocOL`+                  -- Are all high bits equal to the sign bit of the low word?+                  -- nd = (hi == ASR(lo,width-1)) ? 1 : 0+                  CMP   (OpReg W64 hi) (OpRegShift W64 lo SASR (widthInBits w - 1)) `snocOL`+                  CSET  (OpReg W64 nd) NE+            -- For sizes < platform width, we can just perform a multiply and shift+            -- using the normal 64 bit multiply. Calculating the dst_needed value is+            -- complicated a little by the need to be careful when truncation happens.+            -- Currently this case can't be generated since+            -- timesInt2# :: Int# -> Int# -> (# Int#, Int#, Int# #)+            -- TODO: Should this be removed or would other primops be useful?+          | w < W64+          , [src_a, src_b] <- arg_regs+          , [dst_needed, dst_hi, dst_lo] <- dest_regs+            ->  do+              (reg_a', _format_x, code_a) <- getSomeReg src_a+              (reg_b', _format_y, code_b) <- getSomeReg src_b++              let lo = getRegisterReg platform (CmmLocal dst_lo)+                  hi = getRegisterReg platform (CmmLocal dst_hi)+                  nd = getRegisterReg platform (CmmLocal dst_needed)+                  -- Do everything in a full 64 bit registers+                  w' = platformWordWidth platform++              (reg_a, code_a') <- signExtendReg w w' reg_a'+              (reg_b, code_b') <- signExtendReg w w' reg_b'++              return $+                  code_a  `appOL`+                  code_b  `appOL`+                  code_a' `appOL`+                  code_b' `snocOL`+                  -- the low 2w' of lo contains the full multiplication;+                  -- eg: int8 * int8 -> int16 result+                  -- so lo is in the last w of the register, and hi is in the second w.+                  SMULL (OpReg w' lo) (OpReg w' reg_a) (OpReg w' reg_b) `snocOL`+                  -- Make sure we hold onto the sign bits for dst_needed+                  ASR (OpReg w' hi) (OpReg w' lo)    (OpImm (ImmInt $ widthInBits w)) `appOL`+                  -- lo can now be truncated so we can get at it's top bit easily.+                  truncateReg w' w lo `snocOL`+                  -- Note the use of CMN (compare negative), not CMP: we want to+                  -- test if the top half is negative one and the top+                  -- bit of the bottom half is positive one. eg:+                  -- hi = 0b1111_1111  (actually 64 bits)+                  -- lo = 0b1010_1111  (-81, so the result didn't need the top half)+                  -- lo' = ASR(lo,7)   (second reg of SMN)+                  --     = 0b0000_0001 (theeshift gives us 1 for negative,+                  --                    and 0 for positive)+                  -- hi == -lo'?+                  -- 0b1111_1111 == 0b1111_1111 (yes, top half is just overflow)+                  -- Another way to think of this is if hi + lo' == 0, which is what+                  -- CMN really is under the hood.+                  CMN   (OpReg w' hi) (OpRegShift w' lo SLSR (widthInBits w - 1)) `snocOL`+                  -- Set dst_needed to 1 if hi and lo' were (negatively) equal+                  CSET  (OpReg w' nd) EQ `appOL`+                  -- Finally truncate hi to drop any extraneous sign bits.+                  truncateReg w' w hi+          -- Can't handle > 64 bit operands+          | otherwise -> unsupported (MO_S_Mul2 w)+    PrimTarget (MO_U_Mul2  w)+          -- The unsigned case is much simpler than the signed, all we need to+          -- do is the multiplication straight into the destination registers.+          | w == W64+          , [src_a, src_b] <- arg_regs+          , [dst_hi, dst_lo] <- dest_regs+            ->  do+              (reg_a, _format_x, code_x) <- getSomeReg src_a+              (reg_b, _format_y, code_y) <- getSomeReg src_b++              let lo = getRegisterReg platform (CmmLocal dst_lo)+                  hi = getRegisterReg platform (CmmLocal dst_hi)+              return (+                  code_x `appOL`+                  code_y `snocOL`+                  MUL   (OpReg W64 lo) (OpReg W64 reg_a) (OpReg W64 reg_b) `snocOL`+                  UMULH (OpReg W64 hi) (OpReg W64 reg_a) (OpReg W64 reg_b)+                  )+            -- For sizes < platform width, we can just perform a multiply and shift+            -- Need to be careful to truncate the low half, but the upper half should be+            -- be ok if the invariant in [Signed arithmetic on AArch64] is maintained.+            -- Currently this case can't be produced by the compiler since+            -- timesWord2# :: Word# -> Word# -> (# Word#, Word# #)+            -- TODO: Remove? Or would the extra primop be useful for avoiding the extra+            -- steps needed to do this in userland?+          | w < W64+          , [src_a, src_b] <- arg_regs+          , [dst_hi, dst_lo] <- dest_regs+            ->  do+              (reg_a, _format_x, code_x) <- getSomeReg src_a+              (reg_b, _format_y, code_y) <- getSomeReg src_b++              let lo = getRegisterReg platform (CmmLocal dst_lo)+                  hi = getRegisterReg platform (CmmLocal dst_hi)+                  w' = opRegWidth w+              return (+                  code_x `appOL`+                  code_y `snocOL`+                  -- UMULL: Xd = Wa * Wb with 64 bit result+                  -- W64 inputs should have been caught by case above+                  UMULL (OpReg W64 lo) (OpReg w' reg_a) (OpReg w' reg_b) `snocOL`+                  -- Extract and truncate high result+                  -- hi[w:0] = lo[2w:w]+                  UBFX (OpReg W64 hi) (OpReg W64 lo)+                      (OpImm (ImmInt $ widthInBits w)) -- lsb+                      (OpImm (ImmInt $ widthInBits w)) -- width to extract+                      `appOL`+                  truncateReg W64 w lo+                  )+          | otherwise -> unsupported (MO_U_Mul2  w)+    PrimTarget (MO_Clz  w)+          | w == W64 || w == W32+          , [src] <- arg_regs+          , [dst] <- dest_regs+          -> do+              (reg_a, _format_x, code_x) <- getSomeReg src+              let dst_reg = getRegisterReg platform (CmmLocal dst)+              return (+                  code_x `snocOL`+                  CLZ   (OpReg w dst_reg) (OpReg w reg_a)+                  )+          | w == W16+          , [src] <- arg_regs+          , [dst] <- dest_regs+          -> do+              (reg_a, _format_x, code_x) <- getSomeReg src+              let dst' = getRegisterReg platform (CmmLocal dst)+                  r n = OpReg W32 n+                  imm n = OpImm (ImmInt n)+              {- dst = clz(x << 16 | 0x0000_8000) -}+              return (+                  code_x `appOL` toOL+                    [ LSL (r dst') (r reg_a) (imm 16)+                    , ORR (r dst') (r dst')  (imm 0x00008000)+                    , CLZ (r dst') (r dst')+                    ]+                  )+          | w == W8+          , [src] <- arg_regs+          , [dst] <- dest_regs+          -> do+              (reg_a, _format_x, code_x) <- getSomeReg src+              let dst' = getRegisterReg platform (CmmLocal dst)+                  r n = OpReg W32 n+                  imm n = OpImm (ImmInt n)+              {- dst = clz(x << 24 | 0x0080_0000) -}+              return $+                  code_x `appOL` toOL+                    [ LSL (r dst') (r reg_a) (imm 24)+                    , ORR (r dst') (r dst')  (imm 0x00800000)+                    , CLZ (r dst') (r dst')+                    ]+            | otherwise -> unsupported (MO_Clz  w)+    PrimTarget (MO_Ctz  w)+          | w == W64 || w == W32+          , [src] <- arg_regs+          , [dst] <- dest_regs+          -> do+              (reg_a, _format_x, code_x) <- getSomeReg src+              let dst_reg = getRegisterReg platform (CmmLocal dst)+              return $+                  code_x `snocOL`+                  RBIT (OpReg w dst_reg) (OpReg w reg_a) `snocOL`+                  CLZ  (OpReg w dst_reg) (OpReg w dst_reg)+          | w == W16+          , [src] <- arg_regs+          , [dst] <- dest_regs+          -> do+              (reg_a, _format_x, code_x) <- getSomeReg src+              let dst' = getRegisterReg platform (CmmLocal dst)+                  r n = OpReg W32 n+                  imm n = OpImm (ImmInt n)+              {- dst = clz(reverseBits(x) | 0x0000_8000) -}+              return $+                  code_x `appOL` toOL+                    [ RBIT (r dst') (r reg_a)+                    , ORR  (r dst') (r dst') (imm 0x00008000)+                    , CLZ  (r dst') (r dst')+                    ]+          | w == W8+          , [src] <- arg_regs+          , [dst] <- dest_regs+          -> do+              (reg_a, _format_x, code_x) <- getSomeReg src+              let dst' = getRegisterReg platform (CmmLocal dst)+                  r n = OpReg W32 n+                  imm n = OpImm (ImmInt n)+              {- dst = clz(reverseBits(x) | 0x0080_0000) -}+              return $+                  code_x `appOL` toOL+                    [ RBIT (r dst') (r reg_a)+                    , ORR (r dst')  (r dst') (imm 0x00800000)+                    , CLZ  (r dst')  (r dst')+                    ]+            | otherwise -> unsupported (MO_Ctz  w)+    PrimTarget (MO_BRev  w)+          | w == W64 || w == W32+          , [src] <- arg_regs+          , [dst] <- dest_regs+          -> do+              (reg_a, _format_x, code_x) <- getSomeReg src+              let dst_reg = getRegisterReg platform (CmmLocal dst)+              return $+                  code_x `snocOL`+                  RBIT (OpReg w dst_reg) (OpReg w reg_a)+          | w == W16+          , [src] <- arg_regs+          , [dst] <- dest_regs+          -> do+              (reg_a, _format_x, code_x) <- getSomeReg src+              let dst' = getRegisterReg platform (CmmLocal dst)+                  r n = OpReg W32 n+                  imm n = OpImm (ImmInt n)+              {- dst = reverseBits32(x << 16) -}+              return $+                  code_x `appOL` toOL+                    [ LSL  (r dst') (r reg_a) (imm 16)+                    , RBIT (r dst') (r dst')+                    ]+          | w == W8+          , [src] <- arg_regs+          , [dst] <- dest_regs+          -> do+              (reg_a, _format_x, code_x) <- getSomeReg src+              let dst' = getRegisterReg platform (CmmLocal dst)+                  r n = OpReg W32 n+                  imm n = OpImm (ImmInt n)+              {- dst = reverseBits32(x << 24) -}+              return $+                  code_x `appOL` toOL+                    [ LSL  (r dst') (r reg_a) (imm 24)+                    , RBIT (r dst') (r dst')+                    ]+            | otherwise -> unsupported (MO_BRev  w)+    PrimTarget (MO_BSwap  w)+          | w == W64 || w == W32+          , [src] <- arg_regs+          , [dst] <- dest_regs+          -> do+              (reg_a, _format_x, code_x) <- getSomeReg src+              let dst_reg = getRegisterReg platform (CmmLocal dst)+              return $ code_x `snocOL` REV (OpReg w dst_reg) (OpReg w reg_a)+          | w == W16+          , [src] <- arg_regs+          , [dst] <- dest_regs+          -> do+              (reg_a, _format_x, code_x) <- getSomeReg src+              let dst' = getRegisterReg platform (CmmLocal dst)+                  r n = OpReg W32 n+              -- Swaps the bytes in each 16bit word+              -- TODO: Expose the 32 & 64 bit version of this?+              return $ code_x `snocOL` REV16 (r dst') (r reg_a)+          | otherwise -> unsupported (MO_BSwap w)++    -- or a possibly side-effecting machine operation+    -- mop :: CallishMachOp (see GHC.Cmm.MachOp)+    PrimTarget mop -> do+      -- We'll need config to construct forien targets+      case mop of+        -- 64 bit float ops+        MO_F64_Pwr   -> mkCCall "pow"++        MO_F64_Sin   -> mkCCall "sin"+        MO_F64_Cos   -> mkCCall "cos"+        MO_F64_Tan   -> mkCCall "tan"++        MO_F64_Sinh  -> mkCCall "sinh"+        MO_F64_Cosh  -> mkCCall "cosh"+        MO_F64_Tanh  -> mkCCall "tanh"++        MO_F64_Asin  -> mkCCall "asin"+        MO_F64_Acos  -> mkCCall "acos"+        MO_F64_Atan  -> mkCCall "atan"++        MO_F64_Asinh -> mkCCall "asinh"+        MO_F64_Acosh -> mkCCall "acosh"+        MO_F64_Atanh -> mkCCall "atanh"++        MO_F64_Log   -> mkCCall "log"+        MO_F64_Log1P -> mkCCall "log1p"+        MO_F64_Exp   -> mkCCall "exp"+        MO_F64_ExpM1 -> mkCCall "expm1"++        -- 32 bit float ops+        MO_F32_Pwr   -> mkCCall "powf"++        MO_F32_Sin   -> mkCCall "sinf"+        MO_F32_Cos   -> mkCCall "cosf"+        MO_F32_Tan   -> mkCCall "tanf"+        MO_F32_Sinh  -> mkCCall "sinhf"+        MO_F32_Cosh  -> mkCCall "coshf"+        MO_F32_Tanh  -> mkCCall "tanhf"+        MO_F32_Asin  -> mkCCall "asinf"+        MO_F32_Acos  -> mkCCall "acosf"+        MO_F32_Atan  -> mkCCall "atanf"+        MO_F32_Asinh -> mkCCall "asinhf"+        MO_F32_Acosh -> mkCCall "acoshf"+        MO_F32_Atanh -> mkCCall "atanhf"+        MO_F32_Log   -> mkCCall "logf"+        MO_F32_Log1P -> mkCCall "log1pf"+        MO_F32_Exp   -> mkCCall "expf"+        MO_F32_ExpM1 -> mkCCall "expm1f"++        -- 64-bit primops+        MO_I64_ToI   -> mkCCall "hs_int64ToInt"+        MO_I64_FromI -> mkCCall "hs_intToInt64"+        MO_W64_ToW   -> mkCCall "hs_word64ToWord"+        MO_W64_FromW -> mkCCall "hs_wordToWord64"+        MO_x64_Neg   -> mkCCall "hs_neg64"+        MO_x64_Add   -> mkCCall "hs_add64"+        MO_x64_Sub   -> mkCCall "hs_sub64"+        MO_x64_Mul   -> mkCCall "hs_mul64"+        MO_I64_Quot  -> mkCCall "hs_quotInt64"+        MO_I64_Rem   -> mkCCall "hs_remInt64"+        MO_W64_Quot  -> mkCCall "hs_quotWord64"+        MO_W64_Rem   -> mkCCall "hs_remWord64"+        MO_x64_And   -> mkCCall "hs_and64"+        MO_x64_Or    -> mkCCall "hs_or64"+        MO_x64_Xor   -> mkCCall "hs_xor64"+        MO_x64_Not   -> mkCCall "hs_not64"+        MO_x64_Shl   -> mkCCall "hs_uncheckedShiftL64"+        MO_I64_Shr   -> mkCCall "hs_uncheckedIShiftRA64"+        MO_W64_Shr   -> mkCCall "hs_uncheckedShiftRL64"+        MO_x64_Eq    -> mkCCall "hs_eq64"+        MO_x64_Ne    -> mkCCall "hs_ne64"+        MO_I64_Ge    -> mkCCall "hs_geInt64"+        MO_I64_Gt    -> mkCCall "hs_gtInt64"+        MO_I64_Le    -> mkCCall "hs_leInt64"+        MO_I64_Lt    -> mkCCall "hs_ltInt64"+        MO_W64_Ge    -> mkCCall "hs_geWord64"+        MO_W64_Gt    -> mkCCall "hs_gtWord64"+        MO_W64_Le    -> mkCCall "hs_leWord64"+        MO_W64_Lt    -> mkCCall "hs_ltWord64"++        -- Conversion+        MO_UF_Conv w        -> mkCCall (word2FloatLabel w)++        -- Arithmetic+        -- These are not supported on X86, so I doubt they are used much.+        MO_S_QuotRem  _w -> unsupported mop+        MO_U_QuotRem  _w -> unsupported mop+        MO_U_QuotRem2 _w -> unsupported mop+        MO_Add2       _w -> unsupported mop+        MO_AddWordC   _w -> unsupported mop+        MO_SubWordC   _w -> unsupported mop+        MO_AddIntC    _w -> unsupported mop+        MO_SubIntC    _w -> unsupported mop++        -- Vector+        MO_VS_Quot {} -> unsupported mop+        MO_VS_Rem {} -> unsupported mop+        MO_VU_Quot {} -> unsupported mop+        MO_VU_Rem {} -> unsupported mop+        MO_I64X2_Min -> unsupported mop+        MO_I64X2_Max -> unsupported mop+        MO_W64X2_Min -> unsupported mop+        MO_W64X2_Max -> unsupported mop++        -- Memory Ordering+        -- Set flags according to their C pendants (stdatomic.h):+        -- atomic_thread_fence(memory_order_acquire); // -> dmb ishld+        MO_AcquireFence     ->  return . unitOL $ DMBISH DmbLoad+        -- atomic_thread_fence(memory_order_release); // -> dmb ish+        MO_ReleaseFence     ->  return . unitOL $ DMBISH DmbLoadStore+        -- atomic_thread_fence(memory_order_seq_cst); // -> dmb ish+        MO_SeqCstFence      ->  return . unitOL $ DMBISH DmbLoadStore+        MO_Touch            ->  return nilOL -- Keep variables live (when using interior pointers)+        -- Prefetch+        MO_Prefetch_Data _n -> return nilOL -- Prefetch hint.++        -- Memory copy/set/move/cmp, with alignment for optimization++        -- TODO Optimize and use e.g. quad registers to move memory around instead+        -- of offloading this to memcpy. For small memcpys we can utilize+        -- the 128bit quad registers in NEON to move block of bytes around.+        -- Might also make sense of small memsets? Use xzr? What's the function+        -- call overhead?+        MO_Memcpy  _align   -> mkCCall "memcpy"+        MO_Memset  _align   -> mkCCall "memset"+        MO_Memmove _align   -> mkCCall "memmove"+        MO_Memcmp  _align   -> mkCCall "memcmp"++        MO_SuspendThread    -> mkCCall "suspendThread"+        MO_ResumeThread     -> mkCCall "resumeThread"++        MO_PopCnt w         -> mkCCall (popCntLabel w)+        MO_Pdep w           -> mkCCall (pdepLabel w)+        MO_Pext w           -> mkCCall (pextLabel w)++        -- -- Atomic read-modify-write.+        MO_AtomicRead w ord+          | [p_reg] <- arg_regs+          , [dst_reg] <- dest_regs -> do+              (p, _fmt_p, code_p) <- getSomeReg p_reg+              platform <- getPlatform+              let instr = case ord of+                      MemOrderRelaxed -> LDR+                      _               -> LDAR+                  dst = getRegisterReg platform (CmmLocal dst_reg)+                  code =+                    code_p `snocOL`+                    instr (intFormat w) (OpReg w dst) (OpAddr $ AddrReg p)+              return code+          | otherwise -> panic "mal-formed AtomicRead"+        MO_AtomicWrite w ord+          | [p_reg, val_reg] <- arg_regs -> do+              (p, _fmt_p, code_p) <- getSomeReg p_reg+              (val, fmt_val, code_val) <- getSomeReg val_reg+              let instr = case ord of+                      MemOrderRelaxed -> STR+                      _               -> STLR+                  code =+                    code_p `appOL`+                    code_val `snocOL`+                    instr fmt_val (OpReg w val) (OpAddr $ AddrReg p)+              return code+          | otherwise -> panic "mal-formed AtomicWrite"+        MO_AtomicRMW w amop -> mkCCall (atomicRMWLabel w amop)+        MO_Cmpxchg w        -> mkCCall (cmpxchgLabel w)+        -- -- Should be an AtomicRMW variant eventually.+        -- -- Sequential consistent.+        -- TODO: this should be implemented properly!+        MO_Xchg w           -> mkCCall (xchgLabel w)++  where+    unsupported :: Show a => a -> b+    unsupported mop = panic ("outOfLineCmmOp: " ++ show mop+                          ++ " not supported here")+    mkCCall :: FastString -> NatM InstrBlock+    mkCCall name = do+      config <- getConfig+      target <- cmmMakeDynamicReference config CallReference $+          mkForeignLabel name ForeignLabelInThisPackage IsFunction+      let cconv = ForeignConvention CCallConv [NoHint] [NoHint] CmmMayReturn+      genCCall (ForeignTarget target cconv) dest_regs arg_regs++    -- TODO: Optimize using paired stores and loads (STP, LDP). It is+    -- automatically done by the allocator for us. However it's not optimal,+    -- as we'd rather want to have control over+    --     all spill/load registers, so we can optimize with instructions like+    --       STP xA, xB, [sp, #-16]!+    --     and+    --       LDP xA, xB, sp, #16+    --+    passArguments :: Bool -> [Reg] -> [Reg] -> [(Reg, Format, ForeignHint, InstrBlock)] -> Int -> [Reg] -> InstrBlock -> NatM (Int, [Reg], InstrBlock)+    passArguments _packStack _ _ [] stackSpace accumRegs accumCode = return (stackSpace, accumRegs, accumCode)+    -- passArguments _ _ [] accumCode stackSpace | isEven stackSpace = return $ SUM (OpReg W64 x31) (OpReg W64 x31) OpImm (ImmInt (-8 * stackSpace))+    -- passArguments _ _ [] accumCode stackSpace = return $ SUM (OpReg W64 x31) (OpReg W64 x31) OpImm (ImmInt (-8 * (stackSpace + 1)))+    -- passArguments [] fpRegs (arg0:arg1:args) stack accumCode = do+    --   -- allocate this on the stack+    --   (r0, format0, code_r0) <- getSomeReg arg0+    --   (r1, format1, code_r1) <- getSomeReg arg1+    --   let w0 = formatToWidth format0+    --       w1 = formatToWidth format1+    --       stackCode = unitOL $ STP (OpReg w0 r0) (OpReg w1 R1), (OpAddr (AddrRegImm x31 (ImmInt (stackSpace * 8)))+    --   passArguments gpRegs (fpReg:fpRegs) args (stackCode `appOL` accumCode)++      -- float promotion.+      -- According to+      --  ISO/IEC 9899:2018+      --  Information technology — Programming languages — C+      --+      -- e.g.+      -- http://www.open-std.org/jtc1/sc22/wg14/www/docs/n1124.pdf+      -- http://www.open-std.org/jtc1/sc22/wg14/www/docs/n1256.pdf+      --+      -- GHC would need to know the prototype.+      --+      -- > If the expression that denotes the called function has a type that does not include a+      -- > prototype, the integer promotions are performed on each argument, and arguments that+      -- > have type float are promoted to double.+      --+      -- As we have no way to get prototypes for C yet, we'll *not* promote this+      -- which is in line with the x86_64 backend :(+      --+      -- See the encode_values.cmm test.+      --+      -- We would essentially need to insert an FCVT (OpReg W64 fpReg) (OpReg W32 fpReg)+      -- if w == W32.  But *only* if we don't have a prototype m(+      --+      -- For AArch64 specificies see: https://developer.arm.com/docs/ihi0055/latest/procedure-call-standard-for-the-arm-64-bit-architecture+      --+    -- Still have GP regs, and we want to pass an GP argument.++    -- AArch64-Darwin: stack packing and alignment+    --+    -- According to the "Writing ARM64 Code for Apple Platforms" document form+    -- Apple, specifically the section "Handle Data Types and Data Alignment Properly"+    -- we need to not only pack, but also align arguments on the stack.+    --+    -- Data type   Size (in bytes)   Natural alignment (in bytes)+    -- BOOL, bool  1                 1+    -- char        1                 1+    -- short       2                 2+    -- int         4                 4+    -- long        8                 8+    -- long long   8                 8+    -- pointer     8                 8+    -- size_t      8                 8+    -- NSInteger   8                 8+    -- CFIndex     8                 8+    -- fpos_t      8                 8+    -- off_t       8                 8+    --+    -- We can see that types are aligned by their sizes so the easiest way to+    -- guarantee alignment during packing seems to be to pad to a multiple of the+    -- size we want to pack. Failure to get this right can result in pretty+    -- subtle bugs, e.g. #20137.++    passArguments pack (gpReg:gpRegs) fpRegs ((r, format, hint, code_r):args) stackSpace accumRegs accumCode | isIntFormat format = do+      platform <- getPlatform+      let w = formatToWidth format+          mov+            -- Specifically, Darwin/AArch64's ABI requires that the caller+            -- sign-extend arguments which are smaller than 32-bits.+            | w < W32+            , platformCConvNeedsExtension platform+            , SignedHint <- hint+            = case w of+                W8  -> SXTB (OpReg W64 gpReg) (OpReg w r)+                W16 -> SXTH (OpReg W64 gpReg) (OpReg w r)+                _   -> panic "impossible"+            | otherwise+            = MOV (OpReg w gpReg) (OpReg w r)+          accumCode' = accumCode `appOL`+                       code_r `snocOL`+                       ann (text "Pass gp argument: " <> ppr r) mov+      passArguments pack gpRegs fpRegs args stackSpace (gpReg:accumRegs) accumCode'++    -- Still have FP regs, and we want to pass an FP argument.+    passArguments pack gpRegs (fpReg:fpRegs) ((r, format, _hint, code_r):args) stackSpace accumRegs accumCode | isFloatFormat format = do+      let w = formatToWidth format+          mov = MOV (OpReg w fpReg) (OpReg w r)+          accumCode' = accumCode `appOL`+                       code_r `snocOL`+                       ann (text "Pass fp argument: " <> ppr r) mov+      passArguments pack gpRegs fpRegs args stackSpace (fpReg:accumRegs) accumCode'++    -- No mor regs left to pass. Must pass on stack.+    passArguments pack [] [] ((r, format, _hint, code_r):args) stackSpace accumRegs accumCode = do+      let w = formatToWidth format+          bytes = widthInBits w `div` 8+          space = if pack then bytes else 8+          stackSpace' | pack && stackSpace `mod` space /= 0 = stackSpace + space - (stackSpace `mod` space)+                      | otherwise                           = stackSpace+          str = STR format (OpReg w r) (OpAddr (AddrRegImm (regSingle 31) (ImmInt stackSpace')))+          stackCode = code_r `snocOL`+                      ann (text "Pass argument (size " <> ppr w <> text ") on the stack: " <> ppr r) str+      passArguments pack [] [] args (stackSpace'+space) accumRegs (stackCode `appOL` accumCode)++    -- Still have fpRegs left, but want to pass a GP argument. Must be passed on the stack then.+    passArguments pack [] fpRegs ((r, format, _hint, code_r):args) stackSpace accumRegs accumCode | isIntFormat format = do+      let w = formatToWidth format+          bytes = widthInBits w `div` 8+          space = if pack then bytes else 8+          stackSpace' | pack && stackSpace `mod` space /= 0 = stackSpace + space - (stackSpace `mod` space)+                      | otherwise                           = stackSpace+          str = STR format (OpReg w r) (OpAddr (AddrRegImm (regSingle 31) (ImmInt stackSpace')))+          stackCode = code_r `snocOL`+                      ann (text "Pass argument (size " <> ppr w <> text ") on the stack: " <> ppr r) str+      passArguments pack [] fpRegs args (stackSpace'+space) accumRegs (stackCode `appOL` accumCode)++    -- Still have gpRegs left, but want to pass a FP argument. Must be passed on the stack then.+    passArguments pack gpRegs [] ((r, format, _hint, code_r):args) stackSpace accumRegs accumCode | isFloatFormat format = do+      let w = formatToWidth format+          bytes = widthInBits w `div` 8+          space = if pack then bytes else 8+          stackSpace' | pack && stackSpace `mod` space /= 0 = stackSpace + space - (stackSpace `mod` space)+                      | otherwise                           = stackSpace+          str = STR format (OpReg w r) (OpAddr (AddrRegImm (regSingle 31) (ImmInt stackSpace')))+          stackCode = code_r `snocOL`+                      ann (text "Pass argument (size " <> ppr w <> text ") on the stack: " <> ppr r) str+      passArguments pack gpRegs [] args (stackSpace'+space) accumRegs (stackCode `appOL` accumCode)++    passArguments _ _ _ _ _ _ _ = pprPanic "passArguments" (text "invalid state")++    readResults :: [Reg] -> [Reg] -> [LocalReg] -> [Reg]-> InstrBlock -> NatM (InstrBlock)+    readResults _ _ [] _ accumCode = return accumCode+    readResults [] _ _ _ _ = do+      platform <- getPlatform+      pprPanic "genCCall, out of gp registers when reading results" (pdoc platform target)+    readResults _ [] _ _ _ = do+      platform <- getPlatform+      pprPanic "genCCall, out of fp registers when reading results" (pdoc platform target)+    readResults (gpReg:gpRegs) (fpReg:fpRegs) (dst:dsts) accumRegs accumCode = do+      -- gp/fp reg -> dst+      platform <- getPlatform+      let rep = cmmRegType (CmmLocal dst)+          format = cmmTypeFormat rep+          w   = cmmRegWidth (CmmLocal dst)+          r_dst = getRegisterReg platform (CmmLocal dst)+      if isFloatFormat format+        then readResults (gpReg:gpRegs) fpRegs dsts (fpReg:accumRegs) (accumCode `snocOL` MOV (OpReg w r_dst) (OpReg w fpReg))+        else readResults gpRegs (fpReg:fpRegs) dsts (gpReg:accumRegs) (accumCode `snocOL` MOV (OpReg w r_dst) (OpReg w gpReg))++    unaryFloatOp w op arg_reg dest_reg = do+      platform <- getPlatform+      (reg_fx, _format_x, code_fx) <- getFloatReg arg_reg+      let dst = getRegisterReg platform (CmmLocal dest_reg)+      let code = code_fx `appOL` op (OpReg w dst) (OpReg w reg_fx)+      return code++{- Note [AArch64 far jumps]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+AArch conditional jump instructions can only encode an offset of +/-1MB+which is usually enough but can be exceeded in edge cases. In these cases+we will replace:++  b.cond <cond> foo++with the sequence:++  b.cond <cond> <lbl_true>+  b <lbl_false>+  <lbl_true>:+  b foo+  <lbl_false>:++Note the encoding of the `b` instruction still limits jumps to++/-128M offsets, but that seems like an acceptable limitation.++Since AArch64 instructions are all of equal length we can reasonably estimate jumps+in range by counting the instructions between a jump and its target label.++We make some simplifications in the name of performance which can result in overestimating+jump <-> label offsets:++* To avoid having to recalculate the label offsets once we replaced a jump we simply+  assume all jumps will be expanded to a three instruction far jump sequence.+* For labels associated with a info table we assume the info table is 64byte large.+  Most info tables are smaller than that but it means we don't have to distinguish+  between multiple types of info tables.++In terms of implementation we walk the instruction stream at least once calculating+label offsets, and if we determine during this that the functions body is big enough+to potentially contain out of range jumps we walk the instructions a second time, replacing+out of range jumps with the sequence of instructions described above.++-}++-- See Note [AArch64 far jumps]+data BlockInRange = InRange | NotInRange Target++-- See Note [AArch64 far jumps]+makeFarBranches :: Platform -> LabelMap RawCmmStatics -> [NatBasicBlock Instr]+                -> UniqDSM [NatBasicBlock Instr]+makeFarBranches {- only used when debugging -} _platform statics basic_blocks = do+  -- All offsets/positions are counted in multiples of 4 bytes (the size of AArch64 instructions)+  -- That is an offset of 1 represents a 4-byte/one instruction offset.+  let (func_size, lblMap) = foldl' calc_lbl_positions (0, mapEmpty) basic_blocks+  if func_size < max_jump_dist+    then pure basic_blocks+    else do+      (_,blocks) <- mapAccumLM (replace_blk lblMap) 0 basic_blocks+      pure $ concat blocks+      -- pprTrace "lblMap" (ppr lblMap) $ basic_blocks++  where+    -- 2^18, 19 bit immediate with one bit is reserved for the sign+    max_jump_dist = 2^(18::Int) - 1 :: Int+    -- Currently all inline info tables fit into 64 bytes.+    max_info_size     = 16 :: Int+    long_bc_jump_size =  3 :: Int+    long_bz_jump_size =  4 :: Int++    -- Replace out of range conditional jumps with unconditional jumps.+    replace_blk :: LabelMap Int -> Int -> GenBasicBlock Instr -> UniqDSM (Int, [GenBasicBlock Instr])+    replace_blk !m !pos (BasicBlock lbl instrs) = do+      -- Account for a potential info table before the label.+      let !block_pos = pos + infoTblSize_maybe lbl+      (!pos', instrs') <- mapAccumLM (replace_jump m) block_pos instrs+      let instrs'' = concat instrs'+      -- We might have introduced new labels, so split the instructions into basic blocks again if neccesary.+      let (top, split_blocks, no_data) = foldr mkBlocks ([],[],[]) instrs''+      -- There should be no data in the instruction stream at this point+      massert (null no_data)++      let final_blocks = BasicBlock lbl top : split_blocks+      pure (pos', final_blocks)++    replace_jump :: LabelMap Int -> Int -> Instr -> UniqDSM (Int, [Instr])+    replace_jump !m !pos instr = do+      case instr of+        ANN ann instr -> do+          replace_jump m pos instr >>= \case+            (idx,instr':instrs') ->+              pure (idx, ANN ann instr':instrs')+            (idx,[]) -> pprPanic "replace_jump" (text "empty return list for " <+> ppr idx)+        BCOND cond t+          -> case target_in_range m t pos of+              InRange -> pure (pos+long_bc_jump_size,[instr])+              NotInRange far_target -> do+                jmp_code <- genCondFarJump cond far_target+                pure (pos+long_bc_jump_size, fromOL jmp_code)+        CBZ op t -> long_zero_jump op t EQ+        CBNZ op t -> long_zero_jump op t NE+        instr+          | isMetaInstr instr -> pure (pos,[instr])+          | otherwise -> pure (pos+1, [instr])++      where+        -- cmp_op: EQ = CBZ, NEQ = CBNZ+        long_zero_jump op t cmp_op =+          case target_in_range m t pos of+              InRange -> pure (pos+long_bz_jump_size,[instr])+              NotInRange far_target -> do+                jmp_code <- genCondFarJump cmp_op far_target+                -- TODO: Fix zero reg so we can use it here+                pure (pos + long_bz_jump_size, CMP op (OpImm (ImmInt 0)) : fromOL jmp_code)+++    target_in_range :: LabelMap Int -> Target -> Int -> BlockInRange+    target_in_range m target src =+      case target of+        (TReg{}) -> InRange+        (TBlock bid) -> block_in_range m src bid+        (TLabel clbl)+          | Just bid <- maybeLocalBlockLabel clbl+          -> block_in_range m src bid+          | otherwise+          -- Maybe we should be pessimistic here, for now just fixing intra proc jumps+          -> InRange++    block_in_range :: LabelMap Int -> Int -> BlockId -> BlockInRange+    block_in_range m src_pos dest_lbl =+      case mapLookup dest_lbl m of+        Nothing       ->+          pprTrace "not in range" (ppr dest_lbl) $+            NotInRange (TBlock dest_lbl)+        Just dest_pos -> if abs (dest_pos - src_pos) < max_jump_dist+          then InRange+          else NotInRange (TBlock dest_lbl)++    calc_lbl_positions :: (Int, LabelMap Int) -> GenBasicBlock Instr -> (Int, LabelMap Int)+    calc_lbl_positions (pos, m) (BasicBlock lbl instrs)+      = let !pos' = pos + infoTblSize_maybe lbl+        in foldl' instr_pos (pos',mapInsert lbl pos' m) instrs++    instr_pos :: (Int, LabelMap Int) -> Instr -> (Int, LabelMap Int)+    instr_pos (pos, m) instr =+      case instr of+        ANN _ann instr -> instr_pos (pos, m) instr+        NEWBLOCK _bid -> panic "mkFarBranched - unexpected NEWBLOCK" -- At this point there should be no NEWBLOCK+                                                                     -- in the instruction stream+                                                                     -- (pos, mapInsert bid pos m)+        COMMENT{} -> (pos, m)+        instr+          | Just jump_size <- is_expandable_jump instr -> (pos+jump_size, m)+          | otherwise -> (pos+1, m)++    infoTblSize_maybe bid =+      case mapLookup bid statics of+        Nothing           -> 0 :: Int+        Just _info_static -> max_info_size++    -- These jumps have a 19bit immediate as offset which is quite+    -- limiting so we potentially have to expand them into+    -- multiple instructions.+    is_expandable_jump i = case i of+      CBZ{}   -> Just long_bz_jump_size+      CBNZ{}  -> Just long_bz_jump_size+      BCOND{} -> Just long_bc_jump_size+      _ -> Nothing
GHC/CmmToAsm/AArch64/Cond.hs view
@@ -1,6 +1,6 @@ module GHC.CmmToAsm.AArch64.Cond  where -import GHC.Prelude+import GHC.Prelude hiding (EQ)  -- https://developer.arm.com/documentation/den0024/a/the-a64-instruction-set/data-processing-instructions/conditional-instructions @@ -60,7 +60,13 @@     | UOGE   -- b.pl     | UOGT   -- b.hi     -- others-    | NEVER  -- b.nv+    -- NEVER -- b.nv+             -- I removed never. According to the ARM spec:+             -- >   The Condition code NV exists only to provide a valid disassembly of+             -- >   the 0b1111 encoding, otherwise its behavior is identical to AL.+             -- This can only lead to disaster. Better to not have it than someone+             -- using it assuming it actually means never.+     | VS     -- oVerflow set     | VC     -- oVerflow clear     deriving Eq
GHC/CmmToAsm/AArch64/Instr.hs view
@@ -14,27 +14,28 @@ 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.Collections import GHC.Cmm.Dataflow.Label import GHC.Cmm import GHC.Cmm.CLabel import GHC.Utils.Outputable import GHC.Platform-import GHC.Types.Unique.Supply+import GHC.Types.Unique.DSM  import GHC.Utils.Panic -import Data.Maybe (fromMaybe)+import Data.Maybe (fromMaybe, catMaybes)  import GHC.Stack --- | TODO: verify this!-stackFrameHeaderSize :: Platform -> Int-stackFrameHeaderSize _ = 64+-- | 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@@ -49,14 +50,13 @@ maxSpillSlots :: NCGConfig -> Int maxSpillSlots config --  = 0 -- set to zero, to see when allocMoreStack has to fire.-    = let platform = ncgPlatform config-      in ((ncgSpillPreallocSize config - stackFrameHeaderSize platform)+    = ((ncgSpillPreallocSize config - stackFrameHeaderSize)          `div` spillSlotSize) - 1  -- | Convert a spill slot number to a *byte* offset, with no sign. spillSlotToOffset :: NCGConfig -> Int -> Int-spillSlotToOffset config slot-   = stackFrameHeaderSize (ncgPlatform config) + spillSlotSize * slot+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.@@ -72,15 +72,23 @@ regUsageOfInstr :: Platform -> Instr -> RegUsage regUsageOfInstr platform instr = case instr of   ANN _ i                  -> regUsageOfInstr platform i+  COMMENT{}                -> usage ([], [])+  MULTILINE_COMMENT{}      -> usage ([], [])+  PUSH_STACK_FRAME         -> usage ([], [])+  POP_STACK_FRAME          -> usage ([], [])+  DELTA{}                  -> usage ([], [])+   -- 1. Arithmetic Instructions ------------------------------------------------   ADD dst src1 src2        -> usage (regOp src1 ++ regOp src2, regOp dst)-  CMN l r                  -> usage (regOp l ++ regOp r, [])   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)@@ -94,26 +102,28 @@   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)-  BIC dst src1 src2        -> usage (regOp src1 ++ regOp src2, regOp dst)-  BICS dst src1 src2       -> usage (regOp src1 ++ regOp src2, regOp dst)-  EON 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)-  ROR dst src1 src2        -> usage (regOp src1 ++ regOp src2, regOp dst)-  TST src1 src2            -> usage (regOp src1 ++ regOp src2, [])   -- 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 _rs              -> usage (regTarget t ++ ps, callerSavedRegisters)+  BL t ps                  -> usage (regTarget t ++ ps, callerSavedRegisters)    -- 5. Atomic Instructions ----------------------------------------------------   -- 6. Conditional Instructions -----------------------------------------------@@ -122,28 +132,41 @@   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)-  -- TODO is this right? see STR, which I'm only partial about being right?-  STP _ src1 src2 dst      -> usage (regOp src1 ++ regOp src2 ++ regOp dst, [])-  LDP _ dst1 dst2 src      -> usage (regOp src, regOp dst1 ++ regOp dst2)+  LDAR _ dst src           -> usage (regOp src, regOp dst)    -- 8. Synchronization Instructions --------------------------------------------  DMBSY                    -> usage ([], [])+  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) -  _ -> panic "regUsageOfInstr"+  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 (filter (interesting platform) src)-                              (filter (interesting platform) dst)+        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]@@ -164,9 +187,10 @@         -- Is this register interesting for the register allocator?         interesting :: Platform -> Reg -> Bool         interesting _        (RegVirtual _)                 = True-        interesting _        (RegReal (RealRegSingle (-1))) = False         interesting platform (RegReal (RealRegSingle i))    = freeReg platform i +-- Note [AArch64 Register assignments]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- Save caller save registers -- This is x0-x18 --@@ -187,8 +211,10 @@ -- | <---- 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, FP: Frame pointer, LR: Link register, SP: Stack pointer+-- 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]@@ -200,16 +226,23 @@ patchRegsOfInstr :: Instr -> (Reg -> Reg) -> Instr patchRegsOfInstr instr env = case instr of     -- 0. Meta Instructions-    ANN d i        -> ANN d (patchRegsOfInstr i env)+    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)-    CMN o1 o2      -> CMN (patchOp o1) (patchOp o2)     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)@@ -223,29 +256,31 @@     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)-    ANDS o1 o2 o3  -> ANDS (patchOp o1) (patchOp o2) (patchOp o3)     ASR o1 o2 o3   -> ASR  (patchOp o1) (patchOp o2) (patchOp o3)-    BIC o1 o2 o3   -> BIC  (patchOp o1) (patchOp o2) (patchOp o3)-    BICS o1 o2 o3  -> BICS (patchOp o1) (patchOp o2) (patchOp o3)-    EON o1 o2 o3   -> EON  (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)-    ROR o1 o2 o3   -> ROR  (patchOp o1) (patchOp o2) (patchOp o3)-    TST o1 o2      -> TST  (patchOp o1) (patchOp o2)      -- 4. Branch Instructions ---------------------------------------------------    J t            -> J (patchTarget t)-    B t            -> B (patchTarget t)-    BL t rs ts     -> BL (patchTarget t) rs ts-    BCOND c t      -> BCOND c (patchTarget t)+    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 ---------------------------------------------@@ -254,20 +289,27 @@     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)-    STP f o1 o2 o3 -> STP f (patchOp o1) (patchOp o2) (patchOp o3)-    LDP f o1 o2 o3 -> LDP f (patchOp o1) (patchOp o2) (patchOp o3)+    LDAR f o1 o2   -> LDAR f (patchOp o1) (patchOp o2)      -- 8. Synchronization Instructions ------------------------------------------    DMBSY          -> DMBSY+    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) -    _ -> pprPanic "patchRegsOfInstr" (text $ show instr)+    NEWBLOCK{}     -> panic $ "patchRegsOfInstr: " ++ instrCon instr+    LOCATION{}     -> panic $ "patchRegsOfInstr: " ++ instrCon instr     where         patchOp :: Operand -> Operand         patchOp (OpReg w r) = OpReg w (env r)@@ -292,6 +334,7 @@     CBZ{} -> True     CBNZ{} -> True     J{} -> True+    J_TBL{} -> True     B{} -> True     BL{} -> True     BCOND{} -> True@@ -305,11 +348,23 @@ 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 (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.@@ -320,10 +375,11 @@         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 rs -> BL (TBlock (patchF bid)) ps rs+        BL (TBlock bid) ps -> BL (TBlock (patchF bid)) ps         BCOND c (TBlock bid) -> BCOND c (TBlock (patchF bid))-        _ -> pprPanic "patchJumpInstr" (text $ show instr)+        _ -> panic $ "patchJumpInstr: " ++ instrCon instr  -- ----------------------------------------------------------------------------- -- Note [Spills and Reloads]@@ -338,32 +394,31 @@ -- -- 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 poitner--- always poitns to the top of the stack, and we can't use it for computation.+-- 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-   -> Reg       -- register to spill+   -> RegWithFormat -- register to spill    -> Int       -- current stack delta    -> Int       -- spill slot to use    -> [Instr] -mkSpillInstr config reg delta slot =-  case (spillSlotToOffset config slot) - delta of+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 into" <+> int imm)+    imm -> pprPanic "mkSpillInstr" (text "Unable to spill register into" <+> int imm)     where         a .&~. b = a .&. (complement b) -        fmt = case reg of-            RegReal (RealRegSingle n) | n < 32 -> II64-            _                                  -> FF64+        -- 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)))@@ -372,26 +427,23 @@  mkLoadInstr    :: NCGConfig-   -> Reg       -- register to load+   -> RegWithFormat    -> Int       -- current stack delta    -> Int       -- spill slot to use    -> [Instr]--mkLoadInstr config reg delta slot =-  case (spillSlotToOffset config slot) - delta of+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 "mkSpillInstr" (text "Unable to spill into" <+> int imm)+    imm -> pprPanic "mkLoadInstr" (text "Unable to load spilled register at" <+> int imm)     where         a .&~. b = a .&. (complement b) -        fmt = case reg of-            RegReal (RealRegSingle n) | n < 32 -> II64-            _                                  -> FF64-+        -- 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)))@@ -413,7 +465,6 @@     COMMENT{}   -> True     MULTILINE_COMMENT{} -> True     LOCATION{}  -> True-    LDATA{}     -> True     NEWBLOCK{}  -> True     DELTA{}     -> True     PUSH_STACK_FRAME -> True@@ -422,13 +473,27 @@  -- | Copy the value in a register to another one. -- Must work for all register classes.-mkRegRegMoveInstr :: Reg -> Reg -> Instr-mkRegRegMoveInstr src dst = ANN (text "Reg->Reg Move: " <> ppr src <> text " -> " <> ppr dst) $ MOV (OpReg W64 dst) (OpReg W64 src)+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 from this reg -> reg move instruction--- or Nothing if it's not one+-- | 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)) | fmt == fmt' = Just (src, dst)+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.@@ -456,13 +521,13 @@   :: Platform   -> Int   -> NatCmmDecl statics GHC.CmmToAsm.AArch64.Instr.Instr-  -> UniqSM (NatCmmDecl statics GHC.CmmToAsm.AArch64.Instr.Instr, [(BlockId,BlockId)])+  -> 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 -    uniqs <- getUniquesM+    retargetList <- mapM (\e -> (e,) <$> newBlockId) entries      let       delta = ((x + stackAlign - 1) `quot` stackAlign) * stackAlign -- round up@@ -471,8 +536,6 @@       alloc   = mkStackAllocInstr   platform delta       dealloc = mkStackDeallocInstr platform delta -      retargetList = (zip entries (map mkBlockId uniqs))-       new_blockmap :: LabelMap BlockId       new_blockmap = mapFromList retargetList @@ -516,11 +579,6 @@     -- 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@@ -541,14 +599,14 @@     | PUSH_STACK_FRAME     | POP_STACK_FRAME     -- 1. Arithmetic Instructions -----------------------------------------------    -- | ADC Operand Operand Operang -- rd = rn + rm + C+    -- | 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 ...-    | CMN Operand Operand -- rd + op2     | CMP Operand Operand -- rd - op2+    | CMN Operand Operand -- rd + op2     -- | MADD ...     -- | MNEG ...     | MSUB Operand Operand Operand Operand -- rd = ra - rn × rm@@ -571,8 +629,8 @@     -- | UMADDL ...  -- Xd = Xa + Wn × Wm     -- | UMNEGL ... -- Xd = - Wn × Wm     -- | UMSUBL ... -- Xd = Xa - Wn × Wm-    -- | UMULH ... -- Xd = (Xn × Xm)_127:64-    -- | UMULL ... -- Xd = 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]@@ -585,32 +643,33 @@     -- 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-    | ANDS Operand Operand Operand -- rd = rn & op2     | ASR Operand Operand Operand -- rd = rn ≫ rm  or  rd = rn ≫ #i, i is 6 bits-    | BIC Operand Operand Operand -- rd = rn & ~op2-    | BICS Operand Operand Operand -- rd = rn & ~op2-    | EON Operand Operand Operand -- rd = rn ⊕ ~op2     | 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+    | MOVZ Operand Operand     | MVN Operand Operand -- rd = ~rn-    | ORN Operand Operand Operand -- rd = rn | ~op2     | ORR Operand Operand Operand -- rd = rn | op2-    | ROR Operand Operand Operand -- rd = rn ≫ rm  or  rd = rn ≫ #i, i is 6 bits-    | TST Operand Operand -- 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-    | STP Format Operand Operand Operand -- stp Xn, Xm, address-mode // Xn -> *addr, Xm -> *(addr + 8)-    | LDP Format Operand Operand Operand -- stp Xn, Xm, address-mode // Xn <- *addr, Xm <- *(addr + 8)+    | LDAR Format Operand Operand -- ldar Xn, address-mode // Xn <- *addr      -- Conditional instructions     | CSET Operand Cond   -- if(cond) op <- 1 else op <- 0@@ -619,13 +678,16 @@     | 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] [Reg] -- branch and link (e.g. set x30 to next pc, and branch)+    | BL Target [Reg] -- branch and link (e.g. set x30 to next pc, and branch)     | BCOND Cond Target   -- branch with condition. b.<cond>      -- 8. Synchronization Instructions ------------------------------------------    | DMBSY+    | 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@@ -634,16 +696,104 @@     | 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 -instance Show Instr where-    show (LDR _f o1 o2) = "LDR " ++ show o1 ++ ", " ++ show o2-    show (MOV o1 o2) = "MOV " ++ show o1 ++ ", " ++ show o2-    show _ = "missing"+    -- | 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@@ -677,9 +827,7 @@ opReg :: Width -> Reg -> Operand opReg = OpReg -xzr, wzr, sp, ip0 :: Operand-xzr = OpReg W64 (RegReal (RealRegSingle (-1)))-wzr = OpReg W32 (RegReal (RealRegSingle (-1)))+sp, ip0 :: Operand sp  = OpReg W64 (RegReal (RealRegSingle 31)) ip0 = OpReg W64 (RegReal (RealRegSingle 16)) @@ -766,11 +914,11 @@ opRegUExt W32 r = OpRegExt W32 r EUXTW 0 opRegUExt W16 r = OpRegExt W16 r EUXTH 0 opRegUExt W8  r = OpRegExt W8  r EUXTB 0-opRegUExt w  _r = pprPanic "opRegUExt" (text $ show w)+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" (text $ show w)+opRegSExt w  _r = pprPanic "opRegSExt" (ppr w)
GHC/CmmToAsm/AArch64/Ppr.hs view
@@ -1,7 +1,6 @@ {-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE CPP #-} -module GHC.CmmToAsm.AArch64.Ppr (pprNatCmmDecl, pprInstr) where+module GHC.CmmToAsm.AArch64.Ppr (pprNatCmmDecl, pprInstr, pprBasicBlock) where  import GHC.Prelude hiding (EQ) @@ -16,13 +15,10 @@ import GHC.CmmToAsm.Utils  import GHC.Cmm hiding (topInfoTable)-import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Label-import GHC.Types.Basic (Alignment, mkAlignment, alignmentBytes)  import GHC.Cmm.BlockId import GHC.Cmm.CLabel-import GHC.Cmm.Ppr.Expr () -- For Outputable instances  import GHC.Types.Unique ( pprUniqueAlways, getUnique ) import GHC.Platform@@ -30,66 +26,62 @@  import GHC.Utils.Panic -pprProcAlignment :: NCGConfig -> SDoc-pprProcAlignment config = maybe empty (pprAlign platform . mkAlignment) (ncgProcAlignment config)-   where-      platform = ncgPlatform config--pprNatCmmDecl :: NCGConfig -> NatCmmDecl RawCmmStatics Instr -> SDoc+pprNatCmmDecl :: IsDoc doc => NCGConfig -> NatCmmDecl RawCmmStatics Instr -> doc pprNatCmmDecl config (CmmData section dats) =-  pprSectionAlign config section $$ pprDatas config 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 in-  pprProcAlignment config $$+  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 $$-        pprLabel platform lbl $$ -- blocks guaranteed not null, so label needed-        vcat (map (pprBasicBlock config top_info) blocks) $$+        (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 ppr (mkAsmTempEndLabel lbl) <> char ':' else empty) $$+         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 ppr (mkDeadStripPreventer info_lbl) <> char ':'+          then line (pprAsmLabel platform (mkDeadStripPreventer info_lbl) <> char ':')           else empty) $$-      vcat (map (pprBasicBlock config top_info) blocks) $$+      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]-                text "\t.long "-            <+> ppr info_lbl+                line+              $ text "\t.long "+            <+> pprAsmLabel platform info_lbl             <+> char '-'-            <+> ppr (mkDeadStripPreventer info_lbl)+            <+> 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 :: Platform -> CLabel -> SDoc+pprLabel :: IsDoc doc => Platform -> CLabel -> doc pprLabel platform lbl =    pprGloblDecl platform lbl    $$ pprTypeDecl platform lbl-   $$ (pdoc platform lbl <> char ':')--pprAlign :: Platform -> Alignment -> SDoc-pprAlign _platform alignment-        = text "\t.balign " <> int (alignmentBytes alignment)+   $$ line (pprAsmLabel platform lbl <> char ':')  -- | Print appropriate alignment for the given section type.-pprAlignForSection :: Platform -> SectionType -> SDoc+pprAlignForSection :: IsDoc doc => Platform -> SectionType -> doc pprAlignForSection _platform _seg     -- .balign is stable, whereas .align is platform dependent.-    = text "\t.balign 8" --  always 8--instance Outputable Instr where-    ppr = pprInstr genericPlatform+    = line (text "\t.balign 8") --  always 8  -- | Print section header and appropriate alignment for that section. --@@ -98,28 +90,28 @@ --     .section .text --     .balign 8 ---pprSectionAlign :: NCGConfig -> Section -> SDoc+pprSectionAlign :: IsDoc doc => NCGConfig -> Section -> doc pprSectionAlign _config (Section (OtherSection _) _) =      panic "AArch64.Ppr.pprSectionAlign: unknown section" pprSectionAlign config sec@(Section seg _) =-    pprSectionHeader config sec+    line (pprSectionHeader config sec)     $$ pprAlignForSection (ncgPlatform config) seg  -- | Output the ELF .size directive.-pprSizeDecl :: Platform -> CLabel -> SDoc+pprSizeDecl :: IsDoc doc => Platform -> CLabel -> doc pprSizeDecl platform lbl  = if osElfTarget (platformOS platform)-   then text "\t.size" <+> pdoc platform lbl <> text ", .-" <> pdoc platform lbl+   then line (text "\t.size" <+> pprAsmLabel platform lbl <> text ", .-" <> pprAsmLabel platform lbl)    else empty -pprBasicBlock :: NCGConfig -> LabelMap RawCmmStatics -> NatBasicBlock Instr-              -> SDoc-pprBasicBlock config info_env (BasicBlock blockid instrs)+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  ncgDwarfEnabled config-      then ppr (mkAsmTempEndLabel asmLbl) <> char ':'+    (if  with_dwarf+      then line (pprAsmLabel platform (mkAsmTempEndLabel asmLbl) <> char ':')       else empty     )   where@@ -129,17 +121,16 @@             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) $$+           vcat (map (pprData platform) info) $$            pprLabel platform info_lbl $$            c $$-           (if ncgDwarfEnabled config-             then ppr (mkAsmTempEndLabel info_lbl) <> char ':'+           (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]@@ -147,51 +138,48 @@       (l@LOCATION{} : _) -> pprInstr platform l       _other             -> empty -pprDatas :: NCGConfig -> RawCmmStatics -> SDoc+pprDatas :: IsDoc doc => Platform -> RawCmmStatics -> doc -- See Note [emit-time elimination of static indirections] in "GHC.Cmm.CLabel".-pprDatas config (CmmStaticsRaw alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _])+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 (ncgPlatform config) alias-    $$ text ".equiv" <+> pdoc (ncgPlatform config) alias <> comma <> pdoc (ncgPlatform config) (CmmLabel ind')+  = pprGloblDecl platform alias+    $$ line (text ".equiv" <+> pprAsmLabel platform alias <> comma <> pprAsmLabel platform ind') -pprDatas config (CmmStaticsRaw lbl dats)-  = vcat (pprLabel platform lbl : map (pprData config) dats)-   where-      platform = ncgPlatform config+pprDatas platform (CmmStaticsRaw lbl dats)+  = vcat (pprLabel platform lbl : map (pprData platform) dats) -pprData :: NCGConfig -> CmmStatic -> SDoc-pprData _config (CmmString str) = pprString str-pprData _config (CmmFileEmbed path) = pprFileEmbed path+pprData :: IsDoc doc => Platform -> CmmStatic -> doc+pprData _platform (CmmString str) = line (pprString str)+pprData _platform (CmmFileEmbed path _) = line (pprFileEmbed path) -pprData config (CmmUninitialised bytes)- = let platform = ncgPlatform config-   in if platformOS platform == OSDarwin-         then text ".space " <> int bytes-         else text ".skip "  <> int bytes+pprData platform (CmmUninitialised bytes)+ = line $ if platformOS platform == OSDarwin+                then text ".space " <> int bytes+                else text ".skip "  <> int bytes -pprData config (CmmStaticLit lit) = pprDataItem config lit+pprData platform (CmmStaticLit lit) = pprDataItem platform lit -pprGloblDecl :: Platform -> CLabel -> SDoc+pprGloblDecl :: IsDoc doc => Platform -> CLabel -> doc pprGloblDecl platform lbl   | not (externallyVisibleCLabel lbl) = empty-  | otherwise = text "\t.globl " <> pdoc platform lbl+  | 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 migth want to lookup the+-- 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' :: Platform -> CLabel -> SDoc+pprLabelType' :: IsLine doc => Platform -> CLabel -> doc pprLabelType' platform lbl =   if isCFunctionLabel lbl || functionOkInfoTable then     text "@function"@@ -199,21 +187,19 @@     text "@object"   where     functionOkInfoTable = platformTablesNextToCode platform &&-      isInfoTableLabel lbl && not (isConInfoTableLabel lbl)+      isInfoTableLabel lbl && not (isCmmInfoTableLabel lbl) && not (isConInfoTableLabel lbl)  -- this is called pprTypeAndSizeDecl in PPC.Ppr-pprTypeDecl :: Platform -> CLabel -> SDoc+pprTypeDecl :: IsDoc doc => Platform -> CLabel -> doc pprTypeDecl platform lbl     = if osElfTarget (platformOS platform) && externallyVisibleCLabel lbl-      then text ".type " <> pdoc platform lbl <> text ", " <> pprLabelType' platform lbl+      then line (text ".type " <> pprAsmLabel platform lbl <> text ", " <> pprLabelType' platform lbl)       else empty -pprDataItem :: NCGConfig -> CmmLit -> SDoc-pprDataItem config lit-  = vcat (ppr_item (cmmTypeFormat $ cmmLitType platform lit) lit)+pprDataItem :: IsDoc doc => Platform -> CmmLit -> doc+pprDataItem platform lit+  = lines_ (ppr_item (cmmTypeFormat $ cmmLitType platform lit) lit)     where-        platform = ncgPlatform config-         imm = litToImm lit          ppr_item II8  _ = [text "\t.byte\t"  <> pprImm platform imm]@@ -231,12 +217,12 @@          ppr_item _ _ = pprPanic "pprDataItem:ppr_item" (text $ show lit) -pprImm :: Platform -> Imm -> SDoc+pprImm :: IsLine doc => Platform -> Imm -> doc pprImm _ (ImmInt i)     = int i pprImm _ (ImmInteger i) = integer i-pprImm p (ImmCLbl l)    = pdoc p l-pprImm p (ImmIndex l i) = pdoc p l <> char '+' <> int i-pprImm _ (ImmLit s)     = s+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)@@ -261,13 +247,13 @@ asmMultilineComment :: SDoc -> SDoc asmMultilineComment c = whenPprDebug $ text "/*" $+$ c $+$ text "*/" -pprIm :: Platform -> Imm -> SDoc+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 expressable as ±n ÷ 16 × 2^r,+  -- 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.   --@@ -277,17 +263,17 @@   -- This is something the x86 backend does.   --   -- We could also just turn them into statics :-/ Which is what the-  -- PowerPC backend odes.+  -- PowerPC backend does.   ImmFloat f | f == 0 -> text "wzr"   ImmFloat f -> char '#' <> float (fromRational f)   ImmDouble d | d == 0 -> text "xzr"   ImmDouble d -> char '#' <> double (fromRational d)   -- =<lbl> pseudo instruction!-  ImmCLbl l    -> char '=' <> pdoc platform l-  ImmIndex l o -> text "[=" <> pdoc platform l <> comma <+> char '#' <> int o <> char ']'+  ImmCLbl l    -> char '=' <> pprAsmLabel platform l+  ImmIndex l o -> text "[=" <> pprAsmLabel platform l <> comma <+> char '#' <> int o <> char ']'   _            -> panic "AArch64.pprIm" -pprExt :: ExtMode -> SDoc+pprExt :: IsLine doc => ExtMode -> doc pprExt EUXTB = text "uxtb" pprExt EUXTH = text "uxth" pprExt EUXTW = text "uxtw"@@ -297,13 +283,13 @@ pprExt ESXTW = text "sxtw" pprExt ESXTX = text "sxtx" -pprShift :: ShiftMode -> SDoc+pprShift :: IsLine doc => ShiftMode -> doc pprShift SLSL = text "lsl" pprShift SLSR = text "lsr" pprShift SASR = text "asr" pprShift SROR = text "ror" -pprOp :: Platform -> Operand -> SDoc+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@@ -311,26 +297,26 @@   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 compuation always use registers as 64bit -- is this correct?+  -- 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 :: Width -> Reg -> SDoc+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 (VirtualRegF u)   -> text "%vF_" <> pprUniqueAlways u   RegVirtual (VirtualRegD u)   -> text "%vD_" <> pprUniqueAlways u   _                            -> pprPanic "AArch64.pprReg" (text $ show r)    where-    ppr_reg_no :: Width -> Int -> SDoc+    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"@@ -346,116 +332,123 @@          | 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)-         -- no support for 'q'uad in GHC's NCG yet.-         | otherwise = text "very naughty powerpc register"+         | 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 (VirtualRegF _))) = True isFloatOp (OpReg _ (RegVirtual (VirtualRegD _))) = True+-- SIMD NCG TODO: what about VirtualVecV128? Could be floating-point or not? isFloatOp _ = False -pprInstr :: Platform -> Instr -> SDoc+pprInstr :: IsDoc doc => Platform -> Instr -> doc pprInstr platform instr = case instr of   -- Meta Instructions ----------------------------------------------------------  COMMENT s  -> asmComment s-  MULTILINE_COMMENT s -> asmMultilineComment s-  ANN d i -> pprInstr platform i <+> asmDoubleslashComment d-  LOCATION file line col _name-    -> text "\t.loc" <+> ppr file <+> ppr line <+> ppr col-  DELTA d    -> asmComment $ text ("\tdelta = " ++ show d)-  NEWBLOCK _ -> panic "PprInstr: NEWBLOCK"-  LDATA _ _  -> panic "pprInstr: LDATA"+  -- 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 -> text "\tstp x29, x30, [sp, #-16]!"-                   $$ text "\tmov x29, sp"+  PUSH_STACK_FRAME -> lines_ [text "\tstp x29, x30, [sp, #-16]!",+                              text "\tmov x29, sp"] -  POP_STACK_FRAME -> text "\tldp x29, x30, [sp], #16"+  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 -> text "\tfadd"  <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3-    | otherwise -> text "\tadd"  <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3-  CMN  o1 o2    -> text "\tcmn"  <+> pprOp platform o1 <> comma <+> pprOp platform o2+    | 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 -> text "\tfcmp"  <+> pprOp platform o1 <> comma <+> pprOp platform o2-    | otherwise -> text "\tcmp" <+> pprOp platform o1 <> comma <+> pprOp platform o2-  MSUB o1 o2 o3 o4 -> text "\tmsub" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 <> comma <+> pprOp platform o4+    | 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 -> text "\tfmul"  <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3-    | otherwise -> text "\tmul"  <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3-  SMULH o1 o2 o3 -> text "\tsmulh"  <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3-  SMULL o1 o2 o3 -> text "\tsmull"  <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform 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 -> text "\tfneg"  <+> pprOp platform o1 <> comma <+> pprOp platform o2-    | otherwise -> text "\tneg"  <+> pprOp platform o1 <> comma <+> pprOp platform 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-    -> text "\tfdiv" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3-  SDIV o1 o2 o3 -> text "\tsdiv" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform 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 -> text "\tfsub"  <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3-    | otherwise -> text "\tsub"  <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3-  UDIV o1 o2 o3 -> text "\tudiv" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform 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 -> text "\tsbfm" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 <> comma <+> pprOp platform o4-  UBFM o1 o2 o3 o4 -> text "\tubfm" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 <> comma <+> pprOp platform o4+  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 -> text "\tsbfx" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 <> comma <+> pprOp platform o4-  UBFX o1 o2 o3 o4 -> text "\tubfx" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 <> comma <+> pprOp platform o4-  SXTB o1 o2       -> text "\tsxtb" <+> pprOp platform o1 <> comma <+> pprOp platform o2-  UXTB o1 o2       -> text "\tuxtb" <+> pprOp platform o1 <> comma <+> pprOp platform o2-  SXTH o1 o2       -> text "\tsxth" <+> pprOp platform o1 <> comma <+> pprOp platform o2-  UXTH o1 o2       -> text "\tuxth" <+> pprOp platform o1 <> comma <+> pprOp platform o2+  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  -> text "\tand" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3-  ANDS o1 o2 o3 -> text "\tands" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3-  ASR o1 o2 o3  -> text "\tasr" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3-  BIC o1 o2 o3  -> text "\tbic" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3-  BICS o1 o2 o3 -> text "\tbics" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3-  EON o1 o2 o3  -> text "\teon" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3-  EOR o1 o2 o3  -> text "\teor" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3-  LSL o1 o2 o3  -> text "\tlsl" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3-  LSR o1 o2 o3  -> text "\tlsr" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3+  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 -> text "\tfmov" <+> pprOp platform o1 <> comma <+> pprOp platform o2-    | otherwise -> text "\tmov" <+> pprOp platform o1 <> comma <+> pprOp platform o2-  MOVK o1 o2    -> text "\tmovk" <+> pprOp platform o1 <> comma <+> pprOp platform o2-  MVN o1 o2     -> text "\tmvn" <+> pprOp platform o1 <> comma <+> pprOp platform o2-  ORN o1 o2 o3  -> text "\torn" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3-  ORR o1 o2 o3  -> text "\torr" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3-  ROR o1 o2 o3  -> text "\tror" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3-  TST o1 o2     -> text "\ttst" <+> pprOp platform o1 <> comma <+> pprOp platform 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)-  B (TBlock bid) -> text "\tb" <+> pdoc platform (mkLocalBlockLabel (getUnique bid))-  B (TLabel lbl) -> text "\tb" <+> pdoc platform lbl-  B (TReg r)     -> text "\tbr" <+> pprReg W64 r+  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) _ _ -> text "\tbl" <+> pdoc platform (mkLocalBlockLabel (getUnique bid))-  BL (TLabel lbl) _ _ -> text "\tbl" <+> pdoc platform lbl-  BL (TReg r)     _ _ -> text "\tblr" <+> 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) -> text "\t" <> pprBcond c <+> pdoc platform (mkLocalBlockLabel (getUnique bid))-  BCOND c (TLabel lbl) -> text "\t" <> pprBcond c <+> pdoc platform lbl+  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  -> text "\tcset" <+> pprOp platform o <> comma <+> pprCond c+  CSET o c  -> line $ text "\tcset" <+> pprOp platform o <> comma <+> pprCond c -  CBZ o (TBlock bid) -> text "\tcbz" <+> pprOp platform o <> comma <+> pdoc platform (mkLocalBlockLabel (getUnique bid))-  CBZ o (TLabel lbl) -> text "\tcbz" <+> pprOp platform o <> comma <+> pdoc platform lbl+  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) -> text "\tcbnz" <+> pprOp platform o <> comma <+> pdoc platform (mkLocalBlockLabel (getUnique bid))-  CBNZ o (TLabel lbl) -> text "\tcbnz" <+> pprOp platform o <> comma <+> pdoc platform lbl+  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 --------------------------------------------@@ -463,88 +456,111 @@   --       address. Not observing the correct size when loading will lead   --       inevitably to crashes.   STR _f o1@(OpReg W8 (RegReal (RealRegSingle i))) o2 | i < 32 ->-    text "\tstrb" <+> pprOp platform o1 <> comma <+> pprOp platform o2+    op2 (text "\tstrb") o1 o2   STR _f o1@(OpReg W16 (RegReal (RealRegSingle i))) o2 | i < 32 ->-    text "\tstrh" <+> pprOp platform o1 <> comma <+> pprOp platform o2-  STR _f o1 o2 -> text "\tstr" <+> pprOp platform o1 <> comma <+> pprOp platform o2+    op2 (text "\tstrh") o1 o2+  STR _f o1 o2 -> op2 (text "\tstr") o1 o2+  STLR _f o1 o2 -> op2 (text "\tstlr") o1 o2 -#if defined(darwin_HOST_OS)   LDR _f o1 (OpImm (ImmIndex lbl' off)) | Just (_info, lbl) <- dynamicLinkerLabelInfo lbl' ->-    text "\tadrp" <+> pprOp platform o1 <> comma <+> pdoc platform lbl <> text "@gotpage" $$-    text "\tldr" <+> pprOp platform o1 <> comma <+> text "[" <> pprOp platform o1 <> comma <+> pdoc platform lbl <> text "@gotpageoff" <> text "]" $$-    text "\tadd" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> char '#' <> int off -- TODO: check that off is in 12bits.--  LDR _f o1 (OpImm (ImmIndex lbl off)) | isForeignLabel lbl ->-    text "\tadrp" <+> pprOp platform o1 <> comma <+> pdoc platform lbl <> text "@gotpage" $$-    text "\tldr" <+> pprOp platform o1 <> comma <+> text "[" <> pprOp platform o1 <> comma <+> pdoc platform lbl <> text "@gotpageoff" <> text "]" $$-    text "\tadd" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> char '#' <> int off -- TODO: check that off is in 12bits.--  LDR _f o1 (OpImm (ImmIndex lbl off)) ->-    text "\tadrp" <+> pprOp platform o1 <> comma <+> pdoc platform lbl <> text "@page" $$-    text "\tadd" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> pdoc platform lbl <> text "@pageoff" $$-    text "\tadd" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> char '#' <> int off -- TODO: check that off is in 12bits.--  LDR _f o1 (OpImm (ImmCLbl lbl')) | Just (_info, lbl) <- dynamicLinkerLabelInfo lbl' ->-    text "\tadrp" <+> pprOp platform o1 <> comma <+> pdoc platform lbl <> text "@gotpage" $$-    text "\tldr" <+> pprOp platform o1 <> comma <+> text "[" <> pprOp platform o1 <> comma <+> pdoc platform lbl <> text "@gotpageoff" <> text "]"--  LDR _f o1 (OpImm (ImmCLbl lbl)) | isForeignLabel lbl ->-    text "\tadrp" <+> pprOp platform o1 <> comma <+> pdoc platform lbl <> text "@gotpage" $$-    text "\tldr" <+> pprOp platform o1 <> comma <+> text "[" <> pprOp platform o1 <> comma <+> pdoc platform lbl <> text "@gotpageoff" <> text "]"--  LDR _f o1 (OpImm (ImmCLbl lbl)) ->-    text "\tadrp" <+> pprOp platform o1 <> comma <+> pdoc platform lbl <> text "@page" $$-    text "\tadd" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> pdoc platform lbl <> text "@pageoff"-#else-  LDR _f o1 (OpImm (ImmIndex lbl' off)) | Just (_info, lbl) <- dynamicLinkerLabelInfo lbl' ->-    text "\tadrp" <+> pprOp platform o1 <> comma <+> text ":got:" <> pdoc platform lbl $$-    text "\tldr" <+> pprOp platform o1 <> comma <+> text "[" <> pprOp platform o1 <> comma <+> text ":got_lo12:" <> pdoc platform lbl <> text "]" $$-    text "\tadd" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> char '#' <> int off -- TODO: check that off is in 12bits.+    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 ->-    text "\tadrp" <+> pprOp platform o1 <> comma <+> text ":got:" <> pdoc platform lbl $$-    text "\tldr" <+> pprOp platform o1 <> comma <+> text "[" <> pprOp platform o1 <> comma <+> text ":got_lo12:" <> pdoc platform lbl <> text "]" $$-    text "\tadd" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> char '#' <> int off -- TODO: check that off is in 12bits.+    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)) ->-    text "\tadrp" <+> pprOp platform o1 <> comma <+> pdoc platform lbl $$-    text "\tadd" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> text ":lo12:" <> pdoc platform lbl $$-    text "\tadd" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> char '#' <> int off -- TODO: check that off is in 12bits.+    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' ->-    text "\tadrp" <+> pprOp platform o1 <> comma <+> text ":got:" <> pdoc platform lbl $$-    text "\tldr" <+> pprOp platform o1 <> comma <+> text "[" <> pprOp platform o1 <> comma <+> text ":got_lo12:" <> pdoc platform lbl <> text "]"+    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 ->-    text "\tadrp" <+> pprOp platform o1 <> comma <+> text ":got:" <> pdoc platform lbl $$-    text "\tldr" <+> pprOp platform o1 <> comma <+> text "[" <> pprOp platform o1 <> comma <+> text ":got_lo12:" <> pdoc platform lbl <> text "]"+    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)) ->-    text "\tadrp" <+> pprOp platform o1 <> comma <+> pdoc platform lbl $$-    text "\tadd" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> text ":lo12:" <> pdoc platform lbl-#endif+    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 ->-    text "\tldrb" <+> pprOp platform o1 <> comma <+> pprOp platform o2+    op2 (text "\tldrb") o1 o2   LDR _f o1@(OpReg W16 (RegReal (RealRegSingle i))) o2 | i < 32 ->-    text "\tldrh" <+> pprOp platform o1 <> comma <+> pprOp platform o2-  LDR _f o1 o2 -> text "\tldr" <+> pprOp platform o1 <> comma <+> pprOp platform o2--  STP _f o1 o2 o3 -> text "\tstp" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3-  LDP _f o1 o2 o3 -> text "\tldp" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3+    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 --------------------------------------------  DMBSY -> text "\tdmb sy"+  DMBISH DmbLoadStore -> line $ text "\tdmb ish"+  DMBISH DmbLoad -> line $ text "\tdmb ishld"+   -- 9. Floating Point Instructions ---------------------------------------------  FCVT o1 o2 -> text "\tfcvt" <+> pprOp platform o1 <> comma <+> pprOp platform o2-  SCVTF o1 o2 -> text "\tscvtf" <+> pprOp platform o1 <> comma <+> pprOp platform o2-  FCVTZS o1 o2 -> text "\tfcvtzs" <+> pprOp platform o1 <> comma <+> pprOp platform o2-  FABS o1 o2 -> text "\tfabs" <+> pprOp platform o1 <> comma <+> pprOp platform o2+  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 -pprBcond :: Cond -> SDoc+       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 :: Cond -> SDoc+pprCond :: IsLine doc => Cond -> doc pprCond c = case c of   ALWAYS -> text "al" -- Always   EQ     -> text "eq" -- Equal@@ -560,11 +576,11 @@   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+  -- NEVER  -> text "nv" -- Never   VS     -> text "vs" -- Overflow                          ; Unordered (at least one NaN operand)   VC     -> text "vc" -- No overflow                       ; Not unordered -  -- Orderd variants.  Respecting NaN.+  -- Ordered variants.  Respecting NaN.   OLT    -> text "mi"   OLE    -> text "ls"   OGE    -> text "ge"
GHC/CmmToAsm/AArch64/RegInfo.hs view
@@ -14,18 +14,16 @@ instance Outputable JumpDest where   ppr (DestBlockId bid) = text "jd<blk>:" <> ppr bid --- TODO: documen what this does. See Ticket 19914+-- Implementations of the methods of 'NgcImpl'+ getJumpDestBlockId :: JumpDest -> Maybe BlockId getJumpDestBlockId (DestBlockId bid) = Just bid --- TODO: document what this does. See Ticket 19914 canShortcut :: Instr -> Maybe JumpDest canShortcut _ = Nothing --- TODO: document what this does. See Ticket 19914 shortcutStatics :: (BlockId -> Maybe JumpDest) -> RawCmmStatics -> RawCmmStatics shortcutStatics _ other_static = other_static --- TODO: document what this does. See Ticket 19914 shortcutJump :: (BlockId -> Maybe JumpDest) -> Instr -> Instr shortcutJump _ other = other
GHC/CmmToAsm/AArch64/Regs.hs view
@@ -2,9 +2,10 @@ module GHC.CmmToAsm.AArch64.Regs where  import GHC.Prelude+import GHC.Data.FastString  import GHC.Platform.Reg-import GHC.Platform.Reg.Class+import GHC.Platform.Reg.Class.Unified import GHC.CmmToAsm.Format  import GHC.Cmm@@ -16,6 +17,7 @@ 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.@@ -59,7 +61,7 @@   = ImmInt      Int   | ImmInteger  Integer     -- Sigh.   | ImmCLbl     CLabel      -- AbstractC Label (with baggage)-  | ImmLit      SDoc        -- Simple string+  | ImmLit      FastString   | ImmIndex    CLabel Int   | ImmFloat    Rational   | ImmDouble   Rational@@ -67,14 +69,8 @@   | ImmConstantDiff Imm Imm   deriving (Eq, Show) -instance Show SDoc where-  show = showPprUnsafe . ppr--instance Eq SDoc where-  lhs == rhs = show lhs == show rhs--strImmLit :: String -> Imm-strImmLit s = ImmLit (text s)+strImmLit :: FastString -> Imm+strImmLit s = ImmLit s   litToImm :: CmmLit -> Imm@@ -82,6 +78,8 @@                 -- 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@@ -111,14 +109,12 @@                 VirtualRegHi{}          -> 1                 _other                  -> 0 -        RcDouble+        RcFloatOrVector          -> case vr of                 VirtualRegD{}           -> 1-                VirtualRegF{}           -> 0+                VirtualRegV128{}        -> 1                 _other                  -> 0 -        _other -> 0- {-# INLINE realRegSqueeze #-} realRegSqueeze :: RegClass -> RealReg -> Int realRegSqueeze cls rr@@ -129,14 +125,12 @@                         | regNo < 32    -> 1     -- first fp reg is 32                         | otherwise     -> 0 -        RcDouble+        RcFloatOrVector          -> case rr of                 RealRegSingle regNo                         | regNo < 32    -> 0                         | otherwise     -> 1 -        _other -> 0- mkVirtualReg :: Unique -> Format -> VirtualReg mkVirtualReg u format    | not (isFloatFormat format) = VirtualRegI u@@ -150,11 +144,10 @@ classOfRealReg :: RealReg -> RegClass classOfRealReg (RealRegSingle i)         | i < 32        = RcInteger-        | otherwise     = RcDouble+        | otherwise     = RcFloatOrVector  regDotColor :: RealReg -> SDoc regDotColor reg  = case classOfRealReg reg of         RcInteger       -> text "blue"-        RcFloat         -> text "red"-        RcDouble        -> text "green"+        RcFloatOrVector -> text "red"
GHC/CmmToAsm/BlockLayout.hs view
@@ -13,7 +13,8 @@     ( sequenceTop, backendMaintainsCfg) where -import GHC.Prelude+import GHC.Prelude hiding (head, init, last, tail)+import qualified GHC.Prelude as Partial (head, tail)  import GHC.Platform @@ -25,7 +26,6 @@  import GHC.Cmm import GHC.Cmm.BlockId-import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Label  import GHC.Types.Unique.FM@@ -35,19 +35,20 @@ import GHC.Data.List.SetOps (removeDups) import GHC.Data.OrdList -import GHC.Utils.Trace import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Utils.Panic.Plain import GHC.Utils.Misc  import Data.List (sortOn, sortBy, nub)+import Data.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]@@ -354,7 +355,7 @@ breakChainAt :: BlockId -> BlockChain              -> (BlockChain,BlockChain) breakChainAt bid (BlockChain blks)-    | not (bid == head rblks)+    | not (bid == Partial.head rblks)     = panic "Block not in chain"     | otherwise     = (BlockChain (toOL lblks),@@ -493,7 +494,7 @@         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 (head chains') (tail chains')+            return $ foldl' chainConcat (Partial.head chains') (Partial.tail chains')         merge ((CfgEdge from to _):edges) chains         --   | pprTrace "merge" (ppr (from,to) <> ppr chains) False         --   = undefined@@ -507,8 +508,8 @@               union cFrom new_point             merge edges chains           where-            cFrom = expectJust "mergeChains:chainMap:from" $ mapLookup from chains-            cTo = expectJust "mergeChains:chainMap:to"   $ mapLookup to   chains+            cFrom = expectJust $ mapLookup from chains+            cTo = expectJust $ mapLookup to   chains   -- See Note [Chain based CFG serialization] for the general idea.@@ -593,8 +594,8 @@             toChain <- readSTRef toRef             let newChain = chainConcat fromChain toChain             ref <- newSTRef newChain-            let start = head $ takeL 1 newChain-            let end = head $ takeR 1 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@@ -655,7 +656,7 @@ sequenceChain _info _weights    [x] = [x] sequenceChain  info weights     blocks@((BasicBlock entry _):_) =     let directEdges :: [CfgEdge]-        directEdges = sortBy (flip compare) $ catMaybes . map relevantWeight $ (infoEdgeList weights)+        directEdges = sortBy (flip compare) $ mapMaybe relevantWeight (infoEdgeList weights)           where             -- Apply modifiers to turn edge frequencies into useable weights             -- for computing code layout.@@ -736,10 +737,6 @@             = [masterChain]             | (rest,entry) <- breakChainAt entry masterChain             = [entry,rest]-#if __GLASGOW_HASKELL__ <= 810-            | otherwise = pprPanic "Entry point eliminated" $-                            ppr masterChain-#endif          blockList             = assert (noDups [masterChain])@@ -758,9 +755,9 @@             -- builds if something slips through.             assert (null unplaced) $             --pprTraceIt "placedBlocks" $-            -- ++ [] is stil kinda expensive+            -- ++ [] is still kinda expensive             if null unplaced then blockList else blockList ++ unplaced-        getBlock bid = expectJust "Block placement" $ mapLookup bid blockMap+        getBlock bid = expectJust $ mapLookup bid blockMap     in         --Assert we placed all blocks given as input         assert (all (\bid -> mapMember bid blockMap) placedBlocks) $@@ -772,13 +769,12 @@ dropJumps :: forall a i. Instruction i => LabelMap a -> [GenBasicBlock i]           -> [GenBasicBlock i] dropJumps _    [] = []-dropJumps info ((BasicBlock lbl ins):todo)-    | not . null $ ins --This can happen because of shortcutting-    , [dest] <- jumpDestsOfInstr (last ins)-    , ((BasicBlock nextLbl _) : _) <- todo-    , not (mapMember dest info)-    , nextLbl == dest-    = BasicBlock lbl (init ins) : dropJumps info todo+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 @@ -797,30 +793,33 @@     => NcgImpl statics instr jumpDest     -> Maybe CFG -- ^ CFG if we have one.     -> NatCmmDecl statics instr -- ^ Function to serialize-    -> NatCmmDecl statics instr+    -> UniqDSM (NatCmmDecl statics instr) -sequenceTop _       _           top@(CmmData _ _) = top-sequenceTop ncgImpl edgeWeights (CmmProc info lbl live (ListGraph blocks))-  = let-      config     = ncgConfig ncgImpl-      platform   = ncgPlatform config+sequenceTop _       _           top@(CmmData _ _) = pure top+sequenceTop ncgImpl edgeWeights (CmmProc info lbl live (ListGraph blocks)) = do+    let config     = ncgConfig ncgImpl+        platform   = ncgPlatform config -    in CmmProc info lbl live $ ListGraph $ ncgMakeFarBranches ncgImpl info $-         if -- Chain based algorithm-            | ncgCfgBlockLayout config-            , backendMaintainsCfg platform-            , Just cfg <- edgeWeights-            -> {-# SCC layoutBlocks #-} sequenceChain info cfg blocks+        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 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+                      -- 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@@ -869,10 +868,10 @@             ((target,info):_)               | length successors > 2 || edgeWeight info <= 0 -> []               | otherwise -> [target]-          | otherwise-          = case jumpDestsOfInstr (last instrs) of-                [one] -> [one]-                _many -> []+          | Just instr <- lastMaybe instrs+          , [one] <- jumpDestsOfInstr instr+          = [one]+          | otherwise = []   seqBlocks :: LabelMap i -> [Node BlockId (GenBasicBlock t1)]
GHC/CmmToAsm/CFG.hs view
@@ -47,9 +47,7 @@ import GHC.Cmm.BlockId import GHC.Cmm as Cmm -import GHC.Cmm.Utils import GHC.Cmm.Switch-import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Label import GHC.Cmm.Dataflow.Block import qualified GHC.Cmm.Dataflow.Graph as G@@ -61,24 +59,26 @@ 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-import GHC.Utils.Panic.Plain -- DEBUGGING ONLY --import GHC.Cmm.DebugBlock --import GHC.Data.OrdList --import GHC.Cmm.DebugBlock.Trace-import GHC.Cmm.Ppr () -- For Outputable instances  import Data.List (sort, nub, partition) import Data.STRef.Strict@@ -92,6 +92,7 @@  import Control.Monad import GHC.Data.UnionFind+import Data.Word  type Prob = Double @@ -221,7 +222,7 @@   -- | Check if the nodes in the cfg and the set of blocks are the same.---   In a case of a missmatch we panic and show the difference.+--   In a case of a mismatch we panic and show the difference. sanityCheckCfg :: CFG -> LabelSet -> SDoc -> Bool sanityCheckCfg m blockSet msg     | blockSet == cfgNodes@@ -309,9 +310,9 @@         -- 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 the the rewrites in the cuts map-        mapM_ (\(from, to) -> expectJust "shortcutWeightMap" (mapLookup from cuts_map)-                              `union` expectJust "shortcutWeightMap" (maybe (Just null) (flip mapLookup cuts_map) to) ) cuts_list+        -- 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@@ -387,10 +388,7 @@  delEdge :: BlockId -> BlockId -> CFG -> CFG delEdge from to m =-    mapAlter remDest from m-    where-        remDest Nothing = Nothing-        remDest (Just wm) = Just $ mapDelete to wm+    mapAdjust (mapDelete to) from m   -- | Destinations from bid ordered by weight (descending)@@ -418,13 +416,10 @@     = Nothing  getEdgeWeight :: CFG -> BlockId -> BlockId -> EdgeWeight-getEdgeWeight cfg from to =-    edgeWeight $ expectJust "Edgeweight for noexisting block" $-                 getEdgeInfo from to cfg+getEdgeWeight cfg from to = edgeWeight $ expectJust $ getEdgeInfo from to cfg  getTransitionSource :: BlockId -> BlockId -> CFG -> TransitionSource-getTransitionSource from to cfg = transitionSource $ expectJust "Source info for noexisting block" $-                        getEdgeInfo from to cfg+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@@ -602,7 +597,7 @@  -} -- | Generate weights for a Cmm proc based on some simple heuristics.-getCfgProc :: Platform -> Weights -> RawCmmDecl -> CFG+getCfgProc :: Platform -> Weights -> GenCmmDecl d h CmmGraph -> CFG getCfgProc _        _       (CmmData {}) = mapEmpty getCfgProc platform weights (CmmProc _info _lab _live graph) = getCfg platform weights graph @@ -665,7 +660,7 @@         (CmmCall { cml_cont = Nothing })   -> []         other ->             panic "Foo" $-            assertPpr False (ppr "Unknown successor cause:" <>+            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@@ -856,7 +851,7 @@      --TODO - This should be a no op: Export constructors? Use unsafeCoerce? ...     rooted = ( fromBlockId root-              , toIntMap $ fmap toIntSet graph) :: (Int, IntMap IntSet)+              , toWord64Map $ fmap toWord64Set graph) :: (Word64, Word64Map Word64Set)     tree = fmap toBlockId $ Dom.domTree rooted :: Tree BlockId      -- Map from Nodes to their dominators@@ -903,10 +898,10 @@           loopCount n = length $ nub . map fst . filter (setMember n . snd) $ bodies       in  map (\n -> (n, loopCount n)) $ nodes :: [(BlockId, Int)] -    toIntSet :: LabelSet -> IntSet-    toIntSet s = IS.fromList . map fromBlockId . setElems $ s-    toIntMap :: LabelMap a -> IntMap a-    toIntMap m = IM.fromList $ map (\(x,y) -> (fromBlockId x,y)) $ mapToList m+    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@@ -921,10 +916,10 @@                             (\n -> go (setInsert (rootLabel n) parents) n)                             leaves -    fromBlockId :: BlockId -> Int+    fromBlockId :: BlockId -> Word64     fromBlockId = getKey . getUnique -    toBlockId :: Int -> BlockId+    toBlockId :: Word64 -> BlockId     toBlockId = mkBlockId . mkUniqueGrimily  -- We make the CFG a Hoopl Graph, so we can reuse revPostOrder.@@ -1006,7 +1001,7 @@     blockMapping = listArray (0,mapSize vertexMapping - 1) revOrder :: Array Int BlockId     -- Map from blockId to indices starting at zero     toVertex :: BlockId -> Int-    toVertex   blockId  = expectJust "mkGlobalWeights" $ mapLookup blockId vertexMapping+    toVertex   blockId  = expectJust $ mapLookup blockId vertexMapping     -- Map from indices starting at zero to blockIds     fromVertex :: Int -> BlockId     fromVertex vertex   = blockMapping ! vertex@@ -1025,11 +1020,11 @@ loops (lehPredicts) and one to predict that backedges are more likely than any other edge. -The back edge case is special as it superceeds any other heuristic if it+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 seeem to have+comparing megaparsec and container benchmarks. Nofib does not seem to have many instances of "loopy" Cmm where these make a difference.  TODO:@@ -1350,7 +1345,7 @@                                 vcat (map (\(k,m) -> ppr (k,m :: IM.IntMap Double)) $ IM.toList g)                             ) -    nodeCount = IM.foldl' (\count toMap -> IM.foldlWithKey' countTargets count toMap) (IM.size graph) graph+    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
GHC/CmmToAsm/CFG/Dominators.hs view
@@ -1,6 +1,3 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE RankNTypes #-} {-# LANGUAGE Strict #-}  {- |@@ -20,8 +17,8 @@       /Advanced Compiler Design and Implementation/, 1997.      \[3\] Brisk, Sarrafzadeh,-      /Interference Graphs for Procedures in Static Single/-      /Information Form are Interval Graphs/, 2007.+      /Interference CGraphs for Procedures in Static Single/+      /Information Form are Interval CGraphs/, 2007.   * Strictness @@ -39,7 +36,7 @@   ,pddfs,rpddfs   ,fromAdj,fromEdges   ,toAdj,toEdges-  ,asTree,asGraph+  ,asTree,asCGraph   ,parents,ancestors ) where @@ -60,15 +57,24 @@ 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  ----------------------------------------------------------------------------- -type Node       = Int-type Path       = [Node]-type Edge       = (Node,Node)-type Graph      = IntMap IntSet-type Rooted     = (Node, Graph)+-- 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/.@@ -110,7 +116,7 @@ -- | /Immediate post-dominators/. -- Complexity as for @idom@. ipdom :: Rooted -> [(Node,Node)]-ipdom rg = runST (evalS idomM =<< initEnv (pruneReach (second predG rg)))+ipdom rg = runST (evalS idomM =<< initEnv (pruneReach (second predGW rg)))  ----------------------------------------------------------------------------- @@ -125,24 +131,24 @@ -----------------------------------------------------------------------------  type Dom s a = S s (Env s) a-type NodeSet    = IntSet-type NodeMap a  = IntMap a+type NodeSet    = Word64Set+type NodeMap a  = Word64Map a data Env s = Env-  {succE      :: !Graph-  ,predE      :: !Graph-  ,bucketE    :: !Graph+  {succE      :: !CGraph+  ,predE      :: !CGraph+  ,bucketE    :: !CGraph   ,dfsE       :: {-# UNPACK #-}!Int-  ,zeroE      :: {-# UNPACK #-}!Node-  ,rootE      :: {-# UNPACK #-}!Node-  ,labelE     :: {-# UNPACK #-}!(Arr s Node)-  ,parentE    :: {-# UNPACK #-}!(Arr s Node)-  ,ancestorE  :: {-# UNPACK #-}!(Arr s Node)-  ,childE     :: {-# UNPACK #-}!(Arr s Node)-  ,ndfsE      :: {-# UNPACK #-}!(Arr s Node)+  ,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 Node)+  ,domE       :: {-# UNPACK #-}!(Arr s CNode)   ,rnE        :: {-# UNPACK #-}!(Arr s Node)}  -----------------------------------------------------------------------------@@ -187,7 +193,7 @@  ----------------------------------------------------------------------------- -eval :: Node -> Dom s Node+eval :: CNode -> Dom s CNode eval v = do   n0 <- zeroM   a  <- ancestorM v@@ -204,7 +210,7 @@         True-> return l         False-> return la -compress :: Node -> Dom s ()+compress :: CNode -> Dom s () compress v = do   n0  <- zeroM   a   <- ancestorM v@@ -223,7 +229,7 @@  ----------------------------------------------------------------------------- -link :: Node -> Node -> Dom s ()+link :: CNode -> CNode -> Dom s () link v w = do   n0  <- zeroM   lw  <- labelM w@@ -267,7 +273,7 @@  ----------------------------------------------------------------------------- -dfsDom :: Node -> Dom s ()+dfsDom :: CNode -> Dom s () dfsDom i = do   _   <- go i   n0  <- zeroM@@ -292,10 +298,10 @@  initEnv :: Rooted -> ST s (Env s) initEnv (r0,g0) = do-  -- Graph renumbered to indices from 1 to |V|+  -- CGraph renumbered to indices from 1 to |V|   let (g,rnmap) = renum 1 g0       pred      = predG g -- reverse graph-      root      = rnmap IM.! r0 -- renamed root+      root      = rnmap WM.! r0 -- renamed root       n         = IM.size g       ns        = [0..n]       m         = n+1@@ -303,9 +309,9 @@   let bucket = IM.fromList         (zip ns (repeat mempty)) -  rna <- newI m+  rna <- newW m   writes rna (fmap swap-        (IM.toList rnmap))+        (WM.toList rnmap))    doms      <- newI m   sdno      <- newI m@@ -360,33 +366,33 @@  ----------------------------------------------------------------------------- -zeroM :: Dom s Node+zeroM :: Dom s CNode zeroM = gets zeroE-domM :: Node -> Dom s Node+domM :: CNode -> Dom s CNode domM = fetch domE-rootM :: Dom s Node+rootM :: Dom s CNode rootM = gets rootE-succsM :: Node -> Dom s [Node]+succsM :: CNode -> Dom s [CNode] succsM i = gets (IS.toList . (! i) . succE)-predsM :: Node -> Dom s [Node]+predsM :: CNode -> Dom s [CNode] predsM i = gets (IS.toList . (! i) . predE)-bucketM :: Node -> Dom s [Node]+bucketM :: CNode -> Dom s [CNode] bucketM i = gets (IS.toList . (! i) . bucketE)-sizeM :: Node -> Dom s Int+sizeM :: CNode -> Dom s Int sizeM = fetch sizeE-sdnoM :: Node -> Dom s Int+sdnoM :: CNode -> Dom s Int sdnoM = fetch sdnoE--- dfnM :: Node -> Dom s Int+-- dfnM :: CNode -> Dom s Int -- dfnM = fetch dfnE-ndfsM :: Int -> Dom s Node+ndfsM :: Int -> Dom s CNode ndfsM = fetch ndfsE-childM :: Node -> Dom s Node+childM :: CNode -> Dom s CNode childM = fetch childE-ancestorM :: Node -> Dom s Node+ancestorM :: CNode -> Dom s CNode ancestorM = fetch ancestorE-parentM :: Node -> Dom s Node+parentM :: CNode -> Dom s CNode parentM = fetch parentE-labelM :: Node -> Dom s Node+labelM :: CNode -> Dom s CNode labelM = fetch labelE nextM :: Dom s Int nextM = do@@ -421,6 +427,9 @@ 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)@@ -430,18 +439,18 @@ (!) g n = maybe mempty id (IM.lookup n g)  fromAdj :: [(Node, [Node])] -> Graph-fromAdj = IM.fromList . fmap (second IS.fromList)+fromAdj = WM.fromList . fmap (second WS.fromList)  fromEdges :: [Edge] -> Graph-fromEdges = collectI IS.union fst (IS.singleton . snd)+fromEdges = collectW WS.union fst (WS.singleton . snd)  toAdj :: Graph -> [(Node, [Node])]-toAdj = fmap (second IS.toList) . IM.toList+toAdj = fmap (second WS.toList) . WM.toList  toEdges :: Graph -> [Edge] toEdges = concatMap (uncurry (fmap . (,))) . toAdj -predG :: Graph -> Graph+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 ->@@ -450,15 +459,24 @@                         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 IM.lookup g) $ r-        g2 = IM.fromList-            . fmap (second (IS.filter (`IS.member`is)))-            . filter ((`IS.member`is) . fst)-            . IM.toList $ g+                . 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)@@ -475,26 +493,28 @@             in p acc' xs ++ concatMap (go acc') xs         p is = fmap (flip (,) is . rootLabel) -asGraph :: Tree Node -> Rooted-asGraph t@(Node a _) = let g = go t in (a, fromAdj g)+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 ((IS.toList . f) a))+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 (IS.singleton a) a+reachable f a = go (WS.singleton a) a   where go seen a = let s = f a-                        as = IS.toList (s `IS.difference` seen)-                    in foldl' go (s `IS.union` seen) as+                        as = WS.toList (s `WS.difference` seen)+                    in foldl' go (s `WS.union` seen) as -collectI :: (c -> c -> c)-        -> (a -> Int) -> (a -> c) -> [a] -> IntMap c-collectI (<>) f g-  = foldl' (\m a -> IM.insertWith (<>)+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 @@ -503,12 +523,12 @@ -- Gives nodes sequential names starting at n. -- Returns the new graph and a mapping. -- (renamed, old -> new)-renum :: Int -> Graph -> (Graph, NodeMap Node)+renum :: Int -> Graph -> (CGraph, NodeMap CNode) renum from = (\(_,m,g)->(g,m))-  . IM.foldrWithKey+  . WM.foldrWithKey       (\i ss (!n,!env,!new)->           let (j,n2,env2) = go n env i-              (n3,env3,ss2) = IS.fold+              (n3,env3,ss2) = WS.fold                 (\k (!n,!env,!new)->                     case go n env k of                       (l,n2,env2)-> (n2,env2,l `IS.insert` new))@@ -516,20 +536,19 @@               new2 = IM.insertWith IS.union j ss2 new           in (n3,env3,new2)) (from,mempty,mempty)   where go :: Int-           -> NodeMap Node+           -> NodeMap CNode            -> Node-           -> (Node,Int,NodeMap Node)+           -> (CNode,Int,NodeMap CNode)         go !n !env i =-          case IM.lookup i env of+          case WM.lookup i env of             Just j -> (j,n,env)-            Nothing -> (n,n+1,IM.insert i n env)+            Nothing -> (n,n+1,WM.insert i n env)  ----------------------------------------------------------------------------- --- Nothing better than reinvinting the state monad.+-- 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}-instance Functor (S z s) where-  fmap f (S g) = S (\k -> g (k . f))+  deriving (Functor) instance Monad (S z s) where   return = pure   S g >>= f = S (\k -> g (\a -> unS (f a) k))
GHC/CmmToAsm/CPrim.hs view
@@ -87,7 +87,7 @@ atomicRMWLabel :: Width -> AtomicMachOp -> FastString atomicRMWLabel w amop = case amop of   -- lots of boring cases, but we do it this way to get shared FastString-  -- literals (compared to concatening strings and allocating FastStrings at+  -- literals (compared to concatenating strings and allocating FastStrings at   -- runtime)   AMO_Add  -> case w of     W8  -> fsLit "hs_atomic_add8"
GHC/CmmToAsm/Config.hs view
@@ -30,6 +30,9 @@    , 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@@ -44,6 +47,7 @@    , 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    }
GHC/CmmToAsm/Dwarf.hs view
@@ -5,7 +5,8 @@ import GHC.Prelude  import GHC.Cmm.CLabel-import GHC.Cmm.Expr        ( GlobalReg(..) )+import GHC.Cmm.Expr+import GHC.Data.FastString import GHC.Settings.Config ( cProjectName, cProjectVersion ) import GHC.Types.Tickish   ( CmmTickish, GenTickish(..) ) import GHC.Cmm.DebugBlock@@ -13,7 +14,7 @@ import GHC.Utils.Outputable import GHC.Platform import GHC.Types.Unique-import GHC.Types.Unique.Supply+import GHC.Types.Unique.DSM  import GHC.CmmToAsm.Dwarf.Constants import GHC.CmmToAsm.Dwarf.Types@@ -26,50 +27,45 @@ import Data.Ord         ( comparing ) import qualified Data.Map as Map import System.FilePath-import System.Directory ( getCurrentDirectory )  import qualified GHC.Cmm.Dataflow.Label as H-import qualified GHC.Cmm.Dataflow.Collections as H  -- | Generate DWARF/debug information-dwarfGen :: NCGConfig -> ModLocation -> UniqSupply -> [DebugBlock]-            -> IO (SDoc, UniqSupply)-dwarfGen _      _      us []     = return (empty, us)-dwarfGen config modLoc us blocks = do+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-  let procs = debugSplitProcs blocks+      -- Convert debug data structures to DWARF info records+      procs = debugSplitProcs blocks       stripBlocks dbg         | ncgDwarfStripBlockInfo config = dbg { dblBlocks = [] }         | otherwise                     = dbg-  compPath <- getCurrentDirectory-  let lowLabel = dblCLabel $ head procs+      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 = pdoc platform lowLabel-        , dwHighLabel = pdoc platform highLabel-        , dwLineLabel = dwarfLineLabel+        , 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).-  let haveSrcIn blk = isJust (dblSourceTick blk) && isJust (dblPosition blk)+      -- 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-  let abbrevSct = pprAbbrevDecls platform haveSrc+      abbrevSct = pprAbbrevDecls platform 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 [ dwarfInfoLabel <> colon+      -- 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@@ -78,21 +74,23 @@    -- .debug_line section: Generated mainly by the assembler, but we   -- need to label it-  let lineSct = dwarfLineSection platform $$-                dwarfLineLabel <> colon+      lineSct = dwarfLineSection platform $$+                line (dwarfLineLabel <> colon)    -- .debug_frame section: Information about the layout of the GHC stack-  let (framesU, us'') = takeUniqFromSupply us'+      (framesU, us'') = takeUniqueFromDSupply us'       frameSct = dwarfFrameSection platform $$-                 dwarfFrameLabel <> colon $$-                 pprDwarfFrame platform (debugFrame framesU procs)+                 line (dwarfFrameLabel <> colon) $$+                 pprDwarfFrame platform (debugFrame platform framesU procs)    -- .aranges section: Information about the bounds of compilation units-  let aranges' | ncgSplitSections config = map mkDwarfARange procs+      aranges' | ncgSplitSections config = map mkDwarfARange procs                | otherwise               = [DwarfARange lowLabel highLabel]-  let aranges = dwarfARangesSection platform $$ pprDwarfARanges platform aranges' unitU+      aranges = dwarfARangesSection platform $$ pprDwarfARanges platform aranges' unitU -  return (infoSct $$ abbrevSct $$ lineSct $$ frameSct $$ aranges, us'')+  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@@ -106,24 +104,24 @@  -- | Header for a compilation unit, establishing global format -- parameters-compileUnitHeader :: Platform -> Unique -> SDoc+compileUnitHeader :: IsDoc doc => Platform -> Unique -> doc compileUnitHeader platform unitU =   let cuLabel = mkAsmTempLabel unitU  -- sits right before initialLength field-      length = pdoc platform (mkAsmTempEndLabel cuLabel) <> char '-' <> pdoc platform cuLabel+      length = pprAsmLabel platform (mkAsmTempEndLabel cuLabel) <> char '-' <> pprAsmLabel platform cuLabel                <> text "-4"       -- length of initialLength field-  in vcat [ pdoc platform cuLabel <> colon-          , text "\t.long " <> length  -- compilation unit size+  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-          , text "\t.byte " <> ppr (platformWordSizeInBytes platform) -- word size+          , line (text "\t.byte " <> int (platformWordSizeInBytes platform)) -- word size           ]  -- | Compilation unit footer, mainly establishing size of debug sections-compileUnitFooter :: Platform -> Unique -> SDoc+compileUnitFooter :: IsDoc doc => Platform -> Unique -> doc compileUnitFooter platform unitU =   let cuEndLabel = mkAsmTempEndLabel $ mkAsmTempLabel unitU-  in pdoc platform cuEndLabel <> colon+  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@@ -178,7 +176,8 @@ procToDwarf config prc   = DwarfSubprogram { dwChildren = map (blockToDwarf config) (dblBlocks prc)                     , dwName     = case dblSourceTick prc of-                         Just s@SourceNote{} -> sourceName s+                         Just s@SourceNote{} -> case sourceName s of+                            LexicalFastString s -> unpackFS s                          _otherwise -> show (dblLabel prc)                     , dwLabel    = dblCLabel prc                     , dwParent   = fmap mkAsmTempDieLabel@@ -216,15 +215,15 @@  -- | 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+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 Sp 0))]+    initUws = Map.fromList [(Sp, Just (UwReg (GlobalRegUse Sp $ bWord p) 0))]  -- | Generates unwind information for a procedure debug block procToFrame :: UnwindTable -> DebugBlock -> DwarfFrameProc
GHC/CmmToAsm/Dwarf/Constants.hs view
@@ -144,17 +144,29 @@  -- * Dwarf section declarations dwarfInfoSection, dwarfAbbrevSection, dwarfLineSection,-  dwarfFrameSection, dwarfGhcSection, dwarfARangesSection :: Platform -> SDoc+  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 :: Platform -> String -> SDoc+dwarfSection :: IsDoc doc => Platform -> String -> doc dwarfSection platform name =-  case platformOS platform of+  line $ case platformOS platform of     os | osElfTarget os        -> text "\t.section .debug_" <> text name <> text ",\"\","           <> sectionType platform "progbits"@@ -162,13 +174,24 @@        -> 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 :: SDoc+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@@ -217,6 +240,8 @@     | 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.@@ -229,5 +254,7 @@     ArchX86    -> 8  -- eip     ArchX86_64 -> 16 -- rip     ArchPPC_64 ELF_V2 -> 65 -- lr (link register)-    ArchAArch64-> 30+    ArchAArch64 -> 30+    ArchRISCV64 -> 1 -- ra (return address)+    ArchLoongArch64 -> 1 -- ra (return address)     _other     -> error "dwarfReturnRegNo: Unsupported platform!"
GHC/CmmToAsm/Dwarf/Types.hs view
@@ -31,7 +31,7 @@  import GHC.Cmm.DebugBlock import GHC.Cmm.CLabel-import GHC.Cmm.Expr         ( GlobalReg(..) )+import GHC.Cmm.Expr import GHC.Utils.Encoding import GHC.Data.FastString import GHC.Utils.Outputable@@ -59,9 +59,8 @@                      , dwName :: String                      , dwProducer :: String                      , dwCompDir :: String-                     , dwLowLabel :: SDoc-                     , dwHighLabel :: SDoc-                     , dwLineLabel :: SDoc }+                     , dwLowLabel :: CLabel+                     , dwHighLabel :: CLabel }   | DwarfSubprogram { dwChildren :: [DwarfInfo]                     , dwName :: String                     , dwLabel :: CLabel@@ -88,13 +87,13 @@   deriving (Eq, Enum)  -- | Generate assembly for the given abbreviation code-pprAbbrev :: DwarfAbbrev -> SDoc+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 :: Platform -> Bool -> SDoc+pprAbbrevDecls :: IsDoc doc => Platform -> Bool -> doc pprAbbrevDecls platform haveDebugLine =   let mkAbbrev abbr tag chld flds =         let fld (tag, form) = pprLEBWord tag $$ pprLEBWord form@@ -111,7 +110,7 @@            , (dW_AT_frame_base, dW_FORM_block1)            ]   in dwarfAbbrevSection platform $$-     dwarfAbbrevLabel <> colon $$+     line (dwarfAbbrevLabel <> colon) $$      mkAbbrev DwAbbrCompileUnit dW_TAG_compile_unit dW_CHILDREN_yes        ([(dW_AT_name,     dW_FORM_string)        , (dW_AT_producer, dW_FORM_string)@@ -144,54 +143,58 @@        , (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 :: Platform -> Bool -> DwarfInfo -> SDoc+pprDwarfInfo :: IsDoc doc => Platform -> Bool -> DwarfInfo -> doc pprDwarfInfo platform haveSrc d   = case d of-      DwarfCompileUnit {}  -> hasChildren-      DwarfSubprogram {}   -> hasChildren-      DwarfBlock {}        -> hasChildren-      DwarfSrcNote {}      -> noChildren+      DwarfCompileUnit {dwChildren = kids} -> hasChildren kids+      DwarfSubprogram  {dwChildren = kids} -> hasChildren kids+      DwarfBlock       {dwChildren = kids} -> hasChildren kids+      DwarfSrcNote {}                      -> noChildren   where-    hasChildren =+    hasChildren kids =         pprDwarfInfoOpen platform haveSrc d $$-        vcat (map (pprDwarfInfo platform haveSrc) (dwChildren 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 :: Platform -> CLabel -> SDoc+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 CStyle label -- pretty-print as C label (foreign labels may be printed differently in Asm)+   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 :: Platform -> Bool -> DwarfInfo -> SDoc+pprDwarfInfoOpen :: IsDoc doc => Platform -> Bool -> DwarfInfo -> doc pprDwarfInfoOpen platform haveSrc (DwarfCompileUnit _ name producer compDir lowLabel-                                           highLabel lineLbl) =+                                           highLabel) =   pprAbbrev DwAbbrCompileUnit   $$ pprString name   $$ pprString producer   $$ pprData4 dW_LANG_Haskell   $$ pprString compDir      -- Offset due to Note [Info Offset]-  $$ pprWord platform (lowLabel <> text "-1")-  $$ pprWord platform highLabel+  $$ pprWord platform (pprAsmLabel platform lowLabel <> text "-1")+  $$ pprWord platform (pprAsmLabel platform highLabel)   $$ if haveSrc-     then sectionOffset platform lineLbl dwarfLineLabel+     then sectionOffset platform dwarfLineLabel dwarfLineLabel      else empty pprDwarfInfoOpen platform _ (DwarfSubprogram _ name label parent) =-  pdoc platform (mkAsmTempDieLabel label) <> colon+  line (pprAsmLabel platform (mkAsmTempDieLabel label) <> colon)   $$ pprAbbrev abbrev   $$ pprString name   $$ pprLabelString platform label   $$ pprFlag (externallyVisibleCLabel label)      -- Offset due to Note [Info Offset]-  $$ pprWord platform (pdoc platform label <> text "-1")-  $$ pprWord platform (pdoc platform $ mkAsmTempProcEndLabel label)+  $$ pprWord platform (pprAsmLabel platform label <> text "-1")+  $$ pprWord platform (pprAsmLabel platform $ mkAsmTempProcEndLabel label)   $$ pprByte 1   $$ pprByte dW_OP_call_frame_cfa   $$ parentValue@@ -199,17 +202,17 @@     abbrev = case parent of Nothing -> DwAbbrSubprogram                             Just _  -> DwAbbrSubprogramWithParent     parentValue = maybe empty pprParentDie parent-    pprParentDie sym = sectionOffset platform (pdoc platform sym) dwarfInfoLabel+    pprParentDie sym = sectionOffset platform (pprAsmLabel platform sym) dwarfInfoLabel pprDwarfInfoOpen platform _ (DwarfBlock _ label Nothing) =-  pdoc platform (mkAsmTempDieLabel label) <> colon+  line (pprAsmLabel platform (mkAsmTempDieLabel label) <> colon)   $$ pprAbbrev DwAbbrBlockWithoutCode   $$ pprLabelString platform label pprDwarfInfoOpen platform _ (DwarfBlock _ label (Just marker)) =-  pdoc platform (mkAsmTempDieLabel label) <> colon+  line (pprAsmLabel platform (mkAsmTempDieLabel label) <> colon)   $$ pprAbbrev DwAbbrBlock   $$ pprLabelString platform label-  $$ pprWord platform (pdoc platform marker)-  $$ pprWord platform (pdoc platform $ mkAsmTempEndLabel marker)+  $$ pprWord platform (pprAsmLabel platform marker)+  $$ pprWord platform (pprAsmLabel platform $ mkAsmTempEndLabel marker) pprDwarfInfoOpen _ _ (DwarfSrcNote ss) =   pprAbbrev DwAbbrGhcSrcNote   $$ pprString' (ftext $ srcSpanFile ss)@@ -219,7 +222,7 @@   $$ pprHalf (fromIntegral $ srcSpanEndCol ss)  -- | Close a DWARF info record with children-pprDwarfInfoClose :: SDoc+pprDwarfInfoClose :: IsDoc doc => doc pprDwarfInfoClose = pprAbbrev DwAbbrNull  -- | A DWARF address range. This is used by the debugger to quickly locate@@ -233,7 +236,7 @@  -- | Print assembler directives corresponding to a DWARF @.debug_aranges@ -- address table entry.-pprDwarfARanges :: Platform -> [DwarfARange] -> Unique -> SDoc+pprDwarfARanges :: IsDoc doc => Platform -> [DwarfARange] -> Unique -> doc pprDwarfARanges platform arngs unitU =   let wordSize = platformWordSizeInBytes platform       paddingSize = 4 :: Int@@ -243,9 +246,9 @@       pad n = vcat $ replicate n $ pprByte 0       -- Fix for #17428       initialLength = 8 + paddingSize + (1 + length arngs) * 2 * wordSize-  in pprDwWord (ppr initialLength)+  in pprDwWord (int initialLength)      $$ pprHalf 2-     $$ sectionOffset platform (pdoc platform $ mkAsmTempLabel $ unitU) dwarfInfoLabel+     $$ sectionOffset platform (pprAsmLabel platform $ mkAsmTempLabel $ unitU) dwarfInfoLabel      $$ pprByte (fromIntegral wordSize)      $$ pprByte 0      $$ pad paddingSize@@ -254,15 +257,17 @@      -- 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 :: Platform -> DwarfARange -> SDoc+pprDwarfARange :: IsDoc doc => Platform -> DwarfARange -> doc pprDwarfARange platform arng =     -- Offset due to Note [Info Offset].-    pprWord platform (pdoc platform (dwArngStartLabel arng) <> text "-1")+    pprWord platform (pprAsmLabel platform (dwArngStartLabel arng) <> text "-1")     $$ pprWord platform length   where-    length = pdoc platform (dwArngEndLabel arng)-             <> char '-' <> pdoc platform (dwArngStartLabel arng)+    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.@@ -293,21 +298,21 @@       -- in the block     } -instance OutputableP env CLabel => OutputableP env DwarfFrameBlock where+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 :: Platform -> DwarfFrame -> SDoc+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      = pdoc platform cieEndLabel <> char '-' <> pdoc platform cieStartLabel+        length      = pprAsmLabel platform cieEndLabel <> char '-' <> pprAsmLabel platform cieStartLabel         spReg       = dwarfGlobalRegNo platform Sp         retReg      = dwarfReturnRegNo platform         wordSize    = platformWordSizeInBytes platform-        pprInit :: (GlobalReg, Maybe UnwindExpr) -> SDoc+        pprInit :: (GlobalReg, Maybe UnwindExpr) -> doc         pprInit (g, uw) = pprSetUnwind platform g (Nothing, uw)          -- Preserve C stack pointer: This necessary to override that default@@ -316,9 +321,9 @@           ArchX86    -> pprByte dW_CFA_same_value $$ pprLEBWord 4           ArchX86_64 -> pprByte dW_CFA_same_value $$ pprLEBWord 7           _          -> empty-    in vcat [ pdoc platform cieLabel <> colon+    in vcat [ line (pprAsmLabel platform cieLabel <> colon)             , pprData4' length -- Length of CIE-            , pdoc platform cieStartLabel <> colon+            , line (pprAsmLabel platform cieStartLabel <> colon)             , pprData4' (text "-1")                                -- Common Information Entry marker (-1 = 0xf..f)             , pprByte 3        -- CIE version (we require DWARF 3)@@ -346,41 +351,43 @@             , pprLEBWord 0             ] $$        wordAlign platform $$-       pdoc platform cieEndLabel <> colon $$+       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 :: Platform -> CLabel -> UnwindTable -> DwarfFrameProc -> SDoc+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 $ text "# Unwinding for" <+> pdoc platform procLbl <> colon-            , pprData4' (pdoc platform fdeEndLabel <> char '-' <> pdoc platform fdeLabel)-            , pdoc platform fdeLabel <> colon-            , pprData4' (pdoc platform frameLbl <> char '-' <> dwarfFrameLabel)    -- Reference to CIE-            , pprWord platform (pdoc platform procLbl <> ifInfo "-1") -- Code pointer-            , pprWord platform (pdoc platform procEnd <> char '-' <>-                                 pdoc platform procLbl <> ifInfo "+1") -- Block byte length+    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 $$-       pdoc platform fdeEndLabel <> colon+       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 :: Platform -> DwarfFrameBlock -> S.State UnwindTable SDoc+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 SDoc+    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@@ -402,7 +409,7 @@              then (empty, oldUws)              else let -- see Note [Info Offset]                       needsOffset = firstDecl && hasInfo-                      lblDoc = pdoc platform lbl <>+                      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)@@ -450,19 +457,19 @@ -- | 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+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-             -> SDoc+             -> 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 s' o'))+pprSetUnwind plat Sp (_, Just (UwReg (GlobalRegUse s' _) o'))   = if o' >= 0     then pprByte dW_CFA_def_cfa $$          pprLEBRegNo plat s' $$@@ -472,7 +479,7 @@          pprLEBInt o' pprSetUnwind plat Sp (_, Just uw)   = pprByte dW_CFA_def_cfa_expression $$ pprUnwindExpr plat False uw-pprSetUnwind plat g  (_, Just (UwDeref (UwReg Sp o)))+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))@@ -484,7 +491,7 @@   = pprByte dW_CFA_expression $$     pprLEBRegNo plat g $$     pprUnwindExpr plat True uw-pprSetUnwind plat g  (_, Just (UwReg g' 0))+pprSetUnwind plat g  (_, Just (UwReg (GlobalRegUse g' _) 0))   | g == g'   = pprByte dW_CFA_same_value $$     pprLEBRegNo plat g@@ -495,114 +502,132 @@  -- | Print the register number of the given 'GlobalReg' as an unsigned LEB128 -- encoded number.-pprLEBRegNo :: Platform -> GlobalReg -> SDoc+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 :: Platform -> Bool -> UnwindExpr -> SDoc+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 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 platform g) $$-                               pprLEBInt i+        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 (pdoc platform l)+        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 text "\t.uleb128 2f-1f" $$ -- DW_FORM_block length+    in line (text "\t.uleb128 2f-1f") $$ -- DW_FORM_block length        -- computed as the difference of the following local labels 2: and 1:-       text "1:" $$+       line (text "1:") $$        pprE expr $$-       text "2:"+       line (text "2:")  -- | Generate code for re-setting the unwind information for a -- register to @undefined@-pprUndefUnwind :: Platform -> GlobalReg -> SDoc+pprUndefUnwind :: IsDoc doc => Platform -> GlobalReg -> doc pprUndefUnwind plat g  = pprByte dW_CFA_undefined $$                          pprLEBRegNo plat g   -- | Align assembly at (machine) word boundary-wordAlign :: Platform -> SDoc+wordAlign :: IsDoc doc => Platform -> doc wordAlign plat =-  text "\t.align " <> case platformOS plat of+  line $ text "\t.align " <> case platformOS plat of     OSDarwin -> case platformWordSize plat of       PW8 -> char '3'       PW4 -> char '2'-    _other   -> ppr (platformWordSizeInBytes plat)+    _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 :: Word8 -> SDoc-pprByte x = text "\t.byte " <> ppr (fromIntegral x :: Word)+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 :: Word16 -> SDoc-pprHalf x = text "\t.short" <+> ppr (fromIntegral x :: Word)+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 :: Bool -> SDoc+pprFlag :: IsDoc doc => Bool -> doc 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+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 :: Word -> SDoc-pprData4 = pprData4' . ppr+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 :: SDoc -> SDoc+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 :: Platform -> SDoc -> SDoc+pprWord :: IsDoc doc => Platform -> Line doc -> doc pprWord plat s =-  case platformWordSize plat of+  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 :: Word -> SDoc+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 :: Int -> SDoc+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' :: SDoc -> SDoc-pprString' str = text "\t.asciz \"" <> str <> char '"'+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 :: String -> SDoc+pprString :: IsDoc doc => String -> doc pprString str   = pprString' $ hcat $ map escapeChar $     if str `lengthIs` utf8EncodedLength str     then str-    else map (chr . fromIntegral) $ BS.unpack $ utf8EncodeString str+    else map (chr . fromIntegral) $ BS.unpack $ utf8EncodeByteString str  -- | Escape a single non-unicode character-escapeChar :: Char -> SDoc+escapeChar :: IsLine doc => Char -> doc escapeChar '\\' = text "\\\\" escapeChar '\"' = text "\\\"" escapeChar '\n' = text "\\n"@@ -621,9 +646,11 @@ -- 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 :: Platform -> SDoc -> SDoc -> SDoc+sectionOffset :: IsDoc doc => Platform -> Line doc -> Line doc -> doc sectionOffset plat target section =   case platformOS plat of     OSDarwin  -> pprDwWord (target <> char '-' <> section)-    OSMinGW32 -> text "\t.secrel32 " <> target+    OSMinGW32 -> line (text "\t.secrel32 " <> target)     _other    -> pprDwWord target+{-# SPECIALIZE sectionOffset :: Platform -> SDoc -> SDoc -> SDoc #-}+{-# SPECIALIZE sectionOffset :: Platform -> HLine -> HLine -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
GHC/CmmToAsm/Format.hs view
@@ -1,3 +1,7 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ViewPatterns #-}+ -- | Formats on this architecture --      A Format is a combination of width and class --@@ -9,14 +13,28 @@ --              properly. eg SPARC doesn't care about FF80. -- module GHC.CmmToAsm.Format (-    Format(..),+    Format(.., IntegerFormat),+    ScalarFormat(..),     intFormat,     floatFormat,     isIntFormat,+    isIntScalarFormat,+    intScalarFormat,     isFloatFormat,+    vecFormat,+    isVecFormat,     cmmTypeFormat,     formatToWidth,-    formatInBytes+    scalarWidth,+    formatInBytes,+    isFloatScalarFormat,+    isFloatOrFloatVecFormat,+    floatScalarFormat,+    scalarFormatFormat,+    VirtualRegWithFormat(..),+    RegWithFormat(..),+    takeVirtualRegs,+    takeRealRegs, )  where@@ -24,9 +42,33 @@ 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.@@ -49,9 +91,71 @@         | II64         | FF32         | FF64-        deriving (Show, Eq)+        | 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@@ -64,6 +168,15 @@             "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@@ -71,13 +184,8 @@  = case width of         W32     -> FF32         W64     -> FF64-         other   -> pprPanic "Format.floatFormat" (ppr other) --- | Check if a format represent an integer value.-isIntFormat :: Format -> Bool-isIntFormat = not . isFloatFormat- -- | Check if a format represents a floating point value. isFloatFormat :: Format -> Bool isFloatFormat format@@ -86,11 +194,33 @@         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)  @@ -98,13 +228,65 @@ formatToWidth :: Format -> Width formatToWidth format  = case format of-        II8             -> W8-        II16            -> W16-        II32            -> W32-        II64            -> W64-        FF32            -> W32-        FF64            -> W64+        II8  -> W8+        II16 -> W16+        II32 -> W32+        II64 -> W64+        FF32 -> W32+        FF64 -> W64+        VecFormat l s ->+          widthFromBytes (l * widthInBytes (scalarWidth s)) +scalarWidth :: ScalarFormat -> Width+scalarWidth = \case+  FmtInt8   -> W8+  FmtInt16  -> W16+  FmtInt32  -> W32+  FmtInt64  -> W64+  FmtFloat  -> W32+  FmtDouble -> W64  formatInBytes :: Format -> Int formatInBytes = widthInBytes . formatToWidth++--------------------------------------------------------------------------------++-- | A typed virtual register: a virtual register, together with the specific+-- format we are using it at.+data VirtualRegWithFormat+    = VirtualRegWithFormat+    { virtualRegWithFormat_reg :: {-# UNPACK #-} !VirtualReg+    , virtualRegWithFormat_format :: !Format+    }++-- | A typed register: a register, together with the specific format we+-- are using it at.+data RegWithFormat+    = RegWithFormat+    { regWithFormat_reg :: {-# UNPACK #-} !Reg+    , regWithFormat_format :: !Format+    }++instance Show RegWithFormat where+  show (RegWithFormat reg fmt) = show reg ++ "::" ++ show fmt++instance Uniquable RegWithFormat where+  getUnique = getUnique . regWithFormat_reg++instance Outputable VirtualRegWithFormat where+  ppr (VirtualRegWithFormat reg fmt) = ppr reg <+> dcolon <+> ppr fmt++instance Outputable RegWithFormat where+  ppr (RegWithFormat reg fmt) = ppr reg <+> dcolon <+> ppr fmt++-- | Take all the virtual registers from this set.+takeVirtualRegs :: UniqSet RegWithFormat -> UniqSet VirtualReg+takeVirtualRegs = mapMaybeUniqSet_sameUnique $+  \ case { RegWithFormat { regWithFormat_reg = RegVirtual vr } -> Just vr; _ -> Nothing }+  -- See Note [Unique Determinism and code generation]++-- | Take all the real registers from this set.+takeRealRegs :: UniqSet RegWithFormat -> UniqSet RealReg+takeRealRegs = mapMaybeUniqSet_sameUnique $+  \ case { RegWithFormat { regWithFormat_reg = RegReal rr } -> Just rr; _ -> Nothing }+  -- See Note [Unique Determinism and code generation]
GHC/CmmToAsm/Instr.hs view
@@ -15,7 +15,11 @@ 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. --@@ -28,8 +32,8 @@ -- data RegUsage         = RU    {-                reads :: [Reg],-                writes :: [Reg]+                reads :: [RegWithFormat],+                writes :: [RegWithFormat]                 }         deriving Show @@ -58,7 +62,9 @@         -- | Apply a given mapping to all the register references in this         --      instruction.         patchRegsOfInstr-                :: instr+                :: HasDebugCallStack+                => Platform+                -> instr                 -> (Reg -> Reg)                 -> instr @@ -70,12 +76,18 @@                 :: instr -> Bool  -        -- | Give the possible destinations of this jump instruction.+        -- | 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.@@ -87,20 +99,22 @@          -- | An instruction to spill a register into a spill slot.         mkSpillInstr-                :: NCGConfig-                -> Reg          -- ^ the reg to spill+                :: HasDebugCallStack+                => NCGConfig+                -> RegWithFormat    -- ^ the reg to spill                 -> Int          -- ^ the current stack delta-                -> Int          -- ^ spill slot to use-                -> [instr]        -- ^ instructions+                -> Int          -- ^ spill slots to use+                -> [instr]      -- ^ instructions           -- | An instruction to reload a register from a spill slot.         mkLoadInstr-                :: NCGConfig-                -> Reg          -- ^ the reg to reload.+                :: HasDebugCallStack+                => NCGConfig+                -> RegWithFormat    -- ^ the reg to reload.                 -> Int          -- ^ the current stack delta                 -> Int          -- ^ the spill slot to use-                -> [instr]        -- ^ instructions+                -> [instr]      -- ^ instructions          -- | See if this instruction is telling us the current C stack delta         takeDeltaInstr@@ -123,15 +137,18 @@         -- | Copy the value in a register to another one.         --      Must work for all register classes.         mkRegRegMoveInstr-                :: Platform-                -> Reg          -- ^ source register-                -> Reg          -- ^ destination register+                :: 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-                :: instr+                :: Platform+                -> instr                 -> Maybe (Reg, Reg)          -- | Make an unconditional jump instruction.@@ -160,4 +177,4 @@         pprInstr :: Platform -> instr -> SDoc          -- Create a comment instruction-        mkComment :: SDoc -> [instr]+        mkComment :: FastString -> [instr]
+ GHC/CmmToAsm/LA64.hs view
@@ -0,0 +1,60 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++-- | Native code generator for LoongArch64 architectures+module GHC.CmmToAsm.LA64 ( ncgLA64 ) where++import GHC.Prelude++import GHC.CmmToAsm.Config+import GHC.CmmToAsm.Instr+import GHC.CmmToAsm.Monad+import GHC.CmmToAsm.Types+import GHC.Utils.Outputable (ftext)++import qualified GHC.CmmToAsm.LA64.CodeGen  as LA64+import qualified GHC.CmmToAsm.LA64.Instr    as LA64+import qualified GHC.CmmToAsm.LA64.Ppr      as LA64+import qualified GHC.CmmToAsm.LA64.RegInfo  as LA64+import qualified GHC.CmmToAsm.LA64.Regs     as LA64++ncgLA64 :: NCGConfig -> NcgImpl RawCmmStatics LA64.Instr LA64.JumpDest+ncgLA64 config =+  NcgImpl+    { ncgConfig                 = config,+      cmmTopCodeGen             = LA64.cmmTopCodeGen,+      generateJumpTableForInstr = LA64.generateJumpTableForInstr config,+      getJumpDestBlockId        = LA64.getJumpDestBlockId,+      canShortcut               = LA64.canShortcut,+      shortcutStatics           = LA64.shortcutStatics,+      shortcutJump              = LA64.shortcutJump,+      pprNatCmmDeclS            = LA64.pprNatCmmDecl config,+      pprNatCmmDeclH            = LA64.pprNatCmmDecl config,+      maxSpillSlots             = LA64.maxSpillSlots config,+      allocatableRegs           = LA64.allocatableRegs platform,+      ncgAllocMoreStack         = LA64.allocMoreStack platform,+      ncgMakeFarBranches        = LA64.makeFarBranches,+      extractUnwindPoints       = const [],+      invertCondBranches        = \_ _ -> id+    }+  where+    platform = ncgPlatform config++-- | `Instruction` instance for LA64+instance Instruction LA64.Instr where+  regUsageOfInstr       = LA64.regUsageOfInstr+  patchRegsOfInstr _    = LA64.patchRegsOfInstr+  isJumpishInstr        = LA64.isJumpishInstr+  canFallthroughTo      = LA64.canFallthroughTo+  jumpDestsOfInstr      = LA64.jumpDestsOfInstr+  patchJumpInstr        = LA64.patchJumpInstr+  mkSpillInstr          = LA64.mkSpillInstr+  mkLoadInstr           = LA64.mkLoadInstr+  takeDeltaInstr        = LA64.takeDeltaInstr+  isMetaInstr           = LA64.isMetaInstr+  mkRegRegMoveInstr _ _ = LA64.mkRegRegMoveInstr+  takeRegRegMoveInstr _ = LA64.takeRegRegMoveInstr+  mkJumpInstr           = LA64.mkJumpInstr+  mkStackAllocInstr     = LA64.mkStackAllocInstr+  mkStackDeallocInstr   = LA64.mkStackDeallocInstr+  mkComment             = pure . LA64.COMMENT . ftext+  pprInstr              = LA64.pprInstr
+ GHC/CmmToAsm/LA64/CodeGen.hs view
@@ -0,0 +1,2236 @@+{-# language GADTs #-}+{-# language LambdaCase #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE BinaryLiterals #-}+{-# LANGUAGE OverloadedStrings #-}+module GHC.CmmToAsm.LA64.CodeGen (+      cmmTopCodeGen+    , generateJumpTableForInstr+    , makeFarBranches+)++where++import Data.Maybe+import Data.Word+import GHC.Cmm+import GHC.Cmm.BlockId+import GHC.Cmm.CLabel+import GHC.Cmm.Dataflow.Block+import GHC.Cmm.Dataflow.Graph+import GHC.Cmm.DebugBlock+import GHC.Cmm.Switch+import GHC.Cmm.Utils+import GHC.CmmToAsm.CPrim+import GHC.CmmToAsm.Config+import GHC.CmmToAsm.Format+import GHC.CmmToAsm.Monad+  ( NatM,+    getConfig,+    getDebugBlock,+    getFileId,+    getNewLabelNat,+    getNewRegNat,+    getPicBaseMaybeNat,+    getPlatform+  )+import GHC.CmmToAsm.PIC+import GHC.CmmToAsm.LA64.Cond+import GHC.CmmToAsm.LA64.Instr+import GHC.CmmToAsm.LA64.Regs+import GHC.CmmToAsm.Types+import GHC.Data.FastString+import GHC.Data.OrdList+import GHC.Float+import GHC.Platform+import GHC.Platform.Reg+import GHC.Platform.Regs+import GHC.Prelude hiding (EQ)+import GHC.Types.Basic+import GHC.Types.ForeignCall+import GHC.Types.SrcLoc (srcSpanFile, srcSpanStartCol, srcSpanStartLine)+import GHC.Types.Tickish (GenTickish (..))+import GHC.Utils.Constants (debugIsOn)+import GHC.Utils.Misc+import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Utils.Monad+import Control.Monad+import GHC.Cmm.Dataflow.Label+import GHC.Types.Unique.DSM++-- [General layout of an NCG]+cmmTopCodeGen ::+  RawCmmDecl ->+  NatM [NatCmmDecl RawCmmStatics Instr]+-- Thus we'll have to deal with either CmmProc ...+cmmTopCodeGen _cmm@(CmmProc info lab live graph) = do+  picBaseMb <- getPicBaseMaybeNat+  when (isJust picBaseMb) $ panic "LA64.cmmTopCodeGen: Unexpected PIC base register"++  let blocks = toBlockListEntryFirst graph+  (nat_blocks, statics) <- mapAndUnzipM basicBlockCodeGen blocks++  let proc = CmmProc info lab live (ListGraph $ concat nat_blocks)+      tops = proc : concat statics++  pure tops++-- ... or CmmData.+cmmTopCodeGen (CmmData sec dat) = pure [CmmData sec dat] -- no translation, we just use CmmStatic++basicBlockCodeGen ::+  Block CmmNode C C ->+  NatM+    ( [NatBasicBlock Instr],+      [NatCmmDecl RawCmmStatics Instr]+    )+basicBlockCodeGen block = do+  config <- getConfig+  let (_, nodes, tail) = blockSplit block+      id = entryLabel block+      stmts = blockToList nodes++      header_comment_instr+        | debugIsOn =+            unitOL+              $ MULTILINE_COMMENT+                ( text "-- --------------------------- basicBlockCodeGen --------------------------- --\n"+                    $+$ withPprStyle defaultDumpStyle (pdoc (ncgPlatform config) block)+                )+        | otherwise = nilOL++  -- Generate location directive `.loc` (DWARF debug location info)+  loc_instrs <- genLocInstrs++  -- Generate other instructions+  mid_instrs <- stmtsToInstrs stmts+  (!tail_instrs) <- stmtToInstrs tail++  let instrs = header_comment_instr `appOL` loc_instrs `appOL` mid_instrs `appOL` tail_instrs++      -- TODO: Then x86 backend runs @verifyBasicBlock@ here. How important it is to+      -- have a valid CFG is an open question: This and the AArch64 and PPC NCGs+      -- work fine without it.++      -- Code generation may introduce new basic block boundaries, which are+      -- indicated by the NEWBLOCK instruction. We must split up the instruction+      -- stream into basic blocks again. Also, we extract LDATAs here too.+      (top, other_blocks, statics) = foldrOL mkBlocks ([], [], []) instrs++  return (BasicBlock id top : other_blocks, statics)+  where+    genLocInstrs :: NatM (OrdList Instr)+    genLocInstrs = do+      dbg <- getDebugBlock (entryLabel block)+      case dblSourceTick =<< dbg of+        Just (SourceNote span name) ->+          do+            fileId <- getFileId (srcSpanFile span)+            let line = srcSpanStartLine span; col = srcSpanStartCol span+            pure $ unitOL $ LOCATION fileId line col name+        _ -> pure nilOL++mkBlocks ::+  Instr ->+  ([Instr], [GenBasicBlock Instr], [GenCmmDecl RawCmmStatics h g]) ->+  ([Instr], [GenBasicBlock Instr], [GenCmmDecl RawCmmStatics h g])+mkBlocks (NEWBLOCK id) (instrs, blocks, statics) =+  ([], BasicBlock id instrs : blocks, statics)+mkBlocks (LDATA sec dat) (instrs, blocks, statics) =+  (instrs, blocks, CmmData sec dat : statics)+mkBlocks instr (instrs, blocks, statics) =+  (instr : instrs, blocks, statics)++-- -----------------------------------------------------------------------------+-- | Utilities++-- | Annotate an `Instr` with a `SDoc` comment+ann :: SDoc -> Instr -> Instr+ann doc instr {- debugIsOn -} = ANN doc instr+{-# INLINE ann #-}++-- Using pprExpr will hide the AST, @ANN@ will end up in the assembly with+-- -dppr-debug.  The idea is that we can trivially see how a cmm expression+-- ended up producing the assembly we see.  By having the verbatim AST printed+-- we can simply check the patterns that were matched to arrive at the assembly+-- we generated.+--+-- pprExpr will hide a lot of noise of the underlying data structure and print+-- the expression into something that can be easily read by a human. However+-- going back to the exact CmmExpr representation can be laborious and adds+-- indirections to find the matches that lead to the assembly.+--+-- An improvement oculd be to have+--+--    (pprExpr genericPlatform e) <> parens (text. show e)+--+-- to have the best of both worlds.+--+-- Note: debugIsOn is too restrictive, it only works for debug compilers.+-- However, we do not only want to inspect this for debug compilers. Ideally+-- we'd have a check for -dppr-debug here already, such that we don't even+-- generate the ANN expressions. However, as they are lazy, they shouldn't be+-- forced until we actually force them, and without -dppr-debug they should+-- never end up being forced.+annExpr :: CmmExpr -> Instr -> Instr+annExpr e {- debugIsOn -} = ANN (text . show $ e)+-- annExpr e instr {- debugIsOn -} = ANN (pprExpr genericPlatform e) instr+-- annExpr _ instr = instr+{-# INLINE annExpr #-}++-- -----------------------------------------------------------------------------+-- Generating a table-branch+-- The index into the jump table is calulated by evaluating @expr@. The+-- corresponding table entry contains the address to jump to.+genSwitch :: NCGConfig -> CmmExpr -> SwitchTargets -> NatM InstrBlock+genSwitch config expr targets = do+  (reg, fmt1, e_code) <- getSomeReg indexExpr+  targetReg <- getNewRegNat II64+  lbl <- getNewLabelNat+  dynRef <- cmmMakeDynamicReference config DataReference lbl+  (tableReg, fmt2, t_code) <- getSomeReg $ dynRef+  let code =+        toOL [ COMMENT (text "indexExpr" <+> (text . show) indexExpr)+             , COMMENT (text "dynRef" <+> (text . show) dynRef)+             ]+          `appOL` e_code+          `appOL` t_code+          `appOL` toOL+            [+              COMMENT (ftext "Jump table for switch"),+              -- index to offset into the table (relative to tableReg)+              annExpr expr (SLL (OpReg W64 reg) (OpReg (formatToWidth fmt1) reg) (OpImm (ImmInt 3))),+              -- calculate table entry address+              ADD (OpReg W64 targetReg) (OpReg W64 reg) (OpReg (formatToWidth fmt2) tableReg),+              -- load table entry (relative offset from tableReg (first entry) to target label)+              LDU II64 (OpReg W64 targetReg) (OpAddr (AddrRegImm targetReg (ImmInt 0))),+              -- calculate absolute address of the target label+              ADD (OpReg W64 targetReg) (OpReg W64 targetReg) (OpReg W64 tableReg),+              -- prepare jump to target label+              J_TBL bids (Just lbl) targetReg+            ]+  return code+  where+    platform = ncgPlatform config+    expr_w = cmmExprWidth platform expr+    indexExpr0 = cmmOffset platform expr offset+    -- Widen to a native-width register(addressing modes)+    indexExpr = CmmMachOp+        (MO_UU_Conv expr_w (platformWordWidth platform))+        [indexExpr0]+    (offset, bids) = switchTargetsToTable targets+++-- Generate jump table data (if required)+--+-- Relies on PIC relocations. The idea is to emit one table entry per case. The+-- entry is the label of the block to jump to. This will be relocated to be the+-- address of the jump target.+generateJumpTableForInstr ::+  NCGConfig ->+  Instr ->+  Maybe (NatCmmDecl RawCmmStatics Instr)+generateJumpTableForInstr config (J_TBL ids (Just lbl) _) =+  let jumpTable =+        map jumpTableEntryRel ids+        where+          jumpTableEntryRel Nothing =+            CmmStaticLit (CmmInt 0 (ncgWordWidth config))+          jumpTableEntryRel (Just blockid) =+            CmmStaticLit+              ( CmmLabelDiffOff+                  blockLabel+                  lbl+                  0+                  (ncgWordWidth config)+              )+            where+              blockLabel = blockLbl blockid+   in Just (CmmData (Section ReadOnlyData lbl) (CmmStaticsRaw lbl jumpTable))+generateJumpTableForInstr _ _ = Nothing++-- -----------------------------------------------------------------------------+-- Top-level of the instruction selector+stmtsToInstrs ::+  -- | Cmm Statements+  [CmmNode O O] ->+  -- | Resulting instruction+  NatM InstrBlock+stmtsToInstrs stmts = concatOL <$> mapM stmtToInstrs stmts++stmtToInstrs ::+  CmmNode e x ->+  -- | Resulting instructions+  NatM InstrBlock++stmtToInstrs stmt = do+  config <- getConfig+  platform <- getPlatform+  case stmt of+    CmmUnsafeForeignCall target result_regs args+      -> genCCall target result_regs args++    CmmComment s   -> return (unitOL (COMMENT (ftext s)))+    CmmTick {}     -> return nilOL++    CmmAssign reg src+      | isFloatType ty         -> assignReg_FltCode format reg src+      | otherwise              -> assignReg_IntCode format reg src+        where ty = cmmRegType reg+              format = cmmTypeFormat ty++    CmmStore addr src _alignment+      | isFloatType ty         -> assignMem_FltCode format addr src+      | otherwise              -> assignMem_IntCode format addr src+        where ty = cmmExprType platform src+              format = cmmTypeFormat ty++    CmmBranch id          -> genBranch id++    --We try to arrange blocks such that the likely branch is the fallthrough+    --in GHC.Cmm.ContFlowOpt. So we can assume the condition is likely false here.+    CmmCondBranch arg true false _prediction ->+        genCondBranch true false arg++    CmmSwitch arg ids -> genSwitch config arg ids++    CmmCall { cml_target = arg } -> genJump arg++    CmmUnwind _regs -> pure nilOL++    _ ->  pprPanic "stmtToInstrs: statement should have been cps'd away" (pdoc platform stmt)++-- | 'InstrBlock's are the insn sequences generated by the insn selectors.+--  They are really trees of insns to facilitate fast appending, where a+--  left-to-right traversal yields the insns in the correct order.+type InstrBlock =+  OrdList Instr++-- | Register's passed up the tree.+--  If the stix code forces the register to live in a pre-decided machine+--  register, it comes out as @Fixed@; otherwise, it comes out as @Any@, and the+--  parent can decide which register to put it in.+data Register+  = Fixed Format Reg InstrBlock+  | Any Format (Reg -> InstrBlock)++-- | Sometimes we need to change the Format of a register. Primarily during+--  conversion.+swizzleRegisterRep :: Format -> Register -> Register+swizzleRegisterRep format' (Fixed _ reg code) = Fixed format' reg code+swizzleRegisterRep format' (Any _ codefn) = Any format' codefn++-- | Grab a `Reg` for a `CmmReg`+getRegisterReg :: Platform -> CmmReg -> Reg++getRegisterReg _ (CmmLocal (LocalReg u pk))+  = RegVirtual $ mkVirtualReg u (cmmTypeFormat pk)++getRegisterReg platform (CmmGlobal mid)+  = case globalRegMaybe platform (globalRegUse_reg mid) of+        Just reg -> RegReal reg+        Nothing  -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal mid)++-- General things for putting together code sequences++-- | Compute an expression into any register+getSomeReg :: CmmExpr -> NatM (Reg, Format, InstrBlock)+getSomeReg expr = do+  r <- getRegister expr+  case r of+    Any rep code -> do+        tmp <- getNewRegNat rep+        return (tmp, rep, code tmp)+    Fixed rep reg code ->+        return (reg, rep, code)++-- | Compute an expression into any floating-point register++-- | Compute an expression into floating point register+--  If the initial expression is not a floating-point expression, finally move+--  the result into a floating-point register.+getFloatReg :: HasCallStack => CmmExpr -> NatM (Reg, Format, InstrBlock)+getFloatReg expr = do+  r <- getRegister expr+  case r of+    Any rep code | isFloatFormat rep -> do+      tmp <- getNewRegNat rep+      return (tmp, rep, code tmp)+    Any II32 code -> do+      tmp <- getNewRegNat FF32+      return (tmp, FF32, code tmp)+    Any II64 code -> do+      tmp <- getNewRegNat FF64+      return (tmp, FF64, code tmp)+    Any _w _code -> do+      config <- getConfig+      pprPanic "can't do getFloatReg on" (pdoc (ncgPlatform config) expr)+    -- can't do much for fixed.+    Fixed rep reg code ->+      return (reg, rep, code)++-- | Map `CmmLit` to `OpImm`+litToImm' :: CmmLit -> Operand+litToImm' = OpImm . litToImm++-- Handling PIC on LA64+-- Commonly, `PIC` means of `position independent code`, that to say, the execution+-- of code does not be influenced by Load_address. Through PC-Relative addressing+-- or GOT addressing, both can be used to implement `PIC`.+--+-- For LoongArch's common compiler(GCC, Clang), they generate PIC code by default+-- without condition. The command option `-fPIC` dicates to generate code for+-- shared-library. If not just specified for shared-library, another option `-fPIE`+-- was be created.+--+-- Like RV64, LA64 does not have a special PIC register, the general approach is to+-- simply do PC-relative addressing or go through the GOT. There is assembly support+-- for both.+--+-- LA64 assembly has many `la*` (load address) pseudo-instructions, that allows+-- loading a symbols's address into a register. These instructions is desugared into+-- different addressing modes. See following:+--+-- la        rd, label + addend  -> Load global symbol+-- la.global rd, label + addend  -> Same as `la`+-- la.local  rd, label + addend  -> Load local symbol+-- la.pcrel  rd, label + addend+-- la.got    rd, label+-- la.abs    rd, label + addend+--+-- `la` is alias of `la.global`. Commonly recommended use `la.local` and `la.global`.+--+-- PC-relative addressing:+--   pcalau12i $a0, %pc_hi20(a)+--   addi.d    $a0, $a0, %pc_lo12(a)+--+-- GOT addressing:+--   pcalau12i $a0, %got_pc_hi20(global_a)+--   ld.d      $a0, $a0, %got_pc_lo12(global_a)+--+-- PIC can be enabled/disabled through:+--  .option pic+--+-- CmmGlobal @PicBaseReg@'s are generated in @GHC.CmmToAsm.PIC@ in the+-- @cmmMakePicReference@.  This is in turn called from @cmmMakeDynamicReference@+-- also in @Cmm.CmmToAsm.PIC@ from where it is also exported.  There are two+-- callsites for this. One is in this module to produce the @target@ in @genCCall@+-- the other is in @GHC.CmmToAsm@ in @cmmExprNative@.+--+-- Conceptually we do not want any special PicBaseReg to be used on LA64. If+-- we want to distinguish between symbol loading, we need to address this through+-- the way we load it, not through a register.++-- Compute a `CmmExpr` into a `Register`+getRegister :: CmmExpr -> NatM Register+getRegister e = do+  config <- getConfig+  getRegister' config (ncgPlatform config) e++-- Signed arithmetic on LoongArch64+--+-- Handling signed arithmetic on sub-word-size values on LA64 is a bit tricky+-- as Cmm's type system does not capture signedness. While 32- and 64-bit+-- values are fairly easy to handle due to LA64's 32- and 64-bit instructions+-- with responding register, 8- and 16-bit values require quite some care.+--+-- For LoongArch64, EXT.W.[B/H] will sign-extend 8- and 16-bit to 64-bit.+-- However, it is best to use EXT instruction only if the input and+-- output data widths are fully determined.+--+-- We handle 16-and 8-bit values by using the following two steps:+--  1. Sign- or Zero-extending operands.+--  2. Truncate results as necessary.+--+-- For simplicity we maintain the invariant that a register containing a+-- sub-word-size value always contains the zero-extended form of that value+-- in between operations.++getRegister' :: NCGConfig -> Platform -> CmmExpr -> NatM Register++-- OPTIMIZATION WARNING: CmmExpr rewrites++-- Generic case.+getRegister' config plat expr =+  case expr of+    CmmReg (CmmGlobal (GlobalRegUse PicBaseReg _)) ->+      pprPanic "getRegisterReg-memory" (ppr PicBaseReg)++    CmmLit lit ->+      case lit of+        CmmInt 0 w -> pure $ Fixed (intFormat w) zeroReg nilOL+        CmmInt i w -> do+          -- narrowU is important: Negative immediates may be+          -- sign-extended on load!+          let imm = OpImm . ImmInteger $ narrowU w i+          return (Any (intFormat w) (\dst -> unitOL $ annExpr expr (MOV (OpReg w dst) imm)))++        CmmFloat 0 w -> do+          let op = litToImm' lit+          pure (Any (floatFormat w) (\dst -> unitOL $ annExpr expr (MOV (OpReg w dst) op)))++        CmmFloat _f W8  -> pprPanic "getRegister' (CmmLit:CmmFloat), no support for bytes" (pdoc plat expr)+        CmmFloat _f W16 -> pprPanic "getRegister' (CmmLit:CmmFloat), no support for halfs" (pdoc plat expr)++        CmmFloat f W32 -> do+          let word = castFloatToWord32 (fromRational f) :: Word32+          tmp <- getNewRegNat (intFormat W32)+          return (Any (floatFormat W32) (\dst -> toOL [ annExpr expr+                                                      $ MOV (OpReg W32 tmp) (OpImm (ImmInteger (fromIntegral word)))+                                                      , MOV (OpReg W32 dst) (OpReg W32 tmp)+                                                      ]))+        CmmFloat f W64 -> do+          let word = castDoubleToWord64 (fromRational f) :: Word64+          tmp <- getNewRegNat (intFormat W64)+          return (Any (floatFormat W64) (\dst -> toOL [ annExpr expr+                                                      $ MOV (OpReg W64 tmp) (OpImm (ImmInteger (fromIntegral word)))+                                                      , MOV (OpReg W64 dst) (OpReg W64 tmp)+                                                      ]))++        CmmFloat _f _w -> pprPanic "getRegister' (CmmLit:CmmFloat), unsupported float lit" (pdoc plat expr)+        CmmVec _lits -> pprPanic "getRegister' (CmmLit:CmmVec): " (pdoc plat expr)++        CmmLabel lbl -> do+          let op = OpImm (ImmCLbl lbl)+              rep = cmmLitType plat lit+              format = cmmTypeFormat rep+          return (Any format (\dst -> unitOL $ annExpr expr (LD format (OpReg (formatToWidth format) dst) op)))++        CmmLabelOff lbl off | isNbitEncodeable 12 (fromIntegral off) -> do+          let op = OpImm (ImmIndex lbl off)+              rep = cmmLitType plat lit+              format = cmmTypeFormat rep+          return (Any format (\dst -> unitOL $ LD format (OpReg (formatToWidth format) dst) op))++        CmmLabelOff lbl off -> do+          let op = litToImm' (CmmLabel lbl)+              rep = cmmLitType plat lit+              format = cmmTypeFormat rep+              width = typeWidth rep+          (off_r, _off_format, off_code) <- getSomeReg $ CmmLit (CmmInt (fromIntegral off) width)+          return (Any format (\dst -> off_code `snocOL`+                                                LD format (OpReg (formatToWidth format) dst) op `snocOL`+                                                ADD (OpReg W64 dst) (OpReg width dst) (OpReg width off_r)+                             ))++        CmmLabelDiffOff {} -> pprPanic "getRegister' (CmmLit:CmmLabelOff): " (pdoc plat expr)+        CmmBlock _ -> pprPanic "getRegister' (CmmLit:CmmLabelOff): " (pdoc plat expr)+        CmmHighStackMark -> pprPanic "getRegister' (CmmLit:CmmLabelOff): " (pdoc plat expr)++    CmmLoad mem rep _ -> do+      let format = cmmTypeFormat rep+          width = typeWidth rep+      Amode addr addr_code <- getAmode plat width mem+      case width of+        w | w `elem` [W8, W16, W32, W64] ->+            -- Load without sign-extension.+            pure (Any format (\dst ->+              addr_code `snocOL`+              LDU format (OpReg width dst) (OpAddr addr))+                              )+        _ -> pprPanic ("Unknown width to load: " ++ show width) (pdoc plat expr)++    CmmStackSlot _ _  -> pprPanic "getRegister' (CmmStackSlot): " (pdoc plat expr)++    CmmReg reg -> return (Fixed (cmmTypeFormat (cmmRegType reg))+                                (getRegisterReg plat reg)+                                nilOL+                         )++    CmmRegOff reg off | isNbitEncodeable 12 (fromIntegral off) -> do+      getRegister' config plat+        $ CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)]+      where+        width = typeWidth (cmmRegType reg)+    CmmRegOff reg off -> do+      (off_r, _off_format, off_code) <- getSomeReg $ CmmLit (CmmInt (fromIntegral off) width)+      (reg, _format, code) <- getSomeReg $ CmmReg reg+      return $ Any (intFormat width) ( \dst ->+                                        off_code `appOL`+                                        code `snocOL`+                                        ADD (OpReg W64 dst) (OpReg width reg) (OpReg width off_r)+                                     )+      where+        width = typeWidth (cmmRegType reg)++    -- Handle MO_RelaxedRead as a normal CmmLoad, to allow+    -- non-trivial addressing modes to be used.+    CmmMachOp (MO_RelaxedRead w) [e] ->+      getRegister (CmmLoad e (cmmBits w) NaturallyAligned)++    -- for MachOps, see GHC.Cmm.MachOp+    -- For CmmMachOp, see GHC.Cmm.Expr+    CmmMachOp op [e] -> do+      (reg, format, code) <- getSomeReg e+      case op of+        MO_Not w -> return $ Any (intFormat w) $ \dst ->+          code `appOL`+          -- pseudo instruction `not dst rd` is `nor dst, r0, rd`+          truncateReg (formatToWidth format) W64 reg `snocOL`+          -- At this point an 8- or 16-bit value would be zero-extended+          -- to 64-bits. Truncate back down the final width.+          ann (text "not") (NOR (OpReg W64 dst) (OpReg W64 reg) zero) `appOL`+          truncateReg W64 w dst++        MO_S_Neg w -> negate code w reg+        MO_F_Neg w -> return $ Any (floatFormat w) (\dst -> code `snocOL` FNEG (OpReg w dst) (OpReg w reg))++        -- Floating convertion oprations+        -- Float -> Float+        MO_FF_Conv from to -> return $ Any (floatFormat to) (\dst -> code `snocOL` FCVT (OpReg to dst) (OpReg from reg))++        -- Signed int -> Float+        MO_SF_Round from to -> return $ Any (floatFormat to) (\dst -> code `snocOL` SCVTF (OpReg to dst) (OpReg from reg))++        -- Float -> Signed int+        MO_FS_Truncate from to | from == W32 -> do+            tmp <- getNewRegNat FF32+            return $ Any (intFormat to) (\dst -> code `snocOL` FCVTZS (OpReg to dst) (OpReg from tmp) (OpReg from reg))++        MO_FS_Truncate from to | from == W64-> do+            tmp <- getNewRegNat FF64+            return $ Any (intFormat to) (\dst -> code `snocOL` FCVTZS (OpReg to dst) (OpReg from tmp) (OpReg from reg))++        -- unsigned int -> unsigned int+        MO_UU_Conv from to -> return $ Any (intFormat to) (\dst ->+          code `snocOL` BSTRPICK II64 (OpReg W64 dst) (OpReg W64 reg) (OpImm (ImmInt (widthToInt (min from to) - 1))) (OpImm (ImmInt 0))+                                                          )++        -- Signed int -> Signed int+        MO_SS_Conv from to -> ss_conv from to reg code++        -- int -> int+        MO_XX_Conv _from to -> swizzleRegisterRep (intFormat to) <$> getRegister e++        MO_WF_Bitcast w    -> return $ Any (floatFormat w)  (\dst -> code `snocOL` MOV (OpReg w dst) (OpReg w reg))+        MO_FW_Bitcast w    -> return $ Any (intFormat w)    (\dst -> code `snocOL` MOV (OpReg w dst) (OpReg w reg))++        x -> pprPanic ("getRegister' (monadic CmmMachOp): " ++ show x) (pdoc plat expr)+      where+        -- In the case of 32- or 16- or 8-bit values we need to sign-extend to 64-bits+        negate code w reg+          | w `elem` [W8, W16] = do+            return $ Any (intFormat w) $ \dst ->+                code `snocOL`+                EXT (OpReg W64 reg) (OpReg w reg) `snocOL`+                NEG (OpReg W64 dst) (OpReg W64 reg) `appOL`+                truncateReg W64 w dst+          | otherwise = do+            return $ Any (intFormat w) $ \dst ->+                code `snocOL`+                NEG (OpReg W64 dst) (OpReg w reg)++        ss_conv from to reg code+          | from `elem` [W8, W16] || to `elem` [W8, W16] = do+            return $ Any (intFormat to) $ \dst ->+                code `snocOL`+                EXT (OpReg W64 dst) (OpReg (min from to) reg) `appOL`+                -- At this point an 8- or 16-bit value would be sign-extended+                -- to 64-bits. Truncate back down the final width.+                truncateReg W64 to dst+          | from == W32 && to == W64 = do+            return $ Any (intFormat to) $ \dst ->+                code `snocOL`+                SLL (OpReg to dst) (OpReg from reg) (OpImm (ImmInt 0))+          | from == to = do+            return $ Any (intFormat from) $ \dst ->+                 code `snocOL` MOV (OpReg from dst) (OpReg from reg)+          | otherwise = do+            return $ Any (intFormat to) $ \dst ->+                code `appOL`+                signExtend from W64 reg dst `appOL`+                truncateReg W64 to dst+++-- Dyadic machops:+    --+    -- The general idea is:+    -- compute x<i> <- x+    -- compute x<j> <- y+    -- OP x<r>, x<i>, x<j>+    --+    -- TODO: for now we'll only implement the 64bit versions. And rely on the+    --      fallthrough to alert us if things go wrong!+    -- OPTIMIZATION WARNING: Dyadic CmmMachOp destructuring+    -- 0. TODO This should not exist! Rewrite: Reg +- 0 -> Reg+    CmmMachOp (MO_Add _) [expr'@(CmmReg (CmmGlobal _r)), CmmLit (CmmInt 0 _)] -> getRegister' config plat expr'+    CmmMachOp (MO_Sub _) [expr'@(CmmReg (CmmGlobal _r)), CmmLit (CmmInt 0 _)] -> getRegister' config plat expr'++    CmmMachOp (MO_Add w) [x, CmmLit (CmmInt n _)] | fitsInNbits 12 (fromIntegral n) -> do+      if w `elem` [W8, W16]+        then do+          (reg_x, _format_x, code_x) <- getSomeReg x+          return $ Any (intFormat w) (\dst ->+                                        code_x `snocOL`+                                        annExpr expr (EXT (OpReg W64 reg_x) (OpReg w reg_x)) `snocOL`+                                        ADD (OpReg W64 dst) (OpReg W64 reg_x) (OpImm (ImmInteger n))+                                     )+        else do+          (reg_x, _format_x, code_x) <- getSomeReg x+          return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (ADD (OpReg W64 dst) (OpReg w reg_x) (OpImm (ImmInteger n))))++    CmmMachOp (MO_Sub w) [x, CmmLit (CmmInt n _)] | fitsInNbits 12 (fromIntegral n) -> do+      if w `elem` [W8, W16]+        then do+          (reg_x, _format_x, code_x) <- getSomeReg x+          return $ Any (intFormat w) (\dst ->+                                        code_x `snocOL`+                                        annExpr expr (EXT (OpReg W64 reg_x) (OpReg w reg_x)) `snocOL`+                                        SUB (OpReg W64 dst) (OpReg W64 reg_x) (OpImm (ImmInteger n))+                                     )+        else do+          (reg_x, _format_x, code_x) <- getSomeReg x+          return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (SUB (OpReg W64 dst) (OpReg w reg_x) (OpImm (ImmInteger n))))++    CmmMachOp (MO_U_Quot w) [x, y]+      | w `elem` [W8, W16] -> do+        (reg_x, _format_x, code_x) <- getSomeReg x+        (reg_y, _format_y, code_y) <- getSomeReg y+        return $ Any (intFormat w) (\dst ->+                                      code_x `appOL`+                                      code_y `appOL`+                                      truncateReg w W64 reg_x `appOL`+                                      truncateReg w W64 reg_y `snocOL`+                                      annExpr expr (DIVU (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))+                                   )++    -- 2. Shifts.+    CmmMachOp (MO_Shl w) [x, y] ->+      case y of+        CmmLit (CmmInt n _) | w `elem` [W8, W16], 0 <= n, n < fromIntegral (widthInBits w) -> do+          (reg_x, _format_x, code_x) <- getSomeReg x+          return $ Any (intFormat w) (\dst ->+                                        code_x `snocOL`+                                        annExpr expr (EXT (OpReg W64 reg_x) (OpReg w reg_x)) `snocOL`+                                        SLL (OpReg W64 dst) (OpReg W64 reg_x) (OpImm (ImmInteger n))+                                     )+        CmmLit (CmmInt n _) | 0 <= n, n < fromIntegral (widthInBits w) -> do+          (reg_x, _format_x, code_x) <- getSomeReg x+          return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (SLL (OpReg W64 dst) (OpReg w reg_x) (OpImm (ImmInteger n))))++        _ | w `elem` [W8, W16] -> do+          (reg_x, _format_x, code_x) <- getSomeReg x+          (reg_y, _format_y, code_y) <- getSomeReg y+          return $ Any (intFormat w) (\dst ->+                                        code_x `appOL`+                                        code_y `snocOL`+                                        annExpr expr (EXT (OpReg W64 reg_x) (OpReg w reg_x)) `snocOL`+                                        EXT (OpReg W64 reg_y) (OpReg w reg_y) `snocOL`+                                        SLL (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y)+                                     )+        _ -> do+          (reg_x, _format_x, code_x) <- getSomeReg x+          (reg_y, _format_y, code_y) <- getSomeReg y+          return $ Any (intFormat w) (\dst ->+                                        code_x `appOL`+                                        code_y `snocOL`+                                        annExpr expr (SLL (OpReg W64 dst) (OpReg w reg_x) (OpReg w reg_y))+                                     )++    -- MO_S_Shr: signed-shift-right+    CmmMachOp (MO_S_Shr w) [x, y] ->+      case y of+        CmmLit (CmmInt n _) | w `elem` [W8, W16], 0 <= n, n < fromIntegral (widthInBits w) -> do+          (reg_x, _format_x, code_x) <- getSomeReg x+          return $ Any (intFormat w)  (\dst ->+                                        code_x `snocOL`+                                        annExpr expr (EXT (OpReg W64 reg_x) (OpReg w reg_x)) `snocOL`+                                        SRA (OpReg W64 dst) (OpReg W64 reg_x) (OpImm (ImmInteger n))+                                      )+        CmmLit (CmmInt n _) | 0 <= n, n < fromIntegral (widthInBits w) -> do+          (reg_x, _format_x, code_x) <- getSomeReg x+          return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (SRA (OpReg W64 dst) (OpReg w reg_x) (OpImm (ImmInteger n))))++        _ | w `elem` [W8, W16] -> do+          (reg_x, _format_x, code_x) <- getSomeReg x+          (reg_y, _format_y, code_y) <- getSomeReg y+          return $ Any (intFormat w) (\dst ->+                                        code_x `appOL`+                                        code_y `snocOL`+                                        annExpr expr (EXT (OpReg W64 reg_x) (OpReg w reg_x)) `snocOL`+                                        EXT (OpReg W64 reg_y) (OpReg w reg_y) `snocOL`+                                        SRA (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y)+                                     )+        _ -> do+          (reg_x, _format_x, code_x) <- getSomeReg x+          (reg_y, _format_y, code_y) <- getSomeReg y+          return $ Any (intFormat w) (\dst ->+                                        code_x `appOL`+                                        code_y `snocOL`+                                        annExpr expr (SRA (OpReg W64 dst) (OpReg w reg_x) (OpReg w reg_y))+                                     )++    -- MO_U_Shr: unsigned-shift-right+    CmmMachOp (MO_U_Shr w) [x, y] ->+      case y of+        CmmLit (CmmInt n _) | w `elem` [W8, W16], 0 <= n, n < fromIntegral (widthInBits w) -> do+          (reg_x, _format_x, code_x) <- getSomeReg x+          return $ Any (intFormat w) (\dst ->+                                        code_x `appOL`+                                        truncateReg w W64 reg_x `snocOL`+                                        annExpr expr (SRL (OpReg W64 dst) (OpReg W64 reg_x) (OpImm (ImmInteger n)))+                                     )+        CmmLit (CmmInt n _) | 0 <= n, n < fromIntegral (widthInBits w) -> do+          (reg_x, _format_x, code_x) <- getSomeReg x+          return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (SRL (OpReg W64 dst) (OpReg w reg_x) (OpImm (ImmInteger n))))++        _ | w `elem` [W8, W16] -> do+          (reg_x, _format_x, code_x) <- getSomeReg x+          (reg_y, _format_y, code_y) <- getSomeReg y+          return $ Any (intFormat w) (\dst ->+                                        code_x `appOL`+                                        code_y `appOL`+                                        truncateReg w W64 reg_x `appOL`+                                        truncateReg w W64 reg_y `snocOL`+                                        annExpr expr (SRL (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))+                                     )+        _ -> do+          (reg_x, _format_x, code_x) <- getSomeReg x+          (reg_y, _format_y, code_y) <- getSomeReg y+          return $ Any (intFormat w) (\dst ->+                                        code_x `appOL`+                                        code_y `snocOL`+                                        annExpr expr (SRL (OpReg W64 dst) (OpReg w reg_x) (OpReg w reg_y))+                                     )++    -- 3. Logic &&, ||+    -- andi Instr's Imm-operand is zero-extended.+    CmmMachOp (MO_And w) [x, y] ->+      case y of+        CmmLit (CmmInt n _) | w `elem` [W8, W16, W32], (n :: Integer) >= 0, (n :: Integer) <= 4095 -> do+          (reg_x, _format_x, code_x) <- getSomeReg x+          return $ Any (intFormat w) (\dst ->+                                        code_x `appOL`+                                        truncateReg w W64 reg_x `snocOL`+                                        annExpr expr (AND (OpReg W64 dst) (OpReg W64 reg_x) (OpImm (ImmInteger n)))+                                     )++        CmmLit (CmmInt n _) | (n :: Integer) >= 0, (n :: Integer) <= 4095 -> do+          (reg_x, _format_x, code_x) <- getSomeReg x+          return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (AND (OpReg W64 dst) (OpReg w reg_x) (OpImm (ImmInteger n))))++        CmmLit (CmmInt n _) | w `elem` [W8, W16, W32] -> do+          (reg_x, _format_x, code_x) <- getSomeReg x+          tmp <- getNewRegNat II64+          return $ Any (intFormat w) (\dst ->+                                       code_x `appOL`+                                       truncateReg w W64 reg_x `snocOL`+                                       annExpr expr (MOV (OpReg W64 tmp) (OpImm (ImmInteger n))) `snocOL`+                                       AND (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 tmp)+                                     )++        CmmLit (CmmInt n _) -> do+          (reg_x, _format_x, code_x) <- getSomeReg x+          tmp <- getNewRegNat II64+          return $ Any (intFormat w) (\dst ->+                                        code_x `snocOL`+                                        annExpr expr (MOV (OpReg W64 tmp) (OpImm (ImmInteger  n))) `snocOL`+                                        AND (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 tmp)+                                     )++        _ | w `elem` [W8, W16, W32] -> do+          (reg_x, _format_x, code_x) <- getSomeReg x+          (reg_y, _format_y, code_y) <- getSomeReg y+          return $ Any (intFormat w) (\dst ->+                                        code_x `appOL`+                                        code_y `appOL`+                                        truncateReg w W64 reg_x `appOL`+                                        truncateReg w W64 reg_y `snocOL`+                                        annExpr expr (AND (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))+                                     )++        _ -> do+          (reg_x, _format_x, code_x) <- getSomeReg x+          (reg_y, _format_y, code_y) <- getSomeReg y+          return $ Any (intFormat w) (\dst ->+                                        code_x `appOL`+                                        code_y `snocOL`+                                        annExpr expr (AND (OpReg W64 dst) (OpReg w reg_x) (OpReg w reg_y))+                                     )++    -- ori Instr's Imm-operand is zero-extended.+    CmmMachOp (MO_Or w) [x, y] ->+      case y of+        CmmLit (CmmInt n _) | w `elem` [W8, W16, W32], (n :: Integer) >= 0, (n :: Integer) <= 4095 -> do+          (reg_x, _format_x, code_x) <- getSomeReg x+          return $ Any (intFormat w) (\dst ->+                                        code_x `appOL`+                                        truncateReg w W64 reg_x `snocOL`+                                        annExpr expr (OR (OpReg W64 dst) (OpReg W64 reg_x) (OpImm (ImmInteger n)))+                                     )++        CmmLit (CmmInt n _) | (n :: Integer) >= 0, (n :: Integer) <= 4095 -> do+          (reg_x, _format_x, code_x) <- getSomeReg x+          return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (OR (OpReg W64 dst) (OpReg w reg_x) (OpImm (ImmInteger n))))++        CmmLit (CmmInt n _) | w `elem` [W8, W16, W32] -> do+          (reg_x, _format_x, code_x) <- getSomeReg x+          tmp <- getNewRegNat II64+          return $ Any (intFormat w) (\dst ->+                                       code_x `appOL`+                                       truncateReg w W64 reg_x `snocOL`+                                       annExpr expr (MOV (OpReg W64 tmp) (OpImm (ImmInteger n))) `snocOL`+                                       OR (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 tmp)+                                     )++        CmmLit (CmmInt n _) -> do+          (reg_x, _format_x, code_x) <- getSomeReg x+          tmp <- getNewRegNat II64+          return $ Any (intFormat w) (\dst ->+                                        code_x `snocOL`+                                        annExpr expr (MOV (OpReg W64 tmp) (OpImm (ImmInteger  n))) `snocOL`+                                        OR (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 tmp)+                                     )++        _ | w `elem` [W8, W16, W32] -> do+          (reg_x, _format_x, code_x) <- getSomeReg x+          (reg_y, _format_y, code_y) <- getSomeReg y+          return $ Any (intFormat w) (\dst ->+                                        code_x `appOL`+                                        code_y `appOL`+                                        truncateReg w W64 reg_x `appOL`+                                        truncateReg w W64 reg_y `snocOL`+                                        annExpr expr (OR (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))+                                     )++        _ -> do+          (reg_x, _format_x, code_x) <- getSomeReg x+          (reg_y, _format_y, code_y) <- getSomeReg y+          return $ Any (intFormat w) (\dst ->+                                        code_x `appOL`+                                        code_y `snocOL`+                                        annExpr expr (OR (OpReg W64 dst) (OpReg w reg_x) (OpReg w reg_y))+                                     )++    -- xori Instr's Imm-operand is zero-extended.+    CmmMachOp (MO_Xor w) [x, y] ->+      case y of+        CmmLit (CmmInt n _) | w `elem` [W8, W16, W32], (n :: Integer) >= 0, (n :: Integer) <= 4095 -> do+          (reg_x, _format_x, code_x) <- getSomeReg x+          return $ Any (intFormat w) (\dst ->+                                        code_x `appOL`+                                        truncateReg w W64 reg_x `snocOL`+                                        annExpr expr (XOR (OpReg W64 dst) (OpReg W64 reg_x) (OpImm (ImmInteger n)))+                                     )++        CmmLit (CmmInt n _) | (n :: Integer) >= 0, (n :: Integer) <= 4095 -> do+          (reg_x, _format_x, code_x) <- getSomeReg x+          return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (XOR (OpReg W64 dst) (OpReg w reg_x) (OpImm (ImmInteger n))))++        CmmLit (CmmInt n _) | w `elem` [W8, W16, W32] -> do+          (reg_x, _format_x, code_x) <- getSomeReg x+          tmp <- getNewRegNat II64+          return $ Any (intFormat w) (\dst ->+                                       code_x `appOL`+                                       truncateReg w W64 reg_x `snocOL`+                                       annExpr expr (MOV (OpReg W64 tmp) (OpImm (ImmInteger n))) `snocOL`+                                       XOR (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 tmp)+                                     )++        CmmLit (CmmInt n _) -> do+          (reg_x, _format_x, code_x) <- getSomeReg x+          tmp <- getNewRegNat II64+          return $ Any (intFormat w) (\dst ->+                                        code_x `snocOL`+                                        annExpr expr (MOV (OpReg W64 tmp) (OpImm (ImmInteger  n))) `snocOL`+                                        XOR (OpReg W64 dst) (OpReg w reg_x) (OpReg W64 tmp)+                                     )++        _ | w `elem` [W8, W16, W32] -> do+          (reg_x, _format_x, code_x) <- getSomeReg x+          (reg_y, _format_y, code_y) <- getSomeReg y+          return $ Any (intFormat w) (\dst ->+                                        code_x `appOL`+                                        code_y `appOL`+                                        truncateReg w W64 reg_x `appOL`+                                        truncateReg w W64 reg_y `snocOL`+                                        annExpr expr (XOR (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))+                                     )++        _ -> do+          (reg_x, _format_x, code_x) <- getSomeReg x+          (reg_y, _format_y, code_y) <- getSomeReg y+          return $ Any (intFormat w) (\dst ->+                                        code_x `appOL`+                                        code_y `snocOL`+                                        annExpr expr (XOR (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))+                                     )++    -- CSET commands register operand being W64.+    CmmMachOp (MO_Eq w) [x, y]+      | w `elem` [W8, W16, W32] -> do+        (reg_x, _format_x, code_x) <- getSomeReg x+        (reg_y, _format_y, code_y) <- getSomeReg y+        return $ Any (intFormat w) ( \dst ->+                                      code_x `appOL`+                                      code_y `appOL`+                                      signExtend w W64 reg_x reg_x `appOL`+                                      signExtend w W64 reg_y reg_y `snocOL`+                                      annExpr expr (CSET EQ (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))+                                   )+       | otherwise -> do+        (reg_x, _format_x, code_x) <- getSomeReg x+        (reg_y, _format_y, code_y) <- getSomeReg y+        return $ Any (intFormat w) ( \dst ->+                                      code_x `appOL`+                                      code_y `snocOL`+                                      annExpr expr (CSET EQ (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))+                                   )++    CmmMachOp (MO_Ne w) [x, y]+      | w `elem` [W8, W16, W32] -> do+        (reg_x, _format_x, code_x) <- getSomeReg x+        (reg_y, _format_y, code_y) <- getSomeReg y+        return $ Any (intFormat w) ( \dst ->+                                      code_x `appOL`+                                      code_y `appOL`+                                      signExtend w W64 reg_x reg_x `appOL`+                                      signExtend w W64 reg_y reg_y `snocOL`+                                      annExpr expr (CSET NE (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))+                                   )+      | otherwise -> do+        (reg_x, _format_x, code_x) <- getSomeReg x+        (reg_y, _format_y, code_y) <- getSomeReg y+        return $ Any (intFormat w) ( \dst ->+                                      code_x `appOL`+                                      code_y `snocOL`+                                      annExpr expr (CSET NE (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))+                                   )++    CmmMachOp (MO_S_Lt w) [x, CmmLit (CmmInt n _)]+      | w `elem` [W8, W16, W32]+      , fitsInNbits 12 (fromIntegral n) -> do+        (reg_x, _format_x, code_x) <- getSomeReg x+        return $ Any (intFormat w) ( \dst ->+                                      code_x `appOL`+                                      signExtend w W64 reg_x reg_x `snocOL`+                                      annExpr expr (SSLT (OpReg W64 dst) (OpReg W64 reg_x) (OpImm (ImmInteger n)))+                                   )+      | fitsInNbits 12 (fromIntegral n) -> do+        (reg_x, _format_x, code_x) <- getSomeReg x+        return $ Any (intFormat w) ( \dst -> code_x `snocOL` annExpr expr (SSLT (OpReg W64 dst) (OpReg W64 reg_x) (OpImm (ImmInteger n))))++    CmmMachOp (MO_U_Lt w) [x, CmmLit (CmmInt n _)]+      | w `elem` [W8, W16, W32]+      , fitsInNbits 12 (fromIntegral n) -> do+        (reg_x, _format_x, code_x) <- getSomeReg x+        return $ Any (intFormat w) ( \dst ->+                                      code_x `appOL`+                                      truncateReg w W64 reg_x `snocOL`+                                      annExpr expr (SSLTU (OpReg W64 dst) (OpReg W64 reg_x) (OpImm (ImmInteger n)))+                                   )+      | fitsInNbits 12 (fromIntegral n) -> do+        (reg_x, _format_x, code_x) <- getSomeReg x+        return $ Any (intFormat w) ( \dst -> code_x `snocOL` annExpr expr (SSLTU (OpReg W64 dst) (OpReg W64 reg_x) (OpImm (ImmInteger  n))))++    CmmMachOp (MO_S_Lt w) [x, y]+      | w `elem` [W8, W16, W32] -> do+        (reg_x, _format_x, code_x) <- getSomeReg x+        (reg_y, _format_y, code_y) <- getSomeReg y+        return $ Any (intFormat w) ( \dst ->+                                      code_x `appOL`+                                      code_y `appOL`+                                      signExtend w W64 reg_x reg_x `appOL`+                                      signExtend w W64 reg_y reg_y `snocOL`+                                      annExpr expr (CSET SLT (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))+                                   )+      | otherwise -> do+        (reg_x, _format_x, code_x) <- getSomeReg x+        (reg_y, _format_y, code_y) <- getSomeReg y+        return $ Any (intFormat w) ( \dst ->+                                      code_x `appOL`+                                      code_y `snocOL`+                                      annExpr expr (CSET SLT (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))+                                   )++    CmmMachOp (MO_S_Le w) [x, y]+      | w `elem` [W8, W16, W32] -> do+        (reg_x, _format_x, code_x) <- getSomeReg x+        (reg_y, _format_y, code_y) <- getSomeReg y+        return $ Any (intFormat w) ( \dst ->+                                      code_x `appOL`+                                      code_y `appOL`+                                      signExtend w W64 reg_x reg_x `appOL`+                                      signExtend w W64 reg_y reg_y `snocOL`+                                      annExpr expr (CSET SLE (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))+                                   )+      | otherwise -> do+        (reg_x, _format_x, code_x) <- getSomeReg x+        (reg_y, _format_y, code_y) <- getSomeReg y+        return $ Any (intFormat w) ( \dst ->+                                      code_x `appOL`+                                      code_y `snocOL`+                                      annExpr expr (CSET SLE (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))+                                   )++    CmmMachOp (MO_S_Ge w) [x, y]+      | w `elem` [W8, W16, W32] -> do+        (reg_x, _format_x, code_x) <- getSomeReg x+        (reg_y, _format_y, code_y) <- getSomeReg y+        return $ Any (intFormat w) ( \dst ->+                                      code_x `appOL`+                                      code_y `appOL`+                                      signExtend w W64 reg_x reg_x `appOL`+                                      signExtend w W64 reg_y reg_y `snocOL`+                                      annExpr expr (CSET SGE (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))+                                   )+      | otherwise -> do+        (reg_x, _format_x, code_x) <- getSomeReg x+        (reg_y, _format_y, code_y) <- getSomeReg y+        return $ Any (intFormat w) ( \dst ->+                                      code_x `appOL`+                                      code_y `snocOL`+                                      annExpr expr (CSET SGE (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))+                                   )++    CmmMachOp (MO_S_Gt w) [x, y]+      | w `elem` [W8, W16, W32] -> do+        (reg_x, _format_x, code_x) <- getSomeReg x+        (reg_y, _format_y, code_y) <- getSomeReg y+        return $ Any (intFormat w) ( \dst ->+                                      code_x `appOL`+                                      code_y `appOL`+                                      signExtend w W64 reg_x reg_x `appOL`+                                      signExtend w W64 reg_y reg_y `snocOL`+                                      annExpr expr (CSET SGT (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))+                                   )+      | otherwise -> do+        (reg_x, _format_x, code_x) <- getSomeReg x+        (reg_y, _format_y, code_y) <- getSomeReg y+        return $ Any (intFormat w) ( \dst ->+                                      code_x `appOL`+                                      code_y `snocOL`+                                      annExpr expr (CSET SGT (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))+                                   )++    CmmMachOp (MO_U_Lt w) [x, y]+      | w `elem` [W8, W16, W32] -> do+        (reg_x, _format_x, code_x) <- getSomeReg x+        (reg_y, _format_y, code_y) <- getSomeReg y+        return $ Any (intFormat w) ( \dst ->+                                      code_x `appOL`+                                      code_y `appOL`+                                      truncateReg w W64 reg_x `appOL`+                                      truncateReg w W64 reg_y `snocOL`+                                      annExpr expr (CSET ULT (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))+                                   )+      | otherwise -> do+        (reg_x, _format_x, code_x) <- getSomeReg x+        (reg_y, _format_y, code_y) <- getSomeReg y+        return $ Any (intFormat w) ( \dst ->+                                      code_x `appOL`+                                      code_y `snocOL`+                                      annExpr expr (CSET ULT (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))+                                   )++    CmmMachOp (MO_U_Le w) [x, y]+      | w `elem` [W8, W16, W32] -> do+        (reg_x, _format_x, code_x) <- getSomeReg x+        (reg_y, _format_y, code_y) <- getSomeReg y+        return $ Any (intFormat w) ( \dst ->+                                      code_x `appOL`+                                      code_y `appOL`+                                      truncateReg w W64 reg_x `appOL`+                                      truncateReg w W64 reg_y `snocOL`+                                      annExpr expr (CSET ULE (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))+                                   )+      | otherwise -> do+        (reg_x, _format_x, code_x) <- getSomeReg x+        (reg_y, _format_y, code_y) <- getSomeReg y+        return $ Any (intFormat w) ( \dst ->+                                      code_x `appOL`+                                      code_y `snocOL`+                                      annExpr expr (CSET ULE (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))+                                   )++    CmmMachOp (MO_U_Ge w) [x, y]+      | w `elem` [W8, W16, W32] -> do+        (reg_x, _format_x, code_x) <- getSomeReg x+        (reg_y, _format_y, code_y) <- getSomeReg y+        return $ Any (intFormat w) ( \dst ->+                                      code_x `appOL`+                                      code_y `appOL`+                                      truncateReg w W64 reg_x `appOL`+                                      truncateReg w W64 reg_y `snocOL`+                                      annExpr expr (CSET UGE (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))+                                   )+      | otherwise -> do+        (reg_x, _format_x, code_x) <- getSomeReg x+        (reg_y, _format_y, code_y) <- getSomeReg y+        return $ Any (intFormat w) ( \dst ->+                                      code_x `appOL`+                                      code_y `snocOL`+                                      annExpr expr (CSET UGE (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))+                                   )++    CmmMachOp (MO_U_Gt w) [x, y]+      | w `elem` [W8, W16, W32] -> do+        (reg_x, _format_x, code_x) <- getSomeReg x+        (reg_y, _format_y, code_y) <- getSomeReg y+        return $ Any (intFormat w) ( \dst ->+                                      code_x `appOL`+                                      code_y `appOL`+                                      truncateReg w W64 reg_x `appOL`+                                      truncateReg w W64 reg_y `snocOL`+                                      annExpr expr (CSET UGT (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))+                                   )+      | otherwise -> do+        (reg_x, _format_x, code_x) <- getSomeReg x+        (reg_y, _format_y, code_y) <- getSomeReg y+        return $ Any (intFormat w) ( \dst ->+                                      code_x `appOL`+                                      code_y `snocOL`+                                      annExpr expr (CSET UGT (OpReg W64 dst) (OpReg W64 reg_x) (OpReg W64 reg_y))+                                   )+++    -- Generic binary case.+    CmmMachOp op [x, y] -> do+      let+          -- A (potentially signed) integer operation.+          -- In the case of 8-, 16- and 32-bit signed arithmetic we must first+          -- sign-extend all arguments to 64-bits.+          -- TODO: can be simplified.+          intOp is_signed w op = do+              -- compute x<m> <- x+              -- compute x<o> <- y+              -- <OP> x<n>, x<m>, x<o>+              (reg_x, format_x, code_x) <- getSomeReg x+              (reg_y, format_y, code_y) <- getSomeReg y+              massertPpr (isIntFormat format_x && isIntFormat format_y) $ text "intOp: non-int"+              let w' = W64+              -- This is the width of the registers on which the operation+              -- should be performed.+              if not is_signed+                then return $ Any (intFormat w) $ \dst ->+                      code_x `appOL`+                      code_y `appOL`+                      -- zero-extend both operands+                      truncateReg (formatToWidth format_x) w' reg_x `appOL`+                      truncateReg (formatToWidth format_y) w' reg_y `snocOL`+                      op (OpReg w' dst) (OpReg w' reg_x) (OpReg w' reg_y) `appOL`+                      truncateReg w' w dst -- truncate back to the operand's original width+                else return $ Any (intFormat w) $ \dst ->+                      code_x `appOL`+                      code_y `appOL`+                      -- sign-extend both operands+                      signExtend (formatToWidth format_x) W64 reg_x reg_x `appOL`+                      signExtend (formatToWidth format_x) W64 reg_y reg_y `snocOL`+                      op (OpReg w' dst) (OpReg w' reg_x) (OpReg w' reg_y) `appOL`+                      truncateReg w' w dst -- truncate back to the operand's original width++          floatOp w op = do+            (reg_fx, format_x, code_fx) <- getFloatReg x+            (reg_fy, format_y, code_fy) <- getFloatReg y+            massertPpr (isFloatFormat format_x && isFloatFormat format_y) $ text "floatOp: non-float"+            return $ Any (floatFormat w) (\dst -> code_fx `appOL` code_fy `appOL` op (OpReg w dst) (OpReg w reg_fx) (OpReg w reg_fy))++          -- need a special one for conditionals, as they return ints+          floatCond w op = do+            (reg_fx, format_x, code_fx) <- getFloatReg x+            (reg_fy, format_y, code_fy) <- getFloatReg y+            massertPpr (isFloatFormat format_x && isFloatFormat format_y) $ text "floatCond: non-float"+            return $ Any (intFormat w) (\dst -> code_fx `appOL` code_fy `appOL` op (OpReg w dst) (OpReg w reg_fx) (OpReg w reg_fy))++      case op of+        -- Integer operations+        -- Add/Sub should only be Integer Options.+        MO_Add w -> intOp False w (\d x y ->  annExpr expr (ADD d x y))+        MO_Sub w -> intOp False w (\d x y ->  annExpr expr (SUB d x y))++        -- Signed multiply/divide/remain+        MO_Mul w          -> intOp True w (\d x y -> annExpr expr (MUL d x y))+        MO_S_MulMayOflo w -> do_mul_may_oflo w x y++        MO_S_Quot w  -> intOp True w (\d x y -> annExpr expr (DIV d x y))+        MO_S_Rem w   -> intOp True w (\d x y -> annExpr expr (MOD d x y))++        -- Unsigned divide/remain+        MO_U_Quot w  -> intOp False w (\d x y -> annExpr expr (DIVU d x y))+        MO_U_Rem w   -> intOp False w (\d x y -> annExpr expr (MODU d x y))++        -- Floating point arithmetic+        MO_F_Add w   -> floatOp w (\d x y -> unitOL $ annExpr expr (ADD d x y))+        MO_F_Sub w   -> floatOp w (\d x y -> unitOL $ annExpr expr (SUB d x y))+        MO_F_Mul w   -> floatOp w (\d x y -> unitOL $ annExpr expr (MUL d x y))+        MO_F_Quot w  -> floatOp w (\d x y -> unitOL $ annExpr expr (DIV d x y))+        MO_F_Min w   -> floatOp w (\d x y -> unitOL $ annExpr expr (FMIN d x y))+        MO_F_Max w   -> floatOp w (\d x y -> unitOL $ annExpr expr (FMAX d x y))++        -- Floating point comparison+        MO_F_Eq w    -> floatCond w (\d x y -> unitOL $ annExpr expr (CSET EQ d x y))+        MO_F_Ne w    -> floatCond w (\d x y -> unitOL $ annExpr expr (CSET NE d x y))+        MO_F_Ge w    -> floatCond w (\d x y -> unitOL $ annExpr expr (CSET FGE d x y))+        MO_F_Le w    -> floatCond w (\d x y -> unitOL $ annExpr expr (CSET FLE d x y))+        MO_F_Gt w    -> floatCond w (\d x y -> unitOL $ annExpr expr (CSET FGT d x y))+        MO_F_Lt w    -> floatCond w (\d x y -> unitOL $ annExpr expr (CSET FLT d x y))++        op -> pprPanic "getRegister' (unhandled dyadic CmmMachOp): " $ pprMachOp op <+> text "in" <+> pdoc plat expr++    -- Generic ternary case.+    CmmMachOp op [x, y, z] ->+      case op of++        -- Floating-point fused multiply-add operations+        MO_FMA var l w+          | l == 1+          -> case var of+            FMAdd  -> float3Op w (\d n m a -> unitOL $ FMA FMAdd  d n m a)+            FMSub  -> float3Op w (\d n m a -> unitOL $ FMA FMSub d n m a)+            FNMAdd -> float3Op w (\d n m a -> unitOL $ FMA FNMSub  d n m a)+            FNMSub -> float3Op w (\d n m a -> unitOL $ FMA FNMAdd d n m a)+          | otherwise+          -> sorry "The RISCV64 backend does not (yet) support vectors."++        _ -> pprPanic "getRegister' (unhandled ternary CmmMachOp): " $ (pprMachOp op) <+> text "in" <+> (pdoc plat expr)++      where+          float3Op w op = do+            (reg_fx, format_x, code_fx) <- getFloatReg x+            (reg_fy, format_y, code_fy) <- getFloatReg y+            (reg_fz, format_z, code_fz) <- getFloatReg z+            massertPpr (isFloatFormat format_x && isFloatFormat format_y && isFloatFormat format_z) $+              text "float3Op: non-float"+            pure $+              Any (floatFormat w) $ \ dst ->+                code_fx `appOL`+                code_fy `appOL`+                code_fz `appOL`+                op (OpReg w dst) (OpReg w reg_fx) (OpReg w reg_fy) (OpReg w reg_fz)++    CmmMachOp _op _xs+      -> pprPanic "getRegister' (variadic CmmMachOp): " (pdoc plat expr)++  where+    -- N.B. MUL does not set the overflow flag.+    -- Return 0 when the operation cannot overflow, /= 0 otherwise+    do_mul_may_oflo :: Width -> CmmExpr -> CmmExpr -> NatM Register+    do_mul_may_oflo W64 x y = do+      (reg_x, _format_x, code_x) <- getSomeReg x+      (reg_y, _format_y, code_y) <- getSomeReg y+      lo <- getNewRegNat II64+      hi <- getNewRegNat II64+      return $ Any (intFormat W64) (\dst ->+        code_x `appOL`+        code_y `snocOL`+        MULH (OpReg W64 hi) (OpReg W64 reg_x)  (OpReg W64 reg_y) `snocOL`+        MUL  (OpReg W64 lo) (OpReg W64 reg_x)  (OpReg W64 reg_y) `snocOL`+        SRA  (OpReg W64 lo) (OpReg W64 lo)     (OpImm (ImmInt 63)) `snocOL`+        CSET NE (OpReg W64 dst) (OpReg W64 hi)  (OpReg W64 lo)+                                 )++    do_mul_may_oflo W32 x y = do+        (reg_x, _format_x, code_x) <- getSomeReg x+        (reg_y, _format_y, code_y) <- getSomeReg y+        tmp1 <- getNewRegNat II64+        tmp2 <- getNewRegNat II64+        return $ Any (intFormat W32) (\dst ->+            code_x `appOL`+            code_y `snocOL`+            MULW (OpReg W64 tmp1) (OpReg W64 reg_x) (OpReg W64 reg_y) `snocOL`+            ADD (OpReg W64 tmp2) (OpReg W32 tmp1) (OpImm (ImmInt 0)) `snocOL`+            CSET NE (OpReg W64 dst) (OpReg W64 tmp1)  (OpReg W64 tmp2)+                                     )++    -- General case+    do_mul_may_oflo w x y = do+      -- Assert: 8bit * 8bit cannot overflow 16bit, and so on.+      (reg_x, format_x, code_x) <- getSomeReg x+      (reg_y, format_y, code_y) <- getSomeReg y+      tmp1 <- getNewRegNat II64+      tmp2 <- getNewRegNat II64+      let width_x = formatToWidth format_x+          width_y = formatToWidth format_y+          extend dst src =+            case w of+              W8  -> SLL (OpReg W64 dst) (OpReg W32 src) (OpImm (ImmInt 0))+              W16 -> SLL (OpReg W64 dst) (OpReg W32 src) (OpImm (ImmInt 0))+              _   -> panic "Must be in [W8, W16, W32]!"+          extract width dst src =+            case width of+              W8  -> EXT (OpReg W64 dst) (OpReg W8 src)+              W16 -> EXT (OpReg W64 dst) (OpReg W16 src)+              W32 -> SLL (OpReg W64 dst) (OpReg W32 src) (OpImm (ImmInt 0))+              _   -> panic "Must be in [W8, W16, W32]!"++      case w of+        w | (width_x < w) && (width_y < w) ->+          return $ Any (intFormat w) ( \dst ->+            unitOL $ annExpr expr (MOV (OpReg w dst) (OpImm (ImmInt 0)))+                                     )+        w | w <= W32 && width_x <= W32 && width_y <= W32 ->+            return $ Any (intFormat W32) (\dst ->+                code_x `appOL`+                code_y `appOL`+                -- signExtend [W8, W16] register to W64 and then SLL+                -- nil for W32+                signExtend (formatToWidth format_x) W64 reg_x reg_x `appOL`+                signExtend (formatToWidth format_y) W64 reg_y reg_y `snocOL`+                extend reg_x reg_x `snocOL`+                extend reg_y reg_y `snocOL`+                -- 64-bits MUL+                MUL (OpReg W64 tmp1) (OpReg W64 reg_x) (OpReg W64 reg_y) `snocOL`+                -- extract valid result via result's width+                -- slli.w for W32, otherwise ext.w.[b, h]+                extract w tmp2 tmp1 `snocOL`+                CSET NE (OpReg W64 dst) (OpReg W64 tmp1)  (OpReg W64 tmp2)+                                        )++        -- Should it be happened?+        _ ->+          return $ Any (intFormat w) ( \dst ->+            unitOL $ annExpr expr (MOV (OpReg w dst) (OpImm (ImmInt 1))))++-- Sign-extend the value in the given register from width @w@+-- up to width @w'@.+-- TODO: Is there room for optimization?+signExtend :: Width -> Width -> Reg -> Reg -> OrdList Instr+signExtend w w' r r'+  | w > w' = pprPanic "Sign-extend Error: not a sign extension, but a truncation." $ ppr w <> text "->" <+> ppr w'+  | w > W64 || w' > W64  = pprPanic "Sign-extend Error: from/to register width greater than 64-bit." $ ppr w <> text "->" <+> ppr w'+  | w == W64 && w' == W64 && r == r' = nilOL+  | w == W32 && w' == W64 = unitOL $ SLL (OpReg W64 r') (OpReg w r) (OpImm (ImmInt 0))+  -- Sign-extend W8 and W16 to W64.+  | w `elem` [W8, W16] = unitOL $ EXT (OpReg W64 r') (OpReg w r)+  | w == w' = unitOL $ MOV (OpReg w' r') (OpReg w r)+  | otherwise = pprPanic "signExtend: Unexpected width: " $ ppr w  <> text "->" <+> ppr w'++-- | Instructions to truncate the value in the given register from width @w@+-- down to width @w'@.+truncateReg :: Width -> Width -> Reg -> OrdList Instr+truncateReg w w' r+  | w > W64 || w' > W64  = pprPanic "Tructate Error: from/to register width greater than 64-bit." $ ppr w <> text "->" <+> ppr w'+  | w == w' = nilOL+  | w /= w' = toOL+    [+      ann+        (text "truncateReg: " <+> ppr r <+> ppr w <> text "->" <> ppr w')+        (BSTRPICK II64 (OpReg w' r) (OpReg w r) (OpImm (ImmInt shift)) (OpImm (ImmInt 0)))+    ]+  | otherwise = pprPanic "truncateReg: Unexpected width: " $ ppr w  <> text "->" <+> ppr w'+  where+    shift = (min (widthInBits w) (widthInBits w')) - 1++--  The 'Amode' type: Memory addressing modes passed up the tree.+data Amode = Amode AddrMode InstrBlock++-- | Provide the value of a `CmmExpr` with an `Amode`+--  N.B. this function should be used to provide operands to load and store+--  instructions with signed 12bit wide immediates (S & I types). For other+--  immediate sizes and formats (e.g. B type uses multiples of 2) this function+--  would need to be adjusted.+getAmode :: Platform+         -> Width     -- ^ width of loaded value+         -> CmmExpr+         -> NatM Amode++-- LD/ST: Immediate can be represented with 12bits+getAmode platform w (CmmRegOff reg off)+  | w <= W64, fitsInNbits 12 (fromIntegral off)+  = return $ Amode (AddrRegImm reg' off') nilOL+    where reg' = getRegisterReg platform reg+          off' = ImmInt off++-- For Stores we often see something like this:+-- CmmStore (CmmMachOp (MO_Add w) [CmmLoad expr, CmmLit (CmmInt n w')]) (expr2)+-- E.g. a CmmStoreOff really. This can be translated to `str $expr2, [$expr, #n ]+-- for `n` in range.+getAmode _platform _ (CmmMachOp (MO_Add _w) [expr, CmmLit (CmmInt off _w')])+  | fitsInNbits 12 (fromIntegral off)+  = do (reg, _format, code) <- getSomeReg expr+       return $ Amode (AddrRegImm reg (ImmInteger off)) code++getAmode _platform _ (CmmMachOp (MO_Sub _w) [expr, CmmLit (CmmInt off _w')])+  | fitsInNbits 12 (fromIntegral (-off))+  = do (reg, _format, code) <- getSomeReg expr+       return $ Amode (AddrRegImm reg (ImmInteger (-off))) code++-- Generic case+getAmode _platform _ expr+  = do (reg, _format, code) <- getSomeReg expr+       return $ Amode (AddrReg reg) code++-- -----------------------------------------------------------------------------+-- Generating assignments++-- Assignments are really at the heart of the whole code generation+-- business.  Almost all top-level nodes of any real importance are+-- assignments, which correspond to loads, stores, or register+-- transfers.  If we're really lucky, some of the register transfers+-- will go away, because we can use the destination register to+-- complete the code generation for the right hand side.  This only+-- fails when the right hand side is forced into a fixed register+-- (e.g. the result of a call).++assignMem_IntCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock+assignReg_IntCode :: Format -> CmmReg  -> CmmExpr -> NatM InstrBlock++assignMem_FltCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock+assignReg_FltCode :: Format -> CmmReg  -> CmmExpr -> NatM InstrBlock++assignMem_IntCode rep addrE srcE+  = do+    (src_reg, _format, code) <- getSomeReg srcE+    platform <- getPlatform+    let w = formatToWidth rep+    Amode addr addr_code <- getAmode platform w addrE+    return $ COMMENT (text "CmmStore" <+> parens (text (show addrE)) <+> parens (text (show srcE)))+            `consOL` (code+            `appOL`   addr_code+            `snocOL`  ST rep (OpReg w src_reg) (OpAddr addr)+                     )++assignReg_IntCode _ reg src+  = do+    platform <- getPlatform+    let dst = getRegisterReg platform reg+    r <- getRegister src+    return $ case r of+      Any _ code              -> COMMENT (text "CmmAssign" <+> parens (text (show reg)) <+> parens (text (show src))) `consOL` code dst+      Fixed format freg fcode -> COMMENT (text "CmmAssign" <+> parens (text (show reg)) <+> parens (text (show src))) `consOL`+                                               (fcode `snocOL`+                                                 MOV (OpReg (formatToWidth format) dst) (OpReg (formatToWidth format) freg)+                                               )++-- Let's treat Floating point stuff+-- as integer code for now. Opaque.+assignMem_FltCode = assignMem_IntCode+assignReg_FltCode = assignReg_IntCode++-- Jumps+genJump :: CmmExpr{-the branch target-} -> NatM InstrBlock+genJump expr = do+  case expr of+    (CmmLit (CmmLabel lbl)) -> do+      return $ unitOL (annExpr expr (TAIL36 (OpReg W64 tmpReg) (TLabel lbl)))+    (CmmLit (CmmBlock bid)) -> do+      return $ unitOL (annExpr expr (TAIL36 (OpReg W64 tmpReg) (TBlock bid)))+    _ -> do+      (target, _format, code) <- getSomeReg expr+      -- I'd like to do more.+      return $ COMMENT (text "genJump for unknow expr: " <+> (text (show expr))) `consOL`+        (code `appOL`+          unitOL (annExpr expr (J (TReg target)))+        )++-- -----------------------------------------------------------------------------+--  Unconditional branches+genBranch :: BlockId -> NatM InstrBlock+genBranch = return . toOL . mkJumpInstr++-- -----------------------------------------------------------------------------+-- Conditional branches+genCondJump+    :: BlockId+    -> CmmExpr+    -> NatM InstrBlock+genCondJump bid expr = do+    case expr of+      -- Optimized == 0 case.+      CmmMachOp (MO_Eq W64) [x, CmmLit (CmmInt 0 _)] -> do+        (reg_x, _format_x, code_x) <- getSomeReg x+        return $+          code_x `snocOL`+          BEQZ (OpReg W64 reg_x) (TBlock bid)+      CmmMachOp (MO_Eq w) [x, CmmLit (CmmInt 0 _)]+        | w `elem` [W8, W16, W32] -> do+        (reg_x, format_x, code_x) <- getSomeReg x+        return $+          code_x `appOL`+          signExtend (formatToWidth format_x) W64 reg_x reg_x `snocOL`+          BEQZ (OpReg W64 reg_x) (TBlock bid)++      -- Optimized /= 0 case.+      CmmMachOp (MO_Ne W64) [x, CmmLit (CmmInt 0 _)] -> do+        (reg_x, _format_x, code_x) <- getSomeReg x+        return $ code_x `snocOL` (annExpr expr (BNEZ (OpReg W64 reg_x) (TBlock bid)))+      CmmMachOp (MO_Ne w) [x, CmmLit (CmmInt 0 _)]+        | w `elem` [W8, W16, W32] -> do+        (reg_x, format_x, code_x) <- getSomeReg x+        return $+          code_x `appOL`+          signExtend (formatToWidth format_x) W64 reg_x reg_x `snocOL`+          BNEZ (OpReg W64 reg_x) (TBlock bid)++      -- Generic case.+      CmmMachOp mop [x, y] -> do+        let ubcond w cmp = do+              (reg_x, format_x, code_x) <- getSomeReg x+              (reg_y, format_y, code_y) <- getSomeReg y+              return $ case w of+                w | w `elem` [W8, W16, W32] ->+                    code_x `appOL`+                    truncateReg (formatToWidth format_x) W64 reg_x  `appOL`+                    code_y `appOL`+                    truncateReg (formatToWidth format_y) W64 reg_y  `snocOL`+                    BCOND1 cmp (OpReg W64 reg_x) (OpReg W64 reg_y) (TBlock bid)+                _ ->+                    code_x `appOL`+                    code_y `snocOL`+                    BCOND1 cmp (OpReg W64 reg_x) (OpReg W64 reg_y) (TBlock bid)++            sbcond w cmp = do+              (reg_x, format_x, code_x) <- getSomeReg x+              (reg_y, format_y, code_y) <- getSomeReg y+              return $ case w of+                w | w `elem` [W8, W16, W32] ->+                  code_x `appOL`+                  signExtend (formatToWidth format_x) W64 reg_x reg_x `appOL`+                  code_y `appOL`+                  signExtend (formatToWidth format_y) W64 reg_y reg_y `snocOL`+                  BCOND1 cmp (OpReg W64 reg_x) (OpReg W64 reg_y) (TBlock bid)+                _ ->+                  code_x `appOL`+                  code_y `snocOL`+                  BCOND1 cmp (OpReg W64 reg_x) (OpReg W64 reg_y) (TBlock bid)++            fbcond w cmp = do+              (reg_fx, _format_fx, code_fx) <- getFloatReg x+              (reg_fy, _format_fy, code_fy) <- getFloatReg y+              rst <- OpReg W64 <$> getNewRegNat II64+              oneReg <- OpReg W64 <$> getNewRegNat II64+              return $+                code_fx `appOL`+                code_fy `snocOL`+                CSET cmp rst (OpReg w reg_fx) (OpReg w reg_fy) `snocOL`+                MOV oneReg (OpImm (ImmInt 1)) `snocOL`+                BCOND1 EQ rst oneReg (TBlock bid)+++        case mop of+          MO_F_Eq w -> fbcond w EQ+          MO_F_Ne w -> fbcond w NE+          MO_F_Gt w -> fbcond w FGT+          MO_F_Ge w -> fbcond w FGE+          MO_F_Lt w -> fbcond w FLT+          MO_F_Le w -> fbcond w FLE+          MO_Eq w   -> sbcond w EQ+          MO_Ne w   -> sbcond w NE+          MO_S_Gt w -> sbcond w SGT+          MO_S_Ge w -> sbcond w SGE+          MO_S_Lt w -> sbcond w SLT+          MO_S_Le w -> sbcond w SLE+          MO_U_Gt w -> ubcond w UGT+          MO_U_Ge w -> ubcond w UGE+          MO_U_Lt w -> ubcond w ULT+          MO_U_Le w -> ubcond w ULE+          _ -> pprPanic "LA64.genCondJump:case mop: " (text $ show expr)++      _ -> pprPanic "LA64.genCondJump: " (text $ show expr)++-- | Generate conditional branching instructions+-- This is basically an "if with else" statement.+genCondBranch ::+  BlockId ->+  BlockId ->+  CmmExpr ->+  NatM InstrBlock+genCondBranch true false expr = do+  b1 <- genCondJump true expr+  b2 <- genBranch false+  return (b1 `appOL` b2)++-- -----------------------------------------------------------------------------+{-+Generating C calls++Generate a call to a C function:++GARs: 8 general-purpose registers $a0 - $a7, where $a0 and $a1 are also used for+integral values.+FARs: 8 floating-point registers $fa0 - $fa7, where $fa0 and $fa1 are also used+for returning values.++An argument is passed using the stack only when no appropriate argument register+is available.++Subroutines should ensure that the initial values of the general-purpose registers+$s0 - $s9 and floating-point registers $fs0 - $fs7 are preserved across the call.++At the entry of a procedure call, the return address of the call site is stored+in $ra. A branch jump to this address should be the last instruction executed in+the called procedure.++The on-stack part of the structure and scalar arguments are aligned to the greater+of the type alignment and GRLEN bits, except when this alignment is larger than+ the 16-byte stack alignment. In this case, the part of the argument should be+16-byte-aligned.++In a procedure call, GARs / FARs are generally only used for passing non-floating+-point / floating-point argument data, respectively. However, the floating-point+member of a structure or union argument, or a vector/floating-point argument+wider than FRLEN may be passed in a GAR.+-}++genCCall+    :: ForeignTarget      -- function to call+    -> [CmmFormal]        -- where to put the result+    -> [CmmActual]        -- arguments (of mixed type)+    -> NatM InstrBlock++-- TODO: Specialize where we can.+-- Generic impl+genCCall target dest_regs arg_regs = do+  case target of+    -- The target :: ForeignTarget call can either+    -- be a foreign procedure with an address expr+    -- and a calling convention.+    ForeignTarget expr _cconv -> do+      (call_target, call_target_code) <- case expr of+        -- if this is a label, let's just directly to it.+        (CmmLit (CmmLabel lbl)) -> pure (TLabel lbl, nilOL)+        -- if it's not a label, let's compute the expression into a+        -- register and jump to that.+        _ -> do+          (reg, _format, reg_code) <- getSomeReg expr+          pure (TReg reg, reg_code)+      -- compute the code and register logic for all arg_regs.+      -- this will give us the format information to match on.+      arg_regs' <- mapM getSomeReg arg_regs++      -- Now this is stupid.  Our Cmm expressions doesn't carry the proper sizes+      -- so while in Cmm we might get W64 incorrectly for an int, that is W32 in+      -- STG; this thenn breaks packing of stack arguments, if we need to pack+      -- for the pcs, e.g. darwinpcs.  Option one would be to fix the Int type+      -- in Cmm proper. Option two, which we choose here is to use extended Hint+      -- information to contain the size information and use that when packing+      -- arguments, spilled onto the stack.+      let (_res_hints, arg_hints) = foreignTargetHints target+          arg_regs'' = zipWith (\(r, f, c) h -> (r,f,h,c)) arg_regs' arg_hints++      (stackSpaceWords, passRegs, passArgumentsCode) <- passArguments allGpArgRegs allFpArgRegs arg_regs'' 0 [] nilOL++      readResultsCode <- readResults allGpArgRegs allFpArgRegs dest_regs [] nilOL++      let moveStackDown 0 = toOL [ PUSH_STACK_FRAME+                                 , DELTA (-16)+                                 ]+          moveStackDown i | odd i = moveStackDown (i + 1)+          moveStackDown i = toOL [ PUSH_STACK_FRAME+                                 , SUB (OpReg W64 (spMachReg)) (OpReg W64 (spMachReg)) (OpImm (ImmInt (8 * i)))+                                 , DELTA (-8 * i - 16)+                                 ]+          moveStackUp 0 = toOL [ POP_STACK_FRAME+                               , DELTA 0+                               ]+          moveStackUp i | odd i = moveStackUp (i + 1)+          moveStackUp i = toOL [ ADD (OpReg W64 (spMachReg)) (OpReg W64 (spMachReg)) (OpImm (ImmInt (8 * i)))+                               , POP_STACK_FRAME+                               , DELTA 0+                               ]++      let code =+            call_target_code -- compute the label (possibly into a register)+              `appOL` moveStackDown (stackSpaceWords)+              `appOL` passArgumentsCode -- put the arguments into x0, ...+              `snocOL` CALL call_target passRegs -- branch and link (C calls aren't tail calls, but return)+              `appOL` readResultsCode -- parse the results into registers+              `appOL` moveStackUp (stackSpaceWords)+      return code++    PrimTarget MO_F32_Fabs+      | [arg_reg] <- arg_regs, [dest_reg] <- dest_regs ->+        unaryFloatOp W32 (\d x -> unitOL $ FABS d x) arg_reg dest_reg+      | otherwise -> panic "mal-formed MO_F32_Fabs"+    PrimTarget MO_F64_Fabs+      | [arg_reg] <- arg_regs, [dest_reg] <- dest_regs ->+        unaryFloatOp W64 (\d x -> unitOL $ FABS d x) arg_reg dest_reg+      | otherwise -> panic "mal-formed MO_F64_Fabs"++    PrimTarget MO_F32_Sqrt+      | [arg_reg] <- arg_regs, [dest_reg] <- dest_regs ->+        unaryFloatOp W32 (\d x -> unitOL $ FSQRT d x) arg_reg dest_reg+      | otherwise -> panic "mal-formed MO_F32_Sqrt"+    PrimTarget MO_F64_Sqrt+      | [arg_reg] <- arg_regs, [dest_reg] <- dest_regs ->+        unaryFloatOp W64 (\d x -> unitOL $ FSQRT d x) arg_reg dest_reg+      | otherwise -> panic "mal-formed MO_F64_Sqrt"++    PrimTarget (MO_Clz w)+      | w `elem` [W32, W64],+      [arg_reg] <- arg_regs,+      [dest_reg] <- dest_regs -> do+      platform <- getPlatform+      (reg_x, _format_x, code_x) <- getSomeReg arg_reg+      let dst_reg = getRegisterReg platform (CmmLocal dest_reg)+      return ( code_x `snocOL`+               CLZ (OpReg w dst_reg) (OpReg w reg_x)+             )+      | w `elem` [W8, W16],+      [arg_reg] <- arg_regs,+      [dest_reg] <- dest_regs -> do+        platform <- getPlatform+        (reg_x, _format_x, code_x) <- getSomeReg arg_reg+        let dst_reg = getRegisterReg platform (CmmLocal dest_reg)+        return ( code_x `appOL` toOL+                 [+                  MOV (OpReg W64 dst_reg) (OpImm (ImmInt 1)),+                  SLL (OpReg W64 dst_reg) (OpReg W64 dst_reg) (OpImm (ImmInt (31-shift))),+                  SLL (OpReg W64 reg_x) (OpReg W64 reg_x) (OpImm (ImmInt (32-shift))),+                  OR (OpReg W64 dst_reg) (OpReg W64 dst_reg) (OpReg W64 reg_x),+                  CLZ (OpReg W64 dst_reg) (OpReg W32 dst_reg)+                 ]+               )+      | otherwise -> unsupported (MO_Clz w)+      where+        shift = widthToInt w++    PrimTarget (MO_Ctz w)+      | w `elem` [W32, W64],+      [arg_reg] <- arg_regs,+      [dest_reg] <- dest_regs -> do+      platform <- getPlatform+      (reg_x, _format_x, code_x) <- getSomeReg arg_reg+      let dst_reg = getRegisterReg platform (CmmLocal dest_reg)+      return ( code_x `snocOL`+               CTZ (OpReg w dst_reg) (OpReg w reg_x)+             )+      | w `elem` [W8, W16],+      [arg_reg] <- arg_regs,+      [dest_reg] <- dest_regs -> do+      platform <- getPlatform+      (reg_x, _format_x, code_x) <- getSomeReg arg_reg+      let dst_reg = getRegisterReg platform (CmmLocal dest_reg)+      return ( code_x `appOL` toOL+               [+                MOV (OpReg W64 dst_reg) (OpImm (ImmInt 1)),+                SLL (OpReg W64 dst_reg) (OpReg W64 dst_reg) (OpImm (ImmInt shift)),+                BSTRPICK II64 (OpReg W64 reg_x) (OpReg W64 reg_x) (OpImm (ImmInt (shift-1))) (OpImm (ImmInt 0)),+                OR  (OpReg W64 dst_reg) (OpReg W64 dst_reg) (OpReg W64 reg_x),+                CTZ (OpReg W64 dst_reg) (OpReg W64 dst_reg)+               ]+             )+      | otherwise -> unsupported (MO_Ctz w)+      where+        shift = (widthToInt w)++    -- mop :: CallishMachOp (see GHC.Cmm.MachOp)+    PrimTarget mop -> do+      -- We'll need config to construct forien targets+      case mop of+        -- 64 bit float ops+        MO_F64_Pwr   -> mkCCall "pow"++        MO_F64_Sin   -> mkCCall "sin"+        MO_F64_Cos   -> mkCCall "cos"+        MO_F64_Tan   -> mkCCall "tan"++        MO_F64_Sinh  -> mkCCall "sinh"+        MO_F64_Cosh  -> mkCCall "cosh"+        MO_F64_Tanh  -> mkCCall "tanh"++        MO_F64_Asin  -> mkCCall "asin"+        MO_F64_Acos  -> mkCCall "acos"+        MO_F64_Atan  -> mkCCall "atan"++        MO_F64_Asinh -> mkCCall "asinh"+        MO_F64_Acosh -> mkCCall "acosh"+        MO_F64_Atanh -> mkCCall "atanh"++        MO_F64_Log   -> mkCCall "log"+        MO_F64_Log1P -> mkCCall "log1p"+        MO_F64_Exp   -> mkCCall "exp"+        MO_F64_ExpM1 -> mkCCall "expm1"++        -- 32 bit float ops+        MO_F32_Pwr   -> mkCCall "powf"++        MO_F32_Sin   -> mkCCall "sinf"+        MO_F32_Cos   -> mkCCall "cosf"+        MO_F32_Tan   -> mkCCall "tanf"+        MO_F32_Sinh  -> mkCCall "sinhf"+        MO_F32_Cosh  -> mkCCall "coshf"+        MO_F32_Tanh  -> mkCCall "tanhf"+        MO_F32_Asin  -> mkCCall "asinf"+        MO_F32_Acos  -> mkCCall "acosf"+        MO_F32_Atan  -> mkCCall "atanf"+        MO_F32_Asinh -> mkCCall "asinhf"+        MO_F32_Acosh -> mkCCall "acoshf"+        MO_F32_Atanh -> mkCCall "atanhf"+        MO_F32_Log   -> mkCCall "logf"+        MO_F32_Log1P -> mkCCall "log1pf"+        MO_F32_Exp   -> mkCCall "expf"+        MO_F32_ExpM1 -> mkCCall "expm1f"++        -- 64-bit primops+        MO_I64_ToI   -> mkCCall "hs_int64ToInt"+        MO_I64_FromI -> mkCCall "hs_intToInt64"+        MO_W64_ToW   -> mkCCall "hs_word64ToWord"+        MO_W64_FromW -> mkCCall "hs_wordToWord64"+        MO_x64_Neg   -> mkCCall "hs_neg64"+        MO_x64_Add   -> mkCCall "hs_add64"+        MO_x64_Sub   -> mkCCall "hs_sub64"+        MO_x64_Mul   -> mkCCall "hs_mul64"+        MO_I64_Quot  -> mkCCall "hs_quotInt64"+        MO_I64_Rem   -> mkCCall "hs_remInt64"+        MO_W64_Quot  -> mkCCall "hs_quotWord64"+        MO_W64_Rem   -> mkCCall "hs_remWord64"+        MO_x64_And   -> mkCCall "hs_and64"+        MO_x64_Or    -> mkCCall "hs_or64"+        MO_x64_Xor   -> mkCCall "hs_xor64"+        MO_x64_Not   -> mkCCall "hs_not64"+        MO_x64_Shl   -> mkCCall "hs_uncheckedShiftL64"+        MO_I64_Shr   -> mkCCall "hs_uncheckedIShiftRA64"+        MO_W64_Shr   -> mkCCall "hs_uncheckedShiftRL64"+        MO_x64_Eq    -> mkCCall "hs_eq64"+        MO_x64_Ne    -> mkCCall "hs_ne64"+        MO_I64_Ge    -> mkCCall "hs_geInt64"+        MO_I64_Gt    -> mkCCall "hs_gtInt64"+        MO_I64_Le    -> mkCCall "hs_leInt64"+        MO_I64_Lt    -> mkCCall "hs_ltInt64"+        MO_W64_Ge    -> mkCCall "hs_geWord64"+        MO_W64_Gt    -> mkCCall "hs_gtWord64"+        MO_W64_Le    -> mkCCall "hs_leWord64"+        MO_W64_Lt    -> mkCCall "hs_ltWord64"++        -- Conversion+        MO_UF_Conv w        -> mkCCall (word2FloatLabel w)++        -- Optional MachOps+        -- These are enabled/disabled by backend flags: GHC.StgToCmm.Config+        MO_S_Mul2     _w -> unsupported mop+        MO_S_QuotRem  _w -> unsupported mop+        MO_U_QuotRem  _w -> unsupported mop+        MO_U_QuotRem2 _w -> unsupported mop+        MO_Add2       _w -> unsupported mop+        MO_AddWordC   _w -> unsupported mop+        MO_SubWordC   _w -> unsupported mop+        MO_AddIntC    _w -> unsupported mop+        MO_SubIntC    _w -> unsupported mop+        MO_U_Mul2     _w -> unsupported mop++        MO_VS_Quot {} -> unsupported mop+        MO_VS_Rem {}  -> unsupported mop+        MO_VU_Quot {} -> unsupported mop+        MO_VU_Rem {}  -> unsupported mop+        MO_I64X2_Min -> unsupported mop+        MO_I64X2_Max -> unsupported mop+        MO_W64X2_Min -> unsupported mop+        MO_W64X2_Max -> unsupported mop++        -- Memory Ordering+        -- A hint value of 0 is mandatory by default, and it indicates a fully functional synchronization barrier.+        -- Only after all previous load/store access operations are completely executed, the DBAR 0 instruction can be executed;+        -- and only after the execution of DBAR 0 is completed, all subsequent load/store access operations can be executed.++        MO_AcquireFence -> pure (unitOL (DBAR Hint0))+        MO_ReleaseFence -> pure (unitOL (DBAR Hint0))+        MO_SeqCstFence  -> pure (unitOL (DBAR Hint0))++        MO_Touch        -> pure nilOL -- Keep variables live (when using interior pointers)+        -- Prefetch+        MO_Prefetch_Data _n -> pure nilOL -- Prefetch hint.++        -- Memory copy/set/move/cmp, with alignment for optimization++        -- TODO Optimize and use e.g. quad registers to move memory around instead+        -- of offloading this to memcpy. For small memcpys we can utilize+        -- the 128bit quad registers in NEON to move block of bytes around.+        -- Might also make sense of small memsets? Use xzr? What's the function+        -- call overhead?+        MO_Memcpy  _align   -> mkCCall "memcpy"+        MO_Memset  _align   -> mkCCall "memset"+        MO_Memmove _align   -> mkCCall "memmove"+        MO_Memcmp  _align   -> mkCCall "memcmp"++        MO_SuspendThread    -> mkCCall "suspendThread"+        MO_ResumeThread     -> mkCCall "resumeThread"++        MO_PopCnt w         -> mkCCall (popCntLabel w)+        MO_Pdep w           -> mkCCall (pdepLabel w)+        MO_Pext w           -> mkCCall (pextLabel w)+        MO_BSwap w          -> mkCCall (bSwapLabel w)+        MO_BRev w           -> mkCCall (bRevLabel w)++    -- or a possibly side-effecting machine operation+        mo@(MO_AtomicRead w ord)+          | [p_reg] <- arg_regs+          , [dst_reg] <- dest_regs -> do+              (p, _fmt_p, code_p) <- getSomeReg p_reg+              platform <- getPlatform+              let instrs = case ord of+                      MemOrderRelaxed -> unitOL $ ann moDescr (LD (intFormat w) (OpReg w dst) (OpAddr $ AddrReg p))++                      MemOrderAcquire -> toOL [+                                                ann moDescr (LD (intFormat w) (OpReg w dst) (OpAddr $ AddrReg p)),+                                                DBAR Hint0+                                              ]+                      MemOrderSeqCst -> toOL [+                                                ann moDescr (DBAR Hint0),+                                                LD (intFormat w) (OpReg w dst) (OpAddr $ AddrReg p),+                                                DBAR Hint0+                                              ]+                      _ -> panic $ "Unexpected MemOrderRelease on an AtomicRead: " ++ show mo+                  dst = getRegisterReg platform (CmmLocal dst_reg)+                  moDescr = (text . show) mo+                  code = code_p `appOL` instrs+              pure code+          | otherwise -> panic "mal-formed AtomicRead"++        mo@(MO_AtomicWrite w ord)+          | [p_reg, val_reg] <- arg_regs -> do+              (p, _fmt_p, code_p) <- getSomeReg p_reg+              (val, fmt_val, code_val) <- getSomeReg val_reg+              let instrs = case ord of+                      MemOrderRelaxed -> unitOL $ ann moDescr (ST fmt_val (OpReg w val) (OpAddr $ AddrReg p))+                      MemOrderRelease -> toOL [+                                                ann moDescr (DBAR Hint0),+                                                ST fmt_val (OpReg w val) (OpAddr $ AddrReg p)+                                              ]+                      MemOrderSeqCst  -> toOL [+                                                ann moDescr (DBAR Hint0),+                                                ST fmt_val (OpReg w val) (OpAddr $ AddrReg p),+                                                DBAR Hint0+                                              ]+                      _ ->  panic $ "Unexpected MemOrderAcquire on an AtomicWrite" ++ show mo+                  moDescr = (text . show) mo+                  code =+                    code_p `appOL`+                    code_val `appOL`+                    instrs+              pure code+          | otherwise -> panic "mal-formed AtomicWrite"++        MO_AtomicRMW w amop -> mkCCall (atomicRMWLabel w amop)+        MO_Cmpxchg w        -> mkCCall (cmpxchgLabel w)+        MO_Xchg w           -> mkCCall (xchgLabel w)++  where+    unsupported :: Show a => a -> b+    unsupported mop = panic ("outOfLineCmmOp: " ++ show mop+                          ++ " not supported here")++    mkCCall :: FastString -> NatM InstrBlock+    mkCCall name = do+      config <- getConfig+      target <-+        cmmMakeDynamicReference config CallReference+          $ mkForeignLabel name ForeignLabelInThisPackage IsFunction+      let cconv = ForeignConvention CCallConv [NoHint] [NoHint] CmmMayReturn+      genCCall (ForeignTarget target cconv) dest_regs arg_regs++    -- Implementiation of the LoongArch ABI calling convention.+    -- https://github.com/loongson/la-abi-specs/blob/release/lapcs.adoc#passing-arguments+    passArguments :: [Reg] -> [Reg] -> [(Reg, Format, ForeignHint, InstrBlock)] -> Int -> [Reg] -> InstrBlock -> NatM (Int, [Reg], InstrBlock)++    -- 1. Base case: no more arguments to pass (left)+    passArguments _ _ [] stackSpaceWords accumRegs accumCode = return (stackSpaceWords, accumRegs, accumCode)++    -- 2. Still have GP regs, and we want to pass an GP argument.+    passArguments (gpReg : gpRegs) fpRegs ((r, format, _hint, code_r) : args) stackSpaceWords accumRegs accumCode | isIntFormat format = do+      let w = formatToWidth format+          ext+            -- Specifically, LoongArch64's ABI requires that the caller+            -- sign-extend arguments which are smaller than 64-bits.+            | w `elem` [W8, W16, W32]+            = case w of+              W8  -> EXT (OpReg W64 gpReg) (OpReg w r)+              W16 -> EXT (OpReg W64 gpReg) (OpReg w r)+              W32 -> SLL (OpReg W64 gpReg) (OpReg w r) (OpImm (ImmInt 0))+              _ -> panic "Unexpected width(Here w < W64)!"+            | otherwise+            = MOV (OpReg w gpReg) (OpReg w r)+          accumCode' = accumCode `appOL`+                          code_r `snocOL`+                          ann (text "Pass gp argument: " <> ppr r) ext++      passArguments gpRegs fpRegs args stackSpaceWords (gpReg : accumRegs) accumCode'++    -- 3. Still have FP regs, and we want to pass an FP argument.+    passArguments gpRegs (fpReg : fpRegs) ((r, format, _hint, code_r) : args) stackSpaceWords accumRegs accumCode | isFloatFormat format = do+      let w = formatToWidth format+          mov = MOV (OpReg w fpReg) (OpReg w r)+          accumCode' = accumCode `appOL`+                       code_r `snocOL`+                       ann (text "Pass fp argument: " <> ppr r) mov++      passArguments gpRegs fpRegs args stackSpaceWords (fpReg : accumRegs) accumCode'++    -- 4. No mor regs left to pass. Must pass on stack.+    passArguments [] [] ((r, format, _hint, code_r) : args) stackSpaceWords accumRegs accumCode = do+      let w = formatToWidth format+          spOffet = 8 * stackSpaceWords+          str = ST format (OpReg w r) (OpAddr (AddrRegImm spMachReg (ImmInt spOffet)))+          stackCode =+            code_r+              `snocOL` (MOV (OpReg w tmpReg) (OpReg w r))+              `appOL` truncateReg w W64 tmpReg+              `snocOL` ann (text "Pass signed argument (size " <> ppr w <> text ") on the stack: " <> ppr tmpReg) str++      passArguments [] [] args (stackSpaceWords + 1) accumRegs (stackCode `appOL` accumCode)++    -- 5. Still have fpRegs left, but want to pass a GP argument. Must be passed on the stack then.+    passArguments [] fpRegs ((r, format, _hint, code_r) : args) stackSpaceWords accumRegs accumCode | isIntFormat format = do+      let w = formatToWidth format+          spOffet = 8 * stackSpaceWords+          str = ST format (OpReg w r) (OpAddr (AddrRegImm spMachReg (ImmInt spOffet)))+          stackCode =+            code_r+              `snocOL` ann (text "Pass argument (size " <> ppr w <> text ") on the stack: " <> ppr r) str++      passArguments [] fpRegs args (stackSpaceWords + 1) accumRegs (stackCode `appOL` accumCode)++   -- 6. Still have gpRegs left, but want to pass a FP argument. Must be passed in gpReg then.+    passArguments (gpReg : gpRegs) [] ((r, format, _hint, code_r) : args) stackSpaceWords accumRegs accumCode | isFloatFormat format = do+      let w = formatToWidth format+          mov = MOV (OpReg w gpReg) (OpReg w r)+          accumCode' = accumCode `appOL`+                       code_r `snocOL`+                       ann (text "Pass fp argument in gpReg: " <> ppr r) mov++      passArguments gpRegs [] args stackSpaceWords (gpReg : accumRegs) accumCode'+++    passArguments _ _ _ _ _ _ = pprPanic "passArguments" (text "invalid state")++    readResults :: [Reg] -> [Reg] -> [LocalReg] -> [Reg] -> InstrBlock -> NatM InstrBlock+    readResults _ _ [] _ accumCode = return accumCode+    readResults [] _ _ _ _ = do+      platform <- getPlatform+      pprPanic "genCCall, out of gp registers when reading results" (pdoc platform target)+    readResults _ [] _ _ _ = do+      platform <- getPlatform+      pprPanic "genCCall, out of fp registers when reading results" (pdoc platform target)+    readResults (gpReg:gpRegs) (fpReg:fpRegs) (dst:dsts) accumRegs accumCode = do+      -- gp/fp reg -> dst+      platform <- getPlatform+      let rep = cmmRegType (CmmLocal dst)+          format = cmmTypeFormat rep+          w = cmmRegWidth (CmmLocal dst)+          r_dst = getRegisterReg platform (CmmLocal dst)+      if isFloatFormat format+        then readResults (gpReg : gpRegs) fpRegs dsts (fpReg : accumRegs) (accumCode `snocOL` MOV (OpReg w r_dst) (OpReg w fpReg))+        else+          readResults gpRegs (fpReg : fpRegs) dsts (gpReg : accumRegs)+            $ accumCode+            `snocOL` MOV (OpReg w r_dst) (OpReg w gpReg)+            `appOL`+            -- truncate, otherwise an unexpectedly big value might be used in upfollowing calculations+            truncateReg W64 w r_dst++    unaryFloatOp w op arg_reg dest_reg = do+      platform <- getPlatform+      (reg_fx, _format_x, code_fx) <- getFloatReg arg_reg+      let dst = getRegisterReg platform (CmmLocal dest_reg)+      let code = code_fx `appOL` op (OpReg w dst) (OpReg w reg_fx)+      pure code++data BlockInRange = InRange | NotInRange BlockId++genCondFarJump :: (MonadGetUnique m) => Cond -> Operand -> Operand -> BlockId -> m InstrBlock+genCondFarJump cond op1 op2 far_target = do+  return $ toOL [ ann (text "Conditional far jump to: " <> ppr far_target)+                $ BCOND cond op1 op2 (TBlock far_target)+                ]++makeFarBranches ::+  Platform ->+  LabelMap RawCmmStatics ->+  [NatBasicBlock Instr] ->+  UniqDSM [NatBasicBlock Instr]++makeFarBranches {- only used when debugging -} _platform statics basic_blocks = do+  -- All offsets/positions are counted in multiples of 4 bytes (the size of LoongArch64 instructions)+  -- That is an offset of 1 represents a 4-byte/one instruction offset.+  let (func_size, lblMap) = foldl' calc_lbl_positions (0, mapEmpty) basic_blocks+  if func_size < max_cond_jump_dist+    then pure basic_blocks+    else do+      (_, blocks) <- mapAccumLM (replace_blk lblMap) 0 basic_blocks+      pure $ concat blocks+  where+    max_cond_jump_dist = 2 ^ (15 :: Int) - 8 :: Int+    -- Currently all inline info tables fit into 64 bytes.+    max_info_size = 16 :: Int+    long_bc_jump_dist = 2 :: Int++    -- Replace out of range conditional jumps with unconditional jumps.+    replace_blk :: LabelMap Int -> Int -> GenBasicBlock Instr -> UniqDSM (Int, [GenBasicBlock Instr])+    replace_blk !m !pos (BasicBlock lbl instrs) = do+      -- Account for a potential info table before the label.+      let !block_pos = pos + infoTblSize_maybe lbl+      (!pos', instrs') <- mapAccumLM (replace_jump m) block_pos instrs+      let instrs'' = concat instrs'+      -- We might have introduced new labels, so split the instructions into basic blocks again if neccesary.+      let (top, split_blocks, no_data) = foldr mkBlocks ([], [], []) instrs''+      -- There should be no data in the instruction stream at this point+      massert (null no_data)++      let final_blocks = BasicBlock lbl top : split_blocks+      pure (pos', final_blocks)++    replace_jump :: LabelMap Int -> Int -> Instr -> UniqDSM (Int, [Instr])+    replace_jump !m !pos instr = do+      case instr of+        ANN ann instr -> do+          replace_jump m pos instr >>= \case+            (idx, instr' : instrs') -> pure (idx, ANN ann instr' : instrs')+            (idx, []) -> pprPanic "replace_jump" (text "empty return list for " <+> ppr idx)++        BCOND1 cond op1 op2 t ->+          case target_in_range m t pos of+            InRange -> pure (pos + 1, [instr])+            NotInRange far_target -> do+              jmp_code <- genCondFarJump cond op1 op2 far_target+              pure (pos + long_bc_jump_dist, fromOL jmp_code)++        _ -> pure (pos + instr_size instr, [instr])++    target_in_range :: LabelMap Int -> Target -> Int -> BlockInRange+    target_in_range m target src =+      case target of+        (TReg{}) -> InRange+        (TBlock bid) -> block_in_range m src bid+        (TLabel clbl)+          | Just bid <- maybeLocalBlockLabel clbl+          -> block_in_range m src bid+          | otherwise+          -> InRange++    block_in_range :: LabelMap Int -> Int -> BlockId -> BlockInRange+    block_in_range m src_pos dest_lbl =+      case mapLookup dest_lbl m of+        Nothing ->+          pprTrace "not in range" (ppr dest_lbl) $ NotInRange dest_lbl+        Just dest_pos ->+          if abs (dest_pos - src_pos) < max_cond_jump_dist+            then InRange+          else NotInRange dest_lbl++    calc_lbl_positions :: (Int, LabelMap Int) -> GenBasicBlock Instr -> (Int, LabelMap Int)+    calc_lbl_positions (pos, m) (BasicBlock lbl instrs) =+      let !pos' = pos + infoTblSize_maybe lbl+       in foldl' instr_pos (pos', mapInsert lbl pos' m) instrs++    instr_pos :: (Int, LabelMap Int) -> Instr -> (Int, LabelMap Int)+    instr_pos (pos, m) instr = (pos + instr_size instr, m)++    infoTblSize_maybe bid =+      case mapLookup bid statics of+        Nothing -> 0 :: Int+        Just _info_static -> max_info_size++    instr_size :: Instr -> Int+    instr_size i = case i of+      COMMENT {} -> 0+      MULTILINE_COMMENT {} -> 0+      ANN _ instr -> instr_size instr+      LOCATION {} -> 0+      DELTA {} -> 0+      -- At this point there should be no NEWBLOCK in the instruction stream (pos, mapInsert bid pos m)+      NEWBLOCK {} -> panic "mkFarBranched - Unexpected"+      LDATA {} -> panic "mkFarBranched - Unexpected"+      PUSH_STACK_FRAME -> 4+      POP_STACK_FRAME -> 4+      CSET {} -> 2+      LD _ _ (OpImm (ImmIndex _ _)) -> 3+      LD _ _ (OpImm (ImmCLbl _)) -> 2+      SCVTF {} -> 2+      FCVTZS {} -> 4+      BCOND {} -> long_bc_jump_dist+      CALL (TReg _) _ -> 1+      CALL {} -> 2+      CALL36 {} -> 2+      TAIL36 {} -> 2+      _ -> 1
+ GHC/CmmToAsm/LA64/Cond.hs view
@@ -0,0 +1,33 @@+module GHC.CmmToAsm.LA64.Cond where++import GHC.Prelude hiding (EQ)++-- | Condition codes.+-- Used in conditional branches and bit setters. According to the available+-- instruction set, some conditions are encoded as their negated opposites. I.e.+-- these are logical things that don't necessarily map 1:1 to hardware/ISA.+-- TODO: Maybe need to simplify or expand?+data Cond+-- ISA condition+  = EQ  -- beq+  | NE  -- bne+  | LT  -- blt+  | GE  -- bge+  | LTU  -- bltu+  | GEU  -- bgeu+  | EQZ  -- beqz+  | NEZ  -- bnez+-- Extra Logical condition+  | SLT -- LT+  | SLE+  | SGE -- GE+  | SGT+  | ULT -- LTU+  | ULE+  | UGE -- GEU+  | UGT+  | FLT+  | FLE+  | FGE+  | FGT+  deriving (Eq, Show)
+ GHC/CmmToAsm/LA64/Instr.hs view
@@ -0,0 +1,1012 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++module GHC.CmmToAsm.LA64.Instr where++import GHC.Prelude++import GHC.CmmToAsm.LA64.Cond+import GHC.CmmToAsm.LA64.Regs++import GHC.CmmToAsm.Instr (RegUsage(..))+import GHC.CmmToAsm.Format+import GHC.CmmToAsm.Types+import GHC.CmmToAsm.Utils+import GHC.CmmToAsm.Config+import GHC.Platform.Reg++import GHC.Platform.Regs+import GHC.Platform.Reg.Class.Separate+import GHC.Cmm.BlockId+import GHC.Cmm.Dataflow.Label+import GHC.Cmm+import GHC.Cmm.CLabel+import GHC.Utils.Outputable+import GHC.Platform+import GHC.Types.Unique.DSM++import GHC.Utils.Panic+import Data.Maybe+import GHC.Stack+import GHC.Data.FastString (LexicalFastString)++-- | Stack frame header size+-- Each stack frame contains ra and fp -- prologue.+stackFrameHeaderSize :: Int+stackFrameHeaderSize = 2 * spillSlotSize++-- | All registers are 8 byte wide.+spillSlotSize :: Int+spillSlotSize = 8++-- | The number of bytes that the stack pointer should be aligned to.+stackAlign :: Int+stackAlign = 16++-- | The number of spill slots available without allocating more.+maxSpillSlots :: NCGConfig -> Int+maxSpillSlots config+    = (+        (ncgSpillPreallocSize config - stackFrameHeaderSize)+         `div`+         spillSlotSize+      ) - 1++-- | Convert a spill slot number to a *byte* offset.+spillSlotToOffset :: Int -> Int+spillSlotToOffset slot+   = stackFrameHeaderSize + spillSlotSize * slot++instance Outputable RegUsage where+    ppr (RU reads writes) = text "RegUsage(reads:" <+> ppr reads <> comma <+> text "writes:" <+> ppr writes <> char ')'++-- | Get the registers that are being used by this instruction.+-- regUsage doesn't need to do any trickery for jumps and such.+-- Just state precisely the regs read and written by that insn.+-- The consequences of control flow transfers, as far as register+-- allocation goes, are taken care of by the register allocator.+--+-- RegUsage = RU [<read regs>] [<write regs>]+regUsageOfInstr :: Platform -> Instr -> RegUsage+regUsageOfInstr platform instr = case instr of+  -- Pseudo Instructions+  ANN _ i                  -> regUsageOfInstr platform i+  COMMENT{}                -> usage ([], [])+  MULTILINE_COMMENT{}      -> usage ([], [])+  PUSH_STACK_FRAME         -> usage ([], [])+  POP_STACK_FRAME          -> usage ([], [])+  DELTA{}                  -> usage ([], [])+  LOCATION{}               -> usage ([], [])++  -- 1. Arithmetic Instructions ------------------------------------------------+  ADD dst src1 src2        -> usage (regOp src1 ++ regOp src2, regOp dst)+  SUB dst src1 src2        -> usage (regOp src1 ++ regOp src2, regOp dst)+  ALSL dst src1 src2 src3  -> usage (regOp src1 ++ regOp src2 ++ regOp src3, regOp dst)+  ALSLU dst src1 src2 src3 -> usage (regOp src1 ++ regOp src2 ++ regOp src3, regOp dst)+  LU12I dst src1           -> usage (regOp src1, regOp dst)+  LU32I dst src1           -> usage (regOp src1, regOp dst)+  LU52I dst src1 src2      -> usage (regOp src1 ++ regOp src2, regOp dst)+  SSLT dst src1 src2       -> usage (regOp src1 ++ regOp src2, regOp dst)+  SSLTU dst src1 src2      -> usage (regOp src1 ++ regOp src2, regOp dst)+  PCADDI dst src1          -> usage (regOp src1, regOp dst)+  PCADDU12I dst src1       -> usage (regOp src1, regOp dst)+  PCADDU18I dst src1       -> usage (regOp src1, regOp dst)+  PCALAU12I dst src1       -> usage (regOp src1, regOp dst)+  AND dst src1 src2        -> usage (regOp src1 ++ regOp src2, regOp dst)+  OR dst src1 src2         -> usage (regOp src1 ++ regOp src2, regOp dst)+  XOR dst src1 src2        -> usage (regOp src1 ++ regOp src2, regOp dst)+  NOR dst src1 src2        -> usage (regOp src1 ++ regOp src2, regOp dst)+  ANDN dst src1 src2       -> usage (regOp src1 ++ regOp src2, regOp dst)+  ORN dst src1 src2        -> usage (regOp src1 ++ regOp src2, regOp dst)+  MUL dst src1 src2        -> usage (regOp src1 ++ regOp src2, regOp dst)+  MULW dst src1 src2       -> usage (regOp src1 ++ regOp src2, regOp dst)+  MULWU dst src1 src2      -> usage (regOp src1 ++ regOp src2, regOp dst)+  MULH dst src1 src2       -> usage (regOp src1 ++ regOp src2, regOp dst)+  MULHU dst src1 src2      -> usage (regOp src1 ++ regOp src2, regOp dst)+  DIV dst src1 src2        -> usage (regOp src1 ++ regOp src2, regOp dst)+  DIVU dst src1 src2       -> usage (regOp src1 ++ regOp src2, regOp dst)+  MOD dst src1 src2        -> usage (regOp src1 ++ regOp src2, regOp dst)+  MODU dst src1 src2       -> usage (regOp src1 ++ regOp src2, regOp dst)+  -- 2. Bit-shift Instructions ------------------------------------------+  SLL dst src1 src2        -> usage (regOp src1 ++ regOp src2, regOp dst)+  SRL dst src1 src2        -> usage (regOp src1 ++ regOp src2, regOp dst)+  SRA dst src1 src2        -> usage (regOp src1 ++ regOp src2, regOp dst)+  ROTR dst src1 src2       -> usage (regOp src1 ++ regOp src2, regOp dst)+  -- 3. Bit Manipulation Instructions ------------------------------------------+  EXT dst src1             -> usage (regOp src1, regOp dst)+  CLO dst src1             -> usage (regOp src1, regOp dst)+  CLZ dst src1             -> usage (regOp src1, regOp dst)+  CTO dst src1             -> usage (regOp src1, regOp dst)+  CTZ dst src1             -> usage (regOp src1, regOp dst)+  BYTEPICK dst src1 src2 src3 -> usage (regOp src1 ++ regOp src2 ++ regOp src3, regOp dst)+  REVB2H dst src1          -> usage (regOp src1, regOp dst)+  REVB4H dst src1          -> usage (regOp src1, regOp dst)+  REVB2W dst src1          -> usage (regOp src1, regOp dst)+  REVBD  dst src1          -> usage (regOp src1, regOp dst)+  REVH2W dst src1          -> usage (regOp src1, regOp dst)+  REVHD  dst src1          -> usage (regOp src1, regOp dst)+  BITREV4B dst src1        -> usage (regOp src1, regOp dst)+  BITREV8B dst src1        -> usage (regOp src1, regOp dst)+  BITREVW dst src1         -> usage (regOp src1, regOp dst)+  BITREVD dst src1         -> usage (regOp src1, regOp dst)+  BSTRINS _ dst src1 src2 src3  -> usage (regOp src1 ++ regOp src2 ++ regOp src3, regOp dst)+  BSTRPICK _ dst src1 src2 src3 -> usage (regOp src1 ++ regOp src2 ++ regOp src3, regOp dst)+  MASKEQZ dst src1 src2         -> usage (regOp src1 ++ regOp src2, regOp dst)+  MASKNEZ dst src1 src2         -> usage (regOp src1 ++ regOp src2, regOp dst)+  --+  -- Pseudo instructions+  NOP                      -> usage ([], [])+  MOV dst src              -> usage (regOp src, regOp dst)+  NEG dst src              -> usage (regOp src, regOp dst)+  CSET _cond dst src1 src2  -> usage (regOp src1 ++ regOp src2 , regOp dst)+  -- 4. Branch Instructions ----------------------------------------------------+  J t                      -> usage (regTarget t, [])+  J_TBL _ _ t              -> usage ([t], [])+  B t                      -> usage (regTarget t, [])+  BL t ps                  -> usage (regTarget t ++ ps, callerSavedRegisters)+  CALL t ps                -> usage (regTarget t ++ ps, callerSavedRegisters)+  CALL36 t                 -> usage (regTarget t, [])+  TAIL36 r t               -> usage (regTarget t, regOp r)+  -- Here two kinds of BCOND and BCOND1 are implemented, mainly because we want+  -- to distinguish between two kinds of conditional jumps with different jump+  -- ranges, corresponding to 2 and 1 instruction implementations respectively.+  --+  -- BCOND1 is selected by default.+  BCOND1 _ j d t           -> usage (regTarget t ++ regOp j ++ regOp d, [])+  BCOND _ j d t            -> usage (regTarget t ++ regOp j ++ regOp d, [])+  BEQZ j t                 -> usage (regTarget t ++ regOp j, [])+  BNEZ j t                 -> usage (regTarget t ++ regOp j, [])+  -- 5. Common Memory Access Instructions --------------------------------------+  LD _ dst src             -> usage (regOp src, regOp dst)+  LDU _ dst src            -> usage (regOp src, regOp dst)+  ST _ dst src             -> usage (regOp src ++ regOp dst, [])+  LDX _ dst src            -> usage (regOp src, regOp dst)+  LDXU _ dst src           -> usage (regOp src, regOp dst)+  STX _ dst src            -> usage (regOp src ++ regOp dst, [])+  LDPTR _ dst src          -> usage (regOp src, regOp dst)+  STPTR _ dst src          -> usage (regOp src ++ regOp dst, [])+  PRELD _hint src          -> usage (regOp src, [])+  -- 6. Bound Check Memory Access Instructions ---------------------------------+  -- LDCOND dst src1 src2     -> usage (regOp src1 ++ regOp src2, regOp dst)+  -- STCOND dst src1 src2     -> usage (regOp src1 ++ regOp src2, regOp dst)+  -- 7. Atomic Memory Access Instructions --------------------------------------+  -- 8. Barrier Instructions ---------------------------------------------------+  DBAR _hint               -> usage ([], [])+  IBAR _hint               -> usage ([], [])+  -- 11. Floating Point Instructions -------------------------------------------+  FMAX dst src1 src2       -> usage (regOp src1 ++ regOp src2, regOp dst)+  FMIN dst src1 src2       -> usage (regOp src1 ++ regOp src2, regOp dst)+  FMAXA dst src1 src2      -> usage (regOp src1 ++ regOp src2, regOp dst)+  FMINA dst src1 src2      -> usage (regOp src1 ++ regOp src2, regOp dst)+  FNEG dst src1            -> usage (regOp src1, regOp dst)++  FCVT dst src             -> usage (regOp src, regOp dst)+  -- SCVTF dst src            -> usage (regOp src, regOp src ++ regOp dst)+  SCVTF dst src            -> usage (regOp src, regOp dst)+  FCVTZS dst src1 src2     -> usage (regOp src2, regOp src1 ++ regOp dst)+  FABS dst src             -> usage (regOp src, regOp dst)+  FSQRT dst src            -> usage (regOp src, regOp dst)+  FMA _ dst src1 src2 src3 -> usage (regOp src1 ++ regOp src2 ++ regOp src3, regOp dst)++  _ -> panic $ "regUsageOfInstr: " ++ instrCon instr++  where+        -- filtering the usage is necessary, otherwise the register+        -- allocator will try to allocate pre-defined fixed stg+        -- registers as well, as they show up.+        usage :: ([Reg], [Reg]) -> RegUsage+        usage (srcRegs, dstRegs) =+          RU+            (map mkFmt $ filter (interesting platform) srcRegs)+            (map mkFmt $ filter (interesting platform) dstRegs)++        mkFmt r = RegWithFormat r fmt+          where+            fmt = case cls of+              RcInteger -> II64+              RcFloat   -> FF64+              RcVector  -> sorry "The LoongArch64 NCG does not (yet) support vectors; please use -fllvm."+            cls = case r of+              RegVirtual vr -> classOfVirtualReg (platformArch platform) vr+              RegReal rr -> classOfRealReg rr++        regAddr :: AddrMode -> [Reg]+        regAddr (AddrRegReg r1 r2) = [r1, r2]+        regAddr (AddrRegImm r1 _)  = [r1]+        regAddr (AddrReg r1)       = [r1]++        regOp :: Operand -> [Reg]+        regOp (OpReg _ r1) = [r1]+        regOp (OpAddr a)    = regAddr a+        regOp (OpImm _)     = []++        regTarget :: Target -> [Reg]+        regTarget (TBlock _) = []+        regTarget (TLabel _) = []+        regTarget (TReg r1)  = [r1]++        -- Is this register interesting for the register allocator?+        interesting :: Platform -> Reg -> Bool+        interesting _        (RegVirtual _)                 = True+        interesting platform (RegReal (RealRegSingle i))    = freeReg platform i++-- | Caller-saved registers (according to calling convention)+--------------------------------------------------------------------------------------------------------------------------------------------------------------------+-- |  0 |  1 |  2 |  3 |  4 |  5 |  6 |  7 |  8 |  9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 |+--------------------------------------------------------------------------------------------------------------------------------------------------------------------+-- |zero| ra | tp | sp | a0 | a1 | a2 | a3 | a4 | a5 | a6 | a7 | t0 | t1 | t2 | t3 | t4 | t5 | t6 | t7 | t8 | Rv | fp | s0 | s1 | s2 | s3 | s4 | s5 | s6 | s7 | s8 |+--------------------------------------------------------------------------------------------------------------------------------------------------------------------+-- | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 42 | 44 | 45 | 46 | 47 | 48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57 | 58 | 59 | 60 | 61 | 62 | 63 |+--------------------------------------------------------------------------------------------------------------------------------------------------------------------+--f| a0 | a1 | a2 | a3 | a4 | a5 | a6 | a7 | t0 | t1 | t2 | t3 | t4 | t5 | t6 | t7 | t8 | t9 | t10| t11| t12| t13| t14| t15| s0 | s1 | s2 | s3 | s4 | s5 | s6 | s7 |+--------------------------------------------------------------------------------------------------------------------------------------------------------------------+callerSavedRegisters :: [Reg]+callerSavedRegisters =+    -- TODO: Not sure.+    [regSingle 1]                 -- ra+    ++ map regSingle [4 .. 11]    -- a0 - a7+    ++ map regSingle [12 .. 20]   -- t0 - t8+    ++ map regSingle [32 .. 39]   -- fa0 - fa7+    ++ map regSingle [40 .. 55]   -- ft0 - ft15++-- | Apply a given mapping to all the register references in this instruction.+patchRegsOfInstr :: Instr -> (Reg -> Reg) -> Instr+patchRegsOfInstr instr env = case instr of+    -- 0. Meta Instructions+    ANN d i             -> ANN d (patchRegsOfInstr i env)+    COMMENT{}           -> instr+    MULTILINE_COMMENT{} -> instr+    PUSH_STACK_FRAME    -> instr+    POP_STACK_FRAME     -> instr+    DELTA{}             -> instr+    LOCATION{}          -> instr+    -- 1. Arithmetic Instructions ------------------------------------------------+    ADD o1 o2 o3        -> ADD  (patchOp o1)  (patchOp o2)  (patchOp o3)+    SUB o1 o2 o3        -> SUB  (patchOp o1)  (patchOp o2)  (patchOp o3)+    ALSL o1 o2 o3 o4    -> ALSL  (patchOp o1)  (patchOp o2)  (patchOp o3)  (patchOp o4)+    ALSLU o1 o2 o3 o4   -> ALSLU (patchOp o1)  (patchOp o2)  (patchOp o3)  (patchOp o4)+    LU12I o1 o2         -> LU12I  (patchOp o1)  (patchOp o2)+    LU32I o1 o2         -> LU32I  (patchOp o1)  (patchOp o2)+    LU52I o1 o2 o3      -> LU52I  (patchOp o1)  (patchOp o2)  (patchOp o3)+    SSLT o1 o2 o3       -> SSLT  (patchOp o1)  (patchOp o2)  (patchOp o3)+    SSLTU o1 o2 o3      -> SSLTU  (patchOp o1)  (patchOp o2)  (patchOp o3)+    PCADDI o1 o2        -> PCADDI  (patchOp o1)  (patchOp o2)+    PCADDU12I o1 o2     -> PCADDU12I  (patchOp o1)  (patchOp o2)+    PCADDU18I o1 o2     -> PCADDU18I  (patchOp o1)  (patchOp o2)+    PCALAU12I o1 o2     -> PCALAU12I  (patchOp o1)  (patchOp o2)+    AND o1 o2 o3        -> AND  (patchOp o1)  (patchOp o2)  (patchOp o3)+    OR o1 o2 o3         -> OR  (patchOp o1)  (patchOp o2)  (patchOp o3)+    XOR o1 o2 o3        -> XOR  (patchOp o1)  (patchOp o2)  (patchOp o3)+    NOR o1 o2 o3        -> NOR  (patchOp o1)  (patchOp o2)  (patchOp o3)+    ANDN o1 o2 o3       -> ANDN  (patchOp o1)  (patchOp o2)  (patchOp o3)+    ORN o1 o2 o3        -> ORN  (patchOp o1)  (patchOp o2)  (patchOp o3)+    MUL o1 o2 o3        -> MUL  (patchOp o1)  (patchOp o2)  (patchOp o3)+    MULW o1 o2 o3       -> MULW  (patchOp o1)  (patchOp o2)  (patchOp o3)+    MULWU o1 o2 o3      -> MULWU (patchOp o1)  (patchOp o2)  (patchOp o3)+    MULH o1 o2 o3       -> MULH  (patchOp o1)  (patchOp o2)  (patchOp o3)+    MULHU o1 o2 o3      -> MULHU  (patchOp o1)  (patchOp o2)  (patchOp o3)+    DIV o1 o2 o3        -> DIV  (patchOp o1)  (patchOp o2)  (patchOp o3)+    MOD o1 o2 o3        -> MOD  (patchOp o1)  (patchOp o2)  (patchOp o3)+    DIVU o1 o2 o3       -> DIVU  (patchOp o1)  (patchOp o2)  (patchOp o3)+    MODU o1 o2 o3       -> MODU  (patchOp o1)  (patchOp o2)  (patchOp o3)+    -- 2. Bit-shift Instructions ------------------------------------------+    SLL o1 o2 o3        -> SLL  (patchOp o1)  (patchOp o2)  (patchOp o3)+    SRL o1 o2 o3        -> SRL  (patchOp o1)  (patchOp o2)  (patchOp o3)+    SRA o1 o2 o3        -> SRA  (patchOp o1)  (patchOp o2)  (patchOp o3)+    ROTR o1 o2 o3       -> ROTR  (patchOp o1)  (patchOp o2)  (patchOp o3)+    -- 3. Bit Manipulation Instructions ------------------------------------------+    EXT o1 o2             -> EXT  (patchOp o1)  (patchOp o2)+    CLO o1 o2             -> CLO  (patchOp o1)  (patchOp o2)+    CLZ o1 o2             -> CLZ  (patchOp o1)  (patchOp o2)+    CTO o1 o2             -> CTO  (patchOp o1)  (patchOp o2)+    CTZ o1 o2             -> CTZ  (patchOp o1)  (patchOp o2)+    BYTEPICK o1 o2 o3 o4  -> BYTEPICK  (patchOp o1)  (patchOp o2) (patchOp o3) (patchOp o4)+    REVB2H o1 o2          -> REVB2H  (patchOp o1)  (patchOp o2)+    REVB4H o1 o2          -> REVB4H  (patchOp o1)  (patchOp o2)+    REVB2W o1 o2          -> REVB2W  (patchOp o1)  (patchOp o2)+    REVBD  o1 o2          -> REVBD  (patchOp o1)  (patchOp o2)+    REVH2W o1 o2          -> REVH2W  (patchOp o1)  (patchOp o2)+    REVHD  o1 o2          -> REVHD  (patchOp o1)  (patchOp o2)+    BITREV4B o1 o2         -> BITREV4B  (patchOp o1)  (patchOp o2)+    BITREV8B o1 o2         -> BITREV8B  (patchOp o1)  (patchOp o2)+    BITREVW o1 o2          -> BITREVW  (patchOp o1)  (patchOp o2)+    BITREVD o1 o2          -> BITREVD  (patchOp o1)  (patchOp o2)+    BSTRINS f o1 o2 o3 o4  -> BSTRINS f (patchOp o1)  (patchOp o2)  (patchOp o3)  (patchOp o4)+    BSTRPICK f o1 o2 o3 o4 -> BSTRPICK f (patchOp o1)  (patchOp o2)  (patchOp o3)  (patchOp o4)+    MASKEQZ o1 o2 o3       -> MASKEQZ  (patchOp o1)  (patchOp o2)  (patchOp o3)+    MASKNEZ o1 o2 o3       -> MASKNEZ  (patchOp o1)  (patchOp o2)  (patchOp o3)+    --+    -- Pseudo instrcutions+    NOP                 -> NOP+    MOV o1 o2           -> MOV  (patchOp o1)  (patchOp o2)+    NEG o1 o2           -> NEG  (patchOp o1)  (patchOp o2)+    CSET cond o1 o2 o3  -> CSET cond (patchOp o1) (patchOp o2) (patchOp o3)+    -- 4. Branch Instructions ----------------------------------------------------+    -- TODO:+    J t            -> J (patchTarget t)+    J_TBL ids mbLbl t  -> J_TBL ids mbLbl (env t)+    B t            -> B (patchTarget t)+    BL t ps        -> BL (patchTarget t) ps+    CALL t ps      -> CALL (patchTarget t) ps+    CALL36 t       -> CALL36 (patchTarget t)+    TAIL36 r t     -> TAIL36 (patchOp r) (patchTarget t)+    BCOND1 c j d t -> BCOND1 c (patchOp j) (patchOp d) (patchTarget t)+    BCOND c j d t  -> BCOND c (patchOp j) (patchOp d) (patchTarget t)+    BEQZ j t       -> BEQZ (patchOp j) (patchTarget t)+    BNEZ j t       -> BNEZ (patchOp j) (patchTarget t)+    -- 5. Common Memory Access Instructions --------------------------------------+    -- TODO:+    LD f o1 o2         -> LD f (patchOp o1)  (patchOp o2)+    LDU f o1 o2        -> LDU f (patchOp o1)  (patchOp o2)+    ST f o1 o2         -> ST f (patchOp o1)  (patchOp o2)+    LDX f o1 o2        -> LDX f (patchOp o1)  (patchOp o2)+    LDXU f o1 o2       -> LDXU f (patchOp o1)  (patchOp o2)+    STX f o1 o2        -> STX f (patchOp o1)  (patchOp o2)+    LDPTR f o1 o2      -> LDPTR f (patchOp o1)  (patchOp o2)+    STPTR f o1 o2      -> STPTR f (patchOp o1)  (patchOp o2)+    PRELD o1 o2         -> PRELD (patchOp o1) (patchOp o2)+    -- 6. Bound Check Memory Access Instructions ---------------------------------+    -- LDCOND o1 o2 o3       -> LDCOND  (patchOp o1)  (patchOp o2)  (patchOp o3)+    -- STCOND o1 o2 o3       -> STCOND  (patchOp o1)  (patchOp o2)  (patchOp o3)+    -- 7. Atomic Memory Access Instructions --------------------------------------+    -- 8. Barrier Instructions ---------------------------------------------------+    -- TODO: need fix+    DBAR o1             -> DBAR o1+    IBAR o1             -> IBAR o1+    -- 11. Floating Point Instructions -------------------------------------------+    FCVT o1 o2          -> FCVT  (patchOp o1)  (patchOp o2)+    SCVTF o1 o2         -> SCVTF  (patchOp o1)  (patchOp o2)+    FCVTZS o1 o2 o3     -> FCVTZS  (patchOp o1)  (patchOp o2) (patchOp o3)+    FMIN o1 o2 o3       -> FMIN  (patchOp o1)  (patchOp o2)  (patchOp o3)+    FMAX o1 o2 o3       -> FMAX  (patchOp o1)  (patchOp o2)  (patchOp o3)+    FMINA o1 o2 o3      -> FMINA  (patchOp o1)  (patchOp o2)  (patchOp o3)+    FMAXA o1 o2 o3      -> FMAXA  (patchOp o1)  (patchOp o2)  (patchOp o3)+    FNEG o1 o2          -> FNEG  (patchOp o1)  (patchOp o2)+    FABS o1 o2          -> FABS  (patchOp o1)  (patchOp o2)+    FSQRT o1 o2         -> FSQRT  (patchOp o1)  (patchOp o2)+    FMA s o1 o2 o3 o4   -> FMA s (patchOp o1)  (patchOp o2)  (patchOp o3)  (patchOp o4)++    _                   -> panic $ "patchRegsOfInstr: " ++ instrCon instr+    where+        -- TODO:+        patchOp :: Operand -> Operand+        patchOp (OpReg w r) = OpReg w (env r)+        patchOp (OpAddr a) = OpAddr (patchAddr a)+        patchOp opImm = opImm++        patchTarget :: Target -> Target+        patchTarget (TReg r) = TReg (env r)+        patchTarget t = t++        patchAddr :: AddrMode -> AddrMode+        patchAddr (AddrRegReg r1 r2)  = AddrRegReg (env r1) (env r2)+        patchAddr (AddrRegImm r1 imm) = AddrRegImm (env r1) imm+        patchAddr (AddrReg r) = AddrReg (env r)++--------------------------------------------------------------------------------++-- | Checks whether this instruction is a jump/branch instruction.+-- One that can change the flow of control in a way that the+-- register allocator needs to worry about.+isJumpishInstr :: Instr -> Bool+isJumpishInstr instr = case instr of+  ANN _ i -> isJumpishInstr i+  J {} -> True+  J_TBL {} -> True+  B {} -> True+  BL {} -> True+  CALL {} -> True+  CALL36 {} -> True+  TAIL36 {} -> True+  BCOND1 {} -> True+  BCOND {} -> True+  BEQZ {} -> True+  BNEZ {} -> True+  _ -> False++-- | Get the `BlockId`s of the jump destinations (if any)+jumpDestsOfInstr :: Instr -> [BlockId]+jumpDestsOfInstr (ANN _ i) = jumpDestsOfInstr i+jumpDestsOfInstr (J t) = [id | TBlock id <- [t]]+jumpDestsOfInstr (J_TBL ids _mbLbl _r) = catMaybes ids+jumpDestsOfInstr (B t) = [id | TBlock id <- [t]]+jumpDestsOfInstr (BL t _) = [id | TBlock id <- [t]]+jumpDestsOfInstr (CALL t _) = [id | TBlock id <- [t]]+jumpDestsOfInstr (CALL36 t) = [id | TBlock id <- [t]]+jumpDestsOfInstr (TAIL36 _ t) = [id | TBlock id <- [t]]+jumpDestsOfInstr (BCOND1 _ _ _ t) = [id | TBlock id <- [t]]+jumpDestsOfInstr (BCOND _ _ _ t) = [id | TBlock id <- [t]]+jumpDestsOfInstr (BEQZ _ t) = [id | TBlock id <- [t]]+jumpDestsOfInstr (BNEZ _ t) = [id | TBlock id <- [t]]+jumpDestsOfInstr _ = []++-- | Change the destination of this (potential) jump instruction.+-- Used in the linear allocator when adding fixup blocks for join+-- points.+patchJumpInstr :: Instr -> (BlockId -> BlockId) -> Instr+patchJumpInstr instr patchF =+  case instr of+    ANN d i -> ANN d (patchJumpInstr i patchF)+    J (TBlock bid) -> J (TBlock (patchF bid))+    J_TBL ids mbLbl r -> J_TBL (map (fmap patchF) ids) mbLbl r+    B (TBlock bid) -> B (TBlock (patchF bid))+    BL (TBlock bid) ps -> BL (TBlock (patchF bid)) ps+    CALL (TBlock bid) ps -> CALL (TBlock (patchF bid)) ps+    CALL36 (TBlock bid) -> CALL36 (TBlock (patchF bid))+    TAIL36 r (TBlock bid) -> TAIL36 r (TBlock (patchF bid))+    BCOND1 c o1 o2 (TBlock bid) -> BCOND1 c o1 o2 (TBlock (patchF bid))+    BCOND c o1 o2 (TBlock bid) -> BCOND c o1 o2 (TBlock (patchF bid))+    BEQZ j (TBlock bid) -> BEQZ j (TBlock (patchF bid))+    BNEZ j (TBlock bid) -> BNEZ j (TBlock (patchF bid))+    _ -> panic $ "patchJumpInstr: " ++ instrCon instr++-- -----------------------------------------------------------------------------+-- | Make a spill instruction, spill a register into spill slot.+mkSpillInstr+   :: HasCallStack+   => NCGConfig+   -> RegWithFormat -- register to spill+   -> Int       -- current stack delta+   -> Int       -- spill slot to use+   -> [Instr]++mkSpillInstr _config (RegWithFormat reg _fmt) delta slot =+  case off - delta of+    imm | fitsInNbits 12 imm -> [mkStrSpImm imm]+    imm ->+      [ movImmToIp imm,+        addSpToIp,+        mkStrIp+      ]+  where+    fmt = case reg of+      RegReal (RealRegSingle n) | n < 32 -> II64+      _ -> FF64+    mkStrSpImm imm = ANN (text "Spill@" <> int (off - delta)) $ ST fmt (OpReg W64 reg) (OpAddr (AddrRegImm spMachReg (ImmInt imm)))+    movImmToIp imm = ANN (text "Spill: TMP <- " <> int imm) $ MOV tmp (OpImm (ImmInt imm))+    addSpToIp = ANN (text "Spill: TMP <- SP + TMP ") $ ADD tmp tmp sp+    mkStrIp = ANN (text "Spill@" <> int (off - delta)) $ ST fmt (OpReg W64 reg) (OpAddr (AddrReg tmpReg))+    off = spillSlotToOffset slot++-- | Make a reload instruction, reload from spill slot to a register.+mkLoadInstr+   :: NCGConfig+   -> RegWithFormat+   -> Int       -- current stack delta+   -> Int       -- spill slot to use+   -> [Instr]++mkLoadInstr _config (RegWithFormat reg _fmt) delta slot =+  case off - delta of+    imm | fitsInNbits 12 imm -> [mkLdrSpImm imm]+    imm ->+      [ movImmToIp imm,+        addSpToIp,+        mkLdrIp+      ]+  where+    fmt = case reg of+      RegReal (RealRegSingle n) | n < 32 -> II64+      _ -> FF64+    mkLdrSpImm imm = ANN (text "Reload@" <> int (off - delta)) $ LD fmt (OpReg W64 reg) (OpAddr (AddrRegImm spMachReg (ImmInt imm)))+    movImmToIp imm = ANN (text "Reload: TMP <- " <> int imm) $ MOV tmp (OpImm (ImmInt imm))+    addSpToIp = ANN (text "Reload: TMP <- SP + TMP ") $ ADD tmp tmp sp+    mkLdrIp = ANN (text "Reload@" <> int (off - delta)) $ LD fmt (OpReg W64 reg) (OpAddr (AddrReg tmpReg))+    off = spillSlotToOffset slot++-- | See if this instruction is telling us the current C stack delta+takeDeltaInstr :: Instr -> Maybe Int+takeDeltaInstr (ANN _ i) = takeDeltaInstr i+takeDeltaInstr (DELTA i) = Just i+takeDeltaInstr _         = Nothing++-- | Not real instructions.  Just meta data+isMetaInstr :: Instr -> Bool+isMetaInstr instr =+  case instr of+    ANN _ i -> isMetaInstr i+    COMMENT {} -> True+    MULTILINE_COMMENT {} -> True+    LOCATION {} -> True+    NEWBLOCK {} -> True+    DELTA {} -> True+    LDATA {} -> True+    PUSH_STACK_FRAME -> True+    POP_STACK_FRAME -> True+    _ -> False++canFallthroughTo :: Instr -> BlockId -> Bool+canFallthroughTo insn bid =+  case insn of+    J (TBlock target) -> bid == target+    J_TBL targets _ _ -> all isTargetBid targets+    B (TBlock target) -> bid == target+    TAIL36 _ (TBlock target) -> bid == target+    BCOND1 _ _ _ (TBlock target) -> bid == target+    BCOND _ _ _ (TBlock target) -> bid == target+    _ -> False+  where+    isTargetBid target = case target of+      Nothing -> True+      Just target -> target == bid++-- | Copy the value in a register to another one.+-- Must work for all register classes.+mkRegRegMoveInstr :: Reg -> Reg -> Instr+mkRegRegMoveInstr src dst = ANN desc instr+  where+    desc = text "Reg->Reg Move: " <> ppr src <> text " -> " <> ppr dst+    instr = MOV (OpReg W64 dst) (OpReg W64 src)++-- | Take the source and destination from this (potential) reg -> reg move instruction+-- We have to be a bit careful here: A `MOV` can also mean an implicit+-- conversion. This case is filtered out.+takeRegRegMoveInstr :: Instr -> Maybe (Reg, Reg)+takeRegRegMoveInstr (MOV (OpReg width dst) (OpReg width' src))+  | width == width' && (isFloatReg dst == isFloatReg src) = pure (src, dst)+takeRegRegMoveInstr _ = Nothing++-- | Make an unconditional jump instruction.+mkJumpInstr :: BlockId -> [Instr]+mkJumpInstr id = [TAIL36 (OpReg W64 tmpReg) (TBlock (id))]++-- | Decrement @sp@ to allocate stack space.+mkStackAllocInstr :: Platform -> Int -> [Instr]+mkStackAllocInstr _platform n+  | n == 0 = []+  | n > 0 && fitsInNbits 12 (fromIntegral n) =+      [ ANN (text "Alloc stack") $ SUB sp sp (OpImm (ImmInt n)) ]+  | n > 0 =+     [+         ANN (text "Alloc more stack") (MOV tmp (OpImm (ImmInt n))),+         SUB sp sp tmp+     ]+mkStackAllocInstr _platform n = pprPanic "mkStackAllocInstr" (int n)++-- | Increment SP to deallocate stack space.+mkStackDeallocInstr :: Platform -> Int -> [Instr]+mkStackDeallocInstr _platform  n+  | n == 0 = []+  | n > 0 && fitsInNbits 12 (fromIntegral n) =+      [ ANN (text "Dealloc stack") $ ADD sp sp (OpImm (ImmInt n)) ]+  | n > 0 =+     [+         ANN (text "Dealloc more stack") (MOV tmp (OpImm (ImmInt n))),+         ADD sp sp tmp+     ]+mkStackDeallocInstr _platform n = pprPanic "mkStackDeallocInstr" (int n)++allocMoreStack+  :: Platform+  -> Int+  -> NatCmmDecl statics GHC.CmmToAsm.LA64.Instr.Instr+  -> UniqDSM (NatCmmDecl statics GHC.CmmToAsm.LA64.Instr.Instr, [(BlockId,BlockId)])++allocMoreStack _ _ top@(CmmData _ _) = return (top, [])+allocMoreStack platform slots proc@(CmmProc info lbl live (ListGraph code)) = do+  let entries = entryBlocks proc++  retargetList <- mapM (\e -> (e,) <$> newBlockId) entries++  let+    delta = ((x + stackAlign - 1) `quot` stackAlign) * stackAlign -- round up+      where x = slots * spillSlotSize -- sp delta++    alloc   = mkStackAllocInstr   platform delta+    dealloc = mkStackDeallocInstr platform delta++    new_blockmap :: LabelMap BlockId+    new_blockmap = mapFromList retargetList++    insert_stack_insn (BasicBlock id insns)+      | Just new_blockid <- mapLookup id new_blockmap =+        [ BasicBlock id $ alloc ++ [ B (TBlock new_blockid) ],+          BasicBlock new_blockid block' ]+      | otherwise =+        [ BasicBlock id block' ]+      where+        block' = foldr insert_dealloc [] insns++    insert_dealloc insn r = case insn of+      J {} -> dealloc ++ (insn : r)+      ANN _ e -> insert_dealloc e r+      _other | jumpDestsOfInstr insn /= [] ->+        patchJumpInstr insn retarget : r+      _other -> insn : r++      where retarget b = fromMaybe b (mapLookup b new_blockmap)++    new_code = concatMap insert_stack_insn code+  return (CmmProc info lbl live (ListGraph new_code), retargetList)++-- -----------------------------------------------------------------------------+-- Machine's assembly language++-- We have a few common "instructions" (nearly all the pseudo-ops) but+-- mostly all of 'Instr' is machine-specific.++data Instr+    -- comment pseudo-op+    = COMMENT SDoc+    | MULTILINE_COMMENT SDoc++    -- Annotated instruction. Should print <instr> # <doc>+    | ANN SDoc Instr++    -- location pseudo-op (file, line, col, name)+    | LOCATION Int Int Int LexicalFastString++    -- start a new basic block.  Useful during codegen, removed later.+    -- Preceding instruction should be a jump, as per the invariants+    -- for a BasicBlock (see Cmm).+    | NEWBLOCK BlockId++    -- specify current stack offset for benefit of subsequent passes.+    -- This carries a BlockId so it can be used in unwinding information.+    | DELTA   Int++    -- | Static data spat out during code generation.+    | LDATA Section RawCmmStatics++    | PUSH_STACK_FRAME+    | POP_STACK_FRAME+    -- Basic Integer Instructions ------------------------------------------------+    -- 1. Arithmetic Instructions ------------------------------------------------+    | ADD Operand Operand Operand+    | SUB Operand Operand Operand+    | ALSL Operand Operand Operand Operand+    | ALSLU Operand Operand Operand Operand+    | LU12I Operand Operand+    | LU32I Operand Operand+    | LU52I Operand Operand Operand+    | SSLT Operand Operand Operand+    | SSLTU Operand Operand Operand+    | PCADDI Operand Operand+    | PCADDU12I Operand Operand+    | PCADDU18I Operand Operand+    | PCALAU12I Operand Operand+    | AND Operand Operand Operand+    | OR Operand Operand Operand+    | XOR Operand Operand Operand+    | NOR Operand Operand Operand+    | ANDN Operand Operand Operand+    | ORN Operand Operand Operand+    | MUL Operand Operand Operand+    | MULW Operand Operand Operand+    | MULWU Operand Operand Operand+    | MULH Operand Operand Operand+    | MULHU Operand Operand Operand+    | DIV Operand Operand Operand+    | DIVU Operand Operand Operand+    | MOD Operand Operand Operand+    | MODU Operand Operand Operand+    -- 2. Bit-shift Instuctions --------------------------------------------------+    | SLL Operand Operand Operand+    | SRL Operand Operand Operand+    | SRA Operand Operand Operand+    | ROTR Operand Operand Operand+    -- 3. Bit-manupulation Instructions ------------------------------------------+    | EXT Operand Operand+    | CLO Operand Operand+    | CTO Operand Operand+    | CLZ Operand Operand+    | CTZ Operand Operand+    | BYTEPICK Operand Operand Operand Operand+    | REVB2H Operand Operand+    | REVB4H Operand Operand+    | REVB2W Operand Operand+    | REVBD Operand Operand+    | REVH2W Operand Operand+    | REVHD Operand Operand+    | BITREV4B Operand Operand+    | BITREV8B Operand Operand+    | BITREVW Operand Operand+    | BITREVD Operand Operand+    | BSTRINS Format Operand Operand Operand Operand+    | BSTRPICK Format Operand Operand Operand Operand+    | MASKEQZ Operand Operand Operand+    | MASKNEZ Operand Operand Operand+    -- Pseudo instructions+    | NOP+    | MOV Operand Operand+    | NEG Operand Operand+    | CSET Cond Operand Operand Operand+    -- 4. Branch Instructions ----------------------------------------------------+    | J Target+    | J_TBL [Maybe BlockId] (Maybe CLabel) Reg+    | B Target+    | BL Target [Reg]+    | CALL Target [Reg]+    | CALL36 Target+    | TAIL36 Operand Target+    | BCOND1 Cond Operand Operand Target+    | BCOND Cond Operand Operand Target+    | BEQZ Operand Target+    | BNEZ Operand Target+    -- 5. Common Memory Access Instructions --------------------------------------+    | LD Format Operand Operand+    | LDU Format Operand Operand+    | ST Format Operand Operand+    | LDX Format Operand Operand+    | LDXU Format Operand Operand+    | STX Format Operand Operand+    | LDPTR Format Operand Operand+    | STPTR Format Operand Operand+    | PRELD Operand Operand+    -- 6. Bound Check Memory Access Instructions ---------------------------------+    -- 7. Atomic Memory Access Instructions --------------------------------------+    -- 8. Barrier Instructions ---------------------------------------------------+    | DBAR BarrierType+    | IBAR BarrierType+    -- Basic Floating Point Instructions -----------------------------------------+    | FCVT    Operand Operand+    | SCVTF   Operand Operand+    | FCVTZS  Operand Operand Operand+    | FMAX Operand Operand Operand+    | FMIN Operand Operand Operand+    | FMAXA Operand Operand Operand+    | FMINA Operand Operand Operand+    | FNEG Operand Operand+    | FABS Operand Operand+    | FSQRT Operand Operand+    -- Floating-point fused multiply-add instructions+    --  fmadd : d =   r1 * r2 + r3+    --  fnmsub: d =   r1 * r2 - r3+    --  fmsub : d = - r1 * r2 + r3+    --  fnmadd: d = - r1 * r2 - r3+    | FMA FMASign Operand Operand Operand Operand++-- TODO: Not complete.+data BarrierType = Hint0++instrCon :: Instr -> String+instrCon i =+    case i of+      COMMENT{} -> "COMMENT"+      MULTILINE_COMMENT{} -> "COMMENT"+      ANN{} -> "ANN"+      LOCATION{} -> "LOCATION"+      NEWBLOCK{} -> "NEWBLOCK"+      DELTA{} -> "DELTA"+      LDATA {} -> "LDATA"+      PUSH_STACK_FRAME{} -> "PUSH_STACK_FRAME"+      POP_STACK_FRAME{} -> "POP_STACK_FRAME"++      ADD{} -> "ADD"+      SUB{} -> "SUB"+      ALSL{} -> "ALSL"+      ALSLU{} -> "ALSLU"+      LU12I{} -> "LU12I"+      LU32I{} -> "LU32I"+      LU52I{} -> "LU52I"+      SSLT{} -> "SSLT"+      SSLTU{} -> "SSLTU"+      PCADDI{} -> "PCADDI"+      PCADDU12I{} -> "PCADDU12I"+      PCADDU18I{} -> "PCADDU18I"+      PCALAU12I{} -> "PCALAU12I"+      AND{} -> "AND"+      OR{} -> "OR"+      XOR{} -> "XOR"+      NOR{} -> "NOR"+      ANDN{} -> "ANDN"+      ORN{} -> "ORN"+      MUL{} -> "MUL"+      MULW{} -> "MULW"+      MULWU{} -> "MULWU"+      MULH{} -> "MULH"+      MULHU{} -> "MULHU"+      DIV{} -> "DIV"+      MOD{} -> "MOD"+      DIVU{} -> "DIVU"+      MODU{} -> "MODU"+      SLL{} -> "SLL"+      SRL{} -> "SRL"+      SRA{} -> "SRA"+      ROTR{} -> "ROTR"+      EXT{} -> "EXT"+      CLO{} -> "CLO"+      CLZ{} -> "CLZ"+      CTO{} -> "CTO"+      CTZ{} -> "CTZ"+      BYTEPICK{} -> "BYTEPICK"+      REVB2H{} -> "REVB2H"+      REVB4H{} -> "REVB4H"+      REVB2W{} -> "REVB2W"+      REVBD{} -> "REVBD"+      REVH2W{} -> "REVH2W"+      REVHD{} -> "REVHD"+      BITREV4B{} -> "BITREV4B"+      BITREV8B{} -> "BITREV8B"+      BITREVW{} -> "BITREVW"+      BITREVD{} -> "BITREVD"+      BSTRINS{} -> "BSTRINS"+      BSTRPICK{} -> "BSTRPICK"+      MASKEQZ{} -> "MASKEQZ"+      MASKNEZ{} -> "MASKNEZ"+      NOP{} -> "NOP"+      MOV{} -> "MOV"+      NEG{} -> "NEG"+      CSET{} -> "CSET"+      J{} -> "J"+      J_TBL{} -> "J_TBL"+      B{} -> "B"+      BL{} -> "BL"+      CALL{} -> "CALL"+      CALL36{} -> "CALL36"+      TAIL36{} -> "TAIL36"+      BCOND1{} -> "BCOND1"+      BCOND{} -> "BCOND"+      BEQZ{} -> "BEQZ"+      BNEZ{} -> "BNEZ"+      LD{} -> "LD"+      LDU{} -> "LDU"+      ST{} -> "ST"+      LDX{} -> "LDX"+      LDXU{} -> "LDXU"+      STX{} -> "STX"+      LDPTR{} -> "LDPTR"+      STPTR{} -> "STPTR"+      PRELD{} -> "PRELD"+      DBAR{} -> "DBAR"+      IBAR{} -> "IBAR"+      FCVT{} -> "FCVT"+      SCVTF{} -> "SCVTF"+      FCVTZS{} -> "FCVTZS"+      FMAX{} -> "FMAX"+      FMIN{} -> "FMIN"+      FMAXA{} -> "FMAXA"+      FMINA{} -> "FMINA"+      FNEG{} -> "FNEG"+      FABS{} -> "FABS"+      FSQRT{} -> "FSQRT"+      FMA variant _ _ _ _ ->+        case variant of+          FMAdd  -> "FMADD"+          FMSub  -> "FMSUB"+          FNMAdd -> "FNMADD"+          FNMSub -> "FNMSUB"++data Target+    = TBlock BlockId+    | TLabel CLabel+    | TReg   Reg++data Operand+  = OpReg Width Reg -- register+  | OpImm Imm       -- immediate+  | OpAddr AddrMode -- address+  deriving (Eq, Show)++opReg :: Reg -> Operand+opReg = OpReg W64++opRegNo :: RegNo -> Operand+opRegNo = opReg . regSingle++-- LoongArch64 has no ip register in ABI. Here ip register is for spilling/+-- reloading register to/from slots. So make t8(r20) non-free for ip.+zero, ra, tp, sp, fp, tmp :: Operand+zero = opReg zeroReg+ra   = opReg raReg+sp   = opReg spMachReg+tp   = opReg tpMachReg+fp   = opReg fpMachReg+tmp  = opReg tmpReg++x0,  x1,  x2,  x3,  x4,  x5,  x6,  x7  :: Operand+x8,  x9,  x10, x11, x12, x13, x14, x15 :: Operand+x16, x17, x18, x19, x20, x21, x22, x23 :: Operand+x24, x25, x26, x27, x28, x29, x30, x31 :: Operand+x0  = opRegNo  0+x1  = opRegNo  1+x2  = opRegNo  2+x3  = opRegNo  3+x4  = opRegNo  4+x5  = opRegNo  5+x6  = opRegNo  6+x7  = opRegNo  7+x8  = opRegNo  8+x9  = opRegNo  9+x10 = opRegNo 10+x11 = opRegNo 11+x12 = opRegNo 12+x13 = opRegNo 13+x14 = opRegNo 14+x15 = opRegNo 15+x16 = opRegNo 16+x17 = opRegNo 17+x18 = opRegNo 18+x19 = opRegNo 19+x20 = opRegNo 20+x21 = opRegNo 21+x22 = opRegNo 22+x23 = opRegNo 23+x24 = opRegNo 24+x25 = opRegNo 25+x26 = opRegNo 26+x27 = opRegNo 27+x28 = opRegNo 18+x29 = opRegNo 29+x30 = opRegNo 30+x31 = opRegNo 31++d0,  d1,  d2,  d3,  d4,  d5,  d6,  d7  :: Operand+d8,  d9,  d10, d11, d12, d13, d14, d15 :: Operand+d16, d17, d18, d19, d20, d21, d22, d23 :: Operand+d24, d25, d26, d27, d28, d29, d30, d31 :: Operand+d0  = opRegNo 32+d1  = opRegNo 33+d2  = opRegNo 34+d3  = opRegNo 35+d4  = opRegNo 36+d5  = opRegNo 37+d6  = opRegNo 38+d7  = opRegNo 39+d8  = opRegNo 40+d9  = opRegNo 41+d10 = opRegNo 42+d11 = opRegNo 43+d12 = opRegNo 44+d13 = opRegNo 45+d14 = opRegNo 46+d15 = opRegNo 47+d16 = opRegNo 48+d17 = opRegNo 49+d18 = opRegNo 50+d19 = opRegNo 51+d20 = opRegNo 52+d21 = opRegNo 53+d22 = opRegNo 54+d23 = opRegNo 55+d24 = opRegNo 56+d25 = opRegNo 57+d26 = opRegNo 58+d27 = opRegNo 59+d28 = opRegNo 60+d29 = opRegNo 61+d30 = opRegNo 62+d31 = opRegNo 63++fitsInNbits :: Int -> Int -> Bool+fitsInNbits n i = (-1 `shiftL` (n - 1)) <= i && i <= (1 `shiftL` (n - 1) - 1)++isUnsignOp :: Int -> Bool+isUnsignOp i = (i >= 0)++isNbitEncodeable :: Int -> Integer -> Bool+isNbitEncodeable n i = let shift = n - 1 in (-1 `shiftL` shift) <= i && i < (1 `shiftL` shift)++isEncodeableInWidth :: Width -> Integer -> Bool+isEncodeableInWidth = isNbitEncodeable . widthInBits++isIntOp :: Operand -> Bool+isIntOp = not . isFloatOp++isFloatOp :: Operand -> Bool+isFloatOp (OpReg _ reg) | isFloatReg reg = True+isFloatOp _ = False++isFloatReg :: Reg -> Bool+isFloatReg (RegReal (RealRegSingle i)) | i > 31 = True+isFloatReg (RegVirtual (VirtualRegD _)) = True+isFloatReg _ = False++widthToInt :: Width -> Int+widthToInt W8   = 8+widthToInt W16  = 16+widthToInt W32  = 32+widthToInt W64  = 64+widthToInt _ = 64++widthFromOpReg :: Operand -> Width+widthFromOpReg (OpReg W8 _)  = W8+widthFromOpReg (OpReg W16 _) = W16+widthFromOpReg (OpReg W32 _) = W32+widthFromOpReg (OpReg W64 _) = W64+widthFromOpReg _ = W64++ldFormat :: Format -> Format+ldFormat f+  | f `elem` [II8, II16, II32, II64] = II64+  | f `elem` [FF32, FF64] = FF64+  | otherwise = pprPanic "unsupported ldFormat: " (text $ show f)
+ GHC/CmmToAsm/LA64/Ppr.hs view
@@ -0,0 +1,1149 @@+module GHC.CmmToAsm.LA64.Ppr (pprNatCmmDecl, pprInstr) where++import GHC.Prelude hiding (EQ)++import GHC.CmmToAsm.LA64.Regs+import GHC.CmmToAsm.LA64.Instr+import GHC.CmmToAsm.LA64.Cond+import GHC.CmmToAsm.Config+import GHC.CmmToAsm.Format+import GHC.CmmToAsm.Ppr+import GHC.CmmToAsm.Types+import GHC.CmmToAsm.Utils+import GHC.Cmm hiding (topInfoTable)+import GHC.Cmm.BlockId+import GHC.Cmm.CLabel+import GHC.Cmm.Dataflow.Label+import GHC.Platform+import GHC.Platform.Reg+import GHC.Types.Unique ( pprUniqueAlways, getUnique )+import GHC.Utils.Outputable+import GHC.Types.Basic (Alignment, alignmentBytes, mkAlignment)+import GHC.Utils.Panic++pprNatCmmDecl :: forall doc. (IsDoc doc) => NCGConfig -> NatCmmDecl RawCmmStatics Instr -> doc++pprNatCmmDecl config (CmmData section dats) =+  pprSectionAlign config section $$ pprDatas config dats++pprNatCmmDecl config proc@(CmmProc top_info lbl _ (ListGraph blocks)) =+  let platform = ncgPlatform config++      pprProcAlignment :: doc+      pprProcAlignment = maybe empty (pprAlign . mkAlignment) (ncgProcAlignment config)+   in pprProcAlignment+        $$ case topInfoTable proc of+          Nothing ->+            -- special case for code without info table:+            pprSectionAlign config (Section Text lbl)+              $$+              -- do not+              -- pprProcAlignment config $$+              pprLabel platform lbl+              $$ vcat (map (pprBasicBlock config top_info) blocks) -- blocks guaranteed not null, so label needed+              $$ ppWhen+                (ncgDwarfEnabled config)+                (line (pprBlockEndLabel platform lbl) $$ line (pprProcEndLabel platform lbl))+              $$ pprSizeDecl platform lbl+          Just (CmmStaticsRaw info_lbl _) ->+            pprSectionAlign config (Section Text info_lbl)+              $$+              -- pprProcAlignment config $$+              ( if platformHasSubsectionsViaSymbols platform+                  then line (pprAsmLabel platform (mkDeadStripPreventer info_lbl) <> char ':')+                  else empty+              )+              $$ vcat (map (pprBasicBlock config top_info) blocks)+              $$ ppWhen (ncgDwarfEnabled config) (line (pprProcEndLabel platform info_lbl))+              $$+              -- above: Even the first block gets a label, because with branch-chain+              -- elimination, it might be the target of a goto.+              ( if platformHasSubsectionsViaSymbols platform+                  then -- See Note [Subsections Via Symbols]++                    line+                      $ text "\t.long "+                      <+> pprAsmLabel platform info_lbl+                      <+> char '-'+                      <+> pprAsmLabel platform (mkDeadStripPreventer info_lbl)+                  else empty+              )+              $$ pprSizeDecl platform info_lbl+{-# SPECIALIZE pprNatCmmDecl :: NCGConfig -> NatCmmDecl RawCmmStatics Instr -> SDoc #-}+{-# SPECIALIZE pprNatCmmDecl :: NCGConfig -> NatCmmDecl RawCmmStatics Instr -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable++pprProcEndLabel :: IsLine doc => Platform -> CLabel -- ^ Procedure+                -> doc+pprProcEndLabel platform lbl =+    pprAsmLabel platform (mkAsmTempProcEndLabel lbl) <> colon++pprBlockEndLabel :: IsLine doc => Platform -> CLabel -- ^ Block name+                 -> doc+pprBlockEndLabel platform lbl =+    pprAsmLabel platform (mkAsmTempEndLabel lbl) <> colon++pprLabel :: IsDoc doc => Platform -> CLabel -> doc+pprLabel platform lbl =+   pprGloblDecl platform lbl+   $$ pprTypeDecl platform lbl+   $$ line (pprAsmLabel platform lbl <> char ':')++pprAlign :: (IsDoc doc) => Alignment -> doc+pprAlign alignment =+  -- .balign is stable, whereas .align is platform dependent.+  line $ text "\t.balign " <> int (alignmentBytes alignment)++-- | Print appropriate alignment for the given section type.+--+-- Currently, this always aligns to a full machine word (8 byte.) A future+-- improvement could be to really do this per section type (though, it's+-- probably not a big gain.)+pprAlignForSection :: (IsDoc doc) => SectionType -> doc+pprAlignForSection _seg = pprAlign . mkAlignment $ 8++-- Print section header and appropriate alignment for that section.+-- This will e.g. emit a header like:+--+--     .section .text+--     .balign 8+--+pprSectionAlign :: IsDoc doc => NCGConfig -> Section -> doc+pprSectionAlign _config (Section (OtherSection _) _) =+  panic "LA64.Ppr.pprSectionAlign: unknown section"+pprSectionAlign config sec@(Section seg _) =+    line (pprSectionHeader config sec)+    $$ pprAlignForSection seg++-- | Output the ELF .size directive+pprSizeDecl :: (IsDoc doc) => Platform -> CLabel -> doc+pprSizeDecl platform lbl+  | osElfTarget (platformOS platform) =+      line $ text "\t.size" <+> pprAsmLabel platform lbl <> text ", .-" <> pprAsmLabel platform lbl+pprSizeDecl _ _ = empty++pprBasicBlock ::+  (IsDoc doc) =>+  NCGConfig ->+  LabelMap RawCmmStatics ->+  NatBasicBlock Instr ->+  doc++pprBasicBlock config info_env (BasicBlock blockid instrs)+  = maybe_infotable $+    pprLabel platform asmLbl $$+    vcat (map (pprInstr platform) (id {-detectTrivialDeadlock-} optInstrs)) $$+    ppWhen (ncgDwarfEnabled config) (+      -- Emit both end labels since this may end up being a standalone+      -- top-level block+      line (pprBlockEndLabel platform asmLbl+         <> pprProcEndLabel platform asmLbl)+    )+  where+    -- Filter out identity moves. E.g. mov x18, x18 will be dropped.+    optInstrs = filter f instrs+      where f (MOV o1 o2) | o1 == o2 = False+            f _ = True++    asmLbl = blockLbl blockid+    platform = ncgPlatform config+    maybe_infotable c = case mapLookup blockid info_env of+       Nothing   -> c+       Just (CmmStaticsRaw info_lbl info) ->+          --  pprAlignForSection platform Text $$+           infoTableLoc $$+           vcat (map (pprData config) info) $$+           pprLabel platform info_lbl $$+           c $$+           ppWhen (ncgDwarfEnabled config)+              (line (pprBlockEndLabel platform info_lbl))+    -- Make sure the info table has the right .loc for the block+    -- coming right after it. See Note [Info Offset]+    infoTableLoc = case instrs of+      (l@LOCATION{} : _) -> pprInstr platform l+      _other             -> empty++pprDatas :: IsDoc doc => NCGConfig -> RawCmmStatics -> doc+-- See Note [emit-time elimination of static indirections] in "GHC.Cmm.CLabel".+pprDatas config (CmmStaticsRaw alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _])+  | lbl == mkIndStaticInfoLabel+  , let labelInd (CmmLabelOff l _) = Just l+        labelInd (CmmLabel l) = Just l+        labelInd _ = Nothing+  , Just ind' <- labelInd ind+  , alias `mayRedirectTo` ind'+  = pprGloblDecl (ncgPlatform config) alias+    $$ line (text ".equiv" <+> pprAsmLabel (ncgPlatform config) alias <> comma <> pprAsmLabel (ncgPlatform config) ind')++pprDatas config (CmmStaticsRaw lbl dats)+  = vcat (pprLabel platform lbl : map (pprData config) dats)+   where+      platform = ncgPlatform config++pprData :: IsDoc doc => NCGConfig -> CmmStatic -> doc+pprData _config (CmmString str) = line (pprString str)+pprData _config (CmmFileEmbed path _) = line (pprFileEmbed path)++pprData config (CmmUninitialised bytes)+ = line $ let platform = ncgPlatform config+          in if platformOS platform == OSDarwin+                then text ".space " <> int bytes+                else text ".skip "  <> int bytes++pprData config (CmmStaticLit lit) = pprDataItem config lit++pprGloblDecl :: IsDoc doc => Platform -> CLabel -> doc+pprGloblDecl platform lbl+  | not (externallyVisibleCLabel lbl) = empty+  | otherwise = line (text "\t.globl " <> pprAsmLabel platform lbl)++-- Always use objects for info tables+--+-- See discussion in X86.Ppr for why this is necessary.  Essentially we need to+-- ensure that we never pass function symbols when we might want to lookup the+-- info table.  If we did, we could end up with procedure linking tables+-- (PLT)s, and thus the lookup wouldn't point to the function, but into the+-- jump table.+--+-- Fun fact: The LLVMMangler exists to patch this issue su on the LLVM side as+-- well.+pprLabelType' :: IsLine doc => Platform -> CLabel -> doc+pprLabelType' platform lbl =+  if isCFunctionLabel lbl || functionOkInfoTable+    then text "@function"+    else text "@object"+  where+    functionOkInfoTable = platformTablesNextToCode platform &&+      isInfoTableLabel lbl && not (isCmmInfoTableLabel lbl) && not (isConInfoTableLabel lbl)++-- this is called pprTypeAndSizeDecl in PPC.Ppr+pprTypeDecl :: IsDoc doc => Platform -> CLabel -> doc+pprTypeDecl platform lbl+    = if osElfTarget (platformOS platform) && externallyVisibleCLabel lbl+      then line (text ".type " <> pprAsmLabel platform lbl <> text ", " <> pprLabelType' platform lbl)+      else empty++pprDataItem :: IsDoc doc => NCGConfig -> CmmLit -> doc+pprDataItem config lit+  = lines_ (ppr_item (cmmTypeFormat $ cmmLitType platform lit) lit)+    where+        platform = ncgPlatform config++        imm = litToImm lit++        ppr_item II8  _ = [text "\t.byte\t"  <> pprDataImm platform imm]+        ppr_item II16 _ = [text "\t.short\t" <> pprDataImm platform imm]+        ppr_item II32 _ = [text "\t.long\t"  <> pprDataImm platform imm]+        ppr_item II64 _ = [text "\t.quad\t"  <> pprDataImm platform imm]++        ppr_item FF32  (CmmFloat r _)+           = let bs = floatToBytes (fromRational r)+             in  map (\b -> text "\t.byte\t" <> int (fromIntegral b)) bs++        ppr_item FF64 (CmmFloat r _)+           = let bs = doubleToBytes (fromRational r)+             in  map (\b -> text "\t.byte\t" <> int (fromIntegral b)) bs++        ppr_item _ _ = pprPanic "pprDataItem:ppr_item" (text $ show lit)++-- | Pretty print an immediate value in the @data@ section+-- This does not include any checks. We rely on the Assembler to check for+-- errors. Use `pprOpImm` for immediates in instructions (operands.)+pprDataImm :: IsLine doc => Platform -> Imm -> doc+pprDataImm _ (ImmInt i)     = int i+pprDataImm _ (ImmInteger i) = integer i+pprDataImm p (ImmCLbl l)    = pprAsmLabel p l+pprDataImm p (ImmIndex l i) = pprAsmLabel p l <> char '+' <> int i+pprDataImm _ (ImmLit s)     = ftext s+pprDataImm _ (ImmFloat f) = float (fromRational f)+pprDataImm _ (ImmDouble d) = double (fromRational d)++pprDataImm p (ImmConstantSum a b) = pprDataImm p a <> char '+' <> pprDataImm p b+pprDataImm p (ImmConstantDiff a b) = pprDataImm p a <> char '-'+                   <> lparen <> pprDataImm p b <> rparen++asmComment :: SDoc -> SDoc+asmComment c = text "#" <+> c++asmDoubleslashComment :: SDoc -> SDoc+asmDoubleslashComment c = text "//" <+> c++asmMultilineComment :: SDoc -> SDoc+asmMultilineComment c =  text "/*" $+$ c $+$ text "*/"++-- | Pretty print an immediate operand of an instruction+pprOpImm :: (IsLine doc) => Platform -> Imm -> doc+pprOpImm platform imm = case imm of+  ImmInt i -> int i+  ImmInteger i -> integer i+  ImmCLbl l -> char '=' <> pprAsmLabel platform l+  ImmFloat f -> float (fromRational f)+  ImmDouble d -> double (fromRational d)+  _ -> pprPanic "LA64.Ppr.pprOpImm" (text "Unsupported immediate for instruction operands:" <+> (text . show) imm)++negOp :: Operand -> Operand+negOp (OpImm (ImmInt i)) = OpImm (ImmInt (negate i))+negOp (OpImm (ImmInteger i)) = OpImm (ImmInteger (negate i))+negOp op = pprPanic "LA64.negOp" (text $ show op)++pprOp :: IsLine doc => Platform -> Operand -> doc+pprOp plat op = case op of+  OpReg w r                 -> pprReg w r+  OpImm imm                 -> pprOpImm plat imm+  OpAddr (AddrRegReg r1 r2) -> pprReg W64 r1 <> comma <+> pprReg W64 r2+  OpAddr (AddrRegImm r imm) -> pprReg W64 r <> comma <+> pprOpImm plat imm+  OpAddr (AddrReg r)        -> pprReg W64 r <+> text ", 0"++pprReg :: forall doc. IsLine doc => Width -> Reg -> doc+pprReg w r = case r of+  RegReal    (RealRegSingle i) -> ppr_reg_no i+  -- virtual regs should not show up, but this is helpful for debugging.+  RegVirtual (VirtualRegI u)   -> text "%vI_" <> pprUniqueAlways u+  -- RegVirtual (VirtualRegF u)   -> text "%vF_" <> pprUniqueAlways u+  RegVirtual (VirtualRegD u)   -> text "%vD_" <> pprUniqueAlways u+  _                            -> pprPanic "LA64.pprReg" (text (show r) <+> ppr w)++  where+    ppr_reg_no :: Int -> doc+    -- LoongArch's registers must be started from `$[fr]`+    -- General Purpose Registers+    ppr_reg_no 0  = text "$zero"+    ppr_reg_no 1  = text "$ra"+    ppr_reg_no 2  = text "$tp"+    ppr_reg_no 3  = text "$sp"+    ppr_reg_no 4  = text "$a0"+    ppr_reg_no 5  = text "$a1"+    ppr_reg_no 6  = text "$a2"+    ppr_reg_no 7  = text "$a3"+    ppr_reg_no 8  = text "$a4"+    ppr_reg_no 9  = text "$a5"+    ppr_reg_no 10 = text "$a6"+    ppr_reg_no 11 = text "$a7"+    ppr_reg_no 12 = text "$t0"+    ppr_reg_no 13 = text "$t1"+    ppr_reg_no 14 = text "$t2"+    ppr_reg_no 15 = text "$t3"+    ppr_reg_no 16 = text "$t4"+    ppr_reg_no 17 = text "$t5"+    ppr_reg_no 18 = text "$t6"+    ppr_reg_no 19 = text "$t7"+    ppr_reg_no 20 = text "$t8"+    ppr_reg_no 21 = text "$u0"  -- Reserverd+    ppr_reg_no 22 = text "$fp"+    ppr_reg_no 23 = text "$s0"+    ppr_reg_no 24 = text "$s1"+    ppr_reg_no 25 = text "$s2"+    ppr_reg_no 26 = text "$s3"+    ppr_reg_no 27 = text "$s4"+    ppr_reg_no 28 = text "$s5"+    ppr_reg_no 29 = text "$s6"+    ppr_reg_no 30 = text "$s7"+    ppr_reg_no 31 = text "$s8"++    -- Floating Point Registers+    ppr_reg_no 32 = text "$fa0"+    ppr_reg_no 33 = text "$fa1"+    ppr_reg_no 34 = text "$fa2"+    ppr_reg_no 35 = text "$fa3"+    ppr_reg_no 36 = text "$fa4"+    ppr_reg_no 37 = text "$fa5"+    ppr_reg_no 38 = text "$fa6"+    ppr_reg_no 39 = text "$fa7"+    ppr_reg_no 40 = text "$ft0"+    ppr_reg_no 41 = text "$ft1"+    ppr_reg_no 42 = text "$ft2"+    ppr_reg_no 43 = text "$ft3"+    ppr_reg_no 44 = text "$ft4"+    ppr_reg_no 45 = text "$ft5"+    ppr_reg_no 46 = text "$ft6"+    ppr_reg_no 47 = text "$ft7"+    ppr_reg_no 48 = text "$ft8"+    ppr_reg_no 49 = text "$ft9"+    ppr_reg_no 50 = text "$ft10"+    ppr_reg_no 51 = text "$ft11"+    ppr_reg_no 52 = text "$ft12"+    ppr_reg_no 53 = text "$ft13"+    ppr_reg_no 54 = text "$ft14"+    ppr_reg_no 55 = text "$ft15"+    ppr_reg_no 56 = text "$fs0"+    ppr_reg_no 57 = text "$fs1"+    ppr_reg_no 58 = text "$fs2"+    ppr_reg_no 59 = text "$fs3"+    ppr_reg_no 60 = text "$fs4"+    ppr_reg_no 61 = text "$fs5"+    ppr_reg_no 62 = text "$fs6"+    ppr_reg_no 63 = text "$fs7"++    ppr_reg_no i+         | i < 0 = pprPanic "Unexpected register number (min is 0)" (ppr w <+> int i)+         | i > 63 = pprPanic "Unexpected register number (max is 63)" (ppr w <+> int i)+         -- no support for widths > W64.+         | otherwise = pprPanic "Unsupported width in register (max is 64)" (ppr w <+> int i)++-- | Single precission `Operand` (floating-point)+isSingleOp :: Operand -> Bool+isSingleOp (OpReg W32 _) = True+isSingleOp _ = False++-- | Double precission `Operand` (floating-point)+isDoubleOp :: Operand -> Bool+isDoubleOp (OpReg W64 _) = True+isDoubleOp _ = False++-- | `Operand` is an immediate value+isImmOp :: Operand -> Bool+isImmOp (OpImm _) = True+isImmOp _ = False++-- | `Operand` is an immediate @0@ value+isImmZero :: Operand -> Bool+isImmZero (OpImm (ImmFloat 0)) = True+isImmZero (OpImm (ImmDouble 0)) = True+isImmZero (OpImm (ImmInt 0)) = True+isImmZero _ = False++pprInstr :: IsDoc doc => Platform -> Instr -> doc+pprInstr platform instr = case instr of+  -- Meta Instructions ---------------------------------------------------------+  -- see Note [dualLine and dualDoc] in GHC.Utils.Outputable+  COMMENT s  -> dualDoc (asmComment s) empty+  MULTILINE_COMMENT s -> dualDoc (asmMultilineComment s) empty+  ANN d i -> dualDoc (pprInstr platform i <+> asmDoubleslashComment d) (pprInstr platform i)++  LOCATION file line' col _name+    -> line (text "\t.loc" <+> int file <+> int line' <+> int col)+  DELTA d   -> dualDoc (asmComment $ text "\tdelta = " <> int d) empty+  NEWBLOCK _ -> panic "PprInstr: NEWBLOCK"+  LDATA _ _ -> panic "PprInstr: NEWBLOCK"++  -- Pseudo Instructions -------------------------------------------------------++  PUSH_STACK_FRAME -> lines_ [ text "\taddi.d $sp, $sp, -16"+                             , text "\tst.d   $ra, $sp, 8"+                             , text "\tst.d   $fp, $sp, 0"+                             , text "\taddi.d $fp, $sp, 16"+                             ]++  POP_STACK_FRAME -> lines_  [ text "\tld.d   $fp, $sp, 0"+                             , text "\tld.d   $ra, $sp, 8"+                             , text "\taddi.d $sp, $sp, 16"+                             ]+++  -- ===========================================================================+  -- LoongArch64 Instruction Set+  -- Basic Integer Instructions ------------------------------------------------+  -- 1. Arithmetic Instructions ------------------------------------------------+    -- ADD.{W/D}, SUB.{W/D}+    -- ADDI.{W/D}, ADDU16I.D+  ADD  o1 o2 o3+    | isFloatOp o2 && isFloatOp o3 && isSingleOp o2 && isSingleOp o3 -> op3 (text "\tfadd.s") o1 o2 o3+    | isFloatOp o2 && isFloatOp o3 && isDoubleOp o2 && isDoubleOp o3 -> op3 (text "\tfadd.d") o1 o2 o3+    | OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tadd.w") o1 o2 o3+    | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tadd.d") o1 o2 o3+    | OpReg W32 _ <- o2, isImmOp o3 -> op3 (text "\taddi.w") o1 o2 o3+    | OpReg W64 _ <- o2, isImmOp o3 -> op3 (text "\taddi.d") o1 o2 o3+    | otherwise -> pprPanic "LA64.ppr: ADD error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3)+    -- TODO: Not complete.+    -- Here we should add addu16i.d for optimizations of accelerating GOT accession+    -- with ldptr.w/d, stptr.w/d+  SUB  o1 o2 o3+    | isFloatOp o2 && isFloatOp o3 && isSingleOp o2 && isSingleOp o3 -> op3 (text "\tfsub.s") o1 o2 o3+    | isFloatOp o2 && isFloatOp o3 && isDoubleOp o2 && isDoubleOp o3 -> op3 (text "\tfsub.d") o1 o2 o3+    | OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tsub.w") o1 o2 o3+    | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tsub.d") o1 o2 o3+    | OpReg W32 _ <- o2, isImmOp o3 -> op3 (text "\taddi.w") o1 o2 (negOp o3)+    | OpReg W64 _ <- o2, isImmOp o3 -> op3 (text "\taddi.d") o1 o2 (negOp o3)+    | otherwise -> pprPanic "LA64.ppr: SUB error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3)+    -- ALSL.{W[U]/D}+  ALSL  o1 o2 o3 o4+    | OpReg W32 _ <- o2, OpReg W32 _ <- o3, isImmOp o4 -> op4 (text "\talsl.w") o1 o2 o3 o4+    | OpReg W64 _ <- o2, OpReg W64 _ <- o3, isImmOp o4 -> op4 (text "\talsl.d") o1 o2 o3 o4+    | otherwise -> pprPanic "LA64.ppr: ALSL error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3)+  ALSLU  o1 o2 o3 o4 -> op4 (text "\talsl.wu") o1 o2 o3 o4+    -- LoongArch-Assembler should implement following pesudo instructions, here we can directly use them.+    -- li.w rd, s32+    -- li.w rd, u32+    -- li.d rd, s64+    -- li.d rd, u64+    --+    -- # Load with one instruction+    -- ori dst, $zero, imm[11:0]+    --+    -- # Load with two instructions+    -- lu12i.w dst, imm[31:12]+    -- ori     dst, dst, imm[11:0]+    --+    -- # Load with four instructions+    -- lu12i.w dst, imm[31:12]+    -- ori     dst, dst, imm[11:0]+    -- lu32i.d dst, imm[51:32]+    -- lu52i.d dst, dst, imm[63:52]++  --  -- LU12I.W, LU32I.D, LU52I.D+  LU12I  o1 o2 -> op2 (text "\tlu12i.w") o1 o2+  LU32I  o1 o2 -> op2 (text "\tlu32i.d") o1 o2+  LU52I  o1 o2 o3 -> op3 (text "\tlu52i.d") o1 o2 o3+    -- SSLT[U]+    -- SSLT[U]I+  SSLT  o1 o2 o3+    | isImmOp o3 -> op3 (text "\tslti") o1 o2 o3+    | OpReg W64 _ <- o2, OpReg W64 _ <- o3  -> op3 (text "\tslt") o1 o2 o3+    | otherwise -> pprPanic "LA64.ppr: SSLT error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3)+  SSLTU  o1 o2 o3+    | isImmOp o3 -> op3 (text "\tsltui") o1 o2 o3+    | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tsltu") o1 o2 o3+    | otherwise -> pprPanic "LA64.ppr: SSLTU error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3)+    -- PCADDI, PCADDU121, PCADDU18l, PCALAU12I+  PCADDI  o1 o2     -> op2 (text "\tpcaddi") o1 o2+  PCADDU12I  o1 o2  -> op2 (text "\tpcaddu12i") o1 o2+  PCADDU18I  o1 (OpImm (ImmCLbl lbl))  ->+    lines_ [+      text "\tpcaddu18i" <+> pprOp platform o1 <> comma <+> text "%call36(" <+> pprAsmLabel platform lbl <+> text ")"+           ]+  PCALAU12I  o1 o2  -> op2 (text "\tpcalau12i") o1 o2+    -- AND, OR, NOR, XOR, ANDN, ORN+    -- ANDI, ORI, XORI: zero-extention+  AND  o1 o2 o3+    | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tand") o1 o2 o3+    | OpReg W64 _ <- o2, isImmOp o3 -> op3 (text "\tandi") o1 o2 o3+    | otherwise -> pprPanic "LA64.ppr: AND error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3)+  OR  o1 o2 o3+    | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tor") o1 o2 o3+    | OpReg W64 _ <- o2, isImmOp o3 -> op3 (text "\tori") o1 o2 o3+    | otherwise -> pprPanic "LA64.ppr: OR error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3)+  XOR  o1 o2 o3+    | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\txor") o1 o2 o3+    | OpReg W64 _ <- o2, isImmOp o3 -> op3 (text "\txori") o1 o2 o3+    | otherwise -> pprPanic "LA64.ppr: XOR error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3)+  NOR  o1 o2 o3   -> op3 (text "\tnor") o1 o2 o3+  ANDN  o1 o2 o3  -> op3 (text "\tandn") o1 o2 o3+  ORN  o1 o2 o3   -> op3 (text "\torn") o1 o2 o3++  -----------------------------------------------------------------------------+  -- Pseudo instructions+  -- NOP, alias for "andi r0, r0, r0"+  NOP -> line $ text "\tnop"+  -- NEG o1 o2, alias for "sub o1, r0, o2"+  NEG o1 o2+    | isFloatOp o2 && isSingleOp o2 -> op2 (text "\tfneg.s") o1 o2+    | isFloatOp o2 && isDoubleOp o2 -> op2 (text "\tfneg.d") o1 o2+    | OpReg W32 _ <- o2 -> op3 (text "\tsub.w" ) o1 zero o2+    | OpReg W64 _ <- o2 -> op3 (text "\tsub.d" ) o1 zero o2+    | otherwise -> pprPanic "LA64.ppr: NEG error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2)+  -- Here we can do more simplitcations.+  -- To be honest, floating point instructions are too scarce, so maybe+  -- we should reimplement some pseudo instructions with others.+  MOV o1 o2+    | isFloatOp o1 && isFloatOp o2 && isSingleOp o1 && isSingleOp o2 -> op2 (text "\tfmov.s") o1 o2+    | isFloatOp o1 && isFloatOp o2 && isDoubleOp o1 && isDoubleOp o2 -> op2 (text "\tfmov.d") o1 o2+    | isFloatOp o1 && isImmZero o2 && isSingleOp o1 -> op2 (text "\tmovgr2fr.w") o1 zero+    | isFloatOp o1 && isImmZero o2 && isDoubleOp o1 -> op2 (text "\tmovgr2fr.d") o1 zero+    | isFloatOp o1 && not (isFloatOp o2) && isSingleOp o1 -> op2 (text "\tmovgr2fr.w") o1 o2+    | isFloatOp o1 && not (isFloatOp o2) && isDoubleOp o1 -> op2 (text "\tmovgr2fr.d") o1 o2+    | not (isFloatOp o1) && isFloatOp o2 && isSingleOp o2 -> op2 (text "\tmovfr2gr.s") o1 o2+    | not (isFloatOp o1) && isFloatOp o2 && isDoubleOp o2 -> op2 (text "\tmovfr2gr.d") o1 o2+    | isImmOp o2, (OpImm (ImmInt i)) <- o2, fitsInNbits 12 (fromIntegral i) ->+      lines_ [text "\taddi.d" <+> pprOp platform o1 <> comma <+> pprOp platform x0 <+> comma <> pprOp platform o2]+    | isImmOp o2, (OpImm (ImmInteger i)) <- o2, fitsInNbits 12 (fromIntegral i) ->+      lines_ [text "\taddi.d" <+> pprOp platform o1 <> comma <+> pprOp platform x0 <+> comma <> pprOp platform o2]+    | OpReg W64 _ <- o2 -> op2 (text "\tmove") o1 o2+    | OpReg _ _ <- o2  ->+      lines_ [+        text "\tbstrpick.d" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform (OpImm (ImmInt ((widthToInt (min (widthFromOpReg o1) (widthFromOpReg o2))) - 1))) <+> text ", 0"+             ]+    -- TODO: Maybe we can do more.+    -- Let the assembler do these concret things.+    | isImmOp o2 ->+      lines_ [text "\tli.d" <+> pprOp platform o1 <> comma <+> pprOp platform o2]+    | otherwise -> pprPanic "LA64.ppr: MOV error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2)++  -- CSET pesudo instrcutions implementation+  CSET cond dst o1 o2 -> case cond of+    -- SEQ dst, rd, rs -> [SUB rd, rd, rs;  sltui dst, rd, 1]+    EQ | isIntOp o1 && isIntOp o2 ->+      lines_ [+              subFor o1 o2,+              text "\tsltui" <+> pprOp platform dst <> comma <+> pprOp platform dst <> comma <+> pprOp platform (OpImm (ImmInt 1))+             ]+    EQ | isFloatOp o1 && isFloatOp o2 && isDoubleOp o1 && isDoubleOp o2 ->+      lines_ [+              text "\tfcmp.seq.d $fcc0," <+> pprOp platform o1 <> comma <+> pprOp platform o2,+              text "\tmovcf2gr" <+> pprOp platform dst <+> text ", $fcc0"+             ]+    EQ | isFloatOp o1 && isFloatOp o2 && isSingleOp o1 && isSingleOp o2 ->+      lines_ [+              text "\tfcmp.seq.s $fcc0," <+> pprOp platform o1 <> comma <+> pprOp platform o2,+              text "\tmovcf2gr" <+> pprOp platform dst <+> text ", $fcc0"+             ]+    -- SNE rd, rs -> [SUB rd, rd, rs;   sltu rd, zero, rs]+    NE | isIntOp o1 && isIntOp o2 ->+      lines_ [+              subFor o1 o2,+              text "\tsltu" <+> pprOp platform dst <> comma <+> text "$r0" <+> comma <+> pprOp platform dst+             ]+    NE | isFloatOp o1 && isFloatOp o2 && isDoubleOp o1 && isDoubleOp o2 ->+      lines_ [+              text "\tfcmp.cune.d $fcc0," <+> pprOp platform o1 <> comma <+> pprOp platform o2,+              text "\tmovcf2gr" <+> pprOp platform dst <+> text ", $fcc0"+             ]+    NE | isFloatOp o1 && isFloatOp o2 && isSingleOp o1 && isSingleOp o2 ->+      lines_ [+              text "\tfcmp.cune.s $fcc0," <+> pprOp platform o1 <> comma <+> pprOp platform o2,+              text "\tmovcf2gr" <+> pprOp platform dst <+> text ", $fcc0"+             ]+    SLT -> lines_ [ sltFor o1 o2 <+> pprOp platform dst <> comma <+> pprOp platform o1 <> comma <+> pprOp platform o2 ]+    -- SLE rd, rs -> [SLT rd, rs;  xori rd, rs, o1]+    SLE ->+      lines_ [+              sltFor o1 o2 <+> pprOp platform dst <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o1,+              text "\txori" <+>  pprOp platform dst <> comma <+> pprOp platform dst <> comma <+> pprOp platform (OpImm (ImmInt 1))+             ]+    -- SGE rd, rs -> [SLT rd, rs;  xori rd, rs, o1]+    SGE ->+      lines_ [+              sltFor o1 o2 <+> pprOp platform dst <> comma <+> pprOp platform o1 <> comma <+> pprOp platform o2,+              text "\txori" <+>  pprOp platform dst <> comma <+> pprOp platform dst <> comma <+> pprOp platform (OpImm (ImmInt 1))+             ]+    -- SGT rd, rs -> [SLT rd, rs]+    SGT -> lines_ [ sltFor o1 o2 <+> pprOp platform dst <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o1 ]++    ULT -> lines_ [ sltuFor o1 o2 <+> pprOp platform dst <> comma <+> pprOp platform o1 <> comma <+> pprOp platform o2 ]+    ULE ->+      lines_ [+              sltuFor o1 o2 <+> pprOp platform dst <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o1,+              text "\txori" <+> pprOp platform dst <> comma <+> pprOp platform dst <> comma <+> pprOp platform (OpImm (ImmInt 1))+             ]+    -- UGE rd, rs -> [SLTU rd, rs;  xori rd, rs, 1]+    UGE ->+      lines_ [+              sltuFor o1 o2 <+> pprOp platform dst <> comma <+> pprOp platform o1 <> comma <+> pprOp platform o2,+              text "\txori" <+>  pprOp platform dst <> comma <+> pprOp platform dst <> comma <+> pprOp platform (OpImm (ImmInt 1))+             ]+    -- SGTU rd, rs -> [SLTU rd, rs]+    UGT -> lines_ [ sltuFor o1 o2 <+> pprOp platform dst <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o1 ]++    -- TODO:+    -- LoongArch's floating point instrcutions don't write the compared result to an interger register, instead of cc.+    -- Fcond dst o1 o2 -> [fcmp.cond.[s/d] fcc0 o1 o2;  movcf2gr dst, fcc0]+    FLT | isFloatOp o1 && isFloatOp o2 && isDoubleOp o1 && isDoubleOp o2 ->+      lines_ [+              text "\tfcmp.slt.d $fcc0," <+> pprOp platform o1 <> comma <+> pprOp platform o2,+              text "\tmovcf2gr" <+> pprOp platform dst <+> text ", $fcc0"+             ]+    FLE | isFloatOp o1 && isFloatOp o2 && isDoubleOp o1 && isDoubleOp o2 ->+      lines_ [+              text "\tfcmp.sle.d $fcc0," <+> pprOp platform o1 <> comma <+> pprOp platform o2,+              text "\tmovcf2gr" <+> pprOp platform dst <+> text ", $fcc0"+             ]+    FGT | isFloatOp o1 && isFloatOp o2 && isDoubleOp o1 && isDoubleOp o2 ->+      lines_ [+              text "\tfcmp.slt.d $fcc0," <+> pprOp platform o2 <> comma <+> pprOp platform o1,+              text "\tmovcf2gr" <+> pprOp platform dst <+> text ", $fcc0"+             ]+    FGE | isFloatOp o1 && isFloatOp o2 && isDoubleOp o1 && isDoubleOp o2 ->+      lines_ [+              text "\tfcmp.sle.d $fcc0," <+> pprOp platform o2 <> comma <+> pprOp platform o1,+              text "\tmovcf2gr" <+> pprOp platform dst <+> text ", $fcc0"+             ]++    FLT | isFloatOp o1 && isFloatOp o2 && isSingleOp o1 && isSingleOp o2 ->+      lines_ [+              text "\tfcmp.slt.s $fcc0," <+> pprOp platform o1 <> comma <+> pprOp platform o2,+              text "\tmovcf2gr" <+> pprOp platform dst <+> text ", $fcc0"+             ]+    FLE | isFloatOp o1 && isFloatOp o2 && isSingleOp o1 && isSingleOp o2 ->+      lines_ [+              text "\tfcmp.sle.s $fcc0," <+> pprOp platform o1 <> comma <+> pprOp platform o2,+              text "\tmovcf2gr" <+> pprOp platform dst <+> text ", $fcc0"+             ]+    FGT | isFloatOp o1 && isFloatOp o2 && isSingleOp o1 && isSingleOp o2 ->+      lines_ [+              text "\tfcmp.slt.s $fcc0," <+> pprOp platform o2 <> comma <+> pprOp platform o1,+              text "\tmovcf2gr" <+> pprOp platform dst <+> text ", $fcc0"+             ]+    FGE | isFloatOp o1 && isFloatOp o2 && isSingleOp o1 && isSingleOp o2 ->+      lines_ [+              text "\tfcmp.sle.s $fcc0," <+> pprOp platform o2 <> comma <+> pprOp platform o1,+              text "\tmovcf2gr" <+> pprOp platform dst <+> text ", $fcc0"+             ]++    _ -> pprPanic "LA64.ppr: CSET error: " (pprCond cond <+> pprOp platform dst <> comma <+> (ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2)++    where+      subFor o1 o2  | (OpReg W64 _) <- dst, (OpImm _) <- o2  =+                        text "\taddi.d" <+> pprOp platform dst <> comma <+> pprOp platform o1 <> comma <+> pprOp platform (negOp o2)+                    | (OpReg W64 _) <- dst, (OpReg W64 _) <- o2 =+                        text "\tsub.d" <+> pprOp platform dst <> comma <+> pprOp platform o1 <> comma <+> pprOp platform o2+                    | otherwise = pprPanic "LA64.ppr: unknown subFor format: " ((ppr (widthFromOpReg dst)) <+> pprOp platform dst <+> (ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2)++      sltFor o1 o2  | (OpReg W64 _) <- dst, (OpImm _) <- o2   = text "\tslti"+                    | (OpReg W64 _) <- dst, (OpReg W64 _) <- o2 = text "\tslt"+                    | otherwise = pprPanic "LA64.ppr: unknown sltFor format: " ((ppr (widthFromOpReg dst)) <+> pprOp platform dst <+> (ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2)++      sltuFor o1 o2 | (OpReg W64 _) <- dst, (OpImm _) <- o2   = text "\tsltui"+                    | (OpReg W64 _) <- dst, (OpReg W64 _) <- o2 = text "\tsltu"+                    | otherwise = pprPanic "LA64.ppr: unknown sltuFor format: " ((ppr (widthFromOpReg dst)) <+> pprOp platform dst <+> (ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2)++    -- MUL.{W/D}, MULH, {W[U]/D[U]}, 'h' means high 32bit.+    -- MULW.D.W[U]+  MUL  o1 o2 o3+    | isFloatOp o1 && isFloatOp o2 && isFloatOp o3 && isSingleOp o1 && isSingleOp o2 && isSingleOp o3 -> op3 (text "\tfmul.s") o1 o2 o3+    | isFloatOp o1 && isFloatOp o2 && isFloatOp o3 && isDoubleOp o1 && isDoubleOp o2 && isDoubleOp o3 -> op3 (text "\tfmul.d") o1 o2 o3+    | OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tmul.w") o1 o2 o3+    | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tmul.d") o1 o2 o3+    | otherwise -> pprPanic "LA64.ppr: MUL error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3)+  MULW   o1 o2 o3+    | OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tmulw.d.w") o1 o2 o3+    | otherwise -> pprPanic "LA64.ppr: MULW error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3)+  MULWU  o1 o2 o3+    | OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tmulw.d.wu") o1 o2 o3+    | otherwise -> pprPanic "LA64.ppr: MULWU error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3)+  MULH  o1 o2 o3+    | OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tmulh.w") o1 o2 o3+    | OpReg W64 _ <- o2, OpReg W64 _ <- o2 -> op3 (text "\tmulh.d") o1 o2 o3+    | otherwise -> pprPanic "LA64.ppr: MULH error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3)+  MULHU  o1 o2 o3+    | OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tmulh.wu") o1 o2 o3+    | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tmulh.du") o1 o2 o3+    | otherwise -> pprPanic "LA64.ppr: MULHU error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3)+    -- DIV.{W[U]/D[U]}, MOD.{W[U]/D[U]}+  DIV  o1 o2 o3+    | isFloatOp o1 && isFloatOp o2 && isFloatOp o3 && isSingleOp o1 && isSingleOp o2 && isSingleOp o3 -> op3 (text "\tfdiv.s") o1 o2 o3+    | isFloatOp o1 && isFloatOp o2 && isFloatOp o3 && isDoubleOp o1 && isDoubleOp o2 && isDoubleOp o3 -> op3 (text "\tfdiv.d") o1 o2 o3+    | OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tdiv.w") o1 o2 o3+    | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tdiv.d") o1 o2 o3+    | otherwise -> pprPanic "LA64.ppr: DIV error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3)+  DIVU  o1 o2 o3+    | OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tdiv.wu") o1 o2 o3+    | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tdiv.du") o1 o2 o3+    | otherwise -> pprPanic "LA64.ppr: DIVU error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3)+  MOD  o1 o2 o3+    | OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tmod.w") o1 o2 o3+    | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tmod.d") o1 o2 o3+    | otherwise -> pprPanic "LA64.ppr: MOD error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3)+  MODU  o1 o2 o3+    | OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tmod.wu") o1 o2 o3+    | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tmod.du") o1 o2 o3+    | otherwise -> pprPanic "LA64.ppr: MODU error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3)+  -- 2. Bit-shift Instuctions --------------------------------------------------+    -- SLL.W, SRL.W, SRA.W, ROTR.W+    -- SLL.D, SRL.D, SRA.D, ROTR.D+    -- SLLI.W, SRLI.W, SRAI.W, ROTRI.W+    -- SLLI.D, SRLI.D, SRAI.D, ROTRI.D+  SLL  o1 o2 o3+    | OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tsll.w") o1 o2 o3+    | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tsll.d") o1 o2 o3+    | OpReg W32 _ <- o2, isImmOp o3 ->+        lines_ [text "\tslli.w" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3]+    | OpReg W64 _ <- o2, isImmOp o3 ->+        lines_ [text "\tslli.d" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3]+    | otherwise -> pprPanic "LA64.ppr: SLL error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3)+  SRL  o1 o2 o3+    | OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tsrl.w") o1 o2 o3+    | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tsrl.d") o1 o2 o3+    | OpReg W32 _ <- o2, isImmOp o3 ->+        lines_ [text "\tsrli.w" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3]+    | OpReg W64 _ <- o2, isImmOp o3 ->+        lines_ [text "\tsrli.d" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3]+    | otherwise -> pprPanic "LA64.ppr: SRL error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3)+  SRA  o1 o2 o3+    | OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\tsra.w") o1 o2 o3+    | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\tsra.d") o1 o2 o3+    | OpReg W32 _ <- o2, isImmOp o3 ->+        lines_ [text "\tsrai.w" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3]+    | OpReg W64 _ <- o2, isImmOp o3 ->+        lines_ [text "\tsrai.d" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3]+    | otherwise -> pprPanic "LA64.ppr: SRA error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3)+  ROTR  o1 o2 o3+    | OpReg W32 _ <- o2, OpReg W32 _ <- o3 -> op3 (text "\trotr.w") o1 o2 o3+    | OpReg W64 _ <- o2, OpReg W64 _ <- o3 -> op3 (text "\trotr.d") o1 o2 o3+    | OpReg W32 _ <- o2, isImmOp o3 ->+        lines_ [text "\trotri.w" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3]+    | OpReg W64 _ <- o2, isImmOp o3 ->+        lines_ [text "\trotri.d" <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3]+    | otherwise -> pprPanic "LA64.ppr: ROTR error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2 <+> (ppr (widthFromOpReg o3)) <+> pprOp platform o3)+  -- 3. Bit-manupulation Instructions ------------------------------------------+    -- EXT.W{B/H}+  EXT o1 o2+    | OpReg W8 _ <- o2  -> op2 (text "\text.w.b") o1 o2+    | OpReg W16 _ <- o2 -> op2 (text "\text.w.h") o1 o2+    | otherwise -> pprPanic "LA64.ppr: EXT error: " ((ppr (widthFromOpReg o1)) <+> pprOp platform o1 <+> (ppr (widthFromOpReg o2)) <+> pprOp platform o2)+    -- CL{O/Z}.{W/D}, CT{O/Z}.{W/D}+  CLO o1 o2+    | OpReg W32 _ <- o2 -> op2 (text "\tclo.w") o1 o2+    | OpReg W64 _ <- o2 -> op2 (text "\tclo.d") o1 o2+    | otherwise -> pprPanic "LA64.ppr: CLO error" (pprOp platform o1 <+> pprOp platform o2)+  CLZ o1 o2+    | OpReg W32 _ <- o2 -> op2 (text "\tclz.w") o1 o2+    | OpReg W64 _ <- o2 -> op2 (text "\tclz.d") o1 o2+    | otherwise -> pprPanic "LA64.ppr: CLZ error" (pprOp platform o1 <+> pprOp platform o2)+  CTO o1 o2+    | OpReg W32 _ <- o2 -> op2 (text "\tcto.w") o1 o2+    | OpReg W64 _ <- o2 -> op2 (text "\tcto.d") o1 o2+    | otherwise -> pprPanic "LA64.ppr: CTO error" (pprOp platform o1 <+> pprOp platform o2)+  CTZ o1 o2+    | OpReg W32 _ <- o2 -> op2 (text "\tctz.w") o1 o2+    | OpReg W64 _ <- o2 -> op2 (text "\tctz.d") o1 o2+    | otherwise -> pprPanic "LA64.ppr: CTZ error" (pprOp platform o1 <+> pprOp platform o2)+    -- BYTEPICK.{W/D} rd, rj, rk, sa2/sa3+  BYTEPICK o1 o2 o3 o4+    | OpReg W32 _ <- o2 -> op4 (text "\tbytepick.w") o1 o2 o3 o4+    | OpReg W64 _ <- o2 -> op4 (text "\tbytepick.d") o1 o2 o3 o4+    | otherwise -> pprPanic "LA64.ppr: BYTEPICK error" (pprOp platform o1 <+> pprOp platform o2 <+> pprOp platform o3 <+> pprOp platform o4)+    -- REVB.{2H/4H/2W/D}+  REVB2H o1 o2 -> op2 (text "\trevb.2h") o1 o2+  REVB4H o1 o2 -> op2 (text "\trevb.4h") o1 o2+  REVB2W o1 o2 -> op2 (text "\trevb.2w") o1 o2+  REVBD  o1 o2 -> op2 (text "\trevb.d") o1 o2+    -- REVH.{2W/D}+  REVH2W o1 o2 -> op2 (text "\trevh.2w") o1 o2+  REVHD o1 o2 -> op2 (text "\trevh.d") o1 o2+    -- BITREV.{4B/8B}+    -- BITREV.{W/D}+  BITREV4B o1 o2 -> op2 (text "\tbitrev.4b") o1 o2+  BITREV8B o1 o2 -> op2 (text "\tbitrev.8b") o1 o2+  BITREVW o1 o2 -> op2 (text "\tbitrev.w") o1 o2+  BITREVD o1 o2 -> op2 (text "\tbitrev.d") o1 o2+    -- BSTRINS.{W/D}+  BSTRINS II64 o1 o2 o3 o4 -> op4 (text "\tbstrins.d") o1 o2 o3 o4+  BSTRINS II32 o1 o2 o3 o4 -> op4 (text "\tbstrins.w") o1 o2 o3 o4+    -- BSTRPICK.{W/D}+  BSTRPICK II64 o1 o2 o3 o4 -> op4 (text "\tbstrpick.d") o1 o2 o3 o4+  BSTRPICK II32 o1 o2 o3 o4 -> op4 (text "\tbstrpick.w") o1 o2 o3 o4+    -- MASKEQZ rd, rj, rk:  if rk == 0 ? rd = 0 : rd = rj+  MASKEQZ o1 o2 o3 -> op3 (text "\tmaskeqz") o1 o2 o3+    -- MASKNEZ:  if rk == 0 ? rd = 0 : rd = rj+  MASKNEZ o1 o2 o3 -> op3 (text "\tmasknez") o1 o2 o3+  -- 4. Branch Instructions ----------------------------------------------------+    -- BEQ, BNE, BLT[U], BGE[U]   rj, rd, off16+    -- BEQZ, BNEZ   rj, off21+    -- B+    -- BL+    -- JIRL+    -- jr rd = jirl $zero, rd, 0: Commonly used for subroutine return.+  J (TReg r) -> line $ text "\tjirl" <+> text "$r0" <> comma <+> pprReg W64 r <> comma <+> text " 0"+  J_TBL _ _ r    -> pprInstr platform (B (TReg r))++  B (TBlock bid) -> line $ text "\tb" <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))+  B (TLabel lbl) -> line $ text "\tb" <+> pprAsmLabel platform lbl+  B (TReg r)     -> line $ text "\tjr" <+> pprReg W64 r++  BL (TBlock bid) _ -> line $ text "\tbl" <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))+  BL (TLabel lbl) _ -> line $ text "\tbl" <+> pprAsmLabel platform lbl+  BL (TReg r) _    -> line $ text "\tjirl" <+> text "$r1" <> comma <+> pprReg W64 r <> comma <+> text " 0"++  CALL (TBlock bid) _ -> line $ text "\tcall36" <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))+  CALL (TLabel lbl) _ -> line $ text "\tcall36" <+> pprAsmLabel platform lbl+  CALL (TReg r) _ -> line $ text "\tjirl" <+> text "$r1" <> comma <+> pprReg W64 r <> comma <+> text " 0"++  CALL36 (TBlock bid) -> line $ text "\tcall36" <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))+  CALL36 (TLabel lbl) -> line $ text "\tcall36" <+> pprAsmLabel platform lbl+  CALL36 _ -> panic "LA64.ppr: CALL36: Not to registers!"+  TAIL36 r (TBlock bid) -> line $ text "\ttail36" <+> pprOp platform r <> comma <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))+  TAIL36 r (TLabel lbl) -> line $ text "\ttail36" <+> pprOp platform r <> comma <+> pprAsmLabel platform lbl+  TAIL36 _ _ -> panic "LA64.ppr: TAIL36: Not to registers!"++  BCOND1 c j d (TBlock bid) -> case c of+    SLE ->+      line $ text "\tbge" <+> pprOp platform d <> comma <+> pprOp platform j <> comma <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))+    SGT ->+      line $ text "\tblt" <+> pprOp platform d <> comma <+> pprOp platform j <> comma <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))+    ULE ->+      line $ text "\tbgeu" <+> pprOp platform d <> comma <+> pprOp platform j <> comma <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))+    UGT ->+      line $ text "\tbltu" <+> pprOp platform d <> comma <+> pprOp platform j <> comma <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))+    _ -> line $ text "\t" <> pprBcond c <+> pprOp platform j <> comma <+> pprOp platform d <> comma <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))++  BCOND1 _ _ _ (TLabel _) -> panic "LA64.ppr: BCOND1: No conditional branching to TLabel!"++  BCOND1 _ _ _ (TReg _) -> panic "LA64.ppr: BCOND1: No conditional branching to registers!"++  -- Reuse t8(IP) register+  BCOND c j d (TBlock bid) -> case c of+    SLE ->+      lines_ [+              text "\tslt $t8, " <+> pprOp platform  d <> comma <+> pprOp platform j,+              text "\tbeqz $t8, " <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))+             ]+    SGT ->+      lines_ [+              text "\tslt $t8, " <+> pprOp platform  d <> comma <+> pprOp platform j,+              text "\tbnez $t8, " <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))+             ]+    ULE ->+      lines_ [+              text "\tsltu $t8, " <+> pprOp platform  d <> comma <+> pprOp platform j,+              text "\tbeqz $t8, " <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))+             ]+    UGT ->+      lines_ [+              text "\tsltu $t8, " <+> pprOp platform  d <> comma <+> pprOp platform j,+              text "\tbnez $t8, " <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))+             ]+    EQ ->+      lines_ [+              text "\tsub.d $t8, " <+> pprOp platform  j <> comma <+> pprOp platform d,+              text "\tbeqz $t8, " <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))+             ]+    NE ->+      lines_ [+              text "\tsub.d $t8, " <+> pprOp platform  j <> comma <+> pprOp platform d,+              text "\tbnez $t8, " <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))+             ]+    SLT ->+      lines_ [+              text "\tslt $t8, " <+> pprOp platform  j <> comma <+> pprOp platform d,+              text "\tbnez $t8, " <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))+             ]+    SGE ->+      lines_ [+              text "\tslt $t8, " <+> pprOp platform  j <> comma <+> pprOp platform d,+              text "\tbeqz $t8, " <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))+             ]+    ULT ->+      lines_ [+              text "\tsltu $t8, " <+> pprOp platform  j <> comma <+> pprOp platform d,+              text "\tbnez $t8, " <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))+             ]+    UGE ->+      lines_ [+              text "\tsltu $t8, " <+> pprOp platform  j <> comma <+> pprOp platform d,+              text "\tbeqz $t8, " <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))+             ]+    _ -> panic "LA64.ppr: BCOND: Unsupported cond!"++  BCOND _ _ _ (TLabel _) -> panic "LA64.ppr: BCOND: No conditional branching to TLabel!"++  BCOND _ _ _ (TReg _) -> panic "LA64.ppr: BCOND: No conditional branching to registers!"++  BEQZ j (TBlock bid) ->+    line $ text "\tbeqz" <+> pprOp platform j <> comma <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))+  BEQZ j (TLabel lbl) ->+    line $ text "\tbeqz" <+> pprOp platform j <> comma <+> pprAsmLabel platform lbl+  BEQZ _ (TReg _)     -> panic "LA64.ppr: BEQZ: No conditional branching to registers!"++  BNEZ j (TBlock bid) ->+    line $ text "\tbnez" <+> pprOp platform j <> comma <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))+  BNEZ j (TLabel lbl) ->+    line $ text "\tbnez" <+> pprOp platform j <> comma <+> pprAsmLabel platform lbl+  BNEZ _ (TReg _)     -> panic "LA64.ppr: BNEZ: No conditional branching to registers!"++  -- 5. Common Memory Access Instructions --------------------------------------+    -- LD.{B[U]/H[U]/W[U]/D}, ST.{B/H/W/D}: AddrRegImm+    -- LD: load, ST: store, x: offset in register, u: load unsigned imm.+    -- LD format dst src: 'src' means final address, not single register or immdiate.+  -- Load symbol's address+  LD _fmt o1 (OpImm (ImmIndex lbl' off)) | Just (_, lbl) <- dynamicLinkerLabelInfo lbl' ->+    lines_ [ text "\tpcalau12i" <+> pprOp platform o1 <> comma <+> text "%got_pc_hi20(" <> pprAsmLabel platform lbl <> text ")"+            , text "\tld.d"   <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> text "%got_pc_lo12(" <> pprAsmLabel platform lbl <> text ")"+            , text "\taddi.d"   <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> int off+           ]+  LD _fmt o1 (OpImm (ImmIndex lbl off)) | isForeignLabel lbl ->+    lines_ [ text "\tpcalau12i" <+> pprOp platform o1 <> comma <+> text "%got_pc_hi20(" <> pprAsmLabel platform lbl <> text ")"+            , text "\tld.d"   <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> text "%got_pc_lo12(" <> pprAsmLabel platform lbl <> text ")"+            , text "\taddi.d"   <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> int off+           ]+  LD _fmt o1 (OpImm (ImmIndex lbl off)) ->+    lines_ [ text "\tpcalau12i" <+> pprOp platform o1 <> comma <+> text "%pc_hi20(" <> pprAsmLabel platform lbl <> text ")"+            , text "\taddi.d"    <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> text "%pc_lo12(" <> pprAsmLabel platform lbl <> text ")"+            , text "\taddi.d"   <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> int off+           ]++  LD _fmt o1 (OpImm (ImmCLbl lbl')) | Just (_, lbl) <- dynamicLinkerLabelInfo lbl' ->+    lines_ [ text "\tpcalau12i" <+> pprOp platform o1 <> comma <+> text "%got_pc_hi20(" <> pprAsmLabel platform lbl <> text ")"+            , text "\tld.d"   <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> text "%got_pc_lo12(" <> pprAsmLabel platform lbl <> text ")"+           ]+  LD _fmt o1 (OpImm (ImmCLbl lbl)) | isForeignLabel lbl ->+    lines_ [ text "\tpcalau12i" <+> pprOp platform o1 <> comma <+> text "%got_pc_hi20(" <> pprAsmLabel platform lbl <> text ")"+            , text "\tld.d"   <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> text "%got_pc_lo12(" <> pprAsmLabel platform lbl <> text ")"+           ]+  LD _fmt o1 (OpImm (ImmCLbl lbl)) ->+    lines_ [ text "\tpcalau12i" <+> pprOp platform o1 <> comma <+> text "%pc_hi20(" <> pprAsmLabel platform lbl <> text ")"+            , text "\taddi.d"    <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> text "%pc_lo12(" <> pprAsmLabel platform lbl <> text ")"+           ]++  LD II8  o1 o2 -> op2 (text "\tld.b") o1 o2+  LD II16 o1 o2 -> op2 (text "\tld.h") o1 o2+  LD II32 o1 o2 -> op2 (text "\tld.w") o1 o2+  LD II64 o1 o2 -> op2 (text "\tld.d") o1 o2+  LD FF32 o1 o2 -> op2 (text "\tfld.s") o1 o2+  LD FF64 o1 o2 -> op2 (text "\tfld.d") o1 o2++  LDU II8  o1 o2 -> op2 (text "\tld.bu") o1 o2+  LDU II16 o1 o2 -> op2 (text "\tld.hu") o1 o2+  LDU II32 o1 o2 -> op2 (text "\tld.wu") o1 o2+  LDU II64 o1 o2 -> op2 (text "\tld.d") o1 o2   -- double words (64bit) cannot be sign extended by definition+  LDU FF32 o1 o2@(OpAddr (AddrReg _))       -> op2 (text "\tfld.s") o1 o2+  LDU FF32 o1 o2@(OpAddr (AddrRegImm _ _))  -> op2 (text "\tfld.s") o1 o2+  LDU FF64 o1 o2@(OpAddr (AddrReg _))       -> op2 (text "\tfld.d") o1 o2+  LDU FF64 o1 o2@(OpAddr (AddrRegImm _ _))  -> op2 (text "\tfld.d") o1 o2+  LDU f o1 o2 -> pprPanic "Unsupported unsigned load" ((text.show) f <+> pprOp platform o1 <+> pprOp platform o2)++  ST II8  o1 o2 -> op2 (text "\tst.b") o1 o2+  ST II16 o1 o2 -> op2 (text "\tst.h") o1 o2+  ST II32 o1 o2 -> op2 (text "\tst.w") o1 o2+  ST II64 o1 o2 -> op2 (text "\tst.d") o1 o2+  ST FF32 o1 o2 -> op2 (text "\tfst.s") o1 o2+  ST FF64 o1 o2 -> op2 (text "\tfst.d") o1 o2++    -- LDPTR.{W/D}, STPTR.{W/D}: AddrRegImm: AddrRegImm+  LDPTR II32 o1 o2 -> op2 (text "\tldptr.w") o1 o2+  LDPTR II64 o1 o2 -> op2 (text "\tldptr.d") o1 o2+  STPTR II32 o1 o2 -> op2 (text "\tstptr.w") o1 o2+  STPTR II64 o1 o2 -> op2 (text "\tstptr.d") o1 o2++    -- LDX.{B[U]/H[U]/W[U]/D}, STX.{B/H/W/D}: AddrRegReg+  LDX II8   o1 o2 -> op2 (text "\tldx.b")  o1 o2+  LDX II16  o1 o2 -> op2 (text "\tldx.h")  o1 o2+  LDX II32  o1 o2 -> op2 (text "\tldx.w")  o1 o2+  LDX II64  o1 o2 -> op2 (text "\tldx.d")  o1 o2+  LDX FF32  o1 o2 -> op2 (text "\tfldx.s") o1 o2+  LDX FF64  o1 o2 -> op2 (text "\tfldx.d") o1 o2+  LDXU II8  o1 o2 -> op2 (text "\tldx.bu") o1 o2+  LDXU II16 o1 o2 -> op2 (text "\tldx.hu") o1 o2+  LDXU II32 o1 o2 -> op2 (text "\tldx.wu") o1 o2+  LDXU II64 o1 o2 -> op2 (text "\tldx.d")  o1 o2+  STX II8   o1 o2 -> op2 (text "\tstx.b")  o1 o2+  STX II16  o1 o2 -> op2 (text "\tstx.h")  o1 o2+  STX II32  o1 o2 -> op2 (text "\tstx.w")  o1 o2+  STX II64  o1 o2 -> op2 (text "\tstx.d")  o1 o2+  STX FF32  o1 o2 -> op2 (text "\tfstx.s") o1 o2+  STX FF64  o1 o2 -> op2 (text "\tfstx.d") o1 o2++  PRELD h o1@(OpAddr (AddrRegImm _ _)) -> op2 (text "\tpreld") h o1+  -- 6. Bound Check Memory Access Instructions ---------------------------------+    -- LD{GT/LE}.{B/H/W/D}, ST{GT/LE}.{B/H/W/D}+  -- 7. Atomic Memory Access Instructions --------------------------------------+    -- AM{SWAP/ADD/AND/OR/XOR/MAX/MIN}[DB].{W/D}, AM{MAX/MIN}[_DB].{WU/DU}+    -- AM.{SWAP/ADD}[_DB].{B/H}+    -- AMCAS[_DB].{B/H/W/D}+    -- LL.{W/D}, SC.{W/D}+    -- SC.Q+    -- LL.ACQ.{W/D}, SC.REL.{W/D}+  -- 8. Barrier Instructions ---------------------------------------------------+    -- DBAR, IBAR+  DBAR h -> line $ text "\tdbar" <+> pprBarrierType h+  IBAR h -> line $ text "\tibar" <+> pprBarrierType h++    -- Floating-point convert precision+  FCVT o1@(OpReg W32 _) o2@(OpReg W64 _) -> op2 (text "\tfcvt.s.d") o1 o2+  FCVT o1@(OpReg W64 _) o2@(OpReg W32 _) -> op2 (text "\tfcvt.d.s") o1 o2+  FCVT o1 o2 -> pprPanic "LA64.pprInstr - impossible float conversion" $+                  line (pprOp platform o1 <> text "->" <> pprOp platform o2)+    -- Signed fixed-point convert to floating-point+    -- For LoongArch, ffint.* instructions's second operand must be float-pointing register,+    -- so we need one more operation.+    -- Also to tfint.*.+  SCVTF o1@(OpReg W32 _) o2@(OpReg W32 _) -> lines_+    [+      text "\tmovgr2fr.w" <+> pprOp platform o1 <> comma <+> pprOp platform o2,+      text "\tffint.s.w" <+> pprOp platform o1 <> comma <+> pprOp platform o1+    ]+  SCVTF o1@(OpReg W32 _) o2@(OpReg W64 _) -> lines_+    [+      text "\tmovgr2fr.d" <+> pprOp platform o1 <> comma <+> pprOp platform o2,+      text "\tffint.s.l" <+> pprOp platform o1 <> comma <+> pprOp platform o1+    ]+  SCVTF o1@(OpReg W64 _) o2@(OpReg W32 _) -> lines_+    [+      text "\tmovgr2fr.w" <+> pprOp platform o1 <> comma <+> pprOp platform o2,+      text "\tffint.d.w" <+> pprOp platform o1 <> comma <+> pprOp platform o1+    ]+  SCVTF o1@(OpReg W64 _) o2@(OpReg W64 _) -> lines_+    [+      text "\tmovgr2fr.d" <+> pprOp platform o1 <> comma <+> pprOp platform o2,+      text "\tffint.d.l" <+> pprOp platform o1 <> comma <+> pprOp platform o1+    ]+  SCVTF o1 o2 -> pprPanic "LA64.pprInstr - impossible integer to float conversion" $+                  line (pprOp platform o1 <> text "->" <> pprOp platform o2)++    -- Floating-point convert to signed integer, rounding toward zero+    -- TODO: FCVTZS will destroy src-floating register if the previous opertion+    -- includes this reg. So I'm just stupidly saving and restoring by adding+    -- an extra register.+  FCVTZS o1@(OpReg W32 _) o2@(OpReg W32 _) o3@(OpReg W32 _) -> lines_+    [+      text "\tfmov.s" <+> pprOp platform o2 <> comma <+> pprOp platform o3,+      text "\tftintrz.w.s" <+> pprOp platform o3 <> comma <+> pprOp platform o3,+      text "\tmovfr2gr.s" <+> pprOp platform o1 <> comma <+> pprOp platform o3,+      text "\tfmov.s" <+> pprOp platform o3 <> comma <+> pprOp platform o2+    ]+  FCVTZS o1@(OpReg W32 _) o2@(OpReg W64 _) o3@(OpReg W64 _) -> lines_+    [+      text "\tfmov.d" <+> pprOp platform o2 <> comma <+> pprOp platform o3,+      text "\tftintrz.w.d" <+> pprOp platform o3 <> comma <+> pprOp platform o3,+      text "\tmovfr2gr.s" <+> pprOp platform o1 <> comma <+> pprOp platform o3,+      text "\tfmov.s" <+> pprOp platform o3 <> comma <+> pprOp platform o2+    ]+  FCVTZS o1@(OpReg W64 _) o2@(OpReg W32 _) o3@(OpReg W32 _) -> lines_+    [+      text "\tfmov.s" <+> pprOp platform o2 <> comma <+> pprOp platform o3,+      text "\tftintrz.l.s" <+> pprOp platform o3 <> comma <+> pprOp platform o3,+      text "\tmovfr2gr.d" <+> pprOp platform o1 <> comma <+> pprOp platform o3,+      text "\tfmov.s" <+> pprOp platform o3 <> comma <+> pprOp platform o2+    ]+  FCVTZS o1@(OpReg W64 _) o2@(OpReg W64 _) o3@(OpReg W64 _) -> lines_+    [+      text "\tfmov.d" <+> pprOp platform o2 <> comma <+> pprOp platform o3,+      text "\tftintrz.l.d" <+> pprOp platform o3 <> comma <+> pprOp platform o3,+      text "\tmovfr2gr.d" <+> pprOp platform o1 <> comma <+> pprOp platform o3,+      text "\tfmov.d" <+> pprOp platform o3 <> comma <+> pprOp platform o2+    ]+  FCVTZS o1 o2 o3 -> pprPanic "LA64.pprInstr - impossible float to integer conversion" $+                   line (pprOp platform o3 <> text "->" <+> pprOp platform o1 <+> text "tmpReg:" <+> pprOp platform o2)++  FMIN o1 o2 o3  -> op3 (text "fmin." <> if isSingleOp o2 then text "s" else text "d") o1 o2 o3+  FMINA o1 o2 o3 -> op3 (text "fmina." <> if isSingleOp o2 then text "s" else text "d") o1 o2 o3+  FMAX o1 o2 o3  -> op3 (text "fmax." <> if isSingleOp o2 then text "s" else text "d") o1 o2 o3+  FMAXA o1 o2 o3 -> op3 (text "fmaxa." <> if isSingleOp o2 then text "s" else text "d") o1 o2 o3+  FABS o1 o2 -> op2 (text "fabs." <> if isSingleOp o2 then text "s" else text "d") o1 o2+  FNEG o1 o2 -> op2 (text "fneg." <> if isSingleOp o2 then text "s" else text "d") o1 o2+  FSQRT o1 o2 -> op2 (text "fsqrt." <> if isSingleOp o2 then text "s" else text "d") o1 o2+  FMA variant d o1 o2 o3 ->+    let fma = case variant of+                FMAdd   -> text "\tfmadd." <+> floatPrecission d+                FMSub   -> text "\tfmsub." <+> floatPrecission d+                FNMAdd  -> text "\tfnmadd." <+> floatPrecission d+                FNMSub  -> text "\tfnmsub." <+> floatPrecission d+    in op4 fma d o1 o2 o3++  instr -> panic $ "LA64.pprInstr - Unknown instruction: " ++ (instrCon instr)+  where op2 op o1 o2        = line $ op <+> pprOp platform o1 <> comma <+> pprOp platform o2+        op3 op o1 o2 o3     = line $ op <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3+        op4 op o1 o2 o3 o4  = line $ op <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 <> comma <+> pprOp platform o4+{-+    -- TODO: Support dbar with different hints.+    On LoongArch uses "dbar 0" (full completion barrier) for everything.+    But the full completion barrier has no performance to tell, so+    Loongson-3A6000 and newer processors have made finer granularity hints+    available:++    Bit4: ordering or completion (0: completion, 1: ordering)+    Bit3: barrier for previous read (0: true, 1: false)+    Bit2: barrier for previous write (0: true, 1: false)+    Bit1: barrier for succeeding read (0: true, 1: false)+    Bit0: barrier for succeeding write (0: true, 1: false)+-}+        pprBarrierType Hint0 = text "0x0"+        floatPrecission o | isSingleOp o = text "s"+                          | isDoubleOp o = text "d"+                          | otherwise  = pprPanic "Impossible floating point precission: " (pprOp platform o)++-- LoongArch64 Conditional Branch Instructions+pprBcond :: IsLine doc => Cond -> doc+pprBcond c = text "b" <> pprCond c++pprCond :: IsLine doc => Cond -> doc+pprCond c = case c of+      EQ -> text "eq"     -- beq  rj, rd, off16+      NE -> text "ne"     -- bne  rj, rd, off16+      SLT -> text "lt"    -- blt  rj, rd, off16+      SGE -> text "ge"    -- bge  rj, rd, off16+      ULT -> text "ltu"   -- bltu rj, rd, off16+      UGE -> text "geu"   -- bgeu rj, rd, off16+      -- Following not real instructions, just mark it.+      SLE    -> text "sle->ge"   -- ble  rj, rd, off16 -> bge  rd, rj, off16+      SGT    -> text "sgt->lt"   -- bgt  rj, rd, off16 -> blt  rd, rj, off16+      ULE    -> text "ule->geu"  -- bleu rj, rd, off16 -> bgeu rd, rj, off16+      UGT    -> text "ugt->ltu"  -- bgtu rj, rd, off16 -> bltu rd, rj, off16+      _ -> panic $ "LA64.ppr: non-implemented branch condition: " ++ show c
+ GHC/CmmToAsm/LA64/RegInfo.hs view
@@ -0,0 +1,25 @@+-- Here maybe have something to be optimized in future?+module GHC.CmmToAsm.LA64.RegInfo where++import GHC.Cmm+import GHC.Cmm.BlockId+import GHC.CmmToAsm.LA64.Instr+import GHC.Prelude+import GHC.Utils.Outputable++newtype JumpDest = DestBlockId BlockId++instance Outputable JumpDest where+  ppr (DestBlockId bid) = text "jd<blk>:" <> ppr bid++getJumpDestBlockId :: JumpDest -> Maybe BlockId+getJumpDestBlockId (DestBlockId bid) = Just bid++canShortcut :: Instr -> Maybe JumpDest+canShortcut _ = Nothing++shortcutStatics :: (BlockId -> Maybe JumpDest) -> RawCmmStatics -> RawCmmStatics+shortcutStatics _ other_static = other_static++shortcutJump :: (BlockId -> Maybe JumpDest) -> Instr -> Instr+shortcutJump _ other = other
+ GHC/CmmToAsm/LA64/Regs.hs view
@@ -0,0 +1,155 @@+module GHC.CmmToAsm.LA64.Regs where++import GHC.Prelude+import GHC.Cmm+import GHC.Cmm.CLabel           ( CLabel )+import GHC.CmmToAsm.Format+import GHC.Data.FastString+import GHC.Platform+import GHC.Platform.Reg+import GHC.Platform.Reg.Class+import GHC.Platform.Reg.Class.Separate+import GHC.Platform.Regs+import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Types.Unique++-- All machine register numbers.+allMachRegNos :: [RegNo]+allMachRegNos = [0..31] ++ [32..63]++zeroReg, raReg, tpMachReg, fpMachReg, spMachReg, tmpReg :: Reg+zeroReg = regSingle 0+raReg = regSingle 1+tpMachReg = regSingle 2+-- Not to be confused with the `CmmReg` `spReg`+spMachReg = regSingle 3+fpMachReg = regSingle 22+-- Use t8(r20) for LA64 IP register.+tmpReg = regSingle 20++-- Registers available to the register allocator.+allocatableRegs :: Platform -> [RealReg]+allocatableRegs platform =+  let isFree = freeReg platform+   in map RealRegSingle $ filter isFree allMachRegNos++-- Integer argument registers according to the calling convention+allGpArgRegs :: [Reg]+allGpArgRegs = map regSingle [4..11]++-- | Floating point argument registers according to the calling convention+allFpArgRegs :: [Reg]+allFpArgRegs = map regSingle [32..39]++-- Addressing modes+data AddrMode+  = AddrRegReg Reg Reg+  | AddrRegImm Reg Imm+  | AddrReg Reg+  deriving (Eq, Show)++-- Immediates+data Imm+  = ImmInt      Int+  | ImmInteger  Integer     -- Sigh.+  | ImmCLbl     CLabel      -- AbstractC Label (with baggage)+  | ImmLit      FastString+  | ImmIndex    CLabel Int+  | ImmFloat    Rational+  | ImmDouble   Rational+  | ImmConstantSum Imm Imm+  | ImmConstantDiff Imm Imm+  deriving (Eq, Show)++-- Map CmmLit to Imm+litToImm :: CmmLit -> Imm+litToImm (CmmInt i w) = ImmInteger (narrowS w i)+-- narrow to the width: a CmmInt might be out of+-- range, but we assume that ImmInteger only contains+-- in-range values.  A signed value should be fine here.+litToImm (CmmFloat f W32) = ImmFloat f+litToImm (CmmFloat f W64) = ImmDouble f+litToImm (CmmLabel l)     = ImmCLbl l+litToImm (CmmLabelOff l off) = ImmIndex l off+litToImm (CmmLabelDiffOff l1 l2 off _) =+  ImmConstantSum+    (ImmConstantDiff (ImmCLbl l1) (ImmCLbl l2))+    (ImmInt off)+litToImm l = panic $ "LA64.Regs.litToImm: no match for " ++ show l++-- == To satisfy GHC.CmmToAsm.Reg.Target =======================================++-- squeese functions for the graph allocator -----------------------------------+-- | regSqueeze_class reg+--      Calculate the maximum number of register colors that could be+--      denied to a node of this class due to having this reg+--      as a neighbour.+--+{-# INLINE virtualRegSqueeze #-}+virtualRegSqueeze :: RegClass -> VirtualReg -> Int+virtualRegSqueeze cls vr+  = case cls of+    RcInteger ->+      case vr of+        VirtualRegI {} -> 1+        VirtualRegHi {} -> 1+        _other -> 0+    RcFloat ->+      case vr of+        VirtualRegD {} -> 1+        _other -> 0+    RcVector ->+      case vr of+        VirtualRegV128 {} -> 1+        _other -> 0++{-# INLINE realRegSqueeze #-}+realRegSqueeze :: RegClass -> RealReg -> Int+realRegSqueeze cls rr =+  case cls of+    RcInteger ->+      case rr of+        RealRegSingle regNo+          | regNo < 32+          -> 1+          | otherwise+          -> 0+    RcFloat ->+      case rr of+        RealRegSingle regNo+          |  regNo < 32+          || regNo > 63+          -> 0+          | otherwise+          -> 1+    RcVector ->+      case rr of+        RealRegSingle regNo+          | regNo > 63+          -> 1+          | otherwise+          -> 0++mkVirtualReg :: Unique -> Format -> VirtualReg+mkVirtualReg u format+   | not (isFloatFormat format) = VirtualRegI u+   | otherwise+   = case format of+        FF32    -> VirtualRegD u+        FF64    -> VirtualRegD u+        _       -> panic "LA64.mkVirtualReg"++{-# INLINE classOfRealReg #-}+classOfRealReg :: RealReg -> RegClass+classOfRealReg (RealRegSingle i)+   | i < 32 = RcInteger+   | i > 63 = RcVector+   | otherwise = RcFloat++regDotColor :: RealReg -> SDoc+regDotColor reg+ = case classOfRealReg reg of+        RcInteger       -> text "blue"+        RcFloat         -> text "red"+        RcVector        -> text "green"
GHC/CmmToAsm/Monad.hs view
@@ -1,5 +1,7 @@ {-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ViewPatterns #-}  -- ----------------------------------------------------------------------------- --@@ -20,7 +22,6 @@         addImmediateSuccessorNat,         updateCfgNat,         getUniqueNat,-        mapAccumLNat,         setDeltaNat,         getConfig,         getPlatform,@@ -32,7 +33,6 @@         getPicBaseMaybeNat,         getPicBaseNat,         getCfgWeights,-        getModLoc,         getFileId,         getDebugBlock, @@ -55,7 +55,6 @@ import GHC.CmmToAsm.Types  import GHC.Cmm.BlockId-import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Label import GHC.Cmm.CLabel           ( CLabel ) import GHC.Cmm.DebugBlock@@ -63,36 +62,58 @@  import GHC.Data.FastString      ( FastString ) import GHC.Types.Unique.FM-import GHC.Types.Unique.Supply+import GHC.Types.Unique.DSM import GHC.Types.Unique         ( Unique ) import GHC.Unit.Module -import Control.Monad    ( ap )--import GHC.Utils.Outputable (SDoc, ppr)+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.-    pprNatCmmDecl             :: NatCmmDecl statics instr -> SDoc,+    pprNatCmmDeclS            :: NatCmmDecl statics instr -> SDoc,+    pprNatCmmDeclH            :: NatCmmDecl statics instr -> HDoc,+        -- see Note [pprNatCmmDeclS and pprNatCmmDeclH]     maxSpillSlots             :: Int,     allocatableRegs           :: [RealReg],     ncgAllocMoreStack         :: Int -> NatCmmDecl statics instr-                              -> UniqSM (NatCmmDecl statics instr, [(BlockId,BlockId)]),+                              -> UniqDSM (NatCmmDecl statics instr, [(BlockId,BlockId)]),     -- ^ The list of block ids records the redirected jumps to allow us to update     -- the CFG.-    ncgMakeFarBranches        :: LabelMap RawCmmStatics -> [NatBasicBlock instr] -> [NatBasicBlock instr],+    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@@ -104,14 +125,64 @@     -- 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          :: UniqSupply,-                natm_delta       :: Int,+                natm_us          :: DUniqSupply,+                natm_delta       :: Int, -- ^ Stack offset for unwinding information                 natm_imports     :: [(CLabel)],                 natm_pic         :: Maybe Reg,                 natm_config      :: NCGConfig,-                natm_modloc      :: ModLocation,                 natm_fileid      :: DwarfFiles,                 natm_debug_map   :: LabelMap DebugBlock,                 natm_cfg         :: CFG@@ -122,73 +193,43 @@  type DwarfFiles = UniqFM FastString (FastString, Int) -newtype NatM result = NatM (NatM_State -> (result, NatM_State))-    deriving (Functor)+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 :: UniqSupply -> Int -> NCGConfig -> ModLocation ->+mkNatM_State :: DUniqSupply -> Int -> NCGConfig ->                 DwarfFiles -> LabelMap DebugBlock -> CFG -> NatM_State mkNatM_State us delta config-        = \loc dwf dbg cfg ->+        = \dwf dbg cfg ->                 NatM_State                         { natm_us = us                         , natm_delta = delta                         , natm_imports = []                         , natm_pic = Nothing                         , natm_config = config-                        , natm_modloc = loc                         , natm_fileid = dwf                         , natm_debug_map = dbg                         , natm_cfg = cfg                         }  initNat :: NatM_State -> NatM a -> (a, NatM_State)-initNat init_st m-        = case unNat m init_st of { (r,st) -> (r,st) }--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})+initNat = flip unNat +instance MonadGetUnique NatM where   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)+      case takeUniqueFromDSupply (natm_us st) of+        (uniq, us') -> (uniq, st {natm_us = us'})  getUniqueNat :: NatM Unique-getUniqueNat = NatM $ \ st ->-    case takeUniqFromSupply $ natm_us st of-    (uniq, us') -> (uniq, st {natm_us = us'})+getUniqueNat = getUniqueM  getDeltaNat :: NatM Int getDeltaNat = NatM $ \ st -> (natm_delta st, st)@@ -244,9 +285,7 @@  getBlockIdNat :: NatM BlockId getBlockIdNat- = do   u <- getUniqueNat-        return (mkBlockId u)-+ = mkBlockId <$> getUniqueNat  getNewLabelNat :: NatM CLabel getNewLabelNat@@ -308,10 +347,6 @@                  -> do                         reg <- getNewRegNat rep                         NatM (\state -> (reg, state { natm_pic = Just reg }))--getModLoc :: NatM ModLocation-getModLoc-        = NatM $ \ st -> (natm_modloc st, st)  -- | Get native code generator configuration getConfig :: NatM NCGConfig
GHC/CmmToAsm/PIC.hs view
@@ -60,7 +60,7 @@ import GHC.CmmToAsm.Types  -import GHC.Cmm.Dataflow.Collections+import GHC.Cmm.Dataflow.Label import GHC.Cmm import GHC.Cmm.CLabel import GHC.Cmm.Utils (cmmLoadBWord)@@ -132,11 +132,26 @@               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@@ -164,9 +179,16 @@   | 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 PicBaseReg)+          [ CmmReg (CmmGlobal $ GlobalRegUse PicBaseReg (bWord platform))           , CmmLit $ picRelative (wordWidth platform)                           (platformArch platform)                           (platformOS   platform)@@ -175,7 +197,7 @@   -- both ABI versions default to medium code model   | ArchPPC_64 _ <- platformArch platform   = CmmMachOp (MO_Add W32) -- code model medium-          [ CmmReg (CmmGlobal PicBaseReg)+          [ CmmReg (CmmGlobal $ GlobalRegUse PicBaseReg (bWord platform))           , CmmLit $ picRelative (wordWidth platform)                           (platformArch platform)                           (platformOS   platform)@@ -184,7 +206,7 @@   | (ncgPIC config || ncgExternalDynamicRefs config)       && absoluteLabel lbl   = CmmMachOp (MO_Add (wordWidth platform))-          [ CmmReg (CmmGlobal PicBaseReg)+          [ CmmReg (CmmGlobal $ GlobalRegUse PicBaseReg (bWord platform))           , CmmLit $ picRelative (wordWidth platform)                           (platformArch platform)                           (platformOS   platform)@@ -303,25 +325,15 @@         | otherwise         = AccessDirectly -howToAccessLabel config arch OSDarwin JumpReference lbl+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:-        | arch == ArchX86 || arch == ArchX86_64 || arch == ArchAArch64-        , ncgLabelDynamic config lbl+        | ncgLabelDynamic config lbl         = AccessViaSymbolPtr  -howToAccessLabel config arch OSDarwin _kind 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, neither on Aarch64 (arm64).-        | arch /= ArchX86_64-        , arch /= ArchAArch64-        , ncgLabelDynamic config lbl-        = AccessViaStub--        | otherwise+howToAccessLabel _ _ OSDarwin _ _         = AccessDirectly  ----------------------------------------------------------------------------@@ -414,6 +426,11 @@             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)@@ -523,7 +540,7 @@         -- HACK: this label isn't really foreign         = mkForeignLabel                 (fsLit ".LCTOC1")-                Nothing ForeignLabelInThisPackage IsData+                ForeignLabelInThisPackage IsData   @@ -532,23 +549,13 @@ -- -- We don't need to declare any offset tables. -- However, for PIC on x86, we need a small helper function.-pprGotDeclaration :: NCGConfig -> SDoc+pprGotDeclaration :: NCGConfig -> HDoc pprGotDeclaration config = case (arch,os) of-   (ArchX86, OSDarwin)-        | ncgPIC config-        -> 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" ]-    (_, OSDarwin) -> empty     -- Emit XCOFF TOC section    (_, OSAIX)-        -> vcat $ [ text ".toc"+        -> lines_ [ text ".toc"                   , text ".tc ghc_toc_table[TC],.LCTOC1"                   , text ".csect ghc_toc_table[RW]"                     -- See Note [.LCTOC1 in PPC PIC code]@@ -558,16 +565,16 @@     -- PPC 64 ELF v1 needs a Table Of Contents (TOC)    (ArchPPC_64 ELF_V1, _)-        -> text ".section \".toc\",\"aw\""+        -> 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, _)-        -> vcat [ text ".abiversion 2",-                  text ".section \".toc\",\"aw\""-                ]+        -> lines_ [ text ".abiversion 2",+                    text ".section \".toc\",\"aw\""+                  ]     (arch, os)         | osElfTarget os@@ -577,7 +584,7 @@          | osElfTarget os         , arch /= ArchPPC_64 ELF_V1 && arch /= ArchPPC_64 ELF_V2-        -> vcat [+        -> lines_ [                 -- See Note [.LCTOC1 in PPC PIC code]                 text ".section \".got2\",\"aw\"",                 text ".LCTOC1 = .+32768" ]@@ -595,60 +602,8 @@ -- and one for non-PIC. -- -pprImportedSymbol :: NCGConfig -> CLabel -> SDoc+pprImportedSymbol :: NCGConfig -> CLabel -> HDoc pprImportedSymbol config importedLbl = case (arch,os) of-   (ArchX86, OSDarwin)-        | Just (CodeStub, lbl) <- dynamicLinkerLabelInfo importedLbl-        -> if not pic-             then-              vcat [-                  text ".symbol_stub",-                  text "L" <> ppr_lbl lbl <> text "$stub:",-                      text "\t.indirect_symbol" <+> ppr_lbl lbl,-                      text "\tjmp *L" <> ppr_lbl lbl-                          <> text "$lazy_ptr",-                  text "L" <> ppr_lbl lbl-                      <> text "$stub_binder:",-                      text "\tpushl $L" <> ppr_lbl lbl-                          <> text "$lazy_ptr",-                      text "\tjmp dyld_stub_binding_helper"-              ]-             else-              vcat [-                  text ".section __TEXT,__picsymbolstub2,"-                      <> text "symbol_stubs,pure_instructions,25",-                  text "L" <> ppr_lbl lbl <> text "$stub:",-                      text "\t.indirect_symbol" <+> ppr_lbl lbl,-                      text "\tcall ___i686.get_pc_thunk.ax",-                  text "1:",-                      text "\tmovl L" <> ppr_lbl lbl-                          <> text "$lazy_ptr-1b(%eax),%edx",-                      text "\tjmp *%edx",-                  text "L" <> ppr_lbl lbl-                      <> text "$stub_binder:",-                      text "\tlea L" <> ppr_lbl lbl-                          <> text "$lazy_ptr-1b(%eax),%eax",-                      text "\tpushl %eax",-                      text "\tjmp dyld_stub_binding_helper"-              ]-           $+$ vcat [        text ".section __DATA, __la_sym_ptr"-                    <> (if pic then int 2 else int 3)-                    <> text ",lazy_symbol_pointers",-                text "L" <> ppr_lbl lbl <> text "$lazy_ptr:",-                    text "\t.indirect_symbol" <+> ppr_lbl lbl,-                    text "\t.long L" <> ppr_lbl lbl-                    <> text "$stub_binder"]--        | Just (SymbolPtr, lbl) <- dynamicLinkerLabelInfo importedLbl-        -> vcat [-                text ".non_lazy_symbol_pointer",-                char 'L' <> ppr_lbl lbl <> text "$non_lazy_ptr:",-                text "\t.indirect_symbol" <+> ppr_lbl lbl,-                text "\t.long\t0"]--        | otherwise-        -> empty-    (ArchAArch64, OSDarwin)         -> empty @@ -667,7 +622,7 @@     (_, OSAIX) -> case dynamicLinkerLabelInfo importedLbl of             Just (SymbolPtr, lbl)-              -> vcat [+              -> lines_ [                    text "LC.." <> ppr_lbl lbl <> char ':',                    text "\t.long" <+> ppr_lbl lbl ]             _ -> empty@@ -705,7 +660,7 @@         | osElfTarget os         -> case dynamicLinkerLabelInfo importedLbl of             Just (SymbolPtr, lbl)-              -> vcat [+              -> lines_ [                    text ".LC_" <> ppr_lbl lbl <> char ':',                    text "\t.quad" <+> ppr_lbl lbl ]             _ -> empty@@ -718,7 +673,7 @@                          W64 -> text "\t.quad"                          _ -> panic "Unknown wordRep in pprImportedSymbol" -                 in vcat [+                 in lines_ [                       text ".section \".got2\", \"aw\"",                       text ".LC_" <> ppr_lbl lbl <> char ':',                       symbolSize <+> ppr_lbl lbl ]@@ -729,10 +684,10 @@    _ -> panic "PIC.pprImportedSymbol: no match"  where    platform = ncgPlatform config-   ppr_lbl  = pprCLabel     platform AsmStyle+   ppr_lbl :: CLabel -> HLine+   ppr_lbl  = pprAsmLabel   platform    arch     = platformArch  platform    os       = platformOS    platform-   pic      = ncgPIC config  -------------------------------------------------------------------------------- -- Generate code to calculate the address that should be put in the@@ -838,11 +793,11 @@ -- (See PprMach.hs)  initializePicBase_x86-        :: Arch -> OS -> Reg+        :: OS -> Reg         -> [NatCmmDecl (Alignment, RawCmmStatics) X86.Instr]         -> NatM [NatCmmDecl (Alignment, RawCmmStatics) X86.Instr] -initializePicBase_x86 ArchX86 os picReg+initializePicBase_x86 os picReg         (CmmProc info lab live (ListGraph blocks) : statics)     | osElfTarget os     = return (CmmProc info lab live (ListGraph blocks') : statics)@@ -860,12 +815,12 @@           fetchGOT (BasicBlock bID insns) =              BasicBlock bID (X86.FETCHGOT picReg : insns) -initializePicBase_x86 ArchX86 OSDarwin picReg+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 _ _ _ _+initializePicBase_x86 _ _ _         = panic "initializePicBase_x86: not needed"
GHC/CmmToAsm/PPC.hs view
@@ -28,7 +28,8 @@    , canShortcut               = PPC.canShortcut    , shortcutStatics           = PPC.shortcutStatics    , shortcutJump              = PPC.shortcutJump-   , pprNatCmmDecl             = PPC.pprNatCmmDecl config+   , pprNatCmmDeclH            = PPC.pprNatCmmDecl config+   , pprNatCmmDeclS            = PPC.pprNatCmmDecl config    , maxSpillSlots             = PPC.maxSpillSlots config    , allocatableRegs           = PPC.allocatableRegs platform    , ncgAllocMoreStack         = PPC.allocMoreStack platform@@ -42,16 +43,17 @@ -- | Instruction instance for powerpc instance Instruction PPC.Instr where    regUsageOfInstr     = PPC.regUsageOfInstr-   patchRegsOfInstr    = PPC.patchRegsOfInstr+   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+   takeRegRegMoveInstr _ = PPC.takeRegRegMoveInstr    mkJumpInstr         = PPC.mkJumpInstr    mkStackAllocInstr   = PPC.mkStackAllocInstr    mkStackDeallocInstr = PPC.mkStackDeallocInstr
GHC/CmmToAsm/PPC/CodeGen.hs view
@@ -41,14 +41,13 @@ import GHC.CmmToAsm.PIC import GHC.CmmToAsm.Format import GHC.CmmToAsm.Config-import GHC.Platform.Reg.Class+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.Ppr           ( pprExpr ) import GHC.Cmm import GHC.Cmm.Utils import GHC.Cmm.Switch@@ -62,7 +61,6 @@ import GHC.Data.OrdList import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Utils.Panic.Plain  import Control.Monad    ( mapAndUnzipM, when ) import Data.Word@@ -130,10 +128,10 @@   -- Generate location directive   dbg <- getDebugBlock (entryLabel block)   loc_instrs <- case dblSourceTick =<< dbg of-    Just (SourceNote span name)+    Just (SourceNote span (LexicalFastString name))       -> do fileid <- getFileId (srcSpanFile span)             let line = srcSpanStartLine span; col =srcSpanStartCol span-            return $ unitOL $ LOCATION fileid line col name+            return $ unitOL $ LOCATION fileid line col (unpackFS name)     _ -> return nilOL   mid_instrs <- stmtsToInstrs stmts   tail_instrs <- stmtToInstrs tail@@ -163,7 +161,7 @@   config <- getConfig   platform <- getPlatform   case stmt of-    CmmComment s   -> return (unitOL (COMMENT $ ftext s))+    CmmComment s   -> return (unitOL (COMMENT s))     CmmTick {}     -> return nilOL     CmmUnwind {}   -> return nilOL @@ -172,7 +170,7 @@       | target32Bit platform &&         isWord64 ty    -> assignReg_I64Code      reg src       | otherwise      -> assignReg_IntCode format reg src-        where ty = cmmRegType platform reg+        where ty = cmmRegType reg               format = cmmTypeFormat ty      CmmStore addr src _alignment@@ -197,8 +195,11 @@     _ ->       panic "stmtToInstrs: statement should have been cps'd away" -jumpRegs :: Platform -> [GlobalReg] -> [Reg]-jumpRegs platform gregs = [ RegReal r | Just r <- map (globalRegMaybe platform) gregs ]+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.@@ -234,7 +235,7 @@   = getLocalRegReg local_reg  getRegisterReg platform (CmmGlobal mid)-  = case globalRegMaybe platform mid of+  = 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@@ -254,12 +255,12 @@  -- Expand CmmRegOff.  ToDo: should we do it this way around, or convert -- CmmExprs into CmmRegOff?-mangleIndexTree :: Platform -> CmmExpr -> CmmExpr-mangleIndexTree platform (CmmRegOff reg off)+mangleIndexTree :: CmmExpr -> CmmExpr+mangleIndexTree (CmmRegOff reg off)   = CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)]-  where width = typeWidth (cmmRegType platform reg)+  where width = typeWidth (cmmRegType reg) -mangleIndexTree _ _+mangleIndexTree _         = panic "PPC.CodeGen.mangleIndexTree: no match"  -- -----------------------------------------------------------------------------@@ -395,9 +396,9 @@ iselExpr64 expr    = do      platform <- getPlatform-     pprPanic "iselExpr64(powerpc)" (pprExpr platform expr)-+     pprPanic "iselExpr64(powerpc)" (pdoc platform expr) +data MinOrMax = Min | Max  getRegister :: CmmExpr -> NatM Register getRegister e = do config <- getConfig@@ -405,10 +406,10 @@  getRegister' :: NCGConfig -> Platform -> CmmExpr -> NatM Register -getRegister' _ platform (CmmReg (CmmGlobal PicBaseReg))+getRegister' _ platform (CmmReg (CmmGlobal (GlobalRegUse PicBaseReg _)))   | OSAIX <- platformOS platform = do         let code dst = toOL [ LD II32 dst tocAddr ]-            tocAddr = AddrRegImm toc (ImmLit (text "ghc_toc_table[TC]"))+            tocAddr = AddrRegImm toc (ImmLit (fsLit "ghc_toc_table[TC]"))         return (Any II32 code)   | target32Bit platform = do       reg <- getPicBaseNat $ archWordFormat (target32Bit platform)@@ -417,11 +418,11 @@   | otherwise = return (Fixed II64 toc nilOL)  getRegister' _ platform (CmmReg reg)-  = return (Fixed (cmmTypeFormat (cmmRegType platform reg))+  = return (Fixed (cmmTypeFormat (cmmRegType reg))                   (getRegisterReg platform reg) nilOL)  getRegister' config platform tree@(CmmRegOff _ _)-  = getRegister' config platform (mangleIndexTree platform tree)+  = getRegister' config platform (mangleIndexTree tree)      -- for 32-bit architectures, support some 64 -> 32 bit conversions:     -- TO_W_(x), TO_W_(x >> 32)@@ -451,7 +452,8 @@ getRegister' _ platform (CmmLoad mem pk _)  | not (isWord64 pk) = do         Amode addr addr_code <- getAmode D mem-        let code dst = assert ((targetClassOfReg platform dst == RcDouble) == isFloatType pk) $+        let 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@@ -459,7 +461,12 @@         let code dst = addr_code `snocOL` LD II64 dst addr         return (Any II64 code) -          where format = cmmTypeFormat pk+ | 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@@ -505,6 +512,9 @@     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@@ -515,8 +525,8 @@       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_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@@ -528,9 +538,15 @@        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 @@ -574,6 +590,9 @@       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 ->@@ -637,9 +656,33 @@       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-      _         -> panic "PPC.CodeGen.getRegister: no match" +      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 @@ -650,7 +693,56 @@       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@@ -689,7 +781,7 @@             `consOL` (addr_code `snocOL` LD format dst addr)        return (Any format code) -getRegister' _ platform other = pprPanic "getRegister(ppc)" (pprExpr platform other)+getRegister' _ platform other = pprPanic "getRegister(ppc)" (pdoc platform other)      -- extend?Rep: wrap integer expression of type `from`     -- in a conversion to `to`@@ -736,8 +828,7 @@  getAmode :: InstrForm -> CmmExpr -> NatM Amode getAmode inf tree@(CmmRegOff _ _)-  = do platform <- getPlatform-       getAmode inf (mangleIndexTree platform tree)+  = getAmode inf (mangleIndexTree tree)  getAmode _ (CmmMachOp (MO_Sub W32) [x, CmmLit (CmmInt i _)])   | Just off <- makeImmediate W32 True (-i)@@ -1039,7 +1130,7 @@   -genJump :: CmmExpr{-the branch target-} -> [Reg] -> NatM InstrBlock+genJump :: CmmExpr{-the branch target-} -> [RegWithFormat] -> NatM InstrBlock  genJump (CmmLit (CmmLabel lbl)) regs   = return (unitOL $ JMP lbl regs)@@ -1049,7 +1140,7 @@         platform <- getPlatform         genJump' tree (platformToGCP platform) gregs -genJump' :: CmmExpr -> GenCCallPlatform -> [Reg] -> NatM InstrBlock+genJump' :: CmmExpr -> GenCCallPlatform -> [RegWithFormat] -> NatM InstrBlock  genJump' tree (GCP64ELF 1) regs   = do@@ -1113,10 +1204,12 @@          -> [CmmFormal]        -- where to put the result          -> [CmmActual]        -- arguments (of mixed type)          -> NatM InstrBlock-genCCall (PrimTarget MO_ReadBarrier) _ _+genCCall (PrimTarget MO_AcquireFence) _ _  = return $ unitOL LWSYNC-genCCall (PrimTarget MO_WriteBarrier) _ _+genCCall (PrimTarget MO_ReleaseFence) _ _  = return $ unitOL LWSYNC+genCCall (PrimTarget MO_SeqCstFence) _ _+ = return $ unitOL HWSYNC  genCCall (PrimTarget MO_Touch) _ _  = return $ nilOL@@ -1174,7 +1267,7 @@                           (n_reg, n_code) <- getSomeReg n                           return  (op dst dst (RIReg n_reg), n_code) -genCCall (PrimTarget (MO_AtomicRead width)) [dst] [addr]+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@@ -1201,7 +1294,7 @@ -- This is also what gcc does.  -genCCall (PrimTarget (MO_AtomicWrite width)) [] [addr, val] = do+genCCall (PrimTarget (MO_AtomicWrite width _)) [] [addr, val] = do     code <- assignMem_IntCode (intFormat width) addr val     return $ unitOL HWSYNC `appOL` code @@ -1753,7 +1846,7 @@                                 _ -> panic "genCall': unknown calling conv."          argReps = map (cmmExprType platform) args-        (argHints, _) = foreignTargetHints target+        (_, argHints) = foreignTargetHints target          roundTo a x | x `mod` a == 0 = x                     | otherwise = x + a - (x `mod` a)@@ -1895,8 +1988,15 @@                          -- "Single precision floating point values                          -- are mapped to the second word in a single                          -- doubleword"-                         GCP64ELF 1      -> stackOffset' + 4-                         _               -> stackOffset'+                         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'')@@ -1921,6 +2021,8 @@                           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@@ -1931,6 +2033,9 @@                           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)@@ -1942,6 +2047,8 @@                           -- the FPRs.                           FF32 -> (1, 1, 8, fprs)                           FF64 -> (1, 1, 8, fprs)+                          VecFormat {}+                               -> panic "genCCall' passArguments vector format"          moveResult reduceToFF32 =             case dest_regs of@@ -1953,14 +2060,14 @@                        -> toOL [MR (getHiVRegFromLo r_dest) r3,                                 MR r_dest r4]                     | otherwise -> unitOL (MR r_dest r3)-                    where rep = cmmRegType platform (CmmLocal dest)+                    where rep = cmmRegType (CmmLocal dest)                           r_dest = getLocalRegReg dest                 _ -> panic "genCCall' moveResult: Bad dest_regs"          outOfLineMachOp mop =             do                 mopExpr <- cmmMakeDynamicReference config CallReference $-                              mkForeignLabel functionName Nothing ForeignLabelInThisPackage IsFunction+                              mkForeignLabel functionName ForeignLabelInThisPackage IsFunction                 let mopLabelOrExpr = case mopExpr of                         CmmLit (CmmLabel lbl) -> Left lbl                         _ -> Right mopExpr@@ -2068,8 +2175,8 @@                     MO_AtomicRMW {} -> unsupported                     MO_Cmpxchg w -> (cmpxchgLabel w, False)                     MO_Xchg w    -> (xchgLabel w, False)-                    MO_AtomicRead _  -> unsupported-                    MO_AtomicWrite _ -> unsupported+                    MO_AtomicRead _ _  -> unsupported+                    MO_AtomicWrite _ _ -> unsupported                      MO_S_Mul2    {}  -> unsupported                     MO_S_QuotRem {}  -> unsupported@@ -2081,8 +2188,17 @@                     MO_AddIntC {}    -> unsupported                     MO_SubIntC {}    -> unsupported                     MO_U_Mul2 {}     -> unsupported-                    MO_ReadBarrier   -> unsupported-                    MO_WriteBarrier  -> 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@@ -2146,7 +2262,7 @@     -- See Note [Sub-word subtlety during jump-table indexing] in     -- GHC.CmmToAsm.X86.CodeGen for why we must first offset, then widen.     indexExpr0 = cmmOffset platform expr offset-    -- We widen to a native-width register to santize the high bits+    -- We widen to a native-width register to sanitize the high bits     indexExpr = CmmMachOp       (MO_UU_Conv expr_w (platformWordWidth platform))       [indexExpr0]@@ -2360,10 +2476,28 @@     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
GHC/CmmToAsm/PPC/Instr.hs view
@@ -1,5 +1,3 @@-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}- ----------------------------------------------------------------------------- -- -- Machine-dependent assembly language@@ -22,6 +20,7 @@    , patchJumpInstr    , patchRegsOfInstr    , jumpDestsOfInstr+   , canFallthroughTo    , takeRegRegMoveInstr    , takeDeltaInstr    , mkRegRegMoveInstr@@ -33,7 +32,7 @@    ) where -import GHC.Prelude+import GHC.Prelude hiding (head, init, last, tail)  import GHC.CmmToAsm.PPC.Regs import GHC.CmmToAsm.PPC.Cond@@ -42,23 +41,24 @@ import GHC.CmmToAsm.Format import GHC.CmmToAsm.Reg.Target import GHC.CmmToAsm.Config-import GHC.Platform.Reg.Class+import GHC.Platform.Reg.Class.Unified import GHC.Platform.Reg  import GHC.Platform.Regs import GHC.Cmm.BlockId-import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Label import GHC.Cmm import GHC.Cmm.Info import GHC.Cmm.CLabel-import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Platform import GHC.Types.Unique.FM (listToUFM, lookupUFM)-import GHC.Types.Unique.Supply+import GHC.Types.Unique.DSM -import Data.Maybe (fromMaybe)+import Data.Foldable (toList)+import qualified Data.List.NonEmpty as NE+import GHC.Data.FastString (FastString)+import GHC.Data.Maybe (expectJust, fromMaybe)   --------------------------------------------------------------------------------@@ -103,7 +103,7 @@   :: Platform   -> Int   -> NatCmmDecl statics GHC.CmmToAsm.PPC.Instr.Instr-  -> UniqSM (NatCmmDecl statics GHC.CmmToAsm.PPC.Instr.Instr, [(BlockId,BlockId)])+  -> 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@@ -115,7 +115,7 @@                         | entry `elem` infos -> infos                         | otherwise          -> entry : infos -    uniqs <- getUniquesM+    retargetList <- mapM (\e -> (e,) <$> newBlockId) entries      let         delta = ((x + stackAlign - 1) `quot` stackAlign) * stackAlign -- round up@@ -124,8 +124,6 @@         alloc   = mkStackAllocInstr   platform delta         dealloc = mkStackDeallocInstr platform delta -        retargetList = (zip entries (map mkBlockId uniqs))-         new_blockmap :: LabelMap BlockId         new_blockmap = mapFromList retargetList @@ -177,7 +175,7 @@  data Instr     -- comment pseudo-op-    = COMMENT SDoc+    = COMMENT FastString      -- location pseudo-op (file, line, col, name)     | LOCATION Int Int Int String@@ -219,11 +217,11 @@                                     --    Just True:  branch likely taken                                     --    Just False: branch likely not taken                                     --    Nothing:    no hint-    | JMP     CLabel [Reg]          -- same as branch,+    | JMP     CLabel [RegWithFormat]    -- same as branch,                                     -- but with CLabel instead of block ID                                     -- and live global registers     | MTCTR   Reg-    | BCTR    [Maybe BlockId] (Maybe CLabel) [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@@ -278,6 +276,14 @@     | 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@@ -323,9 +329,9 @@     CMPL    _ reg ri         -> usage (reg : regRI ri,[])     BCC     _ _ _            -> noUsage     BCCFAR  _ _ _            -> noUsage-    JMP     _ regs           -> usage (regs, [])+    JMP     _ regs           -> usage (map regWithFormat_reg regs, [])     MTCTR   reg              -> usage ([reg],[])-    BCTR    _ _ regs         -> usage (regs, [])+    BCTR    _ _ regs         -> usage (map regWithFormat_reg regs, [])     BL      _ params         -> usage (params, callClobberedRegs platform)     BCTRL   params           -> usage (params, callClobberedRegs platform) @@ -378,10 +384,18 @@     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 (filter (interesting platform) src)-                          (filter (interesting platform) dst)+    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] @@ -465,6 +479,8 @@     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)@@ -497,7 +513,14 @@     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.@@ -527,12 +550,12 @@ -- | An instruction to spill a register into a spill slot. mkSpillInstr    :: NCGConfig-   -> Reg       -- register to spill+   -> RegWithFormat -- register to spill    -> Int       -- current stack delta    -> Int       -- spill slot to use    -> [Instr] -mkSpillInstr config reg delta slot+mkSpillInstr config (RegWithFormat reg _fmt) delta slot   = let platform = ncgPlatform config         off      = spillSlotToOffset platform slot         arch     = platformArch platform@@ -541,8 +564,7 @@                 RcInteger -> case arch of                                 ArchPPC -> II32                                 _       -> II64-                RcDouble  -> FF64-                _         -> panic "PPC.Instr.mkSpillInstr: no match"+                RcFloatOrVector  -> FF64         instr = case makeImmediate W32 True (off-delta) of                 Just _  -> ST                 Nothing -> STFAR -- pseudo instruction: 32 bit offsets@@ -552,12 +574,12 @@  mkLoadInstr    :: NCGConfig-   -> Reg       -- register to load+   -> RegWithFormat -- register to load    -> Int       -- current stack delta    -> Int       -- spill slot to use    -> [Instr] -mkLoadInstr config reg delta slot+mkLoadInstr config (RegWithFormat reg _fmt) delta slot   = let platform = ncgPlatform config         off      = spillSlotToOffset platform slot         arch     = platformArch platform@@ -566,8 +588,7 @@                 RcInteger ->  case arch of                                  ArchPPC -> II32                                  _       -> II64-                RcDouble  -> FF64-                _         -> panic "PPC.Instr.mkLoadInstr: no match"+                RcFloatOrVector  -> FF64         instr = case makeImmediate W32 True (off-delta) of                 Just _  -> LD                 Nothing -> LDFAR -- pseudo instruction: 32 bit offsets@@ -645,12 +666,14 @@ -- | Copy the value in a register to another one. -- Must work for all register classes. mkRegRegMoveInstr-    :: Reg+    :: Format     -> Reg+    -> Reg     -> Instr -mkRegRegMoveInstr src dst+mkRegRegMoveInstr _fmt src dst     = MR dst src+    -- SIMD NCG TODO: handle vector format   -- | Make an unconditional jump instruction.@@ -675,14 +698,16 @@ -- big, we have to work around this limitation.  makeFarBranches-        :: LabelMap RawCmmStatics-        -> [NatBasicBlock Instr]+        :: Platform+        -> LabelMap RawCmmStatics         -> [NatBasicBlock Instr]-makeFarBranches info_env blocks-    | last blockAddresses < nearLimit = blocks-    | otherwise = zipWith handleBlock blockAddresses blocks+        -> UniqDSM [NatBasicBlock Instr]+makeFarBranches _platform info_env blocks+    | NE.last blockAddresses < nearLimit = return blocks+    | otherwise = return $ zipWith handleBlock blockAddressList blocks     where-        blockAddresses = scanl (+) 0 $ map blockLen blocks+        blockAddresses = NE.scanl (+) 0 $ map blockLen blocks+        blockAddressList = toList blockAddresses         blockLen (BasicBlock _ instrs) = length instrs          handleBlock addr (BasicBlock id instrs)@@ -694,7 +719,7 @@             = BCCFAR cond tgt p             | otherwise             = BCC cond tgt p-            where Just targetAddr = lookupUFM blockAddressMap tgt+            where targetAddr = expectJust $ lookupUFM blockAddressMap tgt         makeFar _ other            = other          -- 8192 instructions are allowed; let's keep some distance, as@@ -703,4 +728,4 @@         -- to calculate things exactly         nearLimit = 7000 - mapSize info_env * maxRetInfoTableSizeW -        blockAddressMap = listToUFM $ zip (map blockId blocks) blockAddresses+        blockAddressMap = listToUFM $ zip (map blockId blocks) blockAddressList
GHC/CmmToAsm/PPC/Ppr.hs view
@@ -22,19 +22,17 @@ import GHC.CmmToAsm.Ppr import GHC.CmmToAsm.Format import GHC.Platform.Reg-import GHC.Platform.Reg.Class+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.Collections import GHC.Cmm.Dataflow.Label  import GHC.Cmm.BlockId import GHC.Cmm.CLabel-import GHC.Cmm.Ppr.Expr () -- For Outputable instances  import GHC.Types.Unique ( pprUniqueAlways, getUnique ) import GHC.Platform@@ -47,7 +45,7 @@ -- ----------------------------------------------------------------------------- -- Printing this stuff out -pprNatCmmDecl :: NCGConfig -> NatCmmDecl RawCmmStatics Instr -> SDoc+pprNatCmmDecl :: IsDoc doc => NCGConfig -> NatCmmDecl RawCmmStatics Instr -> doc pprNatCmmDecl config (CmmData section dats) =   pprSectionAlign config section   $$ pprDatas (ncgPlatform config) dats@@ -64,15 +62,15 @@             _ -> pprLabel platform lbl) $$ -- blocks guaranteed not null,                                            -- so label needed          vcat (map (pprBasicBlock config top_info) blocks) $$-         ppWhen (ncgDwarfEnabled config) (pdoc platform (mkAsmTempEndLabel lbl)-                                          <> char ':' $$-                                          pprProcEndLabel platform lbl) $$+         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 pdoc platform (mkDeadStripPreventer info_lbl) <> char ':'+          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@@ -80,66 +78,66 @@       (if platformHasSubsectionsViaSymbols platform        then        -- See Note [Subsections Via Symbols] in X86/Ppr.hs-                text "\t.long "-            <+> pdoc platform info_lbl-            <+> char '-'-            <+> pdoc platform (mkDeadStripPreventer info_lbl)+                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 :: Platform -> CLabel -> SDoc+pprSizeDecl :: IsDoc doc => Platform -> CLabel -> doc pprSizeDecl platform lbl  = if osElfTarget (platformOS platform)-   then text "\t.size" <+> prettyLbl <> text ", .-" <> codeLbl+   then line (text "\t.size" <+> prettyLbl <> text ", .-" <> codeLbl)    else empty   where-    prettyLbl = pdoc platform lbl+    prettyLbl = pprAsmLabel platform lbl     codeLbl       | platformArch platform == ArchPPC_64 ELF_V1 = char '.' <> prettyLbl       | otherwise                                  = prettyLbl -pprFunctionDescriptor :: Platform -> CLabel -> SDoc-pprFunctionDescriptor platform lab = pprGloblDecl platform lab-                        $$  text "\t.section \".opd\", \"aw\""-                        $$  text "\t.align 3"-                        $$  pdoc platform lab <> char ':'-                        $$  text "\t.quad ."-                        <>  pdoc platform lab-                        <>  text ",.TOC.@tocbase,0"-                        $$  text "\t.previous"-                        $$  text "\t.type"-                        <+> pdoc platform lab-                        <>  text ", @function"-                        $$  char '.' <> pdoc platform lab <> char ':'+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 :: Platform -> CLabel ->SDoc-pprFunctionPrologue platform lab =  pprGloblDecl platform lab-                        $$  text ".type "-                        <> pdoc platform lab-                        <> text ", @function"-                        $$ pdoc platform 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" <> pdoc platform lab-                        <> text ",.-" <> pdoc platform lab+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 :: Platform -> CLabel -- ^ Procedure name-                -> SDoc+pprProcEndLabel :: IsLine doc => Platform -> CLabel -- ^ Procedure name+                -> doc pprProcEndLabel platform lbl =-    pdoc platform (mkAsmTempProcEndLabel lbl) <> char ':'+    pprAsmLabel platform (mkAsmTempProcEndLabel lbl) <> char ':' -pprBasicBlock :: NCGConfig -> LabelMap RawCmmStatics -> NatBasicBlock Instr-              -> SDoc+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) (-      pdoc platform (mkAsmTempEndLabel asmLbl) <> char ':'-      <> pprProcEndLabel platform asmLbl+      line (pprAsmLabel platform (mkAsmTempEndLabel asmLbl) <> char ':'+            <> pprProcEndLabel platform asmLbl)     )   where     asmLbl = blockLbl blockid@@ -153,7 +151,7 @@   -pprDatas :: Platform -> RawCmmStatics -> SDoc+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@@ -163,49 +161,49 @@   , Just ind' <- labelInd ind   , alias `mayRedirectTo` ind'   = pprGloblDecl platform alias-    $$ text ".equiv" <+> pdoc platform alias <> comma <> pdoc platform (CmmLabel ind')+    $$ line (text ".equiv" <+> pprAsmLabel platform alias <> comma <> pprAsmLabel platform ind') pprDatas platform (CmmStaticsRaw lbl dats) = vcat (pprLabel platform lbl : map (pprData platform) dats) -pprData :: Platform -> CmmStatic -> SDoc+pprData :: IsDoc doc => Platform -> CmmStatic -> doc pprData platform d = case d of-   CmmString str          -> pprString str-   CmmFileEmbed path      -> pprFileEmbed path-   CmmUninitialised bytes -> text ".space " <> int bytes+   CmmString str          -> line (pprString str)+   CmmFileEmbed path _    -> line (pprFileEmbed path)+   CmmUninitialised bytes -> line (text ".space " <> int bytes)    CmmStaticLit lit       -> pprDataItem platform lit -pprGloblDecl :: Platform -> CLabel -> SDoc+pprGloblDecl :: IsDoc doc => Platform -> CLabel -> doc pprGloblDecl platform lbl   | not (externallyVisibleCLabel lbl) = empty-  | otherwise = text ".globl " <> pdoc platform lbl+  | otherwise = line (text ".globl " <> pprAsmLabel platform lbl) -pprTypeAndSizeDecl :: Platform -> CLabel -> SDoc+pprTypeAndSizeDecl :: IsLine doc => Platform -> CLabel -> doc pprTypeAndSizeDecl platform lbl   = if platformOS platform == OSLinux && externallyVisibleCLabel lbl     then text ".type " <>-         pdoc platform lbl <> text ", @object"+         pprAsmLabel platform lbl <> text ", @object"     else empty -pprLabel :: Platform -> CLabel -> SDoc+pprLabel :: IsDoc doc => Platform -> CLabel -> doc pprLabel platform lbl =    pprGloblDecl platform lbl-   $$ pprTypeAndSizeDecl platform lbl-   $$ (pdoc platform lbl <> char ':')+   $$ line (pprTypeAndSizeDecl platform lbl)+   $$ line (pprAsmLabel platform lbl <> char ':')  -- ----------------------------------------------------------------------------- -- pprInstr: print an 'Instr' -pprReg :: Reg -> SDoc+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 (VirtualRegF  u)  -> text "%vF_"   <> pprUniqueAlways u-      RegVirtual (VirtualRegD  u)  -> text "%vD_"   <> pprUniqueAlways u+      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 -> SDoc+    ppr_reg_no :: Int -> doc     ppr_reg_no i          | i <= 31   = int i      -- GPRs          | i <= 63   = int (i-32) -- FPRs@@ -213,7 +211,7 @@   -pprFormat :: Format -> SDoc+pprFormat :: IsLine doc => Format -> doc pprFormat x  = case x of                 II8  -> text "b"@@ -222,9 +220,9 @@                 II64 -> text "d"                 FF32 -> text "fs"                 FF64 -> text "fd"-+                VecFormat {} -> panic "PPC pprFormat: VecFormat" -pprCond :: Cond -> SDoc+pprCond :: IsLine doc => Cond -> doc pprCond c  = case c of {                 ALWAYS  -> text "";@@ -235,13 +233,13 @@                 GU      -> text "gt";  LEU   -> text "le"; }  -pprImm :: Platform -> Imm -> SDoc+pprImm :: IsLine doc => Platform -> Imm -> doc pprImm platform = \case    ImmInt i       -> int i    ImmInteger i   -> integer i-   ImmCLbl l      -> pdoc platform l-   ImmIndex l i   -> pdoc platform l <> char '+' <> int i-   ImmLit s       -> s+   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@@ -265,7 +263,7 @@    HIGHESTA i  -> pprImm platform i <> text "@highesta"  -pprAddr :: Platform -> AddrMode -> SDoc+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 ')' ]@@ -273,14 +271,14 @@    AddrRegImm r1 imm            -> hcat [ pprImm platform imm, char '(', pprReg r1, char ')' ]  -pprSectionAlign :: NCGConfig -> Section -> SDoc+pprSectionAlign :: IsDoc doc => NCGConfig -> Section -> doc pprSectionAlign config sec@(Section seg _) =-   pprSectionHeader config sec $$+   line (pprSectionHeader config sec) $$    pprAlignForSection (ncgPlatform config) seg  -- | Print appropriate alignment for the given section type.-pprAlignForSection :: Platform -> SectionType -> SDoc-pprAlignForSection platform seg =+pprAlignForSection :: IsDoc doc => Platform -> SectionType -> doc+pprAlignForSection platform seg = line $  let ppc64    = not $ target32Bit platform  in case seg of        Text              -> text ".align 2"@@ -296,7 +294,6 @@        UninitialisedData         | ppc64          -> text ".align 3"         | otherwise      -> text ".align 2"-       ReadOnlyData16    -> text ".align 4"        -- TODO: This is copied from the ReadOnlyData case, but it can likely be        -- made more efficient.        InitArray         -> text ".align 3"@@ -306,9 +303,9 @@         | otherwise      -> text ".align 2"        OtherSection _    -> panic "PprMach.pprSectionAlign: unknown section" -pprDataItem :: Platform -> CmmLit -> SDoc+pprDataItem :: IsDoc doc => Platform -> CmmLit -> doc pprDataItem platform lit-  = vcat (ppr_item (cmmTypeFormat $ cmmLitType platform lit) lit)+  = lines_ (ppr_item (cmmTypeFormat $ cmmLitType platform lit) lit)     where         imm = litToImm lit         archPPC_64 = not $ target32Bit platform@@ -335,21 +332,21 @@                 = panic "PPC.Ppr.pprDataItem: no match"  -asmComment :: SDoc -> SDoc+asmComment :: IsLine doc => doc -> doc asmComment c = whenPprDebug $ text "#" <+> c  -pprInstr :: Platform -> Instr -> SDoc+pprInstr :: IsDoc doc => Platform -> Instr -> doc pprInstr platform instr = case instr of     COMMENT s-      -> asmComment s+      -> line (asmComment (ftext s)) -   LOCATION file line col _name-      -> text "\t.loc" <+> ppr file <+> ppr line <+> ppr col+   LOCATION file line' col _name+      -> line (text "\t.loc" <+> int file <+> int line' <+> int col)     DELTA d-      -> asmComment $ text ("\tdelta = " ++ show d)+      -> line (asmComment $ text ("\tdelta = " ++ show d))     NEWBLOCK _       -> panic "PprMach.pprInstr: NEWBLOCK"@@ -376,7 +373,7 @@ -}     LD fmt reg addr-      -> hcat [+      -> line $ hcat [            char '\t',            text "l",            (case fmt of@@ -386,6 +383,7 @@                II64 -> text "d"                FF32 -> text "fs"                FF64 -> text "fd"+               VecFormat {} -> panic "PPC pprInstr: VecFormat"                ),            case addr of AddrRegImm _ _ -> empty                         AddrRegReg _ _ -> char 'x',@@ -405,7 +403,7 @@       -> panic "PPC.Ppr.pprInstr LDFAR: no match"     LDR fmt reg1 addr-      -> hcat [+      -> line $ hcat [            text "\tl",            case fmt of              II32 -> char 'w'@@ -418,7 +416,7 @@            ]     LA fmt reg addr-      -> hcat [+      -> line $ hcat [            char '\t',            text "l",            (case fmt of@@ -428,6 +426,7 @@                II64 -> text "d"                FF32 -> text "fs"                FF64 -> text "fd"+               VecFormat {} -> panic "PPC pprInstr: VecFormat"                ),            case addr of AddrRegImm _ _ -> empty                         AddrRegReg _ _ -> char 'x',@@ -438,7 +437,7 @@            ]     ST fmt reg addr-      -> hcat [+      -> line $ hcat [            char '\t',            text "st",            pprFormat fmt,@@ -459,7 +458,7 @@       -> panic "PPC.Ppr.pprInstr STFAR: no match"     STU fmt reg addr-      -> hcat [+      -> line $ hcat [            char '\t',            text "st",            pprFormat fmt,@@ -473,7 +472,7 @@            ]     STC fmt reg1 addr-      -> hcat [+      -> line $ hcat [            text "\tst",            case fmt of              II32 -> char 'w'@@ -486,7 +485,7 @@            ]     LIS reg imm-      -> hcat [+      -> line $ hcat [            char '\t',            text "lis",            char '\t',@@ -496,7 +495,7 @@            ]     LI reg imm-      -> hcat [+      -> line $ hcat [            char '\t',            text "li",            char '\t',@@ -507,11 +506,11 @@     MR reg1 reg2     | reg1 == reg2 -> empty-    | otherwise    -> hcat [+    | otherwise    -> line $ hcat [         char '\t',         case targetClassOfReg platform reg1 of             RcInteger -> text "mr"-            _ -> text "fmr",+            RcFloatOrVector -> text "fmr",         char '\t',         pprReg reg1,         text ", ",@@ -519,7 +518,7 @@         ]     CMP fmt reg ri-      -> hcat [+      -> line $ hcat [            char '\t',            op,            char '\t',@@ -537,7 +536,7 @@                ]     CMPL fmt reg ri-      -> hcat [+      -> line $ hcat [            char '\t',            op,            char '\t',@@ -555,13 +554,13 @@                   ]     BCC cond blockid prediction-      -> hcat [+      -> line $ hcat [            char '\t',            text "b",            pprCond cond,            pprPrediction prediction,            char '\t',-           pdoc platform lbl+           pprAsmLabel platform lbl            ]          where lbl = mkLocalBlockLabel (getUnique blockid)                pprPrediction p = case p of@@ -570,7 +569,7 @@                  Just False -> char '-'     BCCFAR cond blockid prediction-      -> vcat [+      -> lines_ [            hcat [                text "\tb",                pprCond (condNegate cond),@@ -579,7 +578,7 @@            ],            hcat [                text "\tb\t",-               pdoc platform lbl+               pprAsmLabel platform lbl            ]           ]           where lbl = mkLocalBlockLabel (getUnique blockid)@@ -589,18 +588,20 @@                   Just False -> char '+'     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"+     | 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 ->-       hcat [ -- an alias for b that takes a CLabel-           char '\t',-           text "b",-           char '\t',-           pdoc platform lbl+       line $ hcat [ -- an alias for b that takes a CLabel+           text "\tb\t",+           pprAsmLabel platform lbl        ]     MTCTR reg-      -> hcat [+      -> line $ hcat [            char '\t',            text "mtctr",            char '\t',@@ -608,7 +609,7 @@         ]     BCTR _ _ _-      -> hcat [+      -> line $ hcat [            char '\t',            text "bctr"          ]@@ -616,6 +617,8 @@    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.@@ -625,18 +628,18 @@              -- but when profiling the codegen inserts calls via              -- 'emitRtsCallGen' which are 'CmmLabel's even though              -- they'd technically be more like 'ForeignLabel's.-             hcat [+             line $ hcat [                text "\tbl\t.",-               pdoc platform lbl+               pprAsmLabel platform lbl              ]            _ ->-             hcat [+             line $ hcat [                text "\tbl\t",-               pdoc platform lbl+               pprAsmLabel platform lbl              ]     BCTRL _-      -> hcat [+      -> line $ hcat [              char '\t',              text "bctrl"          ]@@ -645,7 +648,7 @@       -> pprLogic platform (text "add") reg1 reg2 ri     ADDIS reg1 reg2 imm-      -> hcat [+      -> line $ hcat [            char '\t',            text "addis",            char '\t',@@ -675,7 +678,7 @@       -> pprLogic platform (text "subfo") reg1 reg2 (RIReg reg3)     SUBFC reg1 reg2 ri-      -> hcat [+      -> line $ hcat [            char '\t',            text "subf",            case ri of@@ -696,7 +699,7 @@       -> pprMul platform fmt reg1 reg2 ri     MULLO fmt reg1 reg2 reg3-      -> hcat [+      -> line $ hcat [              char '\t',              text "mull",              case fmt of@@ -713,13 +716,13 @@     MFOV fmt reg       -> vcat [-           hcat [+           line $ hcat [                char '\t',                text "mfxer",                char '\t',                pprReg reg                ],-           hcat [+           line $ hcat [                char '\t',                text "extr",                case fmt of@@ -739,7 +742,7 @@            ]     MULHU fmt reg1 reg2 reg3-      -> hcat [+      -> line $ hcat [             char '\t',             text "mulh",             case fmt of@@ -760,7 +763,7 @@         -- for some reason, "andi" doesn't exist.         -- we'll use "andi." instead.    AND reg1 reg2 (RIImm imm)-      -> hcat [+      -> line $ hcat [             char '\t',             text "andi.",             char '\t',@@ -787,7 +790,7 @@       -> pprLogic platform (text "xor") reg1 reg2 ri     ORIS reg1 reg2 imm-      -> hcat [+      -> line $ hcat [             char '\t',             text "oris",             char '\t',@@ -799,7 +802,7 @@         ]     XORIS reg1 reg2 imm-      -> hcat [+      -> line $ hcat [             char '\t',             text "xoris",             char '\t',@@ -811,7 +814,7 @@         ]     EXTS fmt reg1 reg2-      -> hcat [+      -> line $ hcat [            char '\t',            text "exts",            pprFormat fmt,@@ -822,7 +825,7 @@          ]     CNTLZ fmt reg1 reg2-      -> hcat [+      -> line $ hcat [            char '\t',            text "cntlz",            case fmt of@@ -883,7 +886,7 @@          in pprLogic platform op reg1 reg2 (limitShiftRI fmt ri)     RLWINM reg1 reg2 sh mb me-      -> hcat [+      -> line $ hcat [              text "\trlwinm\t",              pprReg reg1,              text ", ",@@ -897,7 +900,7 @@          ]     CLRLI fmt reg1 reg2 n-      -> hcat [+      -> line $ hcat [             text "\tclrl",             pprFormat fmt,             text "i ",@@ -909,7 +912,7 @@         ]     CLRRI fmt reg1 reg2 n-      -> hcat [+      -> line $ hcat [             text "\tclrr",             pprFormat fmt,             text "i ",@@ -938,8 +941,11 @@    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-      -> hcat [+      -> line $ hcat [            char '\t',            text "fcmpu\t0, ",                -- Note: we're using fcmpu, not fcmpo@@ -967,7 +973,7 @@       -> pprUnary (text "frsp") reg1 reg2     CRNOR dst src1 src2-      -> hcat [+      -> line $ hcat [            text "\tcrnor\t",            int dst,            text ", ",@@ -977,7 +983,7 @@          ]     MFCR reg-      -> hcat [+      -> line $ hcat [              char '\t',              text "mfcr",              char '\t',@@ -985,7 +991,7 @@          ]     MFLR reg-      -> hcat [+      -> line $ hcat [            char '\t',            text "mflr",            char '\t',@@ -993,25 +999,25 @@          ]     FETCHPC reg-      -> vcat [+      -> lines_ [              text "\tbcl\t20,31,1f",              hcat [ text "1:\tmflr\t", pprReg reg ]          ]     HWSYNC-      -> text "\tsync"+      -> line $ text "\tsync"     ISYNC-      -> text "\tisync"+      -> line $ text "\tisync"     LWSYNC-      -> text "\tlwsync"+      -> line $ text "\tlwsync"     NOP-      -> text "\tnop"+      -> line $ text "\tnop" -pprLogic :: Platform -> SDoc -> Reg -> Reg -> RI -> SDoc-pprLogic platform op reg1 reg2 ri = hcat [+pprLogic :: IsDoc doc => Platform -> Line doc -> Reg -> Reg -> RI -> doc+pprLogic platform op reg1 reg2 ri = line $ hcat [         char '\t',         op,         case ri of@@ -1026,8 +1032,8 @@     ]  -pprMul :: Platform -> Format -> Reg -> Reg -> RI -> SDoc-pprMul platform fmt reg1 reg2 ri = hcat [+pprMul :: IsDoc doc => Platform -> Format -> Reg -> Reg -> RI -> doc+pprMul platform fmt reg1 reg2 ri = line $ hcat [         char '\t',         text "mull",         case ri of@@ -1045,8 +1051,8 @@     ]  -pprDiv :: Format -> Bool -> Reg -> Reg -> Reg -> SDoc-pprDiv fmt sgn reg1 reg2 reg3 = hcat [+pprDiv :: IsDoc doc => Format -> Bool -> Reg -> Reg -> Reg -> doc+pprDiv fmt sgn reg1 reg2 reg3 = line $ hcat [         char '\t',         text "div",         case fmt of@@ -1063,8 +1069,8 @@     ]  -pprUnary :: SDoc -> Reg -> Reg -> SDoc-pprUnary op reg1 reg2 = hcat [+pprUnary :: IsDoc doc => Line doc -> Reg -> Reg -> doc+pprUnary op reg1 reg2 = line $ hcat [         char '\t',         op,         char '\t',@@ -1074,8 +1080,8 @@     ]  -pprBinaryF :: SDoc -> Format -> Reg -> Reg -> Reg -> SDoc-pprBinaryF op fmt reg1 reg2 reg3 = hcat [+pprBinaryF :: IsDoc doc => Line doc -> Format -> Reg -> Reg -> Reg -> doc+pprBinaryF op fmt reg1 reg2 reg3 = line $ hcat [         char '\t',         op,         pprFFormat fmt,@@ -1087,12 +1093,27 @@         pprReg reg3     ] -pprRI :: Platform -> RI -> SDoc+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 :: Format -> SDoc+pprFFormat :: IsLine doc => Format -> doc pprFFormat FF64     = empty pprFFormat FF32     = char 's' pprFFormat _        = panic "PPC.Ppr.pprFFormat: no match"
GHC/CmmToAsm/PPC/Regs.hs view
@@ -28,7 +28,6 @@         callClobberedRegs,         allMachRegNos,         classOfRealReg,-        showReg,         toRegNo,          -- machine specific@@ -47,9 +46,10 @@ where  import GHC.Prelude+import GHC.Data.FastString  import GHC.Platform.Reg-import GHC.Platform.Reg.Class+import GHC.Platform.Reg.Class.Unified import GHC.CmmToAsm.Format  import GHC.Cmm@@ -82,14 +82,12 @@                 VirtualRegHi{}          -> 1                 _other                  -> 0 -        RcDouble+        RcFloatOrVector          -> case vr of                 VirtualRegD{}           -> 1-                VirtualRegF{}           -> 0+                VirtualRegV128{}        -> 1                 _other                  -> 0 -        _other -> 0- {-# INLINE realRegSqueeze #-} realRegSqueeze :: RegClass -> RealReg -> Int realRegSqueeze cls rr@@ -101,15 +99,13 @@                         | otherwise     -> 0  -        RcDouble+        RcFloatOrVector          -> case rr of                 RealRegSingle regNo                         | regNo < 32    -> 0                         | otherwise     -> 1  -        _other -> 0- mkVirtualReg :: Unique -> Format -> VirtualReg mkVirtualReg u format    | not (isFloatFormat format) = VirtualRegI u@@ -123,8 +119,7 @@ regDotColor reg  = case classOfRealReg reg of         RcInteger       -> text "blue"-        RcFloat         -> text "red"-        RcDouble        -> text "green"+        RcFloatOrVector -> text "red"   @@ -133,7 +128,7 @@         = ImmInt        Int         | ImmInteger    Integer     -- Sigh.         | ImmCLbl       CLabel      -- AbstractC Label (with baggage)-        | ImmLit        SDoc        -- Simple string+        | ImmLit        FastString         | ImmIndex    CLabel Int         | ImmFloat      Rational         | ImmDouble     Rational@@ -146,8 +141,8 @@         | HIGHESTA Imm  -strImmLit :: String -> Imm-strImmLit s = ImmLit (text s)+strImmLit :: FastString -> Imm+strImmLit s = ImmLit s   litToImm :: CmmLit -> Imm@@ -234,14 +229,8 @@ {-# INLINE classOfRealReg      #-} classOfRealReg :: RealReg -> RegClass classOfRealReg (RealRegSingle i)-        | i < 32        = RcInteger-        | otherwise     = RcDouble--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+        | i < 32    = RcInteger+        | otherwise = RcFloatOrVector  toRegNo :: Reg -> RegNo toRegNo (RegReal (RealRegSingle n)) = n
GHC/CmmToAsm/Ppr.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-}  -----------------------------------------------------------------------------@@ -27,7 +26,6 @@ import GHC.Cmm import GHC.CmmToAsm.Config import GHC.Utils.Outputable as SDoc-import qualified GHC.Utils.Ppr as Pretty import GHC.Utils.Panic import GHC.Platform @@ -41,11 +39,6 @@ import GHC.Exts import GHC.Word -#if !MIN_VERSION_base(4,16,0)-word8ToWord# :: Word# -> Word#-word8ToWord# w = w-{-# INLINE word8ToWord# #-}-#endif  -- ----------------------------------------------------------------------------- -- Converting floating-point literals to integrals for printing@@ -89,7 +82,7 @@ -- Print as a string and escape non-printable characters. -- This is similar to charToC in GHC.Utils.Misc -pprASCII :: ByteString -> SDoc+pprASCII :: forall doc. IsLine doc => ByteString -> doc pprASCII str   -- Transform this given literal bytestring to escaped string and construct   -- the literal SDoc directly.@@ -98,19 +91,19 @@   --   -- We work with a `Doc` instead of an `SDoc` because there is no need to carry   -- an `SDocContext` that we don't use. It leads to nicer (STG) code.-  = docToSDoc (BS.foldr f Pretty.empty str)+  = BS.foldr f empty str     where-       f :: Word8 -> Pretty.Doc -> Pretty.Doc-       f w s = do1 w Pretty.<> s+       f :: Word8 -> doc -> doc+       f w s = do1 w <> s -       do1 :: Word8 -> Pretty.Doc-       do1 w | 0x09 == w = Pretty.text "\\t"-             | 0x0A == w = Pretty.text "\\n"-             | 0x22 == w = Pretty.text "\\\""-             | 0x5C == w = Pretty.text "\\\\"+       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 = Pretty.char (chr' w)-             | otherwise = Pretty.sizedText 4 xs+             | w >= 0x20 && w <= 0x7E = char (chr' w)+             | otherwise = text xs                 where                  !xs = [ '\\', x0, x1, x2] -- octal                  !x0 = chr' (ord0 + (w `unsafeShiftR` 6) .&. 0x07)@@ -122,20 +115,25 @@        -- 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 :: ByteString -> SDoc+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 :: FilePath -> SDoc+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]@@ -193,14 +191,16 @@ -- 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 :: NCGConfig -> Section -> SDoc+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 :: NCGConfig -> SectionType -> CLabel -> SDoc+pprGNUSectionHeader :: IsLine doc => NCGConfig -> SectionType -> CLabel -> doc pprGNUSectionHeader config t suffix =   hcat [text ".section ", header, subsection, flags]   where@@ -210,7 +210,7 @@     platform      = ncgPlatform config     splitSections = ncgSplitSections config     subsection-      | splitSections = sep <> pdoc platform suffix+      | splitSections = sep <> pprAsmLabel platform suffix       | otherwise     = empty     header = case t of       Text -> text ".text"@@ -224,9 +224,6 @@                                           -> text ".rdata$rel.ro"                               | otherwise -> text ".data.rel.ro"       UninitialisedData -> text ".bss"-      ReadOnlyData16 | OSMinGW32 <- platformOS platform-                                 -> text ".rdata$cst16"-                     | otherwise -> text ".rodata.cst16"       InitArray         | OSMinGW32 <- platformOS platform                     -> text ".ctors"@@ -242,34 +239,43 @@       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 :: SectionType -> SDoc+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"-  ReadOnlyData16          -> text ".csect .text[PR] # ReadOnlyData16"   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 :: SectionType -> SDoc+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"-  ReadOnlyData16          -> text ".const"   InitArray               -> text ".section\t__DATA,__mod_init_func,mod_init_funcs"   FiniArray               -> panic "pprDarwinSectionHeader: fini not supported"   CString                 -> text ".section\t__TEXT,__cstring,cstring_literals"   OtherSection _          -> panic "pprDarwinSectionHeader: unknown section type"+{-# SPECIALIZE pprDarwinSectionHeader :: SectionType -> SDoc #-}+{-# SPECIALIZE pprDarwinSectionHeader :: SectionType -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable
+ GHC/CmmToAsm/RV64.hs view
@@ -0,0 +1,58 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++-- | Native code generator for RiscV64 architectures+module GHC.CmmToAsm.RV64 (ncgRV64) where++import GHC.CmmToAsm.Config+import GHC.CmmToAsm.Instr+import GHC.CmmToAsm.Monad+import GHC.CmmToAsm.RV64.CodeGen qualified as RV64+import GHC.CmmToAsm.RV64.Instr qualified as RV64+import GHC.CmmToAsm.RV64.Ppr qualified as RV64+import GHC.CmmToAsm.RV64.RegInfo qualified as RV64+import GHC.CmmToAsm.RV64.Regs qualified as RV64+import GHC.CmmToAsm.Types+import GHC.Prelude+import GHC.Utils.Outputable (ftext)++ncgRV64 :: NCGConfig -> NcgImpl RawCmmStatics RV64.Instr RV64.JumpDest+ncgRV64 config =+  NcgImpl+    { ncgConfig = config,+      cmmTopCodeGen = RV64.cmmTopCodeGen,+      generateJumpTableForInstr = RV64.generateJumpTableForInstr config,+      getJumpDestBlockId = RV64.getJumpDestBlockId,+      canShortcut = RV64.canShortcut,+      shortcutStatics = RV64.shortcutStatics,+      shortcutJump = RV64.shortcutJump,+      pprNatCmmDeclS = RV64.pprNatCmmDecl config,+      pprNatCmmDeclH = RV64.pprNatCmmDecl config,+      maxSpillSlots = RV64.maxSpillSlots config,+      allocatableRegs = RV64.allocatableRegs platform,+      ncgAllocMoreStack = RV64.allocMoreStack platform,+      ncgMakeFarBranches = RV64.makeFarBranches,+      extractUnwindPoints = const [],+      invertCondBranches = \_ _ -> id+    }+  where+    platform = ncgPlatform config++-- | `Instruction` instance for RV64+instance Instruction RV64.Instr where+  regUsageOfInstr = RV64.regUsageOfInstr+  patchRegsOfInstr _ = RV64.patchRegsOfInstr+  isJumpishInstr = RV64.isJumpishInstr+  canFallthroughTo = RV64.canFallthroughTo+  jumpDestsOfInstr = RV64.jumpDestsOfInstr+  patchJumpInstr = RV64.patchJumpInstr+  mkSpillInstr = RV64.mkSpillInstr+  mkLoadInstr = RV64.mkLoadInstr+  takeDeltaInstr = RV64.takeDeltaInstr+  isMetaInstr = RV64.isMetaInstr+  mkRegRegMoveInstr _ _ = RV64.mkRegRegMoveInstr+  takeRegRegMoveInstr _ = RV64.takeRegRegMoveInstr+  mkJumpInstr = RV64.mkJumpInstr+  mkStackAllocInstr = RV64.mkStackAllocInstr+  mkStackDeallocInstr = RV64.mkStackDeallocInstr+  mkComment = pure . RV64.COMMENT . ftext+  pprInstr = RV64.pprInstr
+ GHC/CmmToAsm/RV64/CodeGen.hs view
@@ -0,0 +1,2231 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE BinaryLiterals #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++module GHC.CmmToAsm.RV64.CodeGen+  ( cmmTopCodeGen,+    generateJumpTableForInstr,+    makeFarBranches,+  )+where++import Control.Monad+import Data.Maybe+import Data.Word+import GHC.Cmm+import GHC.Cmm.BlockId+import GHC.Cmm.CLabel+import GHC.Cmm.Dataflow.Block+import GHC.Cmm.Dataflow.Graph+import GHC.Cmm.Dataflow.Label+import GHC.Cmm.DebugBlock+import GHC.Cmm.Switch+import GHC.Cmm.Utils+import GHC.CmmToAsm.CPrim+import GHC.CmmToAsm.Config+import GHC.CmmToAsm.Format+import GHC.CmmToAsm.Monad+  ( NatM,+    getBlockIdNat,+    getConfig,+    getDebugBlock,+    getFileId,+    getNewLabelNat,+    getNewRegNat,+    getPicBaseMaybeNat,+    getPlatform,+  )+import GHC.CmmToAsm.PIC+import GHC.CmmToAsm.RV64.Cond+import GHC.CmmToAsm.RV64.Instr+import GHC.CmmToAsm.RV64.Regs+import GHC.CmmToAsm.Types+import GHC.Data.FastString+import GHC.Data.OrdList+import GHC.Float+import GHC.Platform+import GHC.Platform.Reg+import GHC.Platform.Regs+import GHC.Prelude hiding (EQ)+import GHC.Types.Basic+import GHC.Types.ForeignCall+import GHC.Types.SrcLoc (srcSpanFile, srcSpanStartCol, srcSpanStartLine)+import GHC.Types.Tickish (GenTickish (..))+import GHC.Types.Unique.DSM+import GHC.Utils.Constants (debugIsOn)+import GHC.Utils.Misc+import GHC.Utils.Monad+import GHC.Utils.Outputable+import GHC.Utils.Panic++-- For an overview of an NCG's structure, see Note [General layout of an NCG]++cmmTopCodeGen ::+  RawCmmDecl ->+  NatM [NatCmmDecl RawCmmStatics Instr]+-- Thus we'll have to deal with either CmmProc ...+cmmTopCodeGen _cmm@(CmmProc info lab live graph) = do+  picBaseMb <- getPicBaseMaybeNat+  when (isJust picBaseMb) $ panic "RV64.cmmTopCodeGen: Unexpected PIC base register (RISCV ISA does not define one)"++  let blocks = toBlockListEntryFirst graph+  (nat_blocks, statics) <- mapAndUnzipM basicBlockCodeGen blocks++  let proc = CmmProc info lab live (ListGraph $ concat nat_blocks)+      tops = proc : concat statics++  pure tops++-- ... or CmmData.+cmmTopCodeGen (CmmData sec dat) = pure [CmmData sec dat] -- no translation, we just use CmmStatic++basicBlockCodeGen ::+  Block CmmNode C C ->+  NatM+    ( [NatBasicBlock Instr],+      [NatCmmDecl RawCmmStatics Instr]+    )+basicBlockCodeGen block = do+  config <- getConfig+  let (_, nodes, tail) = blockSplit block+      id = entryLabel block+      stmts = blockToList nodes++      header_comment_instr+        | debugIsOn =+            unitOL+              $ MULTILINE_COMMENT+                ( text "-- --------------------------- basicBlockCodeGen --------------------------- --\n"+                    $+$ withPprStyle defaultDumpStyle (pdoc (ncgPlatform config) block)+                )+        | otherwise = nilOL++  -- Generate location directive `.loc` (DWARF debug location info)+  loc_instrs <- genLocInstrs++  -- Generate other instructions+  mid_instrs <- stmtsToInstrs stmts+  (!tail_instrs) <- stmtToInstrs tail++  let instrs = header_comment_instr `appOL` loc_instrs `appOL` mid_instrs `appOL` tail_instrs++      -- TODO: Then x86 backend runs @verifyBasicBlock@ here. How important it is to+      -- have a valid CFG is an open question: This and the AArch64 and PPC NCGs+      -- work fine without it.++      -- Code generation may introduce new basic block boundaries, which are+      -- indicated by the NEWBLOCK instruction. We must split up the instruction+      -- stream into basic blocks again. Also, we extract LDATAs here too.+      (top, other_blocks, statics) = foldrOL mkBlocks ([], [], []) instrs++  return (BasicBlock id top : other_blocks, statics)+  where+    genLocInstrs :: NatM (OrdList Instr)+    genLocInstrs = do+      dbg <- getDebugBlock (entryLabel block)+      case dblSourceTick =<< dbg of+        Just (SourceNote span name) ->+          do+            fileId <- getFileId (srcSpanFile span)+            let line = srcSpanStartLine span; col = srcSpanStartCol span+            pure $ unitOL $ LOCATION fileId line col name+        _ -> pure nilOL++mkBlocks ::+  Instr ->+  ([Instr], [GenBasicBlock Instr], [GenCmmDecl RawCmmStatics h g]) ->+  ([Instr], [GenBasicBlock Instr], [GenCmmDecl RawCmmStatics h g])+mkBlocks (NEWBLOCK id) (instrs, blocks, statics) =+  ([], BasicBlock id instrs : blocks, statics)+mkBlocks (LDATA sec dat) (instrs, blocks, statics) =+  (instrs, blocks, CmmData sec dat : statics)+mkBlocks instr (instrs, blocks, statics) =+  (instr : instrs, blocks, statics)++-- -----------------------------------------------------------------------------++-- | Utilities++-- | Annotate an `Instr` with a `SDoc` comment+ann :: SDoc -> Instr -> Instr+ann doc instr {- debugIsOn -} = ANN doc instr+{-# INLINE ann #-}++-- Using pprExpr will hide the AST, @ANN@ will end up in the assembly with+-- -dppr-debug.  The idea is that we can trivially see how a cmm expression+-- ended up producing the assembly we see.  By having the verbatim AST printed+-- we can simply check the patterns that were matched to arrive at the assembly+-- we generated.+--+-- pprExpr will hide a lot of noise of the underlying data structure and print+-- the expression into something that can be easily read by a human. However+-- going back to the exact CmmExpr representation can be laborious and adds+-- indirections to find the matches that lead to the assembly.+--+-- An improvement could be to have+--+--    (pprExpr genericPlatform e) <> parens (text. show e)+--+-- to have the best of both worlds.+--+-- Note: debugIsOn is too restrictive, it only works for debug compilers.+-- However, we do not only want to inspect this for debug compilers. Ideally+-- we'd have a check for -dppr-debug here already, such that we don't even+-- generate the ANN expressions. However, as they are lazy, they shouldn't be+-- forced until we actually force them, and without -dppr-debug they should+-- never end up being forced.+annExpr :: CmmExpr -> Instr -> Instr+annExpr e {- debugIsOn -} = ANN (text . show $ e)+-- annExpr e instr {- debugIsOn -} = ANN (pprExpr genericPlatform e) instr+-- annExpr _ instr = instr+{-# INLINE annExpr #-}++-- -----------------------------------------------------------------------------+-- Generating a table-branch++-- Note [RISCV64 Jump Tables]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- Jump tables are implemented by generating a table of relative addresses,+-- where each entry is the relative offset to the target block from the first+-- entry / table label (`generateJumpTableForInstr`). Using the jump table means+-- loading the entry's value and jumping to the calculated absolute address+-- (`genSwitch`).+--+-- For example, this Cmm switch+--+--   switch [1 .. 10] _s2wn::I64 {+--       case 1 : goto c347;+--       case 2 : goto c348;+--       case 3 : goto c349;+--       case 4 : goto c34a;+--       case 5 : goto c34b;+--       case 6 : goto c34c;+--       case 7 : goto c34d;+--       case 8 : goto c34e;+--       case 9 : goto c34f;+--       case 10 : goto c34g;+--   }   // CmmSwitch+--+-- leads to this jump table in Assembly+--+--   .section .rodata+--           .balign 8+--   .Ln34G:+--           .quad   0+--           .quad   .Lc347-(.Ln34G)+0+--           .quad   .Lc348-(.Ln34G)+0+--           .quad   .Lc349-(.Ln34G)+0+--           .quad   .Lc34a-(.Ln34G)+0+--           .quad   .Lc34b-(.Ln34G)+0+--           .quad   .Lc34c-(.Ln34G)+0+--           .quad   .Lc34d-(.Ln34G)+0+--           .quad   .Lc34e-(.Ln34G)+0+--           .quad   .Lc34f-(.Ln34G)+0+--           .quad   .Lc34g-(.Ln34G)+0+--+-- and this indexing code where the jump should be done (register t0 contains+-- the index)+--+--           addi t0, t0, 0 // silly move (ignore it)+--           la t1, .Ln34G // load the table's address+--           sll t0, t0, 3 // index * 8 -> offset in bytes+--           add t0, t0, t1 // address of the table's entry+--           ld t0, 0(t0) // load entry+--           add t0, t0, t1 // relative to absolute address+--           jalr zero, t0, 0 // jump to the block+--+-- In object code (disassembled) the table looks like+--+--   0000000000000000 <.Ln34G>:+--        ...+--        8: R_RISCV_ADD64        .Lc347+--        8: R_RISCV_SUB64        .Ln34G+--        10: R_RISCV_ADD64       .Lc348+--        10: R_RISCV_SUB64       .Ln34G+--        18: R_RISCV_ADD64       .Lc349+--        18: R_RISCV_SUB64       .Ln34G+--        20: R_RISCV_ADD64       .Lc34a+--        20: R_RISCV_SUB64       .Ln34G+--        28: R_RISCV_ADD64       .Lc34b+--        28: R_RISCV_SUB64       .Ln34G+--        30: R_RISCV_ADD64       .Lc34c+--        30: R_RISCV_SUB64       .Ln34G+--        38: R_RISCV_ADD64       .Lc34d+--        38: R_RISCV_SUB64       .Ln34G+--        40: R_RISCV_ADD64       .Lc34e+--        40: R_RISCV_SUB64       .Ln34G+--        48: R_RISCV_ADD64       .Lc34f+--        48: R_RISCV_SUB64       .Ln34G+--        50: R_RISCV_ADD64       .Lc34g+--        50: R_RISCV_SUB64       .Ln34G+--+-- I.e. the relative offset calculations are done by the linker via relocations.+-- This seems to be PIC compatible; at least `scanelf` (pax-utils) does not+-- complain.+++-- | Generate jump to jump table target+--+-- The index into the jump table is calulated by evaluating @expr@. The+-- corresponding table entry contains the relative address to jump to (relative+-- to the jump table's first entry / the table's own label).+genSwitch :: NCGConfig -> CmmExpr -> SwitchTargets -> NatM InstrBlock+genSwitch config expr targets = do+  (reg, fmt1, e_code) <- getSomeReg indexExpr+  let fmt = II64+  targetReg <- getNewRegNat fmt+  lbl <- getNewLabelNat+  dynRef <- cmmMakeDynamicReference config DataReference lbl+  (tableReg, fmt2, t_code) <- getSomeReg dynRef+  let code =+        toOL+          [ COMMENT (text "indexExpr" <+> (text . show) indexExpr),+            COMMENT (text "dynRef" <+> (text . show) dynRef)+          ]+          `appOL` e_code+          `appOL` t_code+          `appOL` toOL+            [ COMMENT (ftext "Jump table for switch"),+              -- index to offset into the table (relative to tableReg)+              annExpr expr (SLL (OpReg (formatToWidth fmt1) reg) (OpReg (formatToWidth fmt1) reg) (OpImm (ImmInt 3))),+              -- calculate table entry address+              ADD (OpReg W64 targetReg) (OpReg (formatToWidth fmt1) reg) (OpReg (formatToWidth fmt2) tableReg),+              -- load table entry (relative offset from tableReg (first entry) to target label)+              LDRU II64 (OpReg W64 targetReg) (OpAddr (AddrRegImm targetReg (ImmInt 0))),+              -- calculate absolute address of the target label+              ADD (OpReg W64 targetReg) (OpReg W64 targetReg) (OpReg W64 tableReg),+              -- prepare jump to target label+              J_TBL ids (Just lbl) targetReg+            ]+  return code+  where+    -- See Note [Sub-word subtlety during jump-table indexing] in+    -- GHC.CmmToAsm.X86.CodeGen for why we must first offset, then widen.+    indexExpr0 = cmmOffset platform expr offset+    -- We widen to a native-width register to sanitize the high bits+    indexExpr =+      CmmMachOp+        (MO_UU_Conv expr_w (platformWordWidth platform))+        [indexExpr0]+    expr_w = cmmExprWidth platform expr+    (offset, ids) = switchTargetsToTable targets+    platform = ncgPlatform config++-- | Generate jump table data (if required)+--+-- The idea is to emit one table entry per case. The entry is the relative+-- address of the block to jump to (relative to the table's first entry /+-- table's own label.) The calculation itself is done by the linker.+generateJumpTableForInstr ::+  NCGConfig ->+  Instr ->+  Maybe (NatCmmDecl RawCmmStatics Instr)+generateJumpTableForInstr config (J_TBL ids (Just lbl) _) =+  let jumpTable =+        map jumpTableEntryRel ids+        where+          jumpTableEntryRel Nothing =+            CmmStaticLit (CmmInt 0 (ncgWordWidth config))+          jumpTableEntryRel (Just blockid) =+            CmmStaticLit+              ( CmmLabelDiffOff+                  blockLabel+                  lbl+                  0+                  (ncgWordWidth config)+              )+            where+              blockLabel = blockLbl blockid+   in Just (CmmData (Section ReadOnlyData lbl) (CmmStaticsRaw lbl jumpTable))+generateJumpTableForInstr _ _ = Nothing++-- -----------------------------------------------------------------------------+-- Top-level of the instruction selector++stmtsToInstrs ::+  -- | Cmm Statements+  [CmmNode O O] ->+  -- | Resulting instruction+  NatM InstrBlock+stmtsToInstrs stmts = concatOL <$> mapM stmtToInstrs stmts++stmtToInstrs ::+  CmmNode e x ->+  -- | Resulting instructions+  NatM InstrBlock+stmtToInstrs stmt = do+  config <- getConfig+  platform <- getPlatform+  case stmt of+    CmmUnsafeForeignCall target result_regs args ->+      genCCall target result_regs args+    CmmComment s -> pure (unitOL (COMMENT (ftext s)))+    CmmTick {} -> pure nilOL+    CmmAssign reg src+      | isFloatType ty -> assignReg_FltCode format reg src+      | otherwise -> assignReg_IntCode format reg src+      where+        ty = cmmRegType reg+        format = cmmTypeFormat ty+    CmmStore addr src _alignment+      | isFloatType ty -> assignMem_FltCode format addr src+      | otherwise -> assignMem_IntCode format addr src+      where+        ty = cmmExprType platform src+        format = cmmTypeFormat ty+    CmmBranch id -> genBranch id+    -- We try to arrange blocks such that the likely branch is the fallthrough+    -- in GHC.Cmm.ContFlowOpt. So we can assume the condition is likely false here.+    CmmCondBranch arg true false _prediction ->+      genCondBranch true false arg+    CmmSwitch arg ids -> genSwitch config arg ids+    CmmCall {cml_target = arg} -> genJump arg+    CmmUnwind _regs -> pure nilOL+    -- Intentionally not have a default case here: If anybody adds a+    -- constructor, the compiler should force them to think about this here.+    CmmForeignCall {} -> pprPanic "stmtToInstrs: statement should have been cps'd away" (pdoc platform stmt)+    CmmEntry {} -> pprPanic "stmtToInstrs: statement should have been cps'd away" (pdoc platform stmt)++--------------------------------------------------------------------------------++-- | 'InstrBlock's are the insn sequences generated by the insn selectors.+--+-- They are really trees of insns to facilitate fast appending, where a+-- left-to-right traversal yields the insns in the correct order.+type InstrBlock =+  OrdList Instr++-- | Register's passed up the tree.+--+-- If the stix code forces the register to live in a pre-decided machine+-- register, it comes out as @Fixed@; otherwise, it comes out as @Any@, and the+-- parent can decide which register to put it in.+data Register+  = Fixed Format Reg InstrBlock+  | Any Format (Reg -> InstrBlock)++-- | Sometimes we need to change the Format of a register. Primarily during+-- conversion.+swizzleRegisterRep :: Format -> Register -> Register+swizzleRegisterRep format' (Fixed _format reg code) = Fixed format' reg code+swizzleRegisterRep format' (Any _format codefn) = Any format' codefn++-- | Grab a `Reg` for a `CmmReg`+--+-- `LocalReg`s are assigned virtual registers (`RegVirtual`), `GlobalReg`s are+-- assigned real registers (`RegReal`). It is an error if a `GlobalReg` is not a+-- STG register.+getRegisterReg :: Platform -> CmmReg -> Reg+getRegisterReg _ (CmmLocal (LocalReg u pk)) =+  RegVirtual $ mkVirtualReg u (cmmTypeFormat pk)+getRegisterReg platform (CmmGlobal mid) =+  case globalRegMaybe platform (globalRegUse_reg mid) of+    Just reg -> RegReal reg+    Nothing -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal mid)++-- -----------------------------------------------------------------------------+-- General things for putting together code sequences++-- | Compute an expression into any register+getSomeReg :: CmmExpr -> NatM (Reg, Format, InstrBlock)+getSomeReg expr = do+  r <- getRegister expr+  case r of+    Any rep code -> do+      newReg <- getNewRegNat rep+      return (newReg, rep, code newReg)+    Fixed rep reg code ->+      return (reg, rep, code)++-- | Compute an expression into any floating-point register+--+-- If the initial expression is not a floating-point expression, finally move+-- the result into a floating-point register.+getFloatReg :: (HasCallStack) => CmmExpr -> NatM (Reg, Format, InstrBlock)+getFloatReg expr = do+  r <- getRegister expr+  case r of+    Any rep code | isFloatFormat rep -> do+      newReg <- getNewRegNat rep+      return (newReg, rep, code newReg)+    Any II32 code -> do+      newReg <- getNewRegNat FF32+      return (newReg, FF32, code newReg)+    Any II64 code -> do+      newReg <- getNewRegNat FF64+      return (newReg, FF64, code newReg)+    Any _w _code -> do+      config <- getConfig+      pprPanic "can't do getFloatReg on" (pdoc (ncgPlatform config) expr)+    -- can't do much for fixed.+    Fixed rep reg code ->+      return (reg, rep, code)++-- | Map `CmmLit` to `OpImm`+--+-- N.B. this is a partial function, because not all `CmmLit`s have an immediate+-- representation.+litToImm' :: CmmLit -> Operand+litToImm' = OpImm . litToImm++-- | Compute a `CmmExpr` into a `Register`+getRegister :: CmmExpr -> NatM Register+getRegister e = do+  config <- getConfig+  getRegister' config (ncgPlatform config) e++-- | The register width to be used for an operation on the given width+-- operand.+opRegWidth :: Width -> Width+opRegWidth W64 = W64+opRegWidth W32 = W32+opRegWidth W16 = W32+opRegWidth W8 = W32+opRegWidth w = pprPanic "opRegWidth" (text "Unsupported width" <+> ppr w)++-- Note [Signed arithmetic on RISCV64]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- Handling signed arithmetic on sub-word-size values on RISCV64 is a bit+-- tricky as Cmm's type system does not capture signedness. While 32-bit values+-- are fairly easy to handle due to RISCV64's 32-bit instruction variants+-- (denoted by use of %wN registers), 16- and 8-bit values require quite some+-- care.+--+-- We handle 16-and 8-bit values by using the 32-bit operations and+-- sign-/zero-extending operands and truncate results as necessary. For+-- simplicity we maintain the invariant that a register containing a+-- sub-word-size value always contains the zero-extended form of that value+-- in between operations.+--+-- For instance, consider the program,+--+--    test(bits64 buffer)+--      bits8 a = bits8[buffer];+--      bits8 b = %mul(a, 42);+--      bits8 c = %not(b);+--      bits8 d = %shrl(c, 4::bits8);+--      return (d);+--    }+--+-- This program begins by loading `a` from memory, for which we use a+-- zero-extended byte-size load.  We next sign-extend `a` to 32-bits, and use a+-- 32-bit multiplication to compute `b`, and truncate the result back down to+-- 8-bits.+--+-- Next we compute `c`: The `%not` requires no extension of its operands, but+-- we must still truncate the result back down to 8-bits. Finally the `%shrl`+-- requires no extension and no truncate since we can assume that+-- `c` is zero-extended.+--+-- The "RISC-V Sign Extension Optimizations" LLVM tech talk presentation by+-- Craig Topper covers possible future improvements+-- (https://llvm.org/devmtg/2022-11/slides/TechTalk21-RISC-VSignExtensionOptimizations.pdf)+--+--+-- Note [Handling PIC on RV64]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- RV64 does not have a special PIC register, the general approach is to simply+-- do PC-relative addressing or go through the GOT. There is assembly support+-- for both.+--+-- rv64 assembly has a `la` (load address) pseudo-instruction, that allows+-- loading a label's address into a register. The instruction is desugared into+-- different addressing modes, e.g. PC-relative addressing:+--+-- 1: lui  rd1, %pcrel_hi(label)+--    addi rd1, %pcrel_lo(1b)+--+-- See https://sourceware.org/binutils/docs/as/RISC_002dV_002dModifiers.html,+-- PIC can be enabled/disabled through+--+--  .option pic+--+-- See https://sourceware.org/binutils/docs/as/RISC_002dV_002dDirectives.html#RISC_002dV_002dDirectives+--+-- CmmGlobal @PicBaseReg@'s are generated in @GHC.CmmToAsm.PIC@ in the+-- @cmmMakePicReference@.  This is in turn called from @cmmMakeDynamicReference@+-- also in @Cmm.CmmToAsm.PIC@ from where it is also exported.  There are two+-- callsites for this. One is in this module to produce the @target@ in @genCCall@+-- the other is in @GHC.CmmToAsm@ in @cmmExprNative@.+--+-- Conceptually we do not want any special PicBaseReg to be used on RV64. If+-- we want to distinguish between symbol loading, we need to address this through+-- the way we load it, not through a register.+--++getRegister' :: NCGConfig -> Platform -> CmmExpr -> NatM Register+-- OPTIMIZATION WARNING: CmmExpr rewrites+-- 1. Rewrite: Reg + (-n) => Reg - n+--    TODO: this expression shouldn't even be generated to begin with.+getRegister' config plat (CmmMachOp (MO_Add w0) [x, CmmLit (CmmInt i w1)])+  | i < 0 =+      getRegister' config plat (CmmMachOp (MO_Sub w0) [x, CmmLit (CmmInt (-i) w1)])+getRegister' config plat (CmmMachOp (MO_Sub w0) [x, CmmLit (CmmInt i w1)])+  | i < 0 =+      getRegister' config plat (CmmMachOp (MO_Add w0) [x, CmmLit (CmmInt (-i) w1)])+-- Generic case.+getRegister' config plat expr =+  case expr of+    CmmReg (CmmGlobal (GlobalRegUse PicBaseReg _)) ->+      -- See Note [Handling PIC on RV64]+      pprPanic "getRegister': There's no PIC base register on RISCV" (ppr PicBaseReg)+    CmmLit lit ->+      case lit of+        CmmInt 0 w -> pure $ Fixed (intFormat w) zeroReg nilOL+        CmmInt i w ->+          -- narrowU is important: Negative immediates may be+          -- sign-extended on load!+          let imm = OpImm . ImmInteger $ narrowU w i+           in pure (Any (intFormat w) (\dst -> unitOL $ annExpr expr (MOV (OpReg w dst) imm)))+        CmmFloat 0 w -> do+          let op = litToImm' lit+          pure (Any (floatFormat w) (\dst -> unitOL $ annExpr expr (MOV (OpReg w dst) op)))+        CmmFloat _f W8 -> pprPanic "getRegister' (CmmLit:CmmFloat), no support for bytes" (pdoc plat expr)+        CmmFloat _f W16 -> pprPanic "getRegister' (CmmLit:CmmFloat), no support for halfs" (pdoc plat expr)+        CmmFloat f W32 -> do+          let word = castFloatToWord32 (fromRational f) :: Word32+          intReg <- getNewRegNat (intFormat W32)+          return+            ( Any+                (floatFormat W32)+                ( \dst ->+                    toOL+                      [ annExpr expr+                          $ MOV (OpReg W32 intReg) (OpImm (ImmInteger (fromIntegral word))),+                        MOV (OpReg W32 dst) (OpReg W32 intReg)+                      ]+                )+            )+        CmmFloat f W64 -> do+          let word = castDoubleToWord64 (fromRational f) :: Word64+          intReg <- getNewRegNat (intFormat W64)+          return+            ( Any+                (floatFormat W64)+                ( \dst ->+                    toOL+                      [ annExpr expr+                          $ MOV (OpReg W64 intReg) (OpImm (ImmInteger (fromIntegral word))),+                        MOV (OpReg W64 dst) (OpReg W64 intReg)+                      ]+                )+            )+        CmmFloat _f _w -> pprPanic "getRegister' (CmmLit:CmmFloat), unsupported float lit" (pdoc plat expr)+        CmmVec _lits -> pprPanic "getRegister' (CmmLit:CmmVec): " (pdoc plat expr)+        CmmLabel lbl -> do+          let op = OpImm (ImmCLbl lbl)+              rep = cmmLitType plat lit+              format = cmmTypeFormat rep+          return (Any format (\dst -> unitOL $ annExpr expr (LDR format (OpReg (formatToWidth format) dst) op)))+        CmmLabelOff lbl off | isNbitEncodeable 12 (fromIntegral off) -> do+          let op = OpImm (ImmIndex lbl off)+              rep = cmmLitType plat lit+              format = cmmTypeFormat rep+          return (Any format (\dst -> unitOL $ LDR format (OpReg (formatToWidth format) dst) op))+        CmmLabelOff lbl off -> do+          let op = litToImm' (CmmLabel lbl)+              rep = cmmLitType plat lit+              format = cmmTypeFormat rep+              width = typeWidth rep+          (off_r, _off_format, off_code) <- getSomeReg $ CmmLit (CmmInt (fromIntegral off) width)+          return+            ( Any+                format+                ( \dst ->+                    off_code+                      `snocOL` LDR format (OpReg (formatToWidth format) dst) op+                      `snocOL` ADD (OpReg width dst) (OpReg width dst) (OpReg width off_r)+                )+            )+        CmmLabelDiffOff {} -> pprPanic "getRegister' (CmmLit:CmmLabelOff): " (pdoc plat expr)+        CmmBlock _ -> pprPanic "getRegister' (CmmLit:CmmLabelOff): " (pdoc plat expr)+        CmmHighStackMark -> pprPanic "getRegister' (CmmLit:CmmLabelOff): " (pdoc plat expr)+    CmmLoad mem rep _ -> do+      let format = cmmTypeFormat rep+          width = typeWidth rep+      Amode addr addr_code <- getAmode plat width mem+      case width of+        w+          | w <= W64 ->+              -- Load without sign-extension. See Note [Signed arithmetic on RISCV64]+              pure+                ( Any+                    format+                    ( \dst ->+                        addr_code+                          `snocOL` LDRU format (OpReg width dst) (OpAddr addr)+                    )+                )+        _ ->+          pprPanic ("Width too big! Cannot load: " ++ show width) (pdoc plat expr)+    CmmStackSlot _ _ ->+      pprPanic "getRegister' (CmmStackSlot): " (pdoc plat expr)+    CmmReg reg ->+      return+        ( Fixed+            (cmmTypeFormat (cmmRegType reg))+            (getRegisterReg plat reg)+            nilOL+        )+    CmmRegOff reg off | isNbitEncodeable 12 (fromIntegral off) -> do+      getRegister' config plat+        $ CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)]+      where+        width = typeWidth (cmmRegType reg)+    CmmRegOff reg off -> do+      (off_r, _off_format, off_code) <- getSomeReg $ CmmLit (CmmInt (fromIntegral off) width)+      (reg, _format, code) <- getSomeReg $ CmmReg reg+      return+        $ Any+          (intFormat width)+          ( \dst ->+              off_code+                `appOL` code+                `snocOL` ADD (OpReg width dst) (OpReg width reg) (OpReg width off_r)+          )+      where+        width = typeWidth (cmmRegType reg)++    -- Handle MO_RelaxedRead as a normal CmmLoad, to allow+    -- non-trivial addressing modes to be used.+    CmmMachOp (MO_RelaxedRead w) [e] ->+      getRegister (CmmLoad e (cmmBits w) NaturallyAligned)+    -- for MachOps, see GHC.Cmm.MachOp+    -- For CmmMachOp, see GHC.Cmm.Expr+    CmmMachOp op [e] -> do+      (reg, _format, code) <- getSomeReg e+      case op of+        MO_Not w -> return $ Any (intFormat w) $ \dst ->+          let w' = opRegWidth w+           in code+                `snocOL`+                -- pseudo instruction `not` is `xori rd, rs, -1`+                ann (text "not") (XORI (OpReg w' dst) (OpReg w' reg) (OpImm (ImmInt (-1))))+                `appOL` truncateReg w' w dst -- See Note [Signed arithmetic on RISCV64]+        MO_S_Neg w -> negate code w reg+        MO_F_Neg w ->+          return+            $ Any+              (floatFormat w)+              ( \dst ->+                  code+                    `snocOL` NEG (OpReg w dst) (OpReg w reg)+              )+        -- TODO: Can this case happen?+        MO_SF_Round from to | from < W32 -> do+          -- extend to the smallest available representation+          (reg_x, code_x) <- signExtendReg from W32 reg+          pure+            $ Any+              (floatFormat to)+              ( \dst ->+                  code+                    `appOL` code_x+                    `snocOL` annExpr expr (FCVT IntToFloat (OpReg to dst) (OpReg from reg_x)) -- (Signed ConVerT Float)+              )+        MO_SF_Round from to ->+          pure+            $ Any+              (floatFormat to)+              ( \dst ->+                  code+                    `snocOL` annExpr expr (FCVT IntToFloat (OpReg to dst) (OpReg from reg)) -- (Signed ConVerT Float)+              )+        -- TODO: Can this case happen?+        MO_FS_Truncate from to+          | to < W32 ->+              pure+                $ Any+                  (intFormat to)+                  ( \dst ->+                      code+                        `snocOL`+                        -- W32 is the smallest width to convert to. Decrease width afterwards.+                        annExpr expr (FCVT FloatToInt (OpReg W32 dst) (OpReg from reg))+                        `appOL` signExtendAdjustPrecission W32 to dst dst -- (float convert (-> zero) signed)+                  )+        MO_FS_Truncate from to ->+          pure+            $ Any+              (intFormat to)+              ( \dst ->+                  code+                    `snocOL` annExpr expr (FCVT FloatToInt (OpReg to dst) (OpReg from reg))+                    `appOL` truncateReg from to dst -- (float convert (-> zero) signed)+              )+        MO_UU_Conv from to+          | from <= to ->+              pure+                $ Any+                  (intFormat to)+                  ( \dst ->+                      code+                        `snocOL` annExpr e (MOV (OpReg to dst) (OpReg from reg))+                  )+        MO_UU_Conv from to ->+          pure+            $ Any+              (intFormat to)+              ( \dst ->+                  code+                    `snocOL` annExpr e (MOV (OpReg from dst) (OpReg from reg))+                    `appOL` truncateReg from to dst+              )+        MO_SS_Conv from to -> ss_conv from to reg code+        MO_FF_Conv from to -> return $ Any (floatFormat to) (\dst -> code `snocOL` annExpr e (FCVT FloatToFloat (OpReg to dst) (OpReg from reg)))+        MO_WF_Bitcast w    -> return $ Any (floatFormat w)  (\dst -> code `snocOL` MOV (OpReg w dst) (OpReg w reg))+        MO_FW_Bitcast w    -> return $ Any (intFormat w)    (\dst -> code `snocOL` MOV (OpReg w dst) (OpReg w reg))++        -- Conversions+        -- TODO: Duplication with MO_UU_Conv+        MO_XX_Conv from to+          | to < from ->+              pure+                $ Any+                  (intFormat to)+                  ( \dst ->+                      code+                        `snocOL` annExpr e (MOV (OpReg from dst) (OpReg from reg))+                        `appOL` truncateReg from to dst+                  )+        MO_XX_Conv _from to -> swizzleRegisterRep (intFormat to) <$> getRegister e+        MO_AlignmentCheck align wordWidth -> do+          reg <- getRegister' config plat e+          addAlignmentCheck align wordWidth reg+        x -> pprPanic ("getRegister' (monadic CmmMachOp): " ++ show x) (pdoc plat expr)+      where+        -- In the case of 16- or 8-bit values we need to sign-extend to 32-bits+        -- See Note [Signed arithmetic on RISCV64].+        negate code w reg = do+          let w' = opRegWidth w+          (reg', code_sx) <- signExtendReg w w' reg+          return $ Any (intFormat w) $ \dst ->+            code+              `appOL` code_sx+              `snocOL` NEG (OpReg w' dst) (OpReg w' reg')+              `appOL` truncateReg w' w dst++        ss_conv from to reg code+          | from < to = do+              pure $ Any (intFormat to) $ \dst ->+                code+                  `appOL` signExtend from to reg dst+                  `appOL` truncateReg from to dst+          | from > to =+              pure $ Any (intFormat to) $ \dst ->+                code+                  `appOL` toOL+                    [ ann+                        (text "MO_SS_Conv: narrow register signed" <+> ppr reg <+> ppr from <> text "->" <> ppr to)+                        (SLL (OpReg to dst) (OpReg from reg) (OpImm (ImmInt shift))),+                      -- signed right shift+                      SRA (OpReg to dst) (OpReg to dst) (OpImm (ImmInt shift))+                    ]+                  `appOL` truncateReg from to dst+          | otherwise =+              -- No conversion necessary: Just copy.+              pure $ Any (intFormat from) $ \dst ->+                code `snocOL` MOV (OpReg from dst) (OpReg from reg)+          where+            shift = 64 - (widthInBits from - widthInBits to)++    -- Dyadic machops:+    --+    -- The general idea is:+    -- compute x<i> <- x+    -- compute x<j> <- y+    -- OP x<r>, x<i>, x<j>+    --+    -- TODO: for now we'll only implement the 64bit versions. And rely on the+    --      fallthrough to alert us if things go wrong!+    -- OPTIMIZATION WARNING: Dyadic CmmMachOp destructuring+    -- 0. TODO This should not exist! Rewrite: Reg +- 0 -> Reg+    CmmMachOp (MO_Add _) [expr'@(CmmReg (CmmGlobal _r)), CmmLit (CmmInt 0 _)] -> getRegister' config plat expr'+    CmmMachOp (MO_Sub _) [expr'@(CmmReg (CmmGlobal _r)), CmmLit (CmmInt 0 _)] -> getRegister' config plat expr'+    -- 1. Compute Reg +/- n directly.+    --    For Add/Sub we can directly encode 12bits, or 12bits lsl #12.+    CmmMachOp (MO_Add w) [CmmReg reg, CmmLit (CmmInt n _)]+      | fitsIn12bitImm n -> return $ Any (intFormat w) (\d -> unitOL $ annExpr expr (ADD (OpReg w d) (OpReg w' r') (OpImm (ImmInteger n))))+      where+        -- TODO: 12bits lsl #12; e.g. lower 12 bits of n are 0; shift n >> 12, and set lsl to #12.+        w' = formatToWidth (cmmTypeFormat (cmmRegType reg))+        r' = getRegisterReg plat reg+    CmmMachOp (MO_Sub w) [CmmReg reg, CmmLit (CmmInt n _)]+      | fitsIn12bitImm n -> return $ Any (intFormat w) (\d -> unitOL $ annExpr expr (SUB (OpReg w d) (OpReg w' r') (OpImm (ImmInteger n))))+      where+        -- TODO: 12bits lsl #12; e.g. lower 12 bits of n are 0; shift n >> 12, and set lsl to #12.+        w' = formatToWidth (cmmTypeFormat (cmmRegType reg))+        r' = getRegisterReg plat reg+    CmmMachOp (MO_U_Quot w) [x, y] | w == W8 || w == W16 -> do+      (reg_x, format_x, code_x) <- getSomeReg x+      (reg_y, format_y, code_y) <- getSomeReg y+      return+        $ Any+          (intFormat w)+          ( \dst ->+              code_x+                `appOL` truncateReg (formatToWidth format_x) w reg_x+                `appOL` code_y+                `appOL` truncateReg (formatToWidth format_y) w reg_y+                `snocOL` annExpr expr (DIVU (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y))+          )++    -- 2. Shifts. x << n, x >> n.+    CmmMachOp (MO_Shl w) [x, CmmLit (CmmInt n _)]+      | w == W32,+        0 <= n,+        n < 32 -> do+          (reg_x, _format_x, code_x) <- getSomeReg x+          return+            $ Any+              (intFormat w)+              ( \dst ->+                  code_x+                    `snocOL` annExpr expr (SLL (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)))+                    `appOL` truncateReg w w dst+              )+    CmmMachOp (MO_Shl w) [x, CmmLit (CmmInt n _)]+      | w == W64,+        0 <= n,+        n < 64 -> do+          (reg_x, _format_x, code_x) <- getSomeReg x+          return+            $ Any+              (intFormat w)+              ( \dst ->+                  code_x+                    `snocOL` annExpr expr (SLL (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)))+                    `appOL` truncateReg w w dst+              )+    CmmMachOp (MO_S_Shr w) [x, CmmLit (CmmInt n _)] | fitsIn12bitImm n -> do+      (reg_x, format_x, code_x) <- getSomeReg x+      (reg_x', code_x') <- signExtendReg (formatToWidth format_x) w reg_x+      return+        $ Any+          (intFormat w)+          ( \dst ->+              code_x+                `appOL` code_x'+                `snocOL` annExpr expr (SRA (OpReg w dst) (OpReg w reg_x') (OpImm (ImmInteger n)))+          )+    CmmMachOp (MO_S_Shr w) [x, y] -> do+      (reg_x, format_x, code_x) <- getSomeReg x+      (reg_y, _format_y, code_y) <- getSomeReg y+      (reg_x', code_x') <- signExtendReg (formatToWidth format_x) w reg_x+      return+        $ Any+          (intFormat w)+          ( \dst ->+              code_x+                `appOL` code_x'+                `appOL` code_y+                `snocOL` annExpr expr (SRA (OpReg w dst) (OpReg w reg_x') (OpReg w reg_y))+          )+    CmmMachOp (MO_U_Shr w) [x, CmmLit (CmmInt n _)]+      | w == W8,+        0 <= n,+        n < 8 -> do+          (reg_x, format_x, code_x) <- getSomeReg x+          return+            $ Any+              (intFormat w)+              ( \dst ->+                  code_x+                    `appOL` truncateReg (formatToWidth format_x) w reg_x+                    `snocOL` annExpr expr (SRL (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)))+              )+    CmmMachOp (MO_U_Shr w) [x, CmmLit (CmmInt n _)]+      | w == W16,+        0 <= n,+        n < 16 -> do+          (reg_x, format_x, code_x) <- getSomeReg x+          return+            $ Any+              (intFormat w)+              ( \dst ->+                  code_x+                    `appOL` truncateReg (formatToWidth format_x) w reg_x+                    `snocOL` annExpr expr (SRL (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)))+              )+    CmmMachOp (MO_U_Shr w) [x, y] | w == W8 || w == W16 -> do+      (reg_x, format_x, code_x) <- getSomeReg x+      (reg_y, _format_y, code_y) <- getSomeReg y+      return+        $ Any+          (intFormat w)+          ( \dst ->+              code_x+                `appOL` code_y+                `appOL` truncateReg (formatToWidth format_x) w reg_x+                `snocOL` annExpr expr (SRL (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y))+          )+    CmmMachOp (MO_U_Shr w) [x, CmmLit (CmmInt n _)]+      | w == W32,+        0 <= n,+        n < 32 -> do+          (reg_x, _format_x, code_x) <- getSomeReg x+          return+            $ Any+              (intFormat w)+              ( \dst ->+                  code_x+                    `snocOL` annExpr expr (SRL (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)))+              )+    CmmMachOp (MO_U_Shr w) [x, CmmLit (CmmInt n _)]+      | w == W64,+        0 <= n,+        n < 64 -> do+          (reg_x, _format_x, code_x) <- getSomeReg x+          return+            $ Any+              (intFormat w)+              ( \dst ->+                  code_x+                    `snocOL` annExpr expr (SRL (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)))+              )++    -- 3. Logic &&, ||+    CmmMachOp (MO_And w) [CmmReg reg, CmmLit (CmmInt n _)]+      | fitsIn12bitImm n ->+          return $ Any (intFormat w) (\d -> unitOL $ annExpr expr (AND (OpReg w d) (OpReg w' r') (OpImm (ImmInteger n))))+      where+        w' = formatToWidth (cmmTypeFormat (cmmRegType reg))+        r' = getRegisterReg plat reg+    CmmMachOp (MO_Or w) [CmmReg reg, CmmLit (CmmInt n _)]+      | fitsIn12bitImm n ->+          return $ Any (intFormat w) (\d -> unitOL $ annExpr expr (ORI (OpReg w d) (OpReg w' r') (OpImm (ImmInteger n))))+      where+        w' = formatToWidth (cmmTypeFormat (cmmRegType reg))+        r' = getRegisterReg plat reg++    -- Generic binary case.+    CmmMachOp op [x, y] -> do+      let -- A "plain" operation.+          bitOp w op = do+            -- compute x<m> <- x+            -- compute x<o> <- y+            -- <OP> x<n>, x<m>, x<o>+            (reg_x, format_x, code_x) <- getSomeReg x+            (reg_y, format_y, code_y) <- getSomeReg y+            massertPpr (isIntFormat format_x == isIntFormat format_y) $ text "bitOp: incompatible"+            return+              $ Any+                (intFormat w)+                ( \dst ->+                    code_x+                      `appOL` code_y+                      `appOL` op (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y)+                )++          -- A (potentially signed) integer operation.+          -- In the case of 8- and 16-bit signed arithmetic we must first+          -- sign-extend both arguments to 32-bits.+          -- See Note [Signed arithmetic on RISCV64].+          intOp is_signed w op = do+            -- compute x<m> <- x+            -- compute x<o> <- y+            -- <OP> x<n>, x<m>, x<o>+            (reg_x, format_x, code_x) <- getSomeReg x+            (reg_y, format_y, code_y) <- getSomeReg y+            massertPpr (isIntFormat format_x && isIntFormat format_y) $ text "intOp: non-int"+            -- This is the width of the registers on which the operation+            -- should be performed.+            let w' = opRegWidth w+                signExt r+                  | not is_signed = return (r, nilOL)+                  | otherwise = signExtendReg w w' r+            (reg_x_sx, code_x_sx) <- signExt reg_x+            (reg_y_sx, code_y_sx) <- signExt reg_y+            return $ Any (intFormat w) $ \dst ->+              code_x+                `appOL` code_y+                `appOL`+                -- sign-extend both operands+                code_x_sx+                `appOL` code_y_sx+                `appOL` op (OpReg w' dst) (OpReg w' reg_x_sx) (OpReg w' reg_y_sx)+                `appOL` truncateReg w' w dst -- truncate back to the operand's original width+          floatOp w op = do+            (reg_fx, format_x, code_fx) <- getFloatReg x+            (reg_fy, format_y, code_fy) <- getFloatReg y+            massertPpr (isFloatFormat format_x && isFloatFormat format_y) $ text "floatOp: non-float"+            return+              $ Any+                (floatFormat w)+                ( \dst ->+                    code_fx+                      `appOL` code_fy+                      `appOL` op (OpReg w dst) (OpReg w reg_fx) (OpReg w reg_fy)+                )++          -- need a special one for conditionals, as they return ints+          floatCond w op = do+            (reg_fx, format_x, code_fx) <- getFloatReg x+            (reg_fy, format_y, code_fy) <- getFloatReg y+            massertPpr (isFloatFormat format_x && isFloatFormat format_y) $ text "floatCond: non-float"+            return+              $ Any+                (intFormat w)+                ( \dst ->+                    code_fx+                      `appOL` code_fy+                      `appOL` op (OpReg w dst) (OpReg w reg_fx) (OpReg w reg_fy)+                )++      case op of+        -- Integer operations+        -- Add/Sub should only be Integer Options.+        MO_Add w -> intOp False w (\d x y -> unitOL $ annExpr expr (ADD d x y))+        -- TODO: Handle sub-word case+        MO_Sub w -> intOp False w (\d x y -> unitOL $ annExpr expr (SUB d x y))+        -- N.B. We needn't sign-extend sub-word size (in)equality comparisons+        -- since we don't care about ordering.+        MO_Eq w -> bitOp w (\d x y -> unitOL $ annExpr expr (CSET d x y EQ))+        MO_Ne w -> bitOp w (\d x y -> unitOL $ annExpr expr (CSET d x y NE))+        -- Signed multiply/divide+        MO_Mul w -> intOp True w (\d x y -> unitOL $ annExpr expr (MUL d x y))+        MO_S_MulMayOflo w -> do_mul_may_oflo w x y+        MO_S_Quot w -> intOp True w (\d x y -> unitOL $ annExpr expr (DIV d x y))+        MO_S_Rem w -> intOp True w (\d x y -> unitOL $ annExpr expr (REM d x y))+        -- Unsigned multiply/divide+        MO_U_Quot w -> intOp False w (\d x y -> unitOL $ annExpr expr (DIVU d x y))+        MO_U_Rem w -> intOp False w (\d x y -> unitOL $ annExpr expr (REMU d x y))+        -- Signed comparisons+        MO_S_Ge w -> intOp True w (\d x y -> unitOL $ annExpr expr (CSET d x y SGE))+        MO_S_Le w -> intOp True w (\d x y -> unitOL $ annExpr expr (CSET d x y SLE))+        MO_S_Gt w -> intOp True w (\d x y -> unitOL $ annExpr expr (CSET d x y SGT))+        MO_S_Lt w -> intOp True w (\d x y -> unitOL $ annExpr expr (CSET d x y SLT))+        -- Unsigned comparisons+        MO_U_Ge w -> intOp False w (\d x y -> unitOL $ annExpr expr (CSET d x y UGE))+        MO_U_Le w -> intOp False w (\d x y -> unitOL $ annExpr expr (CSET d x y ULE))+        MO_U_Gt w -> intOp False w (\d x y -> unitOL $ annExpr expr (CSET d x y UGT))+        MO_U_Lt w -> intOp False w (\d x y -> unitOL $ annExpr expr (CSET d x y ULT))+        -- Floating point arithmetic+        MO_F_Add w -> floatOp w (\d x y -> unitOL $ annExpr expr (ADD d x y))+        MO_F_Sub w -> floatOp w (\d x y -> unitOL $ annExpr expr (SUB d x y))+        MO_F_Mul w -> floatOp w (\d x y -> unitOL $ annExpr expr (MUL d x y))+        MO_F_Quot w -> floatOp w (\d x y -> unitOL $ annExpr expr (DIV d x y))+        -- Floating point comparison+        MO_F_Min w -> floatOp w (\d x y -> unitOL $ annExpr expr (FMIN d x y))+        MO_F_Max w -> floatOp w (\d x y -> unitOL $ annExpr expr (FMAX d x y))+        MO_F_Eq w -> floatCond w (\d x y -> unitOL $ annExpr expr (CSET d x y EQ))+        MO_F_Ne w -> floatCond w (\d x y -> unitOL $ annExpr expr (CSET d x y NE))+        MO_F_Ge w -> floatCond w (\d x y -> unitOL $ annExpr expr (CSET d x y FGE))+        MO_F_Le w -> floatCond w (\d x y -> unitOL $ annExpr expr (CSET d x y FLE)) -- x <= y <=> y > x+        MO_F_Gt w -> floatCond w (\d x y -> unitOL $ annExpr expr (CSET d x y FGT))+        MO_F_Lt w -> floatCond w (\d x y -> unitOL $ annExpr expr (CSET d x y FLT)) -- x < y <=> y >= x++        -- Bitwise operations+        MO_And w -> bitOp w (\d x y -> unitOL $ annExpr expr (AND d x y))+        MO_Or w -> bitOp w (\d x y -> unitOL $ annExpr expr (OR d x y))+        MO_Xor w -> bitOp w (\d x y -> unitOL $ annExpr expr (XOR d x y))+        MO_Shl w -> intOp False w (\d x y -> unitOL $ annExpr expr (SLL d x y))+        MO_U_Shr w -> intOp False w (\d x y -> unitOL $ annExpr expr (SRL d x y))+        MO_S_Shr w -> intOp True w (\d x y -> unitOL $ annExpr expr (SRA d x y))+        op -> pprPanic "getRegister' (unhandled dyadic CmmMachOp): " $ pprMachOp op <+> text "in" <+> pdoc plat expr++    -- Generic ternary case.+    CmmMachOp op [x, y, z] ->+      case op of+        -- Floating-point fused multiply-add operations+        --+        -- x86 fmadd    x * y + z <=> RISCV64 fmadd : d =   r1 * r2 + r3+        -- x86 fmsub    x * y - z <=> RISCV64 fnmsub: d =   r1 * r2 - r3+        -- x86 fnmadd - x * y + z <=> RISCV64 fmsub : d = - r1 * r2 + r3+        -- x86 fnmsub - x * y - z <=> RISCV64 fnmadd: d = - r1 * r2 - r3+        MO_FMA var l w+          | l == 1+          -> case var of+                FMAdd -> float3Op w (\d n m a -> unitOL $ FMA FMAdd d n m a)+                FMSub -> float3Op w (\d n m a -> unitOL $ FMA FMSub d n m a)+                FNMAdd -> float3Op w (\d n m a -> unitOL $ FMA FNMSub d n m a)+                FNMSub -> float3Op w (\d n m a -> unitOL $ FMA FNMAdd d n m a)+          | otherwise+          -> sorry "The RISCV64 backend does not (yet) support vectors."+        _ ->+          pprPanic "getRegister' (unhandled ternary CmmMachOp): "+            $ pprMachOp op+            <+> text "in"+            <+> pdoc plat expr+      where+        float3Op w op = do+          (reg_fx, format_x, code_fx) <- getFloatReg x+          (reg_fy, format_y, code_fy) <- getFloatReg y+          (reg_fz, format_z, code_fz) <- getFloatReg z+          massertPpr (isFloatFormat format_x && isFloatFormat format_y && isFloatFormat format_z)+            $ text "float3Op: non-float"+          pure+            $ Any (floatFormat w)+            $ \dst ->+              code_fx+                `appOL` code_fy+                `appOL` code_fz+                `appOL` op (OpReg w dst) (OpReg w reg_fx) (OpReg w reg_fy) (OpReg w reg_fz)+    CmmMachOp _op _xs ->+      pprPanic "getRegister' (variadic CmmMachOp): " (pdoc plat expr)+  where+    isNbitEncodeable :: Int -> Integer -> Bool+    isNbitEncodeable n i = let shift = n - 1 in (-1 `shiftL` shift) <= i && i < (1 `shiftL` shift)+    -- N.B. MUL does not set the overflow flag.+    -- Return 0 when the operation cannot overflow, /= 0 otherwise+    do_mul_may_oflo :: Width -> CmmExpr -> CmmExpr -> NatM Register+    do_mul_may_oflo w _x _y | w > W64 = pprPanic "Cannot multiply larger than 64bit" (ppr w)+    do_mul_may_oflo w@W64 x y = do+      (reg_x, format_x, code_x) <- getSomeReg x+      (reg_y, format_y, code_y) <- getSomeReg y+      -- TODO: Can't we clobber reg_x and reg_y to save registers?+      lo <- getNewRegNat II64+      hi <- getNewRegNat II64+      -- TODO: Overhaul CSET: 3rd operand isn't needed for SNEZ+      let nonSense = OpImm (ImmInt 0)+      pure+        $ Any+          (intFormat w)+          ( \dst ->+              code_x+                `appOL` signExtend (formatToWidth format_x) W64 reg_x reg_x+                `appOL` code_y+                `appOL` signExtend (formatToWidth format_y) W64 reg_y reg_y+                `appOL` toOL+                  [ annExpr expr (MULH (OpReg w hi) (OpReg w reg_x) (OpReg w reg_y)),+                    MUL (OpReg w lo) (OpReg w reg_x) (OpReg w reg_y),+                    SRA (OpReg w lo) (OpReg w lo) (OpImm (ImmInt (widthInBits W64 - 1))),+                    ann+                      (text "Set flag if result of MULH contains more than sign bits.")+                      (XOR (OpReg w hi) (OpReg w hi) (OpReg w lo)),+                    CSET (OpReg w dst) (OpReg w hi) nonSense NE+                  ]+          )+    do_mul_may_oflo w x y = do+      (reg_x, format_x, code_x) <- getSomeReg x+      (reg_y, format_y, code_y) <- getSomeReg y+      let width_x = formatToWidth format_x+          width_y = formatToWidth format_y+      if w > width_x && w > width_y+        then+          pure+            $ Any+              (intFormat w)+              ( \dst ->+                  -- 8bit * 8bit cannot overflow 16bit+                  -- 16bit * 16bit cannot overflow 32bit+                  -- 32bit * 32bit cannot overflow 64bit+                  unitOL $ annExpr expr (ADD (OpReg w dst) zero (OpImm (ImmInt 0)))+              )+        else do+          let use32BitMul = w <= W32 && width_x <= W32 && width_y <= W32+              nonSense = OpImm (ImmInt 0)+          if use32BitMul+            then do+              narrowedReg <- getNewRegNat II64+              pure+                $ Any+                  (intFormat w)+                  ( \dst ->+                      code_x+                        `appOL` signExtend (formatToWidth format_x) W32 reg_x reg_x+                        `appOL` code_y+                        `appOL` signExtend (formatToWidth format_y) W32 reg_y reg_y+                        `snocOL` annExpr expr (MUL (OpReg W32 dst) (OpReg W32 reg_x) (OpReg W32 reg_y))+                        `appOL` signExtendAdjustPrecission W32 w dst narrowedReg+                        `appOL` toOL+                          [ ann+                              (text "Check if the multiplied value fits in the narrowed register")+                              (SUB (OpReg w dst) (OpReg w dst) (OpReg w narrowedReg)),+                            CSET (OpReg w dst) (OpReg w dst) nonSense NE+                          ]+                  )+            else+              pure+                $ Any+                  (intFormat w)+                  ( \dst ->+                      -- Do not handle this unlikely case. Just tell that it may overflow.+                      unitOL $ annExpr expr (ADD (OpReg w dst) zero (OpImm (ImmInt 1)))+                  )++-- | Instructions to sign-extend the value in the given register from width @w@+-- up to width @w'@.+signExtendReg :: Width -> Width -> Reg -> NatM (Reg, OrdList Instr)+signExtendReg w _w' r | w == W64 = pure (r, nilOL)+signExtendReg w w' r = do+  r' <- getNewRegNat (intFormat w')+  let instrs = signExtend w w' r r'+  pure (r', instrs)++-- | Sign extends to 64bit, if needed+--+-- Source `Reg` @r@ stays untouched, while the conversion happens on destination+-- `Reg` @r'@.+signExtend :: Width -> Width -> Reg -> Reg -> OrdList Instr+signExtend w w' _r _r' | w > w' = pprPanic "This is not a sign extension, but a truncation." $ ppr w <> text "->" <+> ppr w'+signExtend w w' _r _r' | w > W64 || w' > W64 = pprPanic "Unexpected width (max is 64bit):" $ ppr w <> text "->" <+> ppr w'+signExtend w w' r r' | w == W64 && w' == W64 && r == r' = nilOL+signExtend w w' r r' | w == W64 && w' == W64 = unitOL $ MOV (OpReg w' r') (OpReg w r)+signExtend w w' r r'+  | w == W32 && w' == W64 =+      unitOL+        $ ann+          (text "sign-extend register (SEXT.W)" <+> ppr r <+> ppr w <> text "->" <> ppr w')+          -- `ADDIW r r 0` is the pseudo-op SEXT.W+          (ADD (OpReg w' r') (OpReg w r) (OpImm (ImmInt 0)))+signExtend w w' r r' =+  toOL+    [ ann+        (text "narrow register signed" <+> ppr r <> char ':' <> ppr w <> text "->" <> ppr r <> char ':' <> ppr w')+        (SLL (OpReg w' r') (OpReg w r) (OpImm (ImmInt shift))),+      -- signed (arithmetic) right shift+      SRA (OpReg w' r') (OpReg w' r') (OpImm (ImmInt shift))+    ]+  where+    shift = 64 - widthInBits w++-- | Sign extends to 64bit, if needed and reduces the precission to the target `Width` (@w'@)+--+-- Source `Reg` @r@ stays untouched, while the conversion happens on destination+-- `Reg` @r'@.+signExtendAdjustPrecission :: Width -> Width -> Reg -> Reg -> OrdList Instr+signExtendAdjustPrecission w w' _r _r' | w > W64 || w' > W64 = pprPanic "Unexpected width (max is 64bit):" $ ppr w <> text "->" <+> ppr w'+signExtendAdjustPrecission w w' r r' | w == W64 && w' == W64 && r == r' = nilOL+signExtendAdjustPrecission w w' r r' | w == W64 && w' == W64 = unitOL $ MOV (OpReg w' r') (OpReg w r)+signExtendAdjustPrecission w w' r r'+  | w == W32 && w' == W64 =+      unitOL+        $ ann+          (text "sign-extend register (SEXT.W)" <+> ppr r <+> ppr w <> text "->" <> ppr w')+          -- `ADDIW r r 0` is the pseudo-op SEXT.W+          (ADD (OpReg w' r') (OpReg w r) (OpImm (ImmInt 0)))+signExtendAdjustPrecission w w' r r'+  | w > w' =+      toOL+        [ ann+            (text "narrow register signed" <+> ppr r <> char ':' <> ppr w <> text "->" <> ppr r <> char ':' <> ppr w')+            (SLL (OpReg w' r') (OpReg w r) (OpImm (ImmInt shift))),+          -- signed (arithmetic) right shift+          SRA (OpReg w' r') (OpReg w' r') (OpImm (ImmInt shift))+        ]+  where+    shift = 64 - widthInBits w'+signExtendAdjustPrecission w w' r r' =+  toOL+    [ ann+        (text "sign extend register" <+> ppr r <> char ':' <> ppr w <> text "->" <> ppr r <> char ':' <> ppr w')+        (SLL (OpReg w' r') (OpReg w r) (OpImm (ImmInt shift))),+      -- signed (arithmetic) right shift+      SRA (OpReg w' r') (OpReg w' r') (OpImm (ImmInt shift))+    ]+  where+    shift = 64 - widthInBits w++-- | Instructions to truncate the value in the given register from width @w@+-- to width @w'@.+--+-- In other words, it just cuts the width out of the register. N.B.: This+-- ignores signedness (no sign extension takes place)!+truncateReg :: Width -> Width -> Reg -> OrdList Instr+truncateReg _w w' _r | w' == W64 = nilOL+truncateReg _w w' r | w' > W64 = pprPanic "Cannot truncate to width bigger than register size (max is 64bit):" $ text (show r) <> char ':' <+> ppr w'+truncateReg w _w' r | w > W64 = pprPanic "Unexpected register size (max is 64bit):" $ text (show r) <> char ':' <+> ppr w+truncateReg w w' r =+  toOL+    [ ann+        (text "truncate register" <+> ppr r <+> ppr w <> text "->" <> ppr w')+        (SLL (OpReg w' r) (OpReg w r) (OpImm (ImmInt shift))),+      -- SHL ignores signedness!+      SRL (OpReg w' r) (OpReg w r) (OpImm (ImmInt shift))+    ]+  where+    shift = 64 - widthInBits w'++-- | Given a 'Register', produce a new 'Register' with an instruction block+-- which will check the value for alignment. Used for @-falignment-sanitisation@.+addAlignmentCheck :: Int -> Width -> Register -> NatM Register+addAlignmentCheck align wordWidth reg = do+  jumpReg <- getNewRegNat II64+  cmpReg <- getNewRegNat II64+  okayLblId <- getBlockIdNat++  pure $ case reg of+    Fixed fmt reg code -> Fixed fmt reg (code `appOL` check fmt jumpReg cmpReg okayLblId reg)+    Any fmt f -> Any fmt (\reg -> f reg `appOL` check fmt jumpReg cmpReg okayLblId reg)+  where+    check :: Format -> Reg -> Reg -> BlockId -> Reg -> InstrBlock+    check fmt jumpReg cmpReg okayLblId reg =+      let width = formatToWidth fmt+       in assert (not $ isFloatFormat fmt)+            $ toOL+              [ ann+                  (text "Alignment check - alignment: " <> int align <> text ", word width: " <> text (show wordWidth))+                  (AND (OpReg width cmpReg) (OpReg width reg) (OpImm $ ImmInt $ align - 1)),+                BCOND EQ (OpReg width cmpReg) zero (TBlock okayLblId),+                COMMENT (text "Alignment check failed"),+                LDR II64 (OpReg W64 jumpReg) (OpImm $ ImmCLbl mkBadAlignmentLabel),+                B (TReg jumpReg),+                NEWBLOCK okayLblId+              ]++-- -----------------------------------------------------------------------------+--  The 'Amode' type: Memory addressing modes passed up the tree.+data Amode = Amode AddrMode InstrBlock++-- | Provide the value of a `CmmExpr` with an `Amode`+--+-- N.B. this function should be used to provide operands to load and store+-- instructions with signed 12bit wide immediates (S & I types). For other+-- immediate sizes and formats (e.g. B type uses multiples of 2) this function+-- would need to be adjusted.+getAmode ::+  Platform ->+  -- | width of loaded value+  Width ->+  CmmExpr ->+  NatM Amode+-- TODO: Specialize stuff we can destructure here.++-- LDR/STR: Immediate can be represented with 12bits+getAmode platform w (CmmRegOff reg off)+  | w <= W64,+    fitsIn12bitImm off =+      return $ Amode (AddrRegImm reg' off') nilOL+  where+    reg' = getRegisterReg platform reg+    off' = ImmInt off++-- For Stores we often see something like this:+-- CmmStore (CmmMachOp (MO_Add w) [CmmLoad expr, CmmLit (CmmInt n w')]) (expr2)+-- E.g. a CmmStoreOff really. This can be translated to `str $expr2, [$expr, #n ]+-- for `n` in range.+getAmode _platform _ (CmmMachOp (MO_Add _w) [expr, CmmLit (CmmInt off _w')])+  | fitsIn12bitImm off =+      do+        (reg, _format, code) <- getSomeReg expr+        return $ Amode (AddrRegImm reg (ImmInteger off)) code+getAmode _platform _ (CmmMachOp (MO_Sub _w) [expr, CmmLit (CmmInt off _w')])+  | fitsIn12bitImm (-off) =+      do+        (reg, _format, code) <- getSomeReg expr+        return $ Amode (AddrRegImm reg (ImmInteger (-off))) code++-- Generic case+getAmode _platform _ expr =+  do+    (reg, _format, code) <- getSomeReg expr+    return $ Amode (AddrReg reg) code++-- -----------------------------------------------------------------------------+-- Generating assignments++-- Assignments are really at the heart of the whole code generation+-- business.  Almost all top-level nodes of any real importance are+-- assignments, which correspond to loads, stores, or register+-- transfers.  If we're really lucky, some of the register transfers+-- will go away, because we can use the destination register to+-- complete the code generation for the right hand side.  This only+-- fails when the right hand side is forced into a fixed register+-- (e.g. the result of a call).++assignMem_IntCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock+assignReg_IntCode :: Format -> CmmReg -> CmmExpr -> NatM InstrBlock+assignMem_FltCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock+assignReg_FltCode :: Format -> CmmReg -> CmmExpr -> NatM InstrBlock+assignMem_IntCode rep addrE srcE =+  do+    (src_reg, _format, code) <- getSomeReg srcE+    platform <- getPlatform+    let w = formatToWidth rep+    Amode addr addr_code <- getAmode platform w addrE+    return $ COMMENT (text "CmmStore" <+> parens (text (show addrE)) <+> parens (text (show srcE)))+      `consOL` ( code+                   `appOL` addr_code+                   `snocOL` STR rep (OpReg w src_reg) (OpAddr addr)+               )++assignReg_IntCode _ reg src =+  do+    platform <- getPlatform+    let dst = getRegisterReg platform reg+    r <- getRegister src+    return $ case r of+      Any _ code ->+        COMMENT (text "CmmAssign" <+> parens (text (show reg)) <+> parens (text (show src)))+          `consOL` code dst+      Fixed format freg fcode ->+        COMMENT (text "CmmAssign" <+> parens (text (show reg)) <+> parens (text (show src)))+          `consOL` ( fcode+                       `snocOL` MOV (OpReg (formatToWidth format) dst) (OpReg (formatToWidth format) freg)+                   )++-- Let's treat Floating point stuff+-- as integer code for now. Opaque.+assignMem_FltCode = assignMem_IntCode++assignReg_FltCode = assignReg_IntCode++-- -----------------------------------------------------------------------------+-- Jumps+-- AArch64 has 26bits for targets, whereas RiscV only has 20.+-- Thus we need to distinguish between far (outside of the)+-- current compilation unit. And regular branches.+-- RiscV has ±2MB of displacement, whereas AArch64 has ±128MB.+-- Thus for most branches we can get away with encoding it+-- directly in the instruction rather than always loading the+-- address into a register and then using that to jump.+-- Under the assumption that our linked build product is less than+-- ~2*128MB of TEXT, and there are no jump that span the whole+-- TEXT segment.+-- Something where riscv's compressed instruction might come in+-- handy.+genJump :: CmmExpr {-the branch target-} -> NatM InstrBlock+genJump expr = do+  (target, _format, code) <- getSomeReg expr+  return (code `appOL` unitOL (annExpr expr (J (TReg target))))++-- -----------------------------------------------------------------------------+--  Unconditional branches+genBranch :: BlockId -> NatM InstrBlock+genBranch = return . toOL . mkJumpInstr++-- -----------------------------------------------------------------------------+-- Conditional branches+genCondJump ::+  BlockId ->+  CmmExpr ->+  NatM InstrBlock+genCondJump bid expr = do+  case expr of+    -- Optimized == 0 case.+    CmmMachOp (MO_Eq w) [x, CmmLit (CmmInt 0 _)] -> do+      (reg_x, _format_x, code_x) <- getSomeReg x+      return $ code_x `snocOL` annExpr expr (BCOND EQ zero (OpReg w reg_x) (TBlock bid))++    -- Optimized /= 0 case.+    CmmMachOp (MO_Ne w) [x, CmmLit (CmmInt 0 _)] -> do+      (reg_x, _format_x, code_x) <- getSomeReg x+      return $ code_x `snocOL` annExpr expr (BCOND NE zero (OpReg w reg_x) (TBlock bid))++    -- Generic case.+    CmmMachOp mop [x, y] -> do+      let ubcond w cmp = do+            -- compute both sides.+            (reg_x, format_x, code_x) <- getSomeReg x+            (reg_y, format_y, code_y) <- getSomeReg y+            let x' = OpReg w reg_x+                y' = OpReg w reg_y+            return $ case w of+              w+                | w == W8 || w == W16 ->+                    code_x+                      `appOL` truncateReg (formatToWidth format_x) w reg_x+                      `appOL` code_y+                      `appOL` truncateReg (formatToWidth format_y) w reg_y+                      `appOL` code_y+                      `snocOL` annExpr expr (BCOND cmp x' y' (TBlock bid))+              _ ->+                code_x+                  `appOL` code_y+                  `snocOL` annExpr expr (BCOND cmp x' y' (TBlock bid))++          sbcond w cmp = do+            -- compute both sides.+            (reg_x, format_x, code_x) <- getSomeReg x+            (reg_y, format_y, code_y) <- getSomeReg y+            let x' = OpReg w reg_x+                y' = OpReg w reg_y+            return $ case w of+              w+                | w `elem` [W8, W16, W32] ->+                    code_x+                      `appOL` signExtend (formatToWidth format_x) W64 reg_x reg_x+                      `appOL` code_y+                      `appOL` signExtend (formatToWidth format_y) W64 reg_y reg_y+                      `appOL` unitOL (annExpr expr (BCOND cmp x' y' (TBlock bid)))+              _ -> code_x `appOL` code_y `appOL` unitOL (annExpr expr (BCOND cmp x' y' (TBlock bid)))++          fbcond w cmp = do+            -- ensure we get float regs+            (reg_fx, _format_fx, code_fx) <- getFloatReg x+            (reg_fy, _format_fy, code_fy) <- getFloatReg y+            condOpReg <- OpReg W64 <$> getNewRegNat II64+            oneReg <- getNewRegNat II64+            return $ code_fx+              `appOL` code_fy+              `snocOL` annExpr expr (CSET condOpReg (OpReg w reg_fx) (OpReg w reg_fy) cmp)+              `snocOL` MOV (OpReg W64 oneReg) (OpImm (ImmInt 1))+              `snocOL` BCOND EQ condOpReg (OpReg w oneReg) (TBlock bid)++      case mop of+        MO_F_Eq w -> fbcond w EQ+        MO_F_Ne w -> fbcond w NE+        MO_F_Gt w -> fbcond w FGT+        MO_F_Ge w -> fbcond w FGE+        MO_F_Lt w -> fbcond w FLT+        MO_F_Le w -> fbcond w FLE+        MO_Eq w -> sbcond w EQ+        MO_Ne w -> sbcond w NE+        MO_S_Gt w -> sbcond w SGT+        MO_S_Ge w -> sbcond w SGE+        MO_S_Lt w -> sbcond w SLT+        MO_S_Le w -> sbcond w SLE+        MO_U_Gt w -> ubcond w UGT+        MO_U_Ge w -> ubcond w UGE+        MO_U_Lt w -> ubcond w ULT+        MO_U_Le w -> ubcond w ULE+        _ -> pprPanic "RV64.genCondJump:case mop: " (text $ show expr)+    _ -> pprPanic "RV64.genCondJump: " (text $ show expr)++-- | Generate conditional branching instructions+--+-- This is basically an "if with else" statement.+genCondBranch ::+  -- | the true branch target+  BlockId ->+  -- | the false branch target+  BlockId ->+  -- | the condition on which to branch+  CmmExpr ->+  -- | Instructions+  NatM InstrBlock+genCondBranch true false expr =+  appOL+    <$> genCondJump true expr+    <*> genBranch false++-- -----------------------------------------------------------------------------+--  Generating C calls++-- | Generate a call to a C function.+--+-- - Integer values are passed in GP registers a0-a7.+-- - Floating point values are passed in FP registers fa0-fa7.+-- - If there are no free floating point registers, the FP values are passed in GP registers.+-- - If all GP registers are taken, the values are spilled as whole words (!) onto the stack.+-- - For integers/words, the return value is in a0.+-- - The return value is in fa0 if the return type is a floating point value.+genCCall ::+  ForeignTarget -> -- function to call+  [CmmFormal] -> -- where to put the result+  [CmmActual] -> -- arguments (of mixed type)+  NatM InstrBlock+-- TODO: Specialize where we can.+-- Generic impl+genCCall target@(ForeignTarget expr _cconv) dest_regs arg_regs = do+  -- we want to pass arg_regs into allArgRegs+  -- The target :: ForeignTarget call can either+  -- be a foreign procedure with an address expr+  -- and a calling convention.+  (call_target_reg, call_target_code) <-+    -- Compute the address of the call target into a register. This+    -- addressing enables us to jump through the whole address space+    -- without further ado. PC-relative addressing would involve+    -- instructions to do similar, though.+    do+      (reg, _format, reg_code) <- getSomeReg expr+      pure (reg, reg_code)+  -- compute the code and register logic for all arg_regs.+  -- this will give us the format information to match on.+  arg_regs' <- mapM getSomeReg arg_regs++  -- Now this is stupid.  Our Cmm expressions doesn't carry the proper sizes+  -- so while in Cmm we might get W64 incorrectly for an int, that is W32 in+  -- STG; this then breaks packing of stack arguments, if we need to pack+  -- for the pcs, e.g. darwinpcs.  Option one would be to fix the Int type+  -- in Cmm proper. Option two, which we choose here is to use extended Hint+  -- information to contain the size information and use that when packing+  -- arguments, spilled onto the stack.+  let (_res_hints, arg_hints) = foreignTargetHints target+      arg_regs'' = zipWith (\(r, f, c) h -> (r, f, h, c)) arg_regs' arg_hints++  (stackSpaceWords, passRegs, passArgumentsCode) <- passArguments allGpArgRegs allFpArgRegs arg_regs'' 0 [] nilOL++  readResultsCode <- readResults allGpArgRegs allFpArgRegs dest_regs [] nilOL++  let moveStackDown 0 =+        toOL+          [ PUSH_STACK_FRAME,+            DELTA (-16)+          ]+      moveStackDown i | odd i = moveStackDown (i + 1)+      moveStackDown i =+        toOL+          [ PUSH_STACK_FRAME,+            SUB (OpReg W64 spMachReg) (OpReg W64 spMachReg) (OpImm (ImmInt (8 * i))),+            DELTA (-8 * i - 16)+          ]+      moveStackUp 0 =+        toOL+          [ POP_STACK_FRAME,+            DELTA 0+          ]+      moveStackUp i | odd i = moveStackUp (i + 1)+      moveStackUp i =+        toOL+          [ ADD (OpReg W64 spMachReg) (OpReg W64 spMachReg) (OpImm (ImmInt (8 * i))),+            POP_STACK_FRAME,+            DELTA 0+          ]++  let code =+        call_target_code -- compute the label (possibly into a register)+          `appOL` moveStackDown stackSpaceWords+          `appOL` passArgumentsCode -- put the arguments into x0, ...+          `snocOL` BL call_target_reg passRegs -- branch and link (C calls aren't tail calls, but return)+          `appOL` readResultsCode -- parse the results into registers+          `appOL` moveStackUp stackSpaceWords+  return code+  where+    -- Implementiation of the RISCV ABI calling convention.+    -- https://github.com/riscv-non-isa/riscv-elf-psabi-doc/blob/948463cd5dbebea7c1869e20146b17a2cc8fda2f/riscv-cc.adoc#integer-calling-convention+    passArguments :: [Reg] -> [Reg] -> [(Reg, Format, ForeignHint, InstrBlock)] -> Int -> [Reg] -> InstrBlock -> NatM (Int, [Reg], InstrBlock)+    -- Base case: no more arguments to pass (left)+    passArguments _ _ [] stackSpaceWords accumRegs accumCode = return (stackSpaceWords, accumRegs, accumCode)+    -- Still have GP regs, and we want to pass an GP argument.+    passArguments (gpReg : gpRegs) fpRegs ((r, format, hint, code_r) : args) stackSpaceWords accumRegs accumCode | isIntFormat format = do+      -- RISCV64 Integer Calling Convention: "When passed in registers or on the+      -- stack, integer scalars narrower than XLEN bits are widened according to+      -- the sign of their type up to 32 bits, then sign-extended to XLEN bits."+      let w = formatToWidth format+          assignArg =+            if hint == SignedHint+              then+                COMMENT (text "Pass gp argument sign-extended (SignedHint): " <> ppr r)+                  `consOL` signExtend w W64 r gpReg+              else+                toOL+                  [ COMMENT (text "Pass gp argument sign-extended (SignedHint): " <> ppr r),+                    MOV (OpReg w gpReg) (OpReg w r)+                  ]+          accumCode' =+            accumCode+              `appOL` code_r+              `appOL` assignArg+      passArguments gpRegs fpRegs args stackSpaceWords (gpReg : accumRegs) accumCode'++    -- Still have FP regs, and we want to pass an FP argument.+    passArguments gpRegs (fpReg : fpRegs) ((r, format, _hint, code_r) : args) stackSpaceWords accumRegs accumCode | isFloatFormat format = do+      let w = formatToWidth format+          mov = MOV (OpReg w fpReg) (OpReg w r)+          accumCode' =+            accumCode+              `appOL` code_r+              `snocOL` ann (text "Pass fp argument: " <> ppr r) mov+      passArguments gpRegs fpRegs args stackSpaceWords (fpReg : accumRegs) accumCode'++    -- No mor regs left to pass. Must pass on stack.+    passArguments [] [] ((r, format, hint, code_r) : args) stackSpaceWords accumRegs accumCode = do+      let w = formatToWidth format+          spOffet = 8 * stackSpaceWords+          str = STR format (OpReg w r) (OpAddr (AddrRegImm spMachReg (ImmInt spOffet)))+          stackCode =+            if hint == SignedHint+              then+                code_r+                  `appOL` signExtend w W64 r tmpReg+                  `snocOL` ann (text "Pass signed argument (size " <> ppr w <> text ") on the stack: " <> ppr tmpReg) str+              else+                code_r+                  `snocOL` ann (text "Pass unsigned argument (size " <> ppr w <> text ") on the stack: " <> ppr r) str+      passArguments [] [] args (stackSpaceWords + 1) accumRegs (stackCode `appOL` accumCode)++    -- Still have fpRegs left, but want to pass a GP argument. Must be passed on the stack then.+    passArguments [] fpRegs ((r, format, _hint, code_r) : args) stackSpaceWords accumRegs accumCode | isIntFormat format = do+      let w = formatToWidth format+          spOffet = 8 * stackSpaceWords+          str = STR format (OpReg w r) (OpAddr (AddrRegImm spMachReg (ImmInt spOffet)))+          stackCode =+            code_r+              `snocOL` ann (text "Pass argument (size " <> ppr w <> text ") on the stack: " <> ppr r) str+      passArguments [] fpRegs args (stackSpaceWords + 1) accumRegs (stackCode `appOL` accumCode)++    -- Still have gpRegs left, but want to pass a FP argument. Must be passed in gpReg then.+    passArguments (gpReg : gpRegs) [] ((r, format, _hint, code_r) : args) stackSpaceWords accumRegs accumCode | isFloatFormat format = do+      let w = formatToWidth format+          mov = MOV (OpReg w gpReg) (OpReg w r)+          accumCode' =+            accumCode+              `appOL` code_r+              `snocOL` ann (text "Pass fp argument in gpReg: " <> ppr r) mov+      passArguments gpRegs [] args stackSpaceWords (gpReg : accumRegs) accumCode'+    passArguments _ _ _ _ _ _ = pprPanic "passArguments" (text "invalid state")++    readResults :: [Reg] -> [Reg] -> [LocalReg] -> [Reg] -> InstrBlock -> NatM InstrBlock+    readResults _ _ [] _ accumCode = return accumCode+    readResults [] _ _ _ _ = do+      platform <- getPlatform+      pprPanic "genCCall, out of gp registers when reading results" (pdoc platform target)+    readResults _ [] _ _ _ = do+      platform <- getPlatform+      pprPanic "genCCall, out of fp registers when reading results" (pdoc platform target)+    readResults (gpReg : gpRegs) (fpReg : fpRegs) (dst : dsts) accumRegs accumCode = do+      -- gp/fp reg -> dst+      platform <- getPlatform+      let rep = cmmRegType (CmmLocal dst)+          format = cmmTypeFormat rep+          w = cmmRegWidth (CmmLocal dst)+          r_dst = getRegisterReg platform (CmmLocal dst)+      if isFloatFormat format+        then readResults (gpReg : gpRegs) fpRegs dsts (fpReg : accumRegs) (accumCode `snocOL` MOV (OpReg w r_dst) (OpReg w fpReg))+        else+          readResults gpRegs (fpReg : fpRegs) dsts (gpReg : accumRegs)+            $ accumCode+            `snocOL` MOV (OpReg w r_dst) (OpReg w gpReg)+            `appOL`+            -- truncate, otherwise an unexpectedly big value might be used in upfollowing calculations+            truncateReg W64 w r_dst+genCCall (PrimTarget mop) dest_regs arg_regs = do+  case mop of+    MO_F32_Fabs+      | [arg_reg] <- arg_regs,+        [dest_reg] <- dest_regs ->+          unaryFloatOp W32 (\d x -> unitOL $ FABS d x) arg_reg dest_reg+    MO_F64_Fabs+      | [arg_reg] <- arg_regs,+        [dest_reg] <- dest_regs ->+          unaryFloatOp W64 (\d x -> unitOL $ FABS d x) arg_reg dest_reg+    -- 64 bit float ops+    MO_F64_Pwr -> mkCCall "pow"+    MO_F64_Sin -> mkCCall "sin"+    MO_F64_Cos -> mkCCall "cos"+    MO_F64_Tan -> mkCCall "tan"+    MO_F64_Sinh -> mkCCall "sinh"+    MO_F64_Cosh -> mkCCall "cosh"+    MO_F64_Tanh -> mkCCall "tanh"+    MO_F64_Asin -> mkCCall "asin"+    MO_F64_Acos -> mkCCall "acos"+    MO_F64_Atan -> mkCCall "atan"+    MO_F64_Asinh -> mkCCall "asinh"+    MO_F64_Acosh -> mkCCall "acosh"+    MO_F64_Atanh -> mkCCall "atanh"+    MO_F64_Log -> mkCCall "log"+    MO_F64_Log1P -> mkCCall "log1p"+    MO_F64_Exp -> mkCCall "exp"+    MO_F64_ExpM1 -> mkCCall "expm1"+    MO_F64_Fabs -> mkCCall "fabs"+    MO_F64_Sqrt -> mkCCall "sqrt"+    -- 32 bit float ops+    MO_F32_Pwr -> mkCCall "powf"+    MO_F32_Sin -> mkCCall "sinf"+    MO_F32_Cos -> mkCCall "cosf"+    MO_F32_Tan -> mkCCall "tanf"+    MO_F32_Sinh -> mkCCall "sinhf"+    MO_F32_Cosh -> mkCCall "coshf"+    MO_F32_Tanh -> mkCCall "tanhf"+    MO_F32_Asin -> mkCCall "asinf"+    MO_F32_Acos -> mkCCall "acosf"+    MO_F32_Atan -> mkCCall "atanf"+    MO_F32_Asinh -> mkCCall "asinhf"+    MO_F32_Acosh -> mkCCall "acoshf"+    MO_F32_Atanh -> mkCCall "atanhf"+    MO_F32_Log -> mkCCall "logf"+    MO_F32_Log1P -> mkCCall "log1pf"+    MO_F32_Exp -> mkCCall "expf"+    MO_F32_ExpM1 -> mkCCall "expm1f"+    MO_F32_Fabs -> mkCCall "fabsf"+    MO_F32_Sqrt -> mkCCall "sqrtf"+    -- 64-bit primops+    MO_I64_ToI -> mkCCall "hs_int64ToInt"+    MO_I64_FromI -> mkCCall "hs_intToInt64"+    MO_W64_ToW -> mkCCall "hs_word64ToWord"+    MO_W64_FromW -> mkCCall "hs_wordToWord64"+    MO_x64_Neg -> mkCCall "hs_neg64"+    MO_x64_Add -> mkCCall "hs_add64"+    MO_x64_Sub -> mkCCall "hs_sub64"+    MO_x64_Mul -> mkCCall "hs_mul64"+    MO_I64_Quot -> mkCCall "hs_quotInt64"+    MO_I64_Rem -> mkCCall "hs_remInt64"+    MO_W64_Quot -> mkCCall "hs_quotWord64"+    MO_W64_Rem -> mkCCall "hs_remWord64"+    MO_x64_And -> mkCCall "hs_and64"+    MO_x64_Or -> mkCCall "hs_or64"+    MO_x64_Xor -> mkCCall "hs_xor64"+    MO_x64_Not -> mkCCall "hs_not64"+    MO_x64_Shl -> mkCCall "hs_uncheckedShiftL64"+    MO_I64_Shr -> mkCCall "hs_uncheckedIShiftRA64"+    MO_W64_Shr -> mkCCall "hs_uncheckedShiftRL64"+    MO_x64_Eq -> mkCCall "hs_eq64"+    MO_x64_Ne -> mkCCall "hs_ne64"+    MO_I64_Ge -> mkCCall "hs_geInt64"+    MO_I64_Gt -> mkCCall "hs_gtInt64"+    MO_I64_Le -> mkCCall "hs_leInt64"+    MO_I64_Lt -> mkCCall "hs_ltInt64"+    MO_W64_Ge -> mkCCall "hs_geWord64"+    MO_W64_Gt -> mkCCall "hs_gtWord64"+    MO_W64_Le -> mkCCall "hs_leWord64"+    MO_W64_Lt -> mkCCall "hs_ltWord64"+    -- Conversion+    MO_UF_Conv w -> mkCCall (word2FloatLabel w)+    -- Optional MachOps+    -- These are enabled/disabled by backend flags: GHC.StgToCmm.Config+    MO_S_Mul2 _w -> unsupported mop+    MO_S_QuotRem _w -> unsupported mop+    MO_U_QuotRem _w -> unsupported mop+    MO_U_QuotRem2 _w -> unsupported mop+    MO_Add2 _w -> unsupported mop+    MO_AddWordC _w -> unsupported mop+    MO_SubWordC _w -> unsupported mop+    MO_AddIntC _w -> unsupported mop+    MO_SubIntC _w -> unsupported mop+    MO_U_Mul2 _w -> unsupported mop+    MO_VS_Quot {} -> unsupported mop+    MO_VS_Rem {} -> unsupported mop+    MO_VU_Quot {} -> unsupported mop+    MO_VU_Rem {} -> unsupported mop+    MO_I64X2_Min -> unsupported mop+    MO_I64X2_Max -> unsupported mop+    MO_W64X2_Min -> unsupported mop+    MO_W64X2_Max -> unsupported mop+    -- Memory Ordering+    -- The related C functions are:+    -- #include <stdatomic.h>+    -- atomic_thread_fence(memory_order_acquire);+    -- atomic_thread_fence(memory_order_release);+    -- atomic_thread_fence(memory_order_seq_cst);+    MO_AcquireFence -> pure (unitOL (FENCE FenceRead FenceReadWrite))+    MO_ReleaseFence -> pure (unitOL (FENCE FenceReadWrite FenceWrite))+    MO_SeqCstFence -> pure (unitOL (FENCE FenceReadWrite FenceReadWrite))+    MO_Touch -> pure nilOL -- Keep variables live (when using interior pointers)+    -- Prefetch+    MO_Prefetch_Data _n -> pure nilOL -- Prefetch hint.++    -- Memory copy/set/move/cmp, with alignment for optimization+    MO_Memcpy _align -> mkCCall "memcpy"+    MO_Memset _align -> mkCCall "memset"+    MO_Memmove _align -> mkCCall "memmove"+    MO_Memcmp _align -> mkCCall "memcmp"+    MO_SuspendThread -> mkCCall "suspendThread"+    MO_ResumeThread -> mkCCall "resumeThread"+    MO_PopCnt w -> mkCCall (popCntLabel w)+    MO_Pdep w -> mkCCall (pdepLabel w)+    MO_Pext w -> mkCCall (pextLabel w)+    MO_Clz w -> mkCCall (clzLabel w)+    MO_Ctz w -> mkCCall (ctzLabel w)+    MO_BSwap w -> mkCCall (bSwapLabel w)+    MO_BRev w -> mkCCall (bRevLabel w)+    -- Atomic read-modify-write.+    mo@(MO_AtomicRead w ord)+      | [p_reg] <- arg_regs,+        [dst_reg] <- dest_regs -> do+          (p, _fmt_p, code_p) <- getSomeReg p_reg+          platform <- getPlatform+          -- Analog to the related MachOps (above)+          -- The related C functions are:+          -- #include <stdatomic.h>+          -- __atomic_load_n(&a, __ATOMIC_ACQUIRE);+          -- __atomic_load_n(&a, __ATOMIC_SEQ_CST);+          let instrs = case ord of+                MemOrderRelaxed -> unitOL $ ann moDescr (LDR (intFormat w) (OpReg w dst) (OpAddr $ AddrReg p))+                MemOrderAcquire ->+                  toOL+                    [ ann moDescr (LDR (intFormat w) (OpReg w dst) (OpAddr $ AddrReg p)),+                      FENCE FenceRead FenceReadWrite+                    ]+                MemOrderSeqCst ->+                  toOL+                    [ ann moDescr (FENCE FenceReadWrite FenceReadWrite),+                      LDR (intFormat w) (OpReg w dst) (OpAddr $ AddrReg p),+                      FENCE FenceRead FenceReadWrite+                    ]+                MemOrderRelease -> panic $ "Unexpected MemOrderRelease on an AtomicRead: " ++ show mo+              dst = getRegisterReg platform (CmmLocal dst_reg)+              moDescr = (text . show) mo+              code = code_p `appOL` instrs+          return code+      | otherwise -> panic "mal-formed AtomicRead"+    mo@(MO_AtomicWrite w ord)+      | [p_reg, val_reg] <- arg_regs -> do+          (p, _fmt_p, code_p) <- getSomeReg p_reg+          (val, fmt_val, code_val) <- getSomeReg val_reg+          -- Analog to the related MachOps (above)+          -- The related C functions are:+          -- #include <stdatomic.h>+          -- __atomic_store_n(&a, 23, __ATOMIC_SEQ_CST);+          -- __atomic_store_n(&a, 23, __ATOMIC_RELEASE);+          let instrs = case ord of+                MemOrderRelaxed -> unitOL $ ann moDescr (STR fmt_val (OpReg w val) (OpAddr $ AddrReg p))+                MemOrderSeqCst ->+                  toOL+                    [ ann moDescr (FENCE FenceReadWrite FenceWrite),+                      STR fmt_val (OpReg w val) (OpAddr $ AddrReg p),+                      FENCE FenceReadWrite FenceReadWrite+                    ]+                MemOrderRelease ->+                  toOL+                    [ ann moDescr (FENCE FenceReadWrite FenceWrite),+                      STR fmt_val (OpReg w val) (OpAddr $ AddrReg p)+                    ]+                MemOrderAcquire -> panic $ "Unexpected MemOrderAcquire on an AtomicWrite" ++ show mo+              moDescr = (text . show) mo+              code =+                code_p+                  `appOL` code_val+                  `appOL` instrs+          pure code+      | otherwise -> panic "mal-formed AtomicWrite"+    MO_AtomicRMW w amop -> mkCCall (atomicRMWLabel w amop)+    MO_Cmpxchg w -> mkCCall (cmpxchgLabel w)+    -- -- Should be an AtomicRMW variant eventually.+    -- -- Sequential consistent.+    -- TODO: this should be implemented properly!+    MO_Xchg w -> mkCCall (xchgLabel w)+  where+    unsupported :: (Show a) => a -> b+    unsupported mop =+      panic+        ( "outOfLineCmmOp: "+            ++ show mop+            ++ " not supported here"+        )+    mkCCall :: FastString -> NatM InstrBlock+    mkCCall name = do+      config <- getConfig+      target <-+        cmmMakeDynamicReference config CallReference+          $ mkForeignLabel name ForeignLabelInThisPackage IsFunction+      let cconv = ForeignConvention CCallConv [NoHint] [NoHint] CmmMayReturn+      genCCall (ForeignTarget target cconv) dest_regs arg_regs++    unaryFloatOp w op arg_reg dest_reg = do+      platform <- getPlatform+      (reg_fx, _format_x, code_fx) <- getFloatReg arg_reg+      let dst = getRegisterReg platform (CmmLocal dest_reg)+      let code = code_fx `appOL` op (OpReg w dst) (OpReg w reg_fx)+      pure code++{- Note [RISCV64 far jumps]+~~~~~~~~~~~~~~~~~~~~~~~~~~~++RISCV64 conditional jump instructions can only encode an offset of +/-4KiB+(12bits) which is usually enough but can be exceeded in edge cases. In these+cases we will replace:++  b.cond <cond> foo++with the sequence:++  b.cond <cond> <lbl_true>+  b <lbl_false>+  <lbl_true>:+  la reg foo+  b reg+  <lbl_false>:++and++  b foo++with the sequence:++  la reg foo+  b reg++Compared to AArch64 the target label is loaded to a register, because+unconditional jump instructions can only address +/-1MiB. The LA+pseudo-instruction will be replaced by up to two real instructions, ensuring+correct addressing.++One could surely find more efficient replacements, taking PC-relative addressing+into account. This could be a future improvement. (As far branches are pretty+rare, one might question and measure the value of such improvement.)++RISCV has many pseudo-instructions which emit more than one real instructions.+Thus, we count the real instructions after the Assembler has seen them.++We make some simplifications in the name of performance which can result in+overestimating jump <-> label offsets:++\* To avoid having to recalculate the label offsets once we replaced a jump we simply+  assume all label jumps will be expanded to a three instruction far jump sequence.+\* For labels associated with a info table we assume the info table is 64byte large.+  Most info tables are smaller than that but it means we don't have to distinguish+  between multiple types of info tables.++In terms of implementation we walk the instruction stream at least once calculating+label offsets, and if we determine during this that the functions body is big enough+to potentially contain out of range jumps we walk the instructions a second time, replacing+out of range jumps with the sequence of instructions described above.++-}++-- | A conditional jump to a far target+--+-- By loading the far target into a register for the jump, we can address the+-- whole memory range.+genCondFarJump :: (MonadGetUnique m) => Cond -> Operand -> Operand -> BlockId -> m InstrBlock+genCondFarJump cond op1 op2 far_target = do+  skip_lbl_id <- newBlockId+  jmp_lbl_id <- newBlockId++  -- TODO: We can improve this by inverting the condition+  -- but it's not quite trivial since we don't know if we+  -- need to consider float orderings.+  -- So we take the hit of the additional jump in the false+  -- case for now.+  return+    $ toOL+      [ ann (text "Conditional far jump to: " <> ppr far_target)+          $ BCOND cond op1 op2 (TBlock jmp_lbl_id),+        B (TBlock skip_lbl_id),+        NEWBLOCK jmp_lbl_id,+        LDR II64 (OpReg W64 tmpReg) (OpImm (ImmCLbl (blockLbl far_target))),+        B (TReg tmpReg),+        NEWBLOCK skip_lbl_id+      ]++-- | An unconditional jump to a far target+--+-- By loading the far target into a register for the jump, we can address the+-- whole memory range.+genFarJump :: (MonadGetUnique m) => BlockId -> m InstrBlock+genFarJump far_target =+  return+    $ toOL+      [ ann (text "Unconditional far jump to: " <> ppr far_target)+          $ LDR II64 (OpReg W64 tmpReg) (OpImm (ImmCLbl (blockLbl far_target))),+        B (TReg tmpReg)+      ]++-- See Note [RISCV64 far jumps]+data BlockInRange = InRange | NotInRange BlockId++-- See Note [RISCV64 far jumps]+makeFarBranches ::+  Platform ->+  LabelMap RawCmmStatics ->+  [NatBasicBlock Instr] ->+  UniqDSM [NatBasicBlock Instr]+makeFarBranches {- only used when debugging -} _platform statics basic_blocks = do+  -- All offsets/positions are counted in multiples of 4 bytes (the size of RISCV64 instructions)+  -- That is an offset of 1 represents a 4-byte/one instruction offset.+  let (func_size, lblMap) = foldl' calc_lbl_positions (0, mapEmpty) basic_blocks+  if func_size < max_jump_dist+    then pure basic_blocks+    else do+      (_, blocks) <- mapAccumLM (replace_blk lblMap) 0 basic_blocks+      pure $ concat blocks+  where+    -- pprTrace "lblMap" (ppr lblMap) $ basic_blocks++    -- 2^11, 12 bit immediate with one bit is reserved for the sign+    max_jump_dist = 2 ^ (11 :: Int) - 1 :: Int+    -- Currently all inline info tables fit into 64 bytes.+    max_info_size = 16 :: Int+    long_bc_jump_size = 5 :: Int+    long_b_jump_size = 2 :: Int++    -- Replace out of range conditional jumps with unconditional jumps.+    replace_blk :: LabelMap Int -> Int -> GenBasicBlock Instr -> UniqDSM (Int, [GenBasicBlock Instr])+    replace_blk !m !pos (BasicBlock lbl instrs) = do+      -- Account for a potential info table before the label.+      let !block_pos = pos + infoTblSize_maybe lbl+      (!pos', instrs') <- mapAccumLM (replace_jump m) block_pos instrs+      let instrs'' = concat instrs'+      -- We might have introduced new labels, so split the instructions into basic blocks again if neccesary.+      let (top, split_blocks, no_data) = foldr mkBlocks ([], [], []) instrs''+      -- There should be no data in the instruction stream at this point+      massert (null no_data)++      let final_blocks = BasicBlock lbl top : split_blocks+      pure (pos', final_blocks)++    replace_jump :: LabelMap Int -> Int -> Instr -> UniqDSM (Int, [Instr])+    replace_jump !m !pos instr = do+      case instr of+        ANN ann instr -> do+          replace_jump m pos instr >>= \case+            (_, []) -> error "RV64:replace_jump"+            (idx, instr' : instrs') ->+              pure (idx, ANN ann instr' : instrs')+        BCOND cond op1 op2 t ->+          case target_in_range m t pos of+            InRange -> pure (pos + instr_size instr, [instr])+            NotInRange far_target -> do+              jmp_code <- genCondFarJump cond op1 op2 far_target+              pure (pos + instr_size instr, fromOL jmp_code)+        B t ->+          case target_in_range m t pos of+            InRange -> pure (pos + instr_size instr, [instr])+            NotInRange far_target -> do+              jmp_code <- genFarJump far_target+              pure (pos + instr_size instr, fromOL jmp_code)+        _ -> pure (pos + instr_size instr, [instr])++    target_in_range :: LabelMap Int -> Target -> Int -> BlockInRange+    target_in_range m target src =+      case target of+        (TReg {}) -> InRange+        (TBlock bid) -> block_in_range m src bid++    block_in_range :: LabelMap Int -> Int -> BlockId -> BlockInRange+    block_in_range m src_pos dest_lbl =+      case mapLookup dest_lbl m of+        Nothing ->+          pprTrace "not in range" (ppr dest_lbl)+            $ NotInRange dest_lbl+        Just dest_pos ->+          if abs (dest_pos - src_pos) < max_jump_dist+            then InRange+            else NotInRange dest_lbl++    calc_lbl_positions :: (Int, LabelMap Int) -> GenBasicBlock Instr -> (Int, LabelMap Int)+    calc_lbl_positions (pos, m) (BasicBlock lbl instrs) =+      let !pos' = pos + infoTblSize_maybe lbl+       in foldl' instr_pos (pos', mapInsert lbl pos' m) instrs++    instr_pos :: (Int, LabelMap Int) -> Instr -> (Int, LabelMap Int)+    instr_pos (pos, m) instr = (pos + instr_size instr, m)++    infoTblSize_maybe bid =+      case mapLookup bid statics of+        Nothing -> 0 :: Int+        Just _info_static -> max_info_size++    instr_size :: Instr -> Int+    instr_size i = case i of+      COMMENT {} -> 0+      MULTILINE_COMMENT {} -> 0+      ANN _ instr -> instr_size instr+      LOCATION {} -> 0+      DELTA {} -> 0+      -- At this point there should be no NEWBLOCK in the instruction stream (pos, mapInsert bid pos m)+      NEWBLOCK {} -> panic "mkFarBranched - Unexpected"+      LDATA {} -> panic "mkFarBranched - Unexpected"+      PUSH_STACK_FRAME -> 4+      POP_STACK_FRAME -> 4+      ADD {} -> 1+      MUL {} -> 1+      MULH {} -> 1+      NEG {} -> 1+      DIV {} -> 1+      REM {} -> 1+      REMU {} -> 1+      SUB {} -> 1+      DIVU {} -> 1+      AND {} -> 1+      OR {} -> 1+      SRA {} -> 1+      XOR {} -> 1+      SLL {} -> 1+      SRL {} -> 1+      MOV {} -> 2+      ORI {} -> 1+      XORI {} -> 1+      CSET {} -> 2+      STR {} -> 1+      LDR {} -> 3+      LDRU {} -> 1+      FENCE {} -> 1+      FCVT {} -> 1+      FABS {} -> 1+      FMIN {} -> 1+      FMAX {} -> 1+      FMA {} -> 1+      -- estimate the subsituted size for jumps to lables+      -- jumps to registers have size 1+      BCOND {} -> long_bc_jump_size+      B (TBlock _) -> long_b_jump_size+      B (TReg _) -> 1+      J op -> instr_size (B op)+      BL _ _ -> 1+      J_TBL {} -> 1
+ GHC/CmmToAsm/RV64/Cond.hs view
@@ -0,0 +1,42 @@+module GHC.CmmToAsm.RV64.Cond+  ( Cond (..),+  )+where++import GHC.Prelude hiding (EQ)++-- | Condition codes.+--+-- Used in conditional branches and bit setters. According to the available+-- instruction set, some conditions are encoded as their negated opposites. I.e.+-- these are logical things that don't necessarily map 1:1 to hardware/ISA.+data Cond+  = -- | int and float+    EQ+  | -- | int and float+    NE+  | -- | signed less than+    SLT+  | -- | signed less than or equal+    SLE+  | -- | signed greater than or equal+    SGE+  | -- | signed greater than+    SGT+  | -- | unsigned less than+    ULT+  | -- | unsigned less than or equal+    ULE+  | -- | unsigned greater than or equal+    UGE+  | -- | unsigned greater than+    UGT+  | -- | floating point instruction @flt@+    FLT+  | -- | floating point instruction @fle@+    FLE+  | -- | floating point instruction @fge@+    FGE+  | -- | floating point instruction @fgt@+    FGT+  deriving (Eq, Show)
+ GHC/CmmToAsm/RV64/Instr.hs view
@@ -0,0 +1,868 @@+-- All instructions will be rendered eventually. Thus, there's no benefit in+-- being lazy in data types.+{-# LANGUAGE StrictData #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module GHC.CmmToAsm.RV64.Instr where++import Data.Maybe+import GHC.Cmm+import GHC.Cmm.BlockId+import GHC.Cmm.CLabel+import GHC.Cmm.Dataflow.Label+import GHC.CmmToAsm.Config+import GHC.CmmToAsm.Format+import GHC.CmmToAsm.Instr (RegUsage (..))+import GHC.CmmToAsm.RV64.Cond+import GHC.CmmToAsm.RV64.Regs+import GHC.CmmToAsm.Types+import GHC.CmmToAsm.Utils+import GHC.Data.FastString (LexicalFastString)+import GHC.Platform+import GHC.Platform.Reg+import GHC.Platform.Regs+import GHC.Platform.Reg.Class.Separate+import GHC.Prelude+import GHC.Stack+import GHC.Types.Unique.DSM+import GHC.Utils.Outputable+import GHC.Utils.Panic++-- | Stack frame header size in bytes.+--+-- The stack frame header is made of the values that are always saved+-- (regardless of the context.) It consists of the saved return address and a+-- pointer to the previous frame. Thus, its size is two stack frame slots which+-- equals two addresses/words (2 * 8 byte).+stackFrameHeaderSize :: Int+stackFrameHeaderSize = 2 * spillSlotSize++-- | All registers are 8 byte wide.+spillSlotSize :: Int+spillSlotSize = 8++-- | The number of bytes that the stack pointer should be aligned to.+stackAlign :: Int+stackAlign = 16++-- | The number of spill slots available without allocating more.+maxSpillSlots :: NCGConfig -> Int+maxSpillSlots config =+  ( (ncgSpillPreallocSize config - stackFrameHeaderSize)+      `div` spillSlotSize+  )+    - 1++-- | Convert a spill slot number to a *byte* offset.+spillSlotToOffset :: Int -> Int+spillSlotToOffset slot =+  stackFrameHeaderSize + spillSlotSize * slot++instance Outputable RegUsage where+  ppr (RU reads writes) = text "RegUsage(reads:" <+> ppr reads <> comma <+> text "writes:" <+> ppr writes <> char ')'++-- | Get the registers that are being used by this instruction.+-- regUsage doesn't need to do any trickery for jumps and such.+-- Just state precisely the regs read and written by that insn.+-- The consequences of control flow transfers, as far as register+-- allocation goes, are taken care of by the register allocator.+--+-- RegUsage = RU [<read regs>] [<write regs>]+regUsageOfInstr :: Platform -> Instr -> RegUsage+regUsageOfInstr platform instr = case instr of+  ANN _ i -> regUsageOfInstr platform i+  COMMENT {} -> usage ([], [])+  MULTILINE_COMMENT {} -> usage ([], [])+  PUSH_STACK_FRAME -> usage ([], [])+  POP_STACK_FRAME -> usage ([], [])+  LOCATION {} -> usage ([], [])+  DELTA {} -> usage ([], [])+  ADD dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)+  MUL dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)+  NEG dst src -> usage (regOp src, regOp dst)+  MULH dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)+  DIV dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)+  REM dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)+  REMU dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)+  SUB dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)+  DIVU dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)+  AND dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)+  OR dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)+  SRA dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)+  XOR dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)+  SLL dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)+  SRL dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)+  MOV dst src -> usage (regOp src, regOp dst)+  -- ORI's third operand is always an immediate+  ORI dst src1 _ -> usage (regOp src1, regOp dst)+  XORI dst src1 _ -> usage (regOp src1, regOp dst)+  J_TBL _ _ t -> usage ([t], [])+  J t -> usage (regTarget t, [])+  B t -> usage (regTarget t, [])+  BCOND _ l r t -> usage (regTarget t ++ regOp l ++ regOp r, [])+  BL t ps -> usage (t : ps, callerSavedRegisters)+  CSET dst l r _ -> usage (regOp l ++ regOp r, regOp dst)+  STR _ src dst -> usage (regOp src ++ regOp dst, [])+  LDR _ dst src -> usage (regOp src, regOp dst)+  LDRU _ dst src -> usage (regOp src, regOp dst)+  FENCE _ _ -> usage ([], [])+  FCVT _variant dst src -> usage (regOp src, regOp dst)+  FABS dst src -> usage (regOp src, regOp dst)+  FMIN dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)+  FMAX dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst)+  FMA _ dst src1 src2 src3 ->+    usage (regOp src1 ++ regOp src2 ++ regOp src3, regOp dst)+  _ -> panic $ "regUsageOfInstr: " ++ instrCon instr+  where+    -- filtering the usage is necessary, otherwise the register+    -- allocator will try to allocate pre-defined fixed stg+    -- registers as well, as they show up.+    usage :: ([Reg], [Reg]) -> RegUsage+    usage (srcRegs, dstRegs) =+      RU+        (map mkFmt $ filter (interesting platform) srcRegs)+        (map mkFmt $ filter (interesting platform) dstRegs)++      -- SIMD NCG TODO: the format here is used for register spilling/unspilling.+      -- As the RISCV64 NCG does not currently support SIMD registers,+      -- this simple logic is OK.+    mkFmt r = RegWithFormat r fmt+      where+        fmt = case cls of+                RcInteger -> II64+                RcFloat   -> FF64+                RcVector  -> sorry "The RISCV64 NCG does not (yet) support vectors; please use -fllvm."+        cls = case r of+                RegVirtual vr -> classOfVirtualReg (platformArch platform) vr+                RegReal rr -> classOfRealReg rr++    regAddr :: AddrMode -> [Reg]+    regAddr (AddrRegImm r1 _imm) = [r1]+    regAddr (AddrReg r1) = [r1]++    regOp :: Operand -> [Reg]+    regOp (OpReg _w r1) = [r1]+    regOp (OpAddr a) = regAddr a+    regOp (OpImm _imm) = []++    regTarget :: Target -> [Reg]+    regTarget (TBlock _bid) = []+    regTarget (TReg r1) = [r1]++    -- Is this register interesting for the register allocator?+    interesting :: Platform -> Reg -> Bool+    interesting _ (RegVirtual _) = True+    interesting platform (RegReal (RealRegSingle i)) = freeReg platform i++-- | Caller-saved registers (according to calling convention)+--+-- These registers may be clobbered after a jump.+callerSavedRegisters :: [Reg]+callerSavedRegisters =+  [regSingle raRegNo]+    ++ map regSingle [t0RegNo .. t2RegNo]+    ++ map regSingle [a0RegNo .. a7RegNo]+    ++ map regSingle [t3RegNo .. t6RegNo]+    ++ map regSingle [ft0RegNo .. ft7RegNo]+    ++ map regSingle [fa0RegNo .. fa7RegNo]++-- | Apply a given mapping to all the register references in this instruction.+patchRegsOfInstr :: Instr -> (Reg -> Reg) -> Instr+patchRegsOfInstr instr env = case instr of+  ANN d i -> ANN d (patchRegsOfInstr i env)+  COMMENT {} -> instr+  MULTILINE_COMMENT {} -> instr+  PUSH_STACK_FRAME -> instr+  POP_STACK_FRAME -> instr+  LOCATION {} -> instr+  DELTA {} -> instr+  ADD o1 o2 o3 -> ADD (patchOp o1) (patchOp o2) (patchOp o3)+  MUL o1 o2 o3 -> MUL (patchOp o1) (patchOp o2) (patchOp o3)+  NEG o1 o2 -> NEG (patchOp o1) (patchOp o2)+  MULH o1 o2 o3 -> MULH (patchOp o1) (patchOp o2) (patchOp o3)+  DIV o1 o2 o3 -> DIV (patchOp o1) (patchOp o2) (patchOp o3)+  REM o1 o2 o3 -> REM (patchOp o1) (patchOp o2) (patchOp o3)+  REMU o1 o2 o3 -> REMU (patchOp o1) (patchOp o2) (patchOp o3)+  SUB o1 o2 o3 -> SUB (patchOp o1) (patchOp o2) (patchOp o3)+  DIVU o1 o2 o3 -> DIVU (patchOp o1) (patchOp o2) (patchOp o3)+  AND o1 o2 o3 -> AND (patchOp o1) (patchOp o2) (patchOp o3)+  OR o1 o2 o3 -> OR (patchOp o1) (patchOp o2) (patchOp o3)+  SRA o1 o2 o3 -> SRA (patchOp o1) (patchOp o2) (patchOp o3)+  XOR o1 o2 o3 -> XOR (patchOp o1) (patchOp o2) (patchOp o3)+  SLL o1 o2 o3 -> SLL (patchOp o1) (patchOp o2) (patchOp o3)+  SRL o1 o2 o3 -> SRL (patchOp o1) (patchOp o2) (patchOp o3)+  MOV o1 o2 -> MOV (patchOp o1) (patchOp o2)+  -- o3 cannot be a register for ORI (always an immediate)+  ORI o1 o2 o3 -> ORI (patchOp o1) (patchOp o2) (patchOp o3)+  XORI o1 o2 o3 -> XORI (patchOp o1) (patchOp o2) (patchOp o3)+  J_TBL ids mbLbl t -> J_TBL ids mbLbl (env t)+  J t -> J (patchTarget t)+  B t -> B (patchTarget t)+  BL t ps -> BL (patchReg t) ps+  BCOND c o1 o2 t -> BCOND c (patchOp o1) (patchOp o2) (patchTarget t)+  CSET o l r c -> CSET (patchOp o) (patchOp l) (patchOp r) c+  STR f o1 o2 -> STR f (patchOp o1) (patchOp o2)+  LDR f o1 o2 -> LDR f (patchOp o1) (patchOp o2)+  LDRU f o1 o2 -> LDRU f (patchOp o1) (patchOp o2)+  FENCE o1 o2 -> FENCE o1 o2+  FCVT variant o1 o2 -> FCVT variant (patchOp o1) (patchOp o2)+  FABS o1 o2 -> FABS (patchOp o1) (patchOp o2)+  FMIN o1 o2 o3 -> FMIN (patchOp o1) (patchOp o2) (patchOp o3)+  FMAX o1 o2 o3 -> FMAX (patchOp o1) (patchOp o2) (patchOp o3)+  FMA s o1 o2 o3 o4 ->+    FMA s (patchOp o1) (patchOp o2) (patchOp o3) (patchOp o4)+  _ -> panic $ "patchRegsOfInstr: " ++ instrCon instr+  where+    patchOp :: Operand -> Operand+    patchOp (OpReg w r) = OpReg w (env r)+    patchOp (OpAddr a) = OpAddr (patchAddr a)+    patchOp opImm = opImm++    patchTarget :: Target -> Target+    patchTarget (TReg r) = TReg (env r)+    patchTarget tBlock = tBlock++    patchAddr :: AddrMode -> AddrMode+    patchAddr (AddrRegImm r1 imm) = AddrRegImm (env r1) imm+    patchAddr (AddrReg r) = AddrReg (env r)++    patchReg :: Reg -> Reg+    patchReg = env++-- | Checks whether this instruction is a jump/branch instruction.+--+-- One that can change the flow of control in a way that the+-- register allocator needs to worry about.+isJumpishInstr :: Instr -> Bool+isJumpishInstr instr = case instr of+  ANN _ i -> isJumpishInstr i+  J_TBL {} -> True+  J {} -> True+  B {} -> True+  BL {} -> True+  BCOND {} -> True+  _ -> False++canFallthroughTo :: Instr -> BlockId -> Bool+canFallthroughTo insn bid =+  case insn of+    J (TBlock target) -> bid == target+    B (TBlock target) -> bid == target+    BCOND _ _ _ (TBlock target) -> bid == target+    J_TBL targets _ _ -> all isTargetBid targets+    _ -> False+  where+    isTargetBid target = case target of+      Nothing -> True+      Just target -> target == bid++-- | Get the `BlockId`s of the jump destinations (if any)+jumpDestsOfInstr :: Instr -> [BlockId]+jumpDestsOfInstr (ANN _ i) = jumpDestsOfInstr i+jumpDestsOfInstr (J_TBL ids _mbLbl _r) = catMaybes ids+jumpDestsOfInstr (J t) = [id | TBlock id <- [t]]+jumpDestsOfInstr (B t) = [id | TBlock id <- [t]]+jumpDestsOfInstr (BCOND _ _ _ t) = [id | TBlock id <- [t]]+jumpDestsOfInstr _ = []++-- | Change the destination of this (potential) jump instruction.+--+-- Used in the linear allocator when adding fixup blocks for join+-- points.+patchJumpInstr :: Instr -> (BlockId -> BlockId) -> Instr+patchJumpInstr instr patchF =+  case instr of+    ANN d i -> ANN d (patchJumpInstr i patchF)+    J_TBL ids mbLbl r -> J_TBL (map (fmap patchF) ids) mbLbl r+    J (TBlock bid) -> J (TBlock (patchF bid))+    B (TBlock bid) -> B (TBlock (patchF bid))+    BCOND c o1 o2 (TBlock bid) -> BCOND c o1 o2 (TBlock (patchF bid))+    _ -> panic $ "patchJumpInstr: " ++ instrCon instr++-- -----------------------------------------------------------------------------+-- Note [RISCV64 Spills and Reloads]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- We reserve @RESERVED_C_STACK_BYTES@ on the C stack for spilling and reloading+-- registers. The load and store instructions of RISCV64 address with a signed+-- 12-bit immediate + a register; machine stackpointer (sp/x2) in this case.+--+-- The @RESERVED_C_STACK_BYTES@ is 16k, so we can't always address into it in a+-- single load/store instruction. There are offsets to sp (not to be confused+-- with STG's SP!) which need a register to be calculated.+--+-- Using sp to compute the offset would violate assumptions about the stack pointer+-- pointing to the top of the stack during signal handling.  As we can't force+-- every signal to use its own stack, we have to ensure that the stack pointer+-- always points to the top of the stack, and we can't use it for computation.+--+-- So, we reserve one register (TMP) for this purpose (and other, unrelated+-- intermediate operations.) See Note [The made-up RISCV64 TMP (IP) register]++-- | Generate instructions to spill a register into a spill slot.+mkSpillInstr ::+  (HasCallStack) =>+  NCGConfig ->+  -- | register to spill+  RegWithFormat ->+  -- | current stack delta+  Int ->+  -- | spill slot to use+  Int ->+  [Instr]+mkSpillInstr _config (RegWithFormat reg _fmt) delta slot =+  case off - delta of+    imm | fitsIn12bitImm imm -> [mkStrSpImm imm]+    imm ->+      [ movImmToTmp imm,+        addSpToTmp,+        mkStrTmp+      ]+  where+    fmt = case reg of+      RegReal (RealRegSingle n) | n < d0RegNo -> II64+      _ -> FF64+    mkStrSpImm imm =+      ANN (text "Spill@" <> int (off - delta))+        $ STR fmt (OpReg W64 reg) (OpAddr (AddrRegImm spMachReg (ImmInt imm)))+    movImmToTmp imm =+      ANN (text "Spill: TMP <- " <> int imm)+        $ MOV tmp (OpImm (ImmInt imm))+    addSpToTmp =+      ANN (text "Spill: TMP <- SP + TMP ")+        $ ADD tmp tmp sp+    mkStrTmp =+      ANN (text "Spill@" <> int (off - delta))+        $ STR fmt (OpReg W64 reg) (OpAddr (AddrReg tmpReg))++    off = spillSlotToOffset slot++-- | Generate instructions to load a register from a spill slot.+mkLoadInstr ::+  NCGConfig ->+  -- | register to load+  RegWithFormat ->+  -- | current stack delta+  Int ->+  -- | spill slot to use+  Int ->+  [Instr]+mkLoadInstr _config (RegWithFormat reg _fmt) delta slot =+  case off - delta of+    imm | fitsIn12bitImm imm -> [mkLdrSpImm imm]+    imm ->+      [ movImmToTmp imm,+        addSpToTmp,+        mkLdrTmp+      ]+  where+    fmt = case reg of+      RegReal (RealRegSingle n) | n < d0RegNo -> II64+      _ -> FF64+    mkLdrSpImm imm =+      ANN (text "Reload@" <> int (off - delta))+        $ LDR fmt (OpReg W64 reg) (OpAddr (AddrRegImm spMachReg (ImmInt imm)))+    movImmToTmp imm =+      ANN (text "Reload: TMP <- " <> int imm)+        $ MOV tmp (OpImm (ImmInt imm))+    addSpToTmp =+      ANN (text "Reload: TMP <- SP + TMP ")+        $ ADD tmp tmp sp+    mkLdrTmp =+      ANN (text "Reload@" <> int (off - delta))+        $ LDR fmt (OpReg W64 reg) (OpAddr (AddrReg tmpReg))++    off = spillSlotToOffset slot++-- | See if this instruction is telling us the current C stack delta+takeDeltaInstr :: Instr -> Maybe Int+takeDeltaInstr (ANN _ i) = takeDeltaInstr i+takeDeltaInstr (DELTA i) = Just i+takeDeltaInstr _ = Nothing++-- | Not real instructions.  Just meta data+isMetaInstr :: Instr -> Bool+isMetaInstr instr =+  case instr of+    ANN _ i -> isMetaInstr i+    COMMENT {} -> True+    MULTILINE_COMMENT {} -> True+    LOCATION {} -> True+    LDATA {} -> True+    NEWBLOCK {} -> True+    DELTA {} -> True+    PUSH_STACK_FRAME -> True+    POP_STACK_FRAME -> True+    _ -> False++-- | Copy the value in a register to another one.+--+-- Must work for all register classes.+mkRegRegMoveInstr :: Reg -> Reg -> Instr+mkRegRegMoveInstr src dst = ANN desc instr+  where+    desc = text "Reg->Reg Move: " <> ppr src <> text " -> " <> ppr dst+    instr = MOV (operandFromReg dst) (operandFromReg src)++-- | Take the source and destination from this (potential) reg -> reg move instruction+--+-- We have to be a bit careful here: A `MOV` can also mean an implicit+-- conversion. This case is filtered out.+takeRegRegMoveInstr :: Instr -> Maybe (Reg, Reg)+takeRegRegMoveInstr (MOV (OpReg width dst) (OpReg width' src))+  | width == width' && (isFloatReg dst == isFloatReg src) = pure (src, dst)+takeRegRegMoveInstr _ = Nothing++-- | Make an unconditional jump instruction.+mkJumpInstr :: BlockId -> [Instr]+mkJumpInstr = pure . B . TBlock++-- | Decrement @sp@ to allocate stack space.+--+-- The stack grows downwards, so we decrement the stack pointer by @n@ (bytes).+-- This is dual to `mkStackDeallocInstr`. @sp@ is the RISCV stack pointer, not+-- to be confused with the STG stack pointer.+mkStackAllocInstr :: Platform -> Int -> [Instr]+mkStackAllocInstr _platform = moveSp . negate++-- | Increment SP to deallocate stack space.+--+-- The stack grows downwards, so we increment the stack pointer by @n@ (bytes).+-- This is dual to `mkStackAllocInstr`. @sp@ is the RISCV stack pointer, not to+-- be confused with the STG stack pointer.+mkStackDeallocInstr :: Platform -> Int -> [Instr]+mkStackDeallocInstr _platform = moveSp++moveSp :: Int -> [Instr]+moveSp n+  | n == 0 = []+  | n /= 0 && fitsIn12bitImm n = pure . ANN desc $ ADD sp sp (OpImm (ImmInt n))+  | otherwise =+      -- This ends up in three effective instructions. We could get away with+      -- two for intMax12bit < n < 3 * intMax12bit by recursing once. However,+      -- this way is likely less surprising.+      [ ANN desc (MOV tmp (OpImm (ImmInt n))),+        ADD sp sp tmp+      ]+  where+    desc = text "Move SP:" <+> int n++--+-- See Note [extra spill slots] in X86/Instr.hs+--+allocMoreStack ::+  Platform ->+  Int ->+  NatCmmDecl statics GHC.CmmToAsm.RV64.Instr.Instr ->+  UniqDSM (NatCmmDecl statics GHC.CmmToAsm.RV64.Instr.Instr, [(BlockId, BlockId)])+allocMoreStack _ _ top@(CmmData _ _) = return (top, [])+allocMoreStack platform slots proc@(CmmProc info lbl live (ListGraph code)) = do+  let entries = entryBlocks proc++  retargetList <- mapM (\e -> (e,) <$> newBlockId) entries++  let delta = ((x + stackAlign - 1) `quot` stackAlign) * stackAlign -- round up+        where+          x = slots * spillSlotSize -- sp delta+      alloc = mkStackAllocInstr platform delta+      dealloc = mkStackDeallocInstr platform delta++      new_blockmap :: LabelMap BlockId+      new_blockmap = mapFromList retargetList++      insert_stack_insn (BasicBlock id insns)+        | Just new_blockid <- mapLookup id new_blockmap =+            [ BasicBlock id $ alloc ++ [B (TBlock new_blockid)],+              BasicBlock new_blockid block'+            ]+        | otherwise =+            [BasicBlock id block']+        where+          block' = foldr insert_dealloc [] insns++      insert_dealloc insn r = case insn of+        J {} -> dealloc ++ (insn : r)+        ANN _ e -> insert_dealloc e r+        _other+          | jumpDestsOfInstr insn /= [] ->+              patchJumpInstr insn retarget : r+        _other -> insn : r+        where+          retarget b = fromMaybe b (mapLookup b new_blockmap)++      new_code = concatMap insert_stack_insn code+  return (CmmProc info lbl live (ListGraph new_code), retargetList)++data Instr+  = -- | Comment pseudo-op+    COMMENT SDoc+  | -- | Multi-line comment pseudo-op+    MULTILINE_COMMENT SDoc+  | -- | Annotated instruction. Should print <instr> # <doc>+    ANN SDoc Instr+  | -- | Location pseudo-op @.loc@ (file, line, col, name)+    LOCATION Int Int Int LexicalFastString+  | -- | Static data spat out during code generation.+    LDATA Section RawCmmStatics+  | -- | Start a new basic block.+    --+    -- Useful during codegen, removed later. Preceding instruction should be a+    -- jump, as per the invariants for a BasicBlock (see Cmm).+    NEWBLOCK BlockId+  | -- | Specify current stack offset for benefit of subsequent passes+    DELTA Int+  | -- | Push a minimal stack frame consisting of the return address (RA) and the frame pointer (FP).+    PUSH_STACK_FRAME+  | -- | Pop the minimal stack frame of prior `PUSH_STACK_FRAME`.+    POP_STACK_FRAME+  | -- | Arithmetic addition (both integer and floating point)+    --+    -- @rd = rs1 + rs2@+    ADD Operand Operand Operand+  | -- | Arithmetic subtraction (both integer and floating point)+    --+    -- @rd = rs1 - rs2@+    SUB Operand Operand Operand+  | -- | Logical AND (integer only)+    --+    -- @rd = rs1 & rs2@+    AND Operand Operand Operand+  | -- | Logical OR (integer only)+    --+    -- @rd = rs1 | rs2@+    OR Operand Operand Operand+  | -- | Logical left shift (zero extened, integer only)+    --+    -- @rd = rs1 << rs2@+    SLL Operand Operand Operand+  | -- | Logical right shift (zero extened, integer only)+    --+    -- @rd = rs1 >> rs2@+    SRL Operand Operand Operand+  | -- | Arithmetic right shift (sign-extened, integer only)+    --+    -- @rd = rs1 >> rs2@+    SRA Operand Operand Operand+  | -- | Store to memory (both, integer and floating point)+    STR Format Operand Operand+  | -- | Load from memory (sign-extended, integer and floating point)+    LDR Format Operand Operand+  | -- | Load from memory (unsigned, integer and floating point)+    LDRU Format Operand Operand+  | -- | Arithmetic multiplication (both, integer and floating point)+    --+    -- @rd = rn × rm@+    MUL Operand Operand Operand+  | -- | Negation (both, integer and floating point)+    --+    -- @rd = -op2@+    NEG Operand Operand+  | -- | Division (both, integer and floating point)+    --+    -- @rd = rn ÷ rm@+    DIV Operand Operand Operand+  | -- | Remainder (integer only, signed)+    --+    -- @rd = rn % rm@+    REM Operand Operand Operand --+  | -- | Remainder (integer only, unsigned)+    --+    -- @rd = |rn % rm|@+    REMU Operand Operand Operand+  | -- | High part of a multiplication that doesn't fit into 64bits (integer only)+    --+    -- E.g. for a multiplication with 64bits width: @rd = (rs1 * rs2) >> 64@.+    MULH Operand Operand Operand+  | -- | Unsigned division (integer only)+    --+    -- @rd = |rn ÷ rm|@+    DIVU Operand Operand Operand+  | -- | XOR (integer only)+    --+    -- @rd = rn ⊕ op2@+    XOR Operand Operand Operand+  | -- | ORI with immediate (integer only)+    --+    -- @rd = rn | op2@+    ORI Operand Operand Operand+  | -- | OR with immediate (integer only)+    --+    -- @rd = rn ⊕ op2@+    XORI Operand Operand Operand+  | -- | Move to register (integer and floating point)+    --+    -- @rd = rn@  or  @rd = #imm@+    MOV Operand Operand+  | -- | Pseudo-op for conditional setting of a register.+    --+    -- @if(o2 cond o3) op <- 1 else op <- 0@+    CSET Operand Operand Operand Cond+    -- | Like B, but only used for non-local jumps. Used to distinguish genJumps from others.+  | J Target+  | -- | A jump instruction with data for switch/jump tables+    J_TBL [Maybe BlockId] (Maybe CLabel) Reg+  | -- | Unconditional jump (no linking)+    B Target+  | -- | Unconditional jump, links return address (sets @ra@/@x1@)+    BL Reg [Reg]+  | -- | branch with condition (integer only)+    BCOND Cond Operand Operand Target+  | -- | Fence instruction+    --+    -- Memory barrier.+    FENCE FenceType FenceType+  | -- | Floating point conversion+    FCVT FcvtVariant Operand Operand+  | -- | Floating point ABSolute value+    FABS Operand Operand++  | -- | Min+    -- dest = min(r1)+    FMIN Operand Operand Operand+  | -- | Max+    FMAX Operand Operand Operand++  | -- | Floating-point fused multiply-add instructions+    --+    -- - fmadd : d =   r1 * r2 + r3+    -- - fnmsub: d =   r1 * r2 - r3+    -- - fmsub : d = - r1 * r2 + r3+    -- - fnmadd: d = - r1 * r2 - r3+    FMA FMASign Operand Operand Operand Operand++-- | Operand of a FENCE instruction (@r@, @w@ or @rw@)+data FenceType = FenceRead | FenceWrite | FenceReadWrite++-- | Variant of a floating point conversion instruction+data FcvtVariant = FloatToFloat | IntToFloat | FloatToInt++instrCon :: Instr -> String+instrCon i =+  case i of+    COMMENT {} -> "COMMENT"+    MULTILINE_COMMENT {} -> "COMMENT"+    ANN {} -> "ANN"+    LOCATION {} -> "LOCATION"+    LDATA {} -> "LDATA"+    NEWBLOCK {} -> "NEWBLOCK"+    DELTA {} -> "DELTA"+    PUSH_STACK_FRAME {} -> "PUSH_STACK_FRAME"+    POP_STACK_FRAME {} -> "POP_STACK_FRAME"+    ADD {} -> "ADD"+    OR {} -> "OR"+    MUL {} -> "MUL"+    NEG {} -> "NEG"+    DIV {} -> "DIV"+    REM {} -> "REM"+    REMU {} -> "REMU"+    MULH {} -> "MULH"+    SUB {} -> "SUB"+    DIVU {} -> "DIVU"+    AND {} -> "AND"+    SRA {} -> "SRA"+    XOR {} -> "XOR"+    SLL {} -> "SLL"+    SRL {} -> "SRL"+    MOV {} -> "MOV"+    ORI {} -> "ORI"+    XORI {} -> "ORI"+    STR {} -> "STR"+    LDR {} -> "LDR"+    LDRU {} -> "LDRU"+    CSET {} -> "CSET"+    J_TBL {} -> "J_TBL"+    J {} -> "J"+    B {} -> "B"+    BL {} -> "BL"+    BCOND {} -> "BCOND"+    FENCE {} -> "FENCE"+    FCVT {} -> "FCVT"+    FABS {} -> "FABS"+    FMIN {} -> "FMIN"+    FMAX {} -> "FMAX"+    FMA variant _ _ _ _ ->+      case variant of+        FMAdd -> "FMADD"+        FMSub -> "FMSUB"+        FNMAdd -> "FNMADD"+        FNMSub -> "FNMSUB"++data Target+  = TBlock BlockId+  | TReg Reg++data Operand+  = -- | register+    OpReg Width Reg+  | -- | immediate value+    OpImm Imm+  | -- | memory reference+    OpAddr AddrMode+  deriving (Eq, Show)++operandFromReg :: Reg -> Operand+operandFromReg = OpReg W64++operandFromRegNo :: RegNo -> Operand+operandFromRegNo = operandFromReg . regSingle++zero, ra, sp, gp, tp, fp, tmp :: Operand+zero = operandFromReg zeroReg+ra = operandFromReg raReg+sp = operandFromReg spMachReg+gp = operandFromRegNo 3+tp = operandFromRegNo 4+fp = operandFromRegNo 8+tmp = operandFromReg tmpReg++x0, x1, x2, x3, x4, x5, x6, x7 :: Operand+x8, x9, x10, x11, x12, x13, x14, x15 :: Operand+x16, x17, x18, x19, x20, x21, x22, x23 :: Operand+x24, x25, x26, x27, x28, x29, x30, x31 :: Operand+x0 = operandFromRegNo x0RegNo+x1 = operandFromRegNo 1+x2 = operandFromRegNo 2+x3 = operandFromRegNo 3+x4 = operandFromRegNo 4+x5 = operandFromRegNo x5RegNo+x6 = operandFromRegNo 6+x7 = operandFromRegNo x7RegNo++x8 = operandFromRegNo 8++x9 = operandFromRegNo 9++x10 = operandFromRegNo x10RegNo++x11 = operandFromRegNo 11++x12 = operandFromRegNo 12++x13 = operandFromRegNo 13++x14 = operandFromRegNo 14++x15 = operandFromRegNo 15++x16 = operandFromRegNo 16++x17 = operandFromRegNo x17RegNo++x18 = operandFromRegNo 18++x19 = operandFromRegNo 19++x20 = operandFromRegNo 20++x21 = operandFromRegNo 21++x22 = operandFromRegNo 22++x23 = operandFromRegNo 23++x24 = operandFromRegNo 24++x25 = operandFromRegNo 25++x26 = operandFromRegNo 26++x27 = operandFromRegNo 27++x28 = operandFromRegNo x28RegNo++x29 = operandFromRegNo 29++x30 = operandFromRegNo 30++x31 = operandFromRegNo x31RegNo++d0, d1, d2, d3, d4, d5, d6, d7 :: Operand+d8, d9, d10, d11, d12, d13, d14, d15 :: Operand+d16, d17, d18, d19, d20, d21, d22, d23 :: Operand+d24, d25, d26, d27, d28, d29, d30, d31 :: Operand+d0 = operandFromRegNo d0RegNo+d1 = operandFromRegNo 33+d2 = operandFromRegNo 34+d3 = operandFromRegNo 35+d4 = operandFromRegNo 36+d5 = operandFromRegNo 37+d6 = operandFromRegNo 38+d7 = operandFromRegNo d7RegNo++d8 = operandFromRegNo 40++d9 = operandFromRegNo 41++d10 = operandFromRegNo d10RegNo++d11 = operandFromRegNo 43++d12 = operandFromRegNo 44++d13 = operandFromRegNo 45++d14 = operandFromRegNo 46++d15 = operandFromRegNo 47++d16 = operandFromRegNo 48++d17 = operandFromRegNo d17RegNo++d18 = operandFromRegNo 50++d19 = operandFromRegNo 51++d20 = operandFromRegNo 52++d21 = operandFromRegNo 53++d22 = operandFromRegNo 54++d23 = operandFromRegNo 55++d24 = operandFromRegNo 56++d25 = operandFromRegNo 57++d26 = operandFromRegNo 58++d27 = operandFromRegNo 59++d28 = operandFromRegNo 60++d29 = operandFromRegNo 61++d30 = operandFromRegNo 62++d31 = operandFromRegNo d31RegNo++fitsIn12bitImm :: (Num a, Ord a) => a -> Bool+fitsIn12bitImm off = off >= intMin12bit && off <= intMax12bit++intMin12bit :: (Num a) => a+intMin12bit = -2048++intMax12bit :: (Num a) => a+intMax12bit = 2047++fitsIn32bits :: (Num a, Ord a, Bits a) => a -> Bool+fitsIn32bits i = (-1 `shiftL` 31) <= i && i <= (1 `shiftL` 31 - 1)++isNbitEncodeable :: Int -> Integer -> Bool+isNbitEncodeable n i = let shift = n - 1 in (-1 `shiftL` shift) <= i && i < (1 `shiftL` shift)++isEncodeableInWidth :: Width -> Integer -> Bool+isEncodeableInWidth = isNbitEncodeable . widthInBits++isIntOp :: Operand -> Bool+isIntOp = not . isFloatOp++isFloatOp :: Operand -> Bool+isFloatOp (OpReg _ reg) | isFloatReg reg = True+isFloatOp _ = False++isFloatReg :: Reg -> Bool+isFloatReg (RegReal (RealRegSingle i)) | i > 31 = True+isFloatReg (RegVirtual (VirtualRegD _)) = True+isFloatReg _ = False
+ GHC/CmmToAsm/RV64/Ppr.hs view
@@ -0,0 +1,719 @@+{-# LANGUAGE ScopedTypeVariables #-}++module GHC.CmmToAsm.RV64.Ppr (pprNatCmmDecl, pprInstr) where++import GHC.Cmm hiding (topInfoTable)+import GHC.Cmm.BlockId+import GHC.Cmm.CLabel+import GHC.Cmm.Dataflow.Label+import GHC.CmmToAsm.Config+import GHC.CmmToAsm.Format+import GHC.CmmToAsm.Ppr+import GHC.CmmToAsm.RV64.Cond+import GHC.CmmToAsm.RV64.Instr+import GHC.CmmToAsm.RV64.Regs+import GHC.CmmToAsm.Types+import GHC.CmmToAsm.Utils+import GHC.Platform+import GHC.Platform.Reg+import GHC.Prelude hiding (EQ)+import GHC.Types.Basic (Alignment, alignmentBytes, mkAlignment)+import GHC.Types.Unique (getUnique, pprUniqueAlways)+import GHC.Utils.Outputable+import GHC.Utils.Panic++pprNatCmmDecl :: forall doc. (IsDoc doc) => NCGConfig -> NatCmmDecl RawCmmStatics Instr -> doc+pprNatCmmDecl config (CmmData section dats) =+  pprSectionAlign config section $$ pprDatas config dats+pprNatCmmDecl config proc@(CmmProc top_info lbl _ (ListGraph blocks)) =+  let platform = ncgPlatform config++      pprProcAlignment :: doc+      pprProcAlignment = maybe empty (pprAlign . mkAlignment) (ncgProcAlignment config)+   in pprProcAlignment+        $$ case topInfoTable proc of+          Nothing ->+            -- special case for code without info table:+            pprSectionAlign config (Section Text lbl)+              $$+              -- do not+              -- pprProcAlignment config $$+              pprLabel platform lbl+              $$ vcat (map (pprBasicBlock config top_info) blocks) -- blocks guaranteed not null, so label needed+              $$ ppWhen+                (ncgDwarfEnabled config)+                (line (pprBlockEndLabel platform lbl) $$ line (pprProcEndLabel platform lbl))+              $$ pprSizeDecl platform lbl+          Just (CmmStaticsRaw info_lbl _) ->+            pprSectionAlign config (Section Text info_lbl)+              $$+              -- pprProcAlignment config $$+              ( if platformHasSubsectionsViaSymbols platform+                  then line (pprAsmLabel platform (mkDeadStripPreventer info_lbl) <> char ':')+                  else empty+              )+              $$ vcat (map (pprBasicBlock config top_info) blocks)+              $$ ppWhen (ncgDwarfEnabled config) (line (pprProcEndLabel platform info_lbl))+              $$+              -- above: Even the first block gets a label, because with branch-chain+              -- elimination, it might be the target of a goto.+              ( if platformHasSubsectionsViaSymbols platform+                  then -- See Note [Subsections Via Symbols]++                    line+                      $ text "\t.long "+                      <+> pprAsmLabel platform info_lbl+                      <+> char '-'+                      <+> pprAsmLabel platform (mkDeadStripPreventer info_lbl)+                  else empty+              )+              $$ pprSizeDecl platform info_lbl+{-# SPECIALIZE pprNatCmmDecl :: NCGConfig -> NatCmmDecl RawCmmStatics Instr -> SDoc #-}+{-# SPECIALIZE pprNatCmmDecl :: NCGConfig -> NatCmmDecl RawCmmStatics Instr -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable++pprLabel :: (IsDoc doc) => Platform -> CLabel -> doc+pprLabel platform lbl =+  pprGloblDecl platform lbl+    $$ pprTypeDecl platform lbl+    $$ line (pprAsmLabel platform lbl <> char ':')++pprAlign :: (IsDoc doc) => Alignment -> doc+pprAlign alignment =+  -- "The .align directive for RISC-V is an alias to .p2align, which aligns to a+  -- power of two, so .align 2 means align to 4 bytes. Because the definition of+  -- the .align directive varies by architecture, it is recommended to use the+  -- unambiguous .p2align or .balign directives instead."+  -- (https://github.com/riscv-non-isa/riscv-asm-manual/blob/main/riscv-asm.md#-align)+  line $ text "\t.balign " <> int (alignmentBytes alignment)++-- | Print appropriate alignment for the given section type.+--+-- Currently, this always aligns to a full machine word (8 byte.) A future+-- improvement could be to really do this per section type (though, it's+-- probably not a big gain.)+pprAlignForSection :: (IsDoc doc) => SectionType -> doc+pprAlignForSection _seg = pprAlign . mkAlignment $ 8++-- | Print section header and appropriate alignment for that section.+--+-- This will e.g. emit a header like:+--+--     .section .text+--     .balign 8+pprSectionAlign :: (IsDoc doc) => NCGConfig -> Section -> doc+pprSectionAlign _config (Section (OtherSection _) _) =+  panic "RV64.Ppr.pprSectionAlign: unknown section"+pprSectionAlign config sec@(Section seg _) =+  line (pprSectionHeader config sec)+    $$ pprAlignForSection seg++pprProcEndLabel ::+  (IsLine doc) =>+  Platform ->+  -- | Procedure name+  CLabel ->+  doc+pprProcEndLabel platform lbl =+  pprAsmLabel platform (mkAsmTempProcEndLabel lbl) <> colon++pprBlockEndLabel ::+  (IsLine doc) =>+  Platform ->+  -- | Block name+  CLabel ->+  doc+pprBlockEndLabel platform lbl =+  pprAsmLabel platform (mkAsmTempEndLabel lbl) <> colon++-- | Output the ELF .size directive (if needed.)+pprSizeDecl :: (IsDoc doc) => Platform -> CLabel -> doc+pprSizeDecl platform lbl+  | osElfTarget (platformOS platform) =+      line $ text "\t.size" <+> asmLbl <> text ", .-" <> asmLbl+  where+    asmLbl = pprAsmLabel platform lbl+pprSizeDecl _ _ = empty++pprBasicBlock ::+  (IsDoc doc) =>+  NCGConfig ->+  LabelMap RawCmmStatics ->+  NatBasicBlock Instr ->+  doc+pprBasicBlock config info_env (BasicBlock blockid instrs) =+  maybe_infotable+    $ pprLabel platform asmLbl+    $$ vcat (map (pprInstr platform) (id {-detectTrivialDeadlock-} optInstrs))+    $$ ppWhen+      (ncgDwarfEnabled config)+      ( -- Emit both end labels since this may end up being a standalone+        -- top-level block+        line+          ( pprBlockEndLabel platform asmLbl+              <> pprProcEndLabel platform asmLbl+          )+      )+  where+    -- TODO: Check if we can  filter more instructions here.+    -- TODO: Shouldn't this be a more general check on a higher level?+    -- Filter out identity moves. E.g. mov x18, x18 will be dropped.+    optInstrs = filter f instrs+      where+        f (MOV o1 o2) | o1 == o2 = False+        f _ = True++    asmLbl = blockLbl blockid+    platform = ncgPlatform config+    maybe_infotable c = case mapLookup blockid info_env of+      Nothing -> c+      Just (CmmStaticsRaw info_lbl info) ->+        --  pprAlignForSection platform Text $$+        infoTableLoc+          $$ vcat (map (pprData config) info)+          $$ pprLabel platform info_lbl+          $$ c+          $$ ppWhen+            (ncgDwarfEnabled config)+            (line (pprBlockEndLabel platform info_lbl))+    -- Make sure the info table has the right .loc for the block+    -- coming right after it. See Note [Info Offset]+    infoTableLoc = case instrs of+      (l@LOCATION {} : _) -> pprInstr platform l+      _other -> empty++pprDatas :: (IsDoc doc) => NCGConfig -> RawCmmStatics -> doc+-- See Note [emit-time elimination of static indirections] in "GHC.Cmm.CLabel".+pprDatas config (CmmStaticsRaw alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _])+  | lbl == mkIndStaticInfoLabel,+    let labelInd (CmmLabelOff l _) = Just l+        labelInd (CmmLabel l) = Just l+        labelInd _ = Nothing,+    Just ind' <- labelInd ind,+    alias `mayRedirectTo` ind' =+      pprGloblDecl (ncgPlatform config) alias+        $$ line (text ".equiv" <+> pprAsmLabel (ncgPlatform config) alias <> comma <> pprAsmLabel (ncgPlatform config) ind')+pprDatas config (CmmStaticsRaw lbl dats) =+  vcat (pprLabel platform lbl : map (pprData config) dats)+  where+    platform = ncgPlatform config++pprData :: (IsDoc doc) => NCGConfig -> CmmStatic -> doc+pprData _config (CmmString str) = line (pprString str)+pprData _config (CmmFileEmbed path _) = line (pprFileEmbed path)+-- TODO: AFAIK there no Darwin for RISCV, so we may consider to simplify this.+pprData config (CmmUninitialised bytes) =+  line+    $ let platform = ncgPlatform config+       in if platformOS platform == OSDarwin+            then text ".space " <> int bytes+            else text ".skip " <> int bytes+pprData config (CmmStaticLit lit) = pprDataItem config lit++pprGloblDecl :: (IsDoc doc) => Platform -> CLabel -> doc+pprGloblDecl platform lbl+  | not (externallyVisibleCLabel lbl) = empty+  | otherwise = line (text "\t.globl " <> pprAsmLabel platform lbl)++-- Note [Always use objects for info tables]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- See discussion in X86.Ppr for why this is necessary.  Essentially we need to+-- ensure that we never pass function symbols when we might want to lookup the+-- info table.  If we did, we could end up with procedure linking tables+-- (PLT)s, and thus the lookup wouldn't point to the function, but into the+-- jump table.+--+-- Fun fact: The LLVMMangler exists to patch this issue on the LLVM side as+-- well.+pprLabelType' :: (IsLine doc) => Platform -> CLabel -> doc+pprLabelType' platform lbl =+  if isCFunctionLabel lbl || functionOkInfoTable+    then text "@function"+    else text "@object"+  where+    functionOkInfoTable =+      platformTablesNextToCode platform+        && isInfoTableLabel lbl+        && not (isCmmInfoTableLabel lbl)+        && not (isConInfoTableLabel lbl)++-- this is called pprTypeAndSizeDecl in PPC.Ppr+pprTypeDecl :: (IsDoc doc) => Platform -> CLabel -> doc+pprTypeDecl platform lbl =+  if osElfTarget (platformOS platform) && externallyVisibleCLabel lbl+    then line (text ".type " <> pprAsmLabel platform lbl <> text ", " <> pprLabelType' platform lbl)+    else empty++pprDataItem :: (IsDoc doc) => NCGConfig -> CmmLit -> doc+pprDataItem config lit =+  lines_ (ppr_item (cmmTypeFormat $ cmmLitType platform lit) lit)+  where+    platform = ncgPlatform config++    imm = litToImm lit++    ppr_item II8 _ = [text "\t.byte\t" <> pprDataImm platform imm]+    ppr_item II16 _ = [text "\t.short\t" <> pprDataImm platform imm]+    ppr_item II32 _ = [text "\t.long\t" <> pprDataImm platform imm]+    ppr_item II64 _ = [text "\t.quad\t" <> pprDataImm platform imm]+    ppr_item FF32 (CmmFloat r _) =+      let bs = floatToBytes (fromRational r)+       in map (\b -> text "\t.byte\t" <> int (fromIntegral b)) bs+    ppr_item FF64 (CmmFloat r _) =+      let bs = doubleToBytes (fromRational r)+       in map (\b -> text "\t.byte\t" <> int (fromIntegral b)) bs+    ppr_item _ _ = pprPanic "pprDataItem:ppr_item" (text $ show lit)++-- | Pretty print an immediate value in the @data@ section+--+-- This does not include any checks. We rely on the Assembler to check for+-- errors. Use `pprOpImm` for immediates in instructions (operands.)+pprDataImm :: (IsLine doc) => Platform -> Imm -> doc+pprDataImm _ (ImmInt i) = int i+pprDataImm _ (ImmInteger i) = integer i+pprDataImm p (ImmCLbl l) = pprAsmLabel p l+pprDataImm p (ImmIndex l i) = pprAsmLabel p l <> char '+' <> int i+pprDataImm _ (ImmLit s) = ftext s+pprDataImm _ (ImmFloat f) = float (fromRational f)+pprDataImm _ (ImmDouble d) = double (fromRational d)+pprDataImm p (ImmConstantSum a b) = pprDataImm p a <> char '+' <> pprDataImm p b+pprDataImm p (ImmConstantDiff a b) =+  pprDataImm p a+    <> char '-'+    <> lparen+    <> pprDataImm p b+    <> rparen++-- | Comment @c@ with @# c@+asmComment :: SDoc -> SDoc+asmComment c = text "#" <+> c++-- | Commen @c@ with @// c@+asmDoubleslashComment :: SDoc -> SDoc+asmDoubleslashComment c = text "//" <+> c++-- | Comment @c@ with @/* c */@ (multiline comment)+asmMultilineComment :: SDoc -> SDoc+asmMultilineComment c = text "/*" $+$ c $+$ text "*/"++-- | Pretty print an immediate operand of an instruction+--+-- The kinds of immediates we can use here is pretty limited: RISCV doesn't+-- support index expressions (as e.g. Aarch64 does.) Floating points need to+-- fit in range. As we don't need them, forbit them to save us from future+-- troubles.+pprOpImm :: (IsLine doc) => Platform -> Imm -> doc+pprOpImm platform im = case im of+  ImmInt i -> int i+  ImmInteger i -> integer i+  ImmCLbl l -> char '=' <> pprAsmLabel platform l+  _ -> pprPanic "RV64.Ppr.pprOpImm" (text "Unsupported immediate for instruction operands" <> colon <+> (text . show) im)++-- | Negate integer immediate operand+--+-- This function is partial and will panic if the operand is not an integer.+negOp :: Operand -> Operand+negOp (OpImm (ImmInt i)) = OpImm (ImmInt (negate i))+negOp (OpImm (ImmInteger i)) = OpImm (ImmInteger (negate i))+negOp op = pprPanic "RV64.negOp" (text $ show op)++-- | Pretty print an operand+pprOp :: (IsLine doc) => Platform -> Operand -> doc+pprOp plat op = case op of+  OpReg w r -> pprReg w r+  OpImm im -> pprOpImm plat im+  OpAddr (AddrRegImm r1 im) -> pprOpImm plat im <> char '(' <> pprReg W64 r1 <> char ')'+  OpAddr (AddrReg r1) -> text "0(" <+> pprReg W64 r1 <+> char ')'++-- | Pretty print register with calling convention name+--+-- This representation makes it easier to reason about the emitted assembly+-- code.+pprReg :: forall doc. (IsLine doc) => Width -> Reg -> doc+pprReg w r = case r of+  RegReal (RealRegSingle i) -> ppr_reg_no i+  -- virtual regs should not show up, but this is helpful for debugging.+  RegVirtual (VirtualRegI u) -> text "%vI_" <> pprUniqueAlways u+  RegVirtual (VirtualRegD u) -> text "%vD_" <> pprUniqueAlways u+  _ -> pprPanic "RiscV64.pprReg" (text (show r) <+> ppr w)+  where+    ppr_reg_no :: Int -> doc+    -- General Purpose Registers+    ppr_reg_no 0 = text "zero"+    ppr_reg_no 1 = text "ra"+    ppr_reg_no 2 = text "sp"+    ppr_reg_no 3 = text "gp"+    ppr_reg_no 4 = text "tp"+    ppr_reg_no 5 = text "t0"+    ppr_reg_no 6 = text "t1"+    ppr_reg_no 7 = text "t2"+    ppr_reg_no 8 = text "s0"+    ppr_reg_no 9 = text "s1"+    ppr_reg_no 10 = text "a0"+    ppr_reg_no 11 = text "a1"+    ppr_reg_no 12 = text "a2"+    ppr_reg_no 13 = text "a3"+    ppr_reg_no 14 = text "a4"+    ppr_reg_no 15 = text "a5"+    ppr_reg_no 16 = text "a6"+    ppr_reg_no 17 = text "a7"+    ppr_reg_no 18 = text "s2"+    ppr_reg_no 19 = text "s3"+    ppr_reg_no 20 = text "s4"+    ppr_reg_no 21 = text "s5"+    ppr_reg_no 22 = text "s6"+    ppr_reg_no 23 = text "s7"+    ppr_reg_no 24 = text "s8"+    ppr_reg_no 25 = text "s9"+    ppr_reg_no 26 = text "s10"+    ppr_reg_no 27 = text "s11"+    ppr_reg_no 28 = text "t3"+    ppr_reg_no 29 = text "t4"+    ppr_reg_no 30 = text "t5"+    ppr_reg_no 31 = text "t6"+    -- Floating Point Registers+    ppr_reg_no 32 = text "ft0"+    ppr_reg_no 33 = text "ft1"+    ppr_reg_no 34 = text "ft2"+    ppr_reg_no 35 = text "ft3"+    ppr_reg_no 36 = text "ft4"+    ppr_reg_no 37 = text "ft5"+    ppr_reg_no 38 = text "ft6"+    ppr_reg_no 39 = text "ft7"+    ppr_reg_no 40 = text "fs0"+    ppr_reg_no 41 = text "fs1"+    ppr_reg_no 42 = text "fa0"+    ppr_reg_no 43 = text "fa1"+    ppr_reg_no 44 = text "fa2"+    ppr_reg_no 45 = text "fa3"+    ppr_reg_no 46 = text "fa4"+    ppr_reg_no 47 = text "fa5"+    ppr_reg_no 48 = text "fa6"+    ppr_reg_no 49 = text "fa7"+    ppr_reg_no 50 = text "fs2"+    ppr_reg_no 51 = text "fs3"+    ppr_reg_no 52 = text "fs4"+    ppr_reg_no 53 = text "fs5"+    ppr_reg_no 54 = text "fs6"+    ppr_reg_no 55 = text "fs7"+    ppr_reg_no 56 = text "fs8"+    ppr_reg_no 57 = text "fs9"+    ppr_reg_no 58 = text "fs10"+    ppr_reg_no 59 = text "fs11"+    ppr_reg_no 60 = text "ft8"+    ppr_reg_no 61 = text "ft9"+    ppr_reg_no 62 = text "ft10"+    ppr_reg_no 63 = text "ft11"+    ppr_reg_no i+      | i < 0 = pprPanic "Unexpected register number (min is 0)" (ppr w <+> int i)+      | i > 63 = pprPanic "Unexpected register number (max is 63)" (ppr w <+> int i)+      -- no support for widths > W64.+      | otherwise = pprPanic "Unsupported width in register (max is 64)" (ppr w <+> int i)++-- | Single precission `Operand` (floating-point)+isSingleOp :: Operand -> Bool+isSingleOp (OpReg W32 _) = True+isSingleOp _ = False++-- | Double precission `Operand` (floating-point)+isDoubleOp :: Operand -> Bool+isDoubleOp (OpReg W64 _) = True+isDoubleOp _ = False++-- | `Operand` is an immediate value+isImmOp :: Operand -> Bool+isImmOp (OpImm _) = True+isImmOp _ = False++-- | `Operand` is an immediate @0@ value+isImmZero :: Operand -> Bool+isImmZero (OpImm (ImmFloat 0)) = True+isImmZero (OpImm (ImmDouble 0)) = True+isImmZero (OpImm (ImmInt 0)) = True+isImmZero _ = False++-- | `Target` represents a label+isLabel :: Target -> Bool+isLabel (TBlock _) = True+isLabel _ = False++-- | Get the pretty-printed label from a `Target`+--+-- This function is partial and will panic if the `Target` is not a label.+getLabel :: (IsLine doc) => Platform -> Target -> doc+getLabel platform (TBlock bid) = pprBlockId platform bid+  where+    pprBlockId :: (IsLine doc) => Platform -> BlockId -> doc+    pprBlockId platform bid = pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))+getLabel _platform _other = panic "Cannot turn this into a label"++-- | Pretty-print an `Instr`+--+-- This function is partial and will panic if the `Instr` is not supported. This+-- can happen due to invalid operands or unexpected meta instructions.+pprInstr :: (IsDoc doc) => Platform -> Instr -> doc+pprInstr platform instr = case instr of+  -- see Note [dualLine and dualDoc] in GHC.Utils.Outputable+  COMMENT s -> dualDoc (asmComment s) empty+  MULTILINE_COMMENT s -> dualDoc (asmMultilineComment s) empty+  ANN d i -> dualDoc (pprInstr platform i <+> asmDoubleslashComment d) (pprInstr platform i)+  LOCATION file line' col _name ->+    line (text "\t.loc" <+> int file <+> int line' <+> int col)+  DELTA d -> dualDoc (asmComment $ text "\tdelta = " <> int d) empty+  NEWBLOCK _ -> panic "PprInstr: NEWBLOCK"+  LDATA _ _ -> panic "pprInstr: LDATA"+  PUSH_STACK_FRAME ->+    lines_+      [ text "\taddi sp, sp, -16",+        text "\tsd x1, 8(sp)", -- store RA+        text "\tsd x8, 0(sp)", -- store FP/s0+        text "\taddi x8, sp, 16"+      ]+  POP_STACK_FRAME ->+    lines_+      [ text "\tld x8, 0(sp)", -- restore FP/s0+        text "\tld x1, 8(sp)", -- restore RA+        text "\taddi sp, sp, 16"+      ]+  ADD o1 o2 o3+    | isFloatOp o1 && isFloatOp o2 && isFloatOp o3 -> op3 (text "\tfadd." <> if isSingleOp o1 then text "s" else text "d") o1 o2 o3+    -- This case is used for sign extension: SEXT.W op+    | OpReg W64 _ <- o1, OpReg W32 _ <- o2, isImmOp o3 -> op3 (text "\taddiw") o1 o2 o3+    | otherwise -> op3 (text "\tadd") o1 o2 o3+  MUL o1 o2 o3+    | isFloatOp o1 && isFloatOp o2 && isFloatOp o3 -> op3 (text "\tfmul." <> if isSingleOp o1 then text "s" else text "d") o1 o2 o3+    | otherwise -> op3 (text "\tmul") o1 o2 o3+  MULH o1 o2 o3 -> op3 (text "\tmulh") o1 o2 o3+  NEG o1 o2 | isFloatOp o1 && isFloatOp o2 && isSingleOp o2 -> op2 (text "\tfneg.s") o1 o2+  NEG o1 o2 | isFloatOp o1 && isFloatOp o2 && isDoubleOp o2 -> op2 (text "\tfneg.d") o1 o2+  NEG o1 o2 -> op2 (text "\tneg") o1 o2+  DIV o1 o2 o3+    | isFloatOp o1 && isFloatOp o2 && isFloatOp o3 ->+        -- TODO: This must (likely) be refined regarding width+        op3 (text "\tfdiv." <> if isSingleOp o1 then text "s" else text "d") o1 o2 o3+  DIV o1 o2 o3 -> op3 (text "\tdiv") o1 o2 o3+  REM o1 o2 o3+    | isFloatOp o1 || isFloatOp o2 || isFloatOp o3 ->+        panic "pprInstr - REM not implemented for floats (yet)"+  REM o1 o2 o3 -> op3 (text "\trem") o1 o2 o3+  REMU o1 o2 o3 -> op3 (text "\tremu") o1 o2 o3+  SUB o1 o2 o3+    | isFloatOp o1 && isFloatOp o2 && isFloatOp o3 -> op3 (text "\tfsub." <> if isSingleOp o1 then text "s" else text "d") o1 o2 o3+    | isImmOp o3 -> op3 (text "\taddi") o1 o2 (negOp o3)+    | otherwise -> op3 (text "\tsub") o1 o2 o3+  DIVU o1 o2 o3 -> op3 (text "\tdivu") o1 o2 o3+  AND o1 o2 o3+    | isImmOp o3 -> op3 (text "\tandi") o1 o2 o3+    | otherwise -> op3 (text "\tand") o1 o2 o3+  OR o1 o2 o3 -> op3 (text "\tor") o1 o2 o3+  SRA o1 o2 o3 | isImmOp o3 -> op3 (text "\tsrai") o1 o2 o3+  SRA o1 o2 o3 -> op3 (text "\tsra") o1 o2 o3+  XOR o1 o2 o3 -> op3 (text "\txor") o1 o2 o3+  SLL o1 o2 o3 -> op3 (text "\tsll") o1 o2 o3+  SRL o1 o2 o3 -> op3 (text "\tsrl") o1 o2 o3+  MOV o1 o2+    | isFloatOp o1 && isFloatOp o2 && isDoubleOp o2 -> op2 (text "\tfmv.d") o1 o2 -- fmv.d rd, rs is pseudo op fsgnj.d rd, rs, rs+    | isFloatOp o1 && isFloatOp o2 && isSingleOp o2 -> op2 (text "\tfmv.s") o1 o2 -- fmv.s rd, rs is pseudo op fsgnj.s rd, rs, rs+    | isFloatOp o1 && isImmZero o2 && isDoubleOp o1 -> op2 (text "\tfcvt.d.w") o1 zero+    | isFloatOp o1 && isImmZero o2 && isSingleOp o1 -> op2 (text "\tfcvt.s.w") o1 zero+    | isFloatOp o1 && not (isFloatOp o2) && isSingleOp o1 -> op2 (text "\tfmv.w.x") o1 o2+    | isFloatOp o1 && not (isFloatOp o2) && isDoubleOp o1 -> op2 (text "\tfmv.d.x") o1 o2+    | not (isFloatOp o1) && isFloatOp o2 && isSingleOp o2 -> op2 (text "\tfmv.x.w") o1 o2+    | not (isFloatOp o1) && isFloatOp o2 && isDoubleOp o2 -> op2 (text "\tfmv.x.d") o1 o2+    | (OpImm (ImmInteger i)) <- o2,+      fitsIn12bitImm i ->+        lines_ [text "\taddi" <+> pprOp platform o1 <> comma <+> pprOp platform x0 <> comma <+> pprOp platform o2]+    | (OpImm (ImmInt i)) <- o2,+      fitsIn12bitImm i ->+        lines_ [text "\taddi" <+> pprOp platform o1 <> comma <+> pprOp platform x0 <> comma <+> pprOp platform o2]+    | (OpImm (ImmInteger i)) <- o2,+      fitsIn32bits i ->+        lines_+          [ text "\tlui" <+> pprOp platform o1 <> comma <+> text "%hi(" <> pprOp platform o2 <> text ")",+            text "\taddw" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> text "%lo(" <> pprOp platform o2 <> text ")"+          ]+    | (OpImm (ImmInt i)) <- o2,+      fitsIn32bits i ->+        lines_+          [ text "\tlui" <+> pprOp platform o1 <> comma <+> text "%hi(" <> pprOp platform o2 <> text ")",+            text "\taddw" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> text "%lo(" <> pprOp platform o2 <> text ")"+          ]+    | isImmOp o2 ->+        -- Surrender! Let the assembler figure out the right expressions with pseudo-op LI.+        lines_ [text "\tli" <+> pprOp platform o1 <> comma <+> pprOp platform o2]+    | otherwise -> op3 (text "\taddi") o1 o2 (OpImm (ImmInt 0))+  ORI o1 o2 o3 -> op3 (text "\tori") o1 o2 o3+  XORI o1 o2 o3 -> op3 (text "\txori") o1 o2 o3+  J o1 -> pprInstr platform (B o1)+  J_TBL _ _ r -> pprInstr platform (B (TReg r))+  B l | isLabel l -> line $ text "\tjal" <+> pprOp platform x0 <> comma <+> getLabel platform l+  B (TReg r) -> line $ text "\tjalr" <+> pprOp platform x0 <> comma <+> pprReg W64 r <> comma <+> text "0"+  BL r _ -> line $ text "\tjalr" <+> text "x1" <> comma <+> pprReg W64 r <> comma <+> text "0"+  BCOND c l r t+    | isLabel t ->+        line $ text "\t" <> pprBcond c <+> pprOp platform l <> comma <+> pprOp platform r <> comma <+> getLabel platform t+  BCOND _ _ _ (TReg _) -> panic "RV64.ppr: No conditional branching to registers!"+  CSET o l r c -> case c of+    EQ+      | isIntOp l && isIntOp r ->+          lines_+            [ subFor l r,+              text "\tseqz" <+> pprOp platform o <> comma <+> pprOp platform o+            ]+    EQ | isFloatOp l && isFloatOp r -> line $ binOp ("\tfeq." ++ floatOpPrecision platform l r)+    NE+      | isIntOp l && isIntOp r ->+          lines_+            [ subFor l r,+              text "\tsnez" <+> pprOp platform o <> comma <+> pprOp platform o+            ]+    NE+      | isFloatOp l && isFloatOp r ->+          lines_+            [ binOp ("\tfeq." ++ floatOpPrecision platform l r),+              text "\txori" <+> pprOp platform o <> comma <+> pprOp platform o <> comma <+> text "1"+            ]+    SLT -> lines_ [sltFor l r <+> pprOp platform o <> comma <+> pprOp platform l <> comma <+> pprOp platform r]+    SLE ->+      lines_+        [ sltFor l r <+> pprOp platform o <> comma <+> pprOp platform r <> comma <+> pprOp platform l,+          text "\txori" <+> pprOp platform o <> comma <+> pprOp platform o <> comma <+> text "1"+        ]+    SGE ->+      lines_+        [ sltFor l r <+> pprOp platform o <> comma <+> pprOp platform l <> comma <+> pprOp platform r,+          text "\txori" <+> pprOp platform o <> comma <+> pprOp platform o <> comma <+> text "1"+        ]+    SGT -> lines_ [sltFor l r <+> pprOp platform o <> comma <+> pprOp platform r <> comma <+> pprOp platform l]+    ULT -> lines_ [sltuFor l r <+> pprOp platform o <> comma <+> pprOp platform l <> comma <+> pprOp platform r]+    ULE ->+      lines_+        [ sltuFor l r <+> pprOp platform o <> comma <+> pprOp platform r <> comma <+> pprOp platform l,+          text "\txori" <+> pprOp platform o <> comma <+> pprOp platform o <> comma <+> text "1"+        ]+    UGE ->+      lines_+        [ sltuFor l r <+> pprOp platform o <> comma <+> pprOp platform l <> comma <+> pprOp platform r,+          text "\txori" <+> pprOp platform o <> comma <+> pprOp platform o <> comma <+> text "1"+        ]+    UGT -> lines_ [sltuFor l r <+> pprOp platform o <> comma <+> pprOp platform r <> comma <+> pprOp platform l]+    FLT | isFloatOp l && isFloatOp r -> line $ binOp ("\tflt." ++ floatOpPrecision platform l r)+    FLE | isFloatOp l && isFloatOp r -> line $ binOp ("\tfle." ++ floatOpPrecision platform l r)+    FGT | isFloatOp l && isFloatOp r -> line $ binOp ("\tfgt." ++ floatOpPrecision platform l r)+    FGE | isFloatOp l && isFloatOp r -> line $ binOp ("\tfge." ++ floatOpPrecision platform l r)+    x -> pprPanic "RV64.ppr: unhandled CSET conditional" (text (show x) <+> pprOp platform o <> comma <+> pprOp platform r <> comma <+> pprOp platform l)+    where+      subFor l r+        | (OpImm _) <- r = text "\taddi" <+> pprOp platform o <> comma <+> pprOp platform l <> comma <+> pprOp platform (negOp r)+        | (OpImm _) <- l = panic "RV64.ppr: Cannot SUB IMM _"+        | otherwise = text "\tsub" <+> pprOp platform o <> comma <+> pprOp platform l <> comma <+> pprOp platform r+      sltFor l r+        | (OpImm _) <- r = text "\tslti"+        | (OpImm _) <- l = panic "PV64.ppr: Cannot SLT IMM _"+        | otherwise = text "\tslt"+      sltuFor l r+        | (OpImm _) <- r = text "\tsltui"+        | (OpImm _) <- l = panic "PV64.ppr: Cannot SLTU IMM _"+        | otherwise = text "\tsltu"+      binOp :: (IsLine doc) => String -> doc+      binOp op = text op <+> pprOp platform o <> comma <+> pprOp platform l <> comma <+> pprOp platform r+  STR II8 o1 o2 -> op2 (text "\tsb") o1 o2+  STR II16 o1 o2 -> op2 (text "\tsh") o1 o2+  STR II32 o1 o2 -> op2 (text "\tsw") o1 o2+  STR II64 o1 o2 -> op2 (text "\tsd") o1 o2+  STR FF32 o1 o2 -> op2 (text "\tfsw") o1 o2+  STR FF64 o1 o2 -> op2 (text "\tfsd") o1 o2+  LDR _f o1 (OpImm (ImmIndex lbl off)) ->+    lines_+      [ text "\tla" <+> pprOp platform o1 <> comma <+> pprAsmLabel platform lbl,+        text "\taddi" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> int off+      ]+  LDR _f o1 (OpImm (ImmCLbl lbl)) ->+    line $ text "\tla" <+> pprOp platform o1 <> comma <+> pprAsmLabel platform lbl+  LDR II8 o1 o2 -> op2 (text "\tlb") o1 o2+  LDR II16 o1 o2 -> op2 (text "\tlh") o1 o2+  LDR II32 o1 o2 -> op2 (text "\tlw") o1 o2+  LDR II64 o1 o2 -> op2 (text "\tld") o1 o2+  LDR FF32 o1 o2 -> op2 (text "\tflw") o1 o2+  LDR FF64 o1 o2 -> op2 (text "\tfld") o1 o2+  LDRU II8 o1 o2 -> op2 (text "\tlbu") o1 o2+  LDRU II16 o1 o2 -> op2 (text "\tlhu") o1 o2+  LDRU II32 o1 o2 -> op2 (text "\tlwu") o1 o2+  -- double words (64bit) cannot be sign extended by definition+  LDRU II64 o1 o2 -> op2 (text "\tld") o1 o2+  LDRU FF32 o1 o2@(OpAddr (AddrReg _)) -> op2 (text "\tflw") o1 o2+  LDRU FF32 o1 o2@(OpAddr (AddrRegImm _ _)) -> op2 (text "\tflw") o1 o2+  LDRU FF64 o1 o2@(OpAddr (AddrReg _)) -> op2 (text "\tfld") o1 o2+  LDRU FF64 o1 o2@(OpAddr (AddrRegImm _ _)) -> op2 (text "\tfld") o1 o2+  LDRU f o1 o2 -> pprPanic "Unsupported unsigned load" ((text . show) f <+> pprOp platform o1 <+> pprOp platform o2)+  FENCE r w -> line $ text "\tfence" <+> pprFenceType r <> char ',' <+> pprFenceType w+  FCVT FloatToFloat o1@(OpReg W32 _) o2@(OpReg W64 _) -> op2 (text "\tfcvt.s.d") o1 o2+  FCVT FloatToFloat o1@(OpReg W64 _) o2@(OpReg W32 _) -> op2 (text "\tfcvt.d.s") o1 o2+  FCVT FloatToFloat o1 o2 ->+    pprPanic "RV64.pprInstr - impossible float to float conversion"+      $ line (pprOp platform o1 <> text "->" <> pprOp platform o2)+  FCVT IntToFloat o1@(OpReg W32 _) o2@(OpReg W32 _) -> op2 (text "\tfcvt.s.w") o1 o2+  FCVT IntToFloat o1@(OpReg W32 _) o2@(OpReg W64 _) -> op2 (text "\tfcvt.s.l") o1 o2+  FCVT IntToFloat o1@(OpReg W64 _) o2@(OpReg W32 _) -> op2 (text "\tfcvt.d.w") o1 o2+  FCVT IntToFloat o1@(OpReg W64 _) o2@(OpReg W64 _) -> op2 (text "\tfcvt.d.l") o1 o2+  FCVT IntToFloat o1 o2 ->+    pprPanic "RV64.pprInstr - impossible integer to float conversion"+      $ line (pprOp platform o1 <> text "->" <> pprOp platform o2)+  FCVT FloatToInt o1@(OpReg W32 _) o2@(OpReg W32 _) -> op2 (text "\tfcvt.w.s") o1 o2+  FCVT FloatToInt o1@(OpReg W32 _) o2@(OpReg W64 _) -> op2 (text "\tfcvt.w.d") o1 o2+  FCVT FloatToInt o1@(OpReg W64 _) o2@(OpReg W32 _) -> op2 (text "\tfcvt.l.s") o1 o2+  FCVT FloatToInt o1@(OpReg W64 _) o2@(OpReg W64 _) -> op2 (text "\tfcvt.l.d") o1 o2+  FCVT FloatToInt o1 o2 ->+    pprPanic "RV64.pprInstr - impossible float to integer conversion"+      $ line (pprOp platform o1 <> text "->" <> pprOp platform o2)+  FABS o1 o2 | isSingleOp o2 -> op2 (text "\tfabs.s") o1 o2+  FABS o1 o2 | isDoubleOp o2 -> op2 (text "\tfabs.d") o1 o2+  FMIN o1 o2 o3 | isSingleOp o1 -> op3 (text "\tfmin.s") o1 o2 o3+                | isDoubleOp o2 -> op3 (text "\tfmin.d") o1 o2 o3+  FMAX o1 o2 o3 | isSingleOp o1 -> op3 (text "\tfmax.s") o1 o2 o3+                | isDoubleOp o2 -> op3 (text "\tfmax.d") o1 o2 o3+  FMA variant d r1 r2 r3 ->+    let fma = case variant of+          FMAdd -> text "\tfmadd" <> dot <> floatPrecission d+          FMSub -> text "\tfmsub" <> dot <> floatPrecission d+          FNMAdd -> text "\tfnmadd" <> dot <> floatPrecission d+          FNMSub -> text "\tfnmsub" <> dot <> floatPrecission d+     in op4 fma d r1 r2 r3+  instr -> panic $ "RV64.pprInstr - Unknown instruction: " ++ instrCon instr+  where+    op2 op o1 o2 = line $ op <+> pprOp platform o1 <> comma <+> pprOp platform o2+    op3 op o1 o2 o3 = line $ op <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3+    op4 op o1 o2 o3 o4 = line $ op <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 <> comma <+> pprOp platform o4+    pprFenceType FenceRead = text "r"+    pprFenceType FenceWrite = text "w"+    pprFenceType FenceReadWrite = text "rw"+    floatPrecission o+      | isSingleOp o = text "s"+      | isDoubleOp o = text "d"+      | otherwise = pprPanic "Impossible floating point precission: " (pprOp platform o)++floatOpPrecision :: Platform -> Operand -> Operand -> String+floatOpPrecision _p l r | isFloatOp l && isFloatOp r && isSingleOp l && isSingleOp r = "s" -- single precision+floatOpPrecision _p l r | isFloatOp l && isFloatOp r && isDoubleOp l && isDoubleOp r = "d" -- double precision+floatOpPrecision p l r = pprPanic "Cannot determine floating point precission" (text "op1" <+> pprOp p l <+> text "op2" <+> pprOp p r)++-- | Pretty print a conditional branch+--+-- This function is partial and will panic if the conditional is not supported;+-- i.e. if its floating point related.+pprBcond :: (IsLine doc) => Cond -> doc+pprBcond c = text "b" <> pprCond c+  where+    pprCond :: (IsLine doc) => Cond -> doc+    pprCond c = case c of+      EQ -> text "eq"+      NE -> text "ne"+      SLT -> text "lt"+      SLE -> text "le"+      SGE -> text "ge"+      SGT -> text "gt"+      ULT -> text "ltu"+      ULE -> text "leu"+      UGE -> text "geu"+      UGT -> text "gtu"+      -- BCOND cannot handle floating point comparisons / registers+      _ -> panic $ "RV64.ppr: unhandled BCOND conditional: " ++ show c
+ GHC/CmmToAsm/RV64/RegInfo.hs view
@@ -0,0 +1,41 @@+-- | Minimum viable implementation of jump short-cutting: No short-cutting.+--+-- The functions here simply implement the no-short-cutting case. Implementing+-- the real behaviour would be a great optimization in future.+module GHC.CmmToAsm.RV64.RegInfo+  ( getJumpDestBlockId,+    canShortcut,+    shortcutStatics,+    shortcutJump,+    JumpDest (..),+  )+where++import GHC.Cmm+import GHC.Cmm.BlockId+import GHC.CmmToAsm.RV64.Instr+import GHC.Prelude+import GHC.Utils.Outputable++newtype JumpDest = DestBlockId BlockId++instance Outputable JumpDest where+  ppr (DestBlockId bid) = text "jd<blk>:" <> ppr bid++-- | Extract BlockId+--+-- Never `Nothing` for Riscv64 NCG.+getJumpDestBlockId :: JumpDest -> Maybe BlockId+getJumpDestBlockId (DestBlockId bid) = Just bid++-- No `Instr`s can bet shortcut (for now)+canShortcut :: Instr -> Maybe JumpDest+canShortcut _ = Nothing++-- Identity of the provided `RawCmmStatics`+shortcutStatics :: (BlockId -> Maybe JumpDest) -> RawCmmStatics -> RawCmmStatics+shortcutStatics _ other_static = other_static++-- Identity of the provided `Instr`+shortcutJump :: (BlockId -> Maybe JumpDest) -> Instr -> Instr+shortcutJump _ other = other
+ GHC/CmmToAsm/RV64/Regs.hs view
@@ -0,0 +1,245 @@+module GHC.CmmToAsm.RV64.Regs where++import GHC.Cmm+import GHC.Cmm.CLabel (CLabel)+import GHC.CmmToAsm.Format+import GHC.Data.FastString+import GHC.Platform+import GHC.Platform.Reg+import GHC.Platform.Reg.Class+import GHC.Platform.Reg.Class.Separate+import GHC.Platform.Regs+import GHC.Prelude+import GHC.Types.Unique+import GHC.Utils.Outputable+import GHC.Utils.Panic++-- * Registers++-- | First integer register number. @zero@ register.+x0RegNo :: RegNo+x0RegNo = 0++-- | return address register+x1RegNo, raRegNo :: RegNo+x1RegNo = 1+raRegNo = x1RegNo++x5RegNo, t0RegNo :: RegNo+x5RegNo = 5+t0RegNo = x5RegNo++x7RegNo, t2RegNo :: RegNo+x7RegNo = 7+t2RegNo = x7RegNo++x28RegNo, t3RegNo :: RegNo+x28RegNo = 28+t3RegNo = x28RegNo++-- | Last integer register number. Used as TMP (IP) register.+x31RegNo, t6RegNo, tmpRegNo :: RegNo+x31RegNo = 31+t6RegNo = x31RegNo+tmpRegNo = x31RegNo++-- | First floating point register.+d0RegNo, ft0RegNo :: RegNo+d0RegNo = 32+ft0RegNo = d0RegNo++d7RegNo, ft7RegNo :: RegNo+d7RegNo = 39+ft7RegNo = d7RegNo++-- | Last floating point register.+d31RegNo :: RegNo+d31RegNo = 63++a0RegNo, x10RegNo :: RegNo+x10RegNo = 10+a0RegNo = x10RegNo++a7RegNo, x17RegNo :: RegNo+x17RegNo = 17+a7RegNo = x17RegNo++fa0RegNo, d10RegNo :: RegNo+d10RegNo = 42+fa0RegNo = d10RegNo++fa7RegNo, d17RegNo :: RegNo+d17RegNo = 49+fa7RegNo = d17RegNo++-- Note [The made-up RISCV64 TMP (IP) register]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- RISCV64 has no inter-procedural register in its ABI. However, we need one to+-- make register spills/loads to/from high number slots. I.e. slot numbers that+-- do not fit in a 12bit integer which is used as immediate in the arithmetic+-- operations. Thus, we're marking one additional register (x31) as permanently+-- non-free and call it TMP.+--+-- TMP can be used as temporary register in all operations. Just be aware that+-- it may be clobbered as soon as you loose direct control over it (i.e. using+-- TMP by-passes the register allocation/spilling mechanisms.) It should be fine+-- to use it as temporary register in a MachOp translation as long as you don't+-- rely on its value beyond this limited scope.+--+-- X31 is a caller-saved register. I.e. there are no guarantees about what the+-- callee does with it. That's exactly what we want here.++zeroReg, raReg, spMachReg, tmpReg :: Reg+zeroReg = regSingle x0RegNo+raReg = regSingle 1++-- | Not to be confused with the `CmmReg` `spReg`+spMachReg = regSingle 2++tmpReg = regSingle tmpRegNo++-- | All machine register numbers.+allMachRegNos :: [RegNo]+allMachRegNos = intRegs ++ fpRegs+  where+    intRegs = [x0RegNo .. x31RegNo]+    fpRegs = [d0RegNo .. d31RegNo]++-- | Registers available to the register allocator.+--+-- These are all registers minus those with a fixed role in RISCV ABI (zero, lr,+-- sp, gp, tp, fp, tmp) and GHC RTS (Base, Sp, Hp, HpLim, R1..R8, F1..F6,+-- D1..D6.)+allocatableRegs :: Platform -> [RealReg]+allocatableRegs platform =+  let isFree = freeReg platform+   in map RealRegSingle $ filter isFree allMachRegNos++-- | Integer argument registers according to the calling convention+allGpArgRegs :: [Reg]+allGpArgRegs = map regSingle [a0RegNo .. a7RegNo]++-- | Floating point argument registers according to the calling convention+allFpArgRegs :: [Reg]+allFpArgRegs = map regSingle [fa0RegNo .. fa7RegNo]++-- * Addressing modes++-- | Addressing modes+data AddrMode+  = -- | A register plus some immediate integer, e.g. @8(sp)@ or @-16(sp)@. The+    -- offset needs to fit into 12bits.+    AddrRegImm Reg Imm+  | -- | A register+    AddrReg Reg+  deriving (Eq, Show)++-- * Immediates++data Imm+  = ImmInt Int+  | ImmInteger Integer -- Sigh.+  | ImmCLbl CLabel -- AbstractC Label (with baggage)+  | ImmLit FastString+  | ImmIndex CLabel Int+  | ImmFloat Rational+  | ImmDouble Rational+  | ImmConstantSum Imm Imm+  | ImmConstantDiff Imm Imm+  deriving (Eq, Show)++-- | Map `CmmLit` to `Imm`+--+-- N.B. this is a partial function, because not all `CmmLit`s have an immediate+-- representation.+litToImm :: CmmLit -> Imm+litToImm (CmmInt i w) = ImmInteger (narrowS w i)+-- narrow to the width: a CmmInt might be out of+-- range, but we assume that ImmInteger only contains+-- in-range values.  A signed value should be fine here.+litToImm (CmmFloat f W32) = ImmFloat f+litToImm (CmmFloat f W64) = ImmDouble f+litToImm (CmmLabel l) = ImmCLbl l+litToImm (CmmLabelOff l off) = ImmIndex l off+litToImm (CmmLabelDiffOff l1 l2 off _) =+  ImmConstantSum+    (ImmConstantDiff (ImmCLbl l1) (ImmCLbl l2))+    (ImmInt off)+litToImm l = panic $ "RV64.Regs.litToImm: no match for " ++ show l++-- == To satisfy GHC.CmmToAsm.Reg.Target =======================================++-- squeese functions for the graph allocator -----------------------------------++-- | regSqueeze_class reg+--      Calculate the maximum number of register colors that could be+--      denied to a node of this class due to having this reg+--      as a neighbour.+{-# INLINE virtualRegSqueeze #-}+virtualRegSqueeze :: RegClass -> VirtualReg -> Int+virtualRegSqueeze cls vr =+  case cls of+    RcInteger ->+      case vr of+        VirtualRegI {} -> 1+        VirtualRegHi {} -> 1+        _other -> 0+    RcFloat ->+      case vr of+        VirtualRegD {} -> 1+        _other -> 0+    RcVector ->+      case vr of+        VirtualRegV128 {} -> 1+        _other -> 0++{-# INLINE realRegSqueeze #-}+realRegSqueeze :: RegClass -> RealReg -> Int+realRegSqueeze cls rr =+  case cls of+    RcInteger ->+      case rr of+        RealRegSingle regNo+          | regNo < d0RegNo+          -> 1+          | otherwise+          -> 0+    RcFloat ->+      case rr of+        RealRegSingle regNo+          |  regNo < d0RegNo+          || regNo > d31RegNo+          -> 0+          | otherwise+          -> 1+    RcVector ->+      case rr of+        RealRegSingle regNo+          | regNo > d31RegNo+          -> 1+          | otherwise+          -> 0++mkVirtualReg :: Unique -> Format -> VirtualReg+mkVirtualReg u format+  | not (isFloatFormat format) = VirtualRegI u+  | otherwise =+      case format of+        FF32 -> VirtualRegD u+        FF64 -> VirtualRegD u+        _ -> panic "RV64.mkVirtualReg"++{-# INLINE classOfRealReg #-}+classOfRealReg :: RealReg -> RegClass+classOfRealReg (RealRegSingle i)+  | i < d0RegNo = RcInteger+  | i > d31RegNo = RcVector+  | otherwise = RcFloat++regDotColor :: RealReg -> SDoc+regDotColor reg =+  case classOfRealReg reg of+    RcInteger -> text "blue"+    RcFloat -> text "red"+    RcVector -> text "green"
GHC/CmmToAsm/Reg/Graph.hs view
@@ -21,6 +21,7 @@ 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@@ -31,8 +32,8 @@ import GHC.Platform import GHC.Types.Unique.FM import GHC.Types.Unique.Set-import GHC.Types.Unique.Supply-import GHC.Utils.Misc (seqList)+import GHC.Types.Unique.DSM+import GHC.Utils.Misc (seqList, HasDebugCallStack) import GHC.CmmToAsm.CFG  import Data.Maybe@@ -57,8 +58,8 @@         -> Int                          -- ^ current number of spill slots         -> [LiveCmmDecl statics instr]  -- ^ code annotated with liveness information.         -> Maybe CFG                    -- ^ CFG of basic blocks if available-        -> UniqSM ( [NatCmmDecl statics instr]-                  , Maybe Int, [RegAllocStats statics instr] )+        -> UniqDSM ( [NatCmmDecl statics instr]+                   , Maybe Int, [RegAllocStats statics instr] )            -- ^ code with registers allocated, additional stacks required            -- and stats for each stage of allocation @@ -95,7 +96,8 @@ regAlloc_spin         :: forall instr statics.            (Instruction instr,-            OutputableP Platform statics)+            OutputableP Platform statics,+            HasDebugCallStack)         => NCGConfig         -> Int  -- ^ Number of solver iterations we've already performed.         -> Color.Triv VirtualReg RegClass RealReg@@ -107,7 +109,7 @@         -> [RegAllocStats statics instr] -- ^ Current regalloc stats to add to.         -> [LiveCmmDecl statics instr]   -- ^ Liveness annotated code to allocate.         -> Maybe CFG-        -> UniqSM ( [NatCmmDecl statics instr]+        -> UniqDSM ( [NatCmmDecl statics instr]                   , [RegAllocStats statics instr]                   , Int                  -- Slots in use                   , Color.Graph VirtualReg RegClass RealReg)@@ -140,7 +142,7 @@          -- Build the register conflict graph from the cmm code.         (graph  :: Color.Graph VirtualReg RegClass RealReg)-                <- {-# SCC "BuildGraph" #-} buildGraph code+                <- {-# SCC "BuildGraph" #-} buildGraph platform code          -- VERY IMPORTANT:         --   We really do want the graph to be fully evaluated _before_ we@@ -188,7 +190,7 @@                 = reg          let (code_coalesced :: [LiveCmmDecl statics instr])-                = map (patchEraseLive patchF) code+                = map (patchEraseLive platform patchF) code          -- Check whether we've found a coloring.         if isEmptyUniqSet rsSpill@@ -214,7 +216,7 @@                 --   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+                        = map (cleanSpills config) code_patched                  -- Strip off liveness information from the allocated code.                 -- Also rewrite SPILL/RELOAD meta instructions into real machine@@ -234,7 +236,7 @@                         , raSpillClean          = code_spillclean                         , raFinal               = code_final                         , raSRMs                = foldl' addSRM (0, 0, 0)-                                                $ map countSRMs code_spillclean+                                                $ map (countSRMs platform) code_spillclean                         , raPlatform    = platform                      } @@ -304,14 +306,15 @@ -- | Build a graph from the liveness and coalesce information in this code. buildGraph         :: Instruction instr-        => [LiveCmmDecl statics instr]-        -> UniqSM (Color.Graph VirtualReg RegClass RealReg)+        => Platform+        -> [LiveCmmDecl statics instr]+        -> UniqDSM (Color.Graph VirtualReg RegClass RealReg) -buildGraph code+buildGraph platform code  = do         -- Slurp out the conflicts and reg->reg moves from this code.         let (conflictList, moveList) =-                unzip $ map slurpConflicts code+                unzip $ map (slurpConflicts platform) code          -- Slurp out the spill/reload coalesces.         let moveList2           = map slurpReloadCoalesce code@@ -319,7 +322,7 @@         -- Add the reg-reg conflicts to the graph.         let conflictBag         = unionManyBags conflictList         let graph_conflict-                = foldr graphAddConflictSet Color.initGraph conflictBag+                = foldr (graphAddConflictSet platform) Color.initGraph conflictBag          -- Add the coalescences edges to the graph.         let moveBag@@ -327,7 +330,7 @@                             (unionManyBags moveList)          let graph_coalesce-                = foldr graphAddCoalesce graph_conflict moveBag+                = foldr (graphAddCoalesce platform) graph_conflict moveBag          return  graph_coalesce @@ -335,47 +338,53 @@ -- | Add some conflict edges to the graph. --   Conflicts between virtual and real regs are recorded as exclusions. graphAddConflictSet-        :: UniqSet Reg+        :: Platform+        -> UniqSet RegWithFormat         -> Color.Graph VirtualReg RegClass RealReg         -> Color.Graph VirtualReg RegClass RealReg -graphAddConflictSet set graph- = let  virtuals        = mkUniqSet-                        [ vr | RegVirtual vr <- nonDetEltsUniqSet set ]+graphAddConflictSet platform regs graph+ = let  arch = platformArch platform+        virtuals = takeVirtualRegs regs+        reals    = takeRealRegs regs -        graph1  = Color.addConflicts virtuals classOfVirtualReg graph+        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 r2)+        graph2  = foldr (\(r1, r2) -> Color.addExclusion r1 (classOfVirtualReg arch) r2)                         graph1                         [ (vr, rr)-                                | RegVirtual vr <- nonDetEltsUniqSet set-                                , RegReal    rr <- nonDetEltsUniqSet set]+                        | vr <- nonDetEltsUniqSet virtuals+                        , rr <- nonDetEltsUniqSet reals ]                           -- 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.+-- | Add some coalescence edges to the graph+--   Coalescences between virtual and real regs are recorded as preferences. graphAddCoalesce-        :: (Reg, Reg)+        :: Platform+        -> (Reg, Reg)         -> Color.Graph VirtualReg RegClass RealReg         -> Color.Graph VirtualReg RegClass RealReg -graphAddCoalesce (r1, r2) graph+graphAddCoalesce platform (r1, r2) graph         | RegReal rr            <- r1         , RegVirtual vr         <- r2-        = Color.addPreference (vr, classOfVirtualReg vr) rr graph+        = Color.addPreference (vr, classOfVirtualReg arch vr) rr graph          | RegReal rr            <- r2         , RegVirtual vr         <- r1-        = Color.addPreference (vr, classOfVirtualReg vr) rr graph+        = Color.addPreference (vr, classOfVirtualReg arch vr) rr graph          | RegVirtual vr1        <- r1         , RegVirtual vr2        <- r2         = Color.addCoalesce-                (vr1, classOfVirtualReg vr1)-                (vr2, classOfVirtualReg vr2)+                (vr1, classOfVirtualReg arch vr1)+                (vr2, classOfVirtualReg arch vr2)                 graph          -- We can't coalesce two real regs, but there could well be existing@@ -384,11 +393,8 @@         | RegReal _             <- r1         , RegReal _             <- r2         = graph--#if __GLASGOW_HASKELL__ <= 810-        | otherwise-        = panic "graphAddCoalesce"-#endif+        where+          arch = platformArch platform   -- | Patch registers in code using the reg -> reg mapping in this graph.@@ -398,7 +404,7 @@         -> LiveCmmDecl statics instr -> LiveCmmDecl statics instr  patchRegsFromGraph platform graph code- = patchEraseLive patchF code+ = patchEraseLive platform patchF code  where         -- Function to lookup the hardreg for a virtual reg from the graph.         patchF reg
GHC/CmmToAsm/Reg/Graph/Base.hs view
@@ -30,6 +30,7 @@ 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@@ -104,16 +105,16 @@         regsC           = regsOfClass classC          -- all the possible subsets of c which have size < m-        regsS           = filter (\s -> sizeUniqSet s >= 1+        regsS           = filter (\s -> not (isEmptyUniqSet s)                                      && sizeUniqSet s <= neighbors)                         $ powersetLS regsC          -- for each of the subsets of C, the regs which conflict-        -- with posiblities for N+        -- with possibilities for N         regsS_conflict                 = map (\s -> intersectUniqSets regsN (regAliasS s)) regsS -  in    maximum $ map sizeUniqSet $ regsS_conflict+  in    maximum $ 0 :| map sizeUniqSet regsS_conflict   -- | For a node N of classN and neighbors of classesC
GHC/CmmToAsm/Reg/Graph/Coalesce.hs view
@@ -12,10 +12,11 @@ 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.Set import GHC.Types.Unique.Supply-+import GHC.Types.Unique.Set  -- | Do register coalescing on this top level thing --@@ -25,18 +26,19 @@ --   safely erased. regCoalesce         :: Instruction instr-        => [LiveCmmDecl statics instr]+        => Platform+        -> [LiveCmmDecl statics instr]         -> UniqSM [LiveCmmDecl statics instr] -regCoalesce code+regCoalesce platform code  = do         let joins       = foldl' unionBags emptyBag-                        $ map slurpJoinMovs code+                        $ map (slurpJoinMovs platform) code          let alloc       = foldl' buildAlloc emptyUFM                         $ bagToList joins -        let patched     = map (patchEraseLive (sinkReg alloc)) code+        let patched     = map (patchEraseLive platform (sinkReg alloc)) code          return patched @@ -67,10 +69,11 @@ --   eliminate the move. slurpJoinMovs         :: Instruction instr-        => LiveCmmDecl statics instr+        => Platform+        -> LiveCmmDecl statics instr         -> Bag (Reg, Reg) -slurpJoinMovs live+slurpJoinMovs platform live         = slurpCmm emptyBag live  where         slurpCmm   rs  CmmData{}@@ -84,9 +87,9 @@          slurpLI    rs (LiveInstr _      Nothing)    = rs         slurpLI    rs (LiveInstr instr (Just live))-                | Just (r1, r2) <- takeRegRegMoveInstr instr-                , elementOfUniqSet r1 $ liveDieRead live-                , elementOfUniqSet r2 $ liveBorn 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
GHC/CmmToAsm/Reg/Graph/Spill.hs view
@@ -9,25 +9,28 @@  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 hiding (RegSet)+import GHC.Cmm import GHC.Cmm.BlockId-import GHC.Cmm.Dataflow.Collections+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.Supply+import GHC.Types.Unique.DSM import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Platform -import Data.List (nub, (\\), intersect)+import Data.Function ( on )+import Data.List (intersectBy, nubBy) import Data.Maybe import Data.IntSet              (IntSet) import qualified Data.IntSet    as IntSet@@ -52,7 +55,7 @@         -> UniqSet Int                  -- ^ available stack slots         -> Int                          -- ^ current number of spill slots.         -> UniqSet VirtualReg           -- ^ the regs to spill-        -> UniqSM+        -> UniqDSM             ([LiveCmmDecl statics instr]                  -- code with SPILL and RELOAD meta instructions added.             , UniqSet Int               -- left over slots@@ -81,19 +84,22 @@                     -- See Note [Unique Determinism and code generation]                  -- Grab the unique supply from the monad.-                us      <- getUniqueSupplyM+                UDSM $ \us -> -                -- Run the spiller on all the blocks.-                let (code', state')     =-                        runState (mapM (regSpill_top platform regSlotMap) code)-                                 (initSpillS us)+                  -- Run the spiller on all the blocks.+                  let (code', state')     =+                          runState (mapM (regSpill_top platform regSlotMap) code)+                                   (initSpillS us) -                return  ( code'+                   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@@ -138,7 +144,7 @@         -- then record the fact that these slots are now live in those blocks         -- in the given slotmap.         patchLiveSlot-                :: BlockMap IntSet -> BlockId -> RegSet -> BlockMap IntSet+                :: BlockMap IntSet -> BlockId -> UniqSet RegWithFormat-> BlockMap IntSet          patchLiveSlot slotMap blockId regsLive          = let@@ -147,8 +153,7 @@                                 $ mapLookup blockId slotMap                  moreSlotsLive   = IntSet.fromList-                                $ catMaybes-                                $ map (lookupUFM regSlotMap)+                                $ mapMaybe (lookupUFM regSlotMap . regWithFormat_reg)                                 $ nonDetEltsUniqSet regsLive                     -- See Note [Unique Determinism and code generation] @@ -189,23 +194,25 @@    -- 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+  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 rsRead              = rsRead_    \\ rsWritten_-  let rsWritten           = rsWritten_ \\ rsRead_-  let rsModify            = intersect rsRead_ rsWritten_+  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 r regSlotMap) rsRead-  let rsSpillWritten      = filter (\r -> elemUFM r regSlotMap) rsWritten-  let rsSpillModify       = filter (\r -> elemUFM r regSlotMap) rsModify+  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   regSlotMap) instr  rsSpillRead-  (instr2, prepost2)      <- mapAccumLM (spillWrite  regSlotMap) instr1 rsSpillWritten-  (instr3, prepost3)      <- mapAccumLM (spillModify regSlotMap) instr2 rsSpillModify+  (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@@ -223,20 +230,21 @@ --   writes to a vreg that is being spilled. spillRead         :: Instruction instr-        => UniqFM Reg Int+        => Platform+        -> UniqFM Reg Int         -> instr-        -> Reg+        -> RegWithFormat         -> SpillM (instr, ([LiveInstr instr'], [LiveInstr instr'])) -spillRead regSlotMap instr reg+spillRead platform regSlotMap instr (RegWithFormat reg fmt)  | Just slot     <- lookupUFM regSlotMap reg- = do    (instr', nReg)  <- patchInstr reg instr+ = 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 nReg) Nothing]+                 , ( [LiveInstr (RELOAD slot (RegWithFormat nReg fmt)) Nothing]                  , []) )   | otherwise     = panic "RegSpill.spillRead: no slot defined for spilled reg"@@ -246,21 +254,22 @@ --   writes to a vreg that is being spilled. spillWrite         :: Instruction instr-        => UniqFM Reg Int+        => Platform+        -> UniqFM Reg Int         -> instr-        -> Reg+        -> RegWithFormat         -> SpillM (instr, ([LiveInstr instr'], [LiveInstr instr'])) -spillWrite regSlotMap instr reg+spillWrite platform regSlotMap instr (RegWithFormat reg fmt)  | Just slot     <- lookupUFM regSlotMap reg- = do    (instr', nReg)  <- patchInstr reg instr+ = do    (instr', nReg)  <- patchInstr platform reg instr           modify $ \s -> s                 { stateSpillSL  = addToUFM_C accSpillSL (stateSpillSL s) reg (reg, 1, 0) }           return  ( instr'                  , ( []-                   , [LiveInstr (SPILL nReg slot) Nothing]))+                   , [LiveInstr (SPILL (RegWithFormat nReg fmt) slot) Nothing]))   | otherwise     = panic "RegSpill.spillWrite: no slot defined for spilled reg" @@ -269,21 +278,22 @@ --   both reads and writes to a vreg that is being spilled. spillModify         :: Instruction instr-        => UniqFM Reg Int+        => Platform+        -> UniqFM Reg Int         -> instr-        -> Reg+        -> RegWithFormat         -> SpillM (instr, ([LiveInstr instr'], [LiveInstr instr'])) -spillModify regSlotMap instr reg+spillModify platform regSlotMap instr (RegWithFormat reg fmt)  | Just slot     <- lookupUFM regSlotMap reg- = do    (instr', nReg)  <- patchInstr reg instr+ = 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 nReg) Nothing]-                   , [LiveInstr (SPILL nReg slot) Nothing]))+                 , ( [LiveInstr (RELOAD slot (RegWithFormat nReg fmt)) Nothing]+                   , [LiveInstr (SPILL (RegWithFormat nReg fmt) slot) Nothing]))   | otherwise     = panic "RegSpill.spillModify: no slot defined for spilled reg" @@ -292,9 +302,9 @@ --   virtual reg. patchInstr         :: Instruction instr-        => Reg -> instr -> SpillM (instr, Reg)+        => Platform -> Reg -> instr -> SpillM (instr, Reg) -patchInstr reg instr+patchInstr platform reg instr  = do   nUnique         <- newUnique          -- The register we're rewriting is supposed to be virtual.@@ -307,38 +317,45 @@                 RegReal{}                  -> panic "RegAlloc.Graph.Spill.patchIntr: not patching real reg" -        let instr'      = patchReg1 reg nReg instr+        let instr'      = patchReg1 platform reg nReg instr         return          (instr', nReg)   patchReg1         :: Instruction instr-        => Reg -> Reg -> instr -> instr+        => Platform -> Reg -> Reg -> instr -> instr -patchReg1 old new instr+patchReg1 platform old new instr  = let  patchF r                 | r == old      = new                 | otherwise     = r-   in   patchRegsOfInstr instr patchF+   in   patchRegsOfInstr platform instr patchF   -- Spiller monad -------------------------------------------------------------- -- | State monad for the spill code generator.-type SpillM a-        = State SpillS a+type SpillM = State SpillS  -- | Spill code generator state. data SpillS         = SpillS         { -- | Unique supply for generating fresh vregs.-          stateUS       :: UniqSupply+          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 :: UniqSupply -> SpillS+initSpillS :: DUniqSupply -> SpillS initSpillS uniqueSupply         = SpillS         { stateUS       = uniqueSupply@@ -347,12 +364,7 @@  -- | 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+newUnique = getUniqueM   -- | Add a spill/reload count to a stats record for a register.
GHC/CmmToAsm/Reg/Graph/SpillClean.hs view
@@ -35,7 +35,9 @@ ) 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 @@ -45,18 +47,19 @@ 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.Platform-import GHC.Cmm.Dataflow.Collections+import GHC.Cmm.Dataflow.Label -import Data.List (nub, foldl1', find)+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.@@ -66,23 +69,23 @@ -- | Clean out unneeded spill\/reloads from this top level thing. cleanSpills         :: Instruction instr-        => Platform+        => NCGConfig         -> LiveCmmDecl statics instr         -> LiveCmmDecl statics instr -cleanSpills platform cmm-        = evalState (cleanSpin platform 0 cmm) initCleanS+cleanSpills config cmm+        = evalState (cleanSpin config 0 cmm) initCleanS   -- | Do one pass of cleaning. cleanSpin         :: Instruction instr-        => Platform+        => NCGConfig         -> Int                              -- ^ Iteration number for the cleaner.         -> LiveCmmDecl statics instr        -- ^ Liveness annotated code to clean.         -> CleanM (LiveCmmDecl statics instr) -cleanSpin platform spinCount code+cleanSpin config spinCount code  = do         -- Initialise count of cleaned spill and reload instructions.         modify $ \s -> s@@ -90,7 +93,7 @@                 , sCleanedReloadsAcc    = 0                 , sReloadedBy           = emptyUFM } -        code_forward    <- mapBlockTopM (cleanBlockForward platform) code+        code_forward    <- mapBlockTopM (cleanBlockForward config) code         code_backward   <- cleanTopBackward code_forward          -- During the cleaning of each block we collected information about@@ -112,7 +115,7 @@            then return code          -- otherwise go around again-           else cleanSpin platform (spinCount + 1) code_backward+           else cleanSpin config (spinCount + 1) code_backward   -------------------------------------------------------------------------------@@ -120,11 +123,11 @@ --   while walking forward over the code. cleanBlockForward         :: Instruction instr-        => Platform+        => NCGConfig         -> LiveBasicBlock instr         -> CleanM (LiveBasicBlock instr) -cleanBlockForward platform (BasicBlock blockId instrs)+cleanBlockForward config (BasicBlock blockId instrs)  = do         -- See if we have a valid association for the entry to this block.         jumpValid       <- gets sJumpValid@@ -132,7 +135,7 @@                                 Just assoc      -> assoc                                 Nothing         -> emptyAssoc -        instrs_reload   <- cleanForward platform blockId assoc [] instrs+        instrs_reload   <- cleanForward config blockId assoc [] instrs         return  $ BasicBlock blockId instrs_reload  @@ -145,7 +148,7 @@ -- cleanForward         :: Instruction instr-        => Platform+        => NCGConfig         -> BlockId                  -- ^ the block that we're currently in         -> Assoc Store              -- ^ two store locations are associated if                                     --     they have the same value@@ -158,24 +161,23 @@  -- 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+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 platform blockId assoc acc-                 $ li1 : LiveInstr (mkRegRegMoveInstr platform reg1 reg2) Nothing+                cleanForward config blockId assoc acc+                 $ li1 : LiveInstr (mkRegRegMoveInstr config (regWithFormat_format reg2) (regWithFormat_reg reg1) (regWithFormat_reg reg2)) Nothing                        : instrs -cleanForward platform blockId assoc acc (li@(LiveInstr i1 _) : instrs)-        | Just (r1, r2) <- takeRegRegMoveInstr i1+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 platform blockId assoc acc instrs+                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@@ -183,26 +185,26 @@                                         $ delAssoc (SReg r2)                                         $ assoc -                        cleanForward platform blockId assoc' (li : acc) instrs+                        cleanForward config blockId assoc' (li : acc) instrs  -cleanForward platform blockId assoc acc (li : instrs)+cleanForward config blockId assoc acc (li : instrs)          -- Update association due to the spill.         | LiveInstr (SPILL reg slot) _  <- li-        = let   assoc'  = addAssoc (SReg reg)  (SSlot slot)+        = let   assoc'  = addAssoc (SReg $ regWithFormat_reg reg)  (SSlot slot)                         $ delAssoc (SSlot slot)                         $ assoc-          in    cleanForward platform blockId assoc' (li : acc) instrs+          in    cleanForward config blockId assoc' (li : acc) instrs          -- Clean a reload instr.         | LiveInstr (RELOAD{}) _        <- li-        = do    (assoc', mli)   <- cleanReload platform blockId assoc li+        = do    (assoc', mli)   <- cleanReload config blockId assoc li                 case mli of-                 Nothing        -> cleanForward platform blockId assoc' acc+                 Nothing        -> cleanForward config blockId assoc' acc                                                 instrs -                 Just li'       -> cleanForward platform blockId assoc' (li' : acc)+                 Just li'       -> cleanForward config blockId assoc' (li' : acc)                                                 instrs          -- Remember the association over a jump.@@ -210,26 +212,26 @@         , targets               <- jumpDestsOfInstr instr         , not $ null targets         = do    mapM_ (accJumpValid assoc) targets-                cleanForward platform blockId assoc (li : acc) instrs+                cleanForward config 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+        , 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-        => Platform+        => NCGConfig         -> BlockId         -> Assoc Store         -> LiveInstr instr         -> CleanM (Assoc Store, Maybe (LiveInstr instr)) -cleanReload platform blockId assoc li@(LiveInstr (RELOAD slot reg) _)+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.@@ -247,7 +249,7 @@                                 $ assoc                  return  ( assoc'-                        , Just $ LiveInstr (mkRegRegMoveInstr platform reg2 reg) Nothing)+                        , Just $ LiveInstr (mkRegRegMoveInstr config fmt reg2 reg) Nothing )          -- Gotta keep this instr.         | otherwise@@ -390,8 +392,7 @@         = do                 let slotsReloadedByTargets                         = IntSet.unions-                        $ catMaybes-                        $ map (flip mapLookup liveSlotsOnEntry)+                        $ mapMaybe (flip mapLookup liveSlotsOnEntry)                         $ targets                  let noReloads'@@ -400,13 +401,7 @@                  cleanBackward liveSlotsOnEntry noReloads' (li : acc) instrs -#if __GLASGOW_HASKELL__ <= 810-        -- some other instruction-        | otherwise-        = cleanBackward liveSlotsOnEntry noReloads (li : acc) instrs-#endif - -- | Combine the associations from all the inward control flow edges. -- collateJoinPoints :: CleanM ()@@ -416,8 +411,7 @@         , sJumpValidAcc = emptyUFM }  intersects :: [Assoc Store]     -> Assoc Store-intersects []           = emptyAssoc-intersects assocs       = foldl1' intersectAssoc assocs+intersects = foldl1WithDefault' emptyAssoc intersectAssoc   -- | See if we have a reg with the same value as this slot in the association table.
GHC/CmmToAsm/Reg/Graph/SpillCost.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE GADTs               #-}+{-# LANGUAGE LambdaCase          #-} {-# LANGUAGE ScopedTypeVariables #-}  module GHC.CmmToAsm.Reg.Graph.SpillCost (@@ -24,7 +25,6 @@  import GHC.Data.Graph.Base -import GHC.Cmm.Dataflow.Collections (mapLookup) import GHC.Cmm.Dataflow.Label import GHC.Cmm import GHC.Types.Unique.FM@@ -35,8 +35,10 @@ 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, minimumBy)+import Data.List        (nub) import Data.Maybe import Control.Monad (join) @@ -100,7 +102,7 @@         countBlock info freqMap (BasicBlock blockId instrs)                 | LiveInfo _ _ blockLive _ <- info                 , Just rsLiveEntry  <- mapLookup blockId blockLive-                , rsLiveEntry_virt  <- takeVirtuals rsLiveEntry+                , rsLiveEntry_virt  <- takeVirtualRegs rsLiveEntry                 = countLIs (ceiling $ blockFreq freqMap blockId) rsLiveEntry_virt instrs                  | otherwise@@ -130,13 +132,13 @@                  -- Increment counts for what regs were read/written from.                 let (RU read written)   = regUsageOfInstr platform instr-                mapM_ (incUses scale) $ catMaybes $ map takeVirtualReg $ nub read-                mapM_ (incDefs scale) $ catMaybes $ map takeVirtualReg $ nub written+                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    = takeVirtuals (liveDieRead  live)-                let liveDieWrite_virt   = takeVirtuals (liveDieWrite live)-                let liveBorn_virt       = takeVirtuals (liveBorn     live)+                let liveDieRead_virt    = takeVirtualRegs (liveDieRead  live)+                let liveDieWrite_virt   = takeVirtualRegs (liveDieWrite live)+                let liveBorn_virt       = takeVirtualRegs (liveBorn     live)                  let rsLiveAcross                         = rsLiveEntry `minusUniqSet` liveDieRead_virt@@ -158,13 +160,6 @@           | otherwise           = 1.0 -- Only if no cfg given --- | 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@@ -174,7 +169,7 @@ chooseSpill info graph  = let  cost    = spillCost_length info graph         node    = minimumBy (\n1 n2 -> compare (cost $ nodeId n1) (cost $ nodeId n2))-                $ nonDetEltsUFM $ graphMap graph+                $ expectNonEmpty $ nonDetEltsUFM $ graphMap graph                 -- See Note [Unique Determinism and code generation]     in   nodeId node
GHC/CmmToAsm/Reg/Graph/Stats.hs view
@@ -1,11 +1,3 @@-{-# LANGUAGE BangPatterns, DeriveFunctor #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-}---{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}- -- | Carries interesting info for debugging / profiling of the --   graph coloring register allocator. module GHC.CmmToAsm.Reg.Graph.Stats (@@ -224,11 +216,10 @@  pprStatsSpills stats  = let-        finals  = [ s   | s@RegAllocStatsColored{} <- stats]+        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)-                $ map raSRMs finals+        total   = foldl' addSRM (0, 0, 0) finals      in  (  text "-- spills-added-total"         $$ text "--    (stores, loads, reg_reg_moves_remaining)"@@ -242,8 +233,7 @@  pprStatsLifetimes stats  = let  info            = foldl' plusSpillCostInfo zeroSpillCostInfo-                                [ raSpillCosts s-                                        | s@RegAllocStatsStart{} <- stats ]+                          [ sc | RegAllocStatsStart{ raSpillCosts = sc } <- stats ]          lifeBins        = binLifetimeCount $ lifeMapFromSpillCostInfo info @@ -292,20 +282,21 @@ pprStatsLifeConflict stats graph  = let  lifeMap = lifeMapFromSpillCostInfo                 $ foldl' plusSpillCostInfo zeroSpillCostInfo-                $ [ raSpillCosts s | s@RegAllocStatsStart{} <- stats ]+                $ [ sc | RegAllocStatsStart{ raSpillCosts = sc } <- 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+        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)"@@ -317,27 +308,29 @@ --      Lets us see how well the register allocator has done. countSRMs         :: Instruction instr-        => LiveCmmDecl statics instr -> (Int, Int, Int)+        => Platform+        -> LiveCmmDecl statics instr -> (Int, Int, Int) -countSRMs cmm-        = execState (mapBlockTopM countSRM_block cmm) (0, 0, 0)+countSRMs platform cmm+        = execState (mapBlockTopM (countSRM_block platform) cmm) (0, 0, 0)   countSRM_block         :: Instruction instr-        => GenBasicBlock (LiveInstr instr)+        => Platform+        -> GenBasicBlock (LiveInstr instr)         -> State (Int, Int, Int) (GenBasicBlock (LiveInstr instr)) -countSRM_block (BasicBlock i instrs)- = do   instrs' <- mapM countSRM_instr instrs+countSRM_block platform (BasicBlock i instrs)+ = do   instrs' <- mapM (countSRM_instr platform) instrs         return  $ BasicBlock i instrs'   countSRM_instr         :: Instruction instr-        => LiveInstr instr -> State (Int, Int, Int) (LiveInstr instr)+        => Platform -> LiveInstr instr -> State (Int, Int, Int) (LiveInstr instr) -countSRM_instr li+countSRM_instr platform li         | LiveInstr SPILL{} _    <- li         = do    modify  $ \(s, r, m)    -> (s + 1, r, m)                 return li@@ -347,7 +340,7 @@                 return li          | LiveInstr instr _     <- li-        , Just _        <- takeRegRegMoveInstr instr+        , Just _        <- takeRegRegMoveInstr platform instr         = do    modify  $ \(s, r, m)    -> (s, r, m + 1)                 return li
GHC/CmmToAsm/Reg/Graph/TrivColorable.hs view
@@ -7,11 +7,13 @@ 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+import GHC.Types.Unique.Set ( nonDetEltsUniqSet, UniqSet ) import GHC.Platform import GHC.Utils.Panic @@ -22,7 +24,7 @@ --      This gets hammered by scanGraph during register allocation, --      so needs to be fairly efficient. -----      NOTE:   This only works for architectures with just RcInteger and RcDouble+--      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@@ -100,102 +102,59 @@         -> (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-                            ArchPPC_64 _  -> 15-                            ArchARM _ _ _ -> panic "trivColorable ArchARM"-                            -- We should be able to allocate *a lot* more in princple.-                            -- essentially all 32 - SP, so 31, we'd trash the link reg-                            -- as well as the platform and all others though.-                            ArchAArch64   -> 18-                            ArchAlpha     -> panic "trivColorable ArchAlpha"-                            ArchMipseb    -> panic "trivColorable ArchMipseb"-                            ArchMipsel    -> panic "trivColorable ArchMipsel"-                            ArchS390X     -> panic "trivColorable ArchS390X"-                            ArchRISCV64   -> panic "trivColorable ArchRISCV64"-                            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-                    -- On x86_64 and x86, Float and RcDouble-                    -- use the same registers,-                    -- so we only use RcDouble to represent the-                    -- register allocation problem on those types.-                            ArchX86       -> 0-                            ArchX86_64    -> 0-                            ArchPPC       -> 0-                            ArchPPC_64 _  -> 0-                            ArchARM _ _ _ -> panic "trivColorable ArchARM"-                            -- we can in princple address all the float regs as-                            -- segments. So we could have 64 Float regs. Or-                            -- 128 Half regs, or even 256 Byte regs.-                            ArchAArch64   -> 0-                            ArchAlpha     -> panic "trivColorable ArchAlpha"-                            ArchMipseb    -> panic "trivColorable ArchMipseb"-                            ArchMipsel    -> panic "trivColorable ArchMipsel"-                            ArchS390X     -> panic "trivColorable ArchS390X"-                            ArchRISCV64   -> panic "trivColorable ArchRISCV64"-                            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       -> 8-                            -- in x86 32bit mode sse2 there are only-                            -- 8 XMM registers xmm0 ... xmm7-                            ArchX86_64    -> 10-                            -- in x86_64 there are 16 XMM registers-                            -- xmm0 .. xmm15, here 10 is a-                            -- "dont need to solve conflicts" count that-                            -- was chosen at some point in the past.-                            ArchPPC       -> 26-                            ArchPPC_64 _  -> 20-                            ArchARM _ _ _ -> panic "trivColorable ArchARM"-                            ArchAArch64   -> 32-                            ArchAlpha     -> panic "trivColorable ArchAlpha"-                            ArchMipseb    -> panic "trivColorable ArchMipseb"-                            ArchMipsel    -> panic "trivColorable ArchMipsel"-                            ArchS390X     -> panic "trivColorable ArchS390X"-                            ArchRISCV64   -> panic "trivColorable ArchRISCV64"-                            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 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 ----------------------------------------------------------@@ -213,21 +172,21 @@         acc r (cd, cf)          = case regClass r of                 RcInteger       -> (cd+1, cf)-                RcFloat         -> (cd,   cf+1)+                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 RcFloat+                        + 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 RcDouble, which don't conflict at all.+--      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@@ -236,11 +195,11 @@         RcInteger          -> case classC of                 RcInteger       -> min n (allocatableRegsInClass RcInteger)-                RcFloat         -> 0+                RcFloatOrVector -> 0 -        RcDouble+        RcFloatOrVector          -> case classC of-                RcFloat         -> min n (allocatableRegsInClass RcFloat)+                RcFloatOrVector -> min n (allocatableRegsInClass RcFloatOrVector)                 RcInteger       -> 0  -- allocatableRegs is allMachRegNos with the fixed-use regs removed.@@ -259,15 +218,15 @@ allocatableRegsInClass cls  = case cls of         RcInteger       -> allocatableRegsInteger-        RcFloat         -> allocatableRegsDouble+        RcFloatOrVector -> allocatableRegsDouble  allocatableRegsInteger :: Int allocatableRegsInteger         = length $ filter (\r -> regClass r == RcInteger)                  $ map RealReg allocatableRegs -allocatableRegsFloat :: Int-allocatableRegsFloat-        = length $ filter (\r -> regClass r == RcFloat+allocatableRegsDouble :: Int+allocatableRegsDouble+        = length $ filter (\r -> regClass r == RcFloatOrVector)                  $ map RealReg allocatableRegs -}
GHC/CmmToAsm/Reg/Linear.hs view
@@ -1,8 +1,4 @@-{-# LANGUAGE BangPatterns, ScopedTypeVariables #-}-{-# LANGUAGE ConstraintKinds #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}- ----------------------------------------------------------------------------- -- -- The register allocator@@ -114,30 +110,37 @@ 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 (RegClass(..))+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.Collections-import GHC.Cmm hiding (RegSet)+import GHC.Cmm.Dataflow.Label+import GHC.Cmm  import GHC.Data.Graph.Directed import GHC.Types.Unique-import GHC.Types.Unique.Set import GHC.Types.Unique.FM-import GHC.Types.Unique.Supply+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 (partition, nub)+import Data.List (sortOn) import Control.Monad  -- -----------------------------------------------------------------------------@@ -148,11 +151,11 @@         :: Instruction instr         => NCGConfig         -> LiveCmmDecl statics instr-        -> UniqSM ( NatCmmDecl statics instr-                  , Maybe Int  -- number of extra stack slots required,-                               -- beyond maxSpillSlots-                  , Maybe RegAllocStats-                  )+        -> UniqDSM ( NatCmmDecl statics instr+                   , Maybe Int  -- number of extra stack slots required,+                                -- beyond maxSpillSlots+                   , Maybe RegAllocStats+                   )  regAlloc _ (CmmData sec d)         = return@@ -174,8 +177,7 @@                  -- 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 !final_blocks' = sortOn ((/= first_id) . blockId) final_blocks                  let max_spill_slots = maxSpillSlots config                     extra_stack@@ -184,7 +186,7 @@                       | otherwise                       = Nothing -                return  ( CmmProc info lbl live (ListGraph (first' : rest'))+                return  ( CmmProc info lbl live (ListGraph final_blocks')                         , extra_stack                         , Just stats) @@ -205,11 +207,11 @@         :: forall instr. (Instruction instr)         => NCGConfig         -> [BlockId] -- ^ entry points-        -> BlockMap RegSet+        -> BlockMap (UniqSet RegWithFormat)               -- ^ live regs on entry to each basic block         -> [SCC (LiveBasicBlock instr)]               -- ^ instructions annotated with "deaths"-        -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int)+        -> UniqDSM ([NatBasicBlock instr], RegAllocStats, Int)  linearRegAlloc config entry_ids block_live sccs  = case platformArch platform of@@ -223,12 +225,14 @@       ArchAlpha      -> panic "linearRegAlloc ArchAlpha"       ArchMipseb     -> panic "linearRegAlloc ArchMipseb"       ArchMipsel     -> panic "linearRegAlloc ArchMipsel"-      ArchRISCV64    -> panic "linearRegAlloc ArchRISCV64"+      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 -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int)+     => regs -> UniqDSM ([NatBasicBlock instr], RegAllocStats, Int)   go f = linearRegAlloc' config f entry_ids block_live sccs   platform = ncgPlatform config @@ -242,21 +246,21 @@         => NCGConfig         -> freeRegs         -> [BlockId]                    -- ^ entry points-        -> BlockMap RegSet              -- ^ live regs on entry to each basic block+        -> BlockMap (UniqSet RegWithFormat)              -- ^ live regs on entry to each basic block         -> [SCC (LiveBasicBlock instr)] -- ^ instructions annotated with "deaths"-        -> UniqSM ([NatBasicBlock instr], RegAllocStats, Int)+        -> UniqDSM ([NatBasicBlock instr], RegAllocStats, Int)  linearRegAlloc' config initFreeRegs entry_ids block_live sccs- = do   us      <- getUniqueSupplyM-        let !(_, !stack, !stats, !blocks) =-                runR config emptyBlockAssignment initFreeRegs emptyRegMap emptyStackMap us-                    $ linearRA_SCCs entry_ids block_live [] sccs-        return  (blocks, stats, getStackUse stack)+ = 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 RegSet+              -> BlockMap (UniqSet RegWithFormat)               -> [NatBasicBlock instr]               -> [SCC (LiveBasicBlock instr)]               -> RegM freeRegs [NatBasicBlock instr]@@ -291,7 +295,7 @@  process :: forall freeRegs instr. (OutputableRegConstraint freeRegs instr)         => [BlockId]-        -> BlockMap RegSet+        -> BlockMap (UniqSet RegWithFormat)         -> [GenBasicBlock (LiveInstr instr)]         -> RegM freeRegs [[NatBasicBlock instr]] process entry_ids block_live =@@ -330,7 +334,7 @@ -- processBlock         :: OutputableRegConstraint freeRegs instr-        => BlockMap RegSet              -- ^ live regs on entry to each basic block+        => 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 @@ -347,7 +351,7 @@ -- | 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 ()+          => BlockId -> BlockMap (UniqSet RegWithFormat) -> RegM freeRegs () initBlock id block_live  = do   platform    <- getPlatform         block_assig <- getBlockAssigR@@ -364,7 +368,7 @@                             setFreeRegsR    (frInitFreeRegs platform)                           Just live ->                             setFreeRegsR $ foldl' (flip $ frAllocateReg platform) (frInitFreeRegs platform)-                                                  [ r | RegReal r <- nonDetEltsUniqSet live ]+                                                  (nonDetEltsUniqSet $ takeRealRegs live)                             -- See Note [Unique Determinism and code generation]                         setAssigR       emptyRegMap @@ -377,7 +381,7 @@ -- | Do allocation for a sequence of instructions. linearRA         :: forall freeRegs instr. (OutputableRegConstraint freeRegs instr)-        => BlockMap RegSet                      -- ^ map of what vregs are live on entry to each block.+        => 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@@ -402,7 +406,7 @@ -- | Do allocation for a single instruction. raInsn         :: OutputableRegConstraint freeRegs instr-        => BlockMap RegSet                      -- ^ map of what vregs are love on entry to each block.+        => 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.@@ -422,6 +426,7 @@  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@@ -431,13 +436,13 @@     -- 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),+    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 rr))+              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.@@ -456,8 +461,8 @@            return (new_instrs, [])          _ -> genRaInsn block_live new_instrs id instr-                        (nonDetEltsUniqSet $ liveDieRead live)-                        (nonDetEltsUniqSet $ liveDieWrite live)+                        (map regWithFormat_reg $ nonDetEltsUniqSet $ liveDieRead live)+                        (map regWithFormat_reg $ nonDetEltsUniqSet $ liveDieWrite live)                         -- See Note [Unique Determinism and code generation]  raInsn _ _ _ instr@@ -486,7 +491,7 @@  genRaInsn :: forall freeRegs instr.              (OutputableRegConstraint freeRegs instr)-          => BlockMap RegSet+          => BlockMap (UniqSet RegWithFormat)           -> [instr]           -> BlockId           -> instr@@ -499,13 +504,14 @@   platform <- getPlatform   case regUsageOfInstr platform instr of { RU read written ->     do-    let real_written    = [ rr  | (RegReal     rr) <- written ] :: [RealReg]-    let virt_written    = [ vr  | (RegVirtual  vr) <- written ]+    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       = nub [ vr      | (RegVirtual vr) <- read ] :: [VirtualReg]+    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]@@ -565,13 +571,13 @@                 = toRegMap $ -- Cast key from VirtualReg to Reg                              -- See Note [UniqFM and the register allocator]                   listToUFM-                        [ (t, RegReal r)-                                | (t, r) <- zip virt_read    r_allocd-                                         ++ zip virt_written w_allocd ]+                        [ (virtualRegWithFormat_reg vr, RegReal rr)+                        | (vr, rr) <- zip virt_read    r_allocd+                                   ++ zip virt_written w_allocd ]          patched_instr :: instr         patched_instr-                = patchRegsOfInstr adjusted_instr patchLookup+                = patchRegsOfInstr platform adjusted_instr patchLookup          patchLookup :: Reg -> Reg         patchLookup x@@ -585,7 +591,7 @@     -- 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+    let squashed_instr  = case takeRegRegMoveInstr platform patched_instr of                                 Just (src, dst)                                  | src == dst   -> []                                 _               -> [patched_instr]@@ -595,7 +601,7 @@     -- 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-    -- mutliple instructions potentially issued by those functions we need to be+    -- 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.     --@@ -618,7 +624,7 @@                       ]  --    pprTrace "patched-code" ((vcat $ map (docToSDoc . pprInstr) code)) $ do---    pprTrace "pached-fixup" ((ppr fixup_blocks)) $ do+--    pprTrace "patched-fixup" ((ppr fixup_blocks)) $ do      return (code, fixup_blocks) @@ -638,9 +644,9 @@       loop assig !free (r:rs) =          case lookupUFM assig r of          Just (InBoth real _) -> loop (delFromUFM assig r)-                                      (frReleaseReg platform real free) rs+                                      (frReleaseReg platform (realReg real) free) rs          Just (InReg real)    -> loop (delFromUFM assig r)-                                      (frReleaseReg platform real free) rs+                                      (frReleaseReg platform (realReg real) free) rs          _                    -> loop (delFromUFM assig r) free rs   loop assig free regs @@ -688,16 +694,17 @@                 -- currently support deterministic code-generation.                 -- See Note [Unique Determinism and code generation]                 InReg reg-                    | any (realRegsAlias reg) clobbered+                    | any (realRegsAlias $ realReg reg) clobbered                     , temp `notElem` map getUnique dying-                    -> clobber temp (assig,instrs) (reg)+                    -> clobber temp (assig,instrs) reg                 _ -> return (assig,instrs)        -- See Note [UniqFM and the register allocator]-     clobber :: Unique -> (RegMap Loc,[instr]) -> (RealReg) -> RegM freeRegs (RegMap Loc,[instr])-     clobber temp (assig,instrs) (reg)-       = do platform <- getPlatform+     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@@ -711,20 +718,20 @@               (my_reg : _) -> do                   setFreeRegsR (frAllocateReg platform my_reg freeRegs) -                  let new_assign = addToUFM_Directly assig temp (InReg my_reg)-                  let instr = mkRegRegMoveInstr platform+                  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 (RegReal reg) temp+                  (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 reg slot)+                  let new_assign  = addToUFM_Directly assig temp (InBoth (RealRegUsage reg fmt) slot)                    return (new_assign, (spill ++ instrs)) @@ -742,12 +749,14 @@  = do   platform <- getPlatform         freeregs <- getFreeRegsR -        let gpRegs  = frGetFreeRegs platform RcInteger freeregs :: [RealReg]-            fltRegs = frGetFreeRegs platform RcFloat   freeregs :: [RealReg]-            dblRegs = frGetFreeRegs platform RcDouble  freeregs :: [RealReg]+        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` (gpRegs ++ fltRegs ++ dblRegs) ]+        let extra_clobbered = [ r | r <- clobbered, r `elem` allFreeRegs ]          setFreeRegsR $! foldl' (flip $ frAllocateReg platform) freeregs extra_clobbered @@ -771,7 +780,7 @@                 = assig          clobber assig ((temp, InBoth reg slot) : rest)-                | any (realRegsAlias reg) clobbered+                | any (realRegsAlias $ realReg reg) clobbered                 = clobber (addToUFM_Directly assig temp (InMem slot)) rest          clobber assig (_:rest)@@ -799,25 +808,25 @@  allocateRegsAndSpill         :: forall freeRegs instr. (FR freeRegs, 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+        => 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:rs)+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 r of+        case lookupUFM assig vr of                 -- case (1a): already in a register                 Just (InReg my_reg) ->-                        allocateRegsAndSpill reading keep spills (my_reg:alloc) rs+                        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@@ -825,14 +834,14 @@                 -- 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 r (InReg my_reg)))-                        allocateRegsAndSpill reading keep spills (my_reg:alloc) rs+                 -> 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 r)+                   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@@ -858,21 +867,22 @@ -- convenient and it maintains the recursive structure of the allocator. -- EZY allocRegsAndSpill_spill :: (FR freeRegs, Instruction instr)                         => Bool-                        -> [VirtualReg]+                        -> [VirtualRegWithFormat]                         -> [instr]                         -> [RealReg]-                        -> VirtualReg-                        -> [VirtualReg]+                        -> VirtualRegWithFormat+                        -> [VirtualRegWithFormat]                         -> UniqFM VirtualReg Loc                         -> SpillLoc                         -> RegM freeRegs ([instr], [RealReg])-allocRegsAndSpill_spill reading keep spills alloc r rs assig spill_loc+allocRegsAndSpill_spill reading keep spills alloc r@(VirtualRegWithFormat vr fmt) rs assig spill_loc  = do   platform <- getPlatform         freeRegs <- getFreeRegsR-        let freeRegs_thisClass  = frGetFreeRegs platform (classOfVirtualReg r) freeRegs :: [RealReg]+        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 r+        pref_reg <- findPrefRealReg vr          case freeRegs_thisClass of          -- case (2): we have a free register@@ -883,10 +893,11 @@                         = reg                         | otherwise                         = first_free+                 spills'   <- loadTemp r spill_loc final_reg spills                  setAssigR $ toRegMap-                          $ (addToUFM assig r $! newLocation spill_loc final_reg)+                          $ (addToUFM assig vr $! newLocation spill_loc $ RealRegUsage final_reg fmt)                 setFreeRegsR $  frAllocateReg platform final_reg freeRegs                  allocateRegsAndSpill reading keep spills' (final_reg : alloc) rs@@ -899,7 +910,7 @@                     inRegOrBoth _ = False                 let candidates' :: UniqFM VirtualReg Loc                     candidates' =-                      flip delListFromUFM keep $+                      flip delListFromUFM (fmap virtualRegWithFormat_reg keep) $                       filterUFM inRegOrBoth $                       assig                       -- This is non-deterministic but we do not@@ -908,44 +919,47 @@                 let candidates = nonDetUFMToList candidates'                  -- the vregs we could kick out that are already in a slot-                let candidates_inBoth :: [(Unique, RealReg, StackSlot)]+                let compat reg'+                      =  targetClassOfRealReg platform reg'+                      == regclass+                    candidates_inBoth :: [(Unique, RealRegUsage, StackSlot)]                     candidates_inBoth                         = [ (temp, reg, mem)                           | (temp, InBoth reg mem) <- candidates-                          , targetClassOfRealReg platform reg == classOfVirtualReg r ]+                          , 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-                          , targetClassOfRealReg platform reg == classOfVirtualReg r ]+                          , compat (realReg reg) ]                  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+                        | (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 r $! newLocation spill_loc my_reg+                                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, (my_reg :: RealReg)) : _+                        | (temp_to_push_out, RealRegUsage my_reg fmt) : _                                         <- candidates_inReg                         = do-                                (spill_store, slot) <- spillR (RegReal my_reg) temp_to_push_out+                                (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 r                 $! newLocation spill_loc my_reg+                                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.@@ -960,16 +974,19 @@                         | otherwise                         = pprPanic ("RegAllocLinear.allocRegsAndSpill: no spill candidates\n")                         $ vcat-                                [ text "allocating vreg:  " <> text (show r)+                                [ text "allocating vreg:  " <> text (show vr)                                 , text "assignment:       " <> ppr assig-                                , text "freeRegs:         " <> text (show freeRegs)-                                , text "initFreeRegs:     " <> text (show (frInitFreeRegs platform `asTypeOf` freeRegs)) ]+                                , 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 -> RealReg -> Loc+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@@ -978,15 +995,15 @@ -- | Load up a spilled temporary if we need to (read from memory). loadTemp         :: (Instruction instr)-        => VirtualReg   -- the temp being loaded+        => 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 vreg (ReadMem slot) hreg spills+loadTemp (VirtualRegWithFormat vreg fmt) (ReadMem slot) hreg spills  = do-        insn <- loadR (RegReal hreg) slot+        insn <- loadR (RegWithFormat (RegReal hreg) fmt) slot         recordSpill (SpillLoad $ getUnique vreg)         return  $  {- mkComment (text "spill load") : -} insn ++ spills
GHC/CmmToAsm/Reg/Linear/AArch64.hs view
@@ -3,16 +3,16 @@ import GHC.Prelude  import GHC.CmmToAsm.AArch64.Regs-import GHC.Platform.Reg.Class+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 -import GHC.Stack -- 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.@@ -35,7 +35,7 @@ -- | - 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 percision fp  | - Single percision fp   |+-- |                        | - Single precision fp  | - Single precision fp   | -- |                        |                        | - Double precision fp   | -- |                        |                        | - Single/Double fp are  | -- |                        |                        |   IEEE compliant        |@@ -65,7 +65,7 @@ showBits w = map (\i -> if testBit w i then '1' else '0') [0..31]  -- FR instance implementation (See Linear.FreeRegs)-allocateReg :: HasCallStack => RealReg -> FreeRegs -> 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@@ -115,10 +115,11 @@ -}  getFreeRegs :: RegClass -> FreeRegs -> [RealReg]-getFreeRegs cls (FreeRegs g f)-  | RcFloat   <- cls = [] -- For now we only support double and integer registers, floats will need to be promoted.-  | RcDouble  <- cls = go 32 f 31-  | RcInteger <- cls = go  0 g 18+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)@@ -127,7 +128,7 @@ initFreeRegs :: Platform -> FreeRegs initFreeRegs platform = foldl' (flip releaseReg) noFreeRegs (allocatableRegs platform) -releaseReg :: HasCallStack => RealReg -> FreeRegs -> FreeRegs+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)
GHC/CmmToAsm/Reg/Linear/Base.hs view
@@ -11,6 +11,7 @@          Loc(..),         regsOfLoc,+        RealRegUsage(..),          -- for stats         SpillReason(..),@@ -32,11 +33,14 @@ import GHC.Utils.Outputable import GHC.Types.Unique import GHC.Types.Unique.FM-import GHC.Types.Unique.Supply+import GHC.Types.Unique.DSM import GHC.Cmm.BlockId-import GHC.Cmm.Dataflow.Collections+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.@@ -76,8 +80,8 @@     combWithExisting old_reg _ = Just $ old_reg      fromLoc :: Loc -> Maybe RealReg-    fromLoc (InReg rr) = Just rr-    fromLoc (InBoth rr _) = Just rr+    fromLoc (InReg rr) = Just $ realReg rr+    fromLoc (InBoth rr _) = Just $ realReg rr     fromLoc _ = Nothing  @@ -94,23 +98,41 @@ -- data Loc         -- | vreg is in a register-        = InReg   !RealReg+        = InReg   {-# UNPACK #-} !RealRegUsage -        -- | vreg is held in a stack slot+        -- | vreg is held in stack slots         | InMem   {-# UNPACK #-}  !StackSlot  -        -- | vreg is held in both a register and a stack slot-        | InBoth   !RealReg+        -- | vreg is held in both a register and stack slots+        | InBoth   {-# UNPACK #-} !RealRegUsage                    {-# UNPACK #-} !StackSlot-        deriving (Eq, Show, Ord)+        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 -> [RealReg]+regsOfLoc :: Loc -> [RealRegUsage] regsOfLoc (InReg r)    = [r] regsOfLoc (InBoth r _) = [r] regsOfLoc (InMem _)    = []@@ -170,7 +192,7 @@         , ra_stack      :: StackMap          -- | unique supply for generating names for join point fixup blocks.-        , ra_us         :: UniqSupply+        , ra_us         :: DUniqSupply          -- | Record why things were spilled, for -ddrop-asm-stats.         --      Just keep a list here instead of a map of regs -> reasons.@@ -184,5 +206,4 @@         , ra_fixups     :: [(BlockId,BlockId,BlockId)]          }-
GHC/CmmToAsm/Reg/Linear/FreeRegs.hs view
@@ -1,5 +1,6 @@ module GHC.CmmToAsm.Reg.Linear.FreeRegs (     FR(..),+    allFreeRegs,     maxSpillSlots ) where@@ -8,6 +9,9 @@  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@@ -29,10 +33,14 @@ 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@@ -64,6 +72,27 @@     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@@ -76,6 +105,8 @@    ArchAlpha     -> panic "maxSpillSlots ArchAlpha"    ArchMipseb    -> panic "maxSpillSlots ArchMipseb"    ArchMipsel    -> panic "maxSpillSlots ArchMipsel"-   ArchRISCV64   -> panic "maxSpillSlots ArchRISCV64"+   ArchRISCV64   -> RV64.Instr.maxSpillSlots config+   ArchLoongArch64  -> LA64.Instr.maxSpillSlots config    ArchJavaScript-> panic "maxSpillSlots ArchJavaScript"+   ArchWasm32    -> panic "maxSpillSlots ArchWasm32"    ArchUnknown   -> panic "maxSpillSlots ArchUnknown"
GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs view
@@ -1,5 +1,3 @@-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}- -- | Handles joining of a jump instruction to its targets.  --      The first time we encounter a jump to a particular basic block, we@@ -23,12 +21,16 @@ import GHC.Platform.Reg  import GHC.Cmm.BlockId-import GHC.Cmm.Dataflow.Collections+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@@ -36,7 +38,7 @@ -- joinToTargets         :: (FR freeRegs, Instruction instr)-        => BlockMap RegSet              -- ^ maps the unique of the blockid to the set of vregs+        => 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@@ -60,7 +62,7 @@ ----- joinToTargets'         :: (FR freeRegs, Instruction instr)-        => BlockMap RegSet              -- ^ maps the unique of the blockid to the set of vregs+        => 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.@@ -87,7 +89,7 @@          -- 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 live_set            = expectJust $ mapLookup dest block_live         let still_live uniq _   = uniq `elemUniqSet_Directly` live_set         let adjusted_assig      = filterUFM_Directly still_live assig @@ -104,7 +106,7 @@          Nothing           -> joinToTargets_first                         block_live new_blocks block_id instr dest dests-                        block_assig adjusted_assig to_free+                        block_assig adjusted_assig $ map realReg to_free           Just (_, dest_assig)           -> joinToTargets_again@@ -114,7 +116,7 @@  -- this is the first time we jumped to this block. joinToTargets_first :: (FR freeRegs, Instruction instr)-                    => BlockMap RegSet+                    => BlockMap (UniqSet RegWithFormat)                     -> [NatBasicBlock instr]                     -> BlockId                     -> instr@@ -143,7 +145,7 @@  -- we've jumped to this block before joinToTargets_again :: (Instruction instr, FR freeRegs)-                    => BlockMap RegSet+                    => BlockMap (UniqSet RegWithFormat)                     -> [NatBasicBlock instr]                     -> BlockId                     -> instr@@ -197,8 +199,7 @@                         (return ())                 -}                 delta           <- getDeltaR-                fixUpInstrs_    <- mapM (handleComponent delta instr) sccs-                let fixUpInstrs = concat fixUpInstrs_+                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,@@ -326,15 +327,15 @@ --      require a fixup. -- handleComponent delta instr-        (CyclicSCC ((DigraphNode vreg (InReg sreg) ((InReg dreg: _))) : rest))+        (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 (RegReal sreg) vreg+                        <- spillR (RegWithFormat (RegReal sreg) scls) vreg          -- reload into destination reg-        instrLoad       <- loadR (RegReal dreg) slot+        instrLoad       <- loadR (RegWithFormat (RegReal dreg) dcls) slot          remainingFixUps <- mapM (handleComponent delta instr)                                 (stronglyConnCompFromEdgedVerticesOrdR rest)@@ -359,22 +360,19 @@  makeMove delta vreg src dst  = do config <- getConfig-      let platform = ncgPlatform config-       case (src, dst) of-          (InReg s, InReg d) ->+          (InReg (RealRegUsage s _), InReg (RealRegUsage d fmt)) ->               do recordSpill (SpillJoinRR vreg)-                 return $ [mkRegRegMoveInstr platform (RegReal s) (RegReal d)]-          (InMem s, InReg d) ->+                 return $ [mkRegRegMoveInstr config fmt (RegReal s) (RegReal d)]+          (InMem s, InReg (RealRegUsage d cls)) ->               do recordSpill (SpillJoinRM vreg)-                 return $ mkLoadInstr config (RegReal d) delta s-          (InReg s, InMem d) ->+                 return $ mkLoadInstr config (RegWithFormat (RegReal d) cls) delta s+          (InReg (RealRegUsage s cls), InMem d) ->               do recordSpill (SpillJoinRM vreg)-                 return $ mkSpillInstr config (RegReal s) delta d+                 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.-              panic ("makeMove " ++ show vreg ++ " (" ++ show src ++ ") ("-                  ++ show dst ++ ")"-                  ++ " we don't handle mem->mem moves.")+              pprPanic "makeMove: we don't handle mem->mem moves"+                 (ppr vreg <+> parens (ppr src) <+> parens (ppr dst))
+ GHC/CmmToAsm/Reg/Linear/LA64.hs view
@@ -0,0 +1,71 @@+module GHC.CmmToAsm.Reg.Linear.LA64 where++import GHC.Prelude++import Data.Word+import GHC.CmmToAsm.LA64.Regs+import GHC.Platform+import GHC.Platform.Reg+import GHC.Platform.Reg.Class+import GHC.Platform.Reg.Class.Separate+import GHC.Stack+import GHC.Utils.Outputable+import GHC.Utils.Panic++data FreeRegs = FreeRegs !Word32 !Word32++noFreeRegs :: FreeRegs+noFreeRegs = FreeRegs 0 0++instance Show FreeRegs where+  show (FreeRegs g f) = "FreeRegs 0b" ++ showBits g ++ " 0b" ++ showBits f++-- | Show bits as a `String` of @1@s and @0@s+showBits :: Word32 -> String+showBits w = map (\i -> if testBit w i then '1' else '0') [0 .. 31]++instance Outputable FreeRegs where+  ppr (FreeRegs g f) =+         text "   " <+> foldr (\i x -> pad_int i <+> x) (text "") [0 .. 31]+      $$ text "GPR" <+> foldr (\i x -> show_bit g i <+> x) (text "") [0 .. 31]+      $$ text "FPR" <+> foldr (\i x -> show_bit f i <+> x) (text "") [0 .. 31]+    where+      pad_int i | i < 10 = char ' ' <> int i+      pad_int i = int i+      -- remember bit = 1 means it's available.+      show_bit bits bit | testBit bits bit = text "  "+      show_bit _ _ = text " x"++-- | Set bits of all allocatable registers to 1+initFreeRegs :: Platform -> FreeRegs+initFreeRegs platform = foldl' (flip releaseReg) noFreeRegs (allocatableRegs platform)++-- | Get all free `RealReg`s (i.e. those where the corresponding bit is 1)+getFreeRegs :: RegClass -> FreeRegs -> [RealReg]+getFreeRegs cls (FreeRegs g f)+  | RcInteger <- cls = go 0 g allocatableIntRegs+  | RcFloat   <- cls = go 32 f allocatableDoubleRegs+  | RcVector  <- cls = sorry "Linear.LA64.getFreeRegs: vector registers are not supported"+  where+    go _ _ [] = []+    go off x (i : is)+      | testBit x i = RealRegSingle (off + i) : (go off x $! is)+      | otherwise = go off x $! is+    allocatableIntRegs = [4 .. 11] ++ [12 .. 19]+    allocatableDoubleRegs = [0 .. 7] ++ [8 .. 23]++-- | Set corresponding register bit to 0+allocateReg :: (HasCallStack) => RealReg -> FreeRegs -> FreeRegs+allocateReg (RealRegSingle r) (FreeRegs g f)+  | r > 31 && testBit f (r - 32) = FreeRegs g (clearBit f (r - 32))+  | r < 32 && testBit g r = FreeRegs (clearBit g r) f+  | r > 31 = panic $ "Linear.LA64.allocReg: double allocation of float reg v" ++ show (r - 32) ++ "; " ++ showBits f+  | otherwise = pprPanic "Linear.LA64.allocReg" $ text ("double allocation of gp reg x" ++ show r ++ "; " ++ showBits g)++-- | Set corresponding register bit to 1+releaseReg :: (HasCallStack) => RealReg -> FreeRegs -> FreeRegs+releaseReg (RealRegSingle r) (FreeRegs g f)+  | r > 31 && testBit f (r - 32) = pprPanic "Linear.LA64.releaseReg" (text "can't release non-allocated reg v" <> int (r - 32))+  | r < 32 && testBit g r = pprPanic "Linear.LA64.releaseReg" (text "can't release non-allocated reg x" <> int r)+  | r > 31 = FreeRegs g (setBit f (r - 32))+  | otherwise = FreeRegs (setBit g r) f
GHC/CmmToAsm/Reg/Linear/PPC.hs view
@@ -4,7 +4,7 @@ import GHC.Prelude  import GHC.CmmToAsm.PPC.Regs-import GHC.Platform.Reg.Class+import GHC.Platform.Reg.Class.Unified import GHC.Platform.Reg  import GHC.Utils.Outputable@@ -41,10 +41,10 @@ initFreeRegs platform = foldl' (flip releaseReg) noFreeRegs (allocatableRegs platform)  getFreeRegs :: RegClass -> FreeRegs -> [RealReg]        -- lazily-getFreeRegs cls (FreeRegs g f)-    | RcFloat <- cls = [] -- no float regs on PowerPC, use double-    | RcDouble <- cls = go f (0x80000000) 63-    | RcInteger <- cls = go g (0x80000000) 31+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)
+ GHC/CmmToAsm/Reg/Linear/RV64.hs view
@@ -0,0 +1,99 @@+-- | Functions to implement the @FR@ (as in "free regs") type class.+--+-- For LLVM GHC calling convention (used registers), see+-- https://github.com/llvm/llvm-project/blob/6ab900f8746e7d8e24afafb5886a40801f6799f4/llvm/lib/Target/RISCV/RISCVISelLowering.cpp#L13638-L13685+module GHC.CmmToAsm.Reg.Linear.RV64+  ( allocateReg,+    getFreeRegs,+    initFreeRegs,+    releaseReg,+    FreeRegs (..),+  )+where++import Data.Word+import GHC.CmmToAsm.RV64.Regs+import GHC.Platform+import GHC.Platform.Reg+import GHC.Platform.Reg.Class.Separate+import GHC.Prelude+import GHC.Stack+import GHC.Utils.Outputable+import GHC.Utils.Panic++-- | Bitmaps to indicate which registers are free (currently unused)+--+-- The bit index represents the `RegNo`, in case of floating point registers+-- with an offset of 32. The register is free when the bit is set.+data FreeRegs+  = FreeRegs+      -- | integer/general purpose registers (`RcInteger`)+      !Word32+      -- | floating point registers (`RcDouble`)+      !Word32++instance Show FreeRegs where+  show (FreeRegs g f) = "FreeRegs 0b" ++ showBits g ++ " 0b" ++ showBits f++-- | Show bits as a `String` of @1@s and @0@s+showBits :: Word32 -> String+showBits w = map (\i -> if testBit w i then '1' else '0') [0 .. 31]++instance Outputable FreeRegs where+  ppr (FreeRegs g f) =+    text "   "+      <+> foldr (\i x -> pad_int i <+> x) (text "") [0 .. 31]+      $$ text "GPR"+      <+> foldr (\i x -> show_bit g i <+> x) (text "") [0 .. 31]+      $$ text "FPR"+      <+> foldr (\i x -> show_bit f i <+> x) (text "") [0 .. 31]+    where+      pad_int i | i < 10 = char ' ' <> int i+      pad_int i = int i+      -- remember bit = 1 means it's available.+      show_bit bits bit | testBit bits bit = text "  "+      show_bit _ _ = text " x"++-- | Set bits of all allocatable registers to 1+initFreeRegs :: Platform -> FreeRegs+initFreeRegs platform = foldl' (flip releaseReg) noFreeRegs (allocatableRegs platform)+  where+    noFreeRegs :: FreeRegs+    noFreeRegs = FreeRegs 0 0++-- | Get all free `RealReg`s (i.e. those where the corresponding bit is 1)+getFreeRegs :: RegClass -> FreeRegs -> [RealReg]+getFreeRegs cls (FreeRegs g f) =+  case cls of+    RcInteger -> go 0 g allocatableIntRegs+    RcFloat -> go 32 f allocatableDoubleRegs+    RcVector ->+      sorry "Linear.RV64.getFreeRegs: vector registers are not supported"++  where+    go _ _ [] = []+    go off x (i : is)+      | testBit x i = RealRegSingle (off + i) : (go off x $! is)+      | otherwise = go off x $! is+    -- The lists of allocatable registers are manually crafted: Register+    -- allocation is pretty hot code. We don't want to iterate and map like+    -- `initFreeRegs` all the time! (The register mappings aren't supposed to+    -- change often.)+    allocatableIntRegs = [5 .. 7] ++ [10 .. 17] ++ [28 .. 30]+    allocatableDoubleRegs = [0 .. 7] ++ [10 .. 17] ++ [28 .. 31]++-- | Set corresponding register bit to 0+allocateReg :: (HasCallStack) => RealReg -> FreeRegs -> FreeRegs+allocateReg (RealRegSingle r) (FreeRegs g f)+  | r > 31 && testBit f (r - 32) = FreeRegs g (clearBit f (r - 32))+  | r < 32 && testBit g r = FreeRegs (clearBit g r) f+  | r > 31 = panic $ "Linear.RV64.allocReg: double allocation of float reg v" ++ show (r - 32) ++ "; " ++ showBits f+  | otherwise = pprPanic "Linear.RV64.allocReg" $ text ("double allocation of gp reg x" ++ show r ++ "; " ++ showBits g)++-- | Set corresponding register bit to 1+releaseReg :: (HasCallStack) => RealReg -> FreeRegs -> FreeRegs+releaseReg (RealRegSingle r) (FreeRegs g f)+  | r > 31 && testBit f (r - 32) = pprPanic "Linear.RV64.releaseReg" (text "can't release non-allocated reg v" <> int (r - 32))+  | r < 32 && testBit g r = pprPanic "Linear.RV64.releaseReg" (text "can't release non-allocated reg x" <> int r)+  | r > 31 = FreeRegs g (setBit f (r - 32))+  | otherwise = FreeRegs (setBit g r) f
GHC/CmmToAsm/Reg/Linear/StackMap.hs view
@@ -24,6 +24,7 @@  import GHC.Types.Unique.FM import GHC.Types.Unique+import GHC.CmmToAsm.Format   -- | Identifier for a stack slot.@@ -47,13 +48,16 @@ -- | 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 :: StackMap -> Format -> Unique -> (StackMap, Int) -getStackSlotFor fs@(StackMap _ reserved) reg-  | Just slot <- lookupUFM reserved reg  =  (fs, slot)+getStackSlotFor fs@(StackMap _ reserved) _fmt regUnique+  | Just slot <- lookupUFM reserved regUnique  =  (fs, slot) -getStackSlotFor (StackMap freeSlot reserved) reg =-    (StackMap (freeSlot+1) (addToUFM reserved reg freeSlot), freeSlot)+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
GHC/CmmToAsm/Reg/Linear/State.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE PatternSynonyms, DeriveFunctor #-}+{-# LANGUAGE PatternSynonyms, DeriveFunctor, DerivingVia #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UnboxedTuples #-} @@ -42,41 +42,34 @@ 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.Platform.Reg import GHC.Cmm.BlockId  import GHC.Platform import GHC.Types.Unique-import GHC.Types.Unique.Supply+import GHC.Types.Unique.DSM import GHC.Exts (oneShot) -import Control.Monad (ap)+import GHC.Utils.Monad.State.Strict as Strict -type RA_Result freeRegs a = (# RA_State freeRegs, a #)+type RA_Result freeRegs a = (# a, RA_State freeRegs #) -pattern RA_Result :: a -> b -> (# a, b #)-pattern RA_Result a b = (# a, b #)+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)+        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) -instance Applicative (RegM freeRegs) where-      pure a  =  mkRegM $ \s -> RA_Result s a-      (<*>) = ap--instance Monad (RegM freeRegs) where-  m >>= k   =  mkRegM $ \s -> case unReg m s of { RA_Result s a -> unReg (k a) s }- -- | Get native code generator configuration getConfig :: RegM a NCGConfig getConfig = mkRegM $ \s -> RA_Result s (ra_config s)@@ -91,9 +84,9 @@         -> freeRegs         -> RegMap Loc         -> StackMap-        -> UniqSupply+        -> DUniqSupply         -> RegM freeRegs a-        -> (BlockAssignment freeRegs, StackMap, RegAllocStats, a)+        -> (BlockAssignment freeRegs, StackMap, RegAllocStats, a, DUniqSupply)  runR config block_assig freeregs assig stack us thing =   case unReg thing@@ -109,7 +102,7 @@                 , ra_fixups     = [] })    of         RA_Result state returned_thing-         ->     (ra_blockassig state, ra_stack state, makeRAStats state, returned_thing)+         ->  (ra_blockassig state, ra_stack state, makeRAStats state, returned_thing, ra_us state)   -- | Make register allocator stats from its final state.@@ -121,17 +114,17 @@   spillR :: Instruction instr-       => Reg -> Unique -> RegM freeRegs ([instr], Int)+       => RegWithFormat -> Unique -> RegM freeRegs ([instr], Int)  spillR reg temp = mkRegM $ \s ->-  let (stack1,slot) = getStackSlotFor (ra_stack s) temp-      instr  = mkSpillInstr (ra_config s) reg (ra_delta s) slot+  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,slot)+  RA_Result s{ra_stack=stack1} (instr,slots)   loadR :: Instruction instr-      => Reg -> Int -> RegM freeRegs [instr]+      => RegWithFormat -> Int -> RegM freeRegs [instr]  loadR reg slot = mkRegM $ \s ->   RA_Result s (mkLoadInstr (ra_config s) reg (ra_delta s) slot)@@ -169,7 +162,7 @@  getUniqueR :: RegM freeRegs Unique getUniqueR = mkRegM $ \s ->-  case takeUniqFromSupply (ra_us s) of+  case takeUniqueFromDSupply (ra_us s) of     (uniq, us) -> RA_Result s{ra_us = us} uniq
GHC/CmmToAsm/Reg/Linear/Stats.hs view
@@ -18,6 +18,7 @@  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@@ -38,9 +39,10 @@ -- | Count reg-reg moves remaining in this code. countRegRegMovesNat         :: Instruction instr-        => NatCmmDecl statics instr -> Int+        => Platform+        -> NatCmmDecl statics instr -> Int -countRegRegMovesNat cmm+countRegRegMovesNat platform cmm         = execState (mapGenBlockTopM countBlock cmm) 0  where         countBlock b@(BasicBlock _ instrs)@@ -48,7 +50,7 @@                 return  b          countInstr instr-                | Just _        <- takeRegRegMoveInstr instr+                | Just _        <- takeRegRegMoveInstr platform instr                 = do    modify (+ 1)                         return instr @@ -59,9 +61,9 @@ -- | Pretty print some RegAllocStats pprStats         :: Instruction instr-        => [NatCmmDecl statics instr] -> [RegAllocStats] -> SDoc+        => Platform -> [NatCmmDecl statics instr] -> [RegAllocStats] -> SDoc -pprStats code statss+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]@@ -75,7 +77,7 @@                         -- See Note [Unique Determinism and code generation]          -- count how many reg-reg-moves remain in the code-        moves           = sum $ map countRegRegMovesNat code+        moves           = sum $ map (countRegRegMovesNat platform) code          pprSpill (reg, spills)                 = parens $ (hcat $ punctuate (text ", ")  (doubleQuotes (ppr reg) : map ppr spills))
GHC/CmmToAsm/Reg/Linear/X86.hs view
@@ -6,7 +6,7 @@ import GHC.Prelude  import GHC.CmmToAsm.X86.Regs-import GHC.Platform.Reg.Class+import GHC.Platform.Reg.Class.Unified import GHC.Platform.Reg import GHC.Platform import GHC.Utils.Outputable@@ -21,26 +21,27 @@  releaseReg :: RealReg -> FreeRegs -> FreeRegs releaseReg (RealRegSingle n) (FreeRegs f)-        = FreeRegs (f .|. (1 `shiftL` n))+        = 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) = 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.+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 (f .&. complement (1 `shiftL` r))+        = FreeRegs (clearBit f r)
GHC/CmmToAsm/Reg/Linear/X86_64.hs view
@@ -6,7 +6,7 @@ import GHC.Prelude  import GHC.CmmToAsm.X86.Regs-import GHC.Platform.Reg.Class+import GHC.Platform.Reg.Class.Unified import GHC.Platform.Reg import GHC.Platform import GHC.Utils.Outputable@@ -21,26 +21,27 @@  releaseReg :: RealReg -> FreeRegs -> FreeRegs releaseReg (RealRegSingle n) (FreeRegs f)-        = FreeRegs (f .|. (1 `shiftL` n))+        = 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) = 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.+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 (f .&. complement (1 `shiftL` r))+        = FreeRegs (clearBit f r)
GHC/CmmToAsm/Reg/Liveness.hs view
@@ -1,14 +1,5 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-} --{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}- ----------------------------------------------------------------------------- -- -- The register liveness determinator@@ -18,9 +9,8 @@ -----------------------------------------------------------------------------  module GHC.CmmToAsm.Reg.Liveness (-        RegSet,         RegMap, emptyRegMap,-        BlockMap, mapEmpty,+        BlockMap,         LiveCmmDecl,         InstrSR   (..),         LiveInstr (..),@@ -48,31 +38,33 @@ 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.Collections import GHC.Cmm.Dataflow.Label-import GHC.Cmm hiding (RegSet, emptyRegSet)+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.Supply+import GHC.Types.Unique.DSM import GHC.Data.Bag import GHC.Utils.Monad.State.Strict -import Data.List (mapAccumL, groupBy, partition)+import Data.List (mapAccumL, sortOn) import Data.Maybe import Data.IntSet              (IntSet)+import GHC.Utils.Misc  ------------------------------------------------------------------------------type RegSet = UniqSet Reg  -- | Map from some kind of register to a. --@@ -84,9 +76,6 @@ emptyRegMap :: RegMap a emptyRegMap = emptyUFM -emptyRegSet :: RegSet-emptyRegSet = emptyUniqSet- type BlockMap a = LabelMap a  type SlotMap a = UniqFM Slot a@@ -105,34 +94,42 @@ --   so we'll keep those here. data InstrSR instr         -- | A real machine instruction-        = Instr  instr+        = Instr  !instr          -- | spill this reg to a stack slot-        | SPILL  Reg Int+        | SPILL  !RegWithFormat !Int          -- | reload this reg from a stack slot-        | RELOAD Int Reg+        | 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]+                Instr  instr  -> regUsageOfInstr platform instr+                SPILL  reg _  -> RU [reg] []+                RELOAD _ reg  -> RU [] [reg] -        patchRegsOfInstr i f+        patchRegsOfInstr platform 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)+                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@@ -156,12 +153,12 @@                 Instr instr     -> isMetaInstr instr                 _               -> False -        mkRegRegMoveInstr platform r1 r2-            = Instr (mkRegRegMoveInstr platform r1 r2)+        mkRegRegMoveInstr platform fmt r1 r2+            = Instr (mkRegRegMoveInstr platform fmt r1 r2) -        takeRegRegMoveInstr i+        takeRegRegMoveInstr platform i          = case i of-                Instr instr     -> takeRegRegMoveInstr instr+                Instr instr     -> takeRegRegMoveInstr platform instr                 _               -> Nothing          mkJumpInstr target      = map Instr (mkJumpInstr target)@@ -191,9 +188,9 @@  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.+        { 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.@@ -202,7 +199,7 @@                 (LabelMap RawCmmStatics)  -- cmm info table static stuff                 [BlockId]                 -- entry points (first one is the                                           -- entry point for the proc).-                (BlockMap RegSet)         -- argument locals live on entry to this block+                (BlockMap (UniqSet RegWithFormat))         -- argument locals live on entry to this block                 (BlockMap IntSet)         -- stack slots live on entry to this block  @@ -217,7 +214,7 @@         ppr (Instr realInstr)            = ppr realInstr -        ppr (SPILL reg slot)+        ppr (SPILL (RegWithFormat reg _fmt) slot)            = hcat [                 text "\tSPILL",                 char ' ',@@ -225,7 +222,7 @@                 comma,                 text "SLOT" <> parens (int slot)] -        ppr (RELOAD slot reg)+        ppr (RELOAD slot (RegWithFormat reg _fmt))            = hcat [                 text "\tRELOAD",                 char ' ',@@ -248,7 +245,7 @@                         , pprRegs (text "# w_dying: ") (liveDieWrite live) ]                     $+$ space) -         where  pprRegs :: SDoc -> RegSet -> SDoc+         where  pprRegs :: SDoc -> UniqSet RegWithFormat -> SDoc                 pprRegs name regs                  | isEmptyUniqSet regs  = empty                  | otherwise            = name <>@@ -262,7 +259,7 @@         =  (pdoc env mb_static)         $$ text "# entryIds         = " <> ppr entryIds         $$ text "# liveVRegsOnEntry = " <> ppr liveVRegsOnEntry-        $$ text "# liveSlotsOnEntry = " <> text (show liveSlotsOnEntry)+        $$ text "# liveSlotsOnEntry = " <> ppr liveSlotsOnEntry   @@ -330,10 +327,11 @@ -- slurpConflicts         :: Instruction instr-        => LiveCmmDecl statics instr-        -> (Bag (UniqSet Reg), Bag (Reg, Reg))+        => Platform+        -> LiveCmmDecl statics instr+        -> (Bag (UniqSet RegWithFormat), Bag (Reg, Reg)) -slurpConflicts live+slurpConflicts platform live         = slurpCmm (emptyBag, emptyBag) live   where  slurpCmm   rs  CmmData{}                = rs@@ -383,7 +381,7 @@                 --                 rsConflicts     = unionUniqSets rsLiveNext rsOrphans -          in    case takeRegRegMoveInstr instr of+          in    case takeRegRegMoveInstr platform instr of                  Just rr        -> slurpLIs rsLiveNext                                         ( consBag rsConflicts conflicts                                         , consBag rr moves) lis@@ -460,12 +458,12 @@         slurpLI slotMap li                  -- remember what reg was stored into the slot-                | LiveInstr (SPILL reg slot) _  <- li-                , slotMap'                      <- addToUFM slotMap slot reg+                | 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 reg) _ <- li+                | LiveInstr (RELOAD slot (RegWithFormat reg _fmt)) _ <- li                 = case lookupUFM slotMap slot of                         Just reg2                          | reg /= reg2  -> return (slotMap, Just (reg, reg2))@@ -529,11 +527,10 @@                 -- 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+                final_blocks' = sortOn ((/= first_id) . blockId) final_blocks -           in   CmmProc info label live-                          (ListGraph $ map (stripLiveBlock config) $ first' : rest')+           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@@ -611,11 +608,12 @@ --   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)+        :: (Instruction instr, HasDebugCallStack)+        => Platform+        -> (Reg -> Reg)         -> LiveCmmDecl statics instr -> LiveCmmDecl statics instr -patchEraseLive patchF cmm+patchEraseLive platform patchF cmm         = patchCmm cmm  where         patchCmm cmm@CmmData{}  = cmm@@ -623,9 +621,8 @@         patchCmm (CmmProc info label live sccs)          | LiveInfo static id blockMap mLiveSlots <- info          = let-                patchRegSet set = mkUniqSet $ map patchF $ nonDetEltsUFM set                   -- See Note [Unique Determinism and code generation]-                blockMap'       = mapMap (patchRegSet . getUniqSet) blockMap+                blockMap'       = mapMap (mapRegFormatSet patchF) blockMap                  info'           = LiveInfo static id blockMap' mLiveSlots            in   CmmProc info' label live $ map patchSCC sccs@@ -640,22 +637,22 @@         patchInstrs (li : lis)                  | LiveInstr i (Just live)       <- li'-                , Just (r1, r2) <- takeRegRegMoveInstr i+                , Just (r1, r2) <- takeRegRegMoveInstr platform i                 , eatMe r1 r2 live                 = patchInstrs lis                  | otherwise                 = li' : patchInstrs lis -                where   li'     = patchRegsLiveInstr patchF li+                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-                | elementOfUniqSet r2 (liveBorn live)-                , elementOfUniqSet r2 (liveDieRead live) || elementOfUniqSet r2 (liveDieWrite live)+                | elemUniqSet_Directly (getUnique r2) (liveBorn live)+                , elemUniqSet_Directly (getUnique r2) (liveDieRead live) || elemUniqSet_Directly (getUnique r2) (liveDieWrite live)                 = True                  | otherwise     = False@@ -664,26 +661,26 @@ -- | Patch registers in this LiveInstr, including the liveness information. -- patchRegsLiveInstr-        :: Instruction instr-        => (Reg -> Reg)+        :: (Instruction instr, HasDebugCallStack)+        => Platform+        -> (Reg -> Reg)         -> LiveInstr instr -> LiveInstr instr -patchRegsLiveInstr patchF li+patchRegsLiveInstr platform patchF li  = case li of         LiveInstr instr Nothing-         -> LiveInstr (patchRegsOfInstr instr patchF) Nothing+         -> LiveInstr (patchRegsOfInstr platform instr patchF) Nothing          LiveInstr instr (Just live)          -> LiveInstr-                (patchRegsOfInstr instr patchF)+                (patchRegsOfInstr platform 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 })+                          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 @@ -692,7 +689,7 @@         => Maybe CFG         -> Platform         -> NatCmmDecl statics instr-        -> UniqSM (LiveCmmDecl statics instr)+        -> UniqDSM (LiveCmmDecl statics instr) cmmTopLiveness cfg platform cmm         = regLiveness platform $ natCmmTopToLive cfg cmm @@ -786,7 +783,7 @@         :: Instruction instr         => Platform         -> LiveCmmDecl statics instr-        -> UniqSM (LiveCmmDecl statics instr)+        -> UniqDSM (LiveCmmDecl statics instr)  regLiveness _ (CmmData i d)         = return $ CmmData i d@@ -871,7 +868,7 @@         -> [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+               BlockMap (UniqSet RegWithFormat))                 -- blocks annotated with set of live registers                                                 -- on entry to the block.  computeLiveness platform sccs@@ -886,11 +883,11 @@ livenessSCCs        :: Instruction instr        => Platform-       -> BlockMap RegSet+       -> BlockMap (UniqSet RegWithFormat)        -> [SCC (LiveBasicBlock instr)]          -- accum        -> [SCC (LiveBasicBlock instr)]        -> ( [SCC (LiveBasicBlock instr)]-          , BlockMap RegSet)+          , BlockMap (UniqSet RegWithFormat))  livenessSCCs _ blockmap done []         = (done, blockmap)@@ -911,18 +908,16 @@                 -> 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")-+            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 RegSet -> [LiveBasicBlock instr]-                -> (BlockMap RegSet, [LiveBasicBlock instr])+                => BlockMap (UniqSet RegWithFormat) -> [LiveBasicBlock instr]+                -> (BlockMap (UniqSet RegWithFormat), [LiveBasicBlock instr])              linearLiveness = mapAccumL (livenessBlock platform) @@ -930,9 +925,8 @@                 -- 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)+              where a' = mapToList a+                    b' = mapToList b                     -- See Note [Unique Determinism and code generation]  @@ -942,9 +936,9 @@ livenessBlock         :: Instruction instr         => Platform-        -> BlockMap RegSet+        -> BlockMap (UniqSet RegWithFormat)         -> LiveBasicBlock instr-        -> (BlockMap RegSet, LiveBasicBlock instr)+        -> (BlockMap (UniqSet RegWithFormat), LiveBasicBlock instr)  livenessBlock platform blockmap (BasicBlock block_id instrs)  = let@@ -964,7 +958,7 @@ livenessForward         :: Instruction instr         => Platform-        -> RegSet                       -- regs live on this instr+        -> UniqSet RegWithFormat -- regs live on this instr         -> [LiveInstr instr] -> [LiveInstr instr]  livenessForward _        _           []  = []@@ -975,7 +969,8 @@                 -- 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+                                $ filter (\ r -> not $ elemUniqSet_Directly (getUnique r) rsLiveEntry)+                                $ written                  rsLiveNext      = (rsLiveEntry `unionUniqSets` rsBorn)                                         `minusUniqSet` (liveDieRead live)@@ -994,16 +989,16 @@ livenessBack         :: Instruction instr         => Platform-        -> RegSet                       -- regs live on this instr-        -> BlockMap RegSet              -- regs live on entry to other BBs+        -> UniqSet RegWithFormat            -- regs live on this instr+        -> BlockMap (UniqSet RegWithFormat) -- regs live on entry to other BBs         -> [LiveInstr instr]            -- instructions (accum)         -> [LiveInstr instr]            -- instructions-        -> (RegSet, [LiveInstr instr])+        -> (UniqSet RegWithFormat, [LiveInstr instr])  livenessBack _        liveregs _        done []  = (liveregs, done)  livenessBack platform liveregs blockmap acc (instr : instrs)- = let  (liveregs', instr')     = liveness1 platform liveregs blockmap instr+ = let  !(!liveregs', instr')     = liveness1 platform liveregs blockmap instr    in   livenessBack platform liveregs' blockmap (instr' : acc) instrs  @@ -1011,10 +1006,10 @@ liveness1         :: Instruction instr         => Platform-        -> RegSet-        -> BlockMap RegSet+        -> UniqSet RegWithFormat+        -> BlockMap (UniqSet RegWithFormat)         -> LiveInstr instr-        -> (RegSet, LiveInstr instr)+        -> (UniqSet RegWithFormat, LiveInstr instr)  liveness1 _ liveregs _ (LiveInstr instr _)         | isMetaInstr instr@@ -1026,15 +1021,15 @@         = (liveregs1, LiveInstr instr                         (Just $ Liveness                         { liveBorn      = emptyUniqSet-                        , liveDieRead   = mkUniqSet r_dying-                        , liveDieWrite  = mkUniqSet w_dying }))+                        , liveDieRead   = r_dying+                        , liveDieWrite  = w_dying }))          | otherwise         = (liveregs_br, LiveInstr instr                         (Just $ Liveness                         { liveBorn      = emptyUniqSet-                        , liveDieRead   = mkUniqSet r_dying_br-                        , liveDieWrite  = mkUniqSet w_dying }))+                        , liveDieRead   = r_dying_br+                        , liveDieWrite  = w_dying }))          where             !(RU read written) = regUsageOfInstr platform instr@@ -1046,11 +1041,16 @@              -- 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) ]+            r_dying     = mkUniqSet+                          [ reg+                          | reg@(RegWithFormat r _) <- read+                          , not $ any (\ w -> getUnique w == getUnique r) written+                          , not (elementOfUniqSet reg liveregs) ] -            w_dying     = [ reg | reg <- 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.@@ -1060,7 +1060,7 @@             targetLiveRegs target                   = case mapLookup target blockmap of                                 Just ra -> ra-                                Nothing -> emptyRegSet+                                Nothing -> emptyUniqSet              live_from_branch = unionManyUniqSets (map targetLiveRegs targets) @@ -1069,6 +1069,5 @@             -- 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)+            r_dying_br  = (r_dying `unionUniqSets` live_branch_only)                           -- See Note [Unique Determinism and code generation]
GHC/CmmToAsm/Reg/Target.hs view
@@ -14,7 +14,8 @@         targetClassOfRealReg,         targetMkVirtualReg,         targetRegDotColor,-        targetClassOfReg+        targetClassOfReg,+        mapRegFormatSet, )  where@@ -26,15 +27,18 @@ 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@@ -49,8 +53,10 @@       ArchAlpha     -> panic "targetVirtualRegSqueeze ArchAlpha"       ArchMipseb    -> panic "targetVirtualRegSqueeze ArchMipseb"       ArchMipsel    -> panic "targetVirtualRegSqueeze ArchMipsel"-      ArchRISCV64   -> panic "targetVirtualRegSqueeze ArchRISCV64"+      ArchRISCV64   -> RV64.virtualRegSqueeze+      ArchLoongArch64 -> LA64.virtualRegSqueeze       ArchJavaScript-> panic "targetVirtualRegSqueeze ArchJavaScript"+      ArchWasm32    -> panic "targetVirtualRegSqueeze ArchWasm32"       ArchUnknown   -> panic "targetVirtualRegSqueeze ArchUnknown"  @@ -67,8 +73,10 @@       ArchAlpha     -> panic "targetRealRegSqueeze ArchAlpha"       ArchMipseb    -> panic "targetRealRegSqueeze ArchMipseb"       ArchMipsel    -> panic "targetRealRegSqueeze ArchMipsel"-      ArchRISCV64   -> panic "targetRealRegSqueeze ArchRISCV64"+      ArchRISCV64   -> RV64.realRegSqueeze+      ArchLoongArch64 -> LA64.realRegSqueeze       ArchJavaScript-> panic "targetRealRegSqueeze ArchJavaScript"+      ArchWasm32    -> panic "targetRealRegSqueeze ArchWasm32"       ArchUnknown   -> panic "targetRealRegSqueeze ArchUnknown"  targetClassOfRealReg :: Platform -> RealReg -> RegClass@@ -84,8 +92,10 @@       ArchAlpha     -> panic "targetClassOfRealReg ArchAlpha"       ArchMipseb    -> panic "targetClassOfRealReg ArchMipseb"       ArchMipsel    -> panic "targetClassOfRealReg ArchMipsel"-      ArchRISCV64   -> panic "targetClassOfRealReg ArchRISCV64"+      ArchRISCV64   -> RV64.classOfRealReg+      ArchLoongArch64 -> LA64.classOfRealReg       ArchJavaScript-> panic "targetClassOfRealReg ArchJavaScript"+      ArchWasm32    -> panic "targetClassOfRealReg ArchWasm32"       ArchUnknown   -> panic "targetClassOfRealReg ArchUnknown"  targetMkVirtualReg :: Platform -> Unique -> Format -> VirtualReg@@ -101,8 +111,10 @@       ArchAlpha     -> panic "targetMkVirtualReg ArchAlpha"       ArchMipseb    -> panic "targetMkVirtualReg ArchMipseb"       ArchMipsel    -> panic "targetMkVirtualReg ArchMipsel"-      ArchRISCV64   -> panic "targetMkVirtualReg ArchRISCV64"+      ArchRISCV64   -> RV64.mkVirtualReg+      ArchLoongArch64 -> LA64.mkVirtualReg       ArchJavaScript-> panic "targetMkVirtualReg ArchJavaScript"+      ArchWasm32    -> panic "targetMkVirtualReg ArchWasm32"       ArchUnknown   -> panic "targetMkVirtualReg ArchUnknown"  targetRegDotColor :: Platform -> RealReg -> SDoc@@ -118,13 +130,18 @@       ArchAlpha     -> panic "targetRegDotColor ArchAlpha"       ArchMipseb    -> panic "targetRegDotColor ArchMipseb"       ArchMipsel    -> panic "targetRegDotColor ArchMipsel"-      ArchRISCV64   -> panic "targetRegDotColor ArchRISCV64"+      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 vr+   RegVirtual vr -> classOfVirtualReg (platformArch platform) vr    RegReal rr -> targetClassOfRealReg platform rr++mapRegFormatSet :: HasDebugCallStack => (Reg -> Reg) -> UniqSet RegWithFormat -> UniqSet RegWithFormat+mapRegFormatSet f = mapUniqSet (\ ( RegWithFormat r fmt ) -> RegWithFormat ( f r ) fmt)
GHC/CmmToAsm/Utils.hs view
@@ -7,7 +7,6 @@ import GHC.Prelude  import GHC.Cmm.BlockId-import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Label import GHC.Cmm hiding (topInfoTable)
+ GHC/CmmToAsm/Wasm.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE Strict #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++module GHC.CmmToAsm.Wasm (ncgWasm) where++import Data.ByteString.Builder+import Data.ByteString.Lazy.Char8 (unpack)+import Data.Maybe+import Data.Semigroup+import GHC.Cmm+import GHC.Cmm.ContFlowOpt+import GHC.Cmm.GenericOpt+import GHC.CmmToAsm.Config+import GHC.CmmToAsm.Wasm.Asm+import GHC.CmmToAsm.Wasm.FromCmm+import GHC.CmmToAsm.Wasm.Types+import GHC.StgToCmm.CgUtils (CgStream)+import GHC.Data.Stream (StreamS (..), runStream, liftIO)+import GHC.Driver.DynFlags+import GHC.Platform+import GHC.Prelude+import GHC.Settings+import GHC.Types.Unique.DSM+import GHC.Unit+import GHC.Utils.Logger+import GHC.Utils.Outputable (text)+import System.IO++ncgWasm ::+  NCGConfig ->+  Logger ->+  Platform ->+  ToolSettings ->+  ModLocation ->+  Handle ->+  CgStream RawCmmGroup a ->+  UniqDSMT IO a+ncgWasm ncg_config logger platform ts loc h cmms = do+  (r, s) <- streamCmmGroups ncg_config platform cmms+  outputWasm $ "# " <> string7 (fromJust $ ml_hs_file loc) <> "\n\n"+  -- See Note [WasmTailCall]+  let cfg = (defaultWasmAsmConfig s) { pic = ncgPIC ncg_config, tailcall = doTailCall ts }+  outputWasm $ execWasmAsmM cfg $ asmTellEverything TagI32 s+  pure r+  where+    outputWasm builder = liftIO $ do+      putDumpFileMaybe+        logger+        Opt_D_dump_asm+        "Asm Code"+        FormatASM+        (text . unpack $ toLazyByteString builder)+      hPutBuilder h builder++streamCmmGroups ::+  NCGConfig ->+  Platform ->+  CgStream RawCmmGroup a ->+  UniqDSMT IO (a, WasmCodeGenState 'I32)+streamCmmGroups ncg_config platform cmms = withDUS $ \us -> do+  (r,s) <- go (initialWasmCodeGenState platform us) $ runStream cmms+  return ((r,s), wasmDUniqSupply s)+  where+    go s (Done r) = pure (r, s)+    go s (Effect m) = do+      (a, us') <- runUDSMT (wasmDUniqSupply s) m+      go s{wasmDUniqSupply = us'} a+    go s (Yield decls k) = go (wasmExecM (onCmmGroup $ map opt decls) s) k+      where+        -- Run the generic cmm optimizations like other NCGs, followed+        -- by a late control-flow optimization pass that does shrink+        -- the CFG block count in some cases.+        opt decl = case decl of+          CmmData {} -> decl+          CmmProc {} -> CmmProc info lbl live $ cmmCfgOpts False graph+            where+              (CmmProc info lbl live graph, _) = cmmToCmm ncg_config decl++doTailCall :: ToolSettings -> Bool+doTailCall ts = Option "-mtail-call" `elem` as_args+  where+    (_, as_args) = toolSettings_pgm_a ts
+ GHC/CmmToAsm/Wasm/Asm.hs view
@@ -0,0 +1,569 @@+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE Strict #-}++module GHC.CmmToAsm.Wasm.Asm (asmTellEverything, execWasmAsmM) where++import Control.Monad+import Control.Monad.Trans.Reader+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import Data.ByteString.Builder+import qualified Data.ByteString.Char8 as BS8+import Data.Coerce+import Data.Foldable+import Data.Maybe+import Data.Semigroup+import GHC.Cmm+import GHC.CmmToAsm.Ppr+import GHC.CmmToAsm.Wasm.FromCmm+import GHC.CmmToAsm.Wasm.Types+import GHC.CmmToAsm.Wasm.Utils+import GHC.Data.FastString+import GHC.Float+import GHC.Prelude+import GHC.Settings.Config (cProjectVersion)+import GHC.Types.Basic+import GHC.Types.Unique+import GHC.Types.Unique.Map+import GHC.Types.Unique.Set+import GHC.Utils.Monad.State.Strict+import GHC.Utils.Outputable hiding ((<>))+import GHC.Utils.Panic (panic)++-- | Reads current indentation, appends result to state+newtype WasmAsmM a = WasmAsmM (WasmAsmConfig -> Builder -> State Builder a)+  deriving+    ( Functor,+      Applicative,+      Monad+    )+    via (ReaderT WasmAsmConfig (ReaderT Builder (State Builder)))++instance Semigroup a => Semigroup (WasmAsmM a) where+  (<>) = liftA2 (<>)++instance Monoid a => Monoid (WasmAsmM a) where+  mempty = pure mempty++getConf :: WasmAsmM WasmAsmConfig+getConf = WasmAsmM $ \conf _ -> pure conf++-- | Default indent level is none+execWasmAsmM :: WasmAsmConfig -> WasmAsmM a -> Builder+execWasmAsmM conf (WasmAsmM m) =+  execState (m conf mempty) mempty++-- | Increase indent level by a tab+asmWithTab :: WasmAsmM a -> WasmAsmM a+asmWithTab (WasmAsmM m) =+  WasmAsmM $ \conf t -> m conf $! char7 '\t' <> t++-- | Writes a single line starting with the current indent+asmTellLine :: Builder -> WasmAsmM ()+asmTellLine b = WasmAsmM $ \_ t -> modify $ \acc -> acc <> t <> b <> char7 '\n'++-- | Writes a single line break+asmTellLF :: WasmAsmM ()+asmTellLF = WasmAsmM $ \_ _ -> modify $ \acc -> acc <> char7 '\n'++-- | Writes a line starting with a single tab, ignoring current indent+-- level+asmTellTabLine :: Builder -> WasmAsmM ()+asmTellTabLine b =+  WasmAsmM $ \_ _ -> modify $ \acc -> acc <> char7 '\t' <> b <> char7 '\n'++asmFromWasmType :: WasmTypeTag t -> Builder+asmFromWasmType ty = case ty of+  TagI32 -> "i32"+  TagI64 -> "i64"+  TagF32 -> "f32"+  TagF64 -> "f64"++asmFromSomeWasmType :: SomeWasmType -> Builder+asmFromSomeWasmType (SomeWasmType t) = asmFromWasmType t++asmFromSomeWasmTypes :: [SomeWasmType] -> Builder+asmFromSomeWasmTypes ts = "(" <> builderCommas asmFromSomeWasmType ts <> ")"++asmFromFuncType :: [SomeWasmType] -> [SomeWasmType] -> Builder+asmFromFuncType arg_tys ret_tys =+  asmFromSomeWasmTypes arg_tys <> " -> " <> asmFromSomeWasmTypes ret_tys++asmTellFuncType ::+  SymName -> ([SomeWasmType], [SomeWasmType]) -> WasmAsmM ()+asmTellFuncType sym (arg_tys, ret_tys) =+  asmTellTabLine $+    ".functype "+      <> asmFromSymName sym+      <> " "+      <> asmFromFuncType arg_tys ret_tys++asmTellLocals :: [SomeWasmType] -> WasmAsmM ()+asmTellLocals [] = mempty+asmTellLocals local_tys =+  asmTellTabLine $ ".local " <> builderCommas asmFromSomeWasmType local_tys++asmFromSymName :: SymName -> Builder+asmFromSymName = shortByteString . coerce fastStringToShortByteString++asmTellDefSym :: SymName -> WasmAsmM ()+asmTellDefSym sym = do+  WasmAsmConfig {..} <- getConf+  unless pic $ asmTellTabLine $ ".hidden " <> asm_sym+  asmTellTabLine $ ".globl " <> asm_sym+  where+    asm_sym = asmFromSymName sym++asmTellDataSectionContent :: WasmTypeTag w -> DataSectionContent -> WasmAsmM ()+asmTellDataSectionContent ty_word c = asmTellTabLine $ case c of+  DataI8 i -> ".int8 0x" <> word8Hex i+  DataI16 i -> ".int16 0x" <> word16Hex i+  DataI32 i -> ".int32 0x" <> word32Hex i+  DataI64 i -> ".int64 0x" <> word64Hex i+  DataF32 f -> ".int32 0x" <> word32Hex (castFloatToWord32 f)+  DataF64 d -> ".int64 0x" <> word64Hex (castDoubleToWord64 d)+  DataSym sym o ->+    ( case ty_word of+        TagI32 -> ".int32 "+        TagI64 -> ".int64 "+        _ -> panic "asmTellDataSectionContent: unreachable"+    )+      <> asmFromSymName sym+      <> ( case compare o 0 of+             EQ -> mempty+             GT -> "+" <> intDec o+             LT -> panic "asmTellDataSectionContent: negative offset"+         )+  DataSkip i -> ".skip " <> intDec i+  DataASCII s+    | not (BS.null s) && BS.last s == 0 ->+        ".asciz \""+          <> string7+            (showSDocOneLine defaultSDocContext $ pprASCII $ BS.init s)+          <> "\""+    | otherwise ->+        ".ascii \""+          <> string7+            (showSDocOneLine defaultSDocContext $ pprASCII s)+          <> "\""+  DataIncBin f _ ->+    ".incbin "+      <> string7+        (showSDocOneLine defaultSDocContext $ pprFilePathString f)++dataSectionContentSize :: WasmTypeTag w -> DataSectionContent -> Int+dataSectionContentSize ty_word c = case c of+  DataI8 {} -> 1+  DataI16 {} -> 2+  DataI32 {} -> 4+  DataI64 {} -> 8+  DataF32 {} -> 4+  DataF64 {} -> 8+  DataSym {} -> alignmentBytes $ alignmentFromWordType ty_word+  DataSkip i -> i+  DataASCII s -> BS.length s+  DataIncBin _ l -> l++dataSectionSize :: WasmTypeTag w -> [DataSectionContent] -> Int+dataSectionSize ty_word =+  coerce+    . foldMap'+      (Sum . dataSectionContentSize ty_word)++asmTellAlign :: Alignment -> WasmAsmM ()+asmTellAlign a = case alignmentBytes a of+  1 -> mempty+  i -> asmTellTabLine $ ".p2align " <> intDec (countTrailingZeros i)++asmTellSectionHeader :: Builder -> WasmAsmM ()+asmTellSectionHeader k = asmTellTabLine $ ".section " <> k <> ",\"\",@"++asmTellDataSection ::+  WasmTypeTag w -> UniqueSet -> SymName -> DataSection -> WasmAsmM ()+asmTellDataSection ty_word def_syms sym DataSection {..} = do+  when (getUnique sym `memberUniqueSet` def_syms) $ asmTellDefSym sym+  asmTellSectionHeader sec_name+  asmTellAlign dataSectionAlignment+  asmTellTabLine asm_size+  asmTellLine $ asm_sym <> ":"+  for_ dataSectionContents $ asmTellDataSectionContent ty_word+  asmTellLF+  where+    asm_sym = asmFromSymName sym++    sec_name =+      ( case dataSectionKind of+          SectionData -> ".data."+          SectionROData -> ".rodata."+      )+        <> asm_sym++    asm_size =+      ".size "+        <> asm_sym+        <> ", "+        <> intDec+          (dataSectionSize ty_word dataSectionContents)++asmFromWasmBlockType :: WasmTypeTag w -> WasmFunctionType pre post -> Builder+asmFromWasmBlockType+  _+  (WasmFunctionType {ft_pops = TypeListNil, ft_pushes = TypeListNil}) =+    mempty+asmFromWasmBlockType+  TagI32+  ( WasmFunctionType+      { ft_pops = TypeListNil,+        ft_pushes = TypeListCons TagI32 TypeListNil+      }+    ) =+    " i32"+asmFromWasmBlockType+  TagI64+  ( WasmFunctionType+      { ft_pops = TypeListNil,+        ft_pushes = TypeListCons TagI64 TypeListNil+      }+    ) =+    " i64"+asmFromWasmBlockType _ _ = panic "asmFromWasmBlockType: invalid block type"++asmFromAlignmentSpec :: AlignmentSpec -> Builder+asmFromAlignmentSpec NaturallyAligned = mempty+asmFromAlignmentSpec Unaligned = ":p2align=0"++asmTellWasmInstr :: WasmTypeTag w -> WasmInstr w pre post -> WasmAsmM ()+asmTellWasmInstr ty_word instr = case instr of+  WasmComment c -> asmTellLine $ stringUtf8 $ "# " <> c+  WasmNop -> mempty+  WasmDrop -> asmTellLine "drop"+  WasmUnreachable -> asmTellLine "unreachable"+  WasmConst TagI32 i -> asmTellLine $ "i32.const " <> integerDec i+  WasmConst TagI64 i -> asmTellLine $ "i64.const " <> integerDec i+  WasmConst {} -> panic "asmTellWasmInstr: unreachable"+  WasmSymConst sym -> do+    WasmAsmConfig {..} <- getConf+    let+      asm_sym = asmFromSymName sym+      (ty_const, ty_add) = case ty_word of+        TagI32 -> ("i32.const ", "i32.add")+        TagI64 -> ("i64.const ", "i64.add")+        _ -> panic "asmTellWasmInstr: invalid word type"+    traverse_ asmTellLine $ if+      | pic, getUnique sym `memberUniqueSet` mbrelSyms -> [+          "global.get __memory_base",+          ty_const <> asm_sym <> "@MBREL",+          ty_add+        ]+      | pic, getUnique sym `memberUniqueSet` tbrelSyms -> [+          "global.get __table_base",+          ty_const <> asm_sym <> "@TBREL",+          ty_add+        ]+      | pic -> [ "global.get " <> asm_sym <> "@GOT" ]+      | otherwise -> [ ty_const <> asm_sym ]+  WasmLoad ty (Just w) s o align ->+    asmTellLine $+      asmFromWasmType ty+        <> ".load"+        <> intDec w+        <> ( case s of+               Signed -> "_s"+               Unsigned -> "_u"+           )+        <> " "+        <> intDec o+        <> asmFromAlignmentSpec align+  WasmLoad ty Nothing _ o align ->+    asmTellLine $+      asmFromWasmType ty+        <> ".load"+        <> " "+        <> intDec o+        <> asmFromAlignmentSpec align+  WasmStore ty (Just w) o align ->+    asmTellLine $+      asmFromWasmType ty+        <> ".store"+        <> intDec w+        <> " "+        <> intDec o+        <> asmFromAlignmentSpec align+  WasmStore ty Nothing o align ->+    asmTellLine $+      asmFromWasmType ty+        <> ".store"+        <> " "+        <> intDec o+        <> asmFromAlignmentSpec align+  WasmGlobalGet _ sym -> asmTellLine $ "global.get " <> asmFromSymName sym+  WasmGlobalSet _ sym -> asmTellLine $ "global.set " <> asmFromSymName sym+  WasmLocalGet _ i -> asmTellLine $ "local.get " <> intDec i+  WasmLocalSet _ i -> asmTellLine $ "local.set " <> intDec i+  WasmLocalTee _ i -> asmTellLine $ "local.tee " <> intDec i+  WasmCCall sym -> asmTellLine $ "call " <> asmFromSymName sym+  WasmCCallIndirect arg_tys ret_tys ->+    asmTellLine $+      "call_indirect "+        <> asmFromFuncType+          (someWasmTypesFromTypeList arg_tys)+          (someWasmTypesFromTypeList ret_tys)+  WasmConcat instr0 instr1 -> do+    asmTellWasmInstr ty_word instr0+    asmTellWasmInstr ty_word instr1+  WasmReinterpret t0 t1 ->+    asmTellLine $+      asmFromWasmType t1 <> ".reinterpret_" <> asmFromWasmType t0+  WasmTruncSat Signed t0 t1 ->+    asmTellLine $+      asmFromWasmType t1 <> ".trunc_sat_" <> asmFromWasmType t0 <> "_s"+  WasmTruncSat Unsigned t0 t1 ->+    asmTellLine $+      asmFromWasmType t1 <> ".trunc_sat_" <> asmFromWasmType t0 <> "_u"+  WasmConvert Signed t0 t1 ->+    asmTellLine $+      asmFromWasmType t1 <> ".convert_" <> asmFromWasmType t0 <> "_s"+  WasmConvert Unsigned t0 t1 ->+    asmTellLine $+      asmFromWasmType t1 <> ".convert_" <> asmFromWasmType t0 <> "_u"+  WasmAdd ty -> asmTellLine $ asmFromWasmType ty <> ".add"+  WasmSub ty -> asmTellLine $ asmFromWasmType ty <> ".sub"+  WasmMul ty -> asmTellLine $ asmFromWasmType ty <> ".mul"+  WasmDiv _ TagF32 -> asmTellLine "f32.div"+  WasmDiv _ TagF64 -> asmTellLine "f64.div"+  WasmDiv Signed ty -> asmTellLine $ asmFromWasmType ty <> ".div_s"+  WasmDiv Unsigned ty -> asmTellLine $ asmFromWasmType ty <> ".div_u"+  WasmRem Signed ty -> asmTellLine $ asmFromWasmType ty <> ".rem_s"+  WasmRem Unsigned ty -> asmTellLine $ asmFromWasmType ty <> ".rem_u"+  WasmAnd ty -> asmTellLine $ asmFromWasmType ty <> ".and"+  WasmOr ty -> asmTellLine $ asmFromWasmType ty <> ".or"+  WasmXor ty -> asmTellLine $ asmFromWasmType ty <> ".xor"+  WasmEq ty -> asmTellLine $ asmFromWasmType ty <> ".eq"+  WasmNe ty -> asmTellLine $ asmFromWasmType ty <> ".ne"+  WasmLt _ TagF32 -> asmTellLine "f32.lt"+  WasmLt _ TagF64 -> asmTellLine "f64.lt"+  WasmLt Signed ty -> asmTellLine $ asmFromWasmType ty <> ".lt_s"+  WasmLt Unsigned ty -> asmTellLine $ asmFromWasmType ty <> ".lt_u"+  WasmGt _ TagF32 -> asmTellLine "f32.gt"+  WasmGt _ TagF64 -> asmTellLine "f64.gt"+  WasmGt Signed ty -> asmTellLine $ asmFromWasmType ty <> ".gt_s"+  WasmGt Unsigned ty -> asmTellLine $ asmFromWasmType ty <> ".gt_u"+  WasmLe _ TagF32 -> asmTellLine "f32.le"+  WasmLe _ TagF64 -> asmTellLine "f64.le"+  WasmLe Signed ty -> asmTellLine $ asmFromWasmType ty <> ".le_s"+  WasmLe Unsigned ty -> asmTellLine $ asmFromWasmType ty <> ".le_u"+  WasmGe _ TagF32 -> asmTellLine "f32.ge"+  WasmGe _ TagF64 -> asmTellLine "f64.ge"+  WasmGe Signed ty -> asmTellLine $ asmFromWasmType ty <> ".ge_s"+  WasmGe Unsigned ty -> asmTellLine $ asmFromWasmType ty <> ".ge_u"+  WasmShl ty -> asmTellLine $ asmFromWasmType ty <> ".shl"+  WasmShr Signed ty -> asmTellLine $ asmFromWasmType ty <> ".shr_s"+  WasmShr Unsigned ty -> asmTellLine $ asmFromWasmType ty <> ".shr_u"+  WasmI32Extend8S -> asmTellLine "i32.extend8_s"+  WasmI32Extend16S -> asmTellLine "i32.extend16_s"+  WasmI64Extend8S -> asmTellLine "i64.extend8_s"+  WasmI64Extend16S -> asmTellLine "i64.extend16_s"+  WasmI64Extend32S -> asmTellLine "i64.extend32_s"+  WasmI64ExtendI32 Signed -> asmTellLine "i64.extend_i32_s"+  WasmI64ExtendI32 Unsigned -> asmTellLine "i64.extend_i32_u"+  WasmI32WrapI64 -> asmTellLine "i32.wrap_i64"+  WasmF32DemoteF64 -> asmTellLine "f32.demote_f64"+  WasmF64PromoteF32 -> asmTellLine "f64.promote_f32"+  WasmAbs ty -> asmTellLine $ asmFromWasmType ty <> ".abs"+  WasmSqrt ty -> asmTellLine $ asmFromWasmType ty <> ".sqrt"+  WasmNeg ty -> asmTellLine $ asmFromWasmType ty <> ".neg"+  WasmMin ty -> asmTellLine $ asmFromWasmType ty <> ".min"+  WasmMax ty -> asmTellLine $ asmFromWasmType ty <> ".max"+  WasmCond t -> do+    asmTellLine "if"+    asmWithTab $ asmTellWasmInstr ty_word t+    asmTellLine "end_if"++asmTellWasmControl ::+  WasmTypeTag w ->+  WasmControl+    (WasmStatements w)+    (WasmExpr w a)+    pre+    post ->+  WasmAsmM ()+asmTellWasmControl ty_word c = case c of+  WasmPush _ (WasmExpr e) -> asmTellWasmInstr ty_word e+  WasmBlock bt c -> do+    asmTellLine $ "block" <> asmFromWasmBlockType ty_word bt+    asmWithTab $ asmTellWasmControl ty_word c+    asmTellLine "end_block"+  WasmLoop bt c -> do+    asmTellLine $ "loop" <> asmFromWasmBlockType ty_word bt+    asmWithTab $ asmTellWasmControl ty_word c+    asmTellLine "end_loop"+  WasmIfTop bt t f -> do+    asmTellLine $ "if" <> asmFromWasmBlockType ty_word bt+    asmWithTab $ asmTellWasmControl ty_word t+    asmTellLine "else"+    asmWithTab $ asmTellWasmControl ty_word f+    asmTellLine "end_if"+  WasmBr i -> asmTellLine $ "br " <> intDec i+  WasmFallthrough -> mempty+  WasmBrTable (WasmExpr e) _ ts t -> do+    asmTellWasmInstr ty_word e+    asmTellLine $ "br_table {" <> builderCommas intDec (ts <> [t]) <> "}"+  -- See Note [WasmTailCall]+  WasmTailCall (WasmExpr e) -> do+    WasmAsmConfig {..} <- getConf+    if+        | tailcall,+          WasmSymConst sym <- e ->+            asmTellLine $ "return_call " <> asmFromSymName sym+        | tailcall ->+            do+              asmTellWasmInstr ty_word e+              asmTellLine $+                "return_call_indirect "+                  <> asmFromFuncType+                    []+                    [SomeWasmType ty_word]+        | otherwise ->+            do+              asmTellWasmInstr ty_word e+              asmTellLine "return"+  WasmActions (WasmStatements a) -> asmTellWasmInstr ty_word a+  WasmSeq c0 c1 -> do+    asmTellWasmControl ty_word c0+    asmTellWasmControl ty_word c1++asmTellFunc ::+  WasmTypeTag w ->+  UniqueSet ->+  SymName ->+  (([SomeWasmType], [SomeWasmType]), FuncBody w) ->+  WasmAsmM ()+asmTellFunc ty_word def_syms sym (func_ty, FuncBody {..}) = do+  when (getUnique sym `memberUniqueSet` def_syms) $ asmTellDefSym sym+  asmTellSectionHeader $ ".text." <> asm_sym+  asmTellLine $ asm_sym <> ":"+  asmTellFuncType sym func_ty+  asmTellLocals funcLocals+  asmWithTab $ asmTellWasmControl ty_word funcBody+  asmTellTabLine "end_function"+  asmTellLF+  where+    asm_sym = asmFromSymName sym++asmTellGlobals :: WasmTypeTag w -> WasmAsmM ()+asmTellGlobals ty_word = do+  WasmAsmConfig {..} <- getConf+  when pic $ traverse_ asmTellTabLine [+      ".globaltype __memory_base, i32, immutable",+      ".globaltype __table_base, i32, immutable"+    ]+  for_ supportedCmmGlobalRegs $ \reg ->+    let+      (sym, ty) = fromJust $ globalInfoFromCmmGlobalReg ty_word reg+      asm_sym = asmFromSymName sym+     in do+      asmTellTabLine $+          ".globaltype "+            <> asm_sym+            <> ", "+            <> asmFromSomeWasmType ty+      when pic $ traverse_ asmTellTabLine [+          ".import_module " <> asm_sym <> ", regs",+          ".import_name " <> asm_sym <> ", " <> asm_sym+        ]+  asmTellLF++asmTellCtors :: WasmTypeTag w -> [SymName] -> WasmAsmM ()+asmTellCtors _ [] = mempty+asmTellCtors ty_word syms = do+  -- See Note [JSFFI initialization] for details+  asmTellSectionHeader ".init_array.101"+  asmTellAlign $ alignmentFromWordType ty_word+  for_ syms $ \sym ->+    asmTellTabLine $+      ( case ty_word of+          TagI32 -> ".int32 "+          TagI64 -> ".int64 "+          _ -> panic "asmTellCtors: unreachable"+      )+        <> asmFromSymName sym+  asmTellLF++asmTellBS :: ByteString -> WasmAsmM ()+asmTellBS s = do+  asmTellTabLine $ ".int8 " <> intDec (BS.length s)+  asmTellTabLine $+    ".ascii \""+      <> string7+        (showSDocOneLine defaultSDocContext $ pprASCII s)+      <> "\""++asmTellVec :: [WasmAsmM ()] -> WasmAsmM ()+asmTellVec xs = do+  asmTellTabLine $ ".int8 " <> intDec (length xs)+  sequence_ xs++asmTellProducers :: WasmAsmM ()+asmTellProducers = do+  asmTellSectionHeader ".custom_section.producers"+  asmTellVec+    [ do+        asmTellBS "processed-by"+        asmTellVec+          [ do+              asmTellBS "ghc"+              asmTellBS $ BS8.pack cProjectVersion+          ]+    ]++asmTellTargetFeatures :: WasmAsmM ()+asmTellTargetFeatures = do+  WasmAsmConfig {..} <- getConf+  asmTellSectionHeader ".custom_section.target_features"+  asmTellVec+    [ do+        asmTellTabLine ".int8 0x2b"+        asmTellBS feature+      | feature <-+          ["tail-call" | tailcall]+            <> [ "bulk-memory",+                 "mutable-globals",+                 "nontrapping-fptoint",+                 "reference-types",+                 "sign-ext"+               ]+    ]++asmTellEverything :: WasmTypeTag w -> WasmCodeGenState w -> WasmAsmM ()+asmTellEverything ty_word WasmCodeGenState {..} = do+  asmTellGlobals ty_word+  asm_functypes+  asm_funcs+  asm_data_secs+  asm_ctors+  asmTellProducers+  asmTellTargetFeatures+  where+    asm_functypes = do+      for_+        (detEltsUniqMap $ funcTypes `minusUniqMap` funcBodies)+        (uncurry asmTellFuncType)+      asmTellLF++    asm_funcs = do+      for_+        (detEltsUniqMap $ intersectUniqMap_C (,) funcTypes funcBodies)+        (uncurry $ asmTellFunc ty_word defaultSyms)+      asmTellLF++    asm_data_secs = do+      for_+        (detEltsUniqMap dataSections)+        (uncurry (asmTellDataSection ty_word defaultSyms))+      asmTellLF++    asm_ctors = asmTellCtors ty_word ctors
+ GHC/CmmToAsm/Wasm/FromCmm.hs view
@@ -0,0 +1,1761 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE Strict #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}++{-# HLINT ignore "Use camelCase" #-}+module GHC.CmmToAsm.Wasm.FromCmm+  ( alignmentFromWordType,+    globalInfoFromCmmGlobalReg,+    supportedCmmGlobalRegs,+    onCmmGroup,+  )+where++import Control.Monad+import qualified Data.ByteString as BS+import Data.Foldable+import Data.Functor+import Data.Semigroup+import Data.String+import Data.Traversable+import Data.Type.Equality+import GHC.Cmm+import GHC.Cmm.BlockId+import GHC.Cmm.CLabel+import GHC.Cmm.Dataflow.Block+import GHC.Cmm.Dataflow.Label+import GHC.Cmm.InitFini+import GHC.CmmToAsm.Wasm.Types+import GHC.CmmToAsm.Wasm.Utils+import GHC.Float+import GHC.Platform+import GHC.Prelude+import GHC.StgToCmm.CgUtils+import GHC.Types.Basic+import GHC.Types.ForeignCall+import GHC.Types.Unique+import GHC.Types.Unique.FM+import GHC.Types.Unique.Map+import GHC.Types.Unique.Set+import GHC.Types.Unique.DSM+import GHC.Utils.Outputable hiding ((<>))+import GHC.Utils.Panic+import GHC.Wasm.ControlFlow.FromCmm++-- | Calculate the wasm representation type from a 'CmmType'. This is+-- a lossy conversion, and sometimes we need to pass the original+-- 'CmmType' or at least its 'Width' around, so to properly add+-- subword truncation or extension logic.+someWasmTypeFromCmmType :: CmmType -> SomeWasmType+someWasmTypeFromCmmType t+  | isWord32 t = SomeWasmType TagI32+  | isWord64 t = SomeWasmType TagI64+  | t `cmmEqType` b16 = SomeWasmType TagI32+  | t `cmmEqType` b8 = SomeWasmType TagI32+  | isFloat64 t = SomeWasmType TagF64+  | isFloat32 t = SomeWasmType TagF32+  | otherwise =+      panic $+        "someWasmTypeFromCmmType: unsupported CmmType "+          <> showSDocOneLine defaultSDocContext (ppr t)++-- | Calculate the optional memory narrowing of a 'CmmLoad' or+-- 'CmmStore'.+wasmMemoryNarrowing :: WasmTypeTag t -> CmmType -> Maybe Int+wasmMemoryNarrowing ty ty_cmm = case (# ty, typeWidth ty_cmm #) of+  (# TagI32, W8 #) -> Just 8+  (# TagI32, W16 #) -> Just 16+  (# TagI32, W32 #) -> Nothing+  (# TagI64, W8 #) -> Just 8+  (# TagI64, W16 #) -> Just 16+  (# TagI64, W32 #) -> Just 32+  (# TagI64, W64 #) -> Nothing+  (# TagF32, W32 #) -> Nothing+  (# TagF64, W64 #) -> Nothing+  _ -> panic "wasmMemoryNarrowing: unreachable"++-- | Despite this is used by the WebAssembly native codegen, we use+-- 'pprCLabel' instead of 'pprAsmLabel' when emitting the textual+-- symbol name. Either one would work, but 'pprCLabel' makes the+-- output assembly code looks closer to the unregisterised codegen+-- output, which can be handy when using the unregisterised codegen as+-- a source of truth when debugging the native codegen.+symNameFromCLabel :: CLabel -> SymName+symNameFromCLabel lbl =+  fromString $+    showSDocOneLine defaultSDocContext {sdocStyle = PprCode} $+      pprCLabel genericPlatform lbl++-- | Calculate a symbol's visibility.+symVisibilityFromCLabel :: CLabel -> SymVisibility+symVisibilityFromCLabel lbl+  | externallyVisibleCLabel lbl = SymDefault+  | otherwise = SymStatic++-- | Calculate a symbol's kind, see haddock docs of 'SymKind' for more+-- explanation.+symKindFromCLabel :: CLabel -> SymKind+symKindFromCLabel lbl+  | isCFunctionLabel lbl = SymFunc+  | otherwise = SymData++-- | Calculate a data section's kind, see haddock docs of+-- 'DataSectionKind' for more explanation.+dataSectionKindFromCmmSection :: Section -> DataSectionKind+dataSectionKindFromCmmSection s = case sectionProtection s of+  ReadWriteSection -> SectionData+  _ -> SectionROData++-- | Calculate the natural alignment size given the platform word+-- type.+alignmentFromWordType :: WasmTypeTag w -> Alignment+alignmentFromWordType TagI32 = mkAlignment 4+alignmentFromWordType TagI64 = mkAlignment 8+alignmentFromWordType _ = panic "alignmentFromWordType: unreachable"++-- | Calculate a data section's alignment. As a conservative+-- optimization, a data section with a single CmmString/CmmFileEmbed+-- has no alignment requirement, otherwise we always align to the word+-- size to satisfy pointer tagging requirements and avoid unaligned+-- loads/stores.+alignmentFromCmmSection :: WasmTypeTag w -> [DataSectionContent] -> Alignment+alignmentFromCmmSection _ [DataASCII {}] = mkAlignment 1+alignmentFromCmmSection _ [DataIncBin {}] = mkAlignment 1+alignmentFromCmmSection t _ = alignmentFromWordType t++-- | Lower a 'CmmStatic'.+lower_CmmStatic :: CmmStatic -> WasmCodeGenM w DataSectionContent+lower_CmmStatic s = case s of+  CmmStaticLit (CmmInt i W8) -> pure $ DataI8 $ fromInteger $ narrowU W8 i+  CmmStaticLit (CmmInt i W16) -> pure $ DataI16 $ fromInteger $ narrowU W16 i+  CmmStaticLit (CmmInt i W32) -> pure $ DataI32 $ fromInteger $ narrowU W32 i+  CmmStaticLit (CmmInt i W64) -> pure $ DataI64 $ fromInteger $ narrowU W64 i+  CmmStaticLit (CmmFloat f W32) -> pure $ DataF32 $ fromRational f+  CmmStaticLit (CmmFloat d W64) -> pure $ DataF64 $ fromRational d+  CmmStaticLit (CmmLabel lbl) ->+    onAnySym lbl+      $> DataSym+        (symNameFromCLabel lbl)+        0+  CmmStaticLit (CmmLabelOff lbl o) ->+    onAnySym lbl+      $> DataSym+        (symNameFromCLabel lbl)+        o+  CmmUninitialised i -> pure $ DataSkip i+  CmmString b -> pure $ DataASCII b+  CmmFileEmbed f l -> pure $ DataIncBin f l+  _ -> panic "lower_CmmStatic: unreachable"++{-+Note [Register mapping on WebAssembly]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Unlike typical ISAs, WebAssembly doesn't expose a fixed set of+registers. For now, we map each Cmm LocalReg to a wasm local, and each+Cmm GlobalReg to a wasm global. The wasm globals are defined in+rts/wasm/Wasm.S, and must be kept in sync with+'globalInfoFromCmmGlobalReg' and 'supportedCmmGlobalRegs' here.++There are some other Cmm GlobalRegs which are still represented by+StgRegTable fields instead of wasm globals (e.g. HpAlloc). It's cheap+to add wasm globals, but other parts of rts logic only work with the+StgRegTable fields, so we also need to instrument StgRun/StgReturn to+sync the wasm globals with the StgRegTable. It's not really worth the+trouble.++-}+globalInfoFromCmmGlobalReg :: WasmTypeTag w -> GlobalReg -> Maybe GlobalInfo+globalInfoFromCmmGlobalReg t reg = case reg of+  VanillaReg i+    | i >= 1 && i <= 10 -> Just (fromString $ "__R" <> show i, ty_word)+  FloatReg i+    | i >= 1 && i <= 6 ->+        Just (fromString $ "__F" <> show i, SomeWasmType TagF32)+  DoubleReg i+    | i >= 1 && i <= 6 ->+        Just (fromString $ "__D" <> show i, SomeWasmType TagF64)+  LongReg i+    | i == 1 -> Just (fromString $ "__L" <> show i, SomeWasmType TagI64)+  Sp -> Just ("__Sp", ty_word)+  SpLim -> Just ("__SpLim", ty_word)+  Hp -> Just ("__Hp", ty_word)+  HpLim -> Just ("__HpLim", ty_word)+  _ -> Nothing+  where+    ty_word = SomeWasmType t++supportedCmmGlobalRegs :: [GlobalReg]+supportedCmmGlobalRegs =+  [VanillaReg i | i <- [1 .. 10]]+    <> [FloatReg i | i <- [1 .. 6]]+    <> [DoubleReg i | i <- [1 .. 6]]+    <> [LongReg i | i <- [1 .. 1]]+    <> [Sp, SpLim, Hp, HpLim]++-- | Truncate a subword.+truncSubword :: Width -> WasmTypeTag t -> WasmExpr w t -> WasmExpr w t+truncSubword W8 ty (WasmExpr instr) =+  WasmExpr $ instr `WasmConcat` WasmConst ty 0xFF `WasmConcat` WasmAnd ty+truncSubword W16 ty (WasmExpr instr) =+  WasmExpr $ instr `WasmConcat` WasmConst ty 0xFFFF `WasmConcat` WasmAnd ty+truncSubword _ _ expr = expr++-- | Sign-extend a subword.+extendSubword :: Width -> WasmTypeTag t -> WasmExpr w t -> WasmExpr w t+extendSubword W8 TagI32 (WasmExpr instr) =+  WasmExpr $ instr `WasmConcat` WasmI32Extend8S+extendSubword W16 TagI32 (WasmExpr instr) =+  WasmExpr $ instr `WasmConcat` WasmI32Extend16S+extendSubword W8 TagI64 (WasmExpr instr) =+  WasmExpr $ instr `WasmConcat` WasmI64Extend8S+extendSubword W16 TagI64 (WasmExpr instr) =+  WasmExpr $ instr `WasmConcat` WasmI64Extend16S+extendSubword W32 TagI64 (WasmExpr instr) =+  WasmExpr $ instr `WasmConcat` WasmI64Extend32S+extendSubword _ _ expr = expr++-- | Lower an unary homogeneous operation.+lower_MO_Un_Homo ::+  ( forall pre t.+    WasmTypeTag t ->+    WasmInstr+      w+      (t : pre)+      (t : pre)+  ) ->+  CLabel ->+  CmmType ->+  [CmmExpr] ->+  WasmCodeGenM w (SomeWasmExpr w)+lower_MO_Un_Homo op lbl t0 [x] = case someWasmTypeFromCmmType t0 of+  SomeWasmType ty -> do+    WasmExpr x_instr <- lower_CmmExpr_Typed lbl ty x+    pure $+      SomeWasmExpr ty $+        WasmExpr $+          x_instr `WasmConcat` op ty+lower_MO_Un_Homo _ _ _ _ = panic "lower_MO_Un_Homo: unreachable"++-- | Lower a binary homogeneous operation. Homogeneous: result type is+-- the same with operand types.+lower_MO_Bin_Homo ::+  ( forall pre t.+    WasmTypeTag t ->+    WasmInstr+      w+      (t : t : pre)+      (t : pre)+  ) ->+  CLabel ->+  CmmType ->+  [CmmExpr] ->+  WasmCodeGenM w (SomeWasmExpr w)+lower_MO_Bin_Homo op lbl t0 [x, y] = case someWasmTypeFromCmmType t0 of+  SomeWasmType ty -> do+    WasmExpr x_instr <- lower_CmmExpr_Typed lbl ty x+    WasmExpr y_instr <- lower_CmmExpr_Typed lbl ty y+    pure $+      SomeWasmExpr ty $+        WasmExpr $+          x_instr `WasmConcat` y_instr `WasmConcat` op ty+lower_MO_Bin_Homo _ _ _ _ = panic "lower_MO_Bin_Homo: unreachable"++-- | Lower a binary homogeneous operation, and truncate the result if+-- it's a subword.+lower_MO_Bin_Homo_Trunc ::+  (forall pre t. WasmTypeTag t -> WasmInstr w (t : t : pre) (t : pre)) ->+  CLabel ->+  Width ->+  [CmmExpr] ->+  WasmCodeGenM w (SomeWasmExpr w)+lower_MO_Bin_Homo_Trunc op lbl w0 [x, y] =+  case someWasmTypeFromCmmType (cmmBits w0) of+    SomeWasmType ty -> do+      WasmExpr x_instr <- lower_CmmExpr_Typed lbl ty x+      WasmExpr y_instr <- lower_CmmExpr_Typed lbl ty y+      pure $+        SomeWasmExpr ty $+          truncSubword w0 ty $+            WasmExpr $+              x_instr `WasmConcat` y_instr `WasmConcat` op ty+lower_MO_Bin_Homo_Trunc _ _ _ _ = panic "lower_MO_Bin_Homo_Trunc: unreachable"++-- | Lower a binary homogeneous operation, first sign extending the+-- operands, then truncating the result.+lower_MO_Bin_Homo_Ext_Trunc ::+  (forall pre t. WasmTypeTag t -> WasmInstr w (t : t : pre) (t : pre)) ->+  CLabel ->+  Width ->+  [CmmExpr] ->+  WasmCodeGenM w (SomeWasmExpr w)+lower_MO_Bin_Homo_Ext_Trunc op lbl w0 [x, y] =+  case someWasmTypeFromCmmType (cmmBits w0) of+    SomeWasmType ty -> do+      WasmExpr x_instr <-+        extendSubword w0 ty <$> lower_CmmExpr_Typed lbl ty x+      WasmExpr y_instr <-+        extendSubword w0 ty <$> lower_CmmExpr_Typed lbl ty y+      pure $+        SomeWasmExpr ty $+          truncSubword w0 ty $+            WasmExpr $+              x_instr `WasmConcat` y_instr `WasmConcat` op ty+lower_MO_Bin_Homo_Ext_Trunc _ _ _ _ =+  panic "lower_MO_Bin_Homo_Ext_Trunc: unreachable"++-- | Lower a relational binary operation, first sign extending the+-- operands. Relational: result type is a boolean (word type).+lower_MO_Bin_Rel_Ext ::+  (forall pre t. WasmTypeTag t -> WasmInstr w (t : t : pre) (w : pre)) ->+  CLabel ->+  Width ->+  [CmmExpr] ->+  WasmCodeGenM w (SomeWasmExpr w)+lower_MO_Bin_Rel_Ext op lbl w0 [x, y] =+  case someWasmTypeFromCmmType (cmmBits w0) of+    SomeWasmType ty -> do+      WasmExpr x_instr <-+        extendSubword w0 ty <$> lower_CmmExpr_Typed lbl ty x+      WasmExpr y_instr <-+        extendSubword w0 ty <$> lower_CmmExpr_Typed lbl ty y+      ty_word <- wasmWordTypeM+      pure $+        SomeWasmExpr ty_word $+          WasmExpr $+            x_instr `WasmConcat` y_instr `WasmConcat` op ty+lower_MO_Bin_Rel_Ext _ _ _ _ = panic "lower_MO_Bin_Rel_Ext: unreachable"++-- | Lower a relational binary operation.+lower_MO_Bin_Rel ::+  ( forall pre t.+    WasmTypeTag t ->+    WasmInstr+      w+      (t : t : pre)+      (w : pre)+  ) ->+  CLabel ->+  CmmType ->+  [CmmExpr] ->+  WasmCodeGenM w (SomeWasmExpr w)+lower_MO_Bin_Rel op lbl t0 [x, y] = case someWasmTypeFromCmmType t0 of+  SomeWasmType ty -> do+    WasmExpr x_instr <- lower_CmmExpr_Typed lbl ty x+    WasmExpr y_instr <- lower_CmmExpr_Typed lbl ty y+    ty_word <- wasmWordTypeM+    pure $+      SomeWasmExpr ty_word $+        WasmExpr $+          x_instr `WasmConcat` y_instr `WasmConcat` op ty+lower_MO_Bin_Rel _ _ _ _ = panic "lower_MO_Bin_Rel: unreachable"++-- | Cast a shiftL/shiftR RHS to the same type as LHS. Because we may+-- have a 64-bit LHS and 32-bit RHS, but wasm shift operators are+-- homogeneous.+shiftRHSCast ::+  CLabel ->+  WasmTypeTag t ->+  CmmExpr ->+  WasmCodeGenM+    w+    (WasmExpr w t)+shiftRHSCast lbl t1 x = do+  SomeWasmExpr t0 (WasmExpr x_instr) <- lower_CmmExpr lbl x+  if+      | Just Refl <- t0 `testEquality` t1 -> pure $ WasmExpr x_instr+      | TagI32 <- t0,+        TagI64 <- t1 ->+          pure $ WasmExpr $ x_instr `WasmConcat` WasmI64ExtendI32 Unsigned+      | otherwise -> panic "shiftRHSCast: unreachable"++-- | Lower a 'MO_Shl' operation, truncating the result.+lower_MO_Shl ::+  CLabel ->+  Width ->+  [CmmExpr] ->+  WasmCodeGenM+    w+    (SomeWasmExpr w)+lower_MO_Shl lbl w0 [x, y] = case someWasmTypeFromCmmType (cmmBits w0) of+  SomeWasmType ty -> do+    WasmExpr x_instr <- lower_CmmExpr_Typed lbl ty x+    WasmExpr y_instr <- shiftRHSCast lbl ty y+    pure $+      SomeWasmExpr ty $+        truncSubword w0 ty $+          WasmExpr $+            x_instr `WasmConcat` y_instr `WasmConcat` WasmShl ty+lower_MO_Shl _ _ _ = panic "lower_MO_Shl: unreachable"++-- | Lower a 'MO_U_Shr' operation.+lower_MO_U_Shr ::+  CLabel ->+  Width ->+  [CmmExpr] ->+  WasmCodeGenM+    w+    (SomeWasmExpr w)+lower_MO_U_Shr lbl w0 [x, y] = case someWasmTypeFromCmmType (cmmBits w0) of+  SomeWasmType ty -> do+    WasmExpr x_instr <- lower_CmmExpr_Typed lbl ty x+    WasmExpr y_instr <- shiftRHSCast lbl ty y+    pure $+      SomeWasmExpr ty $+        WasmExpr $+          x_instr `WasmConcat` y_instr `WasmConcat` WasmShr Unsigned ty+lower_MO_U_Shr _ _ _ = panic "lower_MO_U_Shr: unreachable"++-- | Lower a 'MO_S_Shr' operation, first sign-extending the LHS, then+-- truncating the result.+lower_MO_S_Shr ::+  CLabel ->+  Width ->+  [CmmExpr] ->+  WasmCodeGenM+    w+    (SomeWasmExpr w)+lower_MO_S_Shr lbl w0 [x, y] = case someWasmTypeFromCmmType (cmmBits w0) of+  SomeWasmType ty -> do+    WasmExpr x_instr <- extendSubword w0 ty <$> lower_CmmExpr_Typed lbl ty x+    WasmExpr y_instr <- shiftRHSCast lbl ty y+    pure $+      SomeWasmExpr ty $+        truncSubword w0 ty $+          WasmExpr $+            x_instr `WasmConcat` y_instr `WasmConcat` WasmShr Signed ty+lower_MO_S_Shr _ _ _ = panic "lower_MO_S_Shr: unreachable"++-- | Lower a 'MO_MulMayOflo' operation. It's translated to a ccall to+-- @hs_mulIntMayOflo@ function in @rts/prim/mulIntMayOflo@,+-- otherwise it's quite non-trivial to implement as inline assembly.+lower_MO_MulMayOflo ::+  CLabel -> Width -> [CmmExpr] -> WasmCodeGenM w (SomeWasmExpr w)+lower_MO_MulMayOflo lbl w0 [x, y] = case someWasmTypeFromCmmType ty_cmm of+  SomeWasmType ty -> do+    WasmExpr x_instr <- lower_CmmExpr_Typed lbl ty x+    WasmExpr y_instr <- lower_CmmExpr_Typed lbl ty y+    onFuncSym "hs_mulIntMayOflo" [ty_cmm, ty_cmm] [ty_cmm]+    pure $+      SomeWasmExpr ty $+        WasmExpr $+          x_instr+            `WasmConcat` y_instr+            `WasmConcat` WasmCCall "hs_mulIntMayOflo"+  where+    ty_cmm = cmmBits w0+lower_MO_MulMayOflo _ _ _ = panic "lower_MO_MulMayOflo: unreachable"++-- | Lower an unary conversion operation.+lower_MO_Un_Conv ::+  ( forall pre t0 t1.+    WasmTypeTag t0 ->+    WasmTypeTag t1 ->+    WasmInstr w (t0 : pre) (t1 : pre)+  ) ->+  CLabel ->+  CmmType ->+  CmmType ->+  [CmmExpr] ->+  WasmCodeGenM w (SomeWasmExpr w)+lower_MO_Un_Conv op lbl t0 t1 [x] =+  case (# someWasmTypeFromCmmType t0, someWasmTypeFromCmmType t1 #) of+    (# SomeWasmType ty0, SomeWasmType ty1 #) -> do+      WasmExpr x_instr <- lower_CmmExpr_Typed lbl ty0 x+      pure $ SomeWasmExpr ty1 $ WasmExpr $ x_instr `WasmConcat` op ty0 ty1+lower_MO_Un_Conv _ _ _ _ _ = panic "lower_MO_Un_Conv: unreachable"++-- | Lower a 'MO_SS_Conv' operation.+lower_MO_SS_Conv ::+  CLabel ->+  Width ->+  Width ->+  [CmmExpr] ->+  WasmCodeGenM+    w+    (SomeWasmExpr w)+lower_MO_SS_Conv lbl w0 w1 [x]+  | w0 == w1 = lower_CmmExpr lbl x+lower_MO_SS_Conv lbl w0 w1 [CmmLoad ptr _ align]+  | w0 < w1,+    w1 <= W32 = do+      (WasmExpr ptr_instr, o) <- lower_CmmExpr_Ptr lbl ptr+      pure $+        SomeWasmExpr TagI32 $+          truncSubword w1 TagI32 $+            WasmExpr $+              ptr_instr+                `WasmConcat` WasmLoad+                  TagI32+                  (wasmMemoryNarrowing TagI32 (cmmBits w0))+                  Signed+                  o+                  align+  | w0 > w1 =+      SomeWasmExpr TagI32+        <$> lower_CmmLoad_Typed+          lbl+          ptr+          TagI32+          (cmmBits w1)+          align+lower_MO_SS_Conv lbl w0 W64 [CmmLoad ptr _ align] = do+  (WasmExpr ptr_instr, o) <- lower_CmmExpr_Ptr lbl ptr+  pure $+    SomeWasmExpr TagI64 $+      WasmExpr $+        ptr_instr+          `WasmConcat` WasmLoad+            TagI64+            (wasmMemoryNarrowing TagI64 (cmmBits w0))+            Signed+            o+            align+lower_MO_SS_Conv lbl w0 w1 [x]+  | w0 < w1,+    w1 <= W32 = do+      x_expr <- lower_CmmExpr_Typed lbl TagI32 x+      pure $+        SomeWasmExpr TagI32 $+          truncSubword w1 TagI32 $+            extendSubword w0 TagI32 x_expr+  | W32 >= w0,+    w0 > w1 = do+      x_expr <- lower_CmmExpr_Typed lbl TagI32 x+      pure $ SomeWasmExpr TagI32 $ truncSubword w1 TagI32 x_expr+lower_MO_SS_Conv lbl W32 W64 [x] = do+  WasmExpr x_instr <- lower_CmmExpr_Typed lbl TagI32 x+  pure $+    SomeWasmExpr TagI64 $+      WasmExpr $+        x_instr `WasmConcat` WasmI64ExtendI32 Signed+lower_MO_SS_Conv lbl w0 W64 [x] = do+  WasmExpr x_instr <- lower_CmmExpr_Typed lbl TagI32 x+  pure $+    SomeWasmExpr TagI64 $+      extendSubword w0 TagI64 $+        WasmExpr $+          x_instr `WasmConcat` WasmI64ExtendI32 Unsigned+lower_MO_SS_Conv lbl W64 w1 [x] = do+  WasmExpr x_instr <- lower_CmmExpr_Typed lbl TagI64 x+  pure $+    SomeWasmExpr TagI32 $+      truncSubword w1 TagI32 $+        WasmExpr $+          x_instr `WasmConcat` WasmI32WrapI64+lower_MO_SS_Conv _ _ _ _ = panic "lower_MO_SS_Conv: unreachable"++-- | Lower a 'MO_UU_Conv' operation.+lower_MO_UU_Conv ::+  CLabel ->+  Width ->+  Width ->+  [CmmExpr] ->+  WasmCodeGenM+    w+    (SomeWasmExpr w)+lower_MO_UU_Conv lbl w0 w1 [CmmLoad ptr _ align] =+  case someWasmTypeFromCmmType (cmmBits w1) of+    SomeWasmType ty ->+      SomeWasmExpr ty+        <$> lower_CmmLoad_Typed+          lbl+          ptr+          ty+          (cmmBits (min w0 w1))+          align+lower_MO_UU_Conv lbl w0 w1 [x]+  | w0 == w1 = lower_CmmExpr lbl x+  | w0 < w1, w1 <= W32 = lower_CmmExpr lbl x+  | W32 >= w0,+    w0 > w1 = do+      x_expr <- lower_CmmExpr_Typed lbl TagI32 x+      pure $ SomeWasmExpr TagI32 $ truncSubword w1 TagI32 x_expr+lower_MO_UU_Conv lbl _ W64 [x] = do+  WasmExpr x_instr <- lower_CmmExpr_Typed lbl TagI32 x+  pure $+    SomeWasmExpr TagI64 $+      WasmExpr $+        x_instr `WasmConcat` WasmI64ExtendI32 Unsigned+lower_MO_UU_Conv lbl W64 w1 [x] = do+  WasmExpr x_instr <- lower_CmmExpr_Typed lbl TagI64 x+  pure $+    SomeWasmExpr TagI32 $+      truncSubword w1 TagI32 $+        WasmExpr $+          x_instr `WasmConcat` WasmI32WrapI64+lower_MO_UU_Conv _ _ _ _ = panic "lower_MO_UU_Conv: unreachable"++-- | Lower a 'MO_FF_Conv' operation.+lower_MO_FF_Conv ::+  CLabel ->+  Width ->+  Width ->+  [CmmExpr] ->+  WasmCodeGenM+    w+    (SomeWasmExpr w)+lower_MO_FF_Conv lbl W32 W64 [x] = do+  WasmExpr x_instr <- lower_CmmExpr_Typed lbl TagF32 x+  pure $+    SomeWasmExpr TagF64 $+      WasmExpr $+        x_instr `WasmConcat` WasmF64PromoteF32+lower_MO_FF_Conv lbl W64 W32 [x] = do+  WasmExpr x_instr <- lower_CmmExpr_Typed lbl TagF64 x+  pure $+    SomeWasmExpr TagF32 $+      WasmExpr $+        x_instr `WasmConcat` WasmF32DemoteF64+lower_MO_FF_Conv _ _ _ _ = panic "lower_MO_FF_Conv: unreachable"+++-- | Lower a 'MO_WF_Bitcast' operation. Note that this is not a conversion,+-- rather it reinterprets the data.+lower_MO_WF_Bitcast ::+  CLabel ->+  Width ->+  [CmmActual] ->+  WasmCodeGenM w (SomeWasmExpr w)+lower_MO_WF_Bitcast lbl W32 [x] = do+  WasmExpr x_instr <- lower_CmmExpr_Typed lbl TagI32 x+  pure $+    SomeWasmExpr TagF32 $+      WasmExpr  $+        x_instr `WasmConcat` WasmReinterpret TagI32 TagF32+lower_MO_WF_Bitcast lbl W64 [x] = do+  WasmExpr x_instr <- lower_CmmExpr_Typed lbl TagI64 x+  pure $+    SomeWasmExpr TagF64 $+      WasmExpr  $+        x_instr `WasmConcat` WasmReinterpret TagI64 TagF64+lower_MO_WF_Bitcast _ _ _ = panic "lower_MO_WF_Bitcast: unreachable"++-- | Lower a 'MO_FW_Bitcast' operation. Note that this is not a conversion,+-- rather it reinterprets the data.+lower_MO_FW_Bitcast ::+  CLabel ->+  Width ->+  [CmmActual] ->+  WasmCodeGenM w (SomeWasmExpr w)+lower_MO_FW_Bitcast lbl W32 [x] = do+  WasmExpr x_instr <- lower_CmmExpr_Typed lbl TagF32 x+  pure $+    SomeWasmExpr TagI32 $+      WasmExpr  $+        x_instr `WasmConcat` WasmReinterpret TagF32 TagI32+lower_MO_FW_Bitcast lbl W64 [x] = do+  WasmExpr x_instr <- lower_CmmExpr_Typed lbl TagF64 x+  pure $+    SomeWasmExpr TagI64 $+      WasmExpr  $+        x_instr `WasmConcat` WasmReinterpret TagF64 TagI64+lower_MO_FW_Bitcast _ _ _ = panic "lower_MO_FW_Bitcast: unreachable"++-- | Lower a 'CmmMachOp'.+lower_CmmMachOp ::+  CLabel ->+  MachOp ->+  [CmmExpr] ->+  WasmCodeGenM+    w+    (SomeWasmExpr w)+lower_CmmMachOp lbl (MO_RelaxedRead w0) [x] = lower_CmmExpr lbl (CmmLoad x (cmmBits w0) NaturallyAligned)+lower_CmmMachOp lbl (MO_Add w0) xs = lower_MO_Bin_Homo_Trunc WasmAdd lbl w0 xs+lower_CmmMachOp lbl (MO_Sub w0) xs = lower_MO_Bin_Homo_Trunc WasmSub lbl w0 xs+lower_CmmMachOp lbl (MO_Eq w0) xs = lower_MO_Bin_Rel WasmEq lbl (cmmBits w0) xs+lower_CmmMachOp lbl (MO_Ne w0) xs = lower_MO_Bin_Rel WasmNe lbl (cmmBits w0) xs+lower_CmmMachOp lbl (MO_Mul w0) xs = lower_MO_Bin_Homo_Trunc WasmMul lbl w0 xs+lower_CmmMachOp lbl (MO_S_MulMayOflo w0) xs = lower_MO_MulMayOflo lbl w0 xs+lower_CmmMachOp lbl (MO_S_Quot w0) xs =+  lower_MO_Bin_Homo_Ext_Trunc+    (WasmDiv Signed)+    lbl+    w0+    xs+lower_CmmMachOp lbl (MO_S_Rem w0) xs =+  lower_MO_Bin_Homo_Ext_Trunc+    (WasmRem Signed)+    lbl+    w0+    xs+lower_CmmMachOp lbl (MO_S_Neg w0) [x] =+  lower_CmmMachOp+    lbl+    (MO_Sub w0)+    [CmmLit $ CmmInt 0 w0, x]+lower_CmmMachOp lbl (MO_U_Quot w0) xs =+  lower_MO_Bin_Homo+    (WasmDiv Unsigned)+    lbl+    (cmmBits w0)+    xs+lower_CmmMachOp lbl (MO_U_Rem w0) xs =+  lower_MO_Bin_Homo+    (WasmRem Unsigned)+    lbl+    (cmmBits w0)+    xs+lower_CmmMachOp lbl (MO_S_Ge w0) xs =+  lower_MO_Bin_Rel_Ext+    (WasmGe Signed)+    lbl+    w0+    xs+lower_CmmMachOp lbl (MO_S_Le w0) xs =+  lower_MO_Bin_Rel_Ext+    (WasmLe Signed)+    lbl+    w0+    xs+lower_CmmMachOp lbl (MO_S_Gt w0) xs =+  lower_MO_Bin_Rel_Ext+    (WasmGt Signed)+    lbl+    w0+    xs+lower_CmmMachOp lbl (MO_S_Lt w0) xs =+  lower_MO_Bin_Rel_Ext+    (WasmLt Signed)+    lbl+    w0+    xs+lower_CmmMachOp lbl (MO_U_Ge w0) xs =+  lower_MO_Bin_Rel+    (WasmGe Unsigned)+    lbl+    (cmmBits w0)+    xs+lower_CmmMachOp lbl (MO_U_Le w0) xs =+  lower_MO_Bin_Rel+    (WasmLe Unsigned)+    lbl+    (cmmBits w0)+    xs+lower_CmmMachOp lbl (MO_U_Gt w0) xs =+  lower_MO_Bin_Rel+    (WasmGt Unsigned)+    lbl+    (cmmBits w0)+    xs+lower_CmmMachOp lbl (MO_U_Lt w0) xs =+  lower_MO_Bin_Rel+    (WasmLt Unsigned)+    lbl+    (cmmBits w0)+    xs+lower_CmmMachOp lbl (MO_F_Add w0) xs =+  lower_MO_Bin_Homo+    WasmAdd+    lbl+    (cmmFloat w0)+    xs+lower_CmmMachOp lbl (MO_F_Sub w0) xs =+  lower_MO_Bin_Homo+    WasmSub+    lbl+    (cmmFloat w0)+    xs+lower_CmmMachOp lbl (MO_F_Neg w0) xs =+  lower_MO_Un_Homo+    WasmNeg+    lbl+    (cmmFloat w0)+    xs+lower_CmmMachOp lbl (MO_F_Mul w0) xs =+  lower_MO_Bin_Homo+    WasmMul+    lbl+    (cmmFloat w0)+    xs+lower_CmmMachOp lbl (MO_F_Quot w0) xs =+  lower_MO_Bin_Homo+    (WasmDiv Signed)+    lbl+    (cmmFloat w0)+    xs+lower_CmmMachOp lbl (MO_F_Eq w0) xs =+  lower_MO_Bin_Rel+    WasmEq+    lbl+    (cmmFloat w0)+    xs+lower_CmmMachOp lbl (MO_F_Ne w0) xs =+  lower_MO_Bin_Rel+    WasmNe+    lbl+    (cmmFloat w0)+    xs+lower_CmmMachOp lbl (MO_F_Ge w0) xs =+  lower_MO_Bin_Rel+    (WasmGe Signed)+    lbl+    (cmmFloat w0)+    xs+lower_CmmMachOp lbl (MO_F_Le w0) xs =+  lower_MO_Bin_Rel+    (WasmLe Signed)+    lbl+    (cmmFloat w0)+    xs+lower_CmmMachOp lbl (MO_F_Gt w0) xs =+  lower_MO_Bin_Rel+    (WasmGt Signed)+    lbl+    (cmmFloat w0)+    xs+lower_CmmMachOp lbl (MO_F_Lt w0) xs =+  lower_MO_Bin_Rel+    (WasmLt Signed)+    lbl+    (cmmFloat w0)+    xs+lower_CmmMachOp lbl (MO_F_Min w0) xs =+  lower_MO_Bin_Homo+    WasmMin+    lbl+    (cmmFloat w0)+    xs+lower_CmmMachOp lbl (MO_F_Max w0) xs =+  lower_MO_Bin_Homo+    WasmMax+    lbl+    (cmmFloat w0)+    xs+lower_CmmMachOp lbl (MO_And w0) xs =+  lower_MO_Bin_Homo+    WasmAnd+    lbl+    (cmmBits w0)+    xs+lower_CmmMachOp lbl (MO_Or w0) xs = lower_MO_Bin_Homo WasmOr lbl (cmmBits w0) xs+lower_CmmMachOp lbl (MO_Xor w0) xs =+  lower_MO_Bin_Homo+    WasmXor+    lbl+    (cmmBits w0)+    xs+lower_CmmMachOp lbl (MO_Not w0) [x] =+  lower_CmmMachOp+    lbl+    (MO_Xor w0)+    [x, CmmLit $ CmmInt (widthMax w0) w0]+lower_CmmMachOp lbl (MO_Shl w0) xs = lower_MO_Shl lbl w0 xs+lower_CmmMachOp lbl (MO_U_Shr w0) xs = lower_MO_U_Shr lbl w0 xs+lower_CmmMachOp lbl (MO_S_Shr w0) xs = lower_MO_S_Shr lbl w0 xs+lower_CmmMachOp lbl (MO_SF_Round w0 w1) xs =+  lower_MO_Un_Conv+    (WasmConvert Signed)+    lbl+    (cmmBits w0)+    (cmmFloat w1)+    xs+lower_CmmMachOp lbl (MO_FS_Truncate w0 w1) xs =+  lower_MO_Un_Conv+    (WasmTruncSat Signed)+    lbl+    (cmmFloat w0)+    (cmmBits w1)+    xs+lower_CmmMachOp lbl (MO_SS_Conv w0 w1) xs = lower_MO_SS_Conv lbl w0 w1 xs+lower_CmmMachOp lbl (MO_UU_Conv w0 w1) xs = lower_MO_UU_Conv lbl w0 w1 xs+lower_CmmMachOp lbl (MO_XX_Conv w0 w1) xs = lower_MO_UU_Conv lbl w0 w1 xs+lower_CmmMachOp lbl (MO_FF_Conv w0 w1) xs = lower_MO_FF_Conv lbl w0 w1 xs+lower_CmmMachOp lbl (MO_FW_Bitcast w) xs  = lower_MO_FW_Bitcast lbl w xs+lower_CmmMachOp lbl (MO_WF_Bitcast w) xs  = lower_MO_WF_Bitcast lbl w xs+lower_CmmMachOp _ mop _ =+  pprPanic "lower_CmmMachOp: unreachable" $+    vcat [ text "offending MachOp:" <+> pprMachOp mop ]++-- | Lower a 'CmmLit'. Note that we don't emit 'f32.const' or+-- 'f64.const' for the time being, and instead emit their relative bit+-- pattern as int literals, then use an reinterpret cast. This is+-- simpler than dealing with textual representation of floating point+-- values.+lower_CmmLit :: CmmLit -> WasmCodeGenM w (SomeWasmExpr w)+lower_CmmLit lit = do+  ty_word <- wasmWordTypeM+  case lit of+    CmmInt i w -> case someWasmTypeFromCmmType (cmmBits w) of+      SomeWasmType ty ->+        pure $+          SomeWasmExpr ty $+            WasmExpr $+              WasmConst ty $+                narrowU w i+    CmmFloat f W32 ->+      pure $+        SomeWasmExpr TagF32 $+          WasmExpr $+            WasmConst+              TagI32+              (toInteger $ castFloatToWord32 $ fromRational f)+              `WasmConcat` WasmReinterpret TagI32 TagF32+    CmmFloat f W64 ->+      pure $+        SomeWasmExpr TagF64 $+          WasmExpr $+            WasmConst+              TagI64+              (toInteger $ castDoubleToWord64 $ fromRational f)+              `WasmConcat` WasmReinterpret TagI64 TagF64+    CmmLabel lbl' -> do+      onAnySym lbl'+      let sym = symNameFromCLabel lbl'+      pure $ SomeWasmExpr ty_word $ WasmExpr $ WasmSymConst sym+    CmmLabelOff lbl' o -> do+      onAnySym lbl'+      let sym = symNameFromCLabel lbl'+      pure $+        SomeWasmExpr ty_word $+          WasmExpr $+            WasmSymConst sym+              `WasmConcat` WasmConst ty_word (toInteger o)+              `WasmConcat` WasmAdd ty_word+    CmmBlock bid -> lower_CmmLit $ CmmLabel $ infoTblLbl bid+    _ -> panic "lower_CmmLit: unreachable"++--  | Lower a 'CmmReg'. Some of the logic here wouldn't be needed if+--  we have run 'fixStgRegisters' on the wasm NCG's input Cmm, but we+--  haven't run it yet for certain reasons.+lower_CmmReg :: CLabel -> CmmReg -> WasmCodeGenM w (SomeWasmExpr w)+lower_CmmReg _ (CmmLocal reg) = do+  (reg_i, SomeWasmType ty) <- onCmmLocalReg reg+  pure $ SomeWasmExpr ty $ WasmExpr $ WasmLocalGet ty reg_i+lower_CmmReg lbl (CmmGlobal (GlobalRegUse greg reg_use_ty)) = do+  ty_word <- wasmWordTypeM+  ty_word_cmm <- wasmWordCmmTypeM+  case greg of+    EagerBlackholeInfo ->+      pure $+        SomeWasmExpr ty_word $+          WasmExpr $+            WasmSymConst "__stg_EAGER_BLACKHOLE_info"+    GCEnter1 -> do+      onFuncSym "__stg_gc_enter_1" [] [ty_word_cmm]+      pure $ SomeWasmExpr ty_word $ WasmExpr $ WasmSymConst "__stg_gc_enter_1"+    GCFun -> do+      onFuncSym "__stg_gc_fun" [] [ty_word_cmm]+      pure $ SomeWasmExpr ty_word $ WasmExpr $ WasmSymConst "__stg_gc_fun"+    BaseReg -> do+      platform <- wasmPlatformM+      lower_CmmExpr lbl $ regTableOffset platform 0+    _other+      | Just (sym_global, SomeWasmType ty) <-+          globalInfoFromCmmGlobalReg ty_word greg ->+          pure $ SomeWasmExpr ty $ WasmExpr $ WasmGlobalGet ty sym_global+      | otherwise -> do+          platform <- wasmPlatformM+          case someWasmTypeFromCmmType reg_use_ty of+            SomeWasmType ty -> do+              (WasmExpr ptr_instr, o) <-+                lower_CmmExpr_Ptr lbl $+                  get_GlobalReg_addr platform greg+              pure $+                SomeWasmExpr ty $+                  WasmExpr $+                    ptr_instr+                      `WasmConcat` WasmLoad+                        ty+                        Nothing+                        Unsigned+                        o+                        NaturallyAligned++-- | Lower a 'CmmRegOff'.+lower_CmmRegOff :: CLabel -> CmmReg -> Int -> WasmCodeGenM w (SomeWasmExpr w)+lower_CmmRegOff lbl reg 0 = lower_CmmReg lbl reg+lower_CmmRegOff lbl reg o = do+  SomeWasmExpr ty (WasmExpr reg_instr) <- lower_CmmReg lbl reg+  pure $+    SomeWasmExpr ty $+      WasmExpr $+        reg_instr+          `WasmConcat` WasmConst+            ty+            (toInteger o)+          `WasmConcat` WasmAdd ty++-- | Lower a 'CmmLoad', passing in the expected wasm representation+-- type, and also the Cmm type (which contains width info needed for+-- memory narrowing).+--+-- The Cmm type system doesn't track signedness, so all 'CmmLoad's are+-- unsigned loads. However, as an optimization, we do emit signed+-- loads when a 'CmmLoad' result is immediately used as a 'MO_SS_Conv'+-- operand.+lower_CmmLoad_Typed ::+  CLabel ->+  CmmExpr ->+  WasmTypeTag t ->+  CmmType ->+  AlignmentSpec ->+  WasmCodeGenM w (WasmExpr w t)+lower_CmmLoad_Typed lbl ptr_expr ty ty_cmm align = do+  (WasmExpr ptr_instr, o) <- lower_CmmExpr_Ptr lbl ptr_expr+  pure $+    WasmExpr $+      ptr_instr+        `WasmConcat` WasmLoad+          ty+          (wasmMemoryNarrowing ty ty_cmm)+          Unsigned+          o+          align++-- | Lower a 'CmmLoad'.+lower_CmmLoad ::+  CLabel ->+  CmmExpr ->+  CmmType ->+  AlignmentSpec ->+  WasmCodeGenM+    w+    (SomeWasmExpr w)+lower_CmmLoad lbl ptr_expr ty_cmm align = case someWasmTypeFromCmmType ty_cmm of+  SomeWasmType ty ->+    SomeWasmExpr ty <$> lower_CmmLoad_Typed lbl ptr_expr ty ty_cmm align++-- | Lower a 'CmmExpr'.+lower_CmmExpr :: CLabel -> CmmExpr -> WasmCodeGenM w (SomeWasmExpr w)+lower_CmmExpr lbl expr = case expr of+  CmmLit lit -> lower_CmmLit lit+  CmmLoad ptr_expr ty_cmm align -> lower_CmmLoad lbl ptr_expr ty_cmm align+  CmmReg reg -> lower_CmmReg lbl reg+  CmmRegOff reg o -> lower_CmmRegOff lbl reg o+  CmmMachOp op xs -> lower_CmmMachOp lbl op xs+  _ -> panic "lower_CmmExpr: unreachable"++-- | Lower a 'CmmExpr', passing in the expected wasm representation+-- type.+lower_CmmExpr_Typed ::+  CLabel ->+  WasmTypeTag t ->+  CmmExpr ->+  WasmCodeGenM+    w+    (WasmExpr w t)+lower_CmmExpr_Typed lbl ty expr = do+  SomeWasmExpr ty' r <- lower_CmmExpr lbl expr+  if+      | Just Refl <- ty' `testEquality` ty -> pure r+      | otherwise -> panic "lower_CmmExpr_Typed: unreachable"++-- | Lower a 'CmmExpr' as a pointer, returning the pair of base+-- pointer and non-negative offset.+lower_CmmExpr_Ptr :: CLabel -> CmmExpr -> WasmCodeGenM w (WasmExpr w w, Int)+lower_CmmExpr_Ptr lbl ptr = do+  ty_word <- wasmWordTypeM+  let (ptr', o) = case ptr of+        CmmLit (CmmLabelOff lbl o)+          | o >= 0 -> (CmmLit $ CmmLabel lbl, o)+        CmmRegOff reg o+          | o >= 0 -> (CmmReg reg, o)+        CmmMachOp (MO_Add _) [base, CmmLit (CmmInt o _)]+          | o >= 0 -> (base, fromInteger o)+        _ -> (ptr, 0)+  instrs <- lower_CmmExpr_Typed lbl ty_word ptr'+  pure (instrs, o)++-- | Push a series of values onto the wasm value stack, returning the+-- result stack type.+type family+  WasmPushes (ts :: [WasmType]) (pre :: [WasmType]) ::+    [WasmType]+  where+  WasmPushes '[] pre = pre+  WasmPushes (t : ts) pre = WasmPushes ts (t : pre)++-- | Push the arguments onto the wasm value stack before a ccall.+data SomeWasmPreCCall w where+  SomeWasmPreCCall ::+    TypeList ts ->+    (forall pre. WasmInstr w pre (WasmPushes ts pre)) ->+    SomeWasmPreCCall w++-- | Pop the results into locals after a ccall.+data SomeWasmPostCCall w where+  SomeWasmPostCCall ::+    TypeList ts ->+    (forall post. WasmInstr w (WasmPushes ts post) post) ->+    SomeWasmPostCCall w++-- | Lower an unary homogeneous 'CallishMachOp' to a ccall.+lower_CMO_Un_Homo ::+  CLabel ->+  SymName ->+  [CmmFormal] ->+  [CmmActual] ->+  WasmCodeGenM w (WasmStatements w)+lower_CMO_Un_Homo lbl op [reg] [x] = do+  (ri, SomeWasmType ty) <- onCmmLocalReg reg+  WasmExpr x_instr <- lower_CmmExpr_Typed lbl ty x+  let ty_cmm = localRegType reg+  onFuncSym op [ty_cmm] [ty_cmm]+  pure $+    WasmStatements $+      x_instr `WasmConcat` WasmCCall op `WasmConcat` WasmLocalSet ty ri+lower_CMO_Un_Homo _ _ _ _ = panic "lower_CMO_Un_Homo: unreachable"++-- | Lower an unary homogeneous 'CallishMachOp' to a primitive operation.+lower_CMO_Un_Homo_Prim ::+  CLabel ->+  ( forall pre t.+    WasmTypeTag t ->+    WasmInstr+      w+      (t : pre)+      (t : pre)+  ) ->+  WasmTypeTag t ->+  [CmmFormal] ->+  [CmmActual] ->+  WasmCodeGenM w (WasmStatements w)+lower_CMO_Un_Homo_Prim lbl op ty [reg] [x] = do+  (ri, _) <- onCmmLocalReg reg+  WasmExpr x_instr <- lower_CmmExpr_Typed lbl ty x+  pure $+    WasmStatements $+      x_instr `WasmConcat` op ty `WasmConcat` WasmLocalSet ty ri+lower_CMO_Un_Homo_Prim _ _ _ _ _ = panic "lower_CMO_Bin_Homo_Prim: unreachable"++-- | Lower a binary homogeneous 'CallishMachOp' to a ccall.+lower_CMO_Bin_Homo ::+  CLabel ->+  SymName ->+  [CmmFormal] ->+  [CmmActual] ->+  WasmCodeGenM w (WasmStatements w)+lower_CMO_Bin_Homo lbl op [reg] [x, y] = do+  (ri, SomeWasmType ty) <- onCmmLocalReg reg+  WasmExpr x_instr <- lower_CmmExpr_Typed lbl ty x+  WasmExpr y_instr <- lower_CmmExpr_Typed lbl ty y+  let ty_cmm = localRegType reg+  onFuncSym op [ty_cmm, ty_cmm] [ty_cmm]+  pure $+    WasmStatements $+      x_instr+        `WasmConcat` y_instr+        `WasmConcat` WasmCCall op+        `WasmConcat` WasmLocalSet ty ri+lower_CMO_Bin_Homo _ _ _ _ = panic "lower_CMO_Bin_Homo: unreachable"++-- | Lower a 'MO_UF_Conv' operation.+lower_MO_UF_Conv ::+  CLabel ->+  Width ->+  [CmmFormal] ->+  [CmmActual] ->+  WasmCodeGenM w (WasmStatements w)+lower_MO_UF_Conv lbl W32 [reg] [x] = do+  ri <- onCmmLocalReg_Typed TagF32 reg+  SomeWasmExpr ty0 (WasmExpr x_instr) <- lower_CmmExpr lbl x+  pure $+    WasmStatements $+      x_instr+        `WasmConcat` WasmConvert Unsigned ty0 TagF32+        `WasmConcat` WasmLocalSet TagF32 ri+lower_MO_UF_Conv lbl W64 [reg] [x] = do+  ri <- onCmmLocalReg_Typed TagF64 reg+  SomeWasmExpr ty0 (WasmExpr x_instr) <- lower_CmmExpr lbl x+  pure $+    WasmStatements $+      x_instr+        `WasmConcat` WasmConvert Unsigned ty0 TagF64+        `WasmConcat` WasmLocalSet TagF64 ri+lower_MO_UF_Conv _ _ _ _ = panic "lower_MO_UF_Conv: unreachable"++-- | Lower a 'MO_Cmpxchg' operation to inline assembly. Currently we+-- target wasm without atomics and threads, so it's just lowered to+-- regular memory loads and stores.+lower_MO_Cmpxchg ::+  CLabel ->+  Width ->+  [CmmFormal] ->+  [CmmActual] ->+  WasmCodeGenM w (WasmStatements w)+lower_MO_Cmpxchg lbl w0 [reg] [ptr, expected, new] =+  case someWasmTypeFromCmmType ty_cmm of+    SomeWasmType ty -> do+      reg_i <- onCmmLocalReg_Typed ty reg+      let narrowing = wasmMemoryNarrowing ty ty_cmm+      (WasmExpr ptr_instr, o) <- lower_CmmExpr_Ptr lbl ptr+      WasmExpr expected_instr <- lower_CmmExpr_Typed lbl ty expected+      WasmExpr new_instr <- lower_CmmExpr_Typed lbl ty new+      pure $+        WasmStatements $+          ptr_instr+            `WasmConcat` WasmLoad ty narrowing Unsigned o NaturallyAligned+            `WasmConcat` WasmLocalTee ty reg_i+            `WasmConcat` expected_instr+            `WasmConcat` WasmEq ty+            `WasmConcat` WasmCond+              ( ptr_instr+                  `WasmConcat` new_instr+                  `WasmConcat` WasmStore ty narrowing o NaturallyAligned+              )+  where+    ty_cmm = cmmBits w0+lower_MO_Cmpxchg _ _ _ _ = panic "lower_MO_Cmpxchg: unreachable"++-- | Lower a 'CallishMachOp'.+lower_CallishMachOp ::+  CLabel ->+  CallishMachOp ->+  [CmmFormal] ->+  [CmmActual] ->+  WasmCodeGenM w (WasmStatements w)+lower_CallishMachOp lbl MO_F64_Pwr rs xs = lower_CMO_Bin_Homo lbl "pow" rs xs+lower_CallishMachOp lbl MO_F64_Sin rs xs = lower_CMO_Un_Homo lbl "sin" rs xs+lower_CallishMachOp lbl MO_F64_Cos rs xs = lower_CMO_Un_Homo lbl "cos" rs xs+lower_CallishMachOp lbl MO_F64_Tan rs xs = lower_CMO_Un_Homo lbl "tan" rs xs+lower_CallishMachOp lbl MO_F64_Sinh rs xs = lower_CMO_Un_Homo lbl "sinh" rs xs+lower_CallishMachOp lbl MO_F64_Cosh rs xs = lower_CMO_Un_Homo lbl "cosh" rs xs+lower_CallishMachOp lbl MO_F64_Tanh rs xs = lower_CMO_Un_Homo lbl "tanh" rs xs+lower_CallishMachOp lbl MO_F64_Asin rs xs = lower_CMO_Un_Homo lbl "asin" rs xs+lower_CallishMachOp lbl MO_F64_Acos rs xs = lower_CMO_Un_Homo lbl "acos" rs xs+lower_CallishMachOp lbl MO_F64_Atan rs xs = lower_CMO_Un_Homo lbl "atan" rs xs+lower_CallishMachOp lbl MO_F64_Asinh rs xs = lower_CMO_Un_Homo lbl "asinh" rs xs+lower_CallishMachOp lbl MO_F64_Acosh rs xs = lower_CMO_Un_Homo lbl "acosh" rs xs+lower_CallishMachOp lbl MO_F64_Atanh rs xs = lower_CMO_Un_Homo lbl "atanh" rs xs+lower_CallishMachOp lbl MO_F64_Log rs xs = lower_CMO_Un_Homo lbl "log" rs xs+lower_CallishMachOp lbl MO_F64_Log1P rs xs = lower_CMO_Un_Homo lbl "log1p" rs xs+lower_CallishMachOp lbl MO_F64_Exp rs xs = lower_CMO_Un_Homo lbl "exp" rs xs+lower_CallishMachOp lbl MO_F64_ExpM1 rs xs = lower_CMO_Un_Homo lbl "expm1" rs xs+lower_CallishMachOp lbl MO_F64_Fabs rs xs = lower_CMO_Un_Homo_Prim lbl WasmAbs TagF64 rs xs+lower_CallishMachOp lbl MO_F64_Sqrt rs xs = lower_CMO_Un_Homo_Prim lbl WasmSqrt TagF64 rs xs+lower_CallishMachOp lbl MO_F32_Pwr rs xs = lower_CMO_Bin_Homo lbl "powf" rs xs+lower_CallishMachOp lbl MO_F32_Sin rs xs = lower_CMO_Un_Homo lbl "sinf" rs xs+lower_CallishMachOp lbl MO_F32_Cos rs xs = lower_CMO_Un_Homo lbl "cosf" rs xs+lower_CallishMachOp lbl MO_F32_Tan rs xs = lower_CMO_Un_Homo lbl "tanf" rs xs+lower_CallishMachOp lbl MO_F32_Sinh rs xs = lower_CMO_Un_Homo lbl "sinhf" rs xs+lower_CallishMachOp lbl MO_F32_Cosh rs xs = lower_CMO_Un_Homo lbl "coshf" rs xs+lower_CallishMachOp lbl MO_F32_Tanh rs xs = lower_CMO_Un_Homo lbl "tanhf" rs xs+lower_CallishMachOp lbl MO_F32_Asin rs xs = lower_CMO_Un_Homo lbl "asinf" rs xs+lower_CallishMachOp lbl MO_F32_Acos rs xs = lower_CMO_Un_Homo lbl "acosf" rs xs+lower_CallishMachOp lbl MO_F32_Atan rs xs = lower_CMO_Un_Homo lbl "atanf" rs xs+lower_CallishMachOp lbl MO_F32_Asinh rs xs =+  lower_CMO_Un_Homo lbl "asinhf" rs xs+lower_CallishMachOp lbl MO_F32_Acosh rs xs =+  lower_CMO_Un_Homo lbl "acoshf" rs xs+lower_CallishMachOp lbl MO_F32_Atanh rs xs =+  lower_CMO_Un_Homo lbl "atanhf" rs xs+lower_CallishMachOp lbl MO_F32_Log rs xs = lower_CMO_Un_Homo lbl "logf" rs xs+lower_CallishMachOp lbl MO_F32_Log1P rs xs =+  lower_CMO_Un_Homo lbl "log1pf" rs xs+lower_CallishMachOp lbl MO_F32_Exp rs xs = lower_CMO_Un_Homo lbl "expf" rs xs+lower_CallishMachOp lbl MO_F32_ExpM1 rs xs =+  lower_CMO_Un_Homo lbl "expm1f" rs xs+lower_CallishMachOp lbl MO_F32_Fabs rs xs = lower_CMO_Un_Homo_Prim lbl WasmAbs TagF32 rs xs+lower_CallishMachOp lbl MO_F32_Sqrt rs xs = lower_CMO_Un_Homo_Prim lbl WasmSqrt TagF32 rs xs+lower_CallishMachOp lbl (MO_UF_Conv w0) rs xs = lower_MO_UF_Conv lbl w0 rs xs+lower_CallishMachOp _ MO_AcquireFence _ _ = pure $ WasmStatements WasmNop+lower_CallishMachOp _ MO_ReleaseFence _ _ = pure $ WasmStatements WasmNop+lower_CallishMachOp _ MO_SeqCstFence _ _ = pure $ WasmStatements WasmNop+lower_CallishMachOp _ MO_Touch _ _ = pure $ WasmStatements WasmNop+lower_CallishMachOp _ (MO_Prefetch_Data {}) _ _ = pure $ WasmStatements WasmNop+lower_CallishMachOp lbl (MO_Memcpy {}) [] xs = do+  ty_word_cmm <- wasmWordCmmTypeM+  lower_CmmUnsafeForeignCall_Drop lbl "memcpy" ty_word_cmm xs+lower_CallishMachOp lbl (MO_Memset {}) [] xs = do+  ty_word_cmm <- wasmWordCmmTypeM+  lower_CmmUnsafeForeignCall_Drop lbl "memset" ty_word_cmm xs+lower_CallishMachOp lbl (MO_Memmove {}) [] xs = do+  ty_word_cmm <- wasmWordCmmTypeM+  lower_CmmUnsafeForeignCall_Drop lbl "memmove" ty_word_cmm xs+lower_CallishMachOp lbl (MO_Memcmp {}) rs xs =+  lower_CmmUnsafeForeignCall+    lbl+    (Left "memcmp")+    Nothing+    CmmMayReturn+    rs+    xs+lower_CallishMachOp lbl (MO_PopCnt w0) rs xs =+  lower_CmmUnsafeForeignCall+    lbl+    (Left $ fromString $ "hs_popcnt" <> show (widthInBits w0))+    Nothing+    CmmMayReturn+    rs+    xs+lower_CallishMachOp lbl (MO_Pdep w0) rs xs =+  lower_CmmUnsafeForeignCall+    lbl+    (Left $ fromString $ "hs_pdep" <> show (widthInBits w0))+    Nothing+    CmmMayReturn+    rs+    xs+lower_CallishMachOp lbl (MO_Pext w0) rs xs =+  lower_CmmUnsafeForeignCall+    lbl+    (Left $ fromString $ "hs_pext" <> show (widthInBits w0))+    Nothing+    CmmMayReturn+    rs+    xs+lower_CallishMachOp lbl (MO_Clz w0) rs xs =+  lower_CmmUnsafeForeignCall+    lbl+    (Left $ fromString $ "hs_clz" <> show (widthInBits w0))+    Nothing+    CmmMayReturn+    rs+    xs+lower_CallishMachOp lbl (MO_Ctz w0) rs xs =+  lower_CmmUnsafeForeignCall+    lbl+    (Left $ fromString $ "hs_ctz" <> show (widthInBits w0))+    Nothing+    CmmMayReturn+    rs+    xs+lower_CallishMachOp lbl (MO_BSwap w0) rs xs =+  lower_CmmUnsafeForeignCall+    lbl+    (Left $ fromString $ "hs_bswap" <> show (widthInBits w0))+    Nothing+    CmmMayReturn+    rs+    xs+lower_CallishMachOp lbl (MO_BRev w0) rs xs =+  lower_CmmUnsafeForeignCall+    lbl+    (Left $ fromString $ "hs_bitrev" <> show (widthInBits w0))+    Nothing+    CmmMayReturn+    rs+    xs+lower_CallishMachOp lbl (MO_AtomicRMW w0 op) rs xs =+  lower_CmmUnsafeForeignCall+    lbl+    ( Left $+        fromString $+          ( case op of+              AMO_Add -> "hs_atomic_add"+              AMO_Sub -> "hs_atomic_sub"+              AMO_And -> "hs_atomic_and"+              AMO_Nand -> "hs_atomic_nand"+              AMO_Or -> "hs_atomic_or"+              AMO_Xor -> "hs_atomic_xor"+          )+            <> show (widthInBits w0)+    )+    Nothing+    CmmMayReturn+    rs+    xs+lower_CallishMachOp lbl (MO_AtomicRead w0 _) [reg] [ptr] = do+  SomeWasmExpr ty (WasmExpr ret_instr) <-+    lower_CmmLoad+      lbl+      ptr+      (cmmBits w0)+      NaturallyAligned+  ri <- onCmmLocalReg_Typed ty reg+  pure $ WasmStatements $ ret_instr `WasmConcat` WasmLocalSet ty ri+lower_CallishMachOp lbl (MO_AtomicWrite _ _) [] [ptr, val] =+  lower_CmmStore lbl ptr val NaturallyAligned+lower_CallishMachOp lbl (MO_Cmpxchg w0) rs xs = lower_MO_Cmpxchg lbl w0 rs xs+lower_CallishMachOp lbl (MO_Xchg w0) rs xs =+  lower_CmmUnsafeForeignCall+    lbl+    (Left $ fromString $ "hs_xchg" <> show (widthInBits w0))+    Nothing+    CmmMayReturn+    rs+    xs+lower_CallishMachOp lbl MO_SuspendThread rs xs =+  lower_CmmUnsafeForeignCall+    lbl+    (Left "suspendThread")+    Nothing+    CmmMayReturn+    rs+    xs+lower_CallishMachOp lbl MO_ResumeThread rs xs =+  lower_CmmUnsafeForeignCall+    lbl+    (Left "resumeThread")+    Nothing+    CmmMayReturn+    rs+    xs+lower_CallishMachOp _ _ _ _ = panic "lower_CallishMachOp: unreachable"++-- | Lower a ccall, but drop the result by assigning it to an unused+-- local. This is only used for lowering 'MO_Memcpy' and such, where+-- the libc functions do have a return value, but the corresponding+-- 'CallishMachOp' does not expect one.+lower_CmmUnsafeForeignCall_Drop ::+  CLabel ->+  SymName ->+  CmmType ->+  [CmmActual] ->+  WasmCodeGenM w (WasmStatements w)+lower_CmmUnsafeForeignCall_Drop lbl sym_callee ret_cmm_ty arg_exprs = do+  ret_uniq <- getUniqueM+  let ret_local = LocalReg ret_uniq ret_cmm_ty+  lower_CmmUnsafeForeignCall+    lbl+    (Left sym_callee)+    Nothing+    CmmMayReturn+    [ret_local]+    arg_exprs++-- | Lower a 'CmmUnsafeForeignCall'. The target is 'Either' a symbol,+-- which translates to a direct @call@, or an expression, which+-- translates to a @call_indirect@. The callee function signature is+-- inferred from the passed in arguments here.+lower_CmmUnsafeForeignCall ::+  CLabel ->+  (Either SymName CmmExpr) ->+  Maybe+    ([ForeignHint], [ForeignHint]) ->+  CmmReturnInfo ->+  [CmmFormal] ->+  [CmmActual] ->+  WasmCodeGenM w (WasmStatements w)+lower_CmmUnsafeForeignCall lbl target mb_hints ret_info ret_locals arg_exprs = do+  platform <- wasmPlatformM+  SomeWasmPreCCall arg_tys args_instr <-+    foldrM+      ( \(arg_expr, arg_hint) (SomeWasmPreCCall acc_tys acc_instr) -> do+          SomeWasmExpr arg_ty arg_wasm_expr <- lower_CmmExpr lbl arg_expr+          let WasmExpr arg_instr = case arg_hint of+                SignedHint ->+                  extendSubword+                    (cmmExprWidth platform arg_expr)+                    arg_ty+                    arg_wasm_expr+                _ -> arg_wasm_expr+          pure $+            SomeWasmPreCCall (arg_ty `TypeListCons` acc_tys) $+              arg_instr `WasmConcat` acc_instr+      )+      (SomeWasmPreCCall TypeListNil WasmNop)+      arg_exprs_hints+  SomeWasmPostCCall ret_tys ret_instr <-+    foldrM+      ( \(reg, ret_hint) (SomeWasmPostCCall acc_tys acc_instr) -> do+          (reg_i, SomeWasmType reg_ty) <- onCmmLocalReg reg+          pure $+            SomeWasmPostCCall (reg_ty `TypeListCons` acc_tys) $+              case (# ret_hint, cmmRegWidth $ CmmLocal reg #) of+                (# SignedHint, W8 #) ->+                  acc_instr+                    `WasmConcat` WasmConst reg_ty 0xFF+                    `WasmConcat` WasmAnd reg_ty+                    `WasmConcat` WasmLocalSet reg_ty reg_i+                (# SignedHint, W16 #) ->+                  acc_instr+                    `WasmConcat` WasmConst reg_ty 0xFFFF+                    `WasmConcat` WasmAnd reg_ty+                    `WasmConcat` WasmLocalSet reg_ty reg_i+                _ -> acc_instr `WasmConcat` WasmLocalSet reg_ty reg_i+      )+      (SomeWasmPostCCall TypeListNil WasmNop)+      ret_locals_hints+  case target of+    Left sym_callee -> do+      platform <- wasmPlatformM+      let arg_cmm_tys = map (cmmExprType platform) arg_exprs+          ret_cmm_tys = map localRegType ret_locals+      onFuncSym sym_callee arg_cmm_tys ret_cmm_tys+      pure $+        WasmStatements $+          args_instr+            `WasmConcat` WasmCCall sym_callee+            `WasmConcat` ( case ret_info of+                             CmmMayReturn -> ret_instr+                             CmmNeverReturns -> WasmUnreachable+                         )+    Right fptr_callee -> do+      (WasmExpr instr_callee, _) <- lower_CmmExpr_Ptr lbl fptr_callee+      pure $+        WasmStatements $+          args_instr+            `WasmConcat` instr_callee+            `WasmConcat` WasmCCallIndirect arg_tys ret_tys+            `WasmConcat` ( case ret_info of+                             CmmMayReturn -> ret_instr+                             CmmNeverReturns -> WasmUnreachable+                         )+  where+    (# arg_exprs_hints, ret_locals_hints #) = case mb_hints of+      Just (arg_hints, ret_hints) ->+        (# zip arg_exprs arg_hints, zip ret_locals ret_hints #)+      _ -> (# map (,NoHint) arg_exprs, map (,NoHint) ret_locals #)++-- | Lower a 'CmmStore'.+lower_CmmStore ::+  CLabel ->+  CmmExpr ->+  CmmExpr ->+  AlignmentSpec ->+  WasmCodeGenM+    w+    (WasmStatements w)+lower_CmmStore lbl ptr val align = do+  platform <- wasmPlatformM+  (WasmExpr ptr_instr, o) <- lower_CmmExpr_Ptr lbl ptr+  let ty_cmm = cmmExprType platform val+  SomeWasmExpr ty (WasmExpr val_instr) <- lower_CmmExpr lbl val+  pure $+    WasmStatements $+      ptr_instr+        `WasmConcat` val_instr+        `WasmConcat` WasmStore ty (wasmMemoryNarrowing ty ty_cmm) o align++-- | Lower a single Cmm action.+lower_CmmAction :: CLabel -> CmmNode O O -> WasmCodeGenM w (WasmStatements w)+lower_CmmAction lbl act = do+  ty_word <- wasmWordTypeM+  platform <- wasmPlatformM+  case act of+    CmmComment {} -> pure $ WasmStatements WasmNop+    CmmTick {} -> pure $ WasmStatements WasmNop+    CmmUnwind {} -> pure $ WasmStatements WasmNop+    CmmAssign (CmmLocal reg) e -> do+      (i, SomeWasmType ty_reg) <- onCmmLocalReg reg+      WasmExpr instrs <- lower_CmmExpr_Typed lbl ty_reg e+      pure $ WasmStatements $ instrs `WasmConcat` WasmLocalSet ty_reg i+    CmmAssign (CmmGlobal (GlobalRegUse reg _)) e+      | BaseReg <- reg -> pure $ WasmStatements WasmNop+      | Just (sym_global, SomeWasmType ty_reg) <-+          globalInfoFromCmmGlobalReg ty_word reg -> do+          WasmExpr instrs <- lower_CmmExpr_Typed lbl ty_reg e+          pure $+            WasmStatements $+              instrs `WasmConcat` WasmGlobalSet ty_reg sym_global+      | otherwise -> do+          (WasmExpr ptr_instr, o) <-+            lower_CmmExpr_Ptr lbl $ get_GlobalReg_addr platform reg+          SomeWasmExpr ty_e (WasmExpr instrs) <- lower_CmmExpr lbl e+          pure $+            WasmStatements $+              ptr_instr+                `WasmConcat` instrs+                `WasmConcat` WasmStore ty_e Nothing o NaturallyAligned+    CmmStore ptr val align -> lower_CmmStore lbl ptr val align+    CmmUnsafeForeignCall+      ( ForeignTarget+          (CmmLit (CmmLabel lbl_callee))+          (ForeignConvention conv arg_hints ret_hints ret_info)+        )+      ret_locals+      arg_exprs+        | conv `elem` [CCallConv, CApiConv] ->+            lower_CmmUnsafeForeignCall+              lbl+              (Left $ symNameFromCLabel lbl_callee)+              (Just (arg_hints, ret_hints))+              ret_info+              ret_locals+              arg_exprs+    CmmUnsafeForeignCall+      (ForeignTarget target_expr (ForeignConvention conv arg_hints ret_hints ret_info))+      ret_locals+      arg_exprs+        | conv `elem` [CCallConv, CApiConv] ->+            lower_CmmUnsafeForeignCall+              lbl+              (Right target_expr)+              (Just (arg_hints, ret_hints))+              ret_info+              ret_locals+              arg_exprs+    CmmUnsafeForeignCall (PrimTarget op) ret_locals arg_exprs ->+      lower_CallishMachOp lbl op ret_locals arg_exprs+    _ -> panic "lower_CmmAction: unreachable"++-- | Lower a block of Cmm actions.+lower_CmmActions ::+  CLabel ->+  Label ->+  Block CmmNode O O ->+  WasmCodeGenM+    w+    (WasmStatements w)+lower_CmmActions lbl _ blk =+  foldlM+    ( \(WasmStatements acc) act ->+        (\(WasmStatements stmts) -> WasmStatements $ acc `WasmConcat` stmts)+          <$> lower_CmmAction lbl act+    )+    (WasmStatements WasmNop)+    acts+  where+    acts = blockToList blk++-- | Lower a 'CmmGraph'.+lower_CmmGraph :: CLabel -> CmmGraph -> WasmCodeGenM w (FuncBody w)+lower_CmmGraph lbl g = do+  ty_word <- wasmWordTypeM+  platform <- wasmPlatformM+  body <-+    structuredControl+      platform+      (\_ -> lower_CmmExpr_Typed lbl ty_word)+      (lower_CmmActions lbl)+      g+  locals <- wasmStateM $ \s ->+    (#+      map snd $ detEltsUFM $ localRegs s,+      s {localRegs = emptyUFM, localRegsCount = 0}+    #)+  pure FuncBody {funcLocals = locals, funcBody = wasmControlCast $ body}++-- | Invoked once for each 'CLabel' which indexes a 'CmmData' or+-- 'CmmProc'.+onTopSym :: CLabel -> WasmCodeGenM w ()+onTopSym lbl = case sym_vis of+  SymDefault -> wasmModifyM $ \s ->+    s+      { defaultSyms =+          insertUniqueSet+            (getUnique sym)+            $ defaultSyms s+      }+  _ -> pure ()+  where+    sym = symNameFromCLabel lbl++    sym_vis = symVisibilityFromCLabel lbl++-- | Invoked for each function 'CLabel' with known type (e.g. a+-- 'CmmProc', or callee of 'CmmUnsafeForeignCall').+onFuncSym :: SymName -> [CmmType] -> [CmmType] -> WasmCodeGenM w ()+onFuncSym sym arg_tys ret_tys = wasmModifyM $+  \s@WasmCodeGenState {..} ->+    s+      { funcTypes =+          addToUniqMap+            funcTypes+            sym+            ( map someWasmTypeFromCmmType arg_tys,+              map someWasmTypeFromCmmType ret_tys+            )+      }++-- | Invoked for all other 'CLabel's along the way, e.g. in+-- 'CmmStatic's or 'CmmExpr's.+onAnySym :: CLabel -> WasmCodeGenM w ()+onAnySym lbl = case sym_kind of+  SymFunc -> do+    ty_word <- wasmWordTypeM+    wasmModifyM $ \s@WasmCodeGenState {..} ->+      s {funcTypes = addToUniqMap_C const funcTypes sym ([], [SomeWasmType ty_word])}+  _ -> pure ()+  where+    sym = symNameFromCLabel lbl++    sym_kind = symKindFromCLabel lbl++-- | Invoked for each 'LocalReg', returning its wasm local id and+-- representation type.+onCmmLocalReg :: LocalReg -> WasmCodeGenM w LocalInfo+onCmmLocalReg reg = wasmStateM $ \s@WasmCodeGenState {..} ->+  let reg_info =+        (localRegsCount, someWasmTypeFromCmmType $ localRegType reg)+   in case addToUFM_L (\_ i _ -> i) reg reg_info localRegs of+        (Just i, _) -> (# i, s #)+        (_, localRegs') ->+          (#+            reg_info,+            s+              { localRegs = localRegs',+                localRegsCount =+                  localRegsCount + 1+              }+          #)++-- | Invoked for each 'LocalReg' with expected representation type,+-- only returning its wasm local id.+onCmmLocalReg_Typed :: WasmTypeTag t -> LocalReg -> WasmCodeGenM w Int+onCmmLocalReg_Typed ty reg = do+  (i, SomeWasmType ty') <- onCmmLocalReg reg+  if+      | Just Refl <- ty' `testEquality` ty -> pure i+      | otherwise -> panic "onCmmLocalReg_Typed: unreachable"++-- | Invoked for dtors. We don't bother to implement dtors yet;+-- there's no native @.fini_array@ support for wasm, and the way+-- @clang@ handles dtors is generating a ctor that calls @atexit()@+-- for dtors. Which makes some sense, but we don't need to do the same+-- thing yet.+onFini :: [SymName] -> WasmCodeGenM w ()+onFini syms = do+  let n_finis = length syms+  when (n_finis /= 0) $ panic "dtors unsupported by wasm32 NCG"++-- | Invoked for ctors and dtors.+onCmmInitFini :: InitOrFini -> [CLabel] -> WasmCodeGenM w ()+onCmmInitFini iof lbls = do+  for_ lbls $ \lbl -> onFuncSym (symNameFromCLabel lbl) [] []+  case iof of+    IsInitArray -> wasmModifyM $ \s -> s {ctors = syms <> ctors s}+    IsFiniArray -> onFini syms+  where+    syms = map symNameFromCLabel lbls++-- | Invoked for each data section.+onCmmData :: CLabel -> Section -> [CmmStatic] -> WasmCodeGenM w ()+onCmmData lbl s statics = do+  ty_word <- wasmWordTypeM+  onTopSym lbl+  cs <- for statics lower_CmmStatic+  let sym = symNameFromCLabel lbl+      sec =+        DataSection+          { dataSectionKind =+              dataSectionKindFromCmmSection s,+            dataSectionAlignment =+              alignmentFromCmmSection ty_word cs,+            dataSectionContents =+              case cs of+                [DataASCII buf] -> [DataASCII $ buf `BS.snoc` 0]+                [DataIncBin p l] -> [DataIncBin p l, DataI8 0]+                _ -> cs+          }+  wasmModifyM $ \s ->+    s+      { dataSections =+          addToUniqMap (dataSections s) sym sec+      }++-- | Invoked for each 'CmmProc'.+onCmmProc :: CLabel -> CmmGraph -> WasmCodeGenM w ()+onCmmProc lbl g = do+  ty_word <- wasmWordCmmTypeM+  onTopSym lbl+  onFuncSym sym [] [ty_word]+  body <- lower_CmmGraph lbl g+  wasmModifyM $ \s -> s {funcBodies = addToUniqMap (funcBodies s) sym body}+  where+    sym = symNameFromCLabel lbl++-- | Invoked for each 'RawCmmDecl'.+onCmmDecl :: RawCmmDecl -> WasmCodeGenM w ()+onCmmDecl decl+  | Just (iof, lbls) <- isInitOrFiniArray decl = onCmmInitFini iof lbls+onCmmDecl (CmmData s (CmmStaticsRaw lbl statics)) = onCmmData lbl s statics+onCmmDecl (CmmProc _ lbl _ g) = onCmmProc lbl g++-- | Invoked for each 'RawCmmGroup'.+onCmmGroup :: RawCmmGroup -> WasmCodeGenM w ()+onCmmGroup cmms = wasmStateM $ \s0 ->+  (# (), foldl' (\s cmm -> wasmExecM (onCmmDecl cmm) s) s0 cmms #)
+ GHC/CmmToAsm/Wasm/Types.hs view
@@ -0,0 +1,522 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE Strict #-}+{-# LANGUAGE TypeFamilyDependencies #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE UndecidableInstances #-}++module GHC.CmmToAsm.Wasm.Types+  ( WasmType (..),+    WasmTypeTag (..),+    SomeWasmType (..),+    TypeList (..),+    someWasmTypesFromTypeList,+    WasmFunctionType (..),+    SymName (..),+    SymVisibility (..),+    SymKind (..),+    DataSectionKind (..),+    DataSectionContent (..),+    DataSection (..),+    GlobalInfo,+    LocalInfo,+    FuncBody (..),+    Signage (..),+    WasmInstr (..),+    WasmExpr (..),+    SomeWasmExpr (..),+    WasmStatements (..),+    WasmControl (..),+    BrTableInterval (..),+    wasmControlCast,+    WasmCodeGenState (..),+    initialWasmCodeGenState,+    WasmCodeGenM (..),+    wasmGetsM,+    wasmPlatformM,+    wasmWordTypeM,+    wasmWordCmmTypeM,+    wasmStateM,+    wasmModifyM,+    wasmExecM,+    wasmRunM,+    WasmAsmConfig (..),+    defaultWasmAsmConfig+  )+where++import Control.Applicative+import Data.ByteString (ByteString)+import Data.Coerce+import Data.Functor+import Data.Kind+import Data.String+import Data.Type.Equality+import Data.Word+import GHC.Cmm+import GHC.Data.FastString+import GHC.Float+import GHC.Platform+import GHC.Prelude+import GHC.Types.Basic+import GHC.Types.Unique+import GHC.Types.Unique.FM+import GHC.Types.Unique.Map+import GHC.Types.Unique.Set+import GHC.Types.Unique.DSM+import GHC.Utils.Monad.State.Strict+import GHC.Utils.Outputable hiding ((<>))+import Unsafe.Coerce++-- | WebAssembly type of a WebAssembly value that WebAssembly code+-- could either expect on the evaluation stack or leave on the+-- evaluation stack.+data WasmType = I32 | I64 | F32 | F64++-- | Singleton type useful for programming with `WasmType` at the type+-- level.+data WasmTypeTag :: WasmType -> Type where+  TagI32 :: WasmTypeTag 'I32+  TagI64 :: WasmTypeTag 'I64+  TagF32 :: WasmTypeTag 'F32+  TagF64 :: WasmTypeTag 'F64++deriving instance Show (WasmTypeTag t)++instance TestEquality WasmTypeTag where+  TagI32 `testEquality` TagI32 = Just Refl+  TagI64 `testEquality` TagI64 = Just Refl+  TagF32 `testEquality` TagF32 = Just Refl+  TagF64 `testEquality` TagF64 = Just Refl+  _ `testEquality` _ = Nothing++data SomeWasmType where+  SomeWasmType :: WasmTypeTag t -> SomeWasmType++instance Eq SomeWasmType where+  SomeWasmType ty0 == SomeWasmType ty1+    | Just Refl <- ty0 `testEquality` ty1 = True+    | otherwise = False++-- | List of WebAssembly types used to describe the sequence of+-- WebAssembly values that a block of code may expect on the stack or+-- leave on the stack.+data TypeList :: [WasmType] -> Type where+  TypeListNil :: TypeList '[]+  TypeListCons :: WasmTypeTag t -> TypeList ts -> TypeList (t : ts)++someWasmTypesFromTypeList :: TypeList ts -> [SomeWasmType]+someWasmTypesFromTypeList TypeListNil = []+someWasmTypesFromTypeList (ty `TypeListCons` tys) =+  SomeWasmType ty : someWasmTypesFromTypeList tys++-- | The type of a WebAssembly function, loop, block, or conditional.+-- This type says what values the code expects to pop off the stack+-- and what values it promises to push.  The WebAssembly standard+-- requires that this type appear explicitly in the code.+data WasmFunctionType pre post = WasmFunctionType {ft_pops :: TypeList pre, ft_pushes :: TypeList post}++-- | For simplicity, we record other metadata in 'WasmCodeGenState' by+-- need, instead of carrying them along with 'SymName'.+newtype SymName = SymName FastString+  deriving (Eq, IsString, Show, Uniquable) via FastString+  deriving (Ord) via LexicalFastString++data SymVisibility+  = -- | Not defined in the current compilation unit.+    --+    -- @[ undefined binding=global vis=default ]@+    SymUndefined+  | -- | Defined, not visible to other compilation units.+    --+    -- @[ binding=local vis=default ]@+    SymStatic+  | -- | Defined, visible to other compilation units.+    --+    -- Adds @.globl@ directives in the output assembly. Also adds+    -- @.hidden@ when not generating PIC code, similar to+    -- -fvisibility=hidden in clang.+    --+    -- @[ binding=global vis=hidden ]@+    SymDefault++-- | Represents whether a symbol is a data symbol or a function+-- symbol. Unlike linkers for other targets, @wasm-ld@ does panic at+-- link-time if it finds symbol kind inconsistency between the+-- definition site and other use sites.+--+-- Currently we solely rely on 'isCFunctionLabel' to determine a+-- symbol's kind, but it does take extra effort to make it work. The+-- main source of inconsistency arises from hand-written Cmm sources,+-- where it's possible to refer to external entities like @xxx_info@+-- and @xxx_closure@ without explicit @import CLOSURE@ declarations.+-- The Cmm parser will implicitly assume those are foreign function+-- labels, and then this will break the WebAssembly backend. #22368+-- provides more context on this issue.+--+-- tl;dr for any GHC contributor that accidentally triggers @wasm-ld@+-- errors when hacking Cmm: whatever data symbols are used in new+-- code, just add the corresponding @import CLOSURE@ declarations at+-- the top of that Cmm file.+data SymKind = SymData | SymFunc+  deriving (Eq)++-- | WebAssembly doesn't really have proper read-only memory regions+-- yet. Neverthless we add the .rodata logic here, wasm-ld will+-- aggregate all .rodata sections into a single one, which adds+-- possibility for runtime checks later, either via a customized+-- runtime, or via code instrumentation. See+-- <https://github.com/llvm/llvm-project/blob/b296aed8ae239c20ebdd7969e978f8d2a3b9c178/lld/wasm/Writer.cpp#L856>+data DataSectionKind = SectionData | SectionROData++-- | Neither Cmm or Wasm type system takes integer signedness into+-- account, therefore we always round up a 'CmmLit' to the right width+-- and handle it as an untyped integer.+data DataSectionContent+  = DataI8 Word8+  | DataI16 Word16+  | DataI32 Word32+  | DataI64 Word64+  | DataF32 Float+  | DataF64 Double+  | DataSym SymName Int+  | DataSkip Int+  | DataASCII ByteString+  | DataIncBin FilePath Int++data DataSection = DataSection+  { dataSectionKind :: DataSectionKind,+    dataSectionAlignment ::+      Alignment,+    dataSectionContents :: [DataSectionContent]+  }++-- | We need to remember the symbols. Determinism is achieved by+-- sorting symbols before writing the assembly.+type SymMap = UniqMap SymName++-- | No need to remember the symbols.+type SymSet = UniqueSet++type GlobalInfo = (SymName, SomeWasmType)++type LocalInfo = (Int, SomeWasmType)++data FuncBody w = FuncBody+  { funcLocals :: [SomeWasmType],+    -- | Most are Cmm functions, but may also contain synthesized+    -- function of other types, sigh.+    funcBody :: WasmControl (WasmStatements w) (WasmExpr w w) '[] '[w]+  }++data Signage = Signed | Unsigned++-- | The @w@ type variable in the Wasm IR stands for "platform word+-- type", so 'TagI32' on wasm32, and 'TagI64' on wasm64. This way, we+-- can make the codegen logic work on both wasm32/wasm64 in a+-- type-safe manner.+data WasmInstr :: WasmType -> [WasmType] -> [WasmType] -> Type where+  WasmComment :: String -> WasmInstr w pre pre+  WasmNop :: WasmInstr w pre pre+  WasmDrop :: WasmInstr w (t : pre) pre+  WasmUnreachable :: WasmInstr w pre post+  WasmConst :: WasmTypeTag t -> Integer -> WasmInstr w pre (t : pre)+  WasmSymConst :: SymName -> WasmInstr w pre (w : pre)+  WasmLoad ::+    WasmTypeTag t ->+    Maybe Int ->+    Signage ->+    Int ->+    AlignmentSpec ->+    WasmInstr w (w : pre) (t : pre)+  WasmStore ::+    WasmTypeTag t ->+    Maybe Int ->+    Int ->+    AlignmentSpec ->+    WasmInstr+      w+      (t : w : pre)+      pre+  WasmGlobalGet :: WasmTypeTag t -> SymName -> WasmInstr w pre (t : pre)+  WasmGlobalSet :: WasmTypeTag t -> SymName -> WasmInstr w (t : pre) pre+  WasmLocalGet :: WasmTypeTag t -> Int -> WasmInstr w pre (t : pre)+  WasmLocalSet :: WasmTypeTag t -> Int -> WasmInstr w (t : pre) pre+  WasmLocalTee :: WasmTypeTag t -> Int -> WasmInstr w (t : pre) (t : pre)+  WasmCCall :: SymName -> WasmInstr w pre post+  WasmCCallIndirect ::+    TypeList arg_tys ->+    TypeList ret_tys ->+    WasmInstr+      w+      (w : pre)+      post+  WasmConcat ::+    WasmInstr w pre mid ->+    WasmInstr w mid post ->+    WasmInstr w pre post+  WasmReinterpret ::+    WasmTypeTag t0 ->+    WasmTypeTag t1 ->+    WasmInstr+      w+      (t0 : pre)+      (t1 : pre)+  WasmTruncSat ::+    Signage ->+    WasmTypeTag t0 ->+    WasmTypeTag t1 ->+    WasmInstr+      w+      (t0 : pre)+      (t1 : pre)+  WasmConvert ::+    Signage ->+    WasmTypeTag t0 ->+    WasmTypeTag t1 ->+    WasmInstr+      w+      (t0 : pre)+      (t1 : pre)+  WasmAdd :: WasmTypeTag t -> WasmInstr w (t : t : pre) (t : pre)+  WasmSub :: WasmTypeTag t -> WasmInstr w (t : t : pre) (t : pre)+  WasmMul :: WasmTypeTag t -> WasmInstr w (t : t : pre) (t : pre)+  WasmDiv :: Signage -> WasmTypeTag t -> WasmInstr w (t : t : pre) (t : pre)+  WasmRem :: Signage -> WasmTypeTag t -> WasmInstr w (t : t : pre) (t : pre)+  WasmAnd :: WasmTypeTag t -> WasmInstr w (t : t : pre) (t : pre)+  WasmOr :: WasmTypeTag t -> WasmInstr w (t : t : pre) (t : pre)+  WasmXor :: WasmTypeTag t -> WasmInstr w (t : t : pre) (t : pre)+  WasmEq :: WasmTypeTag t -> WasmInstr w (t : t : pre) (w : pre)+  WasmNe :: WasmTypeTag t -> WasmInstr w (t : t : pre) (w : pre)+  WasmLt :: Signage -> WasmTypeTag t -> WasmInstr w (t : t : pre) (w : pre)+  WasmGt :: Signage -> WasmTypeTag t -> WasmInstr w (t : t : pre) (w : pre)+  WasmLe :: Signage -> WasmTypeTag t -> WasmInstr w (t : t : pre) (w : pre)+  WasmGe :: Signage -> WasmTypeTag t -> WasmInstr w (t : t : pre) (w : pre)+  WasmShl :: WasmTypeTag t -> WasmInstr w (t : t : pre) (t : pre)+  WasmShr :: Signage -> WasmTypeTag t -> WasmInstr w (t : t : pre) (t : pre)+  WasmI32Extend8S :: WasmInstr w ('I32 : pre) ('I32 : pre)+  WasmI32Extend16S :: WasmInstr w ('I32 : pre) ('I32 : pre)+  WasmI64Extend8S :: WasmInstr w ('I64 : pre) ('I64 : pre)+  WasmI64Extend16S :: WasmInstr w ('I64 : pre) ('I64 : pre)+  WasmI64Extend32S :: WasmInstr w ('I64 : pre) ('I64 : pre)+  WasmI64ExtendI32 :: Signage -> WasmInstr w ('I32 : pre) ('I64 : pre)+  WasmI32WrapI64 :: WasmInstr w ('I64 : pre) ('I32 : pre)+  WasmF32DemoteF64 :: WasmInstr w ('F64 : pre) ('F32 : pre)+  WasmF64PromoteF32 :: WasmInstr w ('F32 : pre) ('F64 : pre)+  WasmAbs :: WasmTypeTag t -> WasmInstr w (t : pre) (t : pre)+  WasmSqrt :: WasmTypeTag t -> WasmInstr w (t : pre) (t : pre)+  WasmNeg :: WasmTypeTag t -> WasmInstr w (t : pre) (t : pre)+  WasmMin :: WasmTypeTag t -> WasmInstr w (t : t : pre) (t : pre)+  WasmMax :: WasmTypeTag t -> WasmInstr w (t : t : pre) (t : pre)+  WasmCond :: WasmInstr w pre pre -> WasmInstr w (w : pre) pre++newtype WasmExpr w t = WasmExpr (forall pre. WasmInstr w pre (t : pre))++data SomeWasmExpr w where+  SomeWasmExpr :: WasmTypeTag t -> WasmExpr w t -> SomeWasmExpr w++newtype WasmStatements w = WasmStatements (forall pre. WasmInstr w pre pre)++-- | Representation of WebAssembly control flow.+-- Normally written as+-- @+--   WasmControl s e pre post+-- @+-- Type parameter `s` is the type of (unspecified) statements.+-- It might be instantiated with an open Cmm block or with a sequence+-- of Wasm instructions.+-- Parameter `e` is the type of expressions.+-- Parameter `pre` represents the values that are expected on the+-- WebAssembly stack when the code runs, and `post` represents+-- the state of the stack on completion.+data WasmControl :: Type -> Type -> [WasmType] -> [WasmType] -> Type where+  WasmPush :: WasmTypeTag t -> e -> WasmControl s e stack (t : stack)+  WasmBlock ::+    WasmFunctionType pre post ->+    WasmControl s e pre post ->+    WasmControl s e pre post+  WasmLoop ::+    WasmFunctionType pre post ->+    WasmControl s e pre post ->+    WasmControl s e pre post+  WasmIfTop ::+    WasmFunctionType pre post ->+    WasmControl s e pre post ->+    WasmControl s e pre post ->+    WasmControl s e ('I32 : pre) post+  WasmBr :: Int -> WasmControl s e dropped destination -- not typechecked+  WasmFallthrough :: WasmControl s e dropped destination+  -- generates no code, but has the same type as a branch+  WasmBrTable ::+    e ->+    BrTableInterval -> -- for testing+    [Int] -> -- targets+    Int -> -- default target+    WasmControl s e dropped destination+  -- invariant: the table interval is contained+  -- within [0 .. pred (length targets)]++  -- Note [WasmTailCall]+  -- ~~~~~~~~~~~~~~~~~~~+  -- This represents the exit point of each CmmGraph: tail calling the+  -- destination in CmmCall. The STG stack may grow before the call,+  -- but it's always a tail call in the sense that the C call stack is+  -- guaranteed not to grow.+  --+  -- In the wasm backend, WasmTailCall is lowered to different+  -- assembly code given whether the wasm tail-call extension is+  -- enabled:+  --+  -- When tail-call is not enabled (which is the default as of today),+  -- a WasmTailCall is lowered to code that pushes the callee function+  -- pointer onto the value stack and returns immediately. The actual+  -- call is done by the trampoline in StgRun.+  --+  -- When tail-call is indeed enabled via passing -mtail-call in+  -- CONF_CC_OPTS_STAGE2 at configure time, a WasmTailCall is lowered+  -- to return_call/return_call_indirect, thus tail calling into its+  -- callee without returning to StgRun.+  WasmTailCall ::+    e ->+    WasmControl s e t1star t2star -- as per type system+  WasmActions ::+    s ->+    WasmControl s e stack stack -- basic block: one entry, one exit+  WasmSeq ::+    WasmControl s e pre mid ->+    WasmControl s e mid post ->+    WasmControl s e pre post++data BrTableInterval = BrTableInterval {bti_lo :: Integer, bti_count :: Integer}+  deriving (Show)++instance Outputable BrTableInterval where+  ppr range =+    brackets $+      hcat+        [integer (bti_lo range), text "..", integer hi]+    where+      hi = bti_lo range + bti_count range - 1++wasmControlCast :: WasmControl s e pre post -> WasmControl s e pre' post'+wasmControlCast = unsafeCoerce++data WasmCodeGenState w = WasmCodeGenState+  { -- | Target platform+    wasmPlatform :: Platform,+    -- | Defined symbols with 'SymDefault' visibility.+    defaultSyms :: SymSet,+    -- | Function types, defined or not. There may exist a function+    -- whose type is unknown (e.g. as a function pointer), in that+    -- case we fall back to () -> (), it's imperfect but works with+    -- wasm-ld.+    funcTypes :: SymMap ([SomeWasmType], [SomeWasmType]),+    -- | Defined function bodies.+    funcBodies :: SymMap (FuncBody w),+    -- | Defined data sections.+    dataSections :: SymMap DataSection,+    -- | ctors in the current compilation unit.+    ctors :: [SymName],+    localRegs ::+      UniqFM LocalReg LocalInfo,+    localRegsCount ::+      Int,+    wasmDUniqSupply :: DUniqSupply+  }++initialWasmCodeGenState :: Platform -> DUniqSupply -> WasmCodeGenState w+initialWasmCodeGenState platform us =+  WasmCodeGenState+    { wasmPlatform =+        platform,+      defaultSyms = emptyUniqueSet,+      funcTypes = emptyUniqMap,+      funcBodies =+        emptyUniqMap,+      dataSections = emptyUniqMap,+      ctors =+        [],+      localRegs = emptyUFM,+      localRegsCount = 0,+      wasmDUniqSupply = us+    }++newtype WasmCodeGenM w a = WasmCodeGenM (State (WasmCodeGenState w) a)+  deriving newtype (Functor, Applicative, Monad)++instance MonadUniqDSM (WasmCodeGenM w) where+  liftUniqDSM (UDSM m) = wasmStateM $ \st ->+    let DUniqResult a us' = m (wasmDUniqSupply st)+     in (# a, st{wasmDUniqSupply=us'} #)++wasmGetsM :: (WasmCodeGenState w -> a) -> WasmCodeGenM w a+wasmGetsM = coerce . gets++wasmPlatformM :: WasmCodeGenM w Platform+wasmPlatformM = wasmGetsM wasmPlatform++wasmWordTypeM :: WasmCodeGenM w (WasmTypeTag w)+wasmWordTypeM = wasmGetsM $ \s ->+  if target32Bit $ wasmPlatform s+    then unsafeCoerce TagI32+    else unsafeCoerce TagI64++wasmWordCmmTypeM :: WasmCodeGenM w CmmType+wasmWordCmmTypeM = wasmGetsM (bWord . wasmPlatform)++wasmStateM ::+  (WasmCodeGenState w -> (# a, WasmCodeGenState w #)) ->+  WasmCodeGenM w a+wasmStateM = coerce . State++wasmModifyM :: (WasmCodeGenState w -> WasmCodeGenState w) -> WasmCodeGenM w ()+wasmModifyM = coerce . modify++wasmExecM :: WasmCodeGenM w a -> WasmCodeGenState w -> WasmCodeGenState w+wasmExecM (WasmCodeGenM s) = execState s++wasmRunM :: WasmCodeGenM w a -> WasmCodeGenState w -> (a, WasmCodeGenState w)+wasmRunM (WasmCodeGenM s) = runState s++instance MonadGetUnique (WasmCodeGenM w) where+  getUniqueM = wasmStateM $+    \s@WasmCodeGenState {..} -> case takeUniqueFromDSupply wasmDUniqSupply of+      (u, us) -> (# u, s {wasmDUniqSupply = us} #)++data WasmAsmConfig = WasmAsmConfig+  {+    pic, tailcall :: Bool,+    -- | Data/function symbols with 'SymStatic' visibility (defined+    -- but not visible to other compilation units). When doing PIC+    -- codegen, private symbols must be emitted as @MBREL@/@TBREL@+    -- relocations in the code section. The public symbols, defined or+    -- elsewhere, are all emitted as @GOT@ relocations instead.+    mbrelSyms, tbrelSyms :: ~SymSet+  }++-- | The default 'WasmAsmConfig' must be extracted from the final+-- 'WasmCodeGenState'.+defaultWasmAsmConfig :: WasmCodeGenState w -> WasmAsmConfig+defaultWasmAsmConfig WasmCodeGenState {..} =+  WasmAsmConfig+    { pic = False,+      tailcall = False,+      mbrelSyms = mk_rel_syms dataSections,+      tbrelSyms = mk_rel_syms funcBodies+    }+  where+    mk_rel_syms :: SymMap a -> SymSet+    mk_rel_syms =+      nonDetFoldUniqMap+        ( \(sym, _) acc ->+            if getUnique sym `memberUniqueSet` defaultSyms+              then acc+              else insertUniqueSet (getUnique sym) acc+        )+        emptyUniqueSet
+ GHC/CmmToAsm/Wasm/Utils.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE Strict #-}++module GHC.CmmToAsm.Wasm.Utils+  ( widthMax,+    detEltsUFM,+    detEltsUniqMap,+    builderCommas,+  )+where++import Data.ByteString.Builder+import Data.List (intersperse, sortOn)+import GHC.Cmm+import GHC.Prelude+import GHC.Types.Unique.FM+import GHC.Types.Unique.Map++widthMax :: Width -> Integer+widthMax w = (1 `shiftL` widthInBits w) - 1++detEltsUFM :: Ord k => UniqFM k0 (k, a) -> [(k, a)]+detEltsUFM = sortOn fst . nonDetEltsUFM++detEltsUniqMap :: Ord k => UniqMap k a -> [(k, a)]+detEltsUniqMap = sortOn fst . nonDetUniqMapToList++builderCommas :: (a -> Builder) -> [a] -> Builder+builderCommas f xs = mconcat (intersperse ", " (map f xs))
GHC/CmmToAsm/X86.hs view
@@ -33,11 +33,12 @@    , canShortcut               = X86.canShortcut    , shortcutStatics           = X86.shortcutStatics    , shortcutJump              = X86.shortcutJump-   , pprNatCmmDecl             = X86.pprNatCmmDecl config+   , pprNatCmmDeclS            = X86.pprNatCmmDecl config+   , pprNatCmmDeclH            = X86.pprNatCmmDecl config    , maxSpillSlots             = X86.maxSpillSlots config    , allocatableRegs           = X86.allocatableRegs platform    , ncgAllocMoreStack         = X86.allocMoreStack platform-   , ncgMakeFarBranches        = const id+   , ncgMakeFarBranches        = \_p _i bs -> pure bs    , extractUnwindPoints       = X86.extractUnwindPoints    , invertCondBranches        = X86.invertCondBranches    }@@ -50,6 +51,7 @@    patchRegsOfInstr        = X86.patchRegsOfInstr    isJumpishInstr          = X86.isJumpishInstr    jumpDestsOfInstr        = X86.jumpDestsOfInstr+   canFallthroughTo        = X86.canFallthroughTo    patchJumpInstr          = X86.patchJumpInstr    mkSpillInstr            = X86.mkSpillInstr    mkLoadInstr             = X86.mkLoadInstr
GHC/CmmToAsm/X86/CodeGen.hs view
@@ -1,4395 +1,6718 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE NondecreasingIndentation #-}-{-# LANGUAGE TupleSections #-}--{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}------------------------------------------------------------------------------------- Generating machine code (instruction selection)------ (c) The University of Glasgow 1996-2004------------------------------------------------------------------------------------- This is a big module, but, if you pay attention to--- (a) the sectioning, and (b) the type signatures, the--- structure should not be too overwhelming.--module GHC.CmmToAsm.X86.CodeGen (-        cmmTopCodeGen,-        generateJumpTableForInstr,-        extractUnwindPoints,-        invertCondBranches,-        InstrBlock-)--where---- NCG stuff:-import GHC.Prelude--import GHC.CmmToAsm.X86.Instr-import GHC.CmmToAsm.X86.Cond-import GHC.CmmToAsm.X86.Regs-import GHC.CmmToAsm.X86.Ppr-import GHC.CmmToAsm.X86.RegInfo--import GHC.Platform.Regs-import GHC.CmmToAsm.CPrim-import GHC.CmmToAsm.Types-import GHC.Cmm.DebugBlock-   ( DebugBlock(..), UnwindPoint(..), UnwindTable-   , UnwindExpr(UwReg), toUnwindExpr-   )-import GHC.CmmToAsm.PIC-import GHC.CmmToAsm.Monad-   ( NatM, getNewRegNat, getNewLabelNat, setDeltaNat-   , getDeltaNat, getBlockIdNat, getPicBaseNat-   , Reg64(..), RegCode64(..), getNewReg64, localReg64-   , getPicBaseMaybeNat, getDebugBlock, getFileId-   , addImmediateSuccessorNat, updateCfgNat, getConfig, getPlatform-   , getCfgWeights-   )-import GHC.CmmToAsm.CFG-import GHC.CmmToAsm.Format-import GHC.CmmToAsm.Config-import GHC.Platform.Reg-import GHC.Platform---- Our intermediate code:-import GHC.Types.Basic-import GHC.Cmm.BlockId-import GHC.Unit.Types ( primUnitId )-import GHC.Cmm.Utils-import GHC.Cmm.Switch-import GHC.Cmm-import GHC.Cmm.Dataflow.Block-import GHC.Cmm.Dataflow.Collections-import GHC.Cmm.Dataflow.Graph-import GHC.Cmm.Dataflow.Label-import GHC.Cmm.CLabel-import GHC.Types.Tickish ( GenTickish(..) )-import GHC.Types.SrcLoc  ( srcSpanFile, srcSpanStartLine, srcSpanStartCol )---- The rest:-import GHC.Types.ForeignCall ( CCallConv(..) )-import GHC.Data.OrdList-import GHC.Utils.Outputable-import GHC.Utils.Constants (debugIsOn)-import GHC.Utils.Panic-import GHC.Utils.Panic.Plain-import GHC.Data.FastString-import GHC.Utils.Misc-import GHC.Types.Unique.Supply ( getUniqueM )--import Control.Monad-import Data.Foldable (fold)-import Data.Int-import Data.Maybe-import Data.Word--import qualified Data.Map as M--is32BitPlatform :: NatM Bool-is32BitPlatform = do-    platform <- getPlatform-    return $ target32Bit platform--expect32BitPlatform :: SDoc -> NatM ()-expect32BitPlatform doc = do-  is32Bit <- is32BitPlatform-  when (not is32Bit) $-    pprPanic "Expecting 32-bit platform" doc--sse2Enabled :: NatM Bool-sse2Enabled = do-  config <- getConfig-  return (ncgSseVersion config >= Just SSE2)--sse4_2Enabled :: NatM Bool-sse4_2Enabled = do-  config <- getConfig-  return (ncgSseVersion config >= Just SSE42)--cmmTopCodeGen-        :: RawCmmDecl-        -> NatM [NatCmmDecl (Alignment, RawCmmStatics) Instr]--cmmTopCodeGen (CmmProc info lab live graph) = do-  let blocks = toBlockListEntryFirst graph-  (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks-  picBaseMb <- getPicBaseMaybeNat-  platform <- getPlatform-  let proc = CmmProc info lab live (ListGraph $ concat nat_blocks)-      tops = proc : concat statics-      os   = platformOS platform--  case picBaseMb of-      Just picBase -> initializePicBase_x86 ArchX86 os picBase tops-      Nothing -> return tops--cmmTopCodeGen (CmmData sec dat) =-  return [CmmData sec (mkAlignment 1, dat)]  -- no translation, we just use CmmStatic--{- Note [Verifying basic blocks]-   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-   We want to guarantee a few things about the results-   of instruction selection.--   Namely that each basic blocks consists of:-    * A (potentially empty) sequence of straight line instructions-  followed by-    * A (potentially empty) sequence of jump like instructions.--    We can verify this by going through the instructions and-    making sure that any non-jumpish instruction can't appear-    after a jumpish instruction.--    There are gotchas however:-    * CALLs are strictly speaking control flow but here we care-      not about them. Hence we treat them as regular instructions.--      It's safe for them to appear inside a basic block-      as (ignoring side effects inside the call) they will result in-      straight line code.--    * NEWBLOCK marks the start of a new basic block so can-      be followed by any instructions.--}---- Verifying basic blocks is cheap, but not cheap enough to enable it unconditionally.-verifyBasicBlock :: Platform -> [Instr] -> ()-verifyBasicBlock platform instrs-  | debugIsOn     = go False instrs-  | otherwise     = ()-  where-    go _     [] = ()-    go atEnd (i:instr)-        = case i of-            -- Start a new basic block-            NEWBLOCK {} -> go False instr-            -- Calls are not viable block terminators-            CALL {}     | atEnd -> faultyBlockWith i-                        | not atEnd -> go atEnd instr-            -- All instructions ok, check if we reached the end and continue.-            _ | not atEnd -> go (isJumpishInstr i) instr-              -- Only jumps allowed at the end of basic blocks.-              | otherwise -> if isJumpishInstr i-                                then go True instr-                                else faultyBlockWith i-    faultyBlockWith i-        = pprPanic "Non control flow instructions after end of basic block."-                   (pprInstr platform i <+> text "in:" $$ vcat (map (pprInstr platform) instrs))--basicBlockCodeGen-        :: CmmBlock-        -> NatM ( [NatBasicBlock Instr]-                , [NatCmmDecl (Alignment, RawCmmStatics) Instr])--basicBlockCodeGen block = do-  let (_, nodes, tail)  = blockSplit block-      id = entryLabel block-      stmts = blockToList nodes-  -- Generate location directive-  dbg <- getDebugBlock (entryLabel block)-  loc_instrs <- case dblSourceTick =<< dbg of-    Just (SourceNote span name)-      -> do fileId <- getFileId (srcSpanFile span)-            let line = srcSpanStartLine span; col = srcSpanStartCol span-            return $ unitOL $ LOCATION fileId line col name-    _ -> return nilOL-  (mid_instrs,mid_bid) <- stmtsToInstrs id stmts-  (!tail_instrs,_) <- stmtToInstrs mid_bid tail-  let instrs = loc_instrs `appOL` mid_instrs `appOL` tail_instrs-  platform <- getPlatform-  return $! verifyBasicBlock platform (fromOL instrs)-  instrs' <- fold <$> traverse addSpUnwindings instrs-  -- code generation may introduce new basic block boundaries, which-  -- are indicated by the NEWBLOCK instruction.  We must split up the-  -- instruction stream into basic blocks again.  Also, we extract-  -- LDATAs here too.-  let-        (top,other_blocks,statics) = foldrOL mkBlocks ([],[],[]) instrs'--        mkBlocks (NEWBLOCK id) (instrs,blocks,statics)-          = ([], BasicBlock id instrs : blocks, statics)-        mkBlocks (LDATA sec dat) (instrs,blocks,statics)-          = (instrs, blocks, CmmData sec dat:statics)-        mkBlocks instr (instrs,blocks,statics)-          = (instr:instrs, blocks, statics)-  return (BasicBlock id top : other_blocks, statics)---- | Convert 'DELTA' instructions into 'UNWIND' instructions to capture changes--- in the @sp@ register. See Note [What is this unwinding business?] in "GHC.Cmm.DebugBlock"--- for details.-addSpUnwindings :: Instr -> NatM (OrdList Instr)-addSpUnwindings instr@(DELTA d) = do-    config <- getConfig-    if ncgDwarfUnwindings config-        then do lbl <- mkAsmTempLabel <$> getUniqueM-                let unwind = M.singleton MachSp (Just $ UwReg MachSp $ negate d)-                return $ toOL [ instr, UNWIND lbl unwind ]-        else return (unitOL instr)-addSpUnwindings instr = return $ unitOL instr--{- Note [Keeping track of the current block]-   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When generating instructions for Cmm we sometimes require-the current block for things like retry loops.--We also sometimes change the current block, if a MachOP-results in branching control flow.--Issues arise if we have two statements in the same block,-which both depend on the current block id *and* change the-basic block after them. This happens for atomic primops-in the X86 backend where we want to update the CFG data structure-when introducing new basic blocks.--For example in #17334 we got this Cmm code:--        c3Bf: // global-            (_s3t1::I64) = call MO_AtomicRMW W64 AMO_And(_s3sQ::P64 + 88, 18);-            (_s3t4::I64) = call MO_AtomicRMW W64 AMO_Or(_s3sQ::P64 + 88, 0);-            _s3sT::I64 = _s3sV::I64;-            goto c3B1;--This resulted in two new basic blocks being inserted:--        c3Bf:-                movl $18,%vI_n3Bo-                movq 88(%vI_s3sQ),%rax-                jmp _n3Bp-        n3Bp:-                ...-                cmpxchgq %vI_n3Bq,88(%vI_s3sQ)-                jne _n3Bp-                ...-                jmp _n3Bs-        n3Bs:-                ...-                cmpxchgq %vI_n3Bt,88(%vI_s3sQ)-                jne _n3Bs-                ...-                jmp _c3B1-        ...--Based on the Cmm we called stmtToInstrs we translated both atomic operations under-the assumption they would be placed into their Cmm basic block `c3Bf`.-However for the retry loop we introduce new labels, so this is not the case-for the second statement.-This resulted in a desync between the explicit control flow graph-we construct as a separate data type and the actual control flow graph in the code.--Instead we now return the new basic block if a statement causes a change-in the current block and use the block for all following statements.--For this reason genForeignCall is also split into two parts.  One for calls which-*won't* change the basic blocks in which successive instructions will be-placed (since they only evaluate CmmExpr, which can only contain MachOps, which-cannot introduce basic blocks in their lowerings).  A different one for calls-which *are* known to change the basic block.---}---- See Note [Keeping track of the current block] for why--- we pass the BlockId.-stmtsToInstrs :: BlockId -- ^ Basic block these statement will start to be placed in.-              -> [CmmNode O O] -- ^ Cmm Statement-              -> NatM (InstrBlock, BlockId) -- ^ Resulting instruction-stmtsToInstrs bid stmts =-    go bid stmts nilOL-  where-    go bid  []        instrs = return (instrs,bid)-    go bid (s:stmts)  instrs = do-      (instrs',bid') <- stmtToInstrs bid s-      -- If the statement introduced a new block, we use that one-      let !newBid = fromMaybe bid bid'-      go newBid stmts (instrs `appOL` instrs')---- | `bid` refers to the current block and is used to update the CFG---   if new blocks are inserted in the control flow.--- See Note [Keeping track of the current block] for more details.-stmtToInstrs :: BlockId -- ^ Basic block this statement will start to be placed in.-             -> CmmNode e x-             -> NatM (InstrBlock, Maybe BlockId)-             -- ^ Instructions, and bid of new block if successive-             -- statements are placed in a different basic block.-stmtToInstrs bid stmt = do-  is32Bit <- is32BitPlatform-  platform <- getPlatform-  case stmt of-    CmmUnsafeForeignCall target result_regs args-       -> genForeignCall target result_regs args bid--    _ -> (,Nothing) <$> case stmt of-      CmmComment s   -> return (unitOL (COMMENT $ ftext s))-      CmmTick {}     -> return nilOL--      CmmUnwind regs -> do-        let to_unwind_entry :: (GlobalReg, Maybe CmmExpr) -> UnwindTable-            to_unwind_entry (reg, expr) = M.singleton reg (fmap (toUnwindExpr platform) expr)-        case foldMap to_unwind_entry regs of-          tbl | M.null tbl -> return nilOL-              | otherwise  -> do-                  lbl <- mkAsmTempLabel <$> getUniqueM-                  return $ unitOL $ UNWIND lbl tbl--      CmmAssign reg src-        | isFloatType ty         -> assignReg_FltCode format reg src-        | is32Bit && isWord64 ty -> assignReg_I64Code      reg src-        | otherwise              -> assignReg_IntCode format reg src-          where ty = cmmRegType platform reg-                format = cmmTypeFormat ty--      CmmStore addr src _alignment-        | isFloatType ty         -> assignMem_FltCode format addr src-        | is32Bit && isWord64 ty -> assignMem_I64Code      addr src-        | otherwise              -> assignMem_IntCode format addr src-          where ty = cmmExprType platform src-                format = cmmTypeFormat ty--      CmmBranch id          -> return $ genBranch id--      --We try to arrange blocks such that the likely branch is the fallthrough-      --in GHC.Cmm.ContFlowOpt. So we can assume the condition is likely false here.-      CmmCondBranch arg true false _ -> genCondBranch bid true false arg-      CmmSwitch arg ids -> genSwitch arg ids-      CmmCall { cml_target = arg-              , cml_args_regs = gregs } -> genJump arg (jumpRegs platform gregs)-      _ ->-        panic "stmtToInstrs: statement should have been cps'd away"---jumpRegs :: Platform -> [GlobalReg] -> [Reg]-jumpRegs platform gregs = [ RegReal r | Just r <- map (globalRegMaybe platform) gregs ]------------------------------------------------------------------------------------- | 'InstrBlock's are the insn sequences generated by the insn selectors.---      They are really trees of insns to facilitate fast appending, where a---      left-to-right traversal yields the insns in the correct order.----type InstrBlock-        = OrdList Instr----- | Condition codes passed up the tree.----data CondCode-        = CondCode Bool Cond InstrBlock----- | Register's passed up the tree.  If the stix code forces the register---      to live in a pre-decided machine register, it comes out as @Fixed@;---      otherwise, it comes out as @Any@, and the parent can decide which---      register to put it in.----data Register-        = Fixed Format Reg InstrBlock-        | Any   Format (Reg -> InstrBlock)---swizzleRegisterRep :: Register -> Format -> Register-swizzleRegisterRep (Fixed _ reg code) format = Fixed format reg code-swizzleRegisterRep (Any _ codefn)     format = Any   format codefn--getLocalRegReg :: LocalReg -> Reg-getLocalRegReg (LocalReg u pk)-  = -- by Assuming SSE2, Int,Word,Float,Double all can be register allocated-    RegVirtual (mkVirtualReg u (cmmTypeFormat pk))---- | Grab the Reg for a CmmReg-getRegisterReg :: Platform  -> CmmReg -> Reg--getRegisterReg _   (CmmLocal lreg) = getLocalRegReg lreg--getRegisterReg platform  (CmmGlobal mid)-  = case globalRegMaybe platform mid of-        Just reg -> RegReal $ reg-        Nothing  -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal mid)-        -- By this stage, the only MagicIds remaining should be the-        -- ones which map to a real machine register on this-        -- platform.  Hence ...----- | Memory addressing modes passed up the tree.-data Amode-        = Amode AddrMode InstrBlock--{--Now, given a tree (the argument to a CmmLoad) that references memory,-produce a suitable addressing mode.--A Rule of the Game (tm) for Amodes: use of the addr bit must-immediately follow use of the code part, since the code part puts-values in registers which the addr then refers to.  So you can't put-anything in between, lest it overwrite some of those registers.  If-you need to do some other computation between the code part and use of-the addr bit, first store the effective address from the amode in a-temporary, then do the other computation, and then use the temporary:--    code-    LEA amode, tmp-    ... other computation ...-    ... (tmp) ...--}--{--Note [%rip-relative addressing on x86-64]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-On x86-64 GHC produces code for use in the "small" or, when `-fPIC` is set,-"small PIC" code models defined by the x86-64 System V ABI (section 3.5.1 of-specification version 0.99).--In general the small code model would allow us to assume that code is located-between 0 and 2^31 - 1. However, this is not true on Windows which, due to-high-entropy ASLR, may place the executable image anywhere in 64-bit address-space. This is problematic since immediate operands in x86-64 are generally-32-bit sign-extended values (with the exception of the 64-bit MOVABS encoding).-Consequently, to avoid overflowing we use %rip-relative addressing universally.-Since %rip-relative addressing comes essentially for free and makes linking far-easier, we use it even on non-Windows platforms.--See also: the documentation for GCC's `-mcmodel=small` flag.--}----- | Check whether an integer will fit in 32 bits.---      A CmmInt is intended to be truncated to the appropriate---      number of bits, so here we truncate it to Int64.  This is---      important because e.g. -1 as a CmmInt might be either---      -1 or 18446744073709551615.----is32BitInteger :: Integer -> Bool-is32BitInteger i = i64 <= 0x7fffffff && i64 >= -0x80000000-  where i64 = fromIntegral i :: Int64----- | Convert a BlockId to some CmmStatic data-jumpTableEntry :: NCGConfig -> Maybe BlockId -> CmmStatic-jumpTableEntry config Nothing = CmmStaticLit (CmmInt 0 (ncgWordWidth config))-jumpTableEntry _ (Just blockid) = CmmStaticLit (CmmLabel blockLabel)-    where blockLabel = blockLbl blockid----- -------------------------------------------------------------------------------- General things for putting together code sequences---- Expand CmmRegOff.  ToDo: should we do it this way around, or convert--- CmmExprs into CmmRegOff?-mangleIndexTree :: Platform -> CmmReg -> Int -> CmmExpr-mangleIndexTree platform reg off-  = CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)]-  where width = typeWidth (cmmRegType platform reg)---- | The dual to getAnyReg: compute an expression into a register, but---      we don't mind which one it is.-getSomeReg :: CmmExpr -> NatM (Reg, InstrBlock)-getSomeReg expr = do-  r <- getRegister expr-  case r of-    Any rep code -> do-        tmp <- getNewRegNat rep-        return (tmp, code tmp)-    Fixed _ reg code ->-        return (reg, code)---assignMem_I64Code :: CmmExpr -> CmmExpr -> NatM InstrBlock-assignMem_I64Code addrTree valueTree = do-  Amode addr addr_code <- getAmode addrTree-  RegCode64 vcode rhi rlo <- iselExpr64 valueTree-  let-        -- Little-endian store-        mov_lo = MOV II32 (OpReg rlo) (OpAddr addr)-        mov_hi = MOV II32 (OpReg rhi) (OpAddr (fromJust (addrOffset addr 4)))-  return (vcode `appOL` addr_code `snocOL` mov_lo `snocOL` mov_hi)---assignReg_I64Code :: CmmReg  -> CmmExpr -> NatM InstrBlock-assignReg_I64Code (CmmLocal dst) valueTree = do-   RegCode64 vcode r_src_hi r_src_lo <- iselExpr64 valueTree-   let-         Reg64 r_dst_hi r_dst_lo = localReg64 dst-         mov_lo = MOV II32 (OpReg r_src_lo) (OpReg r_dst_lo)-         mov_hi = MOV II32 (OpReg r_src_hi) (OpReg r_dst_hi)-   return (-        vcode `snocOL` mov_lo `snocOL` mov_hi-     )--assignReg_I64Code _ _-   = panic "assignReg_I64Code(i386): invalid lvalue"---iselExpr64 :: HasDebugCallStack => CmmExpr -> NatM (RegCode64 InstrBlock)-iselExpr64 (CmmLit (CmmInt i _)) = do-  Reg64 rhi rlo <- getNewReg64-  let-        r = fromIntegral (fromIntegral i :: Word32)-        q = fromIntegral (fromIntegral (i `shiftR` 32) :: Word32)-        code = toOL [-                MOV II32 (OpImm (ImmInteger r)) (OpReg rlo),-                MOV II32 (OpImm (ImmInteger q)) (OpReg rhi)-                ]-  return (RegCode64 code rhi rlo)--iselExpr64 (CmmLoad addrTree ty _) | isWord64 ty = do-   Amode addr addr_code <- getAmode addrTree-   Reg64 rhi rlo <- getNewReg64-   let-        mov_lo = MOV II32 (OpAddr addr) (OpReg rlo)-        mov_hi = MOV II32 (OpAddr (fromJust (addrOffset addr 4))) (OpReg rhi)-   return (-            RegCode64 (addr_code `snocOL` mov_lo `snocOL` mov_hi) rhi rlo-     )--iselExpr64 (CmmReg (CmmLocal local_reg)) = do-  let Reg64 hi lo = localReg64 local_reg-  return (RegCode64 nilOL hi lo)---- we handle addition, but rather badly-iselExpr64 (CmmMachOp (MO_Add _) [e1, CmmLit (CmmInt i _)]) = do-   RegCode64 code1 r1hi r1lo <- iselExpr64 e1-   Reg64 rhi rlo <- getNewReg64-   let-        r = fromIntegral (fromIntegral i :: Word32)-        q = fromIntegral (fromIntegral (i `shiftR` 32) :: Word32)-        code =  code1 `appOL`-                toOL [ MOV II32 (OpReg r1lo) (OpReg rlo),-                       ADD II32 (OpImm (ImmInteger r)) (OpReg rlo),-                       MOV II32 (OpReg r1hi) (OpReg rhi),-                       ADC II32 (OpImm (ImmInteger q)) (OpReg rhi) ]-   return (RegCode64 code rhi rlo)--iselExpr64 (CmmMachOp (MO_Add _) [e1,e2]) = do-   RegCode64 code1 r1hi r1lo <- iselExpr64 e1-   RegCode64 code2 r2hi r2lo <- iselExpr64 e2-   Reg64 rhi rlo <- getNewReg64-   let-        code =  code1 `appOL`-                code2 `appOL`-                toOL [ MOV II32 (OpReg r1lo) (OpReg rlo),-                       ADD II32 (OpReg r2lo) (OpReg rlo),-                       MOV II32 (OpReg r1hi) (OpReg rhi),-                       ADC II32 (OpReg r2hi) (OpReg rhi) ]-   return (RegCode64 code rhi rlo)--iselExpr64 (CmmMachOp (MO_Sub _) [e1,e2]) = do-   RegCode64 code1 r1hi r1lo <- iselExpr64 e1-   RegCode64 code2 r2hi r2lo <- iselExpr64 e2-   Reg64 rhi rlo <- getNewReg64-   let-        code =  code1 `appOL`-                code2 `appOL`-                toOL [ MOV II32 (OpReg r1lo) (OpReg rlo),-                       SUB II32 (OpReg r2lo) (OpReg rlo),-                       MOV II32 (OpReg r1hi) (OpReg rhi),-                       SBB II32 (OpReg r2hi) (OpReg rhi) ]-   return (RegCode64 code rhi rlo)--iselExpr64 (CmmMachOp (MO_UU_Conv _ W64) [expr]) = do-     code <- getAnyReg expr-     Reg64 r_dst_hi r_dst_lo <- getNewReg64-     return $ RegCode64 (code r_dst_lo `snocOL`-                          MOV II32 (OpImm (ImmInt 0)) (OpReg r_dst_hi))-                          r_dst_hi-                          r_dst_lo--iselExpr64 (CmmMachOp (MO_SS_Conv W32 W64) [expr]) = do-     code <- getAnyReg expr-     Reg64 r_dst_hi r_dst_lo <- getNewReg64-     return $ RegCode64 (code r_dst_lo `snocOL`-                          MOV II32 (OpReg r_dst_lo) (OpReg eax) `snocOL`-                          CLTD II32 `snocOL`-                          MOV II32 (OpReg eax) (OpReg r_dst_lo) `snocOL`-                          MOV II32 (OpReg edx) (OpReg r_dst_hi))-                          r_dst_hi-                          r_dst_lo--iselExpr64 expr-   = do-      platform <- getPlatform-      pprPanic "iselExpr64(i386)" (pdoc platform expr)------------------------------------------------------------------------------------getRegister :: CmmExpr -> NatM Register-getRegister e = do platform <- getPlatform-                   is32Bit <- is32BitPlatform-                   getRegister' platform is32Bit e--getRegister' :: Platform -> Bool -> CmmExpr -> NatM Register--getRegister' platform is32Bit (CmmReg reg)-  = case reg of-        CmmGlobal PicBaseReg-         | is32Bit ->-            -- on x86_64, we have %rip for PicBaseReg, but it's not-            -- a full-featured register, it can only be used for-            -- rip-relative addressing.-            do reg' <- getPicBaseNat (archWordFormat is32Bit)-               return (Fixed (archWordFormat is32Bit) reg' nilOL)-        _ ->-            do-               let-                 fmt = cmmTypeFormat (cmmRegType platform reg)-                 format  = fmt-               ---               platform <- ncgPlatform <$> getConfig-               return (Fixed format-                             (getRegisterReg platform reg)-                             nilOL)---getRegister' platform is32Bit (CmmRegOff r n)-  = getRegister' platform is32Bit $ mangleIndexTree platform r n--getRegister' platform is32Bit (CmmMachOp (MO_AlignmentCheck align _) [e])-  = addAlignmentCheck align <$> getRegister' platform is32Bit e---- for 32-bit architectures, support some 64 -> 32 bit conversions:--- TO_W_(x), TO_W_(x >> 32)--getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W64 W32)-                     [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]])- | is32Bit = do-  RegCode64 code rhi _rlo <- iselExpr64 x-  return $ Fixed II32 rhi code--getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W64 W32)-                     [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]])- | is32Bit = do-  RegCode64 code rhi _rlo <- iselExpr64 x-  return $ Fixed II32 rhi code--getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W64 W32) [x])- | is32Bit = do-  RegCode64 code _rhi rlo <- iselExpr64 x-  return $ Fixed II32 rlo code--getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W64 W32) [x])- | is32Bit = do-  RegCode64 code _rhi rlo <- iselExpr64 x-  return $ Fixed II32 rlo code--getRegister' _ _ (CmmLit lit@(CmmFloat f w)) =-  float_const_sse2  where-  float_const_sse2-    | f == 0.0 = do-      let-          format = floatFormat w-          code dst = unitOL  (XOR format (OpReg dst) (OpReg dst))-        -- I don't know why there are xorpd, xorps, and pxor instructions.-        -- They all appear to do the same thing --SDM-      return (Any format code)--   | otherwise = do-      Amode addr code <- memConstant (mkAlignment $ widthInBytes w) lit-      loadFloatAmode w addr code---- catch simple cases of zero- or sign-extended load-getRegister' _ _ (CmmMachOp (MO_UU_Conv W8 W32) [CmmLoad addr _ _]) = do-  code <- intLoadCode (MOVZxL II8) addr-  return (Any II32 code)--getRegister' _ _ (CmmMachOp (MO_SS_Conv W8 W32) [CmmLoad addr _ _]) = do-  code <- intLoadCode (MOVSxL II8) addr-  return (Any II32 code)--getRegister' _ _ (CmmMachOp (MO_UU_Conv W16 W32) [CmmLoad addr _ _]) = do-  code <- intLoadCode (MOVZxL II16) addr-  return (Any II32 code)--getRegister' _ _ (CmmMachOp (MO_SS_Conv W16 W32) [CmmLoad addr _ _]) = do-  code <- intLoadCode (MOVSxL II16) addr-  return (Any II32 code)---- catch simple cases of zero- or sign-extended load-getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W8 W64) [CmmLoad addr _ _])- | not is32Bit = do-  code <- intLoadCode (MOVZxL II8) addr-  return (Any II64 code)--getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W8 W64) [CmmLoad addr _ _])- | not is32Bit = do-  code <- intLoadCode (MOVSxL II8) addr-  return (Any II64 code)--getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W16 W64) [CmmLoad addr _ _])- | not is32Bit = do-  code <- intLoadCode (MOVZxL II16) addr-  return (Any II64 code)--getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W16 W64) [CmmLoad addr _ _])- | not is32Bit = do-  code <- intLoadCode (MOVSxL II16) addr-  return (Any II64 code)--getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W32 W64) [CmmLoad addr _ _])- | not is32Bit = do-  code <- intLoadCode (MOV II32) addr -- 32-bit loads zero-extend-  return (Any II64 code)--getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W32 W64) [CmmLoad addr _ _])- | not is32Bit = do-  code <- intLoadCode (MOVSxL II32) addr-  return (Any II64 code)--getRegister' _ is32Bit (CmmMachOp (MO_Add W64) [CmmReg (CmmGlobal PicBaseReg),-                                     CmmLit displacement])- | not is32Bit =-      return $ Any II64 (\dst -> unitOL $-        LEA II64 (OpAddr (ripRel (litToImm displacement))) (OpReg dst))--getRegister' platform is32Bit (CmmMachOp mop [x]) = -- unary MachOps-    case mop of-      MO_F_Neg w  -> sse2NegCode w x---      MO_S_Neg w -> triv_ucode NEGI (intFormat w)-      MO_Not w   -> triv_ucode NOT  (intFormat w)--      -- Nop conversions-      MO_UU_Conv W32 W8  -> toI8Reg  W32 x-      MO_SS_Conv W32 W8  -> toI8Reg  W32 x-      MO_XX_Conv W32 W8  -> toI8Reg  W32 x-      MO_UU_Conv W16 W8  -> toI8Reg  W16 x-      MO_SS_Conv W16 W8  -> toI8Reg  W16 x-      MO_XX_Conv W16 W8  -> toI8Reg  W16 x-      MO_UU_Conv W32 W16 -> toI16Reg W32 x-      MO_SS_Conv W32 W16 -> toI16Reg W32 x-      MO_XX_Conv W32 W16 -> toI16Reg W32 x--      MO_UU_Conv W64 W32 | not is32Bit -> conversionNop II64 x-      MO_SS_Conv W64 W32 | not is32Bit -> conversionNop II64 x-      MO_XX_Conv W64 W32 | not is32Bit -> conversionNop II64 x-      MO_UU_Conv W64 W16 | not is32Bit -> toI16Reg W64 x-      MO_SS_Conv W64 W16 | not is32Bit -> toI16Reg W64 x-      MO_XX_Conv W64 W16 | not is32Bit -> toI16Reg W64 x-      MO_UU_Conv W64 W8  | not is32Bit -> toI8Reg  W64 x-      MO_SS_Conv W64 W8  | not is32Bit -> toI8Reg  W64 x-      MO_XX_Conv W64 W8  | not is32Bit -> toI8Reg  W64 x--      MO_UU_Conv rep1 rep2 | rep1 == rep2 -> conversionNop (intFormat rep1) x-      MO_SS_Conv rep1 rep2 | rep1 == rep2 -> conversionNop (intFormat rep1) x-      MO_XX_Conv rep1 rep2 | rep1 == rep2 -> conversionNop (intFormat rep1) x--      -- widenings-      MO_UU_Conv W8  W32 -> integerExtend W8  W32 MOVZxL x-      MO_UU_Conv W16 W32 -> integerExtend W16 W32 MOVZxL x-      MO_UU_Conv W8  W16 -> integerExtend W8  W16 MOVZxL x--      MO_SS_Conv W8  W32 -> integerExtend W8  W32 MOVSxL x-      MO_SS_Conv W16 W32 -> integerExtend W16 W32 MOVSxL x-      MO_SS_Conv W8  W16 -> integerExtend W8  W16 MOVSxL x--      -- We don't care about the upper bits for MO_XX_Conv, so MOV is enough. However, on 32-bit we-      -- have 8-bit registers only for a few registers (as opposed to x86-64 where every register-      -- has 8-bit version). So for 32-bit code, we'll just zero-extend.-      MO_XX_Conv W8  W32-          | is32Bit   -> integerExtend W8 W32 MOVZxL x-          | otherwise -> integerExtend W8 W32 MOV x-      MO_XX_Conv W8  W16-          | is32Bit   -> integerExtend W8 W16 MOVZxL x-          | otherwise -> integerExtend W8 W16 MOV x-      MO_XX_Conv W16 W32 -> integerExtend W16 W32 MOV x--      MO_UU_Conv W8  W64 | not is32Bit -> integerExtend W8  W64 MOVZxL x-      MO_UU_Conv W16 W64 | not is32Bit -> integerExtend W16 W64 MOVZxL x-      MO_UU_Conv W32 W64 | not is32Bit -> integerExtend W32 W64 MOVZxL x-      MO_SS_Conv W8  W64 | not is32Bit -> integerExtend W8  W64 MOVSxL x-      MO_SS_Conv W16 W64 | not is32Bit -> integerExtend W16 W64 MOVSxL x-      MO_SS_Conv W32 W64 | not is32Bit -> integerExtend W32 W64 MOVSxL x-      -- For 32-to-64 bit zero extension, amd64 uses an ordinary movl.-      -- However, we don't want the register allocator to throw it-      -- away as an unnecessary reg-to-reg move, so we keep it in-      -- the form of a movzl and print it as a movl later.-      -- This doesn't apply to MO_XX_Conv since in this case we don't care about-      -- the upper bits. So we can just use MOV.-      MO_XX_Conv W8  W64 | not is32Bit -> integerExtend W8  W64 MOV x-      MO_XX_Conv W16 W64 | not is32Bit -> integerExtend W16 W64 MOV x-      MO_XX_Conv W32 W64 | not is32Bit -> integerExtend W32 W64 MOV x--      MO_FF_Conv W32 W64 -> coerceFP2FP W64 x---      MO_FF_Conv W64 W32 -> coerceFP2FP W32 x--      MO_FS_Conv from to -> coerceFP2Int from to x-      MO_SF_Conv from to -> coerceInt2FP from to x--      MO_V_Insert {}   -> needLlvm-      MO_V_Extract {}  -> needLlvm-      MO_V_Add {}      -> needLlvm-      MO_V_Sub {}      -> needLlvm-      MO_V_Mul {}      -> needLlvm-      MO_VS_Quot {}    -> needLlvm-      MO_VS_Rem {}     -> needLlvm-      MO_VS_Neg {}     -> needLlvm-      MO_VU_Quot {}    -> needLlvm-      MO_VU_Rem {}     -> needLlvm-      MO_VF_Insert {}  -> needLlvm-      MO_VF_Extract {} -> needLlvm-      MO_VF_Add {}     -> needLlvm-      MO_VF_Sub {}     -> needLlvm-      MO_VF_Mul {}     -> needLlvm-      MO_VF_Quot {}    -> needLlvm-      MO_VF_Neg {}     -> needLlvm--      _other -> pprPanic "getRegister" (pprMachOp mop)-   where-        triv_ucode :: (Format -> Operand -> Instr) -> Format -> NatM Register-        triv_ucode instr format = trivialUCode format (instr format) x--        -- signed or unsigned extension.-        integerExtend :: Width -> Width-                      -> (Format -> Operand -> Operand -> Instr)-                      -> CmmExpr -> NatM Register-        integerExtend from to instr expr = do-            (reg,e_code) <- if from == W8 then getByteReg expr-                                          else getSomeReg expr-            let-                code dst =-                  e_code `snocOL`-                  instr (intFormat from) (OpReg reg) (OpReg dst)-            return (Any (intFormat to) code)--        toI8Reg :: Width -> CmmExpr -> NatM Register-        toI8Reg new_rep expr-            = do codefn <- getAnyReg expr-                 return (Any (intFormat new_rep) codefn)-                -- HACK: use getAnyReg to get a byte-addressable register.-                -- If the source was a Fixed register, this will add the-                -- mov instruction to put it into the desired destination.-                -- We're assuming that the destination won't be a fixed-                -- non-byte-addressable register; it won't be, because all-                -- fixed registers are word-sized.--        toI16Reg = toI8Reg -- for now--        conversionNop :: Format -> CmmExpr -> NatM Register-        conversionNop new_format expr-            = do e_code <- getRegister' platform is32Bit expr-                 return (swizzleRegisterRep e_code new_format)---getRegister' _ is32Bit (CmmMachOp mop [x, y]) = -- dyadic MachOps-  case mop of-      MO_F_Eq _ -> condFltReg is32Bit EQQ x y-      MO_F_Ne _ -> condFltReg is32Bit NE  x y-      MO_F_Gt _ -> condFltReg is32Bit GTT x y-      MO_F_Ge _ -> condFltReg is32Bit GE  x y-      -- Invert comparison condition and swap operands-      -- See Note [SSE Parity Checks]-      MO_F_Lt _ -> condFltReg is32Bit GTT  y x-      MO_F_Le _ -> condFltReg is32Bit GE   y x--      MO_Eq _   -> condIntReg EQQ x y-      MO_Ne _   -> condIntReg NE  x y--      MO_S_Gt _ -> condIntReg GTT x y-      MO_S_Ge _ -> condIntReg GE  x y-      MO_S_Lt _ -> condIntReg LTT x y-      MO_S_Le _ -> condIntReg LE  x y--      MO_U_Gt _ -> condIntReg GU  x y-      MO_U_Ge _ -> condIntReg GEU x y-      MO_U_Lt _ -> condIntReg LU  x y-      MO_U_Le _ -> condIntReg LEU x y--      MO_F_Add w   -> trivialFCode_sse2 w ADD  x y--      MO_F_Sub w   -> trivialFCode_sse2 w SUB  x y--      MO_F_Quot w  -> trivialFCode_sse2 w FDIV x y--      MO_F_Mul w   -> trivialFCode_sse2 w MUL x y---      MO_Add rep -> add_code rep x y-      MO_Sub rep -> sub_code rep x y--      MO_S_Quot rep -> div_code rep True  True  x y-      MO_S_Rem  rep -> div_code rep True  False x y-      MO_U_Quot rep -> div_code rep False True  x y-      MO_U_Rem  rep -> div_code rep False False x y--      MO_S_MulMayOflo rep -> imulMayOflo rep x y--      MO_Mul W8  -> imulW8 x y-      MO_Mul rep -> triv_op rep IMUL-      MO_And rep -> triv_op rep AND-      MO_Or  rep -> triv_op rep OR-      MO_Xor rep -> triv_op rep XOR--        {- Shift ops on x86s have constraints on their source, it-           either has to be Imm, CL or 1-            => trivialCode is not restrictive enough (sigh.)-        -}-      MO_Shl rep   -> shift_code rep SHL x y {-False-}-      MO_U_Shr rep -> shift_code rep SHR x y {-False-}-      MO_S_Shr rep -> shift_code rep SAR x y {-False-}--      MO_V_Insert {}   -> needLlvm-      MO_V_Extract {}  -> needLlvm-      MO_V_Add {}      -> needLlvm-      MO_V_Sub {}      -> needLlvm-      MO_V_Mul {}      -> needLlvm-      MO_VS_Quot {}    -> needLlvm-      MO_VS_Rem {}     -> needLlvm-      MO_VS_Neg {}     -> needLlvm-      MO_VF_Insert {}  -> needLlvm-      MO_VF_Extract {} -> needLlvm-      MO_VF_Add {}     -> needLlvm-      MO_VF_Sub {}     -> needLlvm-      MO_VF_Mul {}     -> needLlvm-      MO_VF_Quot {}    -> needLlvm-      MO_VF_Neg {}     -> needLlvm--      _other -> pprPanic "getRegister(x86) - binary CmmMachOp (1)" (pprMachOp mop)-  where-    ---------------------    triv_op width instr = trivialCode width op (Just op) x y-                        where op   = instr (intFormat width)--    -- Special case for IMUL for bytes, since the result of IMULB will be in-    -- %ax, the split to %dx/%edx/%rdx and %ax/%eax/%rax happens only for wider-    -- values.-    imulW8 :: CmmExpr -> CmmExpr -> NatM Register-    imulW8 arg_a arg_b = do-        (a_reg, a_code) <- getNonClobberedReg arg_a-        b_code <- getAnyReg arg_b--        let code = a_code `appOL` b_code eax `appOL`-                   toOL [ IMUL2 format (OpReg a_reg) ]-            format = intFormat W8--        return (Fixed format eax code)---    imulMayOflo :: Width -> CmmExpr -> CmmExpr -> NatM Register-    imulMayOflo rep a b = do-         (a_reg, a_code) <- getNonClobberedReg a-         b_code <- getAnyReg b-         let-             shift_amt  = case rep of-                           W32 -> 31-                           W64 -> 63-                           _ -> panic "shift_amt"--             format = intFormat rep-             code = a_code `appOL` b_code eax `appOL`-                        toOL [-                           IMUL2 format (OpReg a_reg),   -- result in %edx:%eax-                           SAR format (OpImm (ImmInt shift_amt)) (OpReg eax),-                                -- sign extend lower part-                           SUB format (OpReg edx) (OpReg eax)-                                -- compare against upper-                           -- eax==0 if high part == sign extended low part-                        ]-         return (Fixed format eax code)--    ---------------------    shift_code :: Width-               -> (Format -> Operand -> Operand -> Instr)-               -> CmmExpr-               -> CmmExpr-               -> NatM Register--    {- Case1: shift length as immediate -}-    shift_code width instr x (CmmLit lit)-      -- Handle the case of a shift larger than the width of the shifted value.-      -- This is necessary since x86 applies a mask of 0x1f to the shift-      -- amount, meaning that, e.g., `shr 47, $eax` will actually shift by-      -- `47 & 0x1f == 15`. See #20626.-      | CmmInt n _ <- lit-      , n >= fromIntegral (widthInBits width)-      = getRegister $ CmmLit $ CmmInt 0 width--      | otherwise = do-          x_code <- getAnyReg x-          let-               format = intFormat width-               code dst-                  = x_code dst `snocOL`-                    instr format (OpImm (litToImm lit)) (OpReg dst)-          return (Any format code)--    {- Case2: shift length is complex (non-immediate)-      * y must go in %ecx.-      * we cannot do y first *and* put its result in %ecx, because-        %ecx might be clobbered by x.-      * if we do y second, then x cannot be-        in a clobbered reg.  Also, we cannot clobber x's reg-        with the instruction itself.-      * so we can either:-        - do y first, put its result in a fresh tmp, then copy it to %ecx later-        - do y second and put its result into %ecx.  x gets placed in a fresh-          tmp.  This is likely to be better, because the reg alloc can-          eliminate this reg->reg move here (it won't eliminate the other one,-          because the move is into the fixed %ecx).-      * in the case of C calls the use of ecx here can interfere with arguments.-        We avoid this with the hack described in Note [Evaluate C-call-        arguments before placing in destination registers]-    -}-    shift_code width instr x y{-amount-} = do-        x_code <- getAnyReg x-        let format = intFormat width-        tmp <- getNewRegNat format-        y_code <- getAnyReg y-        let-           code = x_code tmp `appOL`-                  y_code ecx `snocOL`-                  instr format (OpReg ecx) (OpReg tmp)-        return (Fixed format tmp code)--    ---------------------    add_code :: Width -> CmmExpr -> CmmExpr -> NatM Register-    add_code rep x (CmmLit (CmmInt y _))-        | is32BitInteger y-        , rep /= W8 -- LEA doesn't support byte size (#18614)-        = add_int rep x y-    add_code rep x y = trivialCode rep (ADD format) (Just (ADD format)) x y-      where format = intFormat rep-    -- TODO: There are other interesting patterns we want to replace-    --     with a LEA, e.g. `(x + offset) + (y << shift)`.--    ---------------------    sub_code :: Width -> CmmExpr -> CmmExpr -> NatM Register-    sub_code rep x (CmmLit (CmmInt y _))-        | is32BitInteger (-y)-        , rep /= W8 -- LEA doesn't support byte size (#18614)-        = add_int rep x (-y)-    sub_code rep x y = trivialCode rep (SUB (intFormat rep)) Nothing x y--    -- our three-operand add instruction:-    add_int width x y = do-        (x_reg, x_code) <- getSomeReg x-        let-            format = intFormat width-            imm = ImmInt (fromInteger y)-            code dst-               = x_code `snocOL`-                 LEA format-                        (OpAddr (AddrBaseIndex (EABaseReg x_reg) EAIndexNone imm))-                        (OpReg dst)-        ---        return (Any format code)--    ------------------------    -- See Note [DIV/IDIV for bytes]-    div_code W8 signed quotient x y = do-        let widen | signed    = MO_SS_Conv W8 W16-                  | otherwise = MO_UU_Conv W8 W16-        div_code-            W16-            signed-            quotient-            (CmmMachOp widen [x])-            (CmmMachOp widen [y])--    div_code width signed quotient x y = do-           (y_op, y_code) <- getRegOrMem y -- cannot be clobbered-           x_code <- getAnyReg x-           let-             format = intFormat width-             widen | signed    = CLTD format-                   | otherwise = XOR format (OpReg edx) (OpReg edx)--             instr | signed    = IDIV-                   | otherwise = DIV--             code = y_code `appOL`-                    x_code eax `appOL`-                    toOL [widen, instr format y_op]--             result | quotient  = eax-                    | otherwise = edx--           return (Fixed format result code)---getRegister' _ _ (CmmLoad mem pk _)-  | isFloatType pk-  = do-    Amode addr mem_code <- getAmode mem-    loadFloatAmode  (typeWidth pk) addr mem_code--getRegister' _ is32Bit (CmmLoad mem pk _)-  | is32Bit && not (isWord64 pk)-  = do-    code <- intLoadCode instr mem-    return (Any format code)-  where-    width = typeWidth pk-    format = intFormat width-    instr = case width of-                W8     -> MOVZxL II8-                _other -> MOV format-        -- We always zero-extend 8-bit loads, if we-        -- can't think of anything better.  This is because-        -- we can't guarantee access to an 8-bit variant of every register-        -- (esi and edi don't have 8-bit variants), so to make things-        -- simpler we do our 8-bit arithmetic with full 32-bit registers.---- Simpler memory load code on x86_64-getRegister' _ is32Bit (CmmLoad mem pk _)- | not is32Bit-  = do-    code <- intLoadCode (MOV format) mem-    return (Any format code)-  where format = intFormat $ typeWidth pk--getRegister' _ is32Bit (CmmLit (CmmInt 0 width))-  = let-        format = intFormat width--        -- x86_64: 32-bit xor is one byte shorter, and zero-extends to 64 bits-        format1 = if is32Bit then format-                           else case format of-                                II64 -> II32-                                _ -> format-        code dst-           = unitOL (XOR format1 (OpReg dst) (OpReg dst))-    in-        return (Any format code)---- Handle symbol references with LEA and %rip-relative addressing.--- See Note [%rip-relative addressing on x86-64].-getRegister' platform is32Bit (CmmLit lit)-  | is_label lit-  , not is32Bit-  = do let format = cmmTypeFormat (cmmLitType platform lit)-           imm = litToImm lit-           op = OpAddr (AddrBaseIndex EABaseRip EAIndexNone imm)-           code dst = unitOL (LEA format op (OpReg dst))-       return (Any format code)-  where-    is_label (CmmLabel {})        = True-    is_label (CmmLabelOff {})     = True-    is_label (CmmLabelDiffOff {}) = True-    is_label _                    = False--  -- optimisation for loading small literals on x86_64: take advantage-  -- of the automatic zero-extension from 32 to 64 bits, because the 32-bit-  -- instruction forms are shorter.-getRegister' platform is32Bit (CmmLit lit)-  | not is32Bit, isWord64 (cmmLitType platform lit), not (isBigLit lit)-  = let-        imm = litToImm lit-        code dst = unitOL (MOV II32 (OpImm imm) (OpReg dst))-    in-        return (Any II64 code)-  where-   isBigLit (CmmInt i _) = i < 0 || i > 0xffffffff-   isBigLit _ = False-        -- note1: not the same as (not.is32BitLit), because that checks for-        -- signed literals that fit in 32 bits, but we want unsigned-        -- literals here.-        -- note2: all labels are small, because we're assuming the-        -- small memory model. See Note [%rip-relative addressing on x86-64].--getRegister' platform _ (CmmLit lit)-  = do let format = cmmTypeFormat (cmmLitType platform lit)-           imm = litToImm lit-           code dst = unitOL (MOV format (OpImm imm) (OpReg dst))-       return (Any format code)--getRegister' platform _ other-    | isVecExpr other  = needLlvm-    | otherwise        = pprPanic "getRegister(x86)" (pdoc platform other)---intLoadCode :: (Operand -> Operand -> Instr) -> CmmExpr-   -> NatM (Reg -> InstrBlock)-intLoadCode instr mem = do-  Amode src mem_code <- getAmode mem-  return (\dst -> mem_code `snocOL` instr (OpAddr src) (OpReg dst))---- Compute an expression into *any* register, adding the appropriate--- move instruction if necessary.-getAnyReg :: CmmExpr -> NatM (Reg -> InstrBlock)-getAnyReg expr = do-  r <- getRegister expr-  anyReg r--anyReg :: Register -> NatM (Reg -> InstrBlock)-anyReg (Any _ code)          = return code-anyReg (Fixed rep reg fcode) = return (\dst -> fcode `snocOL` reg2reg rep reg dst)---- A bit like getSomeReg, but we want a reg that can be byte-addressed.--- Fixed registers might not be byte-addressable, so we make sure we've--- got a temporary, inserting an extra reg copy if necessary.-getByteReg :: CmmExpr -> NatM (Reg, InstrBlock)-getByteReg expr = do-  is32Bit <- is32BitPlatform-  if is32Bit-      then do r <- getRegister expr-              case r of-                Any rep code -> do-                    tmp <- getNewRegNat rep-                    return (tmp, code tmp)-                Fixed rep reg code-                    | isVirtualReg reg -> return (reg,code)-                    | otherwise -> do-                        tmp <- getNewRegNat rep-                        return (tmp, code `snocOL` reg2reg rep reg tmp)-                    -- ToDo: could optimise slightly by checking for-                    -- byte-addressable real registers, but that will-                    -- happen very rarely if at all.-      else getSomeReg expr -- all regs are byte-addressable on x86_64---- Another variant: this time we want the result in a register that cannot--- be modified by code to evaluate an arbitrary expression.-getNonClobberedReg :: CmmExpr -> NatM (Reg, InstrBlock)-getNonClobberedReg expr = do-  r <- getRegister expr-  platform <- ncgPlatform <$> getConfig-  case r of-    Any rep code -> do-        tmp <- getNewRegNat rep-        return (tmp, code tmp)-    Fixed rep reg code-        -- only certain regs can be clobbered-        | reg `elem` instrClobberedRegs platform-        -> do-                tmp <- getNewRegNat rep-                return (tmp, code `snocOL` reg2reg rep reg tmp)-        | otherwise ->-                return (reg, code)--reg2reg :: Format -> Reg -> Reg -> Instr-reg2reg format src dst = MOV format (OpReg src) (OpReg dst)--------------------------------------------------------------------------------------- | Convert a 'CmmExpr' representing a memory address into an 'Amode'.------ An 'Amode' is a datatype representing a valid address form for the target--- (e.g. "Base + Index + disp" or immediate) and the code to compute it.-getAmode :: CmmExpr -> NatM Amode-getAmode e = do-   platform <- getPlatform-   let is32Bit = target32Bit platform--   case e of-      CmmRegOff r n-         -> getAmode $ mangleIndexTree platform r n--      CmmMachOp (MO_Add W64) [CmmReg (CmmGlobal PicBaseReg), CmmLit displacement]-         | not is32Bit-         -> return $ Amode (ripRel (litToImm displacement)) nilOL--      -- This is all just ridiculous, since it carefully undoes-      -- what mangleIndexTree has just done.-      CmmMachOp (MO_Sub _rep) [x, CmmLit lit@(CmmInt i _)]-         | is32BitLit platform lit-         -- assert (rep == II32)???-         -> do-            (x_reg, x_code) <- getSomeReg x-            let off = ImmInt (-(fromInteger i))-            return (Amode (AddrBaseIndex (EABaseReg x_reg) EAIndexNone off) x_code)--      CmmMachOp (MO_Add _rep) [x, CmmLit lit]-         | is32BitLit platform lit-         -- assert (rep == II32)???-         -> do-            (x_reg, x_code) <- getSomeReg x-            let off = litToImm lit-            return (Amode (AddrBaseIndex (EABaseReg x_reg) EAIndexNone off) x_code)--      -- Turn (lit1 << n  + lit2) into  (lit2 + lit1 << n) so it will be-      -- recognised by the next rule.-      CmmMachOp (MO_Add rep) [a@(CmmMachOp (MO_Shl _) _), b@(CmmLit _)]-         -> getAmode (CmmMachOp (MO_Add rep) [b,a])--      -- Matches: (x + offset) + (y << shift)-      CmmMachOp (MO_Add _) [CmmRegOff x offset, CmmMachOp (MO_Shl _) [y, CmmLit (CmmInt shift _)]]-         | shift == 0 || shift == 1 || shift == 2 || shift == 3-         -> x86_complex_amode (CmmReg x) y shift (fromIntegral offset)--      CmmMachOp (MO_Add _) [x, CmmMachOp (MO_Shl _) [y, CmmLit (CmmInt shift _)]]-         | shift == 0 || shift == 1 || shift == 2 || shift == 3-         -> x86_complex_amode x y shift 0--      CmmMachOp (MO_Add _) [x, CmmMachOp (MO_Add _) [CmmMachOp (MO_Shl _)-                                                    [y, CmmLit (CmmInt shift _)], CmmLit (CmmInt offset _)]]-         | shift == 0 || shift == 1 || shift == 2 || shift == 3-         && is32BitInteger offset-         -> x86_complex_amode x y shift offset--      CmmMachOp (MO_Add _) [x,y]-         | not (isLit y) -- we already handle valid literals above.-         -> x86_complex_amode x y 0 0--      -- Handle labels with %rip-relative addressing since in general the image-      -- may be loaded anywhere in the 64-bit address space (e.g. on Windows-      -- with high-entropy ASLR). See Note [%rip-relative addressing on x86-64].-      CmmLit lit-         | not is32Bit-         , is_label lit-         -> return (Amode (AddrBaseIndex EABaseRip EAIndexNone (litToImm lit)) nilOL)--      CmmLit lit-         | is32BitLit platform lit-         -> return (Amode (ImmAddr (litToImm lit) 0) nilOL)--      -- Literal with offsets too big (> 32 bits) fails during the linking phase-      -- (#15570). We already handled valid literals above so we don't have to-      -- test anything here.-      CmmLit (CmmLabelOff l off)-         -> getAmode (CmmMachOp (MO_Add W64) [ CmmLit (CmmLabel l)-                                             , CmmLit (CmmInt (fromIntegral off) W64)-                                             ])-      CmmLit (CmmLabelDiffOff l1 l2 off w)-         -> getAmode (CmmMachOp (MO_Add W64) [ CmmLit (CmmLabelDiffOff l1 l2 0 w)-                                             , CmmLit (CmmInt (fromIntegral off) W64)-                                             ])--      -- in case we can't do something better, we just compute the expression-      -- and put the result in a register-      _ -> do-        (reg,code) <- getSomeReg e-        return (Amode (AddrBaseIndex (EABaseReg reg) EAIndexNone (ImmInt 0)) code)-  where-    is_label (CmmLabel{}) = True-    is_label (CmmLabelOff{}) = True-    is_label (CmmLabelDiffOff{}) = True-    is_label _ = False----- | Like 'getAmode', but on 32-bit use simple register addressing--- (i.e. no index register). This stops us from running out of--- registers on x86 when using instructions such as cmpxchg, which can--- use up to three virtual registers and one fixed register.-getSimpleAmode :: CmmExpr -> NatM Amode-getSimpleAmode addr = is32BitPlatform >>= \case-  False -> getAmode addr-  True  -> do-    addr_code <- getAnyReg addr-    config <- getConfig-    addr_r <- getNewRegNat (intFormat (ncgWordWidth config))-    let amode = AddrBaseIndex (EABaseReg addr_r) EAIndexNone (ImmInt 0)-    return $! Amode amode (addr_code addr_r)--x86_complex_amode :: CmmExpr -> CmmExpr -> Integer -> Integer -> NatM Amode-x86_complex_amode base index shift offset-  = do (x_reg, x_code) <- getNonClobberedReg base-        -- x must be in a temp, because it has to stay live over y_code-        -- we could compare x_reg and y_reg and do something better here...-       (y_reg, y_code) <- getSomeReg index-       let-           code = x_code `appOL` y_code-           base = case shift of 0 -> 1; 1 -> 2; 2 -> 4; 3 -> 8;-                                n -> panic $ "x86_complex_amode: unhandled shift! (" ++ show n ++ ")"-       return (Amode (AddrBaseIndex (EABaseReg x_reg) (EAIndex y_reg base) (ImmInt (fromIntegral offset)))-               code)------- -------------------------------------------------------------------------------- getOperand: sometimes any operand will do.---- getNonClobberedOperand: the value of the operand will remain valid across--- the computation of an arbitrary expression, unless the expression--- is computed directly into a register which the operand refers to--- (see trivialCode where this function is used for an example).--getNonClobberedOperand :: CmmExpr -> NatM (Operand, InstrBlock)-getNonClobberedOperand (CmmLit lit) =-  if isSuitableFloatingPointLit lit-  then do-    let CmmFloat _ w = lit-    Amode addr code <- memConstant (mkAlignment $ widthInBytes w) lit-    return (OpAddr addr, code)-  else do-    platform <- getPlatform-    if is32BitLit platform lit && not (isFloatType (cmmLitType platform lit))-    then return (OpImm (litToImm lit), nilOL)-    else getNonClobberedOperand_generic (CmmLit lit)--getNonClobberedOperand (CmmLoad mem pk _) = do-  is32Bit <- is32BitPlatform-  -- this logic could be simplified-  -- TODO FIXME-  if   (if is32Bit then not (isWord64 pk) else True)-      -- if 32bit and pk is at float/double/simd value-      -- or if 64bit-      --  this could use some eyeballs or i'll need to stare at it more later-    then do-      platform <- ncgPlatform <$> getConfig-      Amode src mem_code <- getAmode mem-      (src',save_code) <--        if (amodeCouldBeClobbered platform src)-                then do-                   tmp <- getNewRegNat (archWordFormat is32Bit)-                   return (AddrBaseIndex (EABaseReg tmp) EAIndexNone (ImmInt 0),-                           unitOL (LEA (archWordFormat is32Bit)-                                       (OpAddr src)-                                       (OpReg tmp)))-                else-                   return (src, nilOL)-      return (OpAddr src', mem_code `appOL` save_code)-    else-      -- if its a word or gcptr on 32bit?-      getNonClobberedOperand_generic (CmmLoad mem pk NaturallyAligned)--getNonClobberedOperand e = getNonClobberedOperand_generic e--getNonClobberedOperand_generic :: CmmExpr -> NatM (Operand, InstrBlock)-getNonClobberedOperand_generic e = do-  (reg, code) <- getNonClobberedReg e-  return (OpReg reg, code)--amodeCouldBeClobbered :: Platform -> AddrMode -> Bool-amodeCouldBeClobbered platform amode = any (regClobbered platform) (addrModeRegs amode)--regClobbered :: Platform -> Reg -> Bool-regClobbered platform (RegReal (RealRegSingle rr)) = freeReg platform rr-regClobbered _ _ = False---- getOperand: the operand is not required to remain valid across the--- computation of an arbitrary expression.-getOperand :: CmmExpr -> NatM (Operand, InstrBlock)--getOperand (CmmLit lit) = do-  use_sse2 <- sse2Enabled-  if (use_sse2 && isSuitableFloatingPointLit lit)-    then do-      let CmmFloat _ w = lit-      Amode addr code <- memConstant (mkAlignment $ widthInBytes w) lit-      return (OpAddr addr, code)-    else do--  platform <- getPlatform-  if is32BitLit platform lit && not (isFloatType (cmmLitType platform lit))-    then return (OpImm (litToImm lit), nilOL)-    else getOperand_generic (CmmLit lit)--getOperand (CmmLoad mem pk _) = do-  is32Bit <- is32BitPlatform-  use_sse2 <- sse2Enabled-  if (not (isFloatType pk) || use_sse2) && (if is32Bit then not (isWord64 pk) else True)-     then do-       Amode src mem_code <- getAmode mem-       return (OpAddr src, mem_code)-     else-       getOperand_generic (CmmLoad mem pk NaturallyAligned)--getOperand e = getOperand_generic e--getOperand_generic :: CmmExpr -> NatM (Operand, InstrBlock)-getOperand_generic e = do-    (reg, code) <- getSomeReg e-    return (OpReg reg, code)--isOperand :: Platform -> CmmExpr -> Bool-isOperand _ (CmmLoad _ _ _) = True-isOperand platform (CmmLit lit)-                          = is32BitLit platform lit-                          || isSuitableFloatingPointLit lit-isOperand _ _            = False---- | Given a 'Register', produce a new 'Register' with an instruction block--- which will check the value for alignment. Used for @-falignment-sanitisation@.-addAlignmentCheck :: Int -> Register -> Register-addAlignmentCheck align reg =-    case reg of-      Fixed fmt reg code -> Fixed fmt reg (code `appOL` check fmt reg)-      Any fmt f          -> Any fmt (\reg -> f reg `appOL` check fmt reg)-  where-    check :: Format -> Reg -> InstrBlock-    check fmt reg =-        assert (not $ isFloatFormat fmt) $-        toOL [ TEST fmt (OpImm $ ImmInt $ align-1) (OpReg reg)-             , JXX_GBL NE $ ImmCLbl mkBadAlignmentLabel-             ]--memConstant :: Alignment -> CmmLit -> NatM Amode-memConstant align lit = do-  lbl <- getNewLabelNat-  let rosection = Section ReadOnlyData lbl-  config <- getConfig-  platform <- getPlatform-  (addr, addr_code) <- if target32Bit platform-                       then do dynRef <- cmmMakeDynamicReference-                                             config-                                             DataReference-                                             lbl-                               Amode addr addr_code <- getAmode dynRef-                               return (addr, addr_code)-                       else return (ripRel (ImmCLbl lbl), nilOL)-  let code =-        LDATA rosection (align, CmmStaticsRaw lbl [CmmStaticLit lit])-        `consOL` addr_code-  return (Amode addr code)---loadFloatAmode :: Width -> AddrMode -> InstrBlock -> NatM Register-loadFloatAmode w addr addr_code = do-  let format = floatFormat w-      code dst = addr_code `snocOL`-                    MOV format (OpAddr addr) (OpReg dst)--  return (Any format code)----- if we want a floating-point literal as an operand, we can--- use it directly from memory.  However, if the literal is--- zero, we're better off generating it into a register using--- xor.-isSuitableFloatingPointLit :: CmmLit -> Bool-isSuitableFloatingPointLit (CmmFloat f _) = f /= 0.0-isSuitableFloatingPointLit _ = False--getRegOrMem :: CmmExpr -> NatM (Operand, InstrBlock)-getRegOrMem e@(CmmLoad mem pk _) = do-  is32Bit <- is32BitPlatform-  use_sse2 <- sse2Enabled-  if (not (isFloatType pk) || use_sse2) && (if is32Bit then not (isWord64 pk) else True)-     then do-       Amode src mem_code <- getAmode mem-       return (OpAddr src, mem_code)-     else do-       (reg, code) <- getNonClobberedReg e-       return (OpReg reg, code)-getRegOrMem e = do-    (reg, code) <- getNonClobberedReg e-    return (OpReg reg, code)--is32BitLit :: Platform -> CmmLit -> Bool-is32BitLit platform _lit-   | target32Bit platform = True-is32BitLit platform lit =-   case lit of-      CmmInt i W64              -> is32BitInteger i-      -- Except on Windows, assume that labels are in the range 0-2^31-1: this-      -- assumes the small memory model. Note [%rip-relative addressing on-      -- x86-64].-      CmmLabel _                -> low_image-      -- however we can't assume that label offsets are in this range-      -- (see #15570)-      CmmLabelOff _ off         -> low_image && is32BitInteger (fromIntegral off)-      CmmLabelDiffOff _ _ off _ -> low_image && is32BitInteger (fromIntegral off)-      _                         -> True-  where-    -- Is the executable image certain to be located below 4GB? As noted in-    -- Note [%rip-relative addressing on x86-64], this is not true on Windows.-    low_image =-      case platformOS platform of-        OSMinGW32 -> False   -- See Note [%rip-relative addressing on x86-64]-        _         -> True----- Set up a condition code for a conditional branch.--getCondCode :: CmmExpr -> NatM CondCode---- yes, they really do seem to want exactly the same!--getCondCode (CmmMachOp mop [x, y])-  =-    case mop of-      MO_F_Eq W32 -> condFltCode EQQ x y-      MO_F_Ne W32 -> condFltCode NE  x y-      MO_F_Gt W32 -> condFltCode GTT x y-      MO_F_Ge W32 -> condFltCode GE  x y-      -- Invert comparison condition and swap operands-      -- See Note [SSE Parity Checks]-      MO_F_Lt W32 -> condFltCode GTT  y x-      MO_F_Le W32 -> condFltCode GE   y x--      MO_F_Eq W64 -> condFltCode EQQ x y-      MO_F_Ne W64 -> condFltCode NE  x y-      MO_F_Gt W64 -> condFltCode GTT x y-      MO_F_Ge W64 -> condFltCode GE  x y-      MO_F_Lt W64 -> condFltCode GTT y x-      MO_F_Le W64 -> condFltCode GE  y x--      _ -> condIntCode (machOpToCond mop) x y--getCondCode other = do-   platform <- getPlatform-   pprPanic "getCondCode(2)(x86,x86_64)" (pdoc platform other)--machOpToCond :: MachOp -> Cond-machOpToCond mo = case mo of-  MO_Eq _   -> EQQ-  MO_Ne _   -> NE-  MO_S_Gt _ -> GTT-  MO_S_Ge _ -> GE-  MO_S_Lt _ -> LTT-  MO_S_Le _ -> LE-  MO_U_Gt _ -> GU-  MO_U_Ge _ -> GEU-  MO_U_Lt _ -> LU-  MO_U_Le _ -> LEU-  _other -> pprPanic "machOpToCond" (pprMachOp mo)----- @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be--- passed back up the tree.--condIntCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode-condIntCode cond x y = do platform <- getPlatform-                          condIntCode' platform cond x y--condIntCode' :: Platform -> Cond -> CmmExpr -> CmmExpr -> NatM CondCode---- memory vs immediate-condIntCode' platform cond (CmmLoad x pk _) (CmmLit lit)- | is32BitLit platform lit = do-    Amode x_addr x_code <- getAmode x-    let-        imm  = litToImm lit-        code = x_code `snocOL`-                  CMP (cmmTypeFormat pk) (OpImm imm) (OpAddr x_addr)-    ---    return (CondCode False cond code)---- anything vs zero, using a mask--- TODO: Add some sanity checking!!!!-condIntCode' platform cond (CmmMachOp (MO_And _) [x,o2]) (CmmLit (CmmInt 0 pk))-    | (CmmLit lit@(CmmInt mask _)) <- o2, is32BitLit platform lit-    = do-      (x_reg, x_code) <- getSomeReg x-      let-         code = x_code `snocOL`-                TEST (intFormat pk) (OpImm (ImmInteger mask)) (OpReg x_reg)-      ---      return (CondCode False cond code)---- anything vs zero-condIntCode' _ cond x (CmmLit (CmmInt 0 pk)) = do-    (x_reg, x_code) <- getSomeReg x-    let-        code = x_code `snocOL`-                  TEST (intFormat pk) (OpReg x_reg) (OpReg x_reg)-    ---    return (CondCode False cond code)---- anything vs operand-condIntCode' platform cond x y- | isOperand platform y = do-    (x_reg, x_code) <- getNonClobberedReg x-    (y_op,  y_code) <- getOperand y-    let-        code = x_code `appOL` y_code `snocOL`-                  CMP (cmmTypeFormat (cmmExprType platform x)) y_op (OpReg x_reg)-    return (CondCode False cond code)--- operand vs. anything: invert the comparison so that we can use a--- single comparison instruction.- | isOperand platform x- , Just revcond <- maybeFlipCond cond = do-    (y_reg, y_code) <- getNonClobberedReg y-    (x_op,  x_code) <- getOperand x-    let-        code = y_code `appOL` x_code `snocOL`-                  CMP (cmmTypeFormat (cmmExprType platform x)) x_op (OpReg y_reg)-    return (CondCode False revcond code)---- anything vs anything-condIntCode' platform cond x y = do-  (y_reg, y_code) <- getNonClobberedReg y-  (x_op, x_code) <- getRegOrMem x-  let-        code = y_code `appOL`-               x_code `snocOL`-                  CMP (cmmTypeFormat (cmmExprType platform x)) (OpReg y_reg) x_op-  return (CondCode False cond code)-------------------------------------------------------------------------------------condFltCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode--condFltCode cond x y-  =  condFltCode_sse2-  where---  -- in the SSE2 comparison ops (ucomiss, ucomisd) the left arg may be-  -- an operand, but the right must be a reg.  We can probably do better-  -- than this general case...-  condFltCode_sse2 = do-    platform <- getPlatform-    (x_reg, x_code) <- getNonClobberedReg x-    (y_op, y_code) <- getOperand y-    let-        code = x_code `appOL`-               y_code `snocOL`-                  CMP (floatFormat $ cmmExprWidth platform x) y_op (OpReg x_reg)-        -- NB(1): we need to use the unsigned comparison operators on the-        -- result of this comparison.-    return (CondCode True (condToUnsigned cond) code)---- -------------------------------------------------------------------------------- Generating assignments---- Assignments are really at the heart of the whole code generation--- business.  Almost all top-level nodes of any real importance are--- assignments, which correspond to loads, stores, or register--- transfers.  If we're really lucky, some of the register transfers--- will go away, because we can use the destination register to--- complete the code generation for the right hand side.  This only--- fails when the right hand side is forced into a fixed register--- (e.g. the result of a call).--assignMem_IntCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock-assignReg_IntCode :: Format -> CmmReg  -> CmmExpr -> NatM InstrBlock--assignMem_FltCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock-assignReg_FltCode :: Format -> CmmReg  -> CmmExpr -> NatM InstrBlock----- integer assignment to memory---- specific case of adding/subtracting an integer to a particular address.--- ToDo: catch other cases where we can use an operation directly on a memory--- address.-assignMem_IntCode pk addr (CmmMachOp op [CmmLoad addr2 _ _,-                                                 CmmLit (CmmInt i _)])-   | addr == addr2, pk /= II64 || is32BitInteger i,-     Just instr <- check op-   = do Amode amode code_addr <- getAmode addr-        let code = code_addr `snocOL`-                   instr pk (OpImm (ImmInt (fromIntegral i))) (OpAddr amode)-        return code-   where-        check (MO_Add _) = Just ADD-        check (MO_Sub _) = Just SUB-        check _ = Nothing-        -- ToDo: more?---- general case-assignMem_IntCode pk addr src = do-    platform <- getPlatform-    Amode addr code_addr <- getAmode addr-    (code_src, op_src)   <- get_op_RI platform src-    let-        code = code_src `appOL`-               code_addr `snocOL`-                  MOV pk op_src (OpAddr addr)-        -- NOTE: op_src is stable, so it will still be valid-        -- after code_addr.  This may involve the introduction-        -- of an extra MOV to a temporary register, but we hope-        -- the register allocator will get rid of it.-    ---    return code-  where-    get_op_RI :: Platform -> CmmExpr -> NatM (InstrBlock,Operand)   -- code, operator-    get_op_RI platform (CmmLit lit) | is32BitLit platform lit-      = return (nilOL, OpImm (litToImm lit))-    get_op_RI _ op-      = do (reg,code) <- getNonClobberedReg op-           return (code, OpReg reg)----- Assign; dst is a reg, rhs is mem-assignReg_IntCode pk reg (CmmLoad src _ _) = do-  load_code <- intLoadCode (MOV pk) src-  platform <- ncgPlatform <$> getConfig-  return (load_code (getRegisterReg platform reg))---- dst is a reg, but src could be anything-assignReg_IntCode _ reg src = do-  platform <- ncgPlatform <$> getConfig-  code <- getAnyReg src-  return (code (getRegisterReg platform reg))----- Floating point assignment to memory-assignMem_FltCode pk addr src = do-  (src_reg, src_code) <- getNonClobberedReg src-  Amode addr addr_code <- getAmode addr-  let-        code = src_code `appOL`-               addr_code `snocOL`-               MOV pk (OpReg src_reg) (OpAddr addr)--  return code---- Floating point assignment to a register/temporary-assignReg_FltCode _ reg src = do-  src_code <- getAnyReg src-  platform <- ncgPlatform <$> getConfig-  return (src_code (getRegisterReg platform reg))---genJump :: CmmExpr{-the branch target-} -> [Reg] -> NatM InstrBlock--genJump (CmmLoad mem _ _) regs = do-  Amode target code <- getAmode mem-  return (code `snocOL` JMP (OpAddr target) regs)--genJump (CmmLit lit) regs =-  return (unitOL (JMP (OpImm (litToImm lit)) regs))--genJump expr regs = do-  (reg,code) <- getSomeReg expr-  return (code `snocOL` JMP (OpReg reg) regs)----- --------------------------------------------------------------------------------  Unconditional branches--genBranch :: BlockId -> InstrBlock-genBranch = toOL . mkJumpInstr------ --------------------------------------------------------------------------------  Conditional jumps/branches--{--Conditional jumps are always to local labels, so we can use branch-instructions.  We peek at the arguments to decide what kind of-comparison to do.--I386: First, we have to ensure that the condition-codes are set according to the supplied comparison operation.--}--{-  Note [64-bit integer comparisons on 32-bit]-    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--    When doing these comparisons there are 2 kinds of-    comparisons.--    * Comparison for equality (or lack thereof)--    We use xor to check if high/low bits are-    equal. Then combine the results using or and-    perform a single conditional jump based on the-    result.--    * Other comparisons:--    We map all other comparisons to the >= operation.-    Why? Because it's easy to encode it with a single-    conditional jump.--    We do this by first computing [r1_lo - r2_lo]-    and use the carry flag to compute-    [r1_high - r2_high - CF].--    At which point if r1 >= r2 then the result will be-    positive. Otherwise negative so we can branch on this-    condition.---}---genCondBranch-    :: BlockId      -- the source of the jump-    -> BlockId      -- the true branch target-    -> BlockId      -- the false branch target-    -> CmmExpr      -- the condition on which to branch-    -> NatM InstrBlock -- Instructions--genCondBranch bid id false expr = do-  is32Bit <- is32BitPlatform-  genCondBranch' is32Bit bid id false expr---- | We return the instructions generated.-genCondBranch' :: Bool -> BlockId -> BlockId -> BlockId -> CmmExpr-               -> NatM InstrBlock---- 64-bit integer comparisons on 32-bit--- See Note [64-bit integer comparisons on 32-bit]-genCondBranch' is32Bit _bid true false (CmmMachOp mop [e1,e2])-  | is32Bit, Just W64 <- maybeIntComparison mop = do--  RegCode64 code1 r1hi r1lo <- iselExpr64 e1-  RegCode64 code2 r2hi r2lo <- iselExpr64 e2-  let cond = machOpToCond mop :: Cond--  -- we mustn't clobber r1/r2 so we use temporaries-  tmp1 <- getNewRegNat II32-  tmp2 <- getNewRegNat II32--  let cmpCode = intComparison cond true false r1hi r1lo r2hi r2lo tmp1 tmp2-  return $ code1 `appOL` code2 `appOL` cmpCode--  where-    intComparison cond true false r1_hi r1_lo r2_hi r2_lo tmp1 tmp2 =-      case cond of-        -- Impossible results of machOpToCond-        ALWAYS  -> panic "impossible"-        NEG     -> panic "impossible"-        POS     -> panic "impossible"-        CARRY   -> panic "impossible"-        OFLO    -> panic "impossible"-        PARITY  -> panic "impossible"-        NOTPARITY -> panic "impossible"-        -- Special case #1 x == y and x != y-        EQQ -> cmpExact-        NE  -> cmpExact-        -- [x >= y]-        GE  -> cmpGE-        GEU -> cmpGE-        -- [x >  y] <==> ![y >= x]-        GTT -> intComparison GE  false true r2_hi r2_lo r1_hi r1_lo tmp1 tmp2-        GU  -> intComparison GEU false true r2_hi r2_lo r1_hi r1_lo tmp1 tmp2-        -- [x <= y] <==> [y >= x]-        LE  -> intComparison GE  true false r2_hi r2_lo r1_hi r1_lo tmp1 tmp2-        LEU -> intComparison GEU true false r2_hi r2_lo r1_hi r1_lo tmp1 tmp2-        -- [x <  y] <==> ![x >= x]-        LTT -> intComparison GE  false true r1_hi r1_lo r2_hi r2_lo tmp1 tmp2-        LU  -> intComparison GEU false true r1_hi r1_lo r2_hi r2_lo tmp1 tmp2-      where-        cmpExact :: OrdList Instr-        cmpExact =-          toOL-            [ MOV II32 (OpReg r1_hi) (OpReg tmp1)-            , MOV II32 (OpReg r1_lo) (OpReg tmp2)-            , XOR II32 (OpReg r2_hi) (OpReg tmp1)-            , XOR II32 (OpReg r2_lo) (OpReg tmp2)-            , OR  II32 (OpReg tmp1)  (OpReg tmp2)-            , JXX cond true-            , JXX ALWAYS false-            ]-        cmpGE = toOL-            [ MOV II32 (OpReg r1_hi) (OpReg tmp1)-            , CMP II32 (OpReg r2_lo) (OpReg r1_lo)-            , SBB II32 (OpReg r2_hi) (OpReg tmp1)-            , JXX cond true-            , JXX ALWAYS false ]--genCondBranch' _ bid id false bool = do-  CondCode is_float cond cond_code <- getCondCode bool-  use_sse2 <- sse2Enabled-  if not is_float || not use_sse2-    then-        return (cond_code `snocOL` JXX cond id `appOL` genBranch false)-    else do-        -- See Note [SSE Parity Checks]-        let jmpFalse = genBranch false-            code-                = case cond of-                  NE  -> or_unordered-                  GU  -> plain_test-                  GEU -> plain_test-                  -- Use ASSERT so we don't break releases if-                  -- LTT/LE creep in somehow.-                  LTT ->-                    assertPpr False (ppr "Should have been turned into >")-                    and_ordered-                  LE  ->-                    assertPpr False (ppr "Should have been turned into >=")-                    and_ordered-                  _   -> and_ordered--            plain_test = unitOL (-                  JXX cond id-                ) `appOL` jmpFalse-            or_unordered = toOL [-                  JXX cond id,-                  JXX PARITY id-                ] `appOL` jmpFalse-            and_ordered = toOL [-                  JXX PARITY false,-                  JXX cond id,-                  JXX ALWAYS false-                ]-        updateCfgNat (\cfg -> adjustEdgeWeight cfg (+3) bid false)-        return (cond_code `appOL` code)--{-  Note [Introducing cfg edges inside basic blocks]-    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--    During instruction selection a statement `s`-    in a block B with control of the sort: B -> C-    will sometimes result in control-    flow of the sort:--            ┌ < ┐-            v   ^-      B ->  B1  ┴ -> C--    as is the case for some atomic operations.--    Now to keep the CFG in sync when introducing B1 we clearly-    want to insert it between B and C. However there is-    a catch when we have to deal with self loops.--    We might start with code and a CFG of these forms:--    loop:-        stmt1               ┌ < ┐-        ....                v   ^-        stmtX              loop ┘-        stmtY-        ....-        goto loop:--    Now we introduce B1:-                            ┌ ─ ─ ─ ─ ─┐-        loop:               │   ┌ <  ┐ │-        instrs              v   │    │ ^-        ....               loop ┴ B1 ┴ ┘-        instrsFromX-        stmtY-        goto loop:--    This is simple, all outgoing edges from loop now simply-    start from B1 instead and the code generator knows which-    new edges it introduced for the self loop of B1.--    Disaster strikes if the statement Y follows the same pattern.-    If we apply the same rule that all outgoing edges change then-    we end up with:--        loop ─> B1 ─> B2 ┬─┐-          │      │    └─<┤ │-          │      └───<───┘ │-          └───────<────────┘--    This is problematic. The edge B1->B1 is modified as expected.-    However the modification is wrong!--    The assembly in this case looked like this:--    _loop:-        <instrs>-    _B1:-        ...-        cmpxchgq ...-        jne _B1-        <instrs>-        <end _B1>-    _B2:-        ...-        cmpxchgq ...-        jne _B2-        <instrs>-        jmp loop--    There is no edge _B2 -> _B1 here. It's still a self loop onto _B1.--    The problem here is that really B1 should be two basic blocks.-    Otherwise we have control flow in the *middle* of a basic block.-    A contradiction!--    So to account for this we add yet another basic block marker:--    _B:-        <instrs>-    _B1:-        ...-        cmpxchgq ...-        jne _B1-        jmp _B1'-    _B1':-        <instrs>-        <end _B1>-    _B2:-        ...--    Now when inserting B2 we will only look at the outgoing edges of B1' and-    everything will work out nicely.--    You might also wonder why we don't insert jumps at the end of _B1'. There is-    no way another block ends up jumping to the labels _B1 or _B2 since they are-    essentially invisible to other blocks. View them as control flow labels local-    to the basic block if you'd like.--    Not doing this ultimately caused (part 2 of) #17334.--}----- --------------------------------------------------------------------------------  Generating C calls---- Now the biggest nightmare---calls.  Most of the nastiness is buried in--- @get_arg@, which moves the arguments to the correct registers/stack--- locations.  Apart from that, the code is easy.------ (If applicable) Do not fill the delay slots here; you will confuse the--- register allocator.------ See Note [Keeping track of the current block] for information why we need--- to take/return a block id.--genForeignCall-    :: ForeignTarget -- ^ function to call-    -> [CmmFormal]   -- ^ where to put the result-    -> [CmmActual]   -- ^ arguments (of mixed type)-    -> BlockId       -- ^ The block we are in-    -> NatM (InstrBlock, Maybe BlockId)--genForeignCall target dst args bid = do-  case target of-    PrimTarget prim         -> genPrim bid prim dst args-    ForeignTarget addr conv -> (,Nothing) <$> genCCall bid addr conv dst args--genPrim-    :: BlockId       -- ^ The block we are in-    -> CallishMachOp -- ^ MachOp-    -> [CmmFormal]   -- ^ where to put the result-    -> [CmmActual]   -- ^ arguments (of mixed type)-    -> NatM (InstrBlock, Maybe BlockId)---- First we deal with cases which might introduce new blocks in the stream.-genPrim bid (MO_AtomicRMW width amop) [dst] [addr, n]-  = genAtomicRMW bid width amop dst addr n-genPrim bid (MO_Ctz width) [dst] [src]-  = genCtz bid width dst src---- Then we deal with cases which not introducing new blocks in the stream.-genPrim bid prim dst args-  = (,Nothing) <$> genSimplePrim bid prim dst args--genSimplePrim-    :: BlockId       -- ^ the block we are in-    -> CallishMachOp -- ^ MachOp-    -> [CmmFormal]   -- ^ where to put the result-    -> [CmmActual]   -- ^ arguments (of mixed type)-    -> NatM InstrBlock-genSimplePrim bid (MO_Memcpy align)    []      [dst,src,n]    = genMemCpy  bid align dst src n-genSimplePrim bid (MO_Memmove align)   []      [dst,src,n]    = genMemMove bid align dst src n-genSimplePrim bid (MO_Memcmp align)    [res]   [dst,src,n]    = genMemCmp  bid align res dst src n-genSimplePrim bid (MO_Memset align)    []      [dst,c,n]      = genMemSet  bid align dst c n-genSimplePrim _   MO_ReadBarrier       []      []             = return nilOL -- barriers compile to no code on x86/x86-64;-genSimplePrim _   MO_WriteBarrier      []      []             = return nilOL -- we keep it this long in order to prevent earlier optimisations.-genSimplePrim _   MO_Touch             []      [_]            = return nilOL-genSimplePrim _   (MO_Prefetch_Data n) []      [src]          = genPrefetchData n src-genSimplePrim _   (MO_BSwap width)     [dst]   [src]          = genByteSwap width dst src-genSimplePrim bid (MO_BRev width)      [dst]   [src]          = genBitRev bid width dst src-genSimplePrim bid (MO_PopCnt width)    [dst]   [src]          = genPopCnt bid width dst src-genSimplePrim bid (MO_Pdep width)      [dst]   [src,mask]     = genPdep bid width dst src mask-genSimplePrim bid (MO_Pext width)      [dst]   [src,mask]     = genPext bid width dst src mask-genSimplePrim bid (MO_Clz width)       [dst]   [src]          = genClz bid width dst src-genSimplePrim bid (MO_UF_Conv width)   [dst]   [src]          = genWordToFloat bid width dst src-genSimplePrim _   (MO_AtomicRead w)    [dst]   [addr]         = genAtomicRead w dst addr-genSimplePrim _   (MO_AtomicWrite w)   []      [addr,val]     = genAtomicWrite w addr val-genSimplePrim bid (MO_Cmpxchg width)   [dst]   [addr,old,new] = genCmpXchg bid width dst addr old new-genSimplePrim _   (MO_Xchg width)      [dst]   [addr, value]  = genXchg width dst addr value-genSimplePrim _   (MO_AddWordC w)      [r,c]   [x,y]          = genAddSubRetCarry w ADD_CC (const Nothing) CARRY r c x y-genSimplePrim _   (MO_SubWordC w)      [r,c]   [x,y]          = genAddSubRetCarry w SUB_CC (const Nothing) CARRY r c x y-genSimplePrim _   (MO_AddIntC w)       [r,c]   [x,y]          = genAddSubRetCarry w ADD_CC (Just . ADD_CC) OFLO  r c x y-genSimplePrim _   (MO_SubIntC w)       [r,c]   [x,y]          = genAddSubRetCarry w SUB_CC (const Nothing) OFLO  r c x y-genSimplePrim _   (MO_Add2 w)          [h,l]   [x,y]          = genAddWithCarry w h l x y-genSimplePrim _   (MO_U_Mul2 w)        [h,l]   [x,y]          = genUnsignedLargeMul w h l x y-genSimplePrim _   (MO_S_Mul2 w)        [c,h,l] [x,y]          = genSignedLargeMul w c h l x y-genSimplePrim _   (MO_S_QuotRem w)     [q,r]   [x,y]          = genQuotRem w True  q r Nothing   x  y-genSimplePrim _   (MO_U_QuotRem w)     [q,r]   [x,y]          = genQuotRem w False q r Nothing   x  y-genSimplePrim _   (MO_U_QuotRem2 w)    [q,r]   [hx,lx,y]      = genQuotRem w False q r (Just hx) lx y-genSimplePrim _   MO_F32_Fabs          [dst]   [src]          = genFloatAbs W32 dst src-genSimplePrim _   MO_F64_Fabs          [dst]   [src]          = genFloatAbs W64 dst src-genSimplePrim _   MO_F32_Sqrt          [dst]   [src]          = genFloatSqrt FF32 dst src-genSimplePrim _   MO_F64_Sqrt          [dst]   [src]          = genFloatSqrt FF64 dst src-genSimplePrim bid MO_F32_Sin           [dst]   [src]          = genLibCCall bid (fsLit "sinf") [dst] [src]-genSimplePrim bid MO_F32_Cos           [dst]   [src]          = genLibCCall bid (fsLit "cosf") [dst] [src]-genSimplePrim bid MO_F32_Tan           [dst]   [src]          = genLibCCall bid (fsLit "tanf") [dst] [src]-genSimplePrim bid MO_F32_Exp           [dst]   [src]          = genLibCCall bid (fsLit "expf") [dst] [src]-genSimplePrim bid MO_F32_ExpM1         [dst]   [src]          = genLibCCall bid (fsLit "expm1f") [dst] [src]-genSimplePrim bid MO_F32_Log           [dst]   [src]          = genLibCCall bid (fsLit "logf") [dst] [src]-genSimplePrim bid MO_F32_Log1P         [dst]   [src]          = genLibCCall bid (fsLit "log1pf") [dst] [src]-genSimplePrim bid MO_F32_Asin          [dst]   [src]          = genLibCCall bid (fsLit "asinf") [dst] [src]-genSimplePrim bid MO_F32_Acos          [dst]   [src]          = genLibCCall bid (fsLit "acosf") [dst] [src]-genSimplePrim bid MO_F32_Atan          [dst]   [src]          = genLibCCall bid (fsLit "atanf") [dst] [src]-genSimplePrim bid MO_F32_Sinh          [dst]   [src]          = genLibCCall bid (fsLit "sinhf") [dst] [src]-genSimplePrim bid MO_F32_Cosh          [dst]   [src]          = genLibCCall bid (fsLit "coshf") [dst] [src]-genSimplePrim bid MO_F32_Tanh          [dst]   [src]          = genLibCCall bid (fsLit "tanhf") [dst] [src]-genSimplePrim bid MO_F32_Pwr           [dst]   [x,y]          = genLibCCall bid (fsLit "powf")  [dst] [x,y]-genSimplePrim bid MO_F32_Asinh         [dst]   [src]          = genLibCCall bid (fsLit "asinhf") [dst] [src]-genSimplePrim bid MO_F32_Acosh         [dst]   [src]          = genLibCCall bid (fsLit "acoshf") [dst] [src]-genSimplePrim bid MO_F32_Atanh         [dst]   [src]          = genLibCCall bid (fsLit "atanhf") [dst] [src]-genSimplePrim bid MO_F64_Sin           [dst]   [src]          = genLibCCall bid (fsLit "sin") [dst] [src]-genSimplePrim bid MO_F64_Cos           [dst]   [src]          = genLibCCall bid (fsLit "cos") [dst] [src]-genSimplePrim bid MO_F64_Tan           [dst]   [src]          = genLibCCall bid (fsLit "tan") [dst] [src]-genSimplePrim bid MO_F64_Exp           [dst]   [src]          = genLibCCall bid (fsLit "exp") [dst] [src]-genSimplePrim bid MO_F64_ExpM1         [dst]   [src]          = genLibCCall bid (fsLit "expm1") [dst] [src]-genSimplePrim bid MO_F64_Log           [dst]   [src]          = genLibCCall bid (fsLit "log") [dst] [src]-genSimplePrim bid MO_F64_Log1P         [dst]   [src]          = genLibCCall bid (fsLit "log1p") [dst] [src]-genSimplePrim bid MO_F64_Asin          [dst]   [src]          = genLibCCall bid (fsLit "asin") [dst] [src]-genSimplePrim bid MO_F64_Acos          [dst]   [src]          = genLibCCall bid (fsLit "acos") [dst] [src]-genSimplePrim bid MO_F64_Atan          [dst]   [src]          = genLibCCall bid (fsLit "atan") [dst] [src]-genSimplePrim bid MO_F64_Sinh          [dst]   [src]          = genLibCCall bid (fsLit "sinh") [dst] [src]-genSimplePrim bid MO_F64_Cosh          [dst]   [src]          = genLibCCall bid (fsLit "cosh") [dst] [src]-genSimplePrim bid MO_F64_Tanh          [dst]   [src]          = genLibCCall bid (fsLit "tanh") [dst] [src]-genSimplePrim bid MO_F64_Pwr           [dst]   [x,y]          = genLibCCall bid (fsLit "pow")  [dst] [x,y]-genSimplePrim bid MO_F64_Asinh         [dst]   [src]          = genLibCCall bid (fsLit "asinh") [dst] [src]-genSimplePrim bid MO_F64_Acosh         [dst]   [src]          = genLibCCall bid (fsLit "acosh") [dst] [src]-genSimplePrim bid MO_F64_Atanh         [dst]   [src]          = genLibCCall bid (fsLit "atanh") [dst] [src]-genSimplePrim bid MO_SuspendThread     [tok]   [rs,i]         = genRTSCCall bid (fsLit "suspendThread") [tok] [rs,i]-genSimplePrim bid MO_ResumeThread      [rs]    [tok]          = genRTSCCall bid (fsLit "resumeThread") [rs] [tok]-genSimplePrim _   MO_I64_ToI           [dst]   [src]          = genInt64ToInt dst src-genSimplePrim _   MO_I64_FromI         [dst]   [src]          = genIntToInt64 dst src-genSimplePrim _   MO_W64_ToW           [dst]   [src]          = genWord64ToWord dst src-genSimplePrim _   MO_W64_FromW         [dst]   [src]          = genWordToWord64 dst src-genSimplePrim _   MO_x64_Neg           [dst]   [src]          = genNeg64 dst src-genSimplePrim _   MO_x64_Add           [dst]   [x,y]          = genAdd64 dst x y-genSimplePrim _   MO_x64_Sub           [dst]   [x,y]          = genSub64 dst x y-genSimplePrim bid MO_x64_Mul           [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_mul64") [dst] [x,y]-genSimplePrim bid MO_I64_Quot          [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_quotInt64") [dst] [x,y]-genSimplePrim bid MO_I64_Rem           [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_remInt64") [dst] [x,y]-genSimplePrim bid MO_W64_Quot          [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_quotWord64") [dst] [x,y]-genSimplePrim bid MO_W64_Rem           [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_remWord64") [dst] [x,y]-genSimplePrim _   MO_x64_And           [dst]   [x,y]          = genAnd64 dst x y-genSimplePrim _   MO_x64_Or            [dst]   [x,y]          = genOr64  dst x y-genSimplePrim _   MO_x64_Xor           [dst]   [x,y]          = genXor64 dst x y-genSimplePrim _   MO_x64_Not           [dst]   [src]          = genNot64 dst src-genSimplePrim bid MO_x64_Shl           [dst]   [x,n]          = genPrimCCall bid (fsLit "hs_uncheckedShiftL64") [dst] [x,n]-genSimplePrim bid MO_I64_Shr           [dst]   [x,n]          = genPrimCCall bid (fsLit "hs_uncheckedIShiftRA64") [dst] [x,n]-genSimplePrim bid MO_W64_Shr           [dst]   [x,n]          = genPrimCCall bid (fsLit "hs_uncheckedShiftRL64") [dst] [x,n]-genSimplePrim _   MO_x64_Eq            [dst]   [x,y]          = genEq64 dst x y-genSimplePrim _   MO_x64_Ne            [dst]   [x,y]          = genNe64 dst x y-genSimplePrim _   MO_I64_Ge            [dst]   [x,y]          = genGeInt64 dst x y-genSimplePrim _   MO_I64_Gt            [dst]   [x,y]          = genGtInt64 dst x y-genSimplePrim _   MO_I64_Le            [dst]   [x,y]          = genLeInt64 dst x y-genSimplePrim _   MO_I64_Lt            [dst]   [x,y]          = genLtInt64 dst x y-genSimplePrim _   MO_W64_Ge            [dst]   [x,y]          = genGeWord64 dst x y-genSimplePrim _   MO_W64_Gt            [dst]   [x,y]          = genGtWord64 dst x y-genSimplePrim _   MO_W64_Le            [dst]   [x,y]          = genLeWord64 dst x y-genSimplePrim _   MO_W64_Lt            [dst]   [x,y]          = genLtWord64 dst x y-genSimplePrim _   op                   dst     args           = do-  platform <- ncgPlatform <$> getConfig-  pprPanic "genSimplePrim: unhandled primop" (ppr (pprCallishMachOp op, dst, fmap (pdoc platform) args))--{--Note [Evaluate C-call arguments before placing in destination registers]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--When producing code for C calls we must take care when placing arguments-in their final registers. Specifically, we must ensure that temporary register-usage due to evaluation of one argument does not clobber a register in which we-already placed a previous argument (e.g. as the code generation logic for-MO_Shl can clobber %rcx due to x86 instruction limitations).--This is precisely what happened in #18527. Consider this C--:--    (result::I64) = call "ccall" doSomething(_s2hp::I64, 2244, _s2hq::I64, _s2hw::I64 | (1 << _s2hz::I64));--Here we are calling the C function `doSomething` with three arguments, the last-involving a non-trivial expression involving MO_Shl. In this case the NCG could-naively generate the following assembly (where $tmp denotes some temporary-register and $argN denotes the register for argument N, as dictated by the-platform's calling convention):--    mov _s2hp, $arg1   # place first argument-    mov _s2hq, $arg2   # place second argument--    # Compute 1 << _s2hz-    mov _s2hz, %rcx-    shl %cl, $tmp--    # Compute (_s2hw | (1 << _s2hz))-    mov _s2hw, $arg3-    or $tmp, $arg3--    # Perform the call-    call func--This code is outright broken on Windows which assigns $arg1 to %rcx. This means-that the evaluation of the last argument clobbers the first argument.--To avoid this we use a rather awful hack: when producing code for a C call with-at least one non-trivial argument, we first evaluate all of the arguments into-local registers before moving them into their final calling-convention-defined-homes.  This is performed by 'evalArgs'. Here we define "non-trivial" to be an-expression which might contain a MachOp since these are the only cases which-might clobber registers. Furthermore, we use a conservative approximation of-this condition (only looking at the top-level of CmmExprs) to avoid spending-too much effort trying to decide whether we want to take the fast path.--Note that this hack *also* applies to calls to out-of-line PrimTargets (which-are lowered via a C call), which will ultimately end up in-genForeignCall{32,64}.--}---- | See Note [Evaluate C-call arguments before placing in destination registers]-evalArgs :: BlockId -> [CmmActual] -> NatM (InstrBlock, [CmmActual])-evalArgs bid actuals-  | any mightContainMachOp actuals = do-      regs_blks <- mapM evalArg actuals-      return (concatOL $ map fst regs_blks, map snd regs_blks)-  | otherwise = return (nilOL, actuals)-  where-    mightContainMachOp (CmmReg _)      = False-    mightContainMachOp (CmmRegOff _ _) = False-    mightContainMachOp (CmmLit _)      = False-    mightContainMachOp _               = True--    evalArg :: CmmActual -> NatM (InstrBlock, CmmExpr)-    evalArg actual = do-        platform <- getPlatform-        lreg <- newLocalReg $ cmmExprType platform actual-        (instrs, bid1) <- stmtToInstrs bid $ CmmAssign (CmmLocal lreg) actual-        -- The above assignment shouldn't change the current block-        massert (isNothing bid1)-        return (instrs, CmmReg $ CmmLocal lreg)--    newLocalReg :: CmmType -> NatM LocalReg-    newLocalReg ty = LocalReg <$> getUniqueM <*> pure ty---- Note [DIV/IDIV for bytes]--- ~~~~~~~~~~~~~~~~~~~~~~~~~--- IDIV reminder:---   Size    Dividend   Divisor   Quotient    Remainder---   byte    %ax         r/m8      %al          %ah---   word    %dx:%ax     r/m16     %ax          %dx---   dword   %edx:%eax   r/m32     %eax         %edx---   qword   %rdx:%rax   r/m64     %rax         %rdx------ We do a special case for the byte division because the current--- codegen doesn't deal well with accessing %ah register (also,--- accessing %ah in 64-bit mode is complicated because it cannot be an--- operand of many instructions). So we just widen operands to 16 bits--- and get the results from %al, %dl. This is not optimal, but a few--- register moves are probably not a huge deal when doing division.----- | Generate C call to the given function in ghc-prim-genPrimCCall-  :: BlockId-  -> FastString-  -> [CmmFormal]-  -> [CmmActual]-  -> NatM InstrBlock-genPrimCCall bid lbl_txt dsts args = do-  config <- getConfig-  -- FIXME: we should use mkForeignLabel instead of mkCmmCodeLabel-  let lbl = mkCmmCodeLabel primUnitId lbl_txt-  addr <- cmmMakeDynamicReference config CallReference lbl-  let conv = ForeignConvention CCallConv [] [] CmmMayReturn-  genCCall bid addr conv dsts args---- | Generate C call to the given function in libc-genLibCCall-  :: BlockId-  -> FastString-  -> [CmmFormal]-  -> [CmmActual]-  -> NatM InstrBlock-genLibCCall bid lbl_txt dsts args = do-  config <- getConfig-  -- Assume we can call these functions directly, and that they're not in a dynamic library.-  -- TODO: Why is this ok? Under linux this code will be in libm.so-  --       Is it because they're really implemented as a primitive instruction by the assembler??  -- BL 2009/12/31-  let lbl = mkForeignLabel lbl_txt Nothing ForeignLabelInThisPackage IsFunction-  addr <- cmmMakeDynamicReference config CallReference lbl-  let conv = ForeignConvention CCallConv [] [] CmmMayReturn-  genCCall bid addr conv dsts args---- | Generate C call to the given function in the RTS-genRTSCCall-  :: BlockId-  -> FastString-  -> [CmmFormal]-  -> [CmmActual]-  -> NatM InstrBlock-genRTSCCall bid lbl_txt dsts args = do-  config <- getConfig-  -- Assume we can call these functions directly, and that they're not in a dynamic library.-  let lbl = mkForeignLabel lbl_txt Nothing ForeignLabelInThisPackage IsFunction-  addr <- cmmMakeDynamicReference config CallReference lbl-  let conv = ForeignConvention CCallConv [] [] CmmMayReturn-  genCCall bid addr conv dsts args---- | Generate a real C call to the given address with the given convention-genCCall-  :: BlockId-  -> CmmExpr-  -> ForeignConvention-  -> [CmmFormal]-  -> [CmmActual]-  -> NatM InstrBlock-genCCall bid addr conv dest_regs args = do-  is32Bit <- is32BitPlatform-  (instrs0, args') <- evalArgs bid args-  instrs1 <- if is32Bit-    then genCCall32 addr conv dest_regs args'-    else genCCall64 addr conv dest_regs args'-  return (instrs0 `appOL` instrs1)--genCCall32 :: CmmExpr           -- ^ address of the function to call-           -> ForeignConvention -- ^ calling convention-           -> [CmmFormal]       -- ^ where to put the result-           -> [CmmActual]       -- ^ arguments (of mixed type)-           -> NatM InstrBlock-genCCall32 addr conv dest_regs args = do-        config <- getConfig-        let platform = ncgPlatform config-            prom_args = map (maybePromoteCArg platform W32) args--            -- If the size is smaller than the word, we widen things (see maybePromoteCArg)-            arg_size_bytes :: CmmType -> Int-            arg_size_bytes ty = max (widthInBytes (typeWidth ty)) (widthInBytes (wordWidth platform))--            roundTo a x | x `mod` a == 0 = x-                        | otherwise = x + a - (x `mod` a)--            push_arg :: CmmActual {-current argument-}-                            -> NatM InstrBlock  -- code--            push_arg  arg -- we don't need the hints on x86-              | isWord64 arg_ty = do-                RegCode64 code r_hi r_lo <- iselExpr64 arg-                delta <- getDeltaNat-                setDeltaNat (delta - 8)-                return (       code `appOL`-                               toOL [PUSH II32 (OpReg r_hi), DELTA (delta - 4),-                                     PUSH II32 (OpReg r_lo), DELTA (delta - 8),-                                     DELTA (delta-8)]-                    )--              | isFloatType arg_ty = do-                (reg, code) <- getSomeReg arg-                delta <- getDeltaNat-                setDeltaNat (delta-size)-                return (code `appOL`-                                toOL [SUB II32 (OpImm (ImmInt size)) (OpReg esp),-                                      DELTA (delta-size),-                                      let addr = AddrBaseIndex (EABaseReg esp)-                                                                EAIndexNone-                                                                (ImmInt 0)-                                          format = floatFormat (typeWidth arg_ty)-                                      in--                                      -- assume SSE2-                                       MOV format (OpReg reg) (OpAddr addr)--                                     ]-                               )--              | otherwise = do-                -- Arguments can be smaller than 32-bit, but we still use @PUSH-                -- II32@ - the usual calling conventions expect integers to be-                -- 4-byte aligned.-                massert ((typeWidth arg_ty) <= W32)-                (operand, code) <- getOperand arg-                delta <- getDeltaNat-                setDeltaNat (delta-size)-                return (code `snocOL`-                        PUSH II32 operand `snocOL`-                        DELTA (delta-size))--              where-                 arg_ty = cmmExprType platform arg-                 size = arg_size_bytes arg_ty -- Byte size--        let-            -- Align stack to 16n for calls, assuming a starting stack-            -- alignment of 16n - word_size on procedure entry. Which we-            -- maintiain. See Note [Stack Alignment on X86] in rts/StgCRun.c.-            sizes               = map (arg_size_bytes . cmmExprType platform) (reverse args)-            raw_arg_size        = sum sizes + platformWordSizeInBytes platform-            arg_pad_size        = (roundTo 16 $ raw_arg_size) - raw_arg_size-            tot_arg_size        = raw_arg_size + arg_pad_size - platformWordSizeInBytes platform---        delta0 <- getDeltaNat-        setDeltaNat (delta0 - arg_pad_size)--        push_codes <- mapM push_arg (reverse prom_args)-        delta <- getDeltaNat-        massert (delta == delta0 - tot_arg_size)--        -- deal with static vs dynamic call targets-        (callinsns,cconv) <--          case addr of-            CmmLit (CmmLabel lbl)-               -> -- ToDo: stdcall arg sizes-                  return (unitOL (CALL (Left fn_imm) []), conv)-               where fn_imm = ImmCLbl lbl-            _-               -> do { (dyn_r, dyn_c) <- getSomeReg addr-                     ; massert (isWord32 (cmmExprType platform addr))-                     ; return (dyn_c `snocOL` CALL (Right dyn_r) [], conv) }-        let push_code-                | arg_pad_size /= 0-                = toOL [SUB II32 (OpImm (ImmInt arg_pad_size)) (OpReg esp),-                        DELTA (delta0 - arg_pad_size)]-                  `appOL` concatOL push_codes-                | otherwise-                = concatOL push_codes--              -- Deallocate parameters after call for ccall;-              -- but not for stdcall (callee does it)-              ---              -- We have to pop any stack padding we added-              -- even if we are doing stdcall, though (#5052)-            pop_size-               | ForeignConvention StdCallConv _ _ _ <- cconv = arg_pad_size-               | otherwise = tot_arg_size--            call = callinsns `appOL`-                   toOL (-                      (if pop_size==0 then [] else-                       [ADD II32 (OpImm (ImmInt pop_size)) (OpReg esp)])-                      ++-                      [DELTA delta0]-                   )-        setDeltaNat delta0--        let-            -- assign the results, if necessary-            assign_code []     = nilOL-            assign_code [dest]-              | isFloatType ty =-                  -- we assume SSE2-                  let tmp_amode = AddrBaseIndex (EABaseReg esp)-                                                       EAIndexNone-                                                       (ImmInt 0)-                      fmt = floatFormat w-                         in toOL [ SUB II32 (OpImm (ImmInt b)) (OpReg esp),-                                   DELTA (delta0 - b),-                                   X87Store fmt  tmp_amode,-                                   -- X87Store only supported for the CDECL ABI-                                   -- NB: This code will need to be-                                   -- revisited once GHC does more work around-                                   -- SIGFPE f-                                   MOV fmt (OpAddr tmp_amode) (OpReg r_dest),-                                   ADD II32 (OpImm (ImmInt b)) (OpReg esp),-                                   DELTA delta0]-              | isWord64 ty    = toOL [MOV II32 (OpReg eax) (OpReg r_dest),-                                        MOV II32 (OpReg edx) (OpReg r_dest_hi)]-              | otherwise      = unitOL (MOV (intFormat w)-                                             (OpReg eax)-                                             (OpReg r_dest))-              where-                    ty = localRegType dest-                    w  = typeWidth ty-                    b  = widthInBytes w-                    r_dest_hi = getHiVRegFromLo r_dest-                    r_dest    = getLocalRegReg dest-            assign_code many = pprPanic "genForeignCall.assign_code - too many return values:" (ppr many)--        return (push_code `appOL`-                call `appOL`-                assign_code dest_regs)--genCCall64 :: CmmExpr           -- ^ address of function to call-           -> ForeignConvention -- ^ calling convention-           -> [CmmFormal]       -- ^ where to put the result-           -> [CmmActual]       -- ^ arguments (of mixed type)-           -> NatM InstrBlock-genCCall64 addr conv dest_regs args = do-    platform <- getPlatform-    -- load up the register arguments-    let prom_args = map (maybePromoteCArg platform W32) args--    let load_args :: [CmmExpr]-                  -> [Reg]         -- int regs avail for args-                  -> [Reg]         -- FP regs avail for args-                  -> InstrBlock    -- code computing args-                  -> InstrBlock    -- code assigning args to ABI regs-                  -> NatM ([CmmExpr],[Reg],[Reg],InstrBlock,InstrBlock)-        -- no more regs to use-        load_args args [] [] code acode     =-            return (args, [], [], code, acode)--        -- no more args to push-        load_args [] aregs fregs code acode =-            return ([], aregs, fregs, code, acode)--        load_args (arg : rest) aregs fregs code acode-            | isFloatType arg_rep = case fregs of-                 []     -> push_this_arg-                 (r:rs) -> do-                    (code',acode') <- reg_this_arg r-                    load_args rest aregs rs code' acode'-            | otherwise           = case aregs of-                 []     -> push_this_arg-                 (r:rs) -> do-                    (code',acode') <- reg_this_arg r-                    load_args rest rs fregs code' acode'-            where--              -- put arg into the list of stack pushed args-              push_this_arg = do-                 (args',ars,frs,code',acode')-                     <- load_args rest aregs fregs code acode-                 return (arg:args', ars, frs, code', acode')--              -- pass the arg into the given register-              reg_this_arg r-                -- "operand" args can be directly assigned into r-                | isOperand platform arg = do-                    arg_code <- getAnyReg arg-                    return (code, (acode `appOL` arg_code r))-                -- The last non-operand arg can be directly assigned after its-                -- computation without going into a temporary register-                | all (isOperand platform) rest = do-                    arg_code   <- getAnyReg arg-                    return (code `appOL` arg_code r,acode)--                -- other args need to be computed beforehand to avoid clobbering-                -- previously assigned registers used to pass parameters (see-                -- #11792, #12614). They are assigned into temporary registers-                -- and get assigned to proper call ABI registers after they all-                -- have been computed.-                | otherwise     = do-                    arg_code <- getAnyReg arg-                    tmp      <- getNewRegNat arg_fmt-                    let-                      code'  = code `appOL` arg_code tmp-                      acode' = acode `snocOL` reg2reg arg_fmt tmp r-                    return (code',acode')--              arg_rep = cmmExprType platform arg-              arg_fmt = cmmTypeFormat arg_rep--        load_args_win :: [CmmExpr]-                      -> [Reg]        -- used int regs-                      -> [Reg]        -- used FP regs-                      -> [(Reg, Reg)] -- (int, FP) regs avail for args-                      -> InstrBlock-                      -> NatM ([CmmExpr],[Reg],[Reg],InstrBlock,InstrBlock)-        load_args_win args usedInt usedFP [] code-            = return (args, usedInt, usedFP, code, nilOL)-            -- no more regs to use-        load_args_win [] usedInt usedFP _ code-            = return ([], usedInt, usedFP, code, nilOL)-            -- no more args to push-        load_args_win (arg : rest) usedInt usedFP-                      ((ireg, freg) : regs) code-            | isFloatType arg_rep = do-                 arg_code <- getAnyReg arg-                 load_args_win rest (ireg : usedInt) (freg : usedFP) regs-                               (code `appOL`-                                arg_code freg `snocOL`-                                -- If we are calling a varargs function-                                -- then we need to define ireg as well-                                -- as freg-                                MOV II64 (OpReg freg) (OpReg ireg))-            | otherwise = do-                 arg_code <- getAnyReg arg-                 load_args_win rest (ireg : usedInt) usedFP regs-                               (code `appOL` arg_code ireg)-            where-              arg_rep = cmmExprType platform arg--        arg_size = 8 -- always, at the mo--        push_args [] code = return code-        push_args (arg:rest) code-           | isFloatType arg_rep = do-             (arg_reg, arg_code) <- getSomeReg arg-             delta <- getDeltaNat-             setDeltaNat (delta-arg_size)-             let code' = code `appOL` arg_code `appOL` toOL [-                            SUB (intFormat (wordWidth platform)) (OpImm (ImmInt arg_size)) (OpReg rsp),-                            DELTA (delta-arg_size),-                            MOV (floatFormat width) (OpReg arg_reg) (OpAddr (spRel platform 0))]-             push_args rest code'--           | otherwise = do-             -- Arguments can be smaller than 64-bit, but we still use @PUSH-             -- II64@ - the usual calling conventions expect integers to be-             -- 8-byte aligned.-             massert (width <= W64)-             (arg_op, arg_code) <- getOperand arg-             delta <- getDeltaNat-             setDeltaNat (delta-arg_size)-             let code' = code `appOL` arg_code `appOL` toOL [-                                    PUSH II64 arg_op,-                                    DELTA (delta-arg_size)]-             push_args rest code'-            where-              arg_rep = cmmExprType platform arg-              width = typeWidth arg_rep--        leaveStackSpace n = do-             delta <- getDeltaNat-             setDeltaNat (delta - n * arg_size)-             return $ toOL [-                         SUB II64 (OpImm (ImmInt (n * platformWordSizeInBytes platform))) (OpReg rsp),-                         DELTA (delta - n * arg_size)]--    (stack_args, int_regs_used, fp_regs_used, load_args_code, assign_args_code)-         <--        if platformOS platform == OSMinGW32-        then load_args_win prom_args [] [] (allArgRegs platform) nilOL-        else do-           (stack_args, aregs, fregs, load_args_code, assign_args_code)-               <- load_args prom_args (allIntArgRegs platform)-                                      (allFPArgRegs platform)-                                      nilOL nilOL-           let used_regs rs as = reverse (drop (length rs) (reverse as))-               fregs_used      = used_regs fregs (allFPArgRegs platform)-               aregs_used      = used_regs aregs (allIntArgRegs platform)-           return (stack_args, aregs_used, fregs_used, load_args_code-                                                      , assign_args_code)--    let-        arg_regs_used = int_regs_used ++ fp_regs_used-        arg_regs = [eax] ++ arg_regs_used-                -- for annotating the call instruction with-        sse_regs = length fp_regs_used-        arg_stack_slots = if platformOS platform == OSMinGW32-                          then length stack_args + length (allArgRegs platform)-                          else length stack_args-        tot_arg_size = arg_size * arg_stack_slots---    -- Align stack to 16n for calls, assuming a starting stack-    -- alignment of 16n - word_size on procedure entry. Which we-    -- maintain. See Note [Stack Alignment on X86] in rts/StgCRun.c-    let word_size = platformWordSizeInBytes platform-    (real_size, adjust_rsp) <--        if (tot_arg_size + word_size) `rem` 16 == 0-            then return (tot_arg_size, nilOL)-            else do -- we need to adjust...-                delta <- getDeltaNat-                setDeltaNat (delta - word_size)-                return (tot_arg_size + word_size, toOL [-                                SUB II64 (OpImm (ImmInt word_size)) (OpReg rsp),-                                DELTA (delta - word_size) ])--    -- push the stack args, right to left-    push_code <- push_args (reverse stack_args) nilOL-    -- On Win64, we also have to leave stack space for the arguments-    -- that we are passing in registers-    lss_code <- if platformOS platform == OSMinGW32-                then leaveStackSpace (length (allArgRegs platform))-                else return nilOL-    delta <- getDeltaNat--    -- deal with static vs dynamic call targets-    (callinsns,_cconv) <- case addr of-      CmmLit (CmmLabel lbl) ->-        -- ToDo: stdcall arg sizes-        return (unitOL (CALL (Left (ImmCLbl lbl)) arg_regs), conv)-      _ -> do-        (dyn_r, dyn_c) <- getSomeReg addr-        return (dyn_c `snocOL` CALL (Right dyn_r) arg_regs, conv)--    let-        -- The x86_64 ABI requires us to set %al to the number of SSE2-        -- registers that contain arguments, if the called routine-        -- is a varargs function.  We don't know whether it's a-        -- varargs function or not, so we have to assume it is.-        ---        -- It's not safe to omit this assignment, even if the number-        -- of SSE2 regs in use is zero.  If %al is larger than 8-        -- on entry to a varargs function, seg faults ensue.-        assign_eax n = unitOL (MOV II32 (OpImm (ImmInt n)) (OpReg eax))--    let call = callinsns `appOL`-               toOL (-                    -- Deallocate parameters after call for ccall;-                    -- stdcall has callee do it, but is not supported on-                    -- x86_64 target (see #3336)-                  (if real_size==0 then [] else-                   [ADD (intFormat (platformWordWidth platform)) (OpImm (ImmInt real_size)) (OpReg esp)])-                  ++-                  [DELTA (delta + real_size)]-               )-    setDeltaNat (delta + real_size)--    let-        -- assign the results, if necessary-        assign_code []     = nilOL-        assign_code [dest] =-          case typeWidth rep of-                W32 | isFloatType rep -> unitOL (MOV (floatFormat W32)-                                                     (OpReg xmm0)-                                                     (OpReg r_dest))-                W64 | isFloatType rep -> unitOL (MOV (floatFormat W64)-                                                     (OpReg xmm0)-                                                     (OpReg r_dest))-                _ -> unitOL (MOV (cmmTypeFormat rep) (OpReg rax) (OpReg r_dest))-          where-                rep = localRegType dest-                r_dest = getRegisterReg platform  (CmmLocal dest)-        assign_code _many = panic "genForeignCall.assign_code many"--    return (adjust_rsp          `appOL`-            push_code           `appOL`-            load_args_code      `appOL`-            assign_args_code    `appOL`-            lss_code            `appOL`-            assign_eax sse_regs `appOL`-            call                `appOL`-            assign_code dest_regs)---maybePromoteCArg :: Platform -> Width -> CmmExpr -> CmmExpr-maybePromoteCArg platform wto arg- | wfrom < wto = CmmMachOp (MO_UU_Conv wfrom wto) [arg]- | otherwise   = arg- where-   wfrom = cmmExprWidth platform arg---- -------------------------------------------------------------------------------- Generating a table-branch--{--Note [Sub-word subtlety during jump-table indexing]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Offset the index by the start index of the jump table.-It's important that we do this *before* the widening below. To see-why, consider a switch with a sub-word, signed discriminant such as:--    switch [-5...+2] x::I16 {-        case -5: ...-        ...-        case +2: ...-    }--Consider what happens if we offset *after* widening in the case that-x=-4:--                                         // x == -4 == 0xfffc::I16-    indexWidened = UU_Conv(x);           // == 0xfffc::I64-    indexExpr    = indexWidened - (-5);  // == 0x10000::I64--This index is clearly nonsense given that the jump table only has-eight entries.--By contrast, if we widen *after* we offset then we get the correct-index (1),--                                         // x == -4 == 0xfffc::I16-    indexOffset  = x - (-5);             // == 1::I16-    indexExpr    = UU_Conv(indexOffset); // == 1::I64--See #21186.--}--genSwitch :: CmmExpr -> SwitchTargets -> NatM InstrBlock--genSwitch expr targets = do-  config <- getConfig-  let platform = ncgPlatform config-      expr_w = cmmExprWidth platform expr-      indexExpr0 = cmmOffset platform expr offset-      -- We widen to a native-width register because we cannot use arbitrary sizes-      -- in x86 addressing modes.-      -- See Note [Sub-word subtlety during jump-table indexing].-      indexExpr = CmmMachOp-        (MO_UU_Conv expr_w (platformWordWidth platform))-        [indexExpr0]-  if ncgPIC config-  then do-        (reg,e_code) <- getNonClobberedReg indexExpr-           -- getNonClobberedReg because it needs to survive across t_code-        lbl <- getNewLabelNat-        let is32bit = target32Bit platform-            os = platformOS platform-            -- Might want to use .rodata.<function we're in> instead, but as-            -- long as it's something unique it'll work out since the-            -- references to the jump table are in the appropriate section.-            rosection = case os of-              -- on Mac OS X/x86_64, put the jump table in the text section to-              -- work around a limitation of the linker.-              -- ld64 is unable to handle the relocations for-              --     .quad L1 - L0-              -- if L0 is not preceded by a non-anonymous label in its section.-              OSDarwin | not is32bit -> Section Text lbl-              _ -> Section ReadOnlyData lbl-        dynRef <- cmmMakeDynamicReference config DataReference lbl-        (tableReg,t_code) <- getSomeReg $ dynRef-        let op = OpAddr (AddrBaseIndex (EABaseReg tableReg)-                                       (EAIndex reg (platformWordSizeInBytes platform)) (ImmInt 0))--        offsetReg <- getNewRegNat (intFormat (platformWordWidth platform))-        return $ if is32bit || os == OSDarwin-                 then e_code `appOL` t_code `appOL` toOL [-                                ADD (intFormat (platformWordWidth platform)) op (OpReg tableReg),-                                JMP_TBL (OpReg tableReg) ids rosection lbl-                       ]-                 else -- HACK: On x86_64 binutils<2.17 is only able to generate-                      -- PC32 relocations, hence we only get 32-bit offsets in-                      -- the jump table. As these offsets are always negative-                      -- we need to properly sign extend them to 64-bit. This-                      -- hack should be removed in conjunction with the hack in-                      -- PprMach.hs/pprDataItem once binutils 2.17 is standard.-                      e_code `appOL` t_code `appOL` toOL [-                               MOVSxL II32 op (OpReg offsetReg),-                               ADD (intFormat (platformWordWidth platform))-                                   (OpReg offsetReg)-                                   (OpReg tableReg),-                               JMP_TBL (OpReg tableReg) ids rosection lbl-                       ]-  else do-        (reg,e_code) <- getSomeReg indexExpr-        lbl <- getNewLabelNat-        let is32bit = target32Bit platform-        if is32bit-          then let op = OpAddr (AddrBaseIndex EABaseNone (EAIndex reg (platformWordSizeInBytes platform)) (ImmCLbl lbl))-                   jmp_code = JMP_TBL op ids (Section ReadOnlyData lbl) lbl-               in return $ e_code `appOL` unitOL jmp_code-          else do-            -- See Note [%rip-relative addressing on x86-64].-            tableReg <- getNewRegNat (intFormat (platformWordWidth platform))-            targetReg <- getNewRegNat (intFormat (platformWordWidth platform))-            let op = OpAddr (AddrBaseIndex (EABaseReg tableReg) (EAIndex reg (platformWordSizeInBytes platform)) (ImmInt 0))-                code = e_code `appOL` toOL-                    [ LEA (archWordFormat is32bit) (OpAddr (AddrBaseIndex EABaseRip EAIndexNone (ImmCLbl lbl))) (OpReg tableReg)-                    , MOV (archWordFormat is32bit) op (OpReg targetReg)-                    , JMP_TBL (OpReg targetReg) ids (Section ReadOnlyData lbl) lbl-                    ]-            return code-  where-    (offset, blockIds) = switchTargetsToTable targets-    ids = map (fmap DestBlockId) blockIds--generateJumpTableForInstr :: NCGConfig -> Instr -> Maybe (NatCmmDecl (Alignment, RawCmmStatics) Instr)-generateJumpTableForInstr config (JMP_TBL _ ids section lbl)-    = let getBlockId (DestBlockId id) = id-          getBlockId _ = panic "Non-Label target in Jump Table"-          blockIds = map (fmap getBlockId) ids-      in Just (createJumpTable config blockIds section lbl)-generateJumpTableForInstr _ _ = Nothing--createJumpTable :: NCGConfig -> [Maybe BlockId] -> Section -> CLabel-                -> GenCmmDecl (Alignment, RawCmmStatics) h g-createJumpTable config ids section lbl-    = let jumpTable-            | ncgPIC config =-                  let ww = ncgWordWidth config-                      jumpTableEntryRel Nothing-                          = CmmStaticLit (CmmInt 0 ww)-                      jumpTableEntryRel (Just blockid)-                          = CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0 ww)-                          where blockLabel = blockLbl blockid-                  in map jumpTableEntryRel ids-            | otherwise = map (jumpTableEntry config) ids-      in CmmData section (mkAlignment 1, CmmStaticsRaw lbl jumpTable)--extractUnwindPoints :: [Instr] -> [UnwindPoint]-extractUnwindPoints instrs =-    [ UnwindPoint lbl unwinds | UNWIND lbl unwinds <- instrs]---- -------------------------------------------------------------------------------- 'condIntReg' and 'condFltReg': condition codes into registers---- Turn those condition codes into integers now (when they appear on--- the right hand side of an assignment).------ (If applicable) Do not fill the delay slots here; you will confuse the--- register allocator.--condIntReg :: Cond -> CmmExpr -> CmmExpr -> NatM Register--condIntReg cond x y = do-  CondCode _ cond cond_code <- condIntCode cond x y-  tmp <- getNewRegNat II8-  let-        code dst = cond_code `appOL` toOL [-                    SETCC cond (OpReg tmp),-                    MOVZxL II8 (OpReg tmp) (OpReg dst)-                  ]-  return (Any II32 code)----- Note [SSE Parity Checks]--- ~~~~~~~~~~~~~~~~~~~~~~~~--- We have to worry about unordered operands (eg. comparisons--- against NaN).  If the operands are unordered, the comparison--- sets the parity flag, carry flag and zero flag.--- All comparisons are supposed to return false for unordered--- operands except for !=, which returns true.------ Optimisation: we don't have to test the parity flag if we--- know the test has already excluded the unordered case: eg >--- and >= test for a zero carry flag, which can only occur for--- ordered operands.------ By reversing comparisons we can avoid testing the parity--- for < and <= as well. If any of the arguments is an NaN we--- return false either way. If both arguments are valid then--- x <= y  <->  y >= x  holds. So it's safe to swap these.------ We invert the condition inside getRegister'and  getCondCode--- which should cover all invertable cases.--- All other functions translating FP comparisons to assembly--- use these to two generate the comparison code.------ As an example consider a simple check:------ func :: Float -> Float -> Int--- func x y = if x < y then 1 else 0------ Which in Cmm gives the floating point comparison.------  if (%MO_F_Lt_W32(F1, F2)) goto c2gg; else goto c2gf;------ We used to compile this to an assembly code block like this:--- _c2gh:---  ucomiss %xmm2,%xmm1---  jp _c2gf---  jb _c2gg---  jmp _c2gf------ Where we have to introduce an explicit--- check for unordered results (using jmp parity):------ We can avoid this by exchanging the arguments and inverting the direction--- of the comparison. This results in the sequence of:------  ucomiss %xmm1,%xmm2---  ja _c2g2---  jmp _c2g1------ Removing the jump reduces the pressure on the branch predidiction system--- and plays better with the uOP cache.--condFltReg :: Bool -> Cond -> CmmExpr -> CmmExpr -> NatM Register-condFltReg is32Bit cond x y = condFltReg_sse2- where---  condFltReg_sse2 = do-    CondCode _ cond cond_code <- condFltCode cond x y-    tmp1 <- getNewRegNat (archWordFormat is32Bit)-    tmp2 <- getNewRegNat (archWordFormat is32Bit)-    let -- See Note [SSE Parity Checks]-        code dst =-           cond_code `appOL`-             (case cond of-                NE  -> or_unordered dst-                GU  -> plain_test   dst-                GEU -> plain_test   dst-                -- Use ASSERT so we don't break releases if these creep in.-                LTT -> assertPpr False (ppr "Should have been turned into >") $-                       and_ordered  dst-                LE  -> assertPpr False (ppr "Should have been turned into >=") $-                       and_ordered  dst-                _   -> and_ordered  dst)--        plain_test dst = toOL [-                    SETCC cond (OpReg tmp1),-                    MOVZxL II8 (OpReg tmp1) (OpReg dst)-                 ]-        or_unordered dst = toOL [-                    SETCC cond (OpReg tmp1),-                    SETCC PARITY (OpReg tmp2),-                    OR II8 (OpReg tmp1) (OpReg tmp2),-                    MOVZxL II8 (OpReg tmp2) (OpReg dst)-                  ]-        and_ordered dst = toOL [-                    SETCC cond (OpReg tmp1),-                    SETCC NOTPARITY (OpReg tmp2),-                    AND II8 (OpReg tmp1) (OpReg tmp2),-                    MOVZxL II8 (OpReg tmp2) (OpReg dst)-                  ]-    return (Any II32 code)----- -------------------------------------------------------------------------------- 'trivial*Code': deal with trivial instructions---- Trivial (dyadic: 'trivialCode', floating-point: 'trivialFCode',--- unary: 'trivialUCode', unary fl-pt:'trivialUFCode') instructions.--- Only look for constants on the right hand side, because that's--- where the generic optimizer will have put them.---- Similarly, for unary instructions, we don't have to worry about--- matching an StInt as the argument, because genericOpt will already--- have handled the constant-folding.---{--The Rules of the Game are:--* You cannot assume anything about the destination register dst;-  it may be anything, including a fixed reg.--* You may compute an operand into a fixed reg, but you may not-  subsequently change the contents of that fixed reg.  If you-  want to do so, first copy the value either to a temporary-  or into dst.  You are free to modify dst even if it happens-  to be a fixed reg -- that's not your problem.--* You cannot assume that a fixed reg will stay live over an-  arbitrary computation.  The same applies to the dst reg.--* Temporary regs obtained from getNewRegNat are distinct from-  each other and from all other regs, and stay live over-  arbitrary computations.------------------------SDM's version of The Rules:--* If getRegister returns Any, that means it can generate correct-  code which places the result in any register, period.  Even if that-  register happens to be read during the computation.--  Corollary #1: this means that if you are generating code for an-  operation with two arbitrary operands, you cannot assign the result-  of the first operand into the destination register before computing-  the second operand.  The second operand might require the old value-  of the destination register.--  Corollary #2: A function might be able to generate more efficient-  code if it knows the destination register is a new temporary (and-  therefore not read by any of the sub-computations).--* If getRegister returns Any, then the code it generates may modify only:-        (a) fresh temporaries-        (b) the destination register-        (c) known registers (eg. %ecx is used by shifts)-  In particular, it may *not* modify global registers, unless the global-  register happens to be the destination register.--}--trivialCode :: Width -> (Operand -> Operand -> Instr)-            -> Maybe (Operand -> Operand -> Instr)-            -> CmmExpr -> CmmExpr -> NatM Register-trivialCode width instr m a b-    = do platform <- getPlatform-         trivialCode' platform width instr m a b--trivialCode' :: Platform -> Width -> (Operand -> Operand -> Instr)-             -> Maybe (Operand -> Operand -> Instr)-             -> CmmExpr -> CmmExpr -> NatM Register-trivialCode' platform width _ (Just revinstr) (CmmLit lit_a) b-  | is32BitLit platform lit_a = do-  b_code <- getAnyReg b-  let-       code dst-         = b_code dst `snocOL`-           revinstr (OpImm (litToImm lit_a)) (OpReg dst)-  return (Any (intFormat width) code)--trivialCode' _ width instr _ a b-  = genTrivialCode (intFormat width) instr a b---- This is re-used for floating pt instructions too.-genTrivialCode :: Format -> (Operand -> Operand -> Instr)-               -> CmmExpr -> CmmExpr -> NatM Register-genTrivialCode rep instr a b = do-  (b_op, b_code) <- getNonClobberedOperand b-  a_code <- getAnyReg a-  tmp <- getNewRegNat rep-  let-     -- We want the value of b to stay alive across the computation of a.-     -- But, we want to calculate a straight into the destination register,-     -- because the instruction only has two operands (dst := dst `op` src).-     -- The troublesome case is when the result of b is in the same register-     -- as the destination reg.  In this case, we have to save b in a-     -- new temporary across the computation of a.-     code dst-        | dst `regClashesWithOp` b_op =-                b_code `appOL`-                unitOL (MOV rep b_op (OpReg tmp)) `appOL`-                a_code dst `snocOL`-                instr (OpReg tmp) (OpReg dst)-        | otherwise =-                b_code `appOL`-                a_code dst `snocOL`-                instr b_op (OpReg dst)-  return (Any rep code)--regClashesWithOp :: Reg -> Operand -> Bool-reg `regClashesWithOp` OpReg reg2   = reg == reg2-reg `regClashesWithOp` OpAddr amode = any (==reg) (addrModeRegs amode)-_   `regClashesWithOp` _            = False---------------trivialUCode :: Format -> (Operand -> Instr)-             -> CmmExpr -> NatM Register-trivialUCode rep instr x = do-  x_code <- getAnyReg x-  let-     code dst =-        x_code dst `snocOL`-        instr (OpReg dst)-  return (Any rep code)----------------trivialFCode_sse2 :: Width -> (Format -> Operand -> Operand -> Instr)-                  -> CmmExpr -> CmmExpr -> NatM Register-trivialFCode_sse2 pk instr x y-    = genTrivialCode format (instr format) x y-    where format = floatFormat pk------------------------------------------------------------------------------------coerceInt2FP :: Width -> Width -> CmmExpr -> NatM Register-coerceInt2FP from to x =  coerce_sse2- where--   coerce_sse2 = do-     (x_op, x_code) <- getOperand x  -- ToDo: could be a safe operand-     let-           opc  = case to of W32 -> CVTSI2SS; W64 -> CVTSI2SD-                             n -> panic $ "coerceInt2FP.sse: unhandled width ("-                                         ++ show n ++ ")"-           code dst = x_code `snocOL` opc (intFormat from) x_op dst-     return (Any (floatFormat to) code)-        -- works even if the destination rep is <II32-----------------------------------------------------------------------------------coerceFP2Int :: Width -> Width -> CmmExpr -> NatM Register-coerceFP2Int from to x =  coerceFP2Int_sse2- where-   coerceFP2Int_sse2 = do-     (x_op, x_code) <- getOperand x  -- ToDo: could be a safe operand-     let-           opc  = case from of W32 -> CVTTSS2SIQ; W64 -> CVTTSD2SIQ;-                               n -> panic $ "coerceFP2Init.sse: unhandled width ("-                                           ++ show n ++ ")"-           code dst = x_code `snocOL` opc (intFormat to) x_op dst-     return (Any (intFormat to) code)-         -- works even if the destination rep is <II32------------------------------------------------------------------------------------coerceFP2FP :: Width -> CmmExpr -> NatM Register-coerceFP2FP to x = do-  (x_reg, x_code) <- getSomeReg x-  let-        opc  = case to of W32 -> CVTSD2SS; W64 -> CVTSS2SD;-                                     n -> panic $ "coerceFP2FP: unhandled width ("-                                                 ++ show n ++ ")"-        code dst = x_code `snocOL` opc x_reg dst-  return (Any ( floatFormat to) code)------------------------------------------------------------------------------------sse2NegCode :: Width -> CmmExpr -> NatM Register-sse2NegCode w x = do-  let fmt = floatFormat w-  x_code <- getAnyReg x-  -- This is how gcc does it, so it can't be that bad:-  let-    const = case fmt of-      FF32 -> CmmInt 0x80000000 W32-      FF64 -> CmmInt 0x8000000000000000 W64-      x@II8  -> wrongFmt x-      x@II16 -> wrongFmt x-      x@II32 -> wrongFmt x-      x@II64 -> wrongFmt x--      where-        wrongFmt x = panic $ "sse2NegCode: " ++ show x-  Amode amode amode_code <- memConstant (mkAlignment $ widthInBytes w) const-  tmp <- getNewRegNat fmt-  let-    code dst = x_code dst `appOL` amode_code `appOL` toOL [-        MOV fmt (OpAddr amode) (OpReg tmp),-        XOR fmt (OpReg tmp) (OpReg dst)-        ]-  ---  return (Any fmt code)--isVecExpr :: CmmExpr -> Bool-isVecExpr (CmmMachOp (MO_V_Insert {}) _)   = True-isVecExpr (CmmMachOp (MO_V_Extract {}) _)  = True-isVecExpr (CmmMachOp (MO_V_Add {}) _)      = True-isVecExpr (CmmMachOp (MO_V_Sub {}) _)      = True-isVecExpr (CmmMachOp (MO_V_Mul {}) _)      = True-isVecExpr (CmmMachOp (MO_VS_Quot {}) _)    = True-isVecExpr (CmmMachOp (MO_VS_Rem {}) _)     = True-isVecExpr (CmmMachOp (MO_VS_Neg {}) _)     = True-isVecExpr (CmmMachOp (MO_VF_Insert {}) _)  = True-isVecExpr (CmmMachOp (MO_VF_Extract {}) _) = True-isVecExpr (CmmMachOp (MO_VF_Add {}) _)     = True-isVecExpr (CmmMachOp (MO_VF_Sub {}) _)     = True-isVecExpr (CmmMachOp (MO_VF_Mul {}) _)     = True-isVecExpr (CmmMachOp (MO_VF_Quot {}) _)    = True-isVecExpr (CmmMachOp (MO_VF_Neg {}) _)     = True-isVecExpr (CmmMachOp _ [e])                = isVecExpr e-isVecExpr _                                = False--needLlvm :: NatM a-needLlvm =-    sorry $ unlines ["The native code generator does not support vector"-                    ,"instructions. Please use -fllvm."]---- | This works on the invariant that all jumps in the given blocks are required.---   Starting from there we try to make a few more jumps redundant by reordering---   them.---   We depend on the information in the CFG to do so so without a given CFG---   we do nothing.-invertCondBranches :: Maybe CFG  -- ^ CFG if present-                   -> LabelMap a -- ^ Blocks with info tables-                   -> [NatBasicBlock Instr] -- ^ List of basic blocks-                   -> [NatBasicBlock Instr]-invertCondBranches Nothing _       bs = bs-invertCondBranches (Just cfg) keep bs =-    invert bs-  where-    invert :: [NatBasicBlock Instr] -> [NatBasicBlock Instr]-    invert ((BasicBlock lbl1 ins@(_:_:_xs)):b2@(BasicBlock lbl2 _):bs)-      | --pprTrace "Block" (ppr lbl1) True,-        (jmp1,jmp2) <- last2 ins-      , JXX cond1 target1 <- jmp1-      , target1 == lbl2-      --, pprTrace "CutChance" (ppr b1) True-      , JXX ALWAYS target2 <- jmp2-      -- We have enough information to check if we can perform the inversion-      -- TODO: We could also check for the last asm instruction which sets-      -- status flags instead. Which I suspect is worse in terms of compiler-      -- performance, but might be applicable to more cases-      , Just edgeInfo1 <- getEdgeInfo lbl1 target1 cfg-      , Just edgeInfo2 <- getEdgeInfo lbl1 target2 cfg-      -- Both jumps come from the same cmm statement-      , transitionSource edgeInfo1 == transitionSource edgeInfo2-      , CmmSource {trans_cmmNode = cmmCondBranch} <- transitionSource edgeInfo1--      --Int comparisons are invertable-      , CmmCondBranch (CmmMachOp op _args) _ _ _ <- cmmCondBranch-      , Just _ <- maybeIntComparison op-      , Just invCond <- maybeInvertCond cond1--      --Swap the last two jumps, invert the conditional jumps condition.-      = let jumps =-              case () of-                -- We are free the eliminate the jmp. So we do so.-                _ | not (mapMember target1 keep)-                    -> [JXX invCond target2]-                -- If the conditional target is unlikely we put the other-                -- target at the front.-                  | edgeWeight edgeInfo2 > edgeWeight edgeInfo1-                    -> [JXX invCond target2, JXX ALWAYS target1]-                -- Keep things as-is otherwise-                  | otherwise-                    -> [jmp1, jmp2]-        in --pprTrace "Cutable" (ppr [jmp1,jmp2] <+> text "=>" <+> ppr jumps) $-           (BasicBlock lbl1-            (dropTail 2 ins ++ jumps))-            : invert (b2:bs)-    invert (b:bs) = b : invert bs-    invert [] = []--genAtomicRMW-  :: BlockId-  -> Width-  -> AtomicMachOp-  -> LocalReg-  -> CmmExpr-  -> CmmExpr-  -> NatM (InstrBlock, Maybe BlockId)-genAtomicRMW bid width amop dst addr n = do-    Amode amode addr_code <--        if amop `elem` [AMO_Add, AMO_Sub]-        then getAmode addr-        else getSimpleAmode addr  -- See genForeignCall for MO_Cmpxchg-    arg <- getNewRegNat format-    arg_code <- getAnyReg n-    platform <- ncgPlatform <$> getConfig--    let dst_r    = getRegisterReg platform  (CmmLocal dst)-    (code, lbl) <- op_code dst_r arg amode-    return (addr_code `appOL` arg_code arg `appOL` code, Just lbl)-  where-    -- Code for the operation-    op_code :: Reg       -- Destination reg-            -> Reg       -- Register containing argument-            -> AddrMode  -- Address of location to mutate-            -> NatM (OrdList Instr,BlockId) -- TODO: Return Maybe BlockId-    op_code dst_r arg amode = case amop of-        -- In the common case where dst_r is a virtual register the-        -- final move should go away, because it's the last use of arg-        -- and the first use of dst_r.-        AMO_Add  -> return $ (toOL [ LOCK (XADD format (OpReg arg) (OpAddr amode))-                                   , MOV format (OpReg arg) (OpReg dst_r)-                                   ], bid)-        AMO_Sub  -> return $ (toOL [ NEGI format (OpReg arg)-                                   , LOCK (XADD format (OpReg arg) (OpAddr amode))-                                   , MOV format (OpReg arg) (OpReg dst_r)-                                   ], bid)-        -- In these cases we need a new block id, and have to return it so-        -- that later instruction selection can reference it.-        AMO_And  -> cmpxchg_code (\ src dst -> unitOL $ AND format src dst)-        AMO_Nand -> cmpxchg_code (\ src dst -> toOL [ AND format src dst-                                                    , NOT format dst-                                                    ])-        AMO_Or   -> cmpxchg_code (\ src dst -> unitOL $ OR format src dst)-        AMO_Xor  -> cmpxchg_code (\ src dst -> unitOL $ XOR format src dst)-      where-        -- Simulate operation that lacks a dedicated instruction using-        -- cmpxchg.-        cmpxchg_code :: (Operand -> Operand -> OrdList Instr)-                     -> NatM (OrdList Instr, BlockId)-        cmpxchg_code instrs = do-            lbl1 <- getBlockIdNat-            lbl2 <- getBlockIdNat-            tmp <- getNewRegNat format--            --Record inserted blocks-            --  We turn A -> B into A -> A' -> A'' -> B-            --  with a self loop on A'.-            addImmediateSuccessorNat bid lbl1-            addImmediateSuccessorNat lbl1 lbl2-            updateCfgNat (addWeightEdge lbl1 lbl1 0)--            return $ (toOL-                [ MOV format (OpAddr amode) (OpReg eax)-                , JXX ALWAYS lbl1-                , NEWBLOCK lbl1-                  -- Keep old value so we can return it:-                , MOV format (OpReg eax) (OpReg dst_r)-                , MOV format (OpReg eax) (OpReg tmp)-                ]-                `appOL` instrs (OpReg arg) (OpReg tmp) `appOL` toOL-                [ LOCK (CMPXCHG format (OpReg tmp) (OpAddr amode))-                , JXX NE lbl1-                -- See Note [Introducing cfg edges inside basic blocks]-                -- why this basic block is required.-                , JXX ALWAYS lbl2-                , NEWBLOCK lbl2-                ],-                lbl2)-    format = intFormat width---- | Count trailing zeroes-genCtz :: BlockId -> Width -> LocalReg -> CmmExpr -> NatM (InstrBlock, Maybe BlockId)-genCtz bid width dst src = do-  is32Bit <- is32BitPlatform-  if is32Bit && width == W64-    then genCtz64_32 bid dst src-    else (,Nothing) <$> genCtzGeneric width dst src---- | Count trailing zeroes------ 64-bit width on 32-bit architecture-genCtz64_32-  :: BlockId-  -> LocalReg-  -> CmmExpr-  -> NatM (InstrBlock, Maybe BlockId)-genCtz64_32 bid dst src = do-  RegCode64 vcode rhi rlo <- iselExpr64 src-  let dst_r = getLocalRegReg dst-  lbl1 <- getBlockIdNat-  lbl2 <- getBlockIdNat-  tmp_r <- getNewRegNat II64--  -- New CFG Edges:-  --  bid -> lbl2-  --  bid -> lbl1 -> lbl2-  --  We also changes edges originating at bid to start at lbl2 instead.-  weights <- getCfgWeights-  updateCfgNat (addWeightEdge bid lbl1 110 .-                addWeightEdge lbl1 lbl2 110 .-                addImmediateSuccessor weights bid lbl2)--  -- The following instruction sequence corresponds to the pseudo-code-  ---  --  if (src) {-  --    dst = src.lo32 ? BSF(src.lo32) : (BSF(src.hi32) + 32);-  --  } else {-  --    dst = 64;-  --  }-  let instrs = vcode `appOL` toOL-           ([ MOV      II32 (OpReg rhi)         (OpReg tmp_r)-            , OR       II32 (OpReg rlo)         (OpReg tmp_r)-            , MOV      II32 (OpImm (ImmInt 64)) (OpReg dst_r)-            , JXX EQQ    lbl2-            , JXX ALWAYS lbl1--            , NEWBLOCK   lbl1-            , BSF     II32 (OpReg rhi)         dst_r-            , ADD     II32 (OpImm (ImmInt 32)) (OpReg dst_r)-            , BSF     II32 (OpReg rlo)         tmp_r-            , CMOV NE II32 (OpReg tmp_r)       dst_r-            , JXX ALWAYS lbl2--            , NEWBLOCK   lbl2-            ])-  return (instrs, Just lbl2)---- | Count trailing zeroes------ Generic case (width <= word size)-genCtzGeneric :: Width -> LocalReg -> CmmExpr -> NatM InstrBlock-genCtzGeneric width dst src = do-  code_src <- getAnyReg src-  config <- getConfig-  let bw = widthInBits width-  let dst_r = getLocalRegReg dst-  if ncgBmiVersion config >= Just BMI2-  then do-      src_r <- getNewRegNat (intFormat width)-      let instrs = appOL (code_src src_r) $ case width of-              W8 -> toOL-                  [ OR    II32 (OpImm (ImmInteger 0xFFFFFF00)) (OpReg src_r)-                  , TZCNT II32 (OpReg src_r) dst_r-                  ]-              W16 -> toOL-                  [ TZCNT  II16 (OpReg src_r) dst_r-                  , MOVZxL II16 (OpReg dst_r) (OpReg dst_r)-                  ]-              _ -> unitOL $ TZCNT (intFormat width) (OpReg src_r) dst_r-      return instrs-  else do-      -- The following insn sequence makes sure 'ctz 0' has a defined value.-      -- starting with Haswell, one could use the TZCNT insn instead.-      let format = if width == W8 then II16 else intFormat width-      src_r <- getNewRegNat format-      tmp_r <- getNewRegNat format-      let instrs = code_src src_r `appOL` toOL-               ([ MOVZxL  II8    (OpReg src_r) (OpReg src_r) | width == W8 ] ++-                [ BSF     format (OpReg src_r) tmp_r-                , MOV     II32   (OpImm (ImmInt bw)) (OpReg dst_r)-                , CMOV NE format (OpReg tmp_r) dst_r-                ]) -- NB: We don't need to zero-extend the result for the-                   -- W8/W16 cases because the 'MOV' insn already-                   -- took care of implicitly clearing the upper bits-      return instrs------ | Copy memory------ Unroll memcpy calls if the number of bytes to copy isn't too large (cf--- ncgInlineThresholdMemcpy).  Otherwise, call C's memcpy.-genMemCpy-  :: BlockId-  -> Int-  -> CmmExpr-  -> CmmExpr-  -> CmmExpr-  -> NatM InstrBlock-genMemCpy bid align dst src arg_n = do--  let libc_memcpy = genLibCCall bid (fsLit "memcpy") [] [dst,src,arg_n]--  case arg_n of-    CmmLit (CmmInt n _) -> do-      -- try to inline it-      mcode <- genMemCpyInlineMaybe align dst src n-      -- if it didn't inline, call the C function-      case mcode of-        Nothing -> libc_memcpy-        Just c  -> pure c--    -- not a literal size argument: call the C function-    _ -> libc_memcpy----genMemCpyInlineMaybe-  :: Int-  -> CmmExpr-  -> CmmExpr-  -> Integer-  -> NatM (Maybe InstrBlock)-genMemCpyInlineMaybe align dst src n = do-  config <- getConfig-  let-    platform     = ncgPlatform config-    maxAlignment = wordAlignment platform-                   -- only machine word wide MOVs are supported-    effectiveAlignment = min (alignmentOf align) maxAlignment-    format = intFormat . widthFromBytes $ alignmentBytes effectiveAlignment---  -- The size of each move, in bytes.-  let sizeBytes :: Integer-      sizeBytes = fromIntegral (formatInBytes format)--  -- The number of instructions we will generate (approx). We need 2-  -- instructions per move.-  let insns = 2 * ((n + sizeBytes - 1) `div` sizeBytes)--      go :: Reg -> Reg -> Reg -> Integer -> OrdList Instr-      go dst src tmp i-          | i >= sizeBytes =-              unitOL (MOV format (OpAddr src_addr) (OpReg tmp)) `appOL`-              unitOL (MOV format (OpReg tmp) (OpAddr dst_addr)) `appOL`-              go dst src tmp (i - sizeBytes)-          -- Deal with remaining bytes.-          | i >= 4 =  -- Will never happen on 32-bit-              unitOL (MOV II32 (OpAddr src_addr) (OpReg tmp)) `appOL`-              unitOL (MOV II32 (OpReg tmp) (OpAddr dst_addr)) `appOL`-              go dst src tmp (i - 4)-          | i >= 2 =-              unitOL (MOVZxL II16 (OpAddr src_addr) (OpReg tmp)) `appOL`-              unitOL (MOV II16 (OpReg tmp) (OpAddr dst_addr)) `appOL`-              go dst src tmp (i - 2)-          | i >= 1 =-              unitOL (MOVZxL II8 (OpAddr src_addr) (OpReg tmp)) `appOL`-              unitOL (MOV II8 (OpReg tmp) (OpAddr dst_addr)) `appOL`-              go dst src tmp (i - 1)-          | otherwise = nilOL-        where-          src_addr = AddrBaseIndex (EABaseReg src) EAIndexNone-                       (ImmInteger (n - i))--          dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone-                       (ImmInteger (n - i))--  if insns > fromIntegral (ncgInlineThresholdMemcpy config)-    then pure Nothing-    else do-      code_dst <- getAnyReg dst-      dst_r <- getNewRegNat format-      code_src <- getAnyReg src-      src_r <- getNewRegNat format-      tmp_r <- getNewRegNat format-      pure $ Just $ code_dst dst_r `appOL` code_src src_r `appOL`-                      go dst_r src_r tmp_r (fromInteger n)---- | Set memory to the given byte------ Unroll memset calls if the number of bytes to copy isn't too large (cf--- ncgInlineThresholdMemset).  Otherwise, call C's memset.-genMemSet-  :: BlockId-  -> Int-  -> CmmExpr-  -> CmmExpr-  -> CmmExpr-  -> NatM InstrBlock-genMemSet bid align dst arg_c arg_n = do--  let libc_memset = genLibCCall bid (fsLit "memset") [] [dst,arg_c,arg_n]--  case (arg_c,arg_n) of-    (CmmLit (CmmInt c _), CmmLit (CmmInt n _)) -> do-      -- try to inline it-      mcode <- genMemSetInlineMaybe align dst c n-      -- if it didn't inline, call the C function-      case mcode of-        Nothing -> libc_memset-        Just c  -> pure c--    -- not literal size arguments: call the C function-    _ -> libc_memset--genMemSetInlineMaybe-  :: Int-  -> CmmExpr-  -> Integer-  -> Integer-  -> NatM (Maybe InstrBlock)-genMemSetInlineMaybe align dst c n = do-  config <- getConfig-  let-    platform = ncgPlatform config-    maxAlignment = wordAlignment platform -- only machine word wide MOVs are supported-    effectiveAlignment = min (alignmentOf align) maxAlignment-    format = intFormat . widthFromBytes $ alignmentBytes effectiveAlignment-    c2 = c `shiftL` 8 .|. c-    c4 = c2 `shiftL` 16 .|. c2-    c8 = c4 `shiftL` 32 .|. c4--    -- The number of instructions we will generate (approx). We need 1-    -- instructions per move.-    insns = (n + sizeBytes - 1) `div` sizeBytes--    -- The size of each move, in bytes.-    sizeBytes :: Integer-    sizeBytes = fromIntegral (formatInBytes format)--    -- Depending on size returns the widest MOV instruction and its-    -- width.-    gen4 :: AddrMode -> Integer -> (InstrBlock, Integer)-    gen4 addr size-        | size >= 4 =-            (unitOL (MOV II32 (OpImm (ImmInteger c4)) (OpAddr addr)), 4)-        | size >= 2 =-            (unitOL (MOV II16 (OpImm (ImmInteger c2)) (OpAddr addr)), 2)-        | size >= 1 =-            (unitOL (MOV II8 (OpImm (ImmInteger c)) (OpAddr addr)), 1)-        | otherwise = (nilOL, 0)--    -- Generates a 64-bit wide MOV instruction from REG to MEM.-    gen8 :: AddrMode -> Reg -> InstrBlock-    gen8 addr reg8byte =-      unitOL (MOV format (OpReg reg8byte) (OpAddr addr))--    -- Unrolls memset when the widest MOV is <= 4 bytes.-    go4 :: Reg -> Integer -> InstrBlock-    go4 dst left =-      if left <= 0 then nilOL-      else curMov `appOL` go4 dst (left - curWidth)-      where-        possibleWidth = minimum [left, sizeBytes]-        dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone (ImmInteger (n - left))-        (curMov, curWidth) = gen4 dst_addr possibleWidth--    -- Unrolls memset when the widest MOV is 8 bytes (thus another Reg-    -- argument). Falls back to go4 when all 8 byte moves are-    -- exhausted.-    go8 :: Reg -> Reg -> Integer -> InstrBlock-    go8 dst reg8byte left =-      if possibleWidth >= 8 then-        let curMov = gen8 dst_addr reg8byte-        in  curMov `appOL` go8 dst reg8byte (left - 8)-      else go4 dst left-      where-        possibleWidth = minimum [left, sizeBytes]-        dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone (ImmInteger (n - left))--  if fromInteger insns > ncgInlineThresholdMemset config-    then pure Nothing-    else do-        code_dst <- getAnyReg dst-        dst_r <- getNewRegNat format-        if format == II64 && n >= 8-          then do-            code_imm8byte <- getAnyReg (CmmLit (CmmInt c8 W64))-            imm8byte_r <- getNewRegNat II64-            return $ Just $ code_dst dst_r `appOL`-                              code_imm8byte imm8byte_r `appOL`-                              go8 dst_r imm8byte_r (fromInteger n)-          else-            return $ Just $ code_dst dst_r `appOL`-                              go4 dst_r (fromInteger n)---genMemMove :: BlockId -> p -> CmmActual -> CmmActual -> CmmActual -> NatM InstrBlock-genMemMove bid _align dst src n = do-  -- TODO: generate inline assembly when under a given treshold (similarly to-  -- memcpy and memset)-  genLibCCall bid (fsLit "memmove") [] [dst,src,n]--genMemCmp :: BlockId -> p -> CmmFormal -> CmmActual -> CmmActual -> CmmActual -> NatM InstrBlock-genMemCmp bid _align res dst src n = do-  -- TODO: generate inline assembly when under a given treshold (similarly to-  -- memcpy and memset)-  genLibCCall bid (fsLit "memcmp") [res] [dst,src,n]--genPrefetchData :: Int -> CmmExpr -> NatM (OrdList Instr)-genPrefetchData n src = do-  is32Bit <- is32BitPlatform-  let-    format = archWordFormat is32Bit-    -- need to know what register width for pointers!-    genPrefetch inRegSrc prefetchCTor = do-      code_src <- getAnyReg inRegSrc-      src_r <- getNewRegNat format-      return $ code_src src_r `appOL`-        (unitOL (prefetchCTor  (OpAddr-                    ((AddrBaseIndex (EABaseReg src_r )   EAIndexNone (ImmInt 0))))  ))-        -- prefetch always takes an address--  -- the c / llvm prefetch convention is 0, 1, 2, and 3-  -- the x86 corresponding names are : NTA, 2 , 1, and 0-  case n of-      0 -> genPrefetch src $ PREFETCH NTA  format-      1 -> genPrefetch src $ PREFETCH Lvl2 format-      2 -> genPrefetch src $ PREFETCH Lvl1 format-      3 -> genPrefetch src $ PREFETCH Lvl0 format-      l -> pprPanic "genPrefetchData: unexpected prefetch level" (ppr l)--genByteSwap :: Width -> LocalReg -> CmmExpr -> NatM InstrBlock-genByteSwap width dst src = do-  is32Bit <- is32BitPlatform-  let format = intFormat width-  case width of-      W64 | is32Bit -> do-        let Reg64 dst_hi dst_lo = localReg64 dst-        RegCode64 vcode rhi rlo <- iselExpr64 src-        return $ vcode `appOL`-                 toOL [ MOV II32 (OpReg rlo) (OpReg dst_hi),-                        MOV II32 (OpReg rhi) (OpReg dst_lo),-                        BSWAP II32 dst_hi,-                        BSWAP II32 dst_lo ]-      W16 -> do-        let dst_r = getLocalRegReg dst-        code_src <- getAnyReg src-        return $ code_src dst_r `appOL`-                 unitOL (BSWAP II32 dst_r) `appOL`-                 unitOL (SHR II32 (OpImm $ ImmInt 16) (OpReg dst_r))-      _   -> do-        let dst_r = getLocalRegReg dst-        code_src <- getAnyReg src-        return $ code_src dst_r `appOL` unitOL (BSWAP format dst_r)--genBitRev :: BlockId -> Width -> CmmFormal -> CmmActual -> NatM InstrBlock-genBitRev bid width dst src = do-  -- Here the C implementation (hs_bitrevN) is used as there is no x86-  -- instruction to reverse a word's bit order.-  genPrimCCall bid (bRevLabel width) [dst] [src]--genPopCnt :: BlockId -> Width -> LocalReg -> CmmExpr -> NatM InstrBlock-genPopCnt bid width dst src = do-  config <- getConfig-  let-    platform = ncgPlatform config-    format = intFormat width--  sse4_2Enabled >>= \case--    True -> do-      code_src <- getAnyReg src-      src_r <- getNewRegNat format-      let dst_r = getRegisterReg platform  (CmmLocal dst)-      return $ code_src src_r `appOL`-          (if width == W8 then-               -- The POPCNT instruction doesn't take a r/m8-               unitOL (MOVZxL II8 (OpReg src_r) (OpReg src_r)) `appOL`-               unitOL (POPCNT II16 (OpReg src_r) dst_r)-           else-               unitOL (POPCNT format (OpReg src_r) dst_r)) `appOL`-          (if width == W8 || width == W16 then-               -- We used a 16-bit destination register above,-               -- so zero-extend-               unitOL (MOVZxL II16 (OpReg dst_r) (OpReg dst_r))-           else nilOL)--    False ->-      -- generate C call to hs_popcntN in ghc-prim-      -- TODO: we could directly generate the assembly to index popcount_tab-      -- here instead of doing it by calling a C function-      genPrimCCall bid (popCntLabel width) [dst] [src]---genPdep :: BlockId -> Width -> LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock-genPdep bid width dst src mask = do-  config <- getConfig-  let-    platform = ncgPlatform config-    format = intFormat width--  if ncgBmiVersion config >= Just BMI2-    then do-      code_src  <- getAnyReg src-      code_mask <- getAnyReg mask-      src_r     <- getNewRegNat format-      mask_r    <- getNewRegNat format-      let dst_r = getRegisterReg platform  (CmmLocal dst)-      return $ code_src src_r `appOL` code_mask mask_r `appOL`-          -- PDEP only supports > 32 bit args-          ( if width == W8 || width == W16 then-              toOL-                [ MOVZxL format (OpReg src_r ) (OpReg src_r )-                , MOVZxL format (OpReg mask_r) (OpReg mask_r)-                , PDEP   II32 (OpReg mask_r) (OpReg src_r ) dst_r-                , MOVZxL format (OpReg dst_r) (OpReg dst_r) -- Truncate to op width-                ]-            else-              unitOL (PDEP format (OpReg mask_r) (OpReg src_r) dst_r)-          )-    else-      -- generate C call to hs_pdepN in ghc-prim-      genPrimCCall bid (pdepLabel width) [dst] [src,mask]---genPext :: BlockId -> Width -> LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock-genPext bid width dst src mask = do-  config <- getConfig-  if ncgBmiVersion config >= Just BMI2-    then do-      let format   = intFormat width-      let dst_r    = getLocalRegReg dst-      code_src  <- getAnyReg src-      code_mask <- getAnyReg mask-      src_r     <- getNewRegNat format-      mask_r    <- getNewRegNat format-      return $ code_src src_r `appOL` code_mask mask_r `appOL`-          (if width == W8 || width == W16 then-               -- The PEXT instruction doesn't take a r/m8 or 16-              toOL-                [ MOVZxL format (OpReg src_r ) (OpReg src_r )-                , MOVZxL format (OpReg mask_r) (OpReg mask_r)-                , PEXT   II32 (OpReg mask_r) (OpReg src_r ) dst_r-                , MOVZxL format (OpReg dst_r) (OpReg dst_r) -- Truncate to op width-                ]-            else-              unitOL (PEXT format (OpReg mask_r) (OpReg src_r) dst_r)-          )-    else-      -- generate C call to hs_pextN in ghc-prim-      genPrimCCall bid (pextLabel width) [dst] [src,mask]--genClz :: BlockId -> Width -> CmmFormal -> CmmActual -> NatM InstrBlock-genClz bid width dst src = do-  is32Bit <- is32BitPlatform-  config <- getConfig-  if is32Bit && width == W64--    then-      -- Fallback to `hs_clz64` on i386-      genPrimCCall bid (clzLabel width) [dst] [src]--    else do-      code_src <- getAnyReg src-      let dst_r = getLocalRegReg dst-      if ncgBmiVersion config >= Just BMI2-        then do-          src_r <- getNewRegNat (intFormat width)-          return $ appOL (code_src src_r) $ case width of-            W8 -> toOL-                [ MOVZxL II8  (OpReg src_r)       (OpReg src_r) -- zero-extend to 32 bit-                , LZCNT  II32 (OpReg src_r)       dst_r         -- lzcnt with extra 24 zeros-                , SUB    II32 (OpImm (ImmInt 24)) (OpReg dst_r) -- compensate for extra zeros-                ]-            W16 -> toOL-                [ LZCNT  II16 (OpReg src_r) dst_r-                , MOVZxL II16 (OpReg dst_r) (OpReg dst_r) -- zero-extend from 16 bit-                ]-            _ -> unitOL (LZCNT (intFormat width) (OpReg src_r) dst_r)-        else do-          let format = if width == W8 then II16 else intFormat width-          let bw = widthInBits width-          src_r <- getNewRegNat format-          tmp_r <- getNewRegNat format-          return $ code_src src_r `appOL` toOL-                   ([ MOVZxL  II8    (OpReg src_r) (OpReg src_r) | width == W8 ] ++-                    [ BSR     format (OpReg src_r) tmp_r-                    , MOV     II32   (OpImm (ImmInt (2*bw-1))) (OpReg dst_r)-                    , CMOV NE format (OpReg tmp_r) dst_r-                    , XOR     format (OpImm (ImmInt (bw-1))) (OpReg dst_r)-                    ]) -- NB: We don't need to zero-extend the result for the-                       -- W8/W16 cases because the 'MOV' insn already-                       -- took care of implicitly clearing the upper bits--genWordToFloat :: BlockId -> Width -> CmmFormal -> CmmActual -> NatM InstrBlock-genWordToFloat bid width dst src =-  -- TODO: generate assembly instead-  genPrimCCall bid (word2FloatLabel width) [dst] [src]--genAtomicRead :: Width -> LocalReg -> CmmExpr -> NatM InstrBlock-genAtomicRead width dst addr = do-  load_code <- intLoadCode (MOV (intFormat width)) addr-  return (load_code (getLocalRegReg dst))--genAtomicWrite :: Width -> CmmExpr -> CmmExpr -> NatM InstrBlock-genAtomicWrite width addr val = do-  code <- assignMem_IntCode (intFormat width) addr val-  return $ code `snocOL` MFENCE--genCmpXchg-  :: BlockId-  -> Width-  -> LocalReg-  -> CmmExpr-  -> CmmExpr-  -> CmmExpr-  -> NatM InstrBlock-genCmpXchg bid width dst addr old new = do-  is32Bit <- is32BitPlatform-  -- On x86 we don't have enough registers to use cmpxchg with a-  -- complicated addressing mode, so on that architecture we-  -- pre-compute the address first.-  if not (is32Bit && width == W64)-    then do-      let format = intFormat width-      Amode amode addr_code <- getSimpleAmode addr-      newval <- getNewRegNat format-      newval_code <- getAnyReg new-      oldval <- getNewRegNat format-      oldval_code <- getAnyReg old-      platform <- getPlatform-      let dst_r    = getRegisterReg platform  (CmmLocal dst)-          code     = toOL-                     [ MOV format (OpReg oldval) (OpReg eax)-                     , LOCK (CMPXCHG format (OpReg newval) (OpAddr amode))-                     , MOV format (OpReg eax) (OpReg dst_r)-                     ]-      return $ addr_code `appOL` newval_code newval `appOL` oldval_code oldval-          `appOL` code-    else-      -- generate C call to hs_cmpxchgN in ghc-prim-      genPrimCCall bid (cmpxchgLabel width) [dst] [addr,old,new]-      -- TODO: implement cmpxchg8b instruction--genXchg :: Width -> LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock-genXchg width dst addr value = do-  is32Bit <- is32BitPlatform--  when (is32Bit && width == W64) $-    panic "genXchg: 64bit atomic exchange not supported on 32bit platforms"--  Amode amode addr_code <- getSimpleAmode addr-  (newval, newval_code) <- getSomeReg value-  let format   = intFormat width-  let dst_r    = getLocalRegReg dst-  -- Copy the value into the target register, perform the exchange.-  let code     = toOL-                 [ MOV format (OpReg newval) (OpReg dst_r)-                  -- On X86 xchg implies a lock prefix if we use a memory argument.-                  -- so this is atomic.-                 , XCHG format (OpAddr amode) dst_r-                 ]-  return $ addr_code `appOL` newval_code `appOL` code---genFloatAbs :: Width -> LocalReg -> CmmExpr -> NatM InstrBlock-genFloatAbs width dst src = do-  let-    format = floatFormat width-    const = case width of-      W32 -> CmmInt 0x7fffffff W32-      W64 -> CmmInt 0x7fffffffffffffff W64-      _   -> pprPanic "genFloatAbs: invalid width" (ppr width)-  src_code <- getAnyReg src-  Amode amode amode_code <- memConstant (mkAlignment $ widthInBytes width) const-  tmp <- getNewRegNat format-  let dst_r = getLocalRegReg dst-  pure $ src_code dst_r `appOL` amode_code `appOL` toOL-           [ MOV format (OpAddr amode) (OpReg tmp)-           , AND format (OpReg tmp) (OpReg dst_r)-           ]---genFloatSqrt :: Format -> LocalReg -> CmmExpr -> NatM InstrBlock-genFloatSqrt format dst src = do-  let dst_r = getLocalRegReg dst-  src_code <- getAnyReg src-  pure $ src_code dst_r `snocOL` SQRT format (OpReg dst_r) dst_r---genAddSubRetCarry-  :: Width-  -> (Format -> Operand -> Operand -> Instr)-  -> (Format -> Maybe (Operand -> Operand -> Instr))-  -> Cond-  -> LocalReg-  -> LocalReg-  -> CmmExpr-  -> CmmExpr-  -> NatM InstrBlock-genAddSubRetCarry width instr mrevinstr cond res_r res_c arg_x arg_y = do-  platform <- ncgPlatform <$> getConfig-  let format = intFormat width-  rCode <- anyReg =<< trivialCode width (instr format)-                        (mrevinstr format) arg_x arg_y-  reg_tmp <- getNewRegNat II8-  let reg_c = getRegisterReg platform  (CmmLocal res_c)-      reg_r = getRegisterReg platform  (CmmLocal res_r)-      code = rCode reg_r `snocOL`-             SETCC cond (OpReg reg_tmp) `snocOL`-             MOVZxL II8 (OpReg reg_tmp) (OpReg reg_c)-  return code---genAddWithCarry-  :: Width-  -> LocalReg-  -> LocalReg-  -> CmmExpr-  -> CmmExpr-  -> NatM InstrBlock-genAddWithCarry width res_h res_l arg_x arg_y = do-  hCode <- getAnyReg (CmmLit (CmmInt 0 width))-  let format = intFormat width-  lCode <- anyReg =<< trivialCode width (ADD_CC format)-                        (Just (ADD_CC format)) arg_x arg_y-  let reg_l = getLocalRegReg res_l-      reg_h = getLocalRegReg res_h-      code = hCode reg_h `appOL`-             lCode reg_l `snocOL`-             ADC format (OpImm (ImmInteger 0)) (OpReg reg_h)-  return code---genSignedLargeMul-  :: Width-  -> LocalReg-  -> LocalReg-  -> LocalReg-  -> CmmExpr-  -> CmmExpr-  -> NatM (OrdList Instr)-genSignedLargeMul width res_c res_h res_l arg_x arg_y = do-  (y_reg, y_code) <- getRegOrMem arg_y-  x_code <- getAnyReg arg_x-  reg_tmp <- getNewRegNat II8-  let format = intFormat width-      reg_h = getLocalRegReg res_h-      reg_l = getLocalRegReg res_l-      reg_c = getLocalRegReg res_c-      code = y_code `appOL`-             x_code rax `appOL`-             toOL [ IMUL2 format y_reg-                  , MOV format (OpReg rdx) (OpReg reg_h)-                  , MOV format (OpReg rax) (OpReg reg_l)-                  , SETCC CARRY (OpReg reg_tmp)-                  , MOVZxL II8 (OpReg reg_tmp) (OpReg reg_c)-                  ]-  return code--genUnsignedLargeMul-  :: Width-  -> LocalReg-  -> LocalReg-  -> CmmExpr-  -> CmmExpr-  -> NatM (OrdList Instr)-genUnsignedLargeMul width res_h res_l arg_x arg_y = do-  (y_reg, y_code) <- getRegOrMem arg_y-  x_code <- getAnyReg arg_x-  let format = intFormat width-      reg_h = getLocalRegReg res_h-      reg_l = getLocalRegReg res_l-      code = y_code `appOL`-             x_code rax `appOL`-             toOL [MUL2 format y_reg,-                   MOV format (OpReg rdx) (OpReg reg_h),-                   MOV format (OpReg rax) (OpReg reg_l)]-  return code---genQuotRem-  :: Width-  -> Bool-  -> LocalReg-  -> LocalReg-  -> Maybe CmmExpr-  -> CmmExpr-  -> CmmExpr-  -> NatM InstrBlock-genQuotRem width signed res_q res_r m_arg_x_high arg_x_low arg_y = do-  case width of-    W8 -> do-      -- See Note [DIV/IDIV for bytes]-      let widen | signed = MO_SS_Conv W8 W16-                | otherwise = MO_UU_Conv W8 W16-          arg_x_low_16 = CmmMachOp widen [arg_x_low]-          arg_y_16 = CmmMachOp widen [arg_y]-          m_arg_x_high_16 = (\p -> CmmMachOp widen [p]) <$> m_arg_x_high-      genQuotRem W16 signed res_q res_r m_arg_x_high_16 arg_x_low_16 arg_y_16--    _ -> do-      let format = intFormat width-          reg_q = getLocalRegReg res_q-          reg_r = getLocalRegReg res_r-          widen | signed    = CLTD format-                | otherwise = XOR format (OpReg rdx) (OpReg rdx)-          instr | signed    = IDIV-                | otherwise = DIV-      (y_reg, y_code) <- getRegOrMem arg_y-      x_low_code <- getAnyReg arg_x_low-      x_high_code <- case m_arg_x_high of-                     Just arg_x_high ->-                         getAnyReg arg_x_high-                     Nothing ->-                         return $ const $ unitOL widen-      return $ y_code `appOL`-               x_low_code rax `appOL`-               x_high_code rdx `appOL`-               toOL [instr format y_reg,-                     MOV format (OpReg rax) (OpReg reg_q),-                     MOV format (OpReg rdx) (OpReg reg_r)]---------------------------------------------------------------------------------- The following functions implement certain 64-bit MachOps inline for 32-bit--- architectures. On 64-bit architectures, those MachOps aren't supported and--- calling these functions for a 64-bit target platform is considered an error--- (hence the use of `expect32BitPlatform`).------ On 64-bit platforms, generic MachOps should be used instead of these 64-bit--- specific ones (e.g. use MO_Add instead of MO_x64_Add). This MachOp selection--- is done by StgToCmm.--genInt64ToInt :: LocalReg -> CmmExpr -> NatM InstrBlock-genInt64ToInt dst src = do-  expect32BitPlatform (text "genInt64ToInt")-  RegCode64 code _src_hi src_lo <- iselExpr64 src-  let dst_r = getLocalRegReg dst-  pure $ code `snocOL` MOV II32 (OpReg src_lo) (OpReg dst_r)--genWord64ToWord :: LocalReg -> CmmExpr -> NatM InstrBlock-genWord64ToWord dst src = do-  expect32BitPlatform (text "genWord64ToWord")-  RegCode64 code _src_hi src_lo <- iselExpr64 src-  let dst_r = getLocalRegReg dst-  pure $ code `snocOL` MOV II32 (OpReg src_lo) (OpReg dst_r)--genIntToInt64 :: LocalReg -> CmmExpr -> NatM InstrBlock-genIntToInt64 dst src = do-  expect32BitPlatform (text "genIntToInt64")-  let Reg64 dst_hi dst_lo = localReg64 dst-  src_code <- getAnyReg src-  pure $ src_code rax `appOL` toOL-          [ CLTD II32 -- sign extend EAX in EDX:EAX-          , MOV II32 (OpReg rax) (OpReg dst_lo)-          , MOV II32 (OpReg rdx) (OpReg dst_hi)-          ]--genWordToWord64 :: LocalReg -> CmmExpr -> NatM InstrBlock-genWordToWord64 dst src = do-  expect32BitPlatform (text "genWordToWord64")-  let Reg64 dst_hi dst_lo = localReg64 dst-  src_code <- getAnyReg src-  pure $ src_code dst_lo-          `snocOL` XOR II32 (OpReg dst_hi) (OpReg dst_hi)--genNeg64 :: LocalReg -> CmmExpr -> NatM InstrBlock-genNeg64 dst src = do-  expect32BitPlatform (text "genNeg64")-  let Reg64 dst_hi dst_lo = localReg64 dst-  RegCode64 code src_hi src_lo <- iselExpr64 src-  pure $ code `appOL` toOL-          [ MOV  II32 (OpReg src_lo) (OpReg dst_lo)-          , MOV  II32 (OpReg src_hi) (OpReg dst_hi)-          , NEGI II32 (OpReg dst_lo)-          , ADC  II32 (OpImm (ImmInt 0)) (OpReg dst_hi)-          , NEGI II32 (OpReg dst_hi)-          ]--genAdd64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock-genAdd64 dst x y = do-  expect32BitPlatform (text "genAdd64")-  let Reg64 dst_hi dst_lo = localReg64 dst-  RegCode64 x_code x_hi x_lo <- iselExpr64 x-  RegCode64 y_code y_hi y_lo <- iselExpr64 y-  pure $ x_code `appOL` y_code `appOL` toOL-          [ MOV  II32 (OpReg x_lo) (OpReg dst_lo)-          , MOV  II32 (OpReg x_hi) (OpReg dst_hi)-          , ADD  II32 (OpReg y_lo) (OpReg dst_lo)-          , ADC  II32 (OpReg y_hi) (OpReg dst_hi)-          ]--genSub64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock-genSub64 dst x y = do-  expect32BitPlatform (text "genSub64")-  let Reg64 dst_hi dst_lo = localReg64 dst-  RegCode64 x_code x_hi x_lo <- iselExpr64 x-  RegCode64 y_code y_hi y_lo <- iselExpr64 y-  pure $ x_code `appOL` y_code `appOL` toOL-          [ MOV  II32 (OpReg x_lo) (OpReg dst_lo)-          , MOV  II32 (OpReg x_hi) (OpReg dst_hi)-          , SUB  II32 (OpReg y_lo) (OpReg dst_lo)-          , SBB  II32 (OpReg y_hi) (OpReg dst_hi)-          ]--genAnd64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock-genAnd64 dst x y = do-  expect32BitPlatform (text "genAnd64")-  let Reg64 dst_hi dst_lo = localReg64 dst-  RegCode64 x_code x_hi x_lo <- iselExpr64 x-  RegCode64 y_code y_hi y_lo <- iselExpr64 y-  pure $ x_code `appOL` y_code `appOL` toOL-          [ MOV II32 (OpReg x_lo) (OpReg dst_lo)-          , MOV II32 (OpReg x_hi) (OpReg dst_hi)-          , AND II32 (OpReg y_lo) (OpReg dst_lo)-          , AND II32 (OpReg y_hi) (OpReg dst_hi)-          ]--genOr64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock-genOr64 dst x y = do-  expect32BitPlatform (text "genOr64")-  let Reg64 dst_hi dst_lo = localReg64 dst-  RegCode64 x_code x_hi x_lo <- iselExpr64 x-  RegCode64 y_code y_hi y_lo <- iselExpr64 y-  pure $ x_code `appOL` y_code `appOL` toOL-          [ MOV II32 (OpReg x_lo) (OpReg dst_lo)-          , MOV II32 (OpReg x_hi) (OpReg dst_hi)-          , OR  II32 (OpReg y_lo) (OpReg dst_lo)-          , OR  II32 (OpReg y_hi) (OpReg dst_hi)-          ]--genXor64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock-genXor64 dst x y = do-  expect32BitPlatform (text "genXor64")-  let Reg64 dst_hi dst_lo = localReg64 dst-  RegCode64 x_code x_hi x_lo <- iselExpr64 x-  RegCode64 y_code y_hi y_lo <- iselExpr64 y-  pure $ x_code `appOL` y_code `appOL` toOL-          [ MOV II32 (OpReg x_lo) (OpReg dst_lo)-          , MOV II32 (OpReg x_hi) (OpReg dst_hi)-          , XOR II32 (OpReg y_lo) (OpReg dst_lo)-          , XOR II32 (OpReg y_hi) (OpReg dst_hi)-          ]--genNot64 :: LocalReg -> CmmExpr -> NatM InstrBlock-genNot64 dst src = do-  expect32BitPlatform (text "genNot64")-  let Reg64 dst_hi dst_lo = localReg64 dst-  RegCode64 src_code src_hi src_lo <- iselExpr64 src-  pure $ src_code `appOL` toOL-          [ MOV II32 (OpReg src_lo) (OpReg dst_lo)-          , MOV II32 (OpReg src_hi) (OpReg dst_hi)-          , NOT II32 (OpReg dst_lo)-          , NOT II32 (OpReg dst_hi)-          ]--genEq64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock-genEq64 dst x y = do-  expect32BitPlatform (text "genEq64")-  let dst_r = getLocalRegReg dst-  RegCode64 x_code x_hi x_lo <- iselExpr64 x-  RegCode64 y_code y_hi y_lo <- iselExpr64 y-  Reg64 tmp_hi tmp_lo <- getNewReg64-  pure $ x_code `appOL` y_code `appOL` toOL-          [ MOV II32 (OpReg x_lo)   (OpReg tmp_lo)-          , MOV II32 (OpReg x_hi)   (OpReg tmp_hi)-          , XOR II32 (OpReg y_lo)   (OpReg tmp_lo)-          , XOR II32 (OpReg y_hi)   (OpReg tmp_hi)-          , OR  II32 (OpReg tmp_lo) (OpReg tmp_hi)-          , SETCC EQQ (OpReg dst_r)-          , MOVZxL II8 (OpReg dst_r) (OpReg dst_r)-          ]--genNe64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock-genNe64 dst x y = do-  expect32BitPlatform (text "genNe64")-  let dst_r = getLocalRegReg dst-  RegCode64 x_code x_hi x_lo <- iselExpr64 x-  RegCode64 y_code y_hi y_lo <- iselExpr64 y-  Reg64 tmp_hi tmp_lo <- getNewReg64-  pure $ x_code `appOL` y_code `appOL` toOL-          [ MOV II32 (OpReg x_lo)   (OpReg tmp_lo)-          , MOV II32 (OpReg x_hi)   (OpReg tmp_hi)-          , XOR II32 (OpReg y_lo)   (OpReg tmp_lo)-          , XOR II32 (OpReg y_hi)   (OpReg tmp_hi)-          , OR  II32 (OpReg tmp_lo) (OpReg tmp_hi)-          , SETCC NE (OpReg dst_r)-          , MOVZxL II8 (OpReg dst_r) (OpReg dst_r)-          ]--genGtWord64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock-genGtWord64 dst x y = do-  expect32BitPlatform (text "genGtWord64")-  genPred64 LU dst y x--genLtWord64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock-genLtWord64 dst x y = do-  expect32BitPlatform (text "genLtWord64")-  genPred64 LU dst x y--genGeWord64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock-genGeWord64 dst x y = do-  expect32BitPlatform (text "genGeWord64")-  genPred64 GEU dst x y--genLeWord64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock-genLeWord64 dst x y = do-  expect32BitPlatform (text "genLeWord64")-  genPred64 GEU dst y x--genGtInt64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock-genGtInt64 dst x y = do-  expect32BitPlatform (text "genGtInt64")-  genPred64 LTT dst y x--genLtInt64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock-genLtInt64 dst x y = do-  expect32BitPlatform (text "genLtInt64")-  genPred64 LTT dst x y--genGeInt64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock-genGeInt64 dst x y = do-  expect32BitPlatform (text "genGeInt64")-  genPred64 GE dst x y--genLeInt64 :: LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock-genLeInt64 dst x y = do-  expect32BitPlatform (text "genLeInt64")-  genPred64 GE dst y x--genPred64 :: Cond -> LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock-genPred64 cond dst x y = do-  -- we can only rely on CF/SF/OF flags!-  -- Not on ZF, which doesn't take into account the lower parts.-  massert (cond `elem` [LU,GEU,LTT,GE])--  let dst_r = getLocalRegReg dst-  RegCode64 x_code x_hi x_lo <- iselExpr64 x-  RegCode64 y_code y_hi y_lo <- iselExpr64 y-  -- Basically we perform a subtraction with borrow.-  -- As we don't need to result, we can use CMP instead of SUB for the low part-  -- (it sets the borrow flag just like SUB does)-  pure $ x_code `appOL` y_code `appOL` toOL-          [ MOV II32 (OpReg x_hi) (OpReg dst_r)-          , CMP II32 (OpReg y_lo) (OpReg x_lo)-          , SBB II32 (OpReg y_hi) (OpReg dst_r)-          , SETCC cond (OpReg dst_r)-          , MOVZxL II8 (OpReg dst_r) (OpReg dst_r)-          ]-+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE ParallelListComp #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE NondecreasingIndentation #-}++-----------------------------------------------------------------------------+--+-- Generating machine code (instruction selection)+--+-- (c) The University of Glasgow 1996-2004+--+-----------------------------------------------------------------------------++-- This is a big module, but, if you pay attention to+-- (a) the sectioning, and (b) the type signatures, the+-- structure should not be too overwhelming.++module GHC.CmmToAsm.X86.CodeGen (+        cmmTopCodeGen,+        generateJumpTableForInstr,+        extractUnwindPoints,+        invertCondBranches,+        InstrBlock+)++where++-- NCG stuff:+import GHC.Prelude++import GHC.CmmToAsm.X86.Instr+import GHC.CmmToAsm.X86.Cond+import GHC.CmmToAsm.X86.Regs+import GHC.CmmToAsm.X86.Ppr+import GHC.CmmToAsm.X86.RegInfo++import GHC.Platform.Regs+import GHC.CmmToAsm.CPrim+import GHC.CmmToAsm.Types+import GHC.Cmm.DebugBlock+   ( DebugBlock(..), UnwindPoint(..), UnwindTable+   , UnwindExpr(UwReg), toUnwindExpr+   )+import GHC.CmmToAsm.PIC+import GHC.CmmToAsm.Monad+   ( NatM, getNewRegNat, getNewLabelNat, setDeltaNat+   , getDeltaNat, getBlockIdNat, getPicBaseNat+   , Reg64(..), RegCode64(..), getNewReg64, localReg64+   , getPicBaseMaybeNat, getDebugBlock, getFileId+   , addImmediateSuccessorNat, updateCfgNat, getConfig, getPlatform+   , getCfgWeights+   )+import GHC.CmmToAsm.CFG+import GHC.CmmToAsm.Format+import GHC.CmmToAsm.Config+import GHC.Platform.Reg+import GHC.Platform++-- Our intermediate code:+import GHC.Types.Basic+import GHC.Cmm.BlockId+import GHC.Unit.Types ( ghcInternalUnitId )+import GHC.Cmm.Utils+import GHC.Cmm.Switch+import GHC.Cmm+import GHC.Cmm.Dataflow.Block+import GHC.Cmm.Dataflow.Graph+import GHC.Cmm.Dataflow.Label+import GHC.Cmm.CLabel+import GHC.Types.Tickish ( GenTickish(..) )+import GHC.Types.SrcLoc  ( srcSpanFile, srcSpanStartLine, srcSpanStartCol )++-- The rest:+import GHC.Data.Maybe ( expectJust )+import GHC.Types.ForeignCall ( CCallConv(..) )+import GHC.Data.OrdList+import GHC.Utils.Outputable+import GHC.Utils.Constants (debugIsOn)+import GHC.Utils.Monad ( foldMapM )+import GHC.Utils.Panic+import GHC.Data.FastString+import GHC.Utils.Misc+import GHC.Types.Unique.DSM ( getUniqueM )++import qualified Data.Semigroup as S++import Control.Monad+import Control.Monad.Trans.State.Strict+  ( StateT, evalStateT, get, put )+import Control.Monad.Trans.Class (lift)+import Data.Foldable (fold)+import Data.Int+import Data.List (partition, (\\))+import Data.Maybe+import Data.Word++import qualified Data.Map as Map++is32BitPlatform :: NatM Bool+is32BitPlatform = do+    platform <- getPlatform+    return $ target32Bit platform++ssse3Enabled :: NatM Bool+ssse3Enabled = do+  config <- getConfig+  return (ncgSseVersion config >= Just SSSE3)++sse4_1Enabled :: NatM Bool+sse4_1Enabled = do+  config <- getConfig+  return (ncgSseVersion config >= Just SSE4)++sse4_2Enabled :: NatM Bool+sse4_2Enabled = do+  config <- getConfig+  return (ncgSseVersion config >= Just SSE42)++avxEnabled :: NatM Bool+avxEnabled = do+  config <- getConfig+  return (ncgAvxEnabled config)++avx2Enabled :: NatM Bool+avx2Enabled = do+  config <- getConfig+  return (ncgAvx2Enabled config)++cmmTopCodeGen+        :: RawCmmDecl+        -> NatM [NatCmmDecl (Alignment, RawCmmStatics) Instr]++cmmTopCodeGen (CmmProc info lab live graph) = do+  let blocks = toBlockListEntryFirst graph+  (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks+  picBaseMb <- getPicBaseMaybeNat+  platform <- getPlatform+  let proc = CmmProc info lab live (ListGraph $ concat nat_blocks)+      tops = proc : concat statics+      os   = platformOS platform++  case picBaseMb of+      Just picBase -> initializePicBase_x86 os picBase tops+      Nothing -> return tops++cmmTopCodeGen (CmmData sec dat) =+  return [CmmData sec (mkAlignment 1, dat)]  -- no translation, we just use CmmStatic++{- Note [Verifying basic blocks]+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+   We want to guarantee a few things about the results+   of instruction selection.++   Namely that each basic blocks consists of:+    * A (potentially empty) sequence of straight line instructions+  followed by+    * A (potentially empty) sequence of jump like instructions.++    We can verify this by going through the instructions and+    making sure that any non-jumpish instruction can't appear+    after a jumpish instruction.++    There are gotchas however:+    * CALLs are strictly speaking control flow but here we care+      not about them. Hence we treat them as regular instructions.++      It's safe for them to appear inside a basic block+      as (ignoring side effects inside the call) they will result in+      straight line code.++    * NEWBLOCK marks the start of a new basic block so can+      be followed by any instructions.+-}++-- Verifying basic blocks is cheap, but not cheap enough to enable it unconditionally.+verifyBasicBlock :: Platform -> [Instr] -> ()+verifyBasicBlock platform instrs+  | debugIsOn     = go False instrs+  | otherwise     = ()+  where+    go _     [] = ()+    go atEnd (i:instr)+        = case i of+            -- Start a new basic block+            NEWBLOCK {} -> go False instr+            -- Calls are not viable block terminators+            CALL {}     | atEnd -> faultyBlockWith i+                        | not atEnd -> go atEnd instr+            -- All instructions ok, check if we reached the end and continue.+            _ | not atEnd -> go (isJumpishInstr i) instr+              -- Only jumps allowed at the end of basic blocks.+              | otherwise -> if isJumpishInstr i+                                then go True instr+                                else faultyBlockWith i+    faultyBlockWith i+        = pprPanic "Non control flow instructions after end of basic block."+                   (pprInstr platform i <+> text "in:" $$ vcat (map (pprInstr platform) instrs))++basicBlockCodeGen+        :: CmmBlock+        -> NatM ( [NatBasicBlock Instr]+                , [NatCmmDecl (Alignment, RawCmmStatics) Instr])++basicBlockCodeGen block = do+  let (_, nodes, tail)  = blockSplit block+      id = entryLabel block+      stmts = blockToList nodes+  -- Generate location directive+  dbg <- getDebugBlock (entryLabel block)+  loc_instrs <- case dblSourceTick =<< dbg of+    Just (SourceNote span (LexicalFastString name))+      -> do fileId <- getFileId (srcSpanFile span)+            let line = srcSpanStartLine span; col = srcSpanStartCol span+            return $ unitOL $ LOCATION fileId line col (unpackFS name)+    _ -> return nilOL+  (mid_instrs,mid_bid) <- stmtsToInstrs id stmts+  (!tail_instrs,_) <- stmtToInstrs mid_bid tail+  let instrs = loc_instrs `appOL` mid_instrs `appOL` tail_instrs+  platform <- getPlatform+  return $! verifyBasicBlock platform (fromOL instrs)+  instrs' <- fold <$> traverse addSpUnwindings instrs+  -- code generation may introduce new basic block boundaries, which+  -- are indicated by the NEWBLOCK instruction.  We must split up the+  -- instruction stream into basic blocks again.  Also, we extract+  -- LDATAs here too.+  let+        (top,other_blocks,statics) = foldrOL mkBlocks ([],[],[]) instrs'++        mkBlocks (NEWBLOCK id) (instrs,blocks,statics)+          = ([], BasicBlock id instrs : blocks, statics)+        mkBlocks (LDATA sec dat) (instrs,blocks,statics)+          = (instrs, blocks, CmmData sec dat:statics)+        mkBlocks instr (instrs,blocks,statics)+          = (instr:instrs, blocks, statics)+  return (BasicBlock id top : other_blocks, statics)++-- | Convert 'DELTA' instructions into 'UNWIND' instructions to capture changes+-- in the @sp@ register. See Note [What is this unwinding business?] in "GHC.Cmm.DebugBlock"+-- for details.+addSpUnwindings :: Instr -> NatM (OrdList Instr)+addSpUnwindings instr@(DELTA d) = do+    config <- getConfig+    let platform = ncgPlatform config+    if ncgDwarfUnwindings config+        then do lbl <- mkAsmTempLabel <$> getUniqueM+                let unwind = Map.singleton MachSp (Just $ UwReg (GlobalRegUse MachSp (bWord platform)) $ negate d)+                return $ toOL [ instr, UNWIND lbl unwind ]+        else return (unitOL instr)+addSpUnwindings instr = return $ unitOL instr++{- Note [Keeping track of the current block]+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When generating instructions for Cmm we sometimes require+the current block for things like retry loops.++We also sometimes change the current block, if a MachOP+results in branching control flow.++Issues arise if we have two statements in the same block,+which both depend on the current block id *and* change the+basic block after them. This happens for atomic primops+in the X86 backend where we want to update the CFG data structure+when introducing new basic blocks.++For example in #17334 we got this Cmm code:++        c3Bf: // global+            (_s3t1::I64) = call MO_AtomicRMW W64 AMO_And(_s3sQ::P64 + 88, 18);+            (_s3t4::I64) = call MO_AtomicRMW W64 AMO_Or(_s3sQ::P64 + 88, 0);+            _s3sT::I64 = _s3sV::I64;+            goto c3B1;++This resulted in two new basic blocks being inserted:++        c3Bf:+                movl $18,%vI_n3Bo+                movq 88(%vI_s3sQ),%rax+                jmp _n3Bp+        n3Bp:+                ...+                cmpxchgq %vI_n3Bq,88(%vI_s3sQ)+                jne _n3Bp+                ...+                jmp _n3Bs+        n3Bs:+                ...+                cmpxchgq %vI_n3Bt,88(%vI_s3sQ)+                jne _n3Bs+                ...+                jmp _c3B1+        ...++Based on the Cmm we called stmtToInstrs we translated both atomic operations under+the assumption they would be placed into their Cmm basic block `c3Bf`.+However for the retry loop we introduce new labels, so this is not the case+for the second statement.+This resulted in a desync between the explicit control flow graph+we construct as a separate data type and the actual control flow graph in the code.++Instead we now return the new basic block if a statement causes a change+in the current block and use the block for all following statements.++For this reason genForeignCall is also split into two parts.  One for calls which+*won't* change the basic blocks in which successive instructions will be+placed (since they only evaluate CmmExpr, which can only contain MachOps, which+cannot introduce basic blocks in their lowerings).  A different one for calls+which *are* known to change the basic block.++-}++-- See Note [Keeping track of the current block] for why+-- we pass the BlockId.+stmtsToInstrs :: BlockId -- ^ Basic block these statement will start to be placed in.+              -> [CmmNode O O] -- ^ Cmm Statement+              -> NatM (InstrBlock, BlockId) -- ^ Resulting instruction+stmtsToInstrs bid stmts =+    go bid stmts nilOL+  where+    go bid  []        instrs = return (instrs,bid)+    go bid (s:stmts)  instrs = do+      (instrs',bid') <- stmtToInstrs bid s+      -- If the statement introduced a new block, we use that one+      let !newBid = fromMaybe bid bid'+      go newBid stmts (instrs `appOL` instrs')++-- | `bid` refers to the current block and is used to update the CFG+--   if new blocks are inserted in the control flow.+-- See Note [Keeping track of the current block] for more details.+stmtToInstrs :: BlockId -- ^ Basic block this statement will start to be placed in.+             -> CmmNode e x+             -> NatM (InstrBlock, Maybe BlockId)+             -- ^ Instructions, and bid of new block if successive+             -- statements are placed in a different basic block.+stmtToInstrs bid stmt = do+  is32Bit <- is32BitPlatform+  platform <- getPlatform+  case stmt of+    CmmUnsafeForeignCall target result_regs args+       -> genForeignCall target result_regs args bid++    _ -> (,Nothing) <$> case stmt of+      CmmComment s   -> return (unitOL (COMMENT s))+      CmmTick {}     -> return nilOL++      CmmUnwind regs -> do+        let to_unwind_entry :: (GlobalReg, Maybe CmmExpr) -> UnwindTable+            to_unwind_entry (reg, expr) = Map.singleton reg (fmap (toUnwindExpr platform) expr)+        case foldMap to_unwind_entry regs of+          tbl | Map.null tbl -> return nilOL+              | otherwise    -> do+                  lbl <- mkAsmTempLabel <$> getUniqueM+                  return $ unitOL $ UNWIND lbl tbl++      CmmAssign reg src+        | isFloatType ty         -> assignReg_FltCode reg src+        | is32Bit && isWord64 ty -> assignReg_I64Code reg src+        | isVecType ty           -> assignReg_VecCode reg src+        | otherwise              -> assignReg_IntCode reg src+          where ty = cmmRegType reg++      CmmStore addr src _alignment+        | isFloatType ty         -> assignMem_FltCode format addr src+        | is32Bit && isWord64 ty -> assignMem_I64Code        addr src+        | isVecType ty           -> assignMem_VecCode format addr src+        | otherwise              -> assignMem_IntCode format addr src+          where ty = cmmExprType platform src+                format = cmmTypeFormat ty++      CmmBranch id          -> return $ genBranch id++      --We try to arrange blocks such that the likely branch is the fallthrough+      --in GHC.Cmm.ContFlowOpt. So we can assume the condition is likely false here.+      CmmCondBranch arg true false _ -> genCondBranch bid true false arg+      CmmSwitch arg ids -> genSwitch arg ids+      CmmCall { cml_target = arg+              , cml_args_regs = gregs } -> genJump arg (jumpRegs platform gregs)+      _ ->+        panic "stmtToInstrs: statement should have been cps'd away"+++jumpRegs :: Platform -> [GlobalRegUse] -> [RegWithFormat]+jumpRegs platform gregs =+  [ RegWithFormat (RegReal r) (cmmTypeFormat ty)+  | GlobalRegUse gr ty <- gregs+  , Just r <- [globalRegMaybe platform gr] ]++--------------------------------------------------------------------------------+-- | 'InstrBlock's are the insn sequences generated by the insn selectors.+--      They are really trees of insns to facilitate fast appending, where a+--      left-to-right traversal yields the insns in the correct order.+--+type InstrBlock+        = OrdList Instr+++-- | Condition codes passed up the tree.+--+data CondCode+        = CondCode Bool Cond InstrBlock+++-- | Register's passed up the tree.  If the stix code forces the register+--      to live in a pre-decided machine register, it comes out as @Fixed@;+--      otherwise, it comes out as @Any@, and the parent can decide which+--      register to put it in.+--+data Register+        = Fixed Format Reg InstrBlock+        | Any   Format (Reg -> InstrBlock)+++swizzleRegisterRep :: Register -> Format -> Register+swizzleRegisterRep (Fixed _ reg code) format = Fixed format reg code+swizzleRegisterRep (Any _ codefn)     format = Any   format codefn++getLocalRegReg :: LocalReg -> Reg+getLocalRegReg (LocalReg u ty)+  = -- by assuming SSE2, Int, Word, Float, Double and vectors all can be register allocated+    RegVirtual (mkVirtualReg u (cmmTypeFormat ty))++-- | Grab the Reg for a CmmReg+getRegisterReg :: Platform  -> CmmReg -> Reg++getRegisterReg _   (CmmLocal lreg) = getLocalRegReg lreg++getRegisterReg platform  (CmmGlobal mid)+  = case globalRegMaybe platform $ globalRegUse_reg mid of+        Just reg -> RegReal $ reg+        Nothing  -> pprPanic "getRegisterReg-memory" (ppr $ CmmGlobal mid)+        -- By this stage, the only MagicIds remaining should be the+        -- ones which map to a real machine register on this+        -- platform.  Hence ...++-- | Memory addressing modes passed up the tree.+data Amode+        = Amode AddrMode InstrBlock++{-+Now, given a tree (the argument to a CmmLoad) that references memory,+produce a suitable addressing mode.++A Rule of the Game (tm) for Amodes: use of the addr bit must+immediately follow use of the code part, since the code part puts+values in registers which the addr then refers to.  So you can't put+anything in between, lest it overwrite some of those registers.  If+you need to do some other computation between the code part and use of+the addr bit, first store the effective address from the amode in a+temporary, then do the other computation, and then use the temporary:++    code+    LEA amode, tmp+    ... other computation ...+    ... (tmp) ...+-}++{-+Note [%rip-relative addressing on x86-64]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+On x86-64 GHC produces code for use in the "small" or, when `-fPIC` is set,+"small PIC" code models defined by the x86-64 System V ABI (section 3.5.1 of+specification version 0.99).++In general the small code model would allow us to assume that code is located+between 0 and 2^31 - 1. However, this is not true on Windows which, due to+high-entropy ASLR, may place the executable image anywhere in 64-bit address+space. This is problematic since immediate operands in x86-64 are generally+32-bit sign-extended values (with the exception of the 64-bit MOVABS encoding).+Consequently, to avoid overflowing we use %rip-relative addressing universally.+Since %rip-relative addressing comes essentially for free and makes linking far+easier, we use it even on non-Windows platforms.++See also: the documentation for GCC's `-mcmodel=small` flag.+-}+++-- | Check whether an integer will fit in 32 bits.+--      A CmmInt is intended to be truncated to the appropriate+--      number of bits, so here we truncate it to Int64.  This is+--      important because e.g. -1 as a CmmInt might be either+--      -1 or 18446744073709551615.+--+is32BitInteger :: Integer -> Bool+is32BitInteger i = i64 <= 0x7fffffff && i64 >= -0x80000000+  where i64 = fromIntegral i :: Int64+++-- | Convert a BlockId to some CmmStatic data+jumpTableEntry :: NCGConfig -> Maybe BlockId -> CmmStatic+jumpTableEntry config Nothing = CmmStaticLit (CmmInt 0 (ncgWordWidth config))+jumpTableEntry _ (Just blockid) = CmmStaticLit (CmmLabel blockLabel)+    where blockLabel = blockLbl blockid+++-- -----------------------------------------------------------------------------+-- General things for putting together code sequences++-- Expand CmmRegOff.  ToDo: should we do it this way around, or convert+-- CmmExprs into CmmRegOff?+mangleIndexTree :: CmmReg -> Int -> CmmExpr+mangleIndexTree reg off+  = CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)]+  where width = typeWidth (cmmRegType reg)++-- | The dual to getAnyReg: compute an expression into a register, but+--      we don't mind which one it is.+getSomeReg :: CmmExpr -> NatM (Reg, InstrBlock)+getSomeReg expr = do+  r <- getRegister expr+  case r of+    Any rep code -> do+        tmp <- getNewRegNat rep+        return (tmp, code tmp)+    Fixed _ reg code ->+        return (reg, code)++assignMem_I64Code :: CmmExpr -> CmmExpr -> NatM InstrBlock+assignMem_I64Code addrTree valueTree = do+  Amode addr addr_code <- getAmode addrTree+  RegCode64 vcode rhi rlo <- iselExpr64 valueTree+  let+        -- Little-endian store+        mov_lo = MOV II32 (OpReg rlo) (OpAddr addr)+        mov_hi = MOV II32 (OpReg rhi) (OpAddr (fromJust (addrOffset addr 4)))+  return (vcode `appOL` addr_code `snocOL` mov_lo `snocOL` mov_hi)+++assignReg_I64Code :: CmmReg  -> CmmExpr -> NatM InstrBlock+assignReg_I64Code (CmmLocal dst) valueTree = do+   RegCode64 vcode r_src_hi r_src_lo <- iselExpr64 valueTree+   let+         Reg64 r_dst_hi r_dst_lo = localReg64 dst+         mov_lo = MOV II32 (OpReg r_src_lo) (OpReg r_dst_lo)+         mov_hi = MOV II32 (OpReg r_src_hi) (OpReg r_dst_hi)+   return (+        vcode `snocOL` mov_lo `snocOL` mov_hi+     )++assignReg_I64Code _ _+   = panic "assignReg_I64Code(i386): invalid lvalue"++iselExpr64 :: HasDebugCallStack => CmmExpr -> NatM (RegCode64 InstrBlock)+iselExpr64 (CmmLit (CmmInt i _)) = do+  Reg64 rhi rlo <- getNewReg64+  let+        r = fromIntegral (fromIntegral i :: Word32)+        q = fromIntegral (fromIntegral (i `shiftR` 32) :: Word32)+        code = toOL [+                MOV II32 (OpImm (ImmInteger r)) (OpReg rlo),+                MOV II32 (OpImm (ImmInteger q)) (OpReg rhi)+                ]+  return (RegCode64 code rhi rlo)++iselExpr64 (CmmLoad addrTree ty _) | isWord64 ty = do+   Amode addr addr_code <- getAmode addrTree+   Reg64 rhi rlo <- getNewReg64+   let+        mov_lo = MOV II32 (OpAddr addr) (OpReg rlo)+        mov_hi = MOV II32 (OpAddr (fromJust (addrOffset addr 4))) (OpReg rhi)+   return (+            RegCode64 (addr_code `snocOL` mov_lo `snocOL` mov_hi) rhi rlo+     )++iselExpr64 (CmmReg (CmmLocal local_reg)) = do+  let Reg64 hi lo = localReg64 local_reg+  return (RegCode64 nilOL hi lo)++iselExpr64 (CmmMachOp (MO_Add _) [e1, CmmLit (CmmInt i _)]) = do+   RegCode64 code1 r1hi r1lo <- iselExpr64 e1+   Reg64 rhi rlo <- getNewReg64+   let+        r = fromIntegral (fromIntegral i :: Word32)+        q = fromIntegral (fromIntegral (i `shiftR` 32) :: Word32)+        code =  code1 `appOL`+                toOL [ MOV II32 (OpReg r1lo) (OpReg rlo),+                       ADD II32 (OpImm (ImmInteger r)) (OpReg rlo),+                       MOV II32 (OpReg r1hi) (OpReg rhi),+                       ADC II32 (OpImm (ImmInteger q)) (OpReg rhi) ]+   return (RegCode64 code rhi rlo)++iselExpr64 (CmmMachOp (MO_Add _) [e1,e2]) = do+   RegCode64 code1 r1hi r1lo <- iselExpr64 e1+   RegCode64 code2 r2hi r2lo <- iselExpr64 e2+   Reg64 rhi rlo <- getNewReg64+   let+        code =  code1 `appOL`+                code2 `appOL`+                toOL [ MOV II32 (OpReg r1lo) (OpReg rlo),+                       ADD II32 (OpReg r2lo) (OpReg rlo),+                       MOV II32 (OpReg r1hi) (OpReg rhi),+                       ADC II32 (OpReg r2hi) (OpReg rhi) ]+   return (RegCode64 code rhi rlo)++iselExpr64 (CmmMachOp (MO_Sub _) [e1,e2]) = do+   RegCode64 code1 r1hi r1lo <- iselExpr64 e1+   RegCode64 code2 r2hi r2lo <- iselExpr64 e2+   Reg64 rhi rlo <- getNewReg64+   let+        code =  code1 `appOL`+                code2 `appOL`+                toOL [ MOV II32 (OpReg r1lo) (OpReg rlo),+                       SUB II32 (OpReg r2lo) (OpReg rlo),+                       MOV II32 (OpReg r1hi) (OpReg rhi),+                       SBB II32 (OpReg r2hi) (OpReg rhi) ]+   return (RegCode64 code rhi rlo)++iselExpr64 (CmmMachOp (MO_UU_Conv W32 W64) [expr]) = do+     code <- getAnyReg expr+     Reg64 r_dst_hi r_dst_lo <- getNewReg64+     return $ RegCode64 (code r_dst_lo `snocOL`+                          XOR II32 (OpReg r_dst_hi) (OpReg r_dst_hi))+                          r_dst_hi+                          r_dst_lo++iselExpr64 (CmmMachOp (MO_UU_Conv W16 W64) [expr]) = do+     (rsrc, code) <- getByteReg expr+     Reg64 r_dst_hi r_dst_lo <- getNewReg64+     return $ RegCode64 (code `appOL` toOL [+                          MOVZxL II16 (OpReg rsrc) (OpReg r_dst_lo),+                          XOR    II32 (OpReg r_dst_hi) (OpReg r_dst_hi)+                          ])+                          r_dst_hi+                          r_dst_lo++iselExpr64 (CmmMachOp (MO_UU_Conv W8 W64) [expr]) = do+     (rsrc, code) <- getByteReg expr+     Reg64 r_dst_hi r_dst_lo <- getNewReg64+     return $ RegCode64 (code `appOL` toOL [+                          MOVZxL II8 (OpReg rsrc) (OpReg r_dst_lo),+                          XOR    II32 (OpReg r_dst_hi) (OpReg r_dst_hi)+                          ])+                          r_dst_hi+                          r_dst_lo++iselExpr64 (CmmMachOp (MO_SS_Conv W32 W64) [expr]) = do+     code <- getAnyReg expr+     Reg64 r_dst_hi r_dst_lo <- getNewReg64+     return $ RegCode64 (code r_dst_lo `snocOL`+                          MOV II32 (OpReg r_dst_lo) (OpReg eax) `snocOL`+                          CLTD II32 `snocOL`+                          MOV II32 (OpReg eax) (OpReg r_dst_lo) `snocOL`+                          MOV II32 (OpReg edx) (OpReg r_dst_hi))+                          r_dst_hi+                          r_dst_lo++iselExpr64 (CmmMachOp (MO_SS_Conv W16 W64) [expr]) = do+     (r, code) <- getByteReg expr+     Reg64 r_dst_hi r_dst_lo <- getNewReg64+     return $ RegCode64 (code `appOL` toOL [+                          MOVSxL II16 (OpReg r) (OpReg eax),+                          CLTD II32,+                          MOV II32 (OpReg eax) (OpReg r_dst_lo),+                          MOV II32 (OpReg edx) (OpReg r_dst_hi)])+                          r_dst_hi+                          r_dst_lo++iselExpr64 (CmmMachOp (MO_SS_Conv W8 W64) [expr]) = do+     (r, code) <- getByteReg expr+     Reg64 r_dst_hi r_dst_lo <- getNewReg64+     return $ RegCode64 (code `appOL` toOL [+                          MOVSxL II8 (OpReg r) (OpReg eax),+                          CLTD II32,+                          MOV II32 (OpReg eax) (OpReg r_dst_lo),+                          MOV II32 (OpReg edx) (OpReg r_dst_hi)])+                          r_dst_hi+                          r_dst_lo++iselExpr64 (CmmMachOp (MO_S_Neg _) [expr]) = do+   RegCode64 code rhi rlo <- iselExpr64 expr+   Reg64 rohi rolo <- getNewReg64+   let+        ocode = code `appOL`+                toOL [ MOV II32 (OpReg rlo) (OpReg rolo),+                       XOR II32 (OpReg rohi) (OpReg rohi),+                       NEGI II32 (OpReg rolo),+                       SBB II32 (OpReg rhi) (OpReg rohi) ]+   return (RegCode64 ocode rohi rolo)++-- To multiply two 64-bit numbers we use the following decomposition (in C notation):+--+--     ((r1hi << 32) + r1lo) * ((r2hi << 32) + r2lo)+--      = ((r2lo * r1hi) << 32)+--      + ((r1lo * r2hi) << 32)+--      + r1lo * r2lo+--+-- Note that @(r1hi * r2hi) << 64@ can be dropped because it overflows completely.++iselExpr64 (CmmMachOp (MO_Mul _) [e1,e2]) = do+   RegCode64 code1 r1hi r1lo <- iselExpr64 e1+   RegCode64 code2 r2hi r2lo <- iselExpr64 e2+   Reg64 rhi rlo <- getNewReg64+   tmp <- getNewRegNat II32+   let+        code =  code1 `appOL`+                code2 `appOL`+                toOL [ MOV  II32 (OpReg r1lo) (OpReg eax),+                       MOV  II32 (OpReg r2lo) (OpReg tmp),+                       MOV  II32 (OpReg r1hi) (OpReg rhi),+                       IMUL II32 (OpReg tmp) (OpReg rhi),+                       MOV  II32 (OpReg r2hi) (OpReg rlo),+                       IMUL II32 (OpReg eax) (OpReg rlo),+                       ADD  II32 (OpReg rlo) (OpReg rhi),+                       MUL2 II32 (OpReg tmp),+                       ADD  II32 (OpReg edx) (OpReg rhi),+                       MOV  II32 (OpReg eax) (OpReg rlo)+                     ]+   return (RegCode64 code rhi rlo)++iselExpr64 (CmmMachOp (MO_S_MulMayOflo W64) _) = do+   -- Performance sensitive users won't use 32 bit so let's keep it simple:+   -- We always return a (usually false) positive.+   Reg64 rhi rlo <- getNewReg64+   let code = toOL   [+                       MOV II32 (OpImm (ImmInt 1)) (OpReg rhi),+                       MOV II32 (OpImm (ImmInt 1)) (OpReg rlo)+                     ]+   return (RegCode64 code rhi rlo)+++-- To shift a 64-bit number to the left we use the SHLD and SHL instructions.+-- We use SHLD to shift the bits in @rhi@ to the left while copying+-- high bits from @rlo@ to fill the new space in the low bits of @rhi@.+-- That leaves @rlo@ unchanged, so we use SHL to shift the bits of @rlo@ left.+-- However, both these instructions only use the lowest 5 bits from %cl to do+-- their shifting. So if the sixth bit (0x32) is set then we additionally move+-- the contents of @rlo@ to @rhi@ and clear @rlo@.++iselExpr64 (CmmMachOp (MO_Shl _) [e1,e2]) = do+   RegCode64 code1 r1hi r1lo <- iselExpr64 e1+   code2 <- getAnyReg e2+   Reg64 rhi rlo <- getNewReg64+   lbl1 <- newBlockId+   lbl2 <- newBlockId+   let+        code =  code1 `appOL`+                code2 ecx `appOL`+                toOL [ MOV II32 (OpReg r1lo) (OpReg rlo),+                       MOV II32 (OpReg r1hi) (OpReg rhi),+                       SHLD II32 (OpReg ecx) (OpReg rlo) (OpReg rhi),+                       SHL II32 (OpReg ecx) (OpReg rlo),+                       TEST II32 (OpImm (ImmInt 32)) (OpReg ecx),+                       JXX EQQ lbl2,+                       JXX ALWAYS lbl1,+                       NEWBLOCK lbl1,+                       MOV II32 (OpReg rlo) (OpReg rhi),+                       XOR II32 (OpReg rlo) (OpReg rlo),+                       JXX ALWAYS lbl2,+                       NEWBLOCK lbl2+                     ]+   return (RegCode64 code rhi rlo)++-- Similar to above, however now we're shifting to the right+-- and we're doing a signed shift which means that @rhi@ needs+-- to be set to either 0 if @rhi@ is positive or 0xffffffff otherwise,+-- and if the sixth bit of %cl is set (so the shift amount is more than 32).+-- To accomplish that we shift @rhi@ by 31.++iselExpr64 (CmmMachOp (MO_S_Shr _) [e1,e2]) = do+   RegCode64 code1 r1hi r1lo <- iselExpr64 e1+   (r2, code2) <- getSomeReg e2+   Reg64 rhi rlo <- getNewReg64+   lbl1 <- newBlockId+   lbl2 <- newBlockId+   let+        code =  code1 `appOL`+                code2 `appOL`+                toOL [ MOV II32 (OpReg r1lo) (OpReg rlo),+                       MOV II32 (OpReg r1hi) (OpReg rhi),+                       MOV II32 (OpReg r2) (OpReg ecx),+                       SHRD II32 (OpReg ecx) (OpReg rhi) (OpReg rlo),+                       SAR II32 (OpReg ecx) (OpReg rhi),+                       TEST II32 (OpImm (ImmInt 32)) (OpReg ecx),+                       JXX EQQ lbl2,+                       JXX ALWAYS lbl1,+                       NEWBLOCK lbl1,+                       MOV II32 (OpReg rhi) (OpReg rlo),+                       SAR II32 (OpImm (ImmInt 31)) (OpReg rhi),+                       JXX ALWAYS lbl2,+                       NEWBLOCK lbl2+                     ]+   return (RegCode64 code rhi rlo)++-- Similar to the above.++iselExpr64 (CmmMachOp (MO_U_Shr _) [e1,e2]) = do+   RegCode64 code1 r1hi r1lo <- iselExpr64 e1+   (r2, code2) <- getSomeReg e2+   Reg64 rhi rlo <- getNewReg64+   lbl1 <- newBlockId+   lbl2 <- newBlockId+   let+        code =  code1 `appOL`+                code2 `appOL`+                toOL [ MOV II32 (OpReg r1lo) (OpReg rlo),+                       MOV II32 (OpReg r1hi) (OpReg rhi),+                       MOV II32 (OpReg r2) (OpReg ecx),+                       SHRD II32 (OpReg ecx) (OpReg rhi) (OpReg rlo),+                       SHR II32 (OpReg ecx) (OpReg rhi),+                       TEST II32 (OpImm (ImmInt 32)) (OpReg ecx),+                       JXX EQQ lbl2,+                       JXX ALWAYS lbl1,+                       NEWBLOCK lbl1,+                       MOV II32 (OpReg rhi) (OpReg rlo),+                       XOR II32 (OpReg rhi) (OpReg rhi),+                       JXX ALWAYS lbl2,+                       NEWBLOCK lbl2+                     ]+   return (RegCode64 code rhi rlo)++iselExpr64 (CmmMachOp (MO_And _) [e1,e2]) = iselExpr64ParallelBin AND e1 e2+iselExpr64 (CmmMachOp (MO_Or  _) [e1,e2]) = iselExpr64ParallelBin OR  e1 e2+iselExpr64 (CmmMachOp (MO_Xor _) [e1,e2]) = iselExpr64ParallelBin XOR e1 e2++iselExpr64 (CmmMachOp (MO_Not _) [e1]) = do+   RegCode64 code1 r1hi r1lo <- iselExpr64 e1+   Reg64 rhi rlo <- getNewReg64+   let+        code =  code1 `appOL`+                toOL [ MOV II32 (OpReg r1lo) (OpReg rlo),+                       MOV II32 (OpReg r1hi) (OpReg rhi),+                       NOT II32 (OpReg rlo),+                       NOT II32 (OpReg rhi)+                     ]+   return (RegCode64 code rhi rlo)++iselExpr64 (CmmRegOff r i) = iselExpr64 (mangleIndexTree r i)++iselExpr64 expr+   = do+      platform <- getPlatform+      pprPanic "iselExpr64(i386)" (pdoc platform expr $+$ text (show expr))++iselExpr64ParallelBin :: (Format -> Operand -> Operand -> Instr)+                      -> CmmExpr -> CmmExpr -> NatM (RegCode64 (OrdList Instr))+iselExpr64ParallelBin op e1 e2 = do+   RegCode64 code1 r1hi r1lo <- iselExpr64 e1+   RegCode64 code2 r2hi r2lo <- iselExpr64 e2+   Reg64 rhi rlo <- getNewReg64+   let+        code =  code1 `appOL`+                code2 `appOL`+                toOL [ MOV II32 (OpReg r1lo) (OpReg rlo),+                       MOV II32 (OpReg r1hi) (OpReg rhi),+                       op  II32 (OpReg r2lo) (OpReg rlo),+                       op  II32 (OpReg r2hi) (OpReg rhi)+                     ]+   return (RegCode64 code rhi rlo)++--------------------------------------------------------------------------------++getRegister :: HasDebugCallStack => CmmExpr -> NatM Register+getRegister e = do platform <- getPlatform+                   is32Bit <- is32BitPlatform+                   getRegister' platform is32Bit e++getRegister' :: HasDebugCallStack => Platform -> Bool -> CmmExpr -> NatM Register++getRegister' platform is32Bit (CmmReg reg)+  = case reg of+        CmmGlobal (GlobalRegUse PicBaseReg _)+         | is32Bit ->+            -- on x86_64, we have %rip for PicBaseReg, but it's not+            -- a full-featured register, it can only be used for+            -- rip-relative addressing.+            do reg' <- getPicBaseNat (archWordFormat is32Bit)+               return (Fixed (archWordFormat is32Bit) reg' nilOL)+        _ ->+          let ty = cmmRegType reg+              reg_fmt = cmmTypeFormat ty+          in return $ Fixed reg_fmt (getRegisterReg platform reg) nilOL++getRegister' platform is32Bit (CmmRegOff r n)+  = getRegister' platform is32Bit $ mangleIndexTree r n++getRegister' platform is32Bit (CmmMachOp (MO_RelaxedRead w) [e])+  = getRegister' platform is32Bit (CmmLoad e (cmmBits w) NaturallyAligned)++getRegister' platform is32Bit (CmmMachOp (MO_AlignmentCheck align _) [e])+  = addAlignmentCheck align <$> getRegister' platform is32Bit e++-- for 32-bit architectures, support some 64 -> 32 bit conversions:+-- TO_W_(x), TO_W_(x >> 32)++getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W64 W32)+                     [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]])+ | is32Bit = do+  RegCode64 code rhi _rlo <- iselExpr64 x+  return $ Fixed II32 rhi code++getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W64 W32)+                     [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]])+ | is32Bit = do+  RegCode64 code rhi _rlo <- iselExpr64 x+  return $ Fixed II32 rhi code++getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W64 W32) [x])+ | is32Bit = do+  RegCode64 code _rhi rlo <- iselExpr64 x+  return $ Fixed II32 rlo code++getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W64 W32) [x])+ | is32Bit = do+  RegCode64 code _rhi rlo <- iselExpr64 x+  return $ Fixed II32 rlo code++getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W64 W8) [x])+ | is32Bit = do+  RegCode64 code _rhi rlo <- iselExpr64 x+  ro <- getNewRegNat II8+  return $ Fixed II8 ro (code `appOL` toOL [ MOVZxL II8 (OpReg rlo) (OpReg ro) ])++getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W64 W16) [x])+ | is32Bit = do+  RegCode64 code _rhi rlo <- iselExpr64 x+  ro <- getNewRegNat II16+  return $ Fixed II16 ro (code `appOL` toOL [ MOVZxL II16 (OpReg rlo) (OpReg ro) ])++-- catch simple cases of zero- or sign-extended load+getRegister' _ _ (CmmMachOp (MO_UU_Conv W8 W32) [CmmLoad addr _ _]) = do+  code <- intLoadCode (MOVZxL II8) addr+  return (Any II32 code)++getRegister' _ _ (CmmMachOp (MO_SS_Conv W8 W32) [CmmLoad addr _ _]) = do+  code <- intLoadCode (MOVSxL II8) addr+  return (Any II32 code)++getRegister' _ _ (CmmMachOp (MO_UU_Conv W16 W32) [CmmLoad addr _ _]) = do+  code <- intLoadCode (MOVZxL II16) addr+  return (Any II32 code)++getRegister' _ _ (CmmMachOp (MO_SS_Conv W16 W32) [CmmLoad addr _ _]) = do+  code <- intLoadCode (MOVSxL II16) addr+  return (Any II32 code)++-- catch simple cases of zero- or sign-extended load+getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W8 W64) [CmmLoad addr _ _])+ | not is32Bit = do+  code <- intLoadCode (MOVZxL II8) addr+  return (Any II64 code)++getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W8 W64) [CmmLoad addr _ _])+ | not is32Bit = do+  code <- intLoadCode (MOVSxL II8) addr+  return (Any II64 code)++getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W16 W64) [CmmLoad addr _ _])+ | not is32Bit = do+  code <- intLoadCode (MOVZxL II16) addr+  return (Any II64 code)++getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W16 W64) [CmmLoad addr _ _])+ | not is32Bit = do+  code <- intLoadCode (MOVSxL II16) addr+  return (Any II64 code)++getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W32 W64) [CmmLoad addr _ _])+ | not is32Bit = do+  code <- intLoadCode (MOV II32) addr -- 32-bit loads zero-extend+  return (Any II64 code)++getRegister' _ is32Bit (CmmMachOp (MO_SS_Conv W32 W64) [CmmLoad addr _ _])+ | not is32Bit = do+  code <- intLoadCode (MOVSxL II32) addr+  return (Any II64 code)++getRegister' _ is32Bit (CmmMachOp (MO_Add W64) [CmmReg (CmmGlobal (GlobalRegUse PicBaseReg _)),+                                     CmmLit displacement])+ | not is32Bit =+      return $ Any II64 (\dst -> unitOL $+        LEA II64 (OpAddr (ripRel (litToImm displacement))) (OpReg dst))++getRegister' _ _ (CmmMachOp mop []) =+  pprPanic "getRegister(x86): nullary MachOp" (text $ show mop)++getRegister' platform is32Bit (CmmMachOp mop [x]) = do -- unary MachOps+    avx    <- avxEnabled+    avx2   <- avx2Enabled+    case mop of+      MO_F_Neg w  -> sse2NegCode w x+++      MO_S_Neg w -> triv_ucode NEGI (intFormat w)+      MO_Not w   -> triv_ucode NOT  (intFormat w)++      -- Nop conversions+      MO_UU_Conv W32 W8  -> toI8Reg  W32 x+      MO_SS_Conv W32 W8  -> toI8Reg  W32 x+      MO_XX_Conv W32 W8  -> toI8Reg  W32 x+      MO_UU_Conv W16 W8  -> toI8Reg  W16 x+      MO_SS_Conv W16 W8  -> toI8Reg  W16 x+      MO_XX_Conv W16 W8  -> toI8Reg  W16 x+      MO_UU_Conv W32 W16 -> toI16Reg W32 x+      MO_SS_Conv W32 W16 -> toI16Reg W32 x+      MO_XX_Conv W32 W16 -> toI16Reg W32 x++      MO_UU_Conv W64 W32 | not is32Bit -> conversionNop II64 x+      MO_SS_Conv W64 W32 | not is32Bit -> conversionNop II64 x+      MO_XX_Conv W64 W32 | not is32Bit -> conversionNop II64 x+      MO_UU_Conv W64 W16 | not is32Bit -> toI16Reg W64 x+      MO_SS_Conv W64 W16 | not is32Bit -> toI16Reg W64 x+      MO_XX_Conv W64 W16 | not is32Bit -> toI16Reg W64 x+      MO_UU_Conv W64 W8  | not is32Bit -> toI8Reg  W64 x+      MO_SS_Conv W64 W8  | not is32Bit -> toI8Reg  W64 x+      MO_XX_Conv W64 W8  | not is32Bit -> toI8Reg  W64 x++      MO_UU_Conv rep1 rep2 | rep1 == rep2 -> conversionNop (intFormat rep1) x+      MO_SS_Conv rep1 rep2 | rep1 == rep2 -> conversionNop (intFormat rep1) x+      MO_XX_Conv rep1 rep2 | rep1 == rep2 -> conversionNop (intFormat rep1) x++      MO_FW_Bitcast W32 -> bitcast FF32 II32 x+      MO_WF_Bitcast W32 -> bitcast II32 FF32 x+      MO_FW_Bitcast W64 -> bitcast FF64 II64 x+      MO_WF_Bitcast W64 -> bitcast II64 FF64 x+      MO_WF_Bitcast {}  -> incorrectOperands+      MO_FW_Bitcast {}  -> incorrectOperands++      -- widenings+      MO_UU_Conv W8  W32 -> integerExtend W8  W32 MOVZxL x+      MO_UU_Conv W16 W32 -> integerExtend W16 W32 MOVZxL x+      MO_UU_Conv W8  W16 -> integerExtend W8  W16 MOVZxL x++      MO_SS_Conv W8  W32 -> integerExtend W8  W32 MOVSxL x+      MO_SS_Conv W16 W32 -> integerExtend W16 W32 MOVSxL x+      MO_SS_Conv W8  W16 -> integerExtend W8  W16 MOVSxL x++      -- We don't care about the upper bits for MO_XX_Conv, so MOV is enough. However, on 32-bit we+      -- have 8-bit registers only for a few registers (as opposed to x86-64 where every register+      -- has 8-bit version). So for 32-bit code, we'll just zero-extend.+      MO_XX_Conv W8  W32+          | is32Bit   -> integerExtend W8 W32 MOVZxL x+          | otherwise -> integerExtend W8 W32 MOV x+      MO_XX_Conv W8  W16+          | is32Bit   -> integerExtend W8 W16 MOVZxL x+          | otherwise -> integerExtend W8 W16 MOV x+      MO_XX_Conv W16 W32 -> integerExtend W16 W32 MOV x++      MO_UU_Conv W8  W64 | not is32Bit -> integerExtend W8  W64 MOVZxL x+      MO_UU_Conv W16 W64 | not is32Bit -> integerExtend W16 W64 MOVZxL x+      MO_UU_Conv W32 W64 | not is32Bit -> integerExtend W32 W64 MOVZxL x+      MO_SS_Conv W8  W64 | not is32Bit -> integerExtend W8  W64 MOVSxL x+      MO_SS_Conv W16 W64 | not is32Bit -> integerExtend W16 W64 MOVSxL x+      MO_SS_Conv W32 W64 | not is32Bit -> integerExtend W32 W64 MOVSxL x+      -- For 32-to-64 bit zero extension, amd64 uses an ordinary movl.+      -- However, we don't want the register allocator to throw it+      -- away as an unnecessary reg-to-reg move, so we keep it in+      -- the form of a movzl and print it as a movl later.+      -- This doesn't apply to MO_XX_Conv since in this case we don't care about+      -- the upper bits. So we can just use MOV.+      MO_XX_Conv W8  W64 | not is32Bit -> integerExtend W8  W64 MOV x+      MO_XX_Conv W16 W64 | not is32Bit -> integerExtend W16 W64 MOV x+      MO_XX_Conv W32 W64 | not is32Bit -> integerExtend W32 W64 MOV x++      MO_FF_Conv W32 W64 -> coerceFP2FP W64 x+      MO_FF_Conv W64 W32 -> coerceFP2FP W32 x++      MO_FF_Conv from to -> invalidConversion from to+      MO_UU_Conv from to -> invalidConversion from to+      MO_SS_Conv from to -> invalidConversion from to+      MO_XX_Conv from to -> invalidConversion from to++      MO_FS_Truncate from to -> coerceFP2Int from to x+      MO_SF_Round    from to -> coerceInt2FP from to x++      MO_VF_Neg l w  | avx       -> vector_float_negate_avx l w x+                     | otherwise -> vector_float_negate_sse l w x+      -- SIMD NCG TODO: Support 256/512-bit integer vectors+      MO_VS_Neg l w -> getRegister' platform is32Bit (CmmMachOp (MO_V_Sub l w) [zero_vec, x])+        where zero_vec = CmmLit $ CmmVec $ replicate l $ CmmInt 0 w++      MO_VF_Broadcast l w+        | avx+        -> vector_float_broadcast_avx l w x+        | otherwise+        -> vector_float_broadcast_sse l w x+      MO_V_Broadcast l w+        | avx2, l * widthInBits w `elem` [128, 256] -- AVX-512 is not supported for now+        -> vector_int_broadcast_avx2 l w x+      MO_V_Broadcast 16 W8 -> vector_int8x16_broadcast x+      MO_V_Broadcast 8 W16 -> vector_int16x8_broadcast x+      MO_V_Broadcast 4 W32 -> vector_int32x4_broadcast x+      MO_V_Broadcast 2 W64 -> vector_int64x2_broadcast x+      MO_V_Broadcast {}+        -> pprPanic "Unsupported integer vector broadcast operation for: " (pdoc platform x)++      -- Binary MachOps+      MO_Add {}    -> incorrectOperands+      MO_Sub {}    -> incorrectOperands+      MO_Eq {}     -> incorrectOperands+      MO_Ne {}     -> incorrectOperands+      MO_Mul {}    -> incorrectOperands+      MO_S_MulMayOflo {} -> incorrectOperands+      MO_S_Quot {} -> incorrectOperands+      MO_S_Rem {}  -> incorrectOperands+      MO_U_Quot {} -> incorrectOperands+      MO_U_Rem {}  -> incorrectOperands+      MO_S_Ge {}   -> incorrectOperands+      MO_S_Le {}   -> incorrectOperands+      MO_S_Gt {}   -> incorrectOperands+      MO_S_Lt {}   -> incorrectOperands+      MO_U_Ge {}   -> incorrectOperands+      MO_U_Le {}   -> incorrectOperands+      MO_U_Gt {}   -> incorrectOperands+      MO_U_Lt {}   -> incorrectOperands+      MO_F_Add {}  -> incorrectOperands+      MO_F_Sub {}  -> incorrectOperands+      MO_F_Mul {}  -> incorrectOperands+      MO_F_Quot {} -> incorrectOperands+      MO_F_Eq {}   -> incorrectOperands+      MO_F_Ne {}   -> incorrectOperands+      MO_F_Ge {}   -> incorrectOperands+      MO_F_Le {}   -> incorrectOperands+      MO_F_Gt {}   -> incorrectOperands+      MO_F_Lt {}   -> incorrectOperands+      MO_F_Min {}  -> incorrectOperands+      MO_F_Max {}  -> incorrectOperands+      MO_And {}    -> incorrectOperands+      MO_Or {}     -> incorrectOperands+      MO_Xor {}    -> incorrectOperands+      MO_Shl {}    -> incorrectOperands+      MO_U_Shr {}  -> incorrectOperands+      MO_S_Shr {}  -> incorrectOperands++      MO_V_Extract {}     -> incorrectOperands+      MO_V_Add {}         -> incorrectOperands+      MO_V_Sub {}         -> incorrectOperands+      MO_V_Mul {}         -> incorrectOperands+      MO_V_Shuffle {}     -> incorrectOperands+      MO_VF_Shuffle {}    -> incorrectOperands+      MO_VU_Min {}  -> incorrectOperands+      MO_VU_Max {}  -> incorrectOperands+      MO_VS_Min {}  -> incorrectOperands+      MO_VS_Max {}  -> incorrectOperands+      MO_VF_Min {}  -> incorrectOperands+      MO_VF_Max {}  -> incorrectOperands++      MO_VF_Extract {}    -> incorrectOperands+      MO_VF_Add {}        -> incorrectOperands+      MO_VF_Sub {}        -> incorrectOperands+      MO_VF_Mul {}        -> incorrectOperands+      MO_VF_Quot {}       -> incorrectOperands++      -- Ternary MachOps+      MO_FMA {}           -> incorrectOperands+      MO_VF_Insert {}     -> incorrectOperands+      MO_V_Insert {}      -> incorrectOperands++      --_other -> pprPanic "getRegister" (pprMachOp mop)+   where+        triv_ucode :: (Format -> Operand -> Instr) -> Format -> NatM Register+        triv_ucode instr format = trivialUCode format (instr format) x++        -- signed or unsigned extension.+        integerExtend :: Width -> Width+                      -> (Format -> Operand -> Operand -> Instr)+                      -> CmmExpr -> NatM Register+        integerExtend from to instr expr = do+            (reg,e_code) <- if from == W8 then getByteReg expr+                                          else getSomeReg expr+            let+                code dst =+                  e_code `snocOL`+                  instr (intFormat from) (OpReg reg) (OpReg dst)+            return (Any (intFormat to) code)++        bitcast :: Format -> Format -> CmmExpr -> NatM Register+        bitcast fmt rfmt expr =+          do (src, e_code) <- getSomeReg expr+             let code = \dst -> e_code `snocOL` (MOVD fmt rfmt (OpReg src) (OpReg dst))+             return (Any rfmt code)++        toI8Reg :: Width -> CmmExpr -> NatM Register+        toI8Reg new_rep expr+            = do codefn <- getAnyReg expr+                 return (Any (intFormat new_rep) codefn)+                -- HACK: use getAnyReg to get a byte-addressable register.+                -- If the source was a Fixed register, this will add the+                -- mov instruction to put it into the desired destination.+                -- We're assuming that the destination won't be a fixed+                -- non-byte-addressable register; it won't be, because all+                -- fixed registers are word-sized.++        toI16Reg = toI8Reg -- for now++        conversionNop :: Format -> CmmExpr -> NatM Register+        conversionNop new_format expr+            = do e_code <- getRegister' platform is32Bit expr+                 return (swizzleRegisterRep e_code new_format)++        vector_float_negate_avx :: Length -> Width -> CmmExpr -> NatM Register+        vector_float_negate_avx l w expr = do+          let fmt :: Format+              mask :: CmmLit+              (fmt, mask) = case w of+                       W32 -> (VecFormat l FmtFloat , CmmInt (bit 31) w) -- TODO: these should be negative 0 floating point literals,+                       W64 -> (VecFormat l FmtDouble, CmmInt (bit 63) w) -- but we don't currently have those in Cmm.+                       _ -> panic "AVX floating-point negation: elements must be FF32 or FF64"+          (maskReg, maskCode) <- getSomeReg (CmmLit $ CmmVec $ replicate l mask)+          (reg, exp) <- getSomeReg expr+          let code dst = maskCode `appOL`+                         exp `snocOL`+                         (VMOVU fmt (OpReg reg) (OpReg dst)) `snocOL`+                         (VXOR fmt (OpReg maskReg) dst dst)+          return (Any fmt code)++        vector_float_negate_sse :: Length -> Width -> CmmExpr -> NatM Register+        vector_float_negate_sse l w expr = do+          let fmt :: Format+              mask :: CmmLit+              (fmt, mask) = case w of+                       W32 -> (VecFormat l FmtFloat , CmmInt (bit 31) w) -- Same comment as for vector_float_negate_avx,+                       W64 -> (VecFormat l FmtDouble, CmmInt (bit 63) w) -- these should be -0.0 CmmFloat values.+                       _ -> panic "SSE floating-point negation: elements must be FF32 or FF64"+          (maskReg, maskCode) <- getSomeReg (CmmLit $ CmmVec $ replicate l mask)+          (reg, exp) <- getSomeReg expr+          let code dst = maskCode `appOL`+                         exp `snocOL`+                         (MOVU fmt (OpReg reg) (OpReg dst)) `snocOL`+                         (XOR  fmt (OpReg maskReg) (OpReg dst))+          return (Any fmt code)++        -----------------------++        -- TODO: we could use VBROADCASTSS/SD when AVX2 is available.+        vector_float_broadcast_avx :: Length+                                   -> Width+                                   -> CmmExpr+                                   -> NatM Register+        vector_float_broadcast_avx len w expr = do+          (dst, exp) <- getSomeReg expr+          let fmt = VecFormat len (floatScalarFormat w)+              code = VSHUF fmt (ImmInt 0) (OpReg dst) dst dst+          return $ Fixed fmt dst (exp `snocOL` code)++        vector_float_broadcast_sse :: Length+                                   -> Width+                                   -> CmmExpr+                                   -> NatM Register+        vector_float_broadcast_sse len w expr = do+          (dst, exp) <- getSomeReg expr+          let fmt = VecFormat len (floatScalarFormat w)+              code = SHUF fmt (ImmInt 0) (OpReg dst) dst+          return $ Fixed fmt dst (exp `snocOL` code)++        vector_int_broadcast_avx2 :: Length+                                  -> Width+                                  -> CmmExpr+                                  -> NatM Register+        vector_int_broadcast_avx2 len w expr = do+          (reg, exp) <- getNonClobberedReg expr+          let (movFormat, fmt) = case w of+                W8  -> (II32, VecFormat len FmtInt8)+                W16 -> (II32, VecFormat len FmtInt16)+                W32 -> (II32, VecFormat len FmtInt32)+                W64 -> (II64, VecFormat len FmtInt64)+                _   -> pprPanic "Broadcast not supported for: " (pdoc platform expr)+              code dst = exp `snocOL`+                         -- VPBROADCAST from GPR requires AVX-512,+                         -- so we use an additional MOVD.+                         (MOVD movFormat fmt (OpReg reg) (OpReg dst)) `snocOL`+                         (VPBROADCAST fmt fmt (OpReg dst) dst)+          return $ Any fmt code++        vector_int8x16_broadcast :: CmmExpr+                                 -> NatM Register+        vector_int8x16_broadcast expr = do+          (reg, exp) <- getNonClobberedReg expr+          let fmt = VecFormat 16 FmtInt8+          return $ Any fmt (\dst -> exp `snocOL`+                                    (MOVD II32 fmt (OpReg reg) (OpReg dst)) `snocOL`+                                    (PUNPCKLBW fmt (OpReg dst) dst) `snocOL`+                                    (PUNPCKLWD (VecFormat 8 FmtInt16) (OpReg dst) dst) `snocOL`+                                    (PSHUFD fmt (ImmInt 0x00) (OpReg dst) dst)+                                    )++        vector_int16x8_broadcast :: CmmExpr+                                 -> NatM Register+        vector_int16x8_broadcast expr = do+          (reg, exp) <- getNonClobberedReg expr+          let fmt = VecFormat 8 FmtInt16+          return $ Any fmt (\dst -> exp `snocOL`+                                    (MOVD II32 fmt (OpReg reg) (OpReg dst)) `snocOL`+                                    (PUNPCKLWD fmt (OpReg dst) dst) `snocOL`+                                    (PSHUFD fmt (ImmInt 0x00) (OpReg dst) dst)+                                    )++        vector_int32x4_broadcast :: CmmExpr+                                 -> NatM Register+        vector_int32x4_broadcast expr = do+          (reg, exp) <- getNonClobberedReg expr+          let fmt = VecFormat 4 FmtInt32+          return $ Any fmt (\dst -> exp `snocOL`+                                    (MOVD II32 fmt (OpReg reg) (OpReg dst)) `snocOL`+                                    (PSHUFD fmt (ImmInt 0x00) (OpReg dst) dst)+                                    )++        vector_int64x2_broadcast :: CmmExpr+                                 -> NatM Register+        vector_int64x2_broadcast expr = do+          (reg, exp) <- getNonClobberedReg expr+          let fmt = VecFormat 2 FmtInt64+          return $ Any fmt (\dst -> exp `snocOL`+                                    (MOVD II64 fmt (OpReg reg) (OpReg dst)) `snocOL`+                                    (PUNPCKLQDQ fmt (OpReg dst) dst)+                                    )++getRegister' platform is32Bit (CmmMachOp mop [x, y]) = do -- dyadic MachOps+  sse4_1 <- sse4_1Enabled+  sse4_2 <- sse4_2Enabled+  avx <- avxEnabled+  case mop of+      MO_F_Eq _ -> condFltReg is32Bit EQQ x y+      MO_F_Ne _ -> condFltReg is32Bit NE  x y+      MO_F_Gt _ -> condFltReg is32Bit GTT x y+      MO_F_Ge _ -> condFltReg is32Bit GE  x y+      -- Invert comparison condition and swap operands+      -- See Note [SSE Parity Checks]+      MO_F_Lt _ -> condFltReg is32Bit GTT  y x+      MO_F_Le _ -> condFltReg is32Bit GE   y x++      MO_Eq _   -> condIntReg EQQ x y+      MO_Ne _   -> condIntReg NE  x y++      MO_S_Gt _ -> condIntReg GTT x y+      MO_S_Ge _ -> condIntReg GE  x y+      MO_S_Lt _ -> condIntReg LTT x y+      MO_S_Le _ -> condIntReg LE  x y++      MO_U_Gt _ -> condIntReg GU  x y+      MO_U_Ge _ -> condIntReg GEU x y+      MO_U_Lt _ -> condIntReg LU  x y+      MO_U_Le _ -> condIntReg LEU x y++      MO_F_Add  w -> trivialFCode_sse2 w (\fmt op2 -> ADD fmt op2 . OpReg) x y+      MO_F_Sub  w -> trivialFCode_sse2 w (\fmt op2 -> SUB fmt op2 . OpReg) x y+      MO_F_Quot w -> trivialFCode_sse2 w FDIV x y+      MO_F_Mul  w -> trivialFCode_sse2 w (\fmt op2 -> MUL fmt op2 . OpReg) x y+      MO_F_Min  w -> trivialFCode_sse2 w (MINMAX Min FloatMinMax) x y+      MO_F_Max  w -> trivialFCode_sse2 w (MINMAX Max FloatMinMax) x y++      MO_Add rep -> add_code rep x y+      MO_Sub rep -> sub_code rep x y++      MO_S_Quot rep -> div_code rep True  True  x y+      MO_S_Rem  rep -> div_code rep True  False x y+      MO_U_Quot rep -> div_code rep False True  x y+      MO_U_Rem  rep -> div_code rep False False x y++      MO_S_MulMayOflo rep -> imulMayOflo rep x y++      MO_Mul W8  -> imulW8 x y+      MO_Mul rep -> triv_op rep IMUL+      MO_And rep -> triv_op rep AND+      MO_Or  rep -> triv_op rep OR+      MO_Xor rep -> triv_op rep XOR++        {- Shift ops on x86s have constraints on their source, it+           either has to be Imm, CL or 1+            => trivialCode is not restrictive enough (sigh.)+        -}+      MO_Shl rep   -> shift_code rep SHL x y {-False-}+      MO_U_Shr rep -> shift_code rep SHR x y {-False-}+      MO_S_Shr rep -> shift_code rep SAR x y {-False-}++      MO_VF_Shuffle 4 W32 is | avx -> vector_shuffle_float_avx 4 x y is+                             | otherwise -> vector_shuffle_floatx4_sse sse4_1 x y is+      MO_VF_Shuffle 2 W64 is | avx -> vector_shuffle_double_avx 2 x y is+                             | otherwise -> vector_shuffle_doublex2_sse x y is+      MO_VF_Shuffle {} -> sorry "Please use -fllvm for wide shuffle instructions"++      MO_VF_Extract l W32   | avx       -> vector_float_extract l W32 x y+                            | otherwise -> vector_float_extract_sse l W32 x y+      MO_VF_Extract l W64               -> vector_float_extract l W64 x y+      MO_VF_Extract {} -> incorrectOperands++      MO_V_Extract 16 W8 | sse4_1 -> vector_int_extract_pextr 16 W8 x y+                         | otherwise -> vector_int8x16_extract_sse2 x y+      MO_V_Extract 8 W16 -> vector_int_extract_pextr 8 W16 x y -- PEXTRW (SSE2)+      MO_V_Extract 4 W32 | sse4_1 -> vector_int_extract_pextr 4 W32 x y+                         | otherwise -> vector_int32x4_extract_sse2 x y+      MO_V_Extract 2 W64 | sse4_1 -> vector_int_extract_pextr 2 W64 x y+                         | otherwise -> vector_int64x2_extract_sse2 x y+      -- SIMD NCG TODO: 256/512-bit vector+      MO_V_Extract {} -> needLlvm mop++      MO_VF_Add l w         | avx       -> vector_float_op_avx VADD l w x y+                            | otherwise -> vector_float_op_sse (\fmt op2 -> ADD fmt op2 . OpReg) l w x y++      MO_VF_Sub l w         | avx       -> vector_float_op_avx VSUB l w x y+                            | otherwise -> vector_float_op_sse (\fmt op2 -> SUB fmt op2 . OpReg) l w x y++      MO_VF_Mul l w         | avx       -> vector_float_op_avx VMUL l w x y+                            | otherwise -> vector_float_op_sse (\fmt op2 -> MUL fmt op2 . OpReg) l w x y++      MO_VF_Quot l w        | avx       -> vector_float_op_avx VDIV l w x y+                            | otherwise -> vector_float_op_sse FDIV l w x y++      MO_VF_Min l w         | avx       -> vector_float_op_avx (VMINMAX Min FloatMinMax) l w x y+                            | otherwise -> vector_float_op_sse (MINMAX Min FloatMinMax) l w x y++      MO_VF_Max l w         | avx       -> vector_float_op_avx (VMINMAX Max FloatMinMax) l w x y+                            | otherwise -> vector_float_op_sse (MINMAX Max FloatMinMax) l w x y++      -- SIMD NCG TODO: 256/512-bit integer vector operations+      MO_V_Shuffle 16 W8 is | not is32Bit -> vector_shuffle_int8x16 sse4_1 x y is+      MO_V_Shuffle 8 W16 is -> vector_shuffle_int16x8 sse4_1 x y is+      MO_V_Shuffle 4 W32 is -> vector_shuffle_int32x4 sse4_1 x y is+      MO_V_Shuffle 2 W64 is -> vector_shuffle_int64x2 sse4_1 x y is+      MO_V_Shuffle {} -> needLlvm mop+      MO_V_Add l w | l * widthInBits w == 128 -> vector_int_op_sse PADD l w x y+                   | otherwise -> needLlvm mop+      MO_V_Sub l w | l * widthInBits w == 128 -> vector_int_op_sse PSUB l w x y+                   | otherwise -> needLlvm mop+      MO_V_Mul 16 W8 -> vector_int8x16_mul_sse2 x y+      MO_V_Mul l@8 w@W16 -> vector_int_op_sse PMULL l w x y -- PMULLW (SSE2)+      MO_V_Mul l@4 w@W32 | sse4_1 -> vector_int_op_sse PMULL l w x y -- PMULLD (SSE4.1)+                         | otherwise -> vector_int32x4_mul_sse2 x y+      MO_V_Mul 2 W64 -> vector_int64x2_mul_sse2 x y+      MO_V_Mul {} -> needLlvm mop++      MO_VU_Min l@16 w@W8+                    -> vector_int_op_sse (MINMAX Min (IntVecMinMax False)) l w x y -- PMINUB (SSE2)+      MO_VU_Min l@8 w@W16+        | sse4_1    -> vector_int_op_sse (MINMAX Min (IntVecMinMax False)) l w x y -- PMINUW (SSE4.1)+        | otherwise -> vector_word_minmax_sse Min l w x y+      MO_VU_Min l@4 w@W32+        | sse4_1    -> vector_int_op_sse (MINMAX Min (IntVecMinMax False)) l w x y -- PMINUD (SSE4.1)+        | otherwise -> vector_word_minmax_sse Min l w x y+      MO_VU_Min l@2 w@W64+        | sse4_2    -> vector_word_minmax_sse Min l w x y -- PCMPGTQ requires SSE4.2+        -- The SSE2 version is implemented as a C call (MO_W64X2_Min)+      MO_VU_Min {} -> needLlvm mop+      MO_VU_Max l@16 w@W8+                    -> vector_int_op_sse (MINMAX Max (IntVecMinMax False)) l w x y -- PMAXUB (SSE2)+      MO_VU_Max l@8 w@W16+        | sse4_1    -> vector_int_op_sse (MINMAX Max (IntVecMinMax False)) l w x y -- PMAXUW (SSE4.1)+        | otherwise -> vector_word_minmax_sse Max l w x y+      MO_VU_Max l@4 w@W32+        | sse4_1    -> vector_int_op_sse (MINMAX Max (IntVecMinMax False)) l w x y -- PMAXUD (SSE4.1)+        | otherwise -> vector_word_minmax_sse Max l w x y+      MO_VU_Max l@2 w@W64+        | sse4_2    -> vector_word_minmax_sse Max l w x y -- PCMPGTQ requires SSE4.2+        -- The SSE2 version is implemented as a C call (MO_W64X2_Max)+      MO_VU_Max {} -> needLlvm mop+      MO_VS_Min l@16 w@W8+        | sse4_1    -> vector_int_op_sse (MINMAX Min (IntVecMinMax True)) l w x y -- PMINSB (SSE4.1)+        | otherwise -> vector_int_minmax_sse Min l w x y+      MO_VS_Min l@8 w@W16+                    -> vector_int_op_sse (MINMAX Min (IntVecMinMax True)) l w x y -- PMINSW (SSE2)+      MO_VS_Min l@4 w@W32+        | sse4_1    -> vector_int_op_sse (MINMAX Min (IntVecMinMax True)) l w x y -- PMINSD (SSE4.1)+        | otherwise -> vector_int_minmax_sse Min l w x y+      MO_VS_Min l@2 w@W64+        | sse4_2    -> vector_int_minmax_sse Min l w x y -- PCMPGTQ requires SSE4.2+        -- The SSE2 version is implemented as a C call (MO_I64X2_Min)+      MO_VS_Min {} -> needLlvm mop+      MO_VS_Max l@16 w@W8+        | sse4_1    -> vector_int_op_sse (MINMAX Max (IntVecMinMax True)) l w x y -- PMAXSB (SSE4.1)+        | otherwise -> vector_int_minmax_sse Max l w x y+      MO_VS_Max l@8 w@W16+                    -> vector_int_op_sse (MINMAX Max (IntVecMinMax True)) l w x y -- PMAXSW (SSE2)+      MO_VS_Max l@4 w@W32+        | sse4_1    -> vector_int_op_sse (MINMAX Max (IntVecMinMax True)) l w x y -- PMAXSD (SSE4.1)+        | otherwise -> vector_int_minmax_sse Max l w x y+      MO_VS_Max l@2 w@W64+        | sse4_2    -> vector_int_minmax_sse Max l w x y -- PCMPGTQ requires SSE4.2+        -- The SSE2 version is implemented as a C call (MO_I64X2_Max)+      MO_VS_Max {} -> needLlvm mop++      -- Unary MachOps+      MO_S_Neg {} -> incorrectOperands+      MO_F_Neg {} -> incorrectOperands+      MO_Not {} -> incorrectOperands+      MO_SF_Round {} -> incorrectOperands+      MO_FS_Truncate {} -> incorrectOperands+      MO_SS_Conv {} -> incorrectOperands+      MO_XX_Conv {} -> incorrectOperands+      MO_FF_Conv {} -> incorrectOperands+      MO_UU_Conv {} -> incorrectOperands+      MO_WF_Bitcast {} -> incorrectOperands+      MO_FW_Bitcast  {} -> incorrectOperands+      MO_RelaxedRead {} -> incorrectOperands+      MO_AlignmentCheck {} -> incorrectOperands+      MO_VS_Neg {} -> incorrectOperands+      MO_VF_Neg {} -> incorrectOperands+      MO_V_Broadcast {} -> incorrectOperands+      MO_VF_Broadcast {} -> incorrectOperands++      -- Ternary MachOps+      MO_FMA {} -> incorrectOperands+      MO_V_Insert {} -> incorrectOperands+      MO_VF_Insert {} -> incorrectOperands++  where+    --------------------+    triv_op width instr = trivialCode width op (Just op) x y+                        where op   = instr (intFormat width)++    -- Special case for IMUL for bytes, since the result of IMULB will be in+    -- %ax, the split to %dx/%edx/%rdx and %ax/%eax/%rax happens only for wider+    -- values.+    imulW8 :: CmmExpr -> CmmExpr -> NatM Register+    imulW8 arg_a arg_b = do+        (a_reg, a_code) <- getNonClobberedReg arg_a+        b_code <- getAnyReg arg_b++        let code = a_code `appOL` b_code eax `appOL`+                   toOL [ IMUL2 format (OpReg a_reg) ]+            format = intFormat W8++        return (Fixed format eax code)++    imulMayOflo :: Width -> CmmExpr -> CmmExpr -> NatM Register+    imulMayOflo W8 a b = do+         -- The general case (W16, W32, W64) doesn't work for W8 as its+         -- multiplication doesn't use two registers.+         --+         -- The plan is:+         -- 1. truncate and sign-extend a and b to 8bit width+         -- 2. multiply a' = a * b in 32bit width+         -- 3. copy and sign-extend 8bit from a' to c+         -- 4. compare a' and c: they are equal if there was no overflow+         (a_reg, a_code) <- getNonClobberedReg a+         (b_reg, b_code) <- getNonClobberedReg b+         let+             code = a_code `appOL` b_code `appOL`+                        toOL [+                           MOVSxL II8 (OpReg a_reg) (OpReg a_reg),+                           MOVSxL II8 (OpReg b_reg) (OpReg b_reg),+                           IMUL II32 (OpReg b_reg) (OpReg a_reg),+                           MOVSxL II8 (OpReg a_reg) (OpReg eax),+                           CMP II16 (OpReg a_reg) (OpReg eax),+                           SETCC NE (OpReg eax)+                        ]+         return (Fixed II8 eax code)+    imulMayOflo rep a b = do+         (a_reg, a_code) <- getNonClobberedReg a+         b_code <- getAnyReg b+         let+             shift_amt  = case rep of+                           W16 -> 15+                           W32 -> 31+                           W64 -> 63+                           w -> panic ("shift_amt: " ++ show w)++             format = intFormat rep+             code = a_code `appOL` b_code eax `appOL`+                        toOL [+                           IMUL2 format (OpReg a_reg),   -- result in %edx:%eax+                           SAR format (OpImm (ImmInt shift_amt)) (OpReg eax),+                                -- sign extend lower part+                           SUB format (OpReg edx) (OpReg eax)+                                -- compare against upper+                           -- eax==0 if high part == sign extended low part+                        ]+         return (Fixed format eax code)++    --------------------+    shift_code :: Width+               -> (Format -> Operand -> Operand -> Instr)+               -> CmmExpr+               -> CmmExpr+               -> NatM Register++    {- Case1: shift length as immediate -}+    shift_code width instr x (CmmLit lit)+      -- Handle the case of a shift larger than the width of the shifted value.+      -- This is necessary since x86 applies a mask of 0x1f to the shift+      -- amount, meaning that, e.g., `shr 47, $eax` will actually shift by+      -- `47 & 0x1f == 15`. See #20626.+      | CmmInt n _ <- lit+      , n >= fromIntegral (widthInBits width)+      = getRegister $ CmmLit $ CmmInt 0 width++      | otherwise = do+          x_code <- getAnyReg x+          let+               format = intFormat width+               code dst+                  = x_code dst `snocOL`+                    instr format (OpImm (litToImm lit)) (OpReg dst)+          return (Any format code)++    {- Case2: shift length is complex (non-immediate)+      * y must go in %ecx.+      * we cannot do y first *and* put its result in %ecx, because+        %ecx might be clobbered by x.+      * if we do y second, then x cannot be+        in a clobbered reg.  Also, we cannot clobber x's reg+        with the instruction itself.+      * so we can either:+        - do y first, put its result in a fresh tmp, then copy it to %ecx later+        - do y second and put its result into %ecx.  x gets placed in a fresh+          tmp.  This is likely to be better, because the reg alloc can+          eliminate this reg->reg move here (it won't eliminate the other one,+          because the move is into the fixed %ecx).+      * in the case of C calls the use of ecx here can interfere with arguments.+        We avoid this with the hack described in Note [Evaluate C-call+        arguments before placing in destination registers]+    -}+    shift_code width instr x y{-amount-} = do+        x_code <- getAnyReg x+        let format = intFormat width+        tmp <- getNewRegNat format+        y_code <- getAnyReg y+        let+           code = x_code tmp `appOL`+                  y_code ecx `snocOL`+                  instr format (OpReg ecx) (OpReg tmp)+        return (Fixed format tmp code)++    --------------------+    add_code :: Width -> CmmExpr -> CmmExpr -> NatM Register+    add_code rep x (CmmLit (CmmInt y _))+        | is32BitInteger y+        , rep /= W8 -- LEA doesn't support byte size (#18614)+        = add_int rep x y+    add_code rep x y = trivialCode rep (ADD format) (Just (ADD format)) x y+      where format = intFormat rep+    -- TODO: There are other interesting patterns we want to replace+    --     with a LEA, e.g. `(x + offset) + (y << shift)`.++    --------------------+    sub_code :: Width -> CmmExpr -> CmmExpr -> NatM Register+    sub_code rep x (CmmLit (CmmInt y _))+        | is32BitInteger (-y)+        , rep /= W8 -- LEA doesn't support byte size (#18614)+        = add_int rep x (-y)+    sub_code rep x y = trivialCode rep (SUB (intFormat rep)) Nothing x y++    -- our three-operand add instruction:+    add_int width x y = do+        (x_reg, x_code) <- getSomeReg x+        let+            format = intFormat width+            imm = ImmInt (fromInteger y)+            code dst+               = x_code `snocOL`+                 LEA format+                        (OpAddr (AddrBaseIndex (EABaseReg x_reg) EAIndexNone imm))+                        (OpReg dst)+        --+        return (Any format code)++    ----------------------++    -- See Note [DIV/IDIV for bytes]+    div_code W8 signed quotient x y = do+        let widen | signed    = MO_SS_Conv W8 W16+                  | otherwise = MO_UU_Conv W8 W16+        div_code+            W16+            signed+            quotient+            (CmmMachOp widen [x])+            (CmmMachOp widen [y])++    div_code width signed quotient x y = do+           (y_op, y_code) <- getRegOrMem y -- cannot be clobbered+           x_code <- getAnyReg x+           let+             format = intFormat width+             widen | signed    = CLTD format+                   | otherwise = XOR format (OpReg edx) (OpReg edx)++             instr | signed    = IDIV+                   | otherwise = DIV++             code = y_code `appOL`+                    x_code eax `appOL`+                    toOL [widen, instr format y_op]++             result | quotient  = eax+                    | otherwise = edx++           return (Fixed format result code)++    -----------------------+    -- Vector operations---+    vector_float_op_avx :: (Format -> Operand -> Reg -> Reg -> Instr)+                        -> Length+                        -> Width+                        -> CmmExpr+                        -> CmmExpr+                        -> NatM Register+    vector_float_op_avx instr l w = vector_op_avx_reg (\fmt -> instr fmt . OpReg) format+      where format = case w of+                       W32 -> VecFormat l FmtFloat+                       W64 -> VecFormat l FmtDouble+                       _ -> pprPanic "Floating-point AVX vector operation not supported at this width"+                             (text "width:" <+> ppr w)++    vector_op_avx_reg :: (Format -> Reg -> Reg -> Reg -> Instr)+                      -> Format+                      -> CmmExpr+                      -> CmmExpr+                      -> NatM Register+    vector_op_avx_reg instr format expr1 expr2 = do+      (reg1, exp1) <- getSomeReg expr1+      (reg2, exp2) <- getSomeReg expr2+      let -- opcode src2 src1 dst <==> dst = src1 `opcode` src2+          code dst = exp1 `appOL` exp2 `snocOL`+                     (instr format reg2 reg1 dst)+      return (Any format code)++    vector_float_op_sse :: (Format -> Operand -> Reg -> Instr)+                        -> Length -> Width -> CmmExpr -> CmmExpr -> NatM Register+    vector_float_op_sse instr l w = vector_op_sse instr format+      where format = case w of+                       W32 -> VecFormat l FmtFloat+                       W64 -> VecFormat l FmtDouble+                       _ -> pprPanic "Floating-point SSE vector operation not supported at this width"+                             (text "width:" <+> ppr w)++    vector_int_op_sse :: (Format -> Operand -> Reg -> Instr)+                      -> Length -> Width -> CmmExpr -> CmmExpr -> NatM Register+    vector_int_op_sse instr l w = vector_op_sse instr format+      where format = case w of+                       W8 -> VecFormat l FmtInt8+                       W16 -> VecFormat l FmtInt16+                       W32 -> VecFormat l FmtInt32+                       W64 -> VecFormat l FmtInt64+                       _ -> pprPanic "Integer SSE vector operation not supported at this width"+                              (text "width:" <+> ppr w)++    -- This function is similar to genTrivialCode, but re-using it would require+    -- handling alignment correctly: SSE vector instructions typically require 16-byte+    -- alignment for their memory operand (this restriction is relaxed with VEX-encoded+    -- instructions).+    -- For now, we always load the value into a register and avoid the alignment issue.+    vector_op_sse :: (Format -> Operand -> Reg -> Instr)+                  -> Format+                  -> CmmExpr+                  -> CmmExpr+                  -> NatM Register+    vector_op_sse instr = vector_op_sse_reg (\fmt -> instr fmt . OpReg)++    vector_op_sse_reg :: (Format -> Reg -> Reg -> Instr)+                      -> Format+                      -> CmmExpr+                      -> CmmExpr+                      -> NatM Register+    vector_op_sse_reg instr format expr1 expr2 = do+      config <- getConfig+      exp1_code <- getAnyReg expr1+      (reg2, exp2_code) <- getSomeReg expr2 -- vector registers are never clobbered by an instruction+      tmp <- getNewRegNat format+      let code dst+            -- opcode src2 src1 <==> src1 = src1 `opcode` src2+            | dst == reg2 = exp2_code `snocOL`+                            movInstr config format (OpReg reg2) (OpReg tmp) `appOL` -- MOVU or MOVDQU+                            exp1_code dst `snocOL`+                            instr format tmp dst+            | otherwise = exp2_code `appOL`+                          exp1_code dst `snocOL`+                          instr format reg2 dst+      return (Any format code)+    --------------------+    vector_float_extract :: Length+                         -> Width+                         -> CmmExpr+                         -> CmmExpr+                         -> NatM Register+    vector_float_extract l W32 expr (CmmLit lit) = do+      (r, exp) <- getSomeReg expr+      let format   = VecFormat l FmtFloat+          imm      = litToImm lit+          code dst+            = case lit of+                CmmInt 0 _ -> exp `snocOL` (MOV FF32 (OpReg r) (OpReg dst))+                CmmInt _ _ -> exp `snocOL` (VPSHUFD format imm (OpReg r) dst)+                _          -> pprPanic "Unsupported AVX floating-point vector extract offset" (ppr lit)+      return (Any FF32 code)+    vector_float_extract _ W64 expr (CmmLit lit) = do+      (r, exp) <- getSomeReg expr+      let code dst+            = case lit of+                CmmInt 0 _ -> exp `snocOL`+                              (MOV FF64 (OpReg r) (OpReg dst))+                CmmInt 1 _ -> exp `snocOL`+                              (MOVHLPS FF64 r dst)+                _          -> pprPanic "Unsupported AVX floating-point vector extract offset" (ppr lit)+      return (Any FF64 code)+    vector_float_extract _ w c e =+      pprPanic "Unsupported AVX floating-point vector extract" (pdoc platform c $$ pdoc platform e $$ ppr w)+    -----------------------++    vector_float_extract_sse :: Length+                             -> Width+                             -> CmmExpr+                             -> CmmExpr+                             -> NatM Register+    vector_float_extract_sse l W32 expr (CmmLit lit)+      = do+      (r,exp) <- getSomeReg expr+      let format   = VecFormat l FmtFloat+          imm      = litToImm lit+          code dst+            = case lit of+                CmmInt 0 _ -> exp `snocOL` (MOVU format (OpReg r) (OpReg dst))+                CmmInt _ _ -> exp `snocOL` (PSHUFD format imm (OpReg r) dst)+                _          -> pprPanic "Unsupported SSE floating-point vector extract offset" (ppr lit)+      return (Any FF32 code)+    vector_float_extract_sse _ w c e+      = pprPanic "Unsupported SSE floating-point vector extract" (pdoc platform c $$ pdoc platform e $$ ppr w)+    -----------------------++    -- PEXTRW ("to GPR" variant) is an SSE2 instruction,+    -- whereas PEXTR{B,D,Q} and PEXTRW ("to memory" variant) require SSE4.1.+    vector_int_extract_pextr :: Length+                             -> Width+                             -> CmmExpr+                             -> CmmExpr+                             -> NatM Register+    vector_int_extract_pextr l w expr (CmmLit (CmmInt i _))+      | 0 <= i, i < toInteger l+      = do+      (r, exp) <- getSomeReg expr -- vector registers are never clobbered by an instruction+      let (scalarFormat, vectorFormat) = case w of+            W8 -> (II32, VecFormat l FmtInt8)+            W16 -> (II32, VecFormat l FmtInt16)+            W32 -> (II32, VecFormat l FmtInt32)+            W64 -> (II64, VecFormat l FmtInt64)+            _ -> sorry "Unsupported vector format"+          code dst = exp `snocOL`+                     (PEXTR scalarFormat vectorFormat (ImmInteger i) r (OpReg dst))+      return (Any scalarFormat code)+    vector_int_extract_pextr _ _ _ i+      = pprPanic "Unsupported offset" (pdoc platform i)++    vector_int8x16_extract_sse2 :: CmmExpr+                                -> CmmExpr+                                -> NatM Register+    vector_int8x16_extract_sse2 expr (CmmLit (CmmInt i _))+      | 0 <= i, i < 16+      = do+      (r, exp) <- getSomeReg expr+      let code dst =+            case i `quotRem` 2 of+              (j, 0) -> exp `snocOL`+                        (PEXTR II32 (VecFormat 8 FmtInt16) (ImmInteger j) r (OpReg dst)) -- PEXTRW+              (j, _) -> exp `snocOL`+                        (PEXTR II32 (VecFormat 8 FmtInt16) (ImmInteger j) r (OpReg dst)) `snocOL` -- PEXTRW+                        (SHR II32 (OpImm (ImmInt 8)) (OpReg dst))+      return (Any II8 code)+    vector_int8x16_extract_sse2 _ offset+      = pprPanic "Unsupported offset" (pdoc platform offset)++    vector_int32x4_extract_sse2 :: CmmExpr+                                -> CmmExpr+                                -> NatM Register+    vector_int32x4_extract_sse2 expr (CmmLit (CmmInt i _))+      | 0 <= i, i < 4+      = do+      (r, exp) <- getSomeReg expr+      let fmt = VecFormat 4 FmtInt32+      tmp <- getNewRegNat fmt+      let code dst =+            case i of+              0 -> exp `snocOL`+                   (MOVD fmt II32 (OpReg r) (OpReg dst))+              1 -> exp `snocOL`+                   (PSHUFD fmt (ImmInt 0b01_01_01_01) (OpReg r) tmp) `snocOL` -- tmp <- (r[1],r[1],r[1],r[1])+                   (MOVD fmt II32 (OpReg tmp) (OpReg dst))+              2 -> exp `snocOL`+                   (PSHUFD fmt (ImmInt 0b11_10_11_10) (OpReg r) tmp) `snocOL` -- tmp <- (r[2],r[3],r[2],r[3])+                   (MOVD fmt II32 (OpReg tmp) (OpReg dst))+              _ -> exp `snocOL`+                   (PSHUFD fmt (ImmInt 0b11_11_11_11) (OpReg r) tmp) `snocOL` -- tmp <- (r[3],r[3],r[3],r[3])+                   (MOVD fmt II32 (OpReg tmp) (OpReg dst))+      return (Any II32 code)+    vector_int32x4_extract_sse2 _ offset+      = pprPanic "Unsupported offset" (pdoc platform offset)++    vector_int64x2_extract_sse2 :: CmmExpr+                                -> CmmExpr+                                -> NatM Register+    vector_int64x2_extract_sse2 expr (CmmLit lit)+      = do+      (r, exp) <- getSomeReg expr+      let fmt = VecFormat 2 FmtInt64+      tmp <- getNewRegNat fmt+      let code dst =+            case lit of+              CmmInt 0 _ -> exp `snocOL`+                            (MOVD fmt II64 (OpReg r) (OpReg dst))+              CmmInt 1 _ -> exp `snocOL`+                            (MOVHLPS FF64 r tmp) `snocOL`+                            (MOVD fmt II64 (OpReg tmp) (OpReg dst))+              _          -> panic "Error in offset while unpacking"+      return (Any II64 code)+    vector_int64x2_extract_sse2 _ offset+      = pprPanic "Unsupported offset" (pdoc platform offset)++    vector_int8x16_mul_sse2 :: CmmExpr -> CmmExpr -> NatM Register+    vector_int8x16_mul_sse2 expr1 expr2 = do+      -- use two SSE2 PMULLW (low 16 bits of int16 multiplication) operations+      (reg1, exp1) <- getSomeReg expr1+      (reg2, exp2) <- getSomeReg expr2+      let format = VecFormat 16 FmtInt8+          format16 = VecFormat 8 FmtInt16 -- for PMULLW+      tmp1lo <- getNewRegNat format+      tmp1hi <- getNewRegNat format+      tmp2hi <- getNewRegNat format+      tmp2lo <- getNewRegNat format+      (maskReg, maskCode) <- getSomeReg (CmmLit $ CmmVec $ replicate 8 (CmmInt 0xff W16)) -- (0xff,0,0xff,0,...,0xff,0) :: Int8X16+      let code = exp1 `appOL` exp2 `appOL` maskCode `snocOL`+                 (MOVDQU format (OpReg reg1) (OpReg tmp1lo)) `snocOL` -- tmp1lo <- reg1+                 (MOVDQU format (OpReg reg2) (OpReg tmp2lo)) `snocOL` -- tmp2lo <- reg2+                 (PUNPCKLBW format (OpReg reg1) tmp1lo) `snocOL`      -- tmp1lo <- (tmp1lo[0],reg1[0],tmp1lo[1],reg1[1],...,tmp1lo[7],reg1[7]); The first operand does not really matter+                 (PUNPCKLBW format (OpReg reg2) tmp2lo) `snocOL`      -- tmp2lo <- (tmp2lo[0],reg2[0],tmp2lo[1],reg2[1],...,tmp2lo[7],reg2[7]); The first operand does not really matter+                 (MOVDQU format (OpReg reg1) (OpReg tmp1hi)) `snocOL` -- tmp1hi <- reg1+                 (MOVDQU format (OpReg reg2) (OpReg tmp2hi)) `snocOL` -- tmp2hi <- reg2+                 (PUNPCKHBW format (OpReg reg1) tmp1hi) `snocOL`      -- tmp1hi <- (tmp1hi[8],reg1[8],tmp1hi[9],reg1[9],...,tmp1hi[15],reg1[15]); The first operand does not really matter+                 (PMULL format16 (OpReg tmp2lo) tmp1lo) `snocOL`      -- PMULLW; tmp1lo <- (tmp1lo[0]*tmp2lo[0],*,tmp1lo[2]*tmp2lo[2],*,...,tmp1lo[14]*tmp2lo[14],*)+                 (PUNPCKHBW format (OpReg reg2) tmp2hi) `snocOL`      -- tmp2hi <- (tmp2hi[8],reg2[8],tmp2hi[9],reg2[9],...,tmp2hi[15],reg2[15]); The first operand does not really matter+                 (PMULL format16 (OpReg tmp2hi) tmp1hi) `snocOL`      -- PMULLW; tmp1hi <- (tmp1hi[0]*tmp2hi[0],*,tmp1hi[2]*tmp2hi[2],*,...,tmp1hi[14]*tmp2hi[14],*)+                 (PAND format (OpReg maskReg) tmp1lo) `snocOL`        -- tmp1lo <- (tmp1lo[0],0,tmp1lo[2],0,...,tmp1lo[14],0)+                 (PAND format (OpReg maskReg) tmp1hi) `snocOL`        -- tmp1hi <- (tmp1hi[0],0,tmp1hi[2],0,...,tmp1hi[14],0)+                 (PACKUSWB format (OpReg tmp1hi) tmp1lo)              -- tmp1lo <- (tmp1lo[0],tmp1lo[2],...,tmp1lo[14],tmp1hi[0],tmp1hi[2],...tmp1hi[14])+      return (Fixed format tmp1lo code)++    vector_int32x4_mul_sse2 :: CmmExpr -> CmmExpr -> NatM Register+    vector_int32x4_mul_sse2 expr1 expr2 = do+      -- use two SSE2 PMULUDQ (int32 x int32 -> int64 multiplication) operations+      (reg1, exp1) <- getSomeReg expr1+      (reg2, exp2) <- getSomeReg expr2+      let format = VecFormat 4 FmtInt32+      tmpEven <- getNewRegNat format+      tmpOdd1 <- getNewRegNat format+      tmpOdd2 <- getNewRegNat format+      let code dst = exp1 `appOL` exp2 `snocOL`+                     (MOVDQU format (OpReg reg1) (OpReg tmpEven)) `snocOL`                   -- tmpEven <- reg1+                     (PSHUFD format (ImmInt 0b11_11_01_01) (OpReg reg1) tmpOdd1) `snocOL`    -- tmpOdd1 <- (reg1[1],reg1[1],reg1[3],reg1[3])+                     (PMULUDQ format (OpReg reg2) tmpEven) `snocOL`                          -- tmpEven <- (tmpEven[0]*reg2[0],*,tmpEven[2]*reg2[2],*)+                     (PSHUFD format (ImmInt 0b11_11_01_01) (OpReg reg2) tmpOdd2) `snocOL`    -- tmpOdd2 <- (reg2[1],reg2[1],reg2[3],reg2[3])+                     (PMULUDQ format (OpReg tmpOdd2) tmpOdd1) `snocOL`                       -- tmpOdd1 <- (tmpOdd1[0]*tmpOdd2[0],*,tmpOdd1[2]*tmpOdd2[2],*)+                     (PSHUFD format (ImmInt 0b00_00_10_00) (OpReg tmpEven) dst) `snocOL`     -- dst <- (tmpEven[0],tmpEven[2],tmpEven[0],tmpEven[0])+                     (PSHUFD format (ImmInt 0b00_00_10_00) (OpReg tmpOdd1) tmpOdd1) `snocOL` -- tmpOdd1 <- (tmpOdd1[0],tmpOdd1[2],tmpOdd1[0],tmpOdd1[0])+                     (PUNPCKLDQ format (OpReg tmpOdd1) dst)                                  -- dst <- (dst[0],tmpOdd1[0],dst[1],tmpOdd1[1])+      return (Any format code)++    -- TODO: We could use `VPMULLQ` if AVX-512 or AVX10.1 is available.+    vector_int64x2_mul_sse2 :: CmmExpr -> CmmExpr -> NatM Register+    vector_int64x2_mul_sse2 expr1 expr2 = do+      -- implement 64 bit multiplication using 32-bit PMULUDQ multiplication instructions+      -- (lo1 + shiftL hi1 32) * (lo2 + shiftL hi2 32) = lo1 * lo2 + shiftL (lo1 * hi2) 32 + shiftL (lo2 * hi1) 32+      exp1 <- getAnyReg expr1+      exp2 <- getAnyReg expr2+      let format = VecFormat 2 FmtInt64+      reg1 <- getNewRegNat format+      reg2 <- getNewRegNat format+      tmp1Hi <- getNewRegNat format+      tmp2Hi <- getNewRegNat format+      let code dst = exp1 reg1 `appOL` exp2 reg2 `snocOL`+                     (MOVDQU format (OpReg reg1) (OpReg dst)) `snocOL`    -- dst <- reg1+                     (MOVDQU format (OpReg reg1) (OpReg tmp1Hi)) `snocOL` -- tmp1Hi <- reg1+                     (MOVDQU format (OpReg reg2) (OpReg tmp2Hi)) `snocOL` -- tmp2Hi <- reg2+                     (PSRL format (OpImm (ImmInt 32)) tmp1Hi) `snocOL`    -- PSRLQ (logical shift); tmp1Hi <- (tmp1Hi[0] >> 32, tmp1Hi[1] >> 32)+                     (PMULUDQ format (OpReg reg2) dst) `snocOL`           -- dst <- ((dst as Word32X4)[0] * (reg2 as Word32X4)[0] as Word64, (dst as Word32X4)[2] * (reg2 as Word32X4)[2] as Word64)+                     (PSRL format (OpImm (ImmInt 32)) tmp2Hi) `snocOL`    -- PSRLQ (logical shift); tmp2Hi <- (tmp2Hi[0] >> 32, tmp2Hi[1] >> 32)+                     (PMULUDQ format (OpReg reg2) tmp1Hi) `snocOL`        -- tmp1Hi <- ((tmp1Hi as Word32X4)[0] * (reg2 as Word32X4)[0] as Word64, (tmp1Hi as Word32X4)[2] * (reg2 as Word32X4)[2] as Word64)+                     (PMULUDQ format (OpReg reg1) tmp2Hi) `snocOL`        -- tmp2Hi <- ((tmp2Hi as Word32X4)[0] * (reg1 as Word32X4)[0] as Word64, (tmp2Hi as Word32X4)[2] * (reg1 as Word32X4)[2] as Word64)+                     (PADD format (OpReg tmp2Hi) tmp1Hi) `snocOL`         -- PADDQ; tmp1Hi <- (tmp1Hi[0] + tmp2Hi[0], tmp1Hi[1] + tmp2Hi[1])+                     (PSLL format (OpImm (ImmInt 32)) tmp1Hi) `snocOL`    -- PSLLQ; tmp1Hi <- (tmp1Hi[0] << 32, tmp1Hi[1] << 32)+                     (PADD format (OpReg tmp1Hi) dst)                     -- PADDQ; dst <- (dst[0] + tmp1Hi[0], dst[1] + tmp1Hi[1])+      return (Any format code)++    vector_int_minmax_sse :: MinOrMax -> Length -> Width -> CmmExpr -> CmmExpr -> NatM Register+    vector_int_minmax_sse minmax l w expr1 expr2 = do+      -- SSE2 fallback: compute a mask of 0s/1s using PCMPGT, then max a b = (mask & a) | (not mask & b)+      exp1 <- getAnyReg expr1+      exp2 <- getAnyReg expr2+      let format = case w of+            W8 -> VecFormat l FmtInt8+            W16 -> VecFormat l FmtInt16+            W32 -> VecFormat l FmtInt32+            W64 -> VecFormat l FmtInt64+            _  -> panic "Unsupported width"+      reg1 <- getNewRegNat format+      reg2 <- getNewRegNat format+      tmp <- getNewRegNat format+      let codeMin dst = exp1 reg1 `appOL` exp2 reg2 `snocOL`+                        (MOVDQU format (OpReg reg1) (OpReg dst)) `snocOL` -- dst <- reg1+                        (MOVDQU format (OpReg reg2) (OpReg tmp)) `snocOL` -- tmp <- reg2+                        (PCMPGT format (OpReg reg2) dst) `snocOL`         -- dst <- if dst > reg2 then True(-1) else False(0)+                        (PAND format (OpReg dst) tmp) `snocOL`            -- tmp <- tmp & dst; if dst then tmp else 0+                        (PANDN format (OpReg reg1) dst) `snocOL`          -- dst <- ~dst & reg1; if dst then 0 else reg1+                        (POR format (OpReg tmp) dst)                      -- dst <- tmp | dst+          codeMax dst = exp1 reg1 `appOL` exp2 reg2 `snocOL`+                        (MOVDQU format (OpReg reg1) (OpReg dst)) `snocOL` -- dst <- reg1+                        (MOVDQU format (OpReg reg1) (OpReg tmp)) `snocOL` -- tmp <- reg1+                        (PCMPGT format (OpReg reg2) dst) `snocOL`         -- dst <- if dst > reg2 then True(-1) else False(0)+                        (PAND format (OpReg dst) tmp) `snocOL`            -- tmp <- tmp & dst; if dst then tmp else 0+                        (PANDN format (OpReg reg2) dst) `snocOL`          -- dst <- ~dst & reg2; if dst then 0 else reg2+                        (POR format (OpReg tmp) dst)                      -- dst <- tmp | dst+      return $ case minmax of+        Min -> Any format codeMin+        Max -> Any format codeMax++    vector_word_minmax_sse :: MinOrMax -> Length -> Width -> CmmExpr -> CmmExpr -> NatM Register+    vector_word_minmax_sse minmax l w expr1 expr2 = do+      -- SSE2 fallback: compute a mask of 0s/1s using PCMPGT, then max a b = (mask & a) | (not mask & b)+      -- We can use PCMPGT to compare unsigned integers by flipping the most significant bit.+      exp1 <- getAnyReg expr1+      exp2 <- getAnyReg expr2+      let (format, sign) = case w of+            W8 -> (VecFormat l FmtInt8, 0x80)+            W16 -> (VecFormat l FmtInt16, 0x8000)+            W32 -> (VecFormat l FmtInt32, 2^(31 :: Int))+            W64 -> (VecFormat l FmtInt64, 2^(63 :: Int))+            _  -> panic "Unsupported width"+      reg1 <- getNewRegNat format+      reg2 <- getNewRegNat format+      tmp1 <- getNewRegNat format+      tmp2 <- getNewRegNat format+      (signReg, signCode) <- getSomeReg (CmmLit $ CmmVec $ replicate l (CmmInt sign w))+      let codeMin dst = exp1 reg1 `appOL` exp2 reg2 `appOL` signCode `snocOL`+                        (MOVDQU format (OpReg reg1) (OpReg dst)) `snocOL`  -- dst <- reg1+                        (MOVDQU format (OpReg reg2) (OpReg tmp1)) `snocOL` -- tmp1 <- reg2+                        (MOVDQU format (OpReg reg2) (OpReg tmp2)) `snocOL` -- tmp2 <- reg2+                        (PXOR format (OpReg signReg) dst) `snocOL`         -- dst <- dst ^ 2^(w-1)+                        (PXOR format (OpReg signReg) tmp1) `snocOL`        -- tmp1 < dst ^ 2^(w-1)+                        (PCMPGT format (OpReg tmp1) dst) `snocOL`          -- dst <- if dst > tmp1 then True(-1) else False(0)+                        (PAND format (OpReg dst) tmp2) `snocOL`            -- tmp2 <- tmp2 & dst; if dst then tmp2 else 0+                        (PANDN format (OpReg reg1) dst) `snocOL`           -- dst <- ~dst & reg1; if dst then 0 else reg1+                        (POR format (OpReg tmp2) dst)                      -- dst <- tmp2 | dst+          codeMax dst = exp1 reg1 `appOL` exp2 reg2 `appOL` signCode `snocOL`+                        (MOVDQU format (OpReg reg1) (OpReg dst)) `snocOL`  -- dst <- reg1+                        (MOVDQU format (OpReg reg2) (OpReg tmp1)) `snocOL` -- tmp1 <- reg2+                        (MOVDQU format (OpReg reg1) (OpReg tmp2)) `snocOL` -- tmp2 <- reg1+                        (PXOR format (OpReg signReg) dst) `snocOL`         -- dst <- dst ^ 2^(w-1)+                        (PXOR format (OpReg signReg) tmp1) `snocOL`        -- tmp1 <- tmp1 ^ 2^(w-1)+                        (PCMPGT format (OpReg tmp1) dst) `snocOL`          -- dst <- if dst > tmp1 then True(-1) else False(0)+                        (PAND format (OpReg dst) tmp2) `snocOL`            -- tmp2 <- tmp2 & dst; if dst then tmp2 else 0+                        (PANDN format (OpReg reg2) dst) `snocOL`           -- dst <- ~dst & reg2; if dst then 0 else reg2+                        (POR format (OpReg tmp2) dst)                      -- dst <- tmp2 | dst+      return $ case minmax of+        Min -> Any format codeMin+        Max -> Any format codeMax++    vector_shuffle_floatx4_sse :: Bool -> CmmExpr -> CmmExpr -> [Int] -> NatM Register+    vector_shuffle_floatx4_sse sse4_1 v1 v2 is+      | length is == 4, all (\i -> 0 <= i && i < 8) is = do+        let fmt = VecFormat 4 FmtFloat++            -- A helper function to shuffle a vector `r` in-place using (dst,src) pairs+            -- (r[d0],r[d1],...) <- (r[s0],r[s1],...)+            inplaceShuffle pairs r = do+              let mask = foldl' (\acc (dst,src) -> acc .|. (src `shiftL` (2 * dst))) 0 pairs+              case mask of+                0b11_10_01_00 -> nilOL -- trivial+                0b01_00_01_00 -> unitOL (MOVLHPS fmt r r)+                0b11_10_11_10 -> unitOL (MOVHLPS fmt r r)+                0b01_01_00_00 -> unitOL (UNPCKL fmt (OpReg r) r)+                0b11_11_10_10 -> unitOL (UNPCKH fmt (OpReg r) r)+                _ -> unitOL (SHUF fmt (ImmInt mask) (OpReg r) r)++            -- All elements are from one source vector+            oneSource p0 p1 p2 p3 v = do+              exp <- getAnyReg v+              let code dst = exp dst `appOL`+                             inplaceShuffle [p0,p1,p2,p3] dst+              return $ Any fmt code++            -- Two elements from one vector, other two from the other vector+            twoAndTwo (0,0) (1,1) (2,0) (3,1) v1 v2 = vector_op_sse_reg MOVLHPS fmt v1 v2+            twoAndTwo (2,0) (3,1) (0,0) (1,1) v1 v2 = vector_op_sse_reg MOVLHPS fmt v2 v1+            twoAndTwo (2,2) (3,3) (0,2) (1,3) v1 v2 = vector_op_sse_reg MOVHLPS fmt v1 v2+            twoAndTwo (0,2) (1,3) (2,2) (3,3) v1 v2 = vector_op_sse_reg MOVHLPS fmt v2 v1+            twoAndTwo (0,0) (2,1) (1,0) (3,1) v1 v2 = vector_op_sse UNPCKL fmt v1 v2+            twoAndTwo (1,0) (3,1) (0,0) (2,1) v1 v2 = vector_op_sse UNPCKL fmt v2 v1+            twoAndTwo (0,2) (2,3) (1,2) (3,3) v1 v2 = vector_op_sse UNPCKH fmt v1 v2+            twoAndTwo (1,2) (3,3) (0,2) (2,3) v1 v2 = vector_op_sse UNPCKH fmt v2 v1+            twoAndTwo p0 p1 q0 q1 v1 v2 =+              if sse4_1 && all (\(dst,src) -> dst == src) [p0,p1,q0,q1] then+                let imm = (1 `shiftL` fst q0) .|. (1 `shiftL` fst q1)+                in vector_op_sse (`BLEND` (ImmInt imm)) fmt v1 v2+              else do+                let imm = snd p0 .|. (snd p1 `shiftL` 2) .|. (snd q0 `shiftL` 4) .|. (snd q1 `shiftL` 6)+                reg <- vector_op_sse (`SHUF` (ImmInt imm)) fmt v1 v2+                exp <- anyReg reg+                let code dst = exp dst `appOL`+                               inplaceShuffle [(fst p0,0),(fst p1,1),(fst q0,2),(fst q1,3)] dst+                return $ Any fmt code++            -- Three elements from one vector, the last one from the other vector+            threeAndOne p0 p1 p2 q0 v1 v2+              | sse4_1 = do -- Use INSERTPS+                exp1 <- getAnyReg v1+                (r2, exp2) <- getSomeReg v2+                let imm2 = (snd q0 `shiftL` 6) .|. (fst q0 `shiftL` 4)+                dst <- getNewRegNat fmt+                let code = exp1 dst `appOL` exp2 `appOL`+                           inplaceShuffle [p0,p1,p2,(fst q0,fst q0)] dst `snocOL`+                           (INSERTPS fmt (ImmInt imm2) (OpReg r2) dst)+                return $ Fixed fmt dst code++              | (_, 0) <- q0, 0 `notElem` [snd p0,snd p1,snd p2] = do -- Use MOVSS+                exp1 <- getAnyReg v1+                (r2, exp2) <- getSomeReg v2+                dst <- getNewRegNat fmt+                let code = exp1 dst `appOL` exp2 `snocOL`+                           (MOV fmt (OpReg r2) (OpReg dst)) `appOL`+                           inplaceShuffle [p0,p1,p2,(fst q0,0)] dst+                return $ Fixed fmt dst code++              | otherwise = do -- Use two or three SHUFPSs+                (r1, exp1) <- getSomeReg v1+                exp2 <- getAnyReg v2+                let makeMask i0 i1 i2 i3 = i0 .|. (i1 `shiftL` 2) .|. (i2 `shiftL` 4) .|. (i3 `shiftL` 6)+                let imm1 = makeMask (snd q0) (snd q0) (snd p0) (snd p0)+                    (imm2, pairs) =+                      if fst q0 == 1 then+                        (makeMask 2 1 (snd p1) (snd p2), [(fst p0,0),(fst q0,1),(fst p1,2),(fst p2,3)])+                        -- dst <- (dst[2],dst[1],r1[snd p1],r1[snd p2]) = (v1[snd p0],v2[snd q0],v1[snd p1],v1[snd p2])+                        -- (dst[fst p0],dst[fst q0],dst[fst p1],dst[fst p2]) <- dst+                      else+                        (makeMask 0 2 (snd p1) (snd p2), [(fst q0,0),(fst p0,1),(fst p1,2),(fst p2,3)])+                        -- dst <- (dst[0],dst[2],r1[snd p1],r1[snd p2]) = (v2[snd q0],v1[snd p0],v1[snd p1],v1[snd p2])+                        -- (dst[fst p0],dst[fst q0],dst[fst p1],dst[fst p2]) <- dst+                dst <- getNewRegNat fmt+                let code = exp1 `appOL` exp2 dst `snocOL`+                           (SHUF fmt (ImmInt imm1) (OpReg r1) dst) `snocOL` -- dst <- (dst[snd q0],dst[snd q0],r1[snd p0],r1[snd p0]) = (v2[snd q0],v2[snd q0],v1[snd p0],v1[snd p0])+                           (SHUF fmt (ImmInt imm2) (OpReg r1) dst) `appOL`+                           inplaceShuffle pairs dst+                return $ Fixed fmt dst code++        -- We partition the list of indices into those that refer to the first vector and those that+        -- refer to the second, and handle each case depending on the number of indices in each group.+        let (from_first, from_second) = partition (\(_dstPos, srcPos) -> srcPos < 4) (zip [0..] is)+        case (from_first, map (\(dst, src) -> (dst, src - 4)) from_second) of+          ([p0,p1,p2,p3], []) -> oneSource p0 p1 p2 p3 v1+          ([], [q0,q1,q2,q3]) -> oneSource q0 q1 q2 q3 v2+          ([p0,p1], [q0,q1]) -> twoAndTwo p0 p1 q0 q1 v1 v2+          ([p0], [q0,q1,q2]) -> threeAndOne q0 q1 q2 p0 v2 v1+          ([p0,p1,p2], [q0]) -> threeAndOne p0 p1 p2 q0 v1 v2+          _ -> pprPanic "vector shuffle: cannot occur" (ppr is)+      | otherwise = pprPanic "vector shuffle: wrong indices" (ppr is)++    -- Shuffle with AVX instructions.+    -- The components above 128 bits are shuffled in the same way as the lower 128 bits.+    -- For example, `l == 8 && is == [0,2,5,7]` would represent `shuffleFloatX8# _ _ (# 0#, 2#, 9#, 11#, 4#, 6#, 13#, 15# #)`.+    vector_shuffle_float_avx :: Length -- Vector length. 4 for XMM, 8 for YMM, 16 for ZMM.+                             -> CmmExpr+                             -> CmmExpr+                             -> [Int] -- 4-element list of indices+                             -> NatM Register+    vector_shuffle_float_avx l v1 v2 is+      | length is == 4, all (\i -> 0 <= i && i < 8) is = do+        let fmt = VecFormat l FmtFloat++            -- A helper function to shuffle a vector using (dst,src) pairs+            -- (dst[d0],dst[d1],...) <- (r[s0],r[s1],...)+            inplaceShuffle pairs r dst = do+              let mask = foldl' (\acc (dst,src) -> acc .|. (src `shiftL` (2 * dst))) 0 pairs+              case mask of+                0b11_10_01_00 | r == dst -> nilOL+                              | otherwise -> unitOL (VMOVU fmt (OpReg r) (OpReg dst)) -- trivial+                0b01_00_01_00 | l == 4 -> unitOL (VMOVLHPS fmt r r dst) -- 128-bit only+                0b11_10_11_10 | l == 4 -> unitOL (VMOVHLPS fmt r r dst) -- 128-bit only+                0b01_01_00_00 -> unitOL (VUNPCKL fmt (OpReg r) r dst)+                0b11_11_10_10 -> unitOL (VUNPCKH fmt (OpReg r) r dst)+                _ -> unitOL (VSHUF fmt (ImmInt mask) (OpReg r) r dst)++            -- All elements are from one source vector+            oneSource p0 p1 p2 p3 v = do+              (r, exp) <- getSomeReg v+              let code dst = exp `appOL`+                             inplaceShuffle [p0,p1,p2,p3] r dst+              return $ Any fmt code++            -- Two elements from one vector, other two from the other vector+            twoAndTwo (0,0) (1,1) (2,0) (3,1) v1 v2 | l == 4 = vector_op_avx_reg VMOVLHPS fmt v1 v2+            twoAndTwo (2,0) (3,1) (0,0) (1,1) v1 v2 | l == 4 = vector_op_avx_reg VMOVLHPS fmt v2 v1+            twoAndTwo (2,2) (3,3) (0,2) (1,3) v1 v2 | l == 4 = vector_op_avx_reg VMOVHLPS fmt v1 v2+            twoAndTwo (0,2) (1,3) (2,2) (3,3) v1 v2 | l == 4 = vector_op_avx_reg VMOVHLPS fmt v2 v1+            twoAndTwo (0,0) (2,1) (1,0) (3,1) v1 v2 = vector_float_op_avx VUNPCKL l W32 v1 v2+            twoAndTwo (1,0) (3,1) (0,0) (2,1) v1 v2 = vector_float_op_avx VUNPCKL l W32 v2 v1+            twoAndTwo (0,2) (2,3) (1,2) (3,3) v1 v2 = vector_float_op_avx VUNPCKH l W32 v1 v2+            twoAndTwo (1,2) (3,3) (0,2) (2,3) v1 v2 = vector_float_op_avx VUNPCKH l W32 v2 v1+            twoAndTwo p0 p1 q0 q1 v1 v2 =+              if l <= 8 && all (\(dst,src) -> dst == src) [p0,p1,q0,q1] then+                -- VBLENDPS does not support ZMM (no EVEX-encoded variant)+                let imm = (1 `shiftL` fst q0) .|. (1 `shiftL` fst q1)+                    imm' = if l == 4 then imm .|. (imm `shiftL` 4) else imm+                in vector_float_op_avx (`VBLEND` (ImmInt imm')) l W32 v1 v2+              else do+                let imm1 = snd p0 .|. (snd p1 `shiftL` 2) .|. (snd q0 `shiftL` 4) .|. (snd q1 `shiftL` 6)+                reg <- vector_float_op_avx (`VSHUF` (ImmInt imm1)) l W32 v1 v2+                exp <- anyReg reg+                let code dst = exp dst `appOL`+                               inplaceShuffle [(fst p0,0),(fst p1,1),(fst q0,2),(fst q1,3)] dst dst+                return $ Any fmt code++            -- Three elements from one vector, the last one from the other vector+            threeAndOne p0 p1 p2 q0 v1 v2+              | l == 4, (_, 0) <- q0, 0 `notElem` [snd p0,snd p1,snd p2] = do -- Use VMOVSS (128-bit only)+                (r1, exp1) <- getSomeReg v1+                (r2, exp2) <- getSomeReg v2+                let code dst = exp1 `appOL` exp2 `snocOL`+                               (VMOV_MERGE fmt r2 r1 dst) `appOL`+                               inplaceShuffle [p0,p1,p2,(fst q0,0)] dst dst+                return $ Any fmt code++              | l == 4 = do -- Use VINSERTPS (128-bit only)+                (r1, exp1) <- getSomeReg v1+                (r2, exp2) <- getSomeReg v2+                let i = case [0, 1, 2, 3] \\ [snd p0, snd p1, snd p2] of+                          i:_ -> i -- We can clobber this position of r1+                          _ -> panic "cannot occur"+                    imm = (snd q0 `shiftL` 6) .|. (i `shiftL` 4)+                    code dst = exp1 `appOL` exp2 `snocOL`+                               (VINSERTPS fmt (ImmInt imm) (OpReg r2) r1 dst) `appOL`+                               inplaceShuffle [p0,p1,p2,(fst q0,i)] dst dst+                return $ Any fmt code++              | otherwise = do -- Use two or three VSHUFPSs+                (r1, exp1) <- getSomeReg v1+                exp2 <- getAnyReg v2+                let makeMask i0 i1 i2 i3 = i0 .|. (i1 `shiftL` 2) .|. (i2 `shiftL` 4) .|. (i3 `shiftL` 6)+                let imm1 = makeMask (snd q0) (snd q0) (snd p0) (snd p0)+                    (imm2, pairs) =+                      if fst q0 == 1 then+                        (makeMask 2 1 (snd p1) (snd p2), [(fst p0,0),(fst q0,1),(fst p1,2),(fst p2,3)])+                        -- dst <- (dst[2],dst[1],r1[snd p1],r1[snd p2]) = (v1[snd p0],v2[snd q0],v1[snd p1],v1[snd p2])+                        -- (dst[fst p0],dst[fst q0],dst[fst p1],dst[fst p2]) <- dst+                      else+                        (makeMask 0 2 (snd p1) (snd p2), [(fst q0,0),(fst p0,1),(fst p1,2),(fst p2,3)])+                        -- dst <- (dst[0],dst[2],r1[snd p1],r1[snd p2]) = (v2[snd q0],v1[snd p0],v1[snd p1],v1[snd p2])+                        -- (dst[fst p0],dst[fst q0],dst[fst p1],dst[fst p2]) <- dst+                dst <- getNewRegNat fmt+                let code = exp1 `appOL` exp2 dst `snocOL`+                           (VSHUF fmt (ImmInt imm1) (OpReg r1) dst dst) `snocOL` -- dst <- (dst[snd q0],dst[snd q0],r1[snd p0],r1[snd p0]) = (v2[snd q0],v2[snd q0],v1[snd p0],v1[snd p0])+                           (VSHUF fmt (ImmInt imm2) (OpReg r1) dst dst) `appOL`+                           inplaceShuffle pairs dst dst+                return $ Fixed fmt dst code++        -- We partition the list of indices into those that refer to the first vector and those that+        -- refer to the second, and handle each case depending on the number of indices in each group.+        let (from_first, from_second) = partition (\(_dstPos, srcPos) -> srcPos < 4) (zip [0..] is)+        case (from_first, map (\(dst, src) -> (dst, src - 4)) from_second) of+          ([p0,p1,p2,p3], []) -> oneSource p0 p1 p2 p3 v1+          ([], [q0,q1,q2,q3]) -> oneSource q0 q1 q2 q3 v2+          ([p0,p1], [q0,q1]) -> twoAndTwo p0 p1 q0 q1 v1 v2+          ([p0], [q0,q1,q2]) -> threeAndOne q0 q1 q2 p0 v2 v1+          ([p0,p1,p2], [q0]) -> threeAndOne p0 p1 p2 q0 v1 v2+          _ -> pprPanic "vector shuffle: cannot occur" (ppr is)+      | otherwise = pprPanic "vector shuffle: wrong indices" (ppr is)++    vector_shuffle_doublex2_sse :: CmmExpr -> CmmExpr -> [Int] -> NatM Register+    vector_shuffle_doublex2_sse v1 v2 is+      | [i0, i1] <- is =+        let fmt = VecFormat 2 FmtDouble+        in case (i0, i1) of+          -- Trivial cases+          (0, 1) -> getRegister' platform is32Bit v1+          (2, 3) -> getRegister' platform is32Bit v2++          -- MOVSD/UNPCKLPD/UNPCKHPD have shorter encoding than SHUFPD+          -- If SSE4.1 is available, BLENDPD could also be used in place of MOVSD (the encoding is longer though)+          (0, 3) -> vector_op_sse (\_ src -> MOV fmt src . OpReg) fmt v2 v1 -- MOVSD+          (2, 1) -> vector_op_sse (\_ src -> MOV fmt src . OpReg) fmt v1 v2 -- MOVSD+          _ | i0 == i1 -> do+            exp <- getAnyReg (if i0 <= 1 then v1 else v2)+            let unpck = if i0 == 0 || i0 == 2+                        then UNPCKL+                        else UNPCKH+                code dst = exp dst `snocOL`+                           (unpck fmt (OpReg dst) dst)+            return (Any fmt code)+          (0, 2) -> vector_op_sse UNPCKL fmt v1 v2+          (2, 0) -> vector_op_sse UNPCKL fmt v2 v1+          (1, 3) -> vector_op_sse UNPCKH fmt v1 v2+          (3, 1) -> vector_op_sse UNPCKH fmt v2 v1++          -- SHUFPD+          (1, 2) -> vector_op_sse (`SHUF` (ImmInt 0b01)) fmt v1 v2+          (3, 0) -> vector_op_sse (`SHUF` (ImmInt 0b01)) fmt v2 v1+          (1, 0) -> do+            exp <- getAnyReg v1+            let code dst = exp dst `snocOL`+                           (SHUF fmt (ImmInt 0b01) (OpReg dst) dst)+            return (Any fmt code)+          (3, 2) -> do+            exp <- getAnyReg v2+            let code dst = exp dst `snocOL`+                           (SHUF fmt (ImmInt 0b01) (OpReg dst) dst)+            return (Any fmt code)+          _ -> pprPanic "vector shuffle: indices out of bounds 0 <= i <= 3" (ppr is)+      | otherwise = pprPanic "vector shuffle: wrong number of indices (expected 2)" (ppr is)++    -- Shuffle with AVX instructions.+    -- The components above 128 bits are shuffled in the same way as the lower 128 bits.+    -- For example, `l == 4 && is == [0,3]` would represent `shuffleDoubleX4# _ _ (# 0#, 5#, 2#, 7# #)`.+    vector_shuffle_double_avx :: Length -- Vector length. 2 for XMM, 4 for YMM, 8 for ZMM.+                              -> CmmExpr+                              -> CmmExpr+                              -> [Int] -- 2-element list of indices+                              -> NatM Register+    vector_shuffle_double_avx l v1 v2 is+      | [i0, i1] <- is =+        let fmt = VecFormat l FmtDouble+            repeatShufpdMask m = case l of+              8 -> m .|. (m `shiftL` 2) .|. (m `shiftL` 4) .|. (m `shiftL` 6)+              4 -> m .|. (m `shiftL` 2)+              _ -> m+        in case (i0, i1) of+          -- Trivial cases+          (0, 1) -> getRegister' platform is32Bit v1+          (2, 3) -> getRegister' platform is32Bit v2++          -- VMOVSD/VUNPCKLPD/VUNPCKHPD have shorter encoding than VSHUFPD+          (0, 3) | l == 2 -> do+                   (r1, exp1) <- getSomeReg v1+                   (r2, exp2) <- getSomeReg v2+                   let code dst = exp1 `appOL` exp2 `snocOL`+                                  (VMOV_MERGE fmt r1 r2 dst) -- VMOVSD+                   return (Any fmt code)+                 | otherwise -> vector_float_op_avx (`VSHUF` (ImmInt $ repeatShufpdMask 0b10)) l W64 v1 v2+          (2, 1) | l == 2 -> do+                   (r1, exp1) <- getSomeReg v1+                   (r2, exp2) <- getSomeReg v2+                   let code dst = exp1 `appOL` exp2 `snocOL`+                                  (VMOV_MERGE fmt r2 r1 dst) -- VMOVSD+                   return (Any fmt code)+                 | otherwise -> vector_float_op_avx (`VSHUF` (ImmInt $ repeatShufpdMask 0b10)) l W64 v2 v1+          _ | i0 == i1 -> do+            (r, exp) <- getSomeReg (if i0 <= 1 then v1 else v2)+            let unpck = if i0 == 0 || i0 == 2+                        then VUNPCKL+                        else VUNPCKH+                code dst = exp `snocOL`+                           (unpck fmt (OpReg r) r dst)+            return (Any fmt code)+          (0, 2) -> vector_float_op_avx VUNPCKL l W64 v1 v2+          (2, 0) -> vector_float_op_avx VUNPCKL l W64 v2 v1+          (1, 3) -> vector_float_op_avx VUNPCKH l W64 v1 v2+          (3, 1) -> vector_float_op_avx VUNPCKH l W64 v2 v1++          -- SHUFPD+          (1, 2) -> vector_float_op_avx (`VSHUF` (ImmInt $ repeatShufpdMask 0b01)) l W64 v1 v2+          (3, 0) -> vector_float_op_avx (`VSHUF` (ImmInt $ repeatShufpdMask 0b01)) l W64 v2 v1+          (1, 0) -> do+            (r, exp) <- getSomeReg v1+            let code dst = exp `snocOL`+                           (VSHUF fmt (ImmInt $ repeatShufpdMask 0b01) (OpReg r) r dst)+            return (Any fmt code)+          (3, 2) -> do+            (r, exp) <- getSomeReg v2+            let code dst = exp `snocOL`+                           (VSHUF fmt (ImmInt $ repeatShufpdMask 0b01) (OpReg r) r dst)+            return (Any fmt code)+          _ -> pprPanic "vector shuffle: indices out of bounds 0 <= i <= 3" (ppr is)+      | otherwise = pprPanic "vector shuffle: wrong number of indices (expected 2)" (ppr is)++    isZeroVecLit :: CmmExpr -> Bool+    isZeroVecLit (CmmLit (CmmVec elems)) = all (\lit -> case lit of CmmInt 0 _ -> True; _ -> False) elems+    isZeroVecLit _ = False++    vector_shuffle_int128_common :: Bool -> Format -> CmmExpr -> CmmExpr -> [Int] -> Maybe (NatM Register)+    vector_shuffle_int128_common sse4_1 fmt v1 v2 is+      | length is == n, all (\i -> 0 <= i && i < 2 * n) is = if+        -- Trivial cases+        | is == [0..n-1] -> Just $ getRegister' platform is32Bit v1+        | is == [n..2*n-1] -> Just $ getRegister' platform is32Bit v2++        -- We would like to emit PXOR for these trivial cases, instead of PSLLDQ.+        -- These conditions can be generalized to the cases where all elements are equal,+        -- or more generally, a constant-folding rule.+        | v1IsZero, all (< n) is -> Just $ getRegister' platform is32Bit v1+        | v2IsZero, all (>= n) is -> Just $ getRegister' platform is32Bit v2++        -- PSLLDQ: v2 == 0 && is == [n..(2n-1),...,n..(2n-1);0,1,2,3,...,n-i-1]+        | v2IsZero, (z, js) <- span (>= n) is, and (zipWith (==) js [0..]) -> Just $ do+          exp1 <- getAnyReg v1+          let code dst = exp1 dst `snocOL`+                         (PSLLDQ fmt (ImmInt (widthInBytes * length z)) dst)+          return (Any fmt code)++        -- PSLLDQ: v1 == 0 && is == [0..(n-1),...,0..(n-1);n,n+1,...,2n-i-1]+        | v1IsZero, (z, js) <- span (< n) is, and (zipWith (==) js [n..]) -> Just $ do+          exp2 <- getAnyReg v2+          let code dst = exp2 dst `snocOL`+                         (PSLLDQ fmt (ImmInt (widthInBytes * length z)) dst)+          return (Any fmt code)++        -- PSRLDQ: v2 == 0 && is == [i,i+1,...,n-2,n-1;n..(2n-1),...,n..(2n-1)]+        | v2IsZero, (js, z) <- span (< n) is, all (>= n) z, and (zipWith (==) (reverse js) [n-1,n-2..]) -> Just $ do+          exp1 <- getAnyReg v1+          let code dst = exp1 dst `snocOL`+                         (PSRLDQ fmt (ImmInt (widthInBytes * length z)) dst)+          return (Any fmt code)++        -- PSRLDQ: v1 == 0 && is == [n+i,...,2n-2,2n-1;0..(n-1),...,0..(n-1)]+        | v1IsZero, (js, z) <- span (>= n) is, all (< n) z, and (zipWith (==) (reverse js) [2*n-1,2*n-2..]) -> Just $ do+          exp2 <- getAnyReg v2+          let code dst = exp2 dst `snocOL`+                         (PSRLDQ fmt (ImmInt (widthInBytes * length z)) dst)+          return (Any fmt code)++        -- PALIGNR (SSSE3) or PSLLDQ + PSRLDQ: is == [i,i+1,...,n-2,n-1;n,n+1,...,n+i-1]+        | (js, ks) <- span (< n) is, and (zipWith (==) (reverse js) [n-1,n-2..]), and (zipWith (==) ks [n..]) -> Just $ do+          ssse3 <- ssse3Enabled+          let amountInBytes = widthInBytes * length ks+          if ssse3+            then vector_op_sse (`PALIGNR` (ImmInt amountInBytes)) fmt v2 v1+            else do+              exp1 <- getAnyReg v1+              exp2 <- getAnyReg v2+              tmp <- getNewRegNat fmt+              let code dst = exp1 tmp `snocOL`+                             (PSRLDQ fmt (ImmInt amountInBytes) tmp) `appOL`+                             exp2 dst `snocOL`+                             (PSLLDQ fmt (ImmInt (16 - amountInBytes)) dst) `snocOL`+                             (POR fmt (OpReg tmp) dst)+              return (Any fmt code)++        -- PALIGNR (SSSE3) or PSLLDQ + PSRLDQ: is == [n+i,n+i+1,...,2n-2,2n-1;0,1,...,i-1]+        | (js, ks) <- span (>= n) is, and (zipWith (==) (reverse js) [2*n-1,2*n-2..]), and (zipWith (==) ks [0..]) -> Just $ do+          ssse3 <- ssse3Enabled+          let amountInBytes = widthInBytes * length ks+          if ssse3+            then vector_op_sse (`PALIGNR` (ImmInt amountInBytes)) fmt v1 v2+            else do+              exp1 <- getAnyReg v1+              exp2 <- getAnyReg v2+              tmp <- getNewRegNat fmt+              let code dst = exp2 tmp `snocOL`+                             (PSRLDQ fmt (ImmInt amountInBytes) tmp) `appOL`+                             exp1 dst `snocOL`+                             (PSLLDQ fmt (ImmInt (16 - amountInBytes)) dst) `snocOL`+                             (POR fmt (OpReg tmp) dst)+              return (Any fmt code)++        -- PBLENDW (SSE4.1): map (`mod` n) is == [0,1,...,n-1] if widthInBytes >= 2+        | sse4_1, widthInBytes >= 2, and (zipWith (\i j -> i `rem` n == j) is [0..]) -> Just $ do+          let k = widthInBytes `quot` 2+              m = bit k - 1+              imm = foldr (\i acc -> if i >= n then (acc `shiftL` k) .|. m else acc `shiftL` k) 0 is+          vector_op_sse (`PBLENDW` (ImmInt imm)) fmt v1 v2++        | otherwise -> Nothing++      | otherwise = pprPanic "vector shuffle: wrong indices" (ppr is)+      where+        (n, widthInBytes) = case fmt of+          VecFormat 16 FmtInt8 -> (16, 1)+          VecFormat 8 FmtInt16 -> (8, 2)+          VecFormat 4 FmtInt32 -> (4, 4)+          VecFormat 2 FmtInt64 -> (2, 8)+          _ -> pprPanic "Invalid format" (ppr fmt)+        v1IsZero = isZeroVecLit v1+        v2IsZero = isZeroVecLit v2++    vector_shuffle_int8x16 :: Bool -> CmmExpr -> CmmExpr -> [Int] -> NatM Register+    vector_shuffle_int8x16 sse4_1 v1 v2 is+      | Just commonCase <- vector_shuffle_int128_common sse4_1 fmt v1 v2 is = commonCase+      | otherwise = do+        ssse3 <- ssse3Enabled+        let fmtInt16X8 = VecFormat 8 FmtInt16+            v1IsZero = isZeroVecLit v1+            v2IsZero = isZeroVecLit v2+            tryInt16X8Mask [] = Just []+            tryInt16X8Mask (j0:j1:js)+              | even j0, j1 == j0 + 1 = (j0 `quot` 2 :) <$> tryInt16X8Mask js+            tryInt16X8Mask _ = Nothing+        if+          -- PUNPCKLBW / PUNPCKHBW+          | [0,16,1,17,2,18,3,19,4,20,5,21,6,22,7,23] <- is -> vector_op_sse PUNPCKLBW fmt v1 v2+          | [16,0,17,1,18,2,19,3,20,4,21,5,22,6,23,7] <- is -> vector_op_sse PUNPCKLBW fmt v2 v1+          | [8,24,9,25,10,26,11,27,12,28,13,29,14,30,15,31] <- is -> vector_op_sse PUNPCKHBW fmt v1 v2+          | [24,8,25,9,26,10,27,11,28,12,29,13,30,14,31,15] <- is -> vector_op_sse PUNPCKHBW fmt v2 v1++          -- PSHUFB (SSSE3)+          | ssse3, all (< 16) is || v2IsZero -> do+            exp1 <- getAnyReg v1+            let mask1 = CmmVec $ map (\i -> CmmInt (toInteger $ if i < 16 then i else 255) W8) is+            Amode amode1 amode_code1 <- memConstant (mkAlignment 16) mask1+            let code dst = exp1 dst `appOL`+                           amode_code1 `snocOL`+                           (PSHUFB fmt (OpAddr amode1) dst)+            return (Any fmt code)++          -- PSHUFB (SSSE3)+          | ssse3, all (>= 16) is || v1IsZero -> do+            exp2 <- getAnyReg v2+            let mask2 = CmmVec $ map (\i -> CmmInt (toInteger $ if i >= 16 then i - 16 else 255) W8) is+            Amode amode2 amode_code2 <- memConstant (mkAlignment 16) mask2+            let code dst = exp2 dst `appOL`+                           amode_code2 `snocOL`+                           (PSHUFB fmt (OpAddr amode2) dst)+            return (Any fmt code)++          -- PBLENDW (SSE4.1): js <- tryInt16X8Mask is, map (`mod` 8) js == [0,1,...,7]+          | sse4_1, Just js <- tryInt16X8Mask is, and (zipWith (\i j -> i `rem` 8 == j) js [0..]) -> do+            let imm = foldr (\i acc -> if i >= 8 then (acc `shiftL` 1) .|. 1 else acc `shiftL` 1) 0 js+            vector_op_sse (`PBLENDW` (ImmInt imm)) fmt v1 v2++          -- General case with SSSE3: PSHUFB + PSHUFB + POR+          | ssse3 -> do+            exp1 <- getAnyReg v1+            exp2 <- getAnyReg v2+            tmp1 <- getNewRegNat fmt+            let mask1 = CmmVec $ map (\i -> CmmInt (toInteger $ if i < 16 then i else 255) W8) is+                mask2 = CmmVec $ map (\i -> CmmInt (toInteger $ if i >= 16 then i - 16 else 255) W8) is+            Amode amode1 amode_code1 <- memConstant (mkAlignment 16) mask1+            Amode amode2 amode_code2 <- memConstant (mkAlignment 16) mask2+            let code dst = exp1 tmp1 `appOL` exp2 dst `appOL`+                           amode_code1 `snocOL`+                           (PSHUFB fmt (OpAddr amode1) tmp1) `appOL`+                           amode_code2 `snocOL`+                           (PSHUFB fmt (OpAddr amode2) dst) `snocOL`+                           (POR fmt (OpReg tmp1) dst)+            return (Any fmt code)++          -- General case with SSE2: GPR + MOVQ + PUNPCKLQDQ+          | otherwise -> do+            (r1, exp1) <- getSomeReg v1+            (r2, exp2) <- getSomeReg v2+            tmp <- getNewRegNat II64+            tmpLo <- getNewRegNat II64+            tmpHi <- getNewRegNat II64+            tmpXmm <- getNewRegNat fmt+            dst <- getNewRegNat fmt+            let place8Bits srcPos dstPos dst =+                  -- Assumption: 0 <= srcPos < 32, 0 <= dstPos < 8+                  -- tmp <- (src[srcPos] `shiftR` ((srcPos `rem` 16) * 8)) .&. 0xff+                  -- dst <- dst .|. (tmp `shiftL` (dstPos * 8))+                  let r = if srcPos < 16 then r1 else r2+                  in case (srcPos `rem` 16) `quotRem` 2 of+                      (k, 0) -> toOL [ PEXTR II32 fmtInt16X8 (ImmInt k) r (OpReg tmp)+                                     , MOVZxL II8 (OpReg tmp) (OpReg tmp)+                                     , SHL II64 (OpImm (ImmInt (8 * dstPos))) (OpReg tmp)+                                     , OR II64 (OpReg tmp) (OpReg dst)+                                     ]+                      (k, _) -> (PEXTR II32 fmtInt16X8 (ImmInt k) r (OpReg tmp)) `consOL`+                                ((case dstPos of+                                    0 -> unitOL (SHR II32 (OpImm (ImmInt 8)) (OpReg tmp))+                                    1 -> unitOL (AND II32 (OpImm (ImmInt 0xff00)) (OpReg tmp))+                                    _ -> toOL [ AND II32 (OpImm (ImmInt 0xff00)) (OpReg tmp)+                                              , SHL II64 (OpImm (ImmInt (8 * (dstPos - 1)))) (OpReg tmp) ]) `snocOL`+                                 (OR II64 (OpReg tmp) (OpReg dst)))+                makeInt8x8OnGPR dst js = (XOR II32 (OpReg dst) (OpReg dst)) `consOL`+                                         concatOL [ place8Bits srcPos dstPos dst | (srcPos, dstPos) <- zip js [0..] ]+                code = exp1 `appOL` exp2 `appOL`+                       makeInt8x8OnGPR tmpLo (take 8 is) `snocOL`+                       (MOVD II64 fmt (OpReg tmpLo) (OpReg dst)) `appOL`+                       makeInt8x8OnGPR tmpHi (drop 8 is) `snocOL`+                       (MOVD II64 fmt (OpReg tmpHi) (OpReg tmpXmm)) `snocOL`+                       (PUNPCKLQDQ fmt (OpReg tmpXmm) dst)+            return (Fixed fmt dst code)+      where fmt = VecFormat 16 FmtInt8++    vector_shuffle_int16x8 :: Bool -> CmmExpr -> CmmExpr -> [Int] -> NatM Register+    vector_shuffle_int16x8 sse4_1 v1 v2 is@(i0:i1:i2:i3:i4567@[i4,i5,i6,i7])+      | Just commonCase <- vector_shuffle_int128_common sse4_1 fmt v1 v2 is = commonCase+      | otherwise = do+        (r1, exp1) <- getSomeReg v1+        (r2, exp2) <- getSomeReg v2+        let -- shufL src dst k0 k1 k2 k3 (0 <= k_i < 4):+            --   dst <- (src[k0],src[k1],src[k2],src[k3],src[4],src[5],src[6],src[7])+            shufL src dst 0 1 2 3 | src == dst = nilOL+                                  | otherwise = unitOL (MOVDQU fmt (OpReg src) (OpReg dst))+            shufL src dst k0 k1 k2 k3 = let imm = k0 + (k1 `shiftL` 2) + (k2 `shiftL` 4) + (k3 `shiftL` 6)+                                        in unitOL (PSHUFLW fmt (ImmInt imm) (OpReg src) dst)+            -- shufH src dst k0 k1 k2 k3 (4 <= k_i < 8):+            --   dst <- (src[0],src[1],src[2],src[3],src[k0],src[k1],src[k2],src[k3])+            shufH src dst 4 5 6 7 | src == dst = nilOL+                                  | otherwise = unitOL (MOVDQU fmt (OpReg src) (OpReg dst))+            shufH src dst k0 k1 k2 k3 = let imm = (k0 - 4) + ((k1 - 4) `shiftL` 2) + ((k2 - 4) `shiftL` 4) + ((k3 - 4) `shiftL` 6)+                                        in unitOL (PSHUFHW fmt (ImmInt imm) (OpReg src) dst)++            shufLHImm src dst immLo immHi = case (immLo, immHi) of+              (0b11_10_01_00, 0b11_10_01_00)+                | src == dst -> nilOL+                | otherwise -> unitOL (MOVDQU fmt (OpReg src) (OpReg dst))+              (0b11_10_01_00, _) -> unitOL (PSHUFHW fmt (ImmInt immHi) (OpReg src) dst)+              (_, 0b11_10_01_00) -> unitOL (PSHUFLW fmt (ImmInt immLo) (OpReg src) dst)+              (_, _) -> toOL [PSHUFLW fmt (ImmInt immLo) (OpReg src) dst,+                              PSHUFHW fmt (ImmInt immHi) (OpReg dst) dst]++            -- ks = [k0,...,k7]+            -- Assumption: 0 <= k_i < 4 for 0 <= i < 4, 4 <= k_i < 8 for 4 <= i < 8+            -- dst <- (src[k0],...,src[k7])+            shufLH src dst ks+              = let (k_lo, k_hi) = splitAt 4 ks+                    immLo = foldr (\k acc -> (acc `shiftL` 2) + k) 0 k_lo+                    immHi = foldr (\k acc -> (acc `shiftL` 2) + (k - 4)) 0 k_hi+                in shufLHImm src dst immLo immHi++            -- shufRev src dst j0 j1 j2 j3 j4 j5 j6 j7:+            -- Assumption: [j0,j1,j2,j3] `elem` permutations [0,1,2,3] && [j4,j5,j6,j7] `elem` permutations [4,5,6,7]:+            --   dst[j0] <- src[0]; dst[j1] <- src[1]; dst[j2] <- src[2]; dst[j3] <- src[3];+            --   dst[j4] <- src[4]; dst[j5] <- src[5]; dst[j6] <- src[6]; dst[j7] <- src[7];+            shufRev src dst _j0 j1 j2 j3 _j4 j5 j6 j7+              = let immLo = (1 `shiftL` (2 * j1)) + (2 `shiftL` (2 * j2)) + (3 `shiftL` (2 * j3))+                    immHi = (1 `shiftL` (2 * (j5 - 4))) + (2 `shiftL` (2 * (j6 - 4))) + (3 `shiftL` (2 * (j7 - 4)))+                in shufLHImm src dst immLo immHi+            i0123 = [i0, i1, i2, i3]+        if+          -- PSHUFLW + PSHUFHW+          | all (\i -> i < 4) i0123+          , all (\i -> 4 <= i && i < 8) i4567+          -> do+            let code dst = exp1 `appOL`+                           shufLH r1 dst is+            return (Any fmt code)++          -- PSHUFLW + PSHUFHW+          | all (\i -> 8 <= i && i < 12) i0123+          , all (\i -> 12 <= i) i4567+          -> do+            let code dst = exp2 `appOL`+                           shufLH r2 dst (map (subtract 8) is)+            return (Any fmt code)++          -- PSHUF{L,H}W + PBLENDW (SSE4.1)+          | sse4_1+          , all (\i -> i `rem` 8 < 4) i0123+          , all (\i -> 4 <= i `rem` 8) i4567+          -> do+            tmp <- getNewRegNat fmt+            let imm = foldl' (\acc (i,p) -> if i >= 8 then setBit acc p else acc) 0 (zip is [0..])+                js = zipWith (\i p -> if i >= 8 then p else i) is [0..]+                ks = zipWith (\i p -> if i >= 8 then i - 8 else p) is [0..]+                code dst = exp1 `appOL` exp2 `appOL`+                           shufLH r2 tmp ks `appOL`+                           shufLH r1 dst js `snocOL`+                           (PBLENDW fmt (ImmInt imm) (OpReg tmp) dst)+            return (Any fmt code)++          -- PSHUFLW + PSHUFLW + PUNPCKLWD + PSHUFLW + PSHUFHW+          | all (\i -> i < 4 || (8 <= i && i < 12)) is+          , ([(j0, k0), (j1, k1)], [(j2, k2), (j3, k3)]) <- partition (\(_, i) -> i < 4) [(0, i0), (1, i1), (2, i2), (3, i3)]+          , ([(j4, k4), (j5, k5)], [(j6, k6), (j7, k7)]) <- partition (\(_, i) -> i < 4) [(4, i4), (5, i5), (6, i6), (7, i7)]+          -> do+            tmp1 <- getNewRegNat fmt+            tmp2 <- getNewRegNat fmt+            let code dst = exp1 `appOL` exp2 `appOL`+                           shufL r1 tmp1 k0 k1 k4 k5 `appOL`+                           shufL r2 tmp2 (k2 - 8) (k3 - 8) (k6 - 8) (k7 - 8) `snocOL`+                           (PUNPCKLWD fmt (OpReg tmp2) tmp1) `appOL`+                           shufRev tmp1 dst j0 j2 j1 j3 j4 j6 j5 j7+            return (Any fmt code)++          -- PSHUFHW + PSHUFHW + PUNPCKHWD + PSHUFLW + PSHUFHW+          | all (\i -> (4 <= i && i < 8) || 12 <= i) is+          , ([(j0, k0), (j1, k1)], [(j2, k2), (j3, k3)]) <- partition (\(_, i) -> i < 8) [(0, i0), (1, i1), (2, i2), (3, i3)]+          , ([(j4, k4), (j5, k5)], [(j6, k6), (j7, k7)]) <- partition (\(_, i) -> i < 8) [(4, i4), (5, i5), (6, i6), (7, i7)]+          -> do+            tmp1 <- getNewRegNat fmt+            tmp2 <- getNewRegNat fmt+            let code dst = exp1 `appOL` exp2 `appOL`+                           shufH r1 tmp1 k0 k1 k4 k5 `appOL`+                           shufH r2 tmp2 (k2 - 8) (k3 - 8) (k6 - 8) (k7 - 8) `snocOL`+                           (PUNPCKHWD fmt (OpReg tmp2) tmp1) `appOL`+                           shufRev tmp1 dst j0 j2 j1 j3 j4 j6 j5 j7+            return (Any fmt code)++          -- Generic implementation+          | otherwise -> do+            tmp0 <- getNewRegNat II32+            tmps <- replicateM 7 (getNewRegNat II32)+            let code dst = exp1 `appOL` exp2 `appOL`+                           toOL [ PEXTR II32 fmt (ImmInt i') r (OpReg tmp)+                                | (i, tmp) <- zip is (tmp0:tmps)+                                , let (i', r) = if i < 8 then (i, r1) else (i - 8, r2)+                                ] `snocOL`+                           (MOVD II32 fmt (OpReg tmp0) (OpReg dst)) `appOL`+                           toOL [ PINSR II32 fmt (ImmInt i) (OpReg tmp) dst+                                | (i, tmp) <- zip [1..] tmps+                                ]+            return (Any fmt code)+      where fmt = VecFormat 8 FmtInt16+    vector_shuffle_int16x8 _ _ _ is = pprPanic "vector shuffle: wrong number of indices (expected 8)" (ppr is)++    vector_shuffle_int32x4 :: Bool -> CmmExpr -> CmmExpr -> [Int] -> NatM Register+    vector_shuffle_int32x4 sse4_1 v1 v2 is+      | Just commonCase <- vector_shuffle_int128_common sse4_1 fmt v1 v2 is = commonCase+      | otherwise = do+        let -- `pshufd imm src dst` is equivalent to `PSHUFD fmt (ImmInt imm) (OpReg src) dst`+            pshufd 0b11_10_01_00 src dst+              | src == dst = nilOL+              | otherwise = unitOL (MOVDQU fmt (OpReg src) (OpReg dst))+            pshufd imm src dst = unitOL (PSHUFD fmt (ImmInt imm) (OpReg src) dst)++            -- PSHUFD (composeImm imm1 imm2) src dst == (PSHUFD imm1 src tmp; PSHUFD imm2 tmp dst)+            composeMask :: Int -> Int -> Int+            composeMask imm1 imm2 = foldr (\i acc -> let j = (imm2 `shiftR` (2 * i)) .&. 3+                                                     in (imm1 `shiftR` (2 * j) .&. 3) .|. (acc `shiftL` 2)+                                          ) 0 [0..3]++            makeMask :: [(Int, Int)] -- List of (dst,src). If src == -1, the value there can be anything.+                     -> Int+            makeMask m = foldl' (.|.) 0 [ src `shiftL` (2 * dst) | dst <- [0..3], let src = fromMaybe dst (mfilter (>= 0) $ lookup dst m) ]++            twoAndTwo p0@(1,_) p1@(3,_) q0@(0,_) q1@(2,_) imm4 v1 v2 = twoAndTwo' q0 q1 p0 p1 imm4 v2 v1+            twoAndTwo p0 p1 q0 q1 imm4 v1 v2 = twoAndTwo' p0 p1 q0 q1 imm4 v1 v2+            twoAndTwo' p0 p1 q0 q1 imm4 v1 v2 = do+              (r1, exp1) <- getSomeReg v1+              (r2, exp2) <- getSomeReg v2+              tmp <- getNewRegNat fmt+              let (instr, imm1, imm2) =+                    if all (\(_,i) -> 2 <= i || i == -1) [p0,p1,q0,q1] then+                      -- The inputs are all from higher lanes+                      (PUNPCKHDQ, makeMask [(2,snd p0),(3,snd p1)], makeMask [(2,snd q0),(3,snd q1)])+                    else+                      (PUNPCKLDQ, makeMask [(0,snd p0),(1,snd p1)], makeMask [(0,snd q0),(1,snd q1)])+                  imm3 = makeMask [(fst p0,0),(fst q0,1),(fst p1,2),(fst q1,3)]+                  code dst = exp1 `appOL` exp2 `appOL`+                             pshufd imm2 r2 tmp `appOL`             -- tmp <- (*,*,r2[snd q0],r2[snd q1]) or (r2[snd q0],r2[snd q1],*,*)+                             pshufd imm1 r1 dst `snocOL`            -- dst <- (*,*,r1[snd p0],r1[snd p1]) or (r1[snd p0],r1[snd p1],*,*)+                             instr fmt (OpReg tmp) dst `appOL`      -- dst <- (dst[0],tmp[0],dst[1],tmp[1]) = (r1[snd p0],r2[snd q0],r1[snd p1],r2[snd q1])+                             pshufd (composeMask imm3 imm4) dst dst -- (dst[fst p0],dst[fst q0],dst[fst p1],dst[fst q1]) <- dst+              return $ Any fmt code++            threeAndOne p0 p1 p2 q0+              | snd p0 == snd p1 = twoAndTwo p0 p2 q0 (fst p1,-1) (makeMask [(fst p0,fst p0),(fst p1,fst p0),(fst p2,fst p2),(fst q0,fst q0)])+              | snd p0 == snd p2 = twoAndTwo p0 p1 q0 (fst p2,-1) (makeMask [(fst p0,fst p0),(fst p1,fst p1),(fst p2,fst p0),(fst q0,fst q0)])+              | snd p1 == snd p2 = twoAndTwo p0 p1 q0 (fst p2,-1) (makeMask [(fst p0,fst p0),(fst p1,fst p1),(fst p2,fst p1),(fst q0,fst q0)])+              | otherwise = \v1 v2 -> do+                (r1, exp1) <- getSomeReg v1+                (r2, exp2) <- getSomeReg v2+                tmp1 <- getNewRegNat fmt+                if sse4_1+                  then do+                    let imm1 = makeMask [p0,p1,p2]+                        imm2 = makeMask [q0]+                        imm3 = foldl' (.|.) 0 [ (if i == fst q0 then 0 else 3) `shiftL` (2 * i) | i <- [0..3] ]+                    let code dst = exp1 `appOL` exp2 `appOL`+                                   pshufd imm1 r1 tmp1 `appOL`+                                   pshufd imm2 r2 dst `snocOL`+                                   PBLENDW fmt (ImmInt imm3) (OpReg tmp1) dst+                    return $ Any fmt code+                  else do+                    tmp2 <- getNewRegNat fmt+                    tmp3 <- getNewRegNat fmt+                    let imm1 = snd q0 .|. 0b11_10_01_00+                        imm2 = snd p1 .|. 0b11_10_01_00+                        imm3 = snd p0 .|. (snd p2 `shiftL` 2) .|. 0b11_10_00_00+                        imm6 = makeMask [(fst q0,0),(fst p0,1),(fst p1,2),(fst p2,3)]+                        code dst = exp1 `appOL` exp2 `appOL`+                                   pshufd imm1 r2 tmp1 `appOL`              -- tmp1 <- (y0,*,*,*)+                                   pshufd imm2 r1 tmp2 `appOL`              -- tmp2 <- (x1,*,*,*)+                                   pshufd imm3 r1 tmp3 `snocOL`             -- tmp3 <- (x0,x2,*,*)+                                   PUNPCKLDQ fmt (OpReg tmp2) tmp1 `snocOL` -- tmp1 <- unpckldq tmp1 tmp2 = (y0,x1,*,*)+                                   PUNPCKLDQ fmt (OpReg tmp3) tmp1 `appOL`  -- tmp1 <- unpckldq tmp1 tmp3 = (y0,x0,x1,x2)+                                   pshufd imm6 tmp1 dst                     -- dst <- shuffle tmp1+                    return $ Any fmt code++        let (from_first, from_second) = partition (\(_dstPos,srcPos) -> srcPos < 4) (zip [0..] is)+        case (from_first, map (\(dstPos,srcPos) -> (dstPos, srcPos - 4)) from_second) of+          ([p0,p1,p2,p3], []) -> do+            (r, exp) <- getSomeReg v1+            let imm = makeMask [p0,p1,p2,p3]+                code dst = exp `appOL` pshufd imm r dst+            return $ Any fmt code++          ([], [q0,q1,q2,q3]) -> do+            (r, exp) <- getSomeReg v2+            let imm = makeMask [q0,q1,q2,q3]+                code dst = exp `appOL` pshufd imm r dst+            return $ Any fmt code++          ([p0,p1], [q0,q1]) -> twoAndTwo p0 p1 q0 q1 0b11_10_01_00 v1 v2+          ([p0], [q0,q1,q2]) -> threeAndOne q0 q1 q2 p0 v2 v1+          ([p0,p1,p2], [q0]) -> threeAndOne p0 p1 p2 q0 v1 v2++          _ -> pprPanic "vector shuffle: cannot occur" (ppr is)+      where fmt = VecFormat 4 FmtInt32++    vector_shuffle_int64x2 :: Bool -> CmmExpr -> CmmExpr -> [Int] -> NatM Register+    vector_shuffle_int64x2 sse4_1 v1 v2 is+      | Just commonCase <- vector_shuffle_int128_common sse4_1 fmt v1 v2 is = commonCase+      | otherwise = case is of+        -- PUNPCKLQDQ / PUNPCKHQDQ+        [i, i'] | i == i' -> do+          exp <- getAnyReg $ if i < 2 then v1 else v2+          let instr = if i == 0 || i == 2+                      then PUNPCKLQDQ+                      else PUNPCKHQDQ+              code dst = exp dst `snocOL`+                         (instr fmt (OpReg dst) dst)+          return $ Any fmt code+        [0, 2] -> vector_op_sse PUNPCKLQDQ fmt v1 v2+        [2, 0] -> vector_op_sse PUNPCKLQDQ fmt v2 v1+        [1, 3] -> vector_op_sse PUNPCKHQDQ fmt v1 v2+        [3, 1] -> vector_op_sse PUNPCKHQDQ fmt v2 v1++        -- PSHUFD+        [1, 0] -> do+          (r1, exp1) <- getSomeReg v1+          let code dst = exp1 `snocOL`+                         (PSHUFD fmt (ImmInt 0b01_00_11_10) (OpReg r1) dst)+          return $ Any fmt code+        [3, 2] -> do+          (r2, exp2) <- getSomeReg v2+          let code dst = exp2 `snocOL`+                         (PSHUFD fmt (ImmInt 0b01_00_11_10) (OpReg r2) dst)+          return $ Any fmt code++        -- Others:+        -- If SSE4.1 is available, use PBLENDW (see vector_shuffle_int128_common).+        -- Otherwise, we resort to SHUFPD.+        [0, 3] -> vector_op_sse (\_ -> SHUF doubleFormat (ImmInt 2)) fmt v1 v2+        [2, 1] -> vector_op_sse (\_ -> SHUF doubleFormat (ImmInt 2)) fmt v2 v1++        -- [0, 1], [2, 3], [1, 2], [3, 0] are covered by the common cases++        -- Indices are checked in vector_shuffle_int128_common, so the following line should be unreachable:+        _ -> pprPanic "vector shuffle: wrong number of indices (expected 2)" (ppr is)+      where fmt = VecFormat 2 FmtInt64+            doubleFormat = VecFormat 2 FmtDouble+++getRegister' platform _is32Bit (CmmMachOp mop [x, y, z]) = do -- ternary MachOps+  avx    <- avxEnabled+  sse4_1 <- sse4_1Enabled+  case mop of+      -- Floating point fused multiply-add operations @ ± x*y ± z@+      MO_FMA var l w+        | l * widthInBits w > 256+        -> sorry "Please use -fllvm for wide vector FMA support"+        | otherwise+        -> genFMA3Code l w var x y z++      -- Ternary vector operations+      MO_VF_Insert l W32  | l == 4 -> vector_floatx4_insert_sse sse4_1 x y z+                          | otherwise ->+         sorry $ "FloatX" ++ show l ++ "# insert operations require -fllvm"+           -- SIMD NCG TODO:+           --+           --   - add support for FloatX8, FloatX16.+      MO_VF_Insert l W64  -> vector_double_insert avx l x y z+      MO_V_Insert 16 W8 | sse4_1 -> vector_int_insert_pinsr 16 W8 x y z+                        | otherwise -> vector_int8x16_insert_sse2 x y z+      MO_V_Insert 8 W16 -> vector_int_insert_pinsr 8 W16 x y z -- PINSRW (SSE2)+      MO_V_Insert 4 W32 | sse4_1 -> vector_int_insert_pinsr 4 W32 x y z+                        | otherwise -> vector_int32x4_insert_sse2 x y z+      MO_V_Insert 2 W64 | sse4_1 -> vector_int_insert_pinsr 2 W64 x y z+                        | otherwise -> vector_int64x2_insert_sse2 x y z+      MO_V_Insert _ _ -> sorry "Unsupported integer vector insert operation; please use -fllvm"++      _other -> pprPanic "getRegister(x86) - ternary CmmMachOp (1)"+                  (pprMachOp mop)++  where+    -- SIMD NCG TODO:+    --+    --   - add support for FloatX8, FloatX16.+    vector_floatx4_insert_sse :: Bool+                              -> CmmExpr+                              -> CmmExpr+                              -> CmmExpr+                              -> NatM Register+    vector_floatx4_insert_sse sse4_1 vecExpr valExpr (CmmLit (CmmInt offset _))+      | sse4_1 = do+        (r, exp)    <- getNonClobberedReg valExpr+        fn          <- getAnyReg vecExpr+        let fmt      = VecFormat 4 FmtFloat+            imm      = litToImm (CmmInt (offset `shiftL` 4) W32)+            code dst = exp `appOL`+                      (fn dst) `snocOL`+                      (INSERTPS fmt imm (OpReg r) dst)+         in return $ Any fmt code+      | otherwise = do -- SSE <= 3+        (r, exp)    <- getNonClobberedReg valExpr+        fn          <- getAnyReg vecExpr+        let fmt      = VecFormat 4 FmtFloat+        tmp <- getNewRegNat fmt+        let code dst+              = case offset of+                  0 -> exp `appOL`+                      (fn dst) `snocOL`+                      -- The following MOV compiles to MOVSS instruction and merges two vectors+                      (MOV fmt (OpReg r) (OpReg dst))  -- dst <- (r[0],dst[1],dst[2],dst[3])+                  1 -> exp `appOL`+                      (fn dst) `snocOL`+                      (MOVU fmt (OpReg dst) (OpReg tmp)) `snocOL`  -- tmp <- dst+                      (UNPCKL fmt (OpReg r) dst) `snocOL`          -- dst <- (dst[0],r[0],dst[1],r[1])+                      (SHUF fmt (ImmInt 0xe4) (OpReg tmp) dst)     -- dst <- (dst[0],dst[1],tmp[2],tmp[3])+                  2 -> exp `appOL`+                       (fn dst) `snocOL`+                       (MOVU fmt (OpReg dst) (OpReg tmp)) `snocOL`  -- tmp <- dst+                       (MOV fmt (OpReg r) (OpReg tmp)) `snocOL`     -- tmp <- (r[0],tmp[1],tmp[2],tmp[3]) with MOVSS+                       (SHUF fmt (ImmInt 0xc4) (OpReg tmp) dst)     -- dst <- (dst[0],dst[1],tmp[0],tmp[3])+                  3 -> exp `appOL`+                       (fn dst) `snocOL`+                       (MOVU fmt (OpReg dst) (OpReg tmp)) `snocOL`  -- tmp <- dst+                       (MOV fmt (OpReg r) (OpReg tmp)) `snocOL`     -- tmp <- (r[0],tmp[1],tmp[2],tmp[3]) with MOVSS+                       (SHUF fmt (ImmInt 0x24) (OpReg tmp) dst)     -- dst <- (dst[0],dst[1],tmp[2],tmp[0])+                  _ -> panic "MO_VF_Insert FloatX4: unsupported offset"+         in return $ Any fmt code+    vector_floatx4_insert_sse _ _ _ offset+      = pprPanic "Unsupported vector insert operation" $+          vcat+            [ text "FloatX4#"+            , text "offset:" <+> pdoc platform offset ]+++    -- SIMD NCG TODO:+    --+    --   - add support for DoubleX4#, DoubleX8#.+    vector_double_insert :: Bool+                         -> Length+                         -> CmmExpr+                         -> CmmExpr+                         -> CmmExpr+                         -> NatM Register+    -- DoubleX2+    vector_double_insert avx len@2 vecExpr valExpr (CmmLit offset)+      = do+        (valReg, valExp) <- getNonClobberedReg valExpr+        (vecReg, vecExp) <- getSomeReg vecExpr -- NB: vector regs never clobbered by instruction+        let movu = if avx then VMOVU else MOVU+            fmt = VecFormat len FmtDouble+            code dst+              = case offset of+                  CmmInt 0 _ -> valExp `appOL`+                                vecExp `snocOL`+                                (movu (VecFormat 2 FmtDouble) (OpReg vecReg) (OpReg dst)) `snocOL`+                                -- The following MOV compiles to MOVSD instruction and merges two vectors+                                (MOV (VecFormat 2 FmtDouble) (OpReg valReg) (OpReg dst))+                  CmmInt 1 _ -> valExp `appOL`+                                vecExp `snocOL`+                                (movu (VecFormat 2 FmtDouble) (OpReg vecReg) (OpReg dst)) `snocOL`+                                (SHUF fmt (ImmInt 0b00) (OpReg valReg) dst)+                  _ -> pprPanic "MO_VF_Insert DoubleX2: unsupported offset" (ppr offset)+         in return $ Any fmt code+    vector_double_insert _ _ _ _ _ =+      sorry "Unsupported floating-point vector insert operation; please use -fllvm"+    -- For DoubleX4: use VSHUFPD.+    -- For DoubleX8: use something like vinsertf64x2 followed by vpblendd?++    -- SIMD NCG TODO:+    --+    --   - only supports 128-bit vector types (Int64X2, Int32X4, Int16X8, Int8X16),+    --     add support for 256-bit and 512-bit vector types.++    -- PINSRW is an SSE2 instruction, whereas PINSR{B,D,Q} require SSE4.1.+    vector_int_insert_pinsr :: HasCallStack => Length+                            -> Width+                            -> CmmExpr+                            -> CmmExpr+                            -> CmmExpr+                            -> NatM Register+    vector_int_insert_pinsr len w vecExpr valExpr (CmmLit (CmmInt offset _))+      | 0 <= offset, offset < toInteger len+      = do+        (valReg, valExp) <- getNonClobberedReg valExpr+        vecCode <- getAnyReg vecExpr+        let (scalarFormat, vectorFormat) = case w of+              W8 -> (II32, VecFormat len FmtInt8)+              W16 -> (II32, VecFormat len FmtInt16)+              W32 -> (II32, VecFormat len FmtInt32)+              W64 -> (II64, VecFormat len FmtInt64)+              _ -> sorry "Unsupported vector format"+            code dst = valExp `appOL`+                       (vecCode dst) `snocOL`+                       (PINSR scalarFormat vectorFormat (ImmInteger offset) (OpReg valReg) dst)+        return $ Any vectorFormat code+    vector_int_insert_pinsr _ _ _ _ offset = pprPanic "MO_V_Insert: unsupported offset" (pdoc platform offset)++    vector_int8x16_insert_sse2 :: CmmExpr+                               -> CmmExpr+                               -> CmmExpr+                               -> NatM Register+    vector_int8x16_insert_sse2 vecExpr valExpr (CmmLit (CmmInt offset _))+      | 0 <= offset, offset < 16+      = do+        (valReg, valExp) <- getNonClobberedReg valExpr+        vecCode <- getAnyReg vecExpr+        tmp <- getNewRegNat II32+        let vectorFormat = VecFormat 16 FmtInt8+            code dst+              = case offset `quotRem` 2 of+                  (j, 0) -> valExp `appOL`+                            (vecCode dst) `snocOL`+                            (PEXTR II32 (VecFormat 8 FmtInt16) (ImmInteger j) dst (OpReg tmp)) `snocOL` -- PEXTRW+                            (AND II32 (OpImm (ImmInt 0xff00)) (OpReg tmp)) `snocOL`+                            (MOVZxL II8 (OpReg valReg) (OpReg valReg)) `snocOL`+                            (OR II32 (OpReg valReg) (OpReg tmp)) `snocOL`+                            (PINSR II32 (VecFormat 8 FmtInt16) (ImmInteger j) (OpReg tmp) dst) -- PINSRW+                  (j, _) -> valExp `appOL`+                            (vecCode dst) `snocOL`+                            (PEXTR II32 (VecFormat 8 FmtInt16) (ImmInteger j) dst (OpReg tmp)) `snocOL` -- PEXTRW+                            (MOVZxL II8 (OpReg tmp) (OpReg tmp)) `snocOL`+                            (SHL II32 (OpImm (ImmInt 8)) (OpReg valReg)) `snocOL`+                            (OR II32 (OpReg valReg) (OpReg tmp)) `snocOL`+                            (PINSR II32 (VecFormat 8 FmtInt16) (ImmInteger j) (OpReg tmp) dst) -- PINSRW+        return $ Any vectorFormat code+    vector_int8x16_insert_sse2 _ _ offset = pprPanic "MO_V_Insert: unsupported offset" (pdoc platform offset)++    vector_int32x4_insert_sse2 :: CmmExpr+                               -> CmmExpr+                               -> CmmExpr+                               -> NatM Register+    vector_int32x4_insert_sse2 vecExpr valExpr (CmmLit (CmmInt offset _))+      | 0 <= offset, offset < 4+      = do+        (valReg, valExp) <- getNonClobberedReg valExpr+        vecCode <- getAnyReg vecExpr+        -- Since SSE2 does not have an integer vector instruction to achieve this,+        -- we are forced to either use floating-point vector instructions+        -- or lots of integer vector instructions. (sigh)+        let floatVectorFormat = VecFormat 4 FmtFloat+        tmp1 <- getNewRegNat floatVectorFormat+        tmp2 <- getNewRegNat floatVectorFormat+        let vectorFormat = VecFormat 4 FmtInt32+            code dst+              = case offset of+                  0 -> valExp `appOL`+                       (vecCode dst) `snocOL`+                       (MOVD II32 vectorFormat (OpReg valReg) (OpReg tmp1)) `snocOL`+                       (MOV floatVectorFormat (OpReg tmp1) (OpReg dst)) -- MOVSS; dst <- (tmp1[0],dst[1],dst[2],dst[3])+                  1 -> valExp `appOL`+                       (vecCode tmp1) `snocOL`+                       (MOVD II32 vectorFormat (OpReg valReg) (OpReg dst)) `snocOL` -- dst <- (val,0,0,0)+                       (PUNPCKLQDQ vectorFormat (OpReg tmp1) dst) `snocOL` -- dst <- (dst[0],dst[1],tmp1[0],tmp1[1])+                       (SHUF floatVectorFormat (ImmInt 0b11_10_00_10) (OpReg tmp1) dst) -- SHUFPS; dst <- (dst[2],dst[0],tmp1[2],tmp1[3])+                  2 -> valExp `appOL`+                       (vecCode dst) `snocOL`+                       (MOVD II32 vectorFormat (OpReg valReg) (OpReg tmp1)) `snocOL` -- tmp1 <- (val,0,0,0)+                       (MOVU floatVectorFormat (OpReg dst) (OpReg tmp2)) `snocOL` -- MOVUPS; tmp2 <- dst+                       (SHUF floatVectorFormat (ImmInt 0b01_00_01_11) (OpReg tmp1) tmp2) `snocOL` -- SHUFPS; tmp2 <- (tmp2[3],tmp2[1],tmp1[0],tmp1[1])+                       (SHUF floatVectorFormat (ImmInt 0b00_10_01_00) (OpReg tmp2) dst) -- SHUFPS; dst <- (dst[0],dst[1],tmp2[2],tmp2[0])+                  _ -> valExp `appOL`+                       (vecCode dst) `snocOL`+                       (MOVD II32 vectorFormat (OpReg valReg) (OpReg tmp1)) `snocOL` -- tmp1 <- (val,0,0,0)+                       (SHUF floatVectorFormat (ImmInt 0b11_10_01_00) (OpReg dst) tmp1) `snocOL` -- SHUFPS; tmp1 <- (tmp1[0],tmp1[1],dst[2],dst[3])+                       (SHUF floatVectorFormat (ImmInt 0b00_10_01_00) (OpReg tmp1) dst) -- SHUFPS; dst <- (dst[0],dst[1],tmp1[2],tmp1[0])+        return $ Any vectorFormat code+    vector_int32x4_insert_sse2 _ _ offset = pprPanic "MO_V_Insert: unsupported offset" (pdoc platform offset)++    vector_int64x2_insert_sse2 :: CmmExpr+                               -> CmmExpr+                               -> CmmExpr+                               -> NatM Register+    vector_int64x2_insert_sse2 vecExpr valExpr (CmmLit offset)+      = do+        (valReg, valExp) <- getNonClobberedReg valExpr+        (vecReg, vecExp) <- getSomeReg vecExpr -- NB: vector regs never clobbered by instruction+        let fmt = VecFormat 2 FmtInt64+        tmp <- getNewRegNat fmt+        let code dst+              = case offset of+                  CmmInt 0 _ -> valExp `appOL`+                                vecExp `snocOL`+                                (MOVHLPS FF64 vecReg tmp) `snocOL`+                                (MOVD II64 fmt (OpReg valReg) (OpReg dst)) `snocOL`+                                (PUNPCKLQDQ fmt (OpReg tmp) dst)+                  CmmInt 1 _ -> valExp `appOL`+                                vecExp `snocOL`+                                (MOVDQU fmt (OpReg vecReg) (OpReg dst)) `snocOL`+                                (MOVD II64 fmt (OpReg valReg) (OpReg tmp)) `snocOL`+                                (PUNPCKLQDQ fmt (OpReg tmp) dst)+                  _ -> pprPanic "MO_V_Insert Int64X2: unsupported offset" (ppr offset)+         in return $ Any fmt code+    vector_int64x2_insert_sse2 _ _ offset = pprPanic "MO_V_Insert Int64X2: unsupported offset" (pdoc platform offset)++getRegister' _ _ (CmmMachOp mop (_:_:_:_:_)) =+  pprPanic "getRegister(x86): MachOp with >= 4 arguments" (text $ show mop)++getRegister' platform is32Bit load@(CmmLoad mem ty _)+  | isVecType ty+  = do+    config <- getConfig+    Amode addr mem_code <- getAmode mem+    let code dst =+          mem_code `snocOL`+            movInstr config format (OpAddr addr) (OpReg dst)+    return (Any format code)+  | isFloatType ty+  = do+    Amode addr mem_code <- getAmode mem+    loadAmode (floatFormat width) addr mem_code++  | is32Bit && not (isWord64 ty)+  = do+    let+      instr = case width of+                W8     -> MOVZxL II8+                  -- We always zero-extend 8-bit loads, if we+                  -- can't think of anything better.  This is because+                  -- we can't guarantee access to an 8-bit variant of every register+                  -- (esi and edi don't have 8-bit variants), so to make things+                  -- simpler we do our 8-bit arithmetic with full 32-bit registers.+                _other -> MOV format+    code <- intLoadCode instr mem+    return (Any format code)++  | not is32Bit+  -- Simpler memory load code on x86_64+  = do+    code <- intLoadCode (MOV format) mem+    return (Any format code)++  | otherwise+  = pprPanic "getRegister(x86) CmmLoad" (pdoc platform load)+  where+    format = cmmTypeFormat ty+    width = typeWidth ty++-- Handle symbol references with LEA and %rip-relative addressing.+-- See Note [%rip-relative addressing on x86-64].+getRegister' platform is32Bit (CmmLit lit)+  | is_label lit+  , not is32Bit+  = do let format = cmmTypeFormat (cmmLitType platform lit)+           imm = litToImm lit+           op = OpAddr (AddrBaseIndex EABaseRip EAIndexNone imm)+           code dst = unitOL (LEA format op (OpReg dst))+       return (Any format code)+  where+    is_label (CmmLabel {})        = True+    is_label (CmmLabelOff {})     = True+    is_label (CmmLabelDiffOff {}) = True+    is_label _                    = False++getRegister' platform is32Bit (CmmLit lit) = do+  avx <- avxEnabled++  -- NB: it is important that the code produced here (to load a literal into+  -- a register) doesn't clobber any registers other than the destination+  -- register; the code for generating C calls relies on this property.+  --+  -- In particular, we have:+  --+  -- > loadIntoRegMightClobberOtherReg (CmmLit _) = False+  --+  -- which means that we assume that loading a literal into a register+  -- will not clobber any other registers.++  -- TODO: this function mishandles floating-point negative zero,+  -- because -0.0 == 0.0 returns True and because we represent CmmFloat as+  -- Rational, which can't properly represent negative zero.++  if+    -- Zero: use XOR.+    | isZeroLit lit+    -> let code dst+             | isIntFormat fmt+             = let fmt'+                     | is32Bit+                     = fmt+                     | otherwise+                     -- x86_64: 32-bit xor is one byte shorter,+                     -- and zero-extends to 64 bits+                     = case fmt of+                         II64 -> II32+                         _ -> fmt+               in unitOL (XOR fmt' (OpReg dst) (OpReg dst))+             | avx+             = if float_or_floatvec+               then unitOL (VXOR fmt (OpReg dst) dst dst)+               else unitOL (VPXOR fmt dst dst dst)+             | otherwise+             = if float_or_floatvec+               then unitOL (XOR fmt (OpReg dst) (OpReg dst))+               else unitOL (PXOR fmt (OpReg dst) dst)+       in return $ Any fmt code++    -- Constant vector: use broadcast.+    | VecFormat l sFmt <- fmt+    , CmmVec (f:fs) <- lit+    , all (== f) fs+    -> do let w = scalarWidth sFmt+              broadcast = if isFloatScalarFormat sFmt+                          then MO_VF_Broadcast l w+                          else MO_V_Broadcast l w+          valCode <- getAnyReg (CmmMachOp broadcast [CmmLit f])+          return $ Any fmt valCode++    -- Optimisation for loading small literals on x86_64: take advantage+    -- of the automatic zero-extension from 32 to 64 bits, because the 32-bit+    -- instruction forms are shorter.+    | not is32Bit, isWord64 cmmTy, not (isBigLit lit)+    -> let+          imm = litToImm lit+          code dst = unitOL (MOV II32 (OpImm imm) (OpReg dst))+      in+          return (Any II64 code)++    -- Scalar integer: use an immediate.+    | isIntFormat fmt+    -> let imm = litToImm lit+           code dst = unitOL (MOV fmt (OpImm imm) (OpReg dst))+       in return (Any fmt code)++    -- General case: load literal from data address.+    | otherwise+    -> do let w = formatToWidth fmt+          Amode addr addr_code <- memConstant (mkAlignment $ widthInBytes w) lit+          loadAmode fmt addr addr_code++    where+      cmmTy = cmmLitType platform lit+      fmt = cmmTypeFormat cmmTy+      float_or_floatvec = isFloatOrFloatVecFormat fmt+      isZeroLit (CmmInt i _) = i == 0+      isZeroLit (CmmFloat f _) = f == 0 -- TODO: mishandles negative zero+      isZeroLit (CmmVec fs) = all isZeroLit fs+      isZeroLit _ = False++      isBigLit (CmmInt i _) = i < 0 || i > 0xffffffff+      isBigLit _ = False+        -- note1: not the same as (not.is32BitLit), because that checks for+        -- signed literals that fit in 32 bits, but we want unsigned+        -- literals here.+        -- note2: all labels are small, because we're assuming the+        -- small memory model. See Note [%rip-relative addressing on x86-64].++getRegister' platform _ slot@(CmmStackSlot {}) =+  pprPanic "getRegister(x86) CmmStackSlot" (pdoc platform slot)++intLoadCode :: (Operand -> Operand -> Instr) -> CmmExpr+   -> NatM (Reg -> InstrBlock)+intLoadCode instr mem = do+  Amode src mem_code <- getAmode mem+  return (\dst -> mem_code `snocOL` instr (OpAddr src) (OpReg dst))++-- Compute an expression into *any* register, adding the appropriate+-- move instruction if necessary.+getAnyReg :: HasDebugCallStack => CmmExpr -> NatM (Reg -> InstrBlock)+getAnyReg expr = do+  r <- getRegister expr+  anyReg r++anyReg :: HasDebugCallStack => Register -> NatM (Reg -> InstrBlock)+anyReg (Any _ code)          = return code+anyReg (Fixed rep reg fcode) = do+  config <- getConfig+  return (\dst -> fcode `snocOL` mkRegRegMoveInstr config rep reg dst)++-- A bit like getSomeReg, but we want a reg that can be byte-addressed.+-- Fixed registers might not be byte-addressable, so we make sure we've+-- got a temporary, inserting an extra reg copy if necessary.+getByteReg :: HasDebugCallStack => CmmExpr -> NatM (Reg, InstrBlock)+getByteReg expr = do+  config <- getConfig+  is32Bit <- is32BitPlatform+  if is32Bit+      then do r <- getRegister expr+              case r of+                Any rep code -> do+                    tmp <- getNewRegNat rep+                    return (tmp, code tmp)+                Fixed rep reg code+                    | isVirtualReg reg -> return (reg,code)+                    | otherwise -> do+                        tmp <- getNewRegNat rep+                        return (tmp, code `snocOL` mkRegRegMoveInstr config rep reg tmp)+                    -- ToDo: could optimise slightly by checking for+                    -- byte-addressable real registers, but that will+                    -- happen very rarely if at all.+      else getSomeReg expr -- all regs are byte-addressable on x86_64++-- Another variant: this time we want the result in a register that cannot+-- be modified by code to evaluate an arbitrary expression.+getNonClobberedReg :: HasDebugCallStack => CmmExpr -> NatM (Reg, InstrBlock)+getNonClobberedReg expr = do+  r <- getRegister expr+  config <- getConfig+  let platform = ncgPlatform config+  case r of+    Any rep code -> do+        tmp <- getNewRegNat rep+        return (tmp, code tmp)+    Fixed rep reg code+        -- only certain regs can be clobbered+        | reg `elem` instrClobberedRegs platform+        -> do+                tmp <- getNewRegNat rep+                return (tmp, code `snocOL` mkRegRegMoveInstr config rep reg tmp)+        | otherwise ->+                return (reg, code)++--------------------------------------------------------------------------------++-- | Convert a 'CmmExpr' representing a memory address into an 'Amode'.+--+-- An 'Amode' is a datatype representing a valid address form for the target+-- (e.g. "Base + Index + disp" or immediate) and the code to compute it.+getAmode :: CmmExpr -> NatM Amode+getAmode e = do+   platform <- getPlatform+   let is32Bit = target32Bit platform++   case e of+      CmmRegOff r n+         -> getAmode $ mangleIndexTree r n++      CmmMachOp (MO_Add W64) [CmmReg (CmmGlobal (GlobalRegUse PicBaseReg _)), CmmLit displacement]+         | not is32Bit+         -> return $ Amode (ripRel (litToImm displacement)) nilOL++      -- This is all just ridiculous, since it carefully undoes+      -- what mangleIndexTree has just done.+      CmmMachOp (MO_Sub _rep) [x, CmmLit lit@(CmmInt i _)]+         | is32BitLit platform lit+         -- assert (rep == II32)???+         -> do+            (x_reg, x_code) <- getSomeReg x+            let off = ImmInt (-(fromInteger i))+            return (Amode (AddrBaseIndex (EABaseReg x_reg) EAIndexNone off) x_code)++      CmmMachOp (MO_Add _rep) [x, CmmLit lit]+         | is32BitLit platform lit+         -- assert (rep == II32)???+         -> do+            (x_reg, x_code) <- getSomeReg x+            let off = litToImm lit+            return (Amode (AddrBaseIndex (EABaseReg x_reg) EAIndexNone off) x_code)++      -- Turn (lit1 << n  + lit2) into  (lit2 + lit1 << n) so it will be+      -- recognised by the next rule.+      CmmMachOp (MO_Add rep) [a@(CmmMachOp (MO_Shl _) _), b@(CmmLit _)]+         -> getAmode (CmmMachOp (MO_Add rep) [b,a])++      -- Matches: (x + offset) + (y << shift)+      CmmMachOp (MO_Add _) [CmmRegOff x offset, CmmMachOp (MO_Shl _) [y, CmmLit (CmmInt shift _)]]+         | shift == 0 || shift == 1 || shift == 2 || shift == 3+         -> x86_complex_amode (CmmReg x) y shift (fromIntegral offset)++      CmmMachOp (MO_Add _) [x, CmmMachOp (MO_Shl _) [y, CmmLit (CmmInt shift _)]]+         | shift == 0 || shift == 1 || shift == 2 || shift == 3+         -> x86_complex_amode x y shift 0++      CmmMachOp (MO_Add _) [x, CmmMachOp (MO_Add _) [CmmMachOp (MO_Shl _)+                                                    [y, CmmLit (CmmInt shift _)], CmmLit (CmmInt offset _)]]+         | shift == 0 || shift == 1 || shift == 2 || shift == 3+         && is32BitInteger offset+         -> x86_complex_amode x y shift offset++      CmmMachOp (MO_Add _) [x,y]+         | not (isLit y) -- we already handle valid literals above.+         -> x86_complex_amode x y 0 0++      CmmLit lit@(CmmFloat {})+        -> pprPanic "X86 CodeGen: attempt to use floating-point value as a memory address"+             (ppr lit)++      -- Handle labels with %rip-relative addressing since in general the image+      -- may be loaded anywhere in the 64-bit address space (e.g. on Windows+      -- with high-entropy ASLR). See Note [%rip-relative addressing on x86-64].+      CmmLit lit+         | not is32Bit+         , is_label lit+         -> return (Amode (AddrBaseIndex EABaseRip EAIndexNone (litToImm lit)) nilOL)++      CmmLit lit+         | is32BitLit platform lit+         -> return (Amode (ImmAddr (litToImm lit) 0) nilOL)++      -- Literal with offsets too big (> 32 bits) fails during the linking phase+      -- (#15570). We already handled valid literals above so we don't have to+      -- test anything here.+      CmmLit (CmmLabelOff l off)+         -> getAmode (CmmMachOp (MO_Add W64) [ CmmLit (CmmLabel l)+                                             , CmmLit (CmmInt (fromIntegral off) W64)+                                             ])+      CmmLit (CmmLabelDiffOff l1 l2 off w)+         -> getAmode (CmmMachOp (MO_Add W64) [ CmmLit (CmmLabelDiffOff l1 l2 0 w)+                                             , CmmLit (CmmInt (fromIntegral off) W64)+                                             ])++      -- in case we can't do something better, we just compute the expression+      -- and put the result in a register+      _ -> do+        (reg,code) <- getSomeReg e+        return (Amode (AddrBaseIndex (EABaseReg reg) EAIndexNone (ImmInt 0)) code)+  where+    is_label (CmmLabel{}) = True+    is_label (CmmLabelOff{}) = True+    is_label (CmmLabelDiffOff{}) = True+    is_label _ = False+++-- | Like 'getAmode', but on 32-bit use simple register addressing+-- (i.e. no index register). This stops us from running out of+-- registers on x86 when using instructions such as cmpxchg, which can+-- use up to three virtual registers and one fixed register.+getSimpleAmode :: CmmExpr -> NatM Amode+getSimpleAmode addr = is32BitPlatform >>= \case+  False -> getAmode addr+  True  -> do+    addr_code <- getAnyReg addr+    config <- getConfig+    addr_r <- getNewRegNat (intFormat (ncgWordWidth config))+    let amode = AddrBaseIndex (EABaseReg addr_r) EAIndexNone (ImmInt 0)+    return $! Amode amode (addr_code addr_r)++x86_complex_amode :: CmmExpr -> CmmExpr -> Integer -> Integer -> NatM Amode+x86_complex_amode base index shift offset+  = do (x_reg, x_code) <- getNonClobberedReg base+        -- x must be in a temp, because it has to stay live over y_code+        -- we could compare x_reg and y_reg and do something better here...+       (y_reg, y_code) <- getSomeReg index+       let+           code = x_code `appOL` y_code+           base = case shift of 0 -> 1; 1 -> 2; 2 -> 4; 3 -> 8;+                                n -> panic $ "x86_complex_amode: unhandled shift! (" ++ show n ++ ")"+       return (Amode (AddrBaseIndex (EABaseReg x_reg) (EAIndex y_reg base) (ImmInt (fromIntegral offset)))+               code)+++++-- -----------------------------------------------------------------------------+-- getOperand: sometimes any operand will do.++-- getNonClobberedOperand: the value of the operand will remain valid across+-- the computation of an arbitrary expression, unless the expression+-- is computed directly into a register which the operand refers to+-- (see trivialCode where this function is used for an example).++getNonClobberedOperand :: CmmExpr -> NatM (Operand, InstrBlock)+getNonClobberedOperand (CmmLit lit)+  | Just w <- isSuitableFloatingPointLit_maybe lit = do+    Amode addr code <- memConstant (mkAlignment $ widthInBytes w) lit+    return (OpAddr addr, code)+  | otherwise = do+    platform <- getPlatform+    if is32BitLit platform lit && isIntFormat (cmmTypeFormat (cmmLitType platform lit))+    then return (OpImm (litToImm lit), nilOL)+    else getNonClobberedOperand_generic (CmmLit lit)++getNonClobberedOperand (CmmLoad mem ty _) = do+  is32Bit <- is32BitPlatform+  -- this logic could be simplified+  -- TODO FIXME+  if   (if is32Bit then not (isWord64 ty) else True)+      -- if 32bit and ty is at float/double/simd value+      -- or if 64bit+      --  this could use some eyeballs or i'll need to stare at it more later+    then do+      platform <- ncgPlatform <$> getConfig+      Amode src mem_code <- getAmode mem+      (src',save_code) <-+        if (amodeCouldBeClobbered platform src)+                then do+                   tmp <- getNewRegNat (archWordFormat is32Bit)+                   return (AddrBaseIndex (EABaseReg tmp) EAIndexNone (ImmInt 0),+                           unitOL (LEA (archWordFormat is32Bit)+                                       (OpAddr src)+                                       (OpReg tmp)))+                else+                   return (src, nilOL)+      return (OpAddr src', mem_code `appOL` save_code)+    else+      -- if its a word or gcptr on 32bit?+      getNonClobberedOperand_generic (CmmLoad mem ty NaturallyAligned)++getNonClobberedOperand e = getNonClobberedOperand_generic e++getNonClobberedOperand_generic :: CmmExpr -> NatM (Operand, InstrBlock)+getNonClobberedOperand_generic e = do+  (reg, code) <- getNonClobberedReg e+  return (OpReg reg, code)++amodeCouldBeClobbered :: Platform -> AddrMode -> Bool+amodeCouldBeClobbered platform amode = any (regClobbered platform) (addrModeRegs amode)++regClobbered :: Platform -> Reg -> Bool+regClobbered platform (RegReal (RealRegSingle rr)) = freeReg platform rr+regClobbered _ _ = False++-- getOperand: the operand is not required to remain valid across the+-- computation of an arbitrary expression.+getOperand :: CmmExpr -> NatM (Operand, InstrBlock)++getOperand (CmmLit lit) = case isSuitableFloatingPointLit_maybe lit of+    Just w -> do+        Amode addr code <- memConstant (mkAlignment $ widthInBytes w) lit+        return (OpAddr addr, code)+    Nothing -> do+        platform <- getPlatform+        if is32BitLit platform lit && (isIntFormat $ cmmTypeFormat (cmmLitType platform lit))+            then return (OpImm (litToImm lit), nilOL)+            else getOperand_generic (CmmLit lit)++getOperand (CmmLoad mem ty _) = do+  is32Bit <- is32BitPlatform+  if isIntFormat (cmmTypeFormat ty) && (if is32Bit then not (isWord64 ty) else True)+     then do+       Amode src mem_code <- getAmode mem+       return (OpAddr src, mem_code)+     else+       getOperand_generic (CmmLoad mem ty NaturallyAligned)++getOperand e = getOperand_generic e++getOperand_generic :: CmmExpr -> NatM (Operand, InstrBlock)+getOperand_generic e = do+    (reg, code) <- getSomeReg e+    return (OpReg reg, code)++isOperand :: Platform -> CmmExpr -> Bool+isOperand _ (CmmLoad _ _ _) = True+isOperand platform (CmmLit lit)+                          = is32BitLit platform lit+                          || isSuitableFloatingPointLit lit+isOperand _ _            = False++-- | Given a 'Register', produce a new 'Register' with an instruction block+-- which will check the value for alignment. Used for @-falignment-sanitisation@.+addAlignmentCheck :: Int -> Register -> Register+addAlignmentCheck align reg =+    case reg of+      Fixed fmt reg code -> Fixed fmt reg (code `appOL` check fmt reg)+      Any fmt f          -> Any fmt (\reg -> f reg `appOL` check fmt reg)+  where+    check :: Format -> Reg -> InstrBlock+    check fmt reg =+        assert (isIntFormat fmt) $+        toOL [ TEST fmt (OpImm $ ImmInt $ align-1) (OpReg reg)+             , JXX_GBL NE $ ImmCLbl mkBadAlignmentLabel+             ]++memConstant :: Alignment -> CmmLit -> NatM Amode+memConstant align lit = do+  lbl <- getNewLabelNat+  let rosection = Section ReadOnlyData lbl+  config <- getConfig+  platform <- getPlatform+  (addr, addr_code) <- if target32Bit platform+                       then do dynRef <- cmmMakeDynamicReference+                                             config+                                             DataReference+                                             lbl+                               Amode addr addr_code <- getAmode dynRef+                               return (addr, addr_code)+                       else return (ripRel (ImmCLbl lbl), nilOL)+  let code =+        LDATA rosection (align, CmmStaticsRaw lbl [CmmStaticLit lit])+        `consOL` addr_code+  return (Amode addr code)++-- | Load the value at the given address into any register.+loadAmode :: Format -> AddrMode -> InstrBlock -> NatM Register+loadAmode fmt addr addr_code = do+  config <- getConfig+  let load dst = movInstr config fmt (OpAddr addr) (OpReg dst)+  return $ Any fmt (\ dst -> addr_code `snocOL` load dst)++-- if we want a floating-point literal as an operand, we can+-- use it directly from memory.  However, if the literal is+-- zero, we're better off generating it into a register using+-- xor.+isSuitableFloatingPointLit :: CmmLit -> Bool+isSuitableFloatingPointLit = isJust . isSuitableFloatingPointLit_maybe++isSuitableFloatingPointLit_maybe :: CmmLit -> Maybe Width+isSuitableFloatingPointLit_maybe (CmmFloat f w) = w <$ guard (f /= 0.0)+isSuitableFloatingPointLit_maybe _ = Nothing++getRegOrMem :: CmmExpr -> NatM (Operand, InstrBlock)+getRegOrMem e@(CmmLoad mem ty _) = do+  is32Bit <- is32BitPlatform+  if isIntFormat (cmmTypeFormat ty) && (if is32Bit then not (isWord64 ty) else True)+     then do+       Amode src mem_code <- getAmode mem+       return (OpAddr src, mem_code)+     else do+       (reg, code) <- getNonClobberedReg e+       return (OpReg reg, code)+getRegOrMem e = do+    (reg, code) <- getNonClobberedReg e+    return (OpReg reg, code)++is32BitLit :: Platform -> CmmLit -> Bool+is32BitLit platform _lit+   | target32Bit platform = True+is32BitLit platform lit =+   case lit of+      CmmInt i W64              -> is32BitInteger i+      -- Except on Windows, assume that labels are in the range 0-2^31-1: this+      -- assumes the small memory model. Note [%rip-relative addressing on+      -- x86-64].+      CmmLabel _                -> low_image+      -- however we can't assume that label offsets are in this range+      -- (see #15570)+      CmmLabelOff _ off         -> low_image && is32BitInteger (fromIntegral off)+      CmmLabelDiffOff _ _ off _ -> low_image && is32BitInteger (fromIntegral off)+      _                         -> True+  where+    -- Is the executable image certain to be located below 4GB? As noted in+    -- Note [%rip-relative addressing on x86-64], this is not true on Windows.+    low_image =+      case platformOS platform of+        OSMinGW32 -> False   -- See Note [%rip-relative addressing on x86-64]+        _         -> True+++-- Set up a condition code for a conditional branch.++getCondCode :: CmmExpr -> NatM CondCode++-- yes, they really do seem to want exactly the same!++getCondCode (CmmMachOp mop [x, y])+  =+    case mop of+      MO_F_Eq W32 -> condFltCode EQQ x y+      MO_F_Ne W32 -> condFltCode NE  x y+      MO_F_Gt W32 -> condFltCode GTT x y+      MO_F_Ge W32 -> condFltCode GE  x y+      -- Invert comparison condition and swap operands+      -- See Note [SSE Parity Checks]+      MO_F_Lt W32 -> condFltCode GTT  y x+      MO_F_Le W32 -> condFltCode GE   y x++      MO_F_Eq W64 -> condFltCode EQQ x y+      MO_F_Ne W64 -> condFltCode NE  x y+      MO_F_Gt W64 -> condFltCode GTT x y+      MO_F_Ge W64 -> condFltCode GE  x y+      MO_F_Lt W64 -> condFltCode GTT y x+      MO_F_Le W64 -> condFltCode GE  y x++      _ -> condIntCode (machOpToCond mop) x y++getCondCode other = do+   platform <- getPlatform+   pprPanic "getCondCode(2)(x86,x86_64)" (pdoc platform other)++machOpToCond :: MachOp -> Cond+machOpToCond mo = case mo of+  MO_Eq _   -> EQQ+  MO_Ne _   -> NE+  MO_S_Gt _ -> GTT+  MO_S_Ge _ -> GE+  MO_S_Lt _ -> LTT+  MO_S_Le _ -> LE+  MO_U_Gt _ -> GU+  MO_U_Ge _ -> GEU+  MO_U_Lt _ -> LU+  MO_U_Le _ -> LEU+  _other -> pprPanic "machOpToCond" (pprMachOp mo)++{-  Note [64-bit integer comparisons on 32-bit]+    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++    When doing these comparisons there are 2 kinds of+    comparisons.++    * Comparison for equality (or lack thereof)++    We use xor to check if high/low bits are+    equal. Then combine the results using or.++    * Other comparisons:++    We first compare the low registers+    and use a subtraction with borrow to compare the high registers.++    For signed numbers the condition is determined by+    the sign and overflow flags agreeing or not+    and for unsigned numbers the condition is the carry flag.++-}++-- @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be+-- passed back up the tree.++condIntCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode+condIntCode cond x y = do platform <- getPlatform+                          condIntCode' platform cond x y++condIntCode' :: Platform -> Cond -> CmmExpr -> CmmExpr -> NatM CondCode++-- 64-bit integer comparisons on 32-bit+-- See Note [64-bit integer comparisons on 32-bit]+condIntCode' platform cond x y+  | target32Bit platform && isWord64 (cmmExprType platform x) = do++  RegCode64 code1 r1hi r1lo <- iselExpr64 x+  RegCode64 code2 r2hi r2lo <- iselExpr64 y++  -- we mustn't clobber r1/r2 so we use temporaries+  tmp1 <- getNewRegNat II32+  tmp2 <- getNewRegNat II32++  let (cond', cmpCode) = intComparison cond r1hi r1lo r2hi r2lo tmp1 tmp2+  return $ CondCode False cond' (code1 `appOL` code2 `appOL` cmpCode)++  where+    intComparison cond r1_hi r1_lo r2_hi r2_lo tmp1 tmp2 =+      case cond of+        -- These don't occur as argument of condIntCode'+        ALWAYS  -> panic "impossible"+        NEG     -> panic "impossible"+        POS     -> panic "impossible"+        CARRY   -> panic "impossible"+        OFLO    -> panic "impossible"+        PARITY  -> panic "impossible"+        NOTPARITY -> panic "impossible"+        -- Special case #1 x == y and x != y+        EQQ -> (EQQ, cmpExact)+        NE  -> (NE, cmpExact)+        -- [x >= y]+        GE  -> (GE, cmpGE)+        GEU -> (GEU, cmpGE)+        -- [x >  y]+        GTT -> (LTT, cmpLE)+        GU  -> (LU, cmpLE)+        -- [x <= y]+        LE  -> (GE, cmpLE)+        LEU -> (GEU, cmpLE)+        -- [x <  y]+        LTT -> (LTT, cmpGE)+        LU  -> (LU, cmpGE)+      where+        cmpExact :: OrdList Instr+        cmpExact =+          toOL+            [ MOV II32 (OpReg r1_hi) (OpReg tmp1)+            , MOV II32 (OpReg r1_lo) (OpReg tmp2)+            , XOR II32 (OpReg r2_hi) (OpReg tmp1)+            , XOR II32 (OpReg r2_lo) (OpReg tmp2)+            , OR  II32 (OpReg tmp1)  (OpReg tmp2)+            ]+        cmpGE = toOL+            [ MOV II32 (OpReg r1_hi) (OpReg tmp1)+            , CMP II32 (OpReg r2_lo) (OpReg r1_lo)+            , SBB II32 (OpReg r2_hi) (OpReg tmp1)+            ]+        cmpLE = toOL+            [ MOV II32 (OpReg r2_hi) (OpReg tmp1)+            , CMP II32 (OpReg r1_lo) (OpReg r2_lo)+            , SBB II32 (OpReg r1_hi) (OpReg tmp1)+            ]++-- memory vs immediate+condIntCode' platform cond (CmmLoad x ty _) (CmmLit lit)+ | is32BitLit platform lit = do+    Amode x_addr x_code <- getAmode x+    let+        imm  = litToImm lit+        code = x_code `snocOL`+                  CMP (cmmTypeFormat ty) (OpImm imm) (OpAddr x_addr)+    --+    return (CondCode False cond code)++-- anything vs zero, using a mask+-- TODO: Add some sanity checking!!!!+condIntCode' platform cond (CmmMachOp (MO_And _) [x,o2]) (CmmLit (CmmInt 0 ty))+    | (CmmLit lit@(CmmInt mask _)) <- o2, is32BitLit platform lit+    = do+      (x_reg, x_code) <- getSomeReg x+      let+         code = x_code `snocOL`+                TEST (intFormat ty) (OpImm (ImmInteger mask)) (OpReg x_reg)+      --+      return (CondCode False cond code)++-- anything vs zero+condIntCode' _ cond x (CmmLit (CmmInt 0 ty)) = do+    (x_reg, x_code) <- getSomeReg x+    let+        code = x_code `snocOL`+                  TEST (intFormat ty) (OpReg x_reg) (OpReg x_reg)+    --+    return (CondCode False cond code)++-- anything vs operand+condIntCode' platform cond x y+ | isOperand platform y = do+    (x_reg, x_code) <- getNonClobberedReg x+    (y_op,  y_code) <- getOperand y+    let+        code = x_code `appOL` y_code `snocOL`+                  CMP (cmmTypeFormat (cmmExprType platform x)) y_op (OpReg x_reg)+    return (CondCode False cond code)+-- operand vs. anything: invert the comparison so that we can use a+-- single comparison instruction.+ | isOperand platform x+ , Just revcond <- maybeFlipCond cond = do+    (y_reg, y_code) <- getNonClobberedReg y+    (x_op,  x_code) <- getOperand x+    let+        code = y_code `appOL` x_code `snocOL`+                  CMP (cmmTypeFormat (cmmExprType platform x)) x_op (OpReg y_reg)+    return (CondCode False revcond code)++-- anything vs anything+condIntCode' platform cond x y = do+  (y_reg, y_code) <- getNonClobberedReg y+  (x_op, x_code) <- getRegOrMem x+  let+        code = y_code `appOL`+               x_code `snocOL`+                  CMP (cmmTypeFormat (cmmExprType platform x)) (OpReg y_reg) x_op+  return (CondCode False cond code)++++--------------------------------------------------------------------------------+condFltCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode++condFltCode cond x y+  =  condFltCode_sse2+  where+++  -- in the SSE2 comparison ops (ucomiss, ucomisd) the left arg may be+  -- an operand, but the right must be a reg.  We can probably do better+  -- than this general case...+  condFltCode_sse2 = do+    platform <- getPlatform+    (x_reg, x_code) <- getNonClobberedReg x+    (y_op, y_code) <- getOperand y+    let+        code = x_code `appOL`+               y_code `snocOL`+                  CMP (floatFormat $ cmmExprWidth platform x) y_op (OpReg x_reg)+        -- NB(1): we need to use the unsigned comparison operators on the+        -- result of this comparison.+    return (CondCode True (condToUnsigned cond) code)++-- -----------------------------------------------------------------------------+-- Generating assignments++-- Assignments are really at the heart of the whole code generation+-- business.  Almost all top-level nodes of any real importance are+-- assignments, which correspond to loads, stores, or register+-- transfers.  If we're really lucky, some of the register transfers+-- will go away, because we can use the destination register to+-- complete the code generation for the right hand side.  This only+-- fails when the right hand side is forced into a fixed register+-- (e.g. the result of a call).++assignMem_IntCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock+assignReg_IntCode ::           CmmReg  -> CmmExpr -> NatM InstrBlock++assignMem_FltCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock+assignReg_FltCode ::           CmmReg  -> CmmExpr -> NatM InstrBlock++assignMem_VecCode :: Format -> CmmExpr -> CmmExpr -> NatM InstrBlock+assignReg_VecCode ::           CmmReg  -> CmmExpr -> NatM InstrBlock++-- integer assignment to memory++-- specific case of adding/subtracting an integer to a particular address.+-- ToDo: catch other cases where we can use an operation directly on a memory+-- address.+assignMem_IntCode ty addr (CmmMachOp op [CmmLoad addr2 _ _,+                                                 CmmLit (CmmInt i _)])+   | addr == addr2, ty /= II64 || is32BitInteger i,+     Just instr <- check op+   = do Amode amode code_addr <- getAmode addr+        let code = code_addr `snocOL`+                   instr ty (OpImm (ImmInt (fromIntegral i))) (OpAddr amode)+        return code+   where+        check (MO_Add _) = Just ADD+        check (MO_Sub _) = Just SUB+        check _ = Nothing+        -- ToDo: more?++-- general case+assignMem_IntCode ty addr src = do+    platform <- getPlatform+    Amode addr code_addr <- getAmode addr+    (code_src, op_src)   <- get_op_RI platform src+    let+        code = code_src `appOL`+               code_addr `snocOL`+                  MOV ty op_src (OpAddr addr)+        -- NOTE: op_src is stable, so it will still be valid+        -- after code_addr.  This may involve the introduction+        -- of an extra MOV to a temporary register, but we hope+        -- the register allocator will get rid of it.+    --+    return code+  where+    get_op_RI :: Platform -> CmmExpr -> NatM (InstrBlock,Operand)   -- code, operator+    get_op_RI platform (CmmLit lit) | is32BitLit platform lit+      = return (nilOL, OpImm (litToImm lit))+    get_op_RI _ op+      = do (reg,code) <- getNonClobberedReg op+           return (code, OpReg reg)+++-- Assign; dst is a reg, rhs is mem+assignReg_IntCode reg (CmmLoad src _ _) = do+  let ty = cmmTypeFormat $ cmmRegType reg+  load_code <- intLoadCode (MOV ty) src+  platform <- ncgPlatform <$> getConfig+  return (load_code (getRegisterReg platform reg))++-- dst is a reg, but src could be anything+assignReg_IntCode reg src = do+  platform <- ncgPlatform <$> getConfig+  code <- getAnyReg src+  return (code (getRegisterReg platform reg))+++-- Floating point assignment to memory+assignMem_FltCode ty addr src = do+  (src_reg, src_code) <- getNonClobberedReg src+  Amode addr addr_code <- getAmode addr+  let+        code = src_code `appOL`+               addr_code `snocOL`+               MOV ty (OpReg src_reg) (OpAddr addr)++  return code++-- Floating point assignment to a register/temporary+assignReg_FltCode reg src = do+  src_code <- getAnyReg src+  platform <- ncgPlatform <$> getConfig+  return (src_code (getRegisterReg platform reg))++-- Vector assignment to a register/temporary+assignMem_VecCode ty addr src = do+  (src_reg, src_code) <- getNonClobberedReg src+  Amode addr addr_code <- getAmode addr+  config <- getConfig+  let+    code = src_code `appOL`+           addr_code `snocOL`+           movInstr config ty (OpReg src_reg) (OpAddr addr)+  return code++assignReg_VecCode reg src = do+  platform <- ncgPlatform <$> getConfig+  src_code <- getAnyReg src+  return (src_code (getRegisterReg platform reg))++genJump :: CmmExpr{-the branch target-} -> [RegWithFormat] -> NatM InstrBlock++genJump (CmmLoad mem _ _) regs = do+  Amode target code <- getAmode mem+  return (code `snocOL` JMP (OpAddr target) regs)++genJump (CmmLit lit) regs =+  return (unitOL (JMP (OpImm (litToImm lit)) regs))++genJump expr regs = do+  (reg,code) <- getSomeReg expr+  return (code `snocOL` JMP (OpReg reg) regs)+++-- -----------------------------------------------------------------------------+--  Unconditional branches++genBranch :: BlockId -> InstrBlock+genBranch = toOL . mkJumpInstr++++-- -----------------------------------------------------------------------------+--  Conditional jumps/branches++{-+Conditional jumps are always to local labels, so we can use branch+instructions.  We peek at the arguments to decide what kind of+comparison to do.++I386: First, we have to ensure that the condition+codes are set according to the supplied comparison operation.+-}++genCondBranch+    :: BlockId      -- the source of the jump+    -> BlockId      -- the true branch target+    -> BlockId      -- the false branch target+    -> CmmExpr      -- the condition on which to branch+    -> NatM InstrBlock -- Instructions++genCondBranch bid id false expr = do+  is32Bit <- is32BitPlatform+  genCondBranch' is32Bit bid id false expr++-- | We return the instructions generated.+genCondBranch' :: Bool -> BlockId -> BlockId -> BlockId -> CmmExpr+               -> NatM InstrBlock++genCondBranch' _ bid id false bool = do+  CondCode is_float cond cond_code <- getCondCode bool+  if not is_float+    then+        return (cond_code `snocOL` JXX cond id `appOL` genBranch false)+    else do+        -- See Note [SSE Parity Checks]+        let jmpFalse = genBranch false+            code+                = case cond of+                  NE  -> or_unordered+                  GU  -> plain_test+                  GEU -> plain_test+                  -- Use ASSERT so we don't break releases if+                  -- LTT/LE creep in somehow.+                  LTT ->+                    assertPpr False (text "Should have been turned into >")+                    and_ordered+                  LE  ->+                    assertPpr False (text "Should have been turned into >=")+                    and_ordered+                  _   -> and_ordered++            plain_test = unitOL (+                  JXX cond id+                ) `appOL` jmpFalse+            or_unordered = toOL [+                  JXX cond id,+                  JXX PARITY id+                ] `appOL` jmpFalse+            and_ordered = toOL [+                  JXX PARITY false,+                  JXX cond id,+                  JXX ALWAYS false+                ]+        updateCfgNat (\cfg -> adjustEdgeWeight cfg (+3) bid false)+        return (cond_code `appOL` code)++{-  Note [Introducing cfg edges inside basic blocks]+    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++    During instruction selection a statement `s`+    in a block B with control of the sort: B -> C+    will sometimes result in control+    flow of the sort:++            ┌ < ┐+            v   ^+      B ->  B1  ┴ -> C++    as is the case for some atomic operations.++    Now to keep the CFG in sync when introducing B1 we clearly+    want to insert it between B and C. However there is+    a catch when we have to deal with self loops.++    We might start with code and a CFG of these forms:++    loop:+        stmt1               ┌ < ┐+        ....                v   ^+        stmtX              loop ┘+        stmtY+        ....+        goto loop:++    Now we introduce B1:+                            ┌ ─ ─ ─ ─ ─┐+        loop:               │   ┌ <  ┐ │+        instrs              v   │    │ ^+        ....               loop ┴ B1 ┴ ┘+        instrsFromX+        stmtY+        goto loop:++    This is simple, all outgoing edges from loop now simply+    start from B1 instead and the code generator knows which+    new edges it introduced for the self loop of B1.++    Disaster strikes if the statement Y follows the same pattern.+    If we apply the same rule that all outgoing edges change then+    we end up with:++        loop ─> B1 ─> B2 ┬─┐+          │      │    └─<┤ │+          │      └───<───┘ │+          └───────<────────┘++    This is problematic. The edge B1->B1 is modified as expected.+    However the modification is wrong!++    The assembly in this case looked like this:++    _loop:+        <instrs>+    _B1:+        ...+        cmpxchgq ...+        jne _B1+        <instrs>+        <end _B1>+    _B2:+        ...+        cmpxchgq ...+        jne _B2+        <instrs>+        jmp loop++    There is no edge _B2 -> _B1 here. It's still a self loop onto _B1.++    The problem here is that really B1 should be two basic blocks.+    Otherwise we have control flow in the *middle* of a basic block.+    A contradiction!++    So to account for this we add yet another basic block marker:++    _B:+        <instrs>+    _B1:+        ...+        cmpxchgq ...+        jne _B1+        jmp _B1'+    _B1':+        <instrs>+        <end _B1>+    _B2:+        ...++    Now when inserting B2 we will only look at the outgoing edges of B1' and+    everything will work out nicely.++    You might also wonder why we don't insert jumps at the end of _B1'. There is+    no way another block ends up jumping to the labels _B1 or _B2 since they are+    essentially invisible to other blocks. View them as control flow labels local+    to the basic block if you'd like.++    Not doing this ultimately caused (part 2 of) #17334.+-}+++-- -----------------------------------------------------------------------------+--  Generating C calls++-- Now the biggest nightmare---calls.  Most of the nastiness is buried in+-- @get_arg@, which moves the arguments to the correct registers/stack+-- locations.  Apart from that, the code is easy.+--+-- (If applicable) Do not fill the delay slots here; you will confuse the+-- register allocator.+--+-- See Note [Keeping track of the current block] for information why we need+-- to take/return a block id.++genForeignCall+    :: ForeignTarget -- ^ function to call+    -> [CmmFormal]   -- ^ where to put the result+    -> [CmmActual]   -- ^ arguments (of mixed type)+    -> BlockId       -- ^ The block we are in+    -> NatM (InstrBlock, Maybe BlockId)++genForeignCall target dst args bid = do+  case target of+    PrimTarget prim         -> genPrim bid prim dst args+    ForeignTarget addr conv -> (,Nothing) <$> genCCall bid addr conv dst args++genPrim+    :: BlockId       -- ^ The block we are in+    -> CallishMachOp -- ^ MachOp+    -> [CmmFormal]   -- ^ where to put the result+    -> [CmmActual]   -- ^ arguments (of mixed type)+    -> NatM (InstrBlock, Maybe BlockId)++-- First we deal with cases which might introduce new blocks in the stream.+genPrim bid (MO_AtomicRMW width amop) [dst] [addr, n]+  = genAtomicRMW bid width amop dst addr n+genPrim bid (MO_Ctz width) [dst] [src]+  = genCtz bid width dst src++-- Then we deal with cases which not introducing new blocks in the stream.+genPrim bid prim dst args+  = (,Nothing) <$> genSimplePrim bid prim dst args++genSimplePrim+    :: BlockId       -- ^ the block we are in+    -> CallishMachOp -- ^ MachOp+    -> [CmmFormal]   -- ^ where to put the result+    -> [CmmActual]   -- ^ arguments (of mixed type)+    -> NatM InstrBlock+genSimplePrim bid (MO_Memcpy align)    []      [dst,src,n]    = genMemCpy  bid align dst src n+genSimplePrim bid (MO_Memmove align)   []      [dst,src,n]    = genMemMove bid align dst src n+genSimplePrim bid (MO_Memcmp align)    [res]   [dst,src,n]    = genMemCmp  bid align res dst src n+genSimplePrim bid (MO_Memset align)    []      [dst,c,n]      = genMemSet  bid align dst c n+genSimplePrim _   MO_AcquireFence      []      []             = return nilOL -- barriers compile to no code on x86/x86-64;+genSimplePrim _   MO_ReleaseFence      []      []             = return nilOL -- we keep it this long in order to prevent earlier optimisations.+genSimplePrim _   MO_SeqCstFence       []      []             = return $ unitOL MFENCE+genSimplePrim _   MO_Touch             []      [_]            = return nilOL+genSimplePrim _   (MO_Prefetch_Data n) []      [src]          = genPrefetchData n src+genSimplePrim _   (MO_BSwap width)     [dst]   [src]          = genByteSwap width dst src+genSimplePrim bid (MO_BRev width)      [dst]   [src]          = genBitRev bid width dst src+genSimplePrim bid (MO_PopCnt width)    [dst]   [src]          = genPopCnt bid width dst src+genSimplePrim bid (MO_Pdep width)      [dst]   [src,mask]     = genPdep bid width dst src mask+genSimplePrim bid (MO_Pext width)      [dst]   [src,mask]     = genPext bid width dst src mask+genSimplePrim bid (MO_Clz width)       [dst]   [src]          = genClz bid width dst src+genSimplePrim bid (MO_UF_Conv width)   [dst]   [src]          = genWordToFloat bid width dst src+genSimplePrim _   (MO_AtomicRead w mo)  [dst]  [addr]         = genAtomicRead w mo dst addr+genSimplePrim _   (MO_AtomicWrite w mo) []     [addr,val]     = genAtomicWrite w mo addr val+genSimplePrim bid (MO_Cmpxchg width)   [dst]   [addr,old,new] = genCmpXchg bid width dst addr old new+genSimplePrim _   (MO_Xchg width)      [dst]   [addr, value]  = genXchg width dst addr value+genSimplePrim _   (MO_AddWordC w)      [r,c]   [x,y]          = genAddSubRetCarry w ADD_CC (const Nothing) CARRY r c x y+genSimplePrim _   (MO_SubWordC w)      [r,c]   [x,y]          = genAddSubRetCarry w SUB_CC (const Nothing) CARRY r c x y+genSimplePrim _   (MO_AddIntC w)       [r,c]   [x,y]          = genAddSubRetCarry w ADD_CC (Just . ADD_CC) OFLO  r c x y+genSimplePrim _   (MO_SubIntC w)       [r,c]   [x,y]          = genAddSubRetCarry w SUB_CC (const Nothing) OFLO  r c x y+genSimplePrim _   (MO_Add2 w)          [h,l]   [x,y]          = genAddWithCarry w h l x y+genSimplePrim _   (MO_U_Mul2 w)        [h,l]   [x,y]          = genUnsignedLargeMul w h l x y+genSimplePrim _   (MO_S_Mul2 w)        [c,h,l] [x,y]          = genSignedLargeMul w c h l x y+genSimplePrim _   (MO_S_QuotRem w)     [q,r]   [x,y]          = genQuotRem w True  q r Nothing   x  y+genSimplePrim _   (MO_U_QuotRem w)     [q,r]   [x,y]          = genQuotRem w False q r Nothing   x  y+genSimplePrim _   (MO_U_QuotRem2 w)    [q,r]   [hx,lx,y]      = genQuotRem w False q r (Just hx) lx y+genSimplePrim _   MO_F32_Fabs          [dst]   [src]          = genFloatAbs W32 dst src+genSimplePrim _   MO_F64_Fabs          [dst]   [src]          = genFloatAbs W64 dst src+genSimplePrim _   MO_F32_Sqrt          [dst]   [src]          = genFloatSqrt FF32 dst src+genSimplePrim _   MO_F64_Sqrt          [dst]   [src]          = genFloatSqrt FF64 dst src+genSimplePrim bid MO_F32_Sin           [dst]   [src]          = genLibCCall bid (fsLit "sinf") [dst] [src]+genSimplePrim bid MO_F32_Cos           [dst]   [src]          = genLibCCall bid (fsLit "cosf") [dst] [src]+genSimplePrim bid MO_F32_Tan           [dst]   [src]          = genLibCCall bid (fsLit "tanf") [dst] [src]+genSimplePrim bid MO_F32_Exp           [dst]   [src]          = genLibCCall bid (fsLit "expf") [dst] [src]+genSimplePrim bid MO_F32_ExpM1         [dst]   [src]          = genLibCCall bid (fsLit "expm1f") [dst] [src]+genSimplePrim bid MO_F32_Log           [dst]   [src]          = genLibCCall bid (fsLit "logf") [dst] [src]+genSimplePrim bid MO_F32_Log1P         [dst]   [src]          = genLibCCall bid (fsLit "log1pf") [dst] [src]+genSimplePrim bid MO_F32_Asin          [dst]   [src]          = genLibCCall bid (fsLit "asinf") [dst] [src]+genSimplePrim bid MO_F32_Acos          [dst]   [src]          = genLibCCall bid (fsLit "acosf") [dst] [src]+genSimplePrim bid MO_F32_Atan          [dst]   [src]          = genLibCCall bid (fsLit "atanf") [dst] [src]+genSimplePrim bid MO_F32_Sinh          [dst]   [src]          = genLibCCall bid (fsLit "sinhf") [dst] [src]+genSimplePrim bid MO_F32_Cosh          [dst]   [src]          = genLibCCall bid (fsLit "coshf") [dst] [src]+genSimplePrim bid MO_F32_Tanh          [dst]   [src]          = genLibCCall bid (fsLit "tanhf") [dst] [src]+genSimplePrim bid MO_F32_Pwr           [dst]   [x,y]          = genLibCCall bid (fsLit "powf")  [dst] [x,y]+genSimplePrim bid MO_F32_Asinh         [dst]   [src]          = genLibCCall bid (fsLit "asinhf") [dst] [src]+genSimplePrim bid MO_F32_Acosh         [dst]   [src]          = genLibCCall bid (fsLit "acoshf") [dst] [src]+genSimplePrim bid MO_F32_Atanh         [dst]   [src]          = genLibCCall bid (fsLit "atanhf") [dst] [src]+genSimplePrim bid MO_F64_Sin           [dst]   [src]          = genLibCCall bid (fsLit "sin") [dst] [src]+genSimplePrim bid MO_F64_Cos           [dst]   [src]          = genLibCCall bid (fsLit "cos") [dst] [src]+genSimplePrim bid MO_F64_Tan           [dst]   [src]          = genLibCCall bid (fsLit "tan") [dst] [src]+genSimplePrim bid MO_F64_Exp           [dst]   [src]          = genLibCCall bid (fsLit "exp") [dst] [src]+genSimplePrim bid MO_F64_ExpM1         [dst]   [src]          = genLibCCall bid (fsLit "expm1") [dst] [src]+genSimplePrim bid MO_F64_Log           [dst]   [src]          = genLibCCall bid (fsLit "log") [dst] [src]+genSimplePrim bid MO_F64_Log1P         [dst]   [src]          = genLibCCall bid (fsLit "log1p") [dst] [src]+genSimplePrim bid MO_F64_Asin          [dst]   [src]          = genLibCCall bid (fsLit "asin") [dst] [src]+genSimplePrim bid MO_F64_Acos          [dst]   [src]          = genLibCCall bid (fsLit "acos") [dst] [src]+genSimplePrim bid MO_F64_Atan          [dst]   [src]          = genLibCCall bid (fsLit "atan") [dst] [src]+genSimplePrim bid MO_F64_Sinh          [dst]   [src]          = genLibCCall bid (fsLit "sinh") [dst] [src]+genSimplePrim bid MO_F64_Cosh          [dst]   [src]          = genLibCCall bid (fsLit "cosh") [dst] [src]+genSimplePrim bid MO_F64_Tanh          [dst]   [src]          = genLibCCall bid (fsLit "tanh") [dst] [src]+genSimplePrim bid MO_F64_Pwr           [dst]   [x,y]          = genLibCCall bid (fsLit "pow")  [dst] [x,y]+genSimplePrim bid MO_F64_Asinh         [dst]   [src]          = genLibCCall bid (fsLit "asinh") [dst] [src]+genSimplePrim bid MO_F64_Acosh         [dst]   [src]          = genLibCCall bid (fsLit "acosh") [dst] [src]+genSimplePrim bid MO_F64_Atanh         [dst]   [src]          = genLibCCall bid (fsLit "atanh") [dst] [src]+genSimplePrim bid MO_SuspendThread     [tok]   [rs,i]         = genRTSCCall bid (fsLit "suspendThread") [tok] [rs,i]+genSimplePrim bid MO_ResumeThread      [rs]    [tok]          = genRTSCCall bid (fsLit "resumeThread") [rs] [tok]+genSimplePrim bid MO_I64_Quot          [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_quotInt64") [dst] [x,y]+genSimplePrim bid MO_I64_Rem           [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_remInt64") [dst] [x,y]+genSimplePrim bid MO_W64_Quot          [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_quotWord64") [dst] [x,y]+genSimplePrim bid MO_W64_Rem           [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_remWord64") [dst] [x,y]+genSimplePrim bid (MO_VS_Quot 16 W8)   [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_quotInt8X16") [dst] [x,y]+genSimplePrim bid (MO_VS_Quot 8 W16)   [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_quotInt16X8") [dst] [x,y]+genSimplePrim bid (MO_VS_Quot 4 W32)   [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_quotInt32X4") [dst] [x,y]+genSimplePrim bid (MO_VS_Quot 2 W64)   [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_quotInt64X2") [dst] [x,y]+genSimplePrim _   op@(MO_VS_Quot {})   _       _              = pprPanic "Unsupported vector instruction for the native code generator:" (pprCallishMachOp op)+genSimplePrim bid (MO_VS_Rem 16 W8)    [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_remInt8X16") [dst] [x,y]+genSimplePrim bid (MO_VS_Rem 8 W16)    [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_remInt16X8") [dst] [x,y]+genSimplePrim bid (MO_VS_Rem 4 W32)    [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_remInt32X4") [dst] [x,y]+genSimplePrim bid (MO_VS_Rem 2 W64)    [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_remInt64X2") [dst] [x,y]+genSimplePrim _   op@(MO_VS_Rem {})    _       _              = pprPanic "Unsupported vector instruction for the native code generator:" (pprCallishMachOp op)+genSimplePrim bid (MO_VU_Quot 16 W8)   [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_quotWord8X16") [dst] [x,y]+genSimplePrim bid (MO_VU_Quot 8 W16)   [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_quotWord16X8") [dst] [x,y]+genSimplePrim bid (MO_VU_Quot 4 W32)   [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_quotWord32X4") [dst] [x,y]+genSimplePrim bid (MO_VU_Quot 2 W64)   [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_quotWord64X2") [dst] [x,y]+genSimplePrim _   op@(MO_VU_Quot {})   _       _              = pprPanic "Unsupported vector instruction for the native code generator:" (pprCallishMachOp op)+genSimplePrim bid (MO_VU_Rem 16 W8)    [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_remWord8X16") [dst] [x,y]+genSimplePrim bid (MO_VU_Rem 8 W16)    [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_remWord16X8") [dst] [x,y]+genSimplePrim bid (MO_VU_Rem 4 W32)    [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_remWord32X4") [dst] [x,y]+genSimplePrim bid (MO_VU_Rem 2 W64)    [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_remWord64X2") [dst] [x,y]+genSimplePrim _   op@(MO_VU_Rem {})    _       _              = pprPanic "Unsupported vector instruction for the native code generator:" (pprCallishMachOp op)+genSimplePrim bid MO_I64X2_Min         [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_minInt64X2") [dst] [x,y]+genSimplePrim bid MO_I64X2_Max         [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_maxInt64X2") [dst] [x,y]+genSimplePrim bid MO_W64X2_Min         [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_minWord64X2") [dst] [x,y]+genSimplePrim bid MO_W64X2_Max         [dst]   [x,y]          = genPrimCCall bid (fsLit "hs_maxWord64X2") [dst] [x,y]+genSimplePrim _   op                   dst     args           = do+  platform <- ncgPlatform <$> getConfig+  pprPanic "genSimplePrim: unhandled primop" (ppr (pprCallishMachOp op, dst, fmap (pdoc platform) args))++{- Note [Evaluate C-call arguments before placing in destination registers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When producing code for C calls we must take care when placing arguments+in their final registers. Specifically, we must ensure that temporary register+usage due to evaluation of one argument does not clobber a register in which we+already placed a previous argument (e.g. as the code generation logic for+MO_Shl can clobber %rcx due to x86 instruction limitations).++This is precisely what happened in #18527. Consider this C--:++    (result::I64) = call "ccall" doSomething(_s2hp::I64, 2244, _s2hq::I64, _s2hw::I64 | (1 << _s2hz::I64));++Here we are calling the C function `doSomething` with three arguments, the last+involving a non-trivial expression involving MO_Shl. In this case the NCG could+naively generate the following assembly (where $tmp denotes some temporary+register and $argN denotes the register for argument N, as dictated by the+platform's calling convention):++    mov _s2hp, $arg1   # place first argument+    mov _s2hq, $arg2   # place second argument++    # Compute 1 << _s2hz+    mov _s2hz, %rcx+    shl %cl, $tmp++    # Compute (_s2hw | (1 << _s2hz))+    mov _s2hw, $arg3+    or $tmp, $arg3++    # Perform the call+    call func++This code is outright broken on Windows which assigns $arg1 to %rcx. This means+that the evaluation of the last argument clobbers the first argument.++To avoid this we use a rather awful hack: when producing code for a C call with+at least one non-trivial argument, we first evaluate all of the arguments into+local registers before moving them into their final calling-convention-defined+homes.  This is performed by 'evalArgs'. Here we define "non-trivial" to be an+expression which might contain a MachOp since these are the only cases which+might clobber registers. Furthermore, we use a conservative approximation of+this condition (only looking at the top-level of CmmExprs) to avoid spending+too much effort trying to decide whether we want to take the fast path.++Note that this hack *also* applies to calls to out-of-line PrimTargets (which+are lowered via a C call), which will ultimately end up in+genForeignCall{32,64}.+-}++-- | See Note [Evaluate C-call arguments before placing in destination registers]+evalArgs :: BlockId -> [CmmActual] -> NatM (InstrBlock, [CmmActual])+evalArgs bid actuals+  | any loadIntoRegMightClobberOtherReg actuals = do+      regs_blks <- mapM evalArg actuals+      return (concatOL $ map fst regs_blks, map snd regs_blks)+  | otherwise = return (nilOL, actuals)+  where++    evalArg :: CmmActual -> NatM (InstrBlock, CmmExpr)+    evalArg actual = do+        platform <- getPlatform+        lreg <- newLocalReg $ cmmExprType platform actual+        (instrs, bid1) <- stmtToInstrs bid $ CmmAssign (CmmLocal lreg) actual+        -- The above assignment shouldn't change the current block+        massert (isNothing bid1)+        return (instrs, CmmReg $ CmmLocal lreg)++    newLocalReg :: CmmType -> NatM LocalReg+    newLocalReg ty = LocalReg <$> getUniqueM <*> pure ty++-- | Might the code to put this expression into a register+-- clobber any other registers?+loadIntoRegMightClobberOtherReg :: CmmExpr -> Bool+loadIntoRegMightClobberOtherReg (CmmReg _)      = False+loadIntoRegMightClobberOtherReg (CmmRegOff _ _) = False+loadIntoRegMightClobberOtherReg (CmmLit _)      = False+  -- NB: this last 'False' is slightly risky, because the code for loading+  -- a literal into a register is not entirely trivial.+loadIntoRegMightClobberOtherReg _               = True++-- Note [DIV/IDIV for bytes]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~+-- IDIV reminder:+--   Size    Dividend   Divisor   Quotient    Remainder+--   byte    %ax         r/m8      %al          %ah+--   word    %dx:%ax     r/m16     %ax          %dx+--   dword   %edx:%eax   r/m32     %eax         %edx+--   qword   %rdx:%rax   r/m64     %rax         %rdx+--+-- We do a special case for the byte division because the current+-- codegen doesn't deal well with accessing %ah register (also,+-- accessing %ah in 64-bit mode is complicated because it cannot be an+-- operand of many instructions). So we just widen operands to 16 bits+-- and get the results from %al, %dl. This is not optimal, but a few+-- register moves are probably not a huge deal when doing division.+++-- | Generate C call to the given function in ghc-prim+genPrimCCall+  :: BlockId+  -> FastString+  -> [CmmFormal]+  -> [CmmActual]+  -> NatM InstrBlock+genPrimCCall bid lbl_txt dsts args = do+  config <- getConfig+  -- FIXME: we should use mkForeignLabel instead of mkCmmCodeLabel+  let lbl = mkCmmCodeLabel ghcInternalUnitId lbl_txt+  addr <- cmmMakeDynamicReference config CallReference lbl+  let conv = ForeignConvention CCallConv [] [] CmmMayReturn+  genCCall bid addr conv dsts args++-- | Generate C call to the given function in libc+genLibCCall+  :: BlockId+  -> FastString+  -> [CmmFormal]+  -> [CmmActual]+  -> NatM InstrBlock+genLibCCall bid lbl_txt dsts args = do+  config <- getConfig+  -- Assume we can call these functions directly, and that they're not in a dynamic library.+  -- TODO: Why is this ok? Under linux this code will be in libm.so+  --       Is it because they're really implemented as a primitive instruction by the assembler??  -- BL 2009/12/31+  let lbl = mkForeignLabel lbl_txt ForeignLabelInThisPackage IsFunction+  addr <- cmmMakeDynamicReference config CallReference lbl+  let conv = ForeignConvention CCallConv [] [] CmmMayReturn+  genCCall bid addr conv dsts args++-- | Generate C call to the given function in the RTS+genRTSCCall+  :: BlockId+  -> FastString+  -> [CmmFormal]+  -> [CmmActual]+  -> NatM InstrBlock+genRTSCCall bid lbl_txt dsts args = do+  config <- getConfig+  -- Assume we can call these functions directly, and that they're not in a dynamic library.+  let lbl = mkForeignLabel lbl_txt ForeignLabelInThisPackage IsFunction+  addr <- cmmMakeDynamicReference config CallReference lbl+  let conv = ForeignConvention CCallConv [] [] CmmMayReturn+  genCCall bid addr conv dsts args++-- | Generate a real C call to the given address with the given convention+genCCall+  :: BlockId+  -> CmmExpr+  -> ForeignConvention+  -> [CmmFormal]+  -> [CmmActual]+  -> NatM InstrBlock+genCCall bid addr conv@(ForeignConvention _ argHints _ _) dest_regs args = do+  platform <- getPlatform+  is32Bit <- is32BitPlatform+  let args_hints = zip args (argHints ++ repeat NoHint)+      prom_args = map (maybePromoteCArgToW32 platform) args_hints+  (instrs0, args') <- evalArgs bid prom_args+  instrs1 <- if is32Bit+    then genCCall32 addr conv dest_regs args'+    else genCCall64 addr conv dest_regs args'+  return (instrs0 `appOL` instrs1)++maybePromoteCArgToW32 :: Platform -> (CmmExpr, ForeignHint) -> CmmExpr+maybePromoteCArgToW32 platform (arg, hint)+ | wfrom < wto =+    -- As wto=W32, we only need to handle integer conversions,+    -- never Float -> Double.+    case hint of+      SignedHint -> CmmMachOp (MO_SS_Conv wfrom wto) [arg]+      _          -> CmmMachOp (MO_UU_Conv wfrom wto) [arg]+ | otherwise   = arg+ where+   ty = cmmExprType platform arg+   wfrom = typeWidth ty+   wto = W32++genCCall32 :: CmmExpr           -- ^ address of the function to call+           -> ForeignConvention -- ^ calling convention+           -> [CmmFormal]       -- ^ where to put the result+           -> [CmmActual]       -- ^ arguments (of mixed type)+           -> NatM InstrBlock+genCCall32 addr _conv dest_regs args = do+        config <- getConfig+        let platform = ncgPlatform config++            -- If the size is smaller than the word, we widen things (see maybePromoteCArg)+            arg_size_bytes :: CmmType -> Int+            arg_size_bytes ty = max (widthInBytes (typeWidth ty)) (widthInBytes (wordWidth platform))++            roundTo a x | x `mod` a == 0 = x+                        | otherwise = x + a - (x `mod` a)++            push_arg :: CmmActual {-current argument-}+                            -> NatM InstrBlock  -- code++            push_arg  arg -- we don't need the hints on x86+              | isWord64 arg_ty = do+                RegCode64 code r_hi r_lo <- iselExpr64 arg+                delta <- getDeltaNat+                setDeltaNat (delta - 8)+                return (       code `appOL`+                               toOL [PUSH II32 (OpReg r_hi), DELTA (delta - 4),+                                     PUSH II32 (OpReg r_lo), DELTA (delta - 8),+                                     DELTA (delta-8)]+                    )++              | isFloatType arg_ty || isVecType arg_ty = do+                (reg, code) <- getSomeReg arg+                delta <- getDeltaNat+                setDeltaNat (delta-size)+                return (code `appOL`+                                toOL [SUB II32 (OpImm (ImmInt size)) (OpReg esp),+                                      DELTA (delta-size),+                                      let addr = AddrBaseIndex (EABaseReg esp)+                                                                EAIndexNone+                                                                (ImmInt 0)+                                          format = cmmTypeFormat arg_ty+                                      in++                                       movInstr config format (OpReg reg) (OpAddr addr)++                                     ]+                               )++              | otherwise = do+                -- Arguments can be smaller than 32-bit, but we still use @PUSH+                -- II32@ - the usual calling conventions expect integers to be+                -- 4-byte aligned.+                massert ((typeWidth arg_ty) <= W32)+                (operand, code) <- getOperand arg+                delta <- getDeltaNat+                setDeltaNat (delta-size)+                return (code `snocOL`+                        PUSH II32 operand `snocOL`+                        DELTA (delta-size))++              where+                 arg_ty = cmmExprType platform arg+                 size = arg_size_bytes arg_ty -- Byte size++        let+            -- Align stack to 16n for calls, assuming a starting stack+            -- alignment of 16n - word_size on procedure entry. Which we+            -- maintain. See Note [Stack Alignment on X86] in rts/StgCRun.c.+            sizes               = map (arg_size_bytes . cmmExprType platform) (reverse args)+            raw_arg_size        = sum sizes + platformWordSizeInBytes platform+            arg_pad_size        = (roundTo 16 $ raw_arg_size) - raw_arg_size+            tot_arg_size        = raw_arg_size + arg_pad_size - platformWordSizeInBytes platform+++        delta0 <- getDeltaNat+        setDeltaNat (delta0 - arg_pad_size)++        push_codes <- mapM push_arg (reverse args)+        delta <- getDeltaNat+        massert (delta == delta0 - tot_arg_size)++        -- deal with static vs dynamic call targets+        callinsns <-+          case addr of+            CmmLit (CmmLabel lbl)+               -> return $ unitOL (CALL (Left fn_imm) [])+               where fn_imm = ImmCLbl lbl+            _+               -> do { (dyn_r, dyn_c) <- getSomeReg addr+                     ; massert (isWord32 (cmmExprType platform addr))+                     ; return $ dyn_c `snocOL` CALL (Right dyn_r) [] }+        let push_code+                | arg_pad_size /= 0+                = toOL [SUB II32 (OpImm (ImmInt arg_pad_size)) (OpReg esp),+                        DELTA (delta0 - arg_pad_size)]+                  `appOL` concatOL push_codes+                | otherwise+                = concatOL push_codes++            call = callinsns `appOL`+                   toOL (+                      (if tot_arg_size == 0 then [] else+                       [ADD II32 (OpImm (ImmInt tot_arg_size)) (OpReg esp)])+                      +++                      [DELTA delta0]+                   )+        setDeltaNat delta0++        let+            -- assign the results, if necessary+            assign_code []     = nilOL+            assign_code [dest]+              | isVecType ty+              = unitOL (mkRegRegMoveInstr config (cmmTypeFormat ty) xmm0 r_dest)+              | isFloatType ty =+                  -- we assume SSE2+                  let tmp_amode = AddrBaseIndex (EABaseReg esp)+                                                       EAIndexNone+                                                       (ImmInt 0)+                      fmt = floatFormat w+                         in toOL [ SUB II32 (OpImm (ImmInt b)) (OpReg esp),+                                   DELTA (delta0 - b),+                                   X87Store fmt  tmp_amode,+                                   -- X87Store only supported for the CDECL ABI+                                   -- NB: This code will need to be+                                   -- revisited once GHC does more work around+                                   -- SIGFPE f+                                   MOV fmt (OpAddr tmp_amode) (OpReg r_dest),+                                   ADD II32 (OpImm (ImmInt b)) (OpReg esp),+                                   DELTA delta0]+              | isWord64 ty    = toOL [MOV II32 (OpReg eax) (OpReg r_dest),+                                        MOV II32 (OpReg edx) (OpReg r_dest_hi)]+              | otherwise      = unitOL (MOV (intFormat w)+                                             (OpReg eax)+                                             (OpReg r_dest))+              where+                    ty = localRegType dest+                    w  = typeWidth ty+                    b  = widthInBytes w+                    r_dest_hi = getHiVRegFromLo r_dest+                    r_dest    = getLocalRegReg dest+            assign_code many = pprPanic "genForeignCall.assign_code - too many return values:" (ppr many)++        return (push_code `appOL`+                call `appOL`+                assign_code dest_regs)++genCCall64 :: CmmExpr           -- ^ address of function to call+           -> ForeignConvention -- ^ calling convention+           -> [CmmFormal]       -- ^ where to put the result+           -> [CmmActual]       -- ^ arguments (of mixed type)+           -> NatM InstrBlock+genCCall64 addr conv dest_regs args = do+    config <- getConfig+    let platform = ncgPlatform config+        word_size = platformWordSizeInBytes platform+        wordFmt = archWordFormat (target32Bit platform)++    -- Compute the code for loading arguments into registers,+    -- returning the leftover arguments that will need to be passed on the stack.+    --+    -- NB: the code for loading references to data into registers is computed+    -- later (in 'pushArgs'), because we don't yet know where the data will be+    -- placed (due to alignment requirements).+    LoadArgs+      { stackArgs       = proper_stack_args+      , stackDataArgs   = stack_data_args+      , usedRegs        = arg_regs_used+      , assignArgsCode  = assign_args_code+      }+      <- loadArgs config args++    let++    -- Pad all arguments and data passed on stack to align them properly.+        (stk_args_with_padding, args_aligned_16) =+          padStackArgs platform (proper_stack_args, stack_data_args)++    -- Align stack to 16n for calls, assuming a starting stack+    -- alignment of 16n - word_size on procedure entry. Which we+    -- maintain. See Note [Stack Alignment on X86] in rts/StgCRun.c+        need_realign_call = args_aligned_16+    align_call_code <-+      if need_realign_call+      then addStackPadding word_size+      else return nilOL++    -- Compute the code that pushes data to the stack, and also+    -- the code that loads references to that data into registers,+    -- when the data is passed by reference in a register.+    (load_data_refs, push_code) <-+      pushArgs config proper_stack_args stk_args_with_padding++    -- On Windows, leave stack space for the arguments that we are passing+    -- in registers (the so-called shadow space).+    let shadow_space =+          if platformOS platform == OSMinGW32+          then 8 * length (allArgRegs platform)+            -- NB: the shadow store is always 8 * 4 = 32 bytes large,+            -- i.e. the cumulative size of rcx, rdx, r8, r9 (see 'allArgRegs').+          else 0+    shadow_space_code <- addStackPadding shadow_space++    let total_args_size+          = shadow_space+          + sum (map (stackArgSpace platform) stk_args_with_padding)+        real_size =+          total_args_size + if need_realign_call then word_size else 0++    -- End of argument passing.+    --+    -- Next step: emit the appropriate call instruction.+    delta <- getDeltaNat++    let -- The System V AMD64 ABI requires us to set %al to the number of SSE2+        -- registers that contain arguments, if the called routine+        -- is a varargs function.  We don't know whether it's a+        -- varargs function or not, so we have to assume it is.+        --+        -- It's not safe to omit this assignment, even if the number+        -- of SSE2 regs in use is zero.  If %al is larger than 8+        -- on entry to a varargs function, seg faults ensue.+        nb_sse_regs_used = count (isFloatFormat . regWithFormat_format) arg_regs_used+        assign_eax_sse_regs+          = unitOL (MOV II32 (OpImm (ImmInt nb_sse_regs_used)) (OpReg eax))+          -- Note: we do this on Windows as well. It's not entirely clear why+          -- it's needed (the Windows X86_64 calling convention does not+          -- dictate it), but we get segfaults without it.+          --+          -- One test case exhibiting the issue is T20030_test1j;+          -- if you change this, make sure to run it in a loop for a while+          -- with at least -j8 to check.++        -- Live registers we are annotating the call instruction with+        arg_regs = [RegWithFormat eax wordFmt] ++ arg_regs_used++    -- deal with static vs dynamic call targets+    (callinsns,_cconv) <- case addr of+      CmmLit (CmmLabel lbl) ->+        return (unitOL (CALL (Left (ImmCLbl lbl)) arg_regs), conv)+      _ -> do+        (dyn_r, dyn_c) <- getSomeReg addr+        return (dyn_c `snocOL` CALL (Right dyn_r) arg_regs, conv)++    let call = callinsns `appOL`+               toOL (+                    -- Deallocate parameters after call for ccall+                  (if real_size==0 then [] else+                   [ADD (intFormat (platformWordWidth platform)) (OpImm (ImmInt real_size)) (OpReg esp)])+                  +++                  [DELTA (delta + real_size)]+               )+    setDeltaNat (delta + real_size)++    let+        -- assign the results, if necessary+        assign_code []     = nilOL+        assign_code [dest] =+          unitOL $+            mkRegRegMoveInstr config fmt reg r_dest+          where+            reg = if isIntFormat fmt then rax else xmm0+            fmt = cmmTypeFormat rep+            rep = localRegType dest+            r_dest = getRegisterReg platform (CmmLocal dest)+        assign_code _many = panic "genForeignCall.assign_code many"++    return (align_call_code     `appOL`+            push_code           `appOL`+            assign_args_code    `appOL`+            load_data_refs      `appOL`+            shadow_space_code   `appOL`+            assign_eax_sse_regs `appOL`+            call                `appOL`+            assign_code dest_regs)++-- -----------------------------------------------------------------------------+-- Loading arguments into registers for 64-bit C calls.++-- | Information needed to know how to pass arguments in a C call,+-- and in particular how to load them into registers.+data LoadArgs+  = LoadArgs+  -- | Arguments that should be passed on the stack+  { stackArgs     :: [RawStackArg]+  -- | Additional values to store onto the stack.+  , stackDataArgs :: [CmmExpr]+  -- | Which registers are we using for argument passing?+  , usedRegs      :: [RegWithFormat]+  -- | The code to assign arguments to registers used for argument passing.+  , assignArgsCode :: InstrBlock+  }+instance Semigroup LoadArgs where+  LoadArgs a1 d1 r1 j1 <> LoadArgs a2 d2 r2 j2+    = LoadArgs (a1 ++ a2) (d1 ++ d2) (r1 ++ r2) (j1 S.<> j2)+instance Monoid LoadArgs where+  mempty = LoadArgs [] [] [] nilOL++-- | An argument passed on the stack, either directly or by reference.+--+-- The padding information hasn't yet been computed (see 'StackArg').+data RawStackArg+  -- | Pass the argument on the stack directly.+  = RawStackArg { stackArgExpr :: CmmExpr }+  -- | Pass the argument by reference.+  | RawStackArgRef+    { stackRef :: StackRef+       -- ^ is the reference passed in a register, or on the stack?+    , stackRefArgSize :: Int+        -- ^ the size of the data pointed to+    }+  deriving ( Show )++-- | An argument passed on the stack, either directly or by reference,+-- with additional padding information.+data StackArg+  -- | Pass the argument on the stack directly.+  = StackArg+      { stackArgExpr :: CmmExpr+      , stackArgPadding :: Int+        -- ^ padding required (in bytes)+      }+  -- | Pass the argument by reference.+  | StackArgRef+     { stackRef :: StackRef+        -- ^ where the reference is passed+     , stackRefArgSize :: Int+        -- ^ the size of the data pointed to+     , stackRefArgPadding :: Int+       -- ^ padding of the data pointed to+       -- (the reference itself never requires padding)+     }+  deriving ( Show )++-- | Where is a reference to data on the stack passed?+data StackRef+  -- | In a register.+  = InReg Reg+  -- | On the stack.+  | OnStack+  deriving ( Eq, Ord, Show )++newtype Padding = Padding { paddingBytes :: Int }+  deriving ( Show, Eq, Ord )++-- | How much space does this 'StackArg' take up on the stack?+--+-- Only counts the "reference" part for references, not the data it points to.+stackArgSpace :: Platform -> StackArg -> Int+stackArgSpace platform = \case+  StackArg arg padding ->+    argSize platform arg + padding+  StackArgRef { stackRef = ref } ->+    case ref of+      InReg   {} -> 0+      OnStack {} -> 8++-- | Pad arguments, assuming we start aligned to a 16-byte boundary.+--+-- Returns padded arguments, together with whether we end up aligned+-- to a 16-byte boundary.+padStackArgs :: Platform+             -> ([RawStackArg], [CmmExpr])+             -> ([StackArg], Bool)+padStackArgs platform (args0, data_args0) =+  let+    -- Pad the direct args+    (args, align_16_mid) = pad_args True args0++    -- Pad the data section+    (data_args, align_16_end) = pad_args align_16_mid (map RawStackArg data_args0)++    -- Now figure out where the data is placed relative to the direct arguments,+    -- in order to resolve references.+    resolve_args :: [(RawStackArg, Padding)] -> [Padding] -> [StackArg]+    resolve_args [] _ = []+    resolve_args ((stk_arg, Padding pad):rest) pads =+      let (this_arg, pads') =+            case stk_arg of+              RawStackArg arg -> (StackArg arg pad, pads)+              RawStackArgRef ref size -> case pads of+                  Padding arg_pad : rest_pads ->+                    let arg = StackArgRef+                          { stackRef = ref+                          , stackRefArgSize = size+                          , stackRefArgPadding = arg_pad }+                    in (arg, rest_pads)+                  _ -> panic "padStackArgs: no padding info found for StackArgRef"+      in this_arg : resolve_args rest pads'++  in+    ( resolve_args args (fmap snd data_args) +++        [ case data_arg of+            RawStackArg arg -> StackArg arg pad+            RawStackArgRef {} -> panic "padStackArgs: reference in data section"+        | (data_arg, Padding pad) <- data_args+        ]+    , align_16_end )++  where+    pad_args :: Bool -> [RawStackArg] -> ([(RawStackArg, Padding)], Bool)+    pad_args aligned_16 [] = ([], aligned_16)+    pad_args aligned_16 (arg:args)+      | needed_alignment > 16+      -- We don't know if the stack is aligned to 8 (mod 32) or 24 (mod 32).+      -- This makes aligning the stack to a 32 or 64 byte boundary more+      -- complicated, in particular with DELTA.+      = sorry $ unlines+        [ "X86_86 C call: unsupported argument."+        , "  Alignment requirement: " ++ show needed_alignment ++ " bytes."+        , if platformOS platform == OSMinGW32+          then "  The X86_64 NCG does not (yet) support Windows C calls with 256/512 bit vectors."+          else "  The X86_64 NCG cannot (yet) pass 256/512 bit vectors on the stack for C calls."+        , "  Please use the LLVM backend (-fllvm)." ]+      | otherwise+      = let ( rest, final_align_16 ) = pad_args next_aligned_16 args+        in  ( (arg, Padding padding) : rest, final_align_16 )++      where+        needed_alignment = case arg of+          RawStackArg arg   -> argSize platform arg+          RawStackArgRef {} -> platformWordSizeInBytes platform+        padding+          | needed_alignment < 16 || aligned_16+          = 0+          | otherwise+          = 8+        next_aligned_16 = not ( aligned_16 && needed_alignment < 16 )++-- | Load arguments into available registers.+loadArgs :: NCGConfig -> [CmmExpr] -> NatM LoadArgs+loadArgs config args+  | platformOS platform == OSMinGW32+  = evalStateT (loadArgsWin config args) (allArgRegs platform)+  | otherwise+  = evalStateT (loadArgsSysV config args) (allIntArgRegs platform+                                          ,allFPArgRegs  platform)+  where+    platform = ncgPlatform config++-- | Load arguments into available registers (System V AMD64 ABI).+loadArgsSysV :: NCGConfig+             -> [CmmExpr]+             -> StateT ([Reg], [Reg]) NatM LoadArgs+loadArgsSysV _ [] = return mempty+loadArgsSysV config (arg:rest) = do+  (iregs, fregs) <- get+  -- No available registers: pass everything on the stack (shortcut).+  if null iregs && null fregs+  then return $+          LoadArgs+            { stackArgs       = map RawStackArg (arg:rest)+            , stackDataArgs   = []+            , assignArgsCode  = nilOL+            , usedRegs        = []+            }+  else do+    mbReg <-+      if+        | isIntFormat arg_fmt+        , ireg:iregs' <- iregs+        -> do put (iregs', fregs)+              return $ Just ireg+        | isFloatFormat arg_fmt || isVecFormat arg_fmt+        , freg:fregs' <- fregs+        -> do put (iregs, fregs')+              return $ Just freg+        | otherwise+        -> return Nothing+    this_arg <-+      case mbReg of+        Just reg -> do+          assign_code <- lift $ loadArgIntoReg arg reg+          return $+            LoadArgs+                { stackArgs       = [] -- passed in register+                , stackDataArgs   = []+                , assignArgsCode  = assign_code+                , usedRegs        = [RegWithFormat reg arg_fmt]+                }+        Nothing -> do+          return $+            -- No available register for this argument: pass it on the stack.+            LoadArgs+                { stackArgs       = [RawStackArg arg]+                , stackDataArgs   = []+                , assignArgsCode  = nilOL+                , usedRegs        = []+                }+    others <- loadArgsSysV config rest+    return $ this_arg S.<> others++  where+    platform = ncgPlatform config+    arg_fmt = cmmTypeFormat (cmmExprType platform arg)++-- | Compute all things that will need to be pushed to the stack.+--+-- On Windows, an argument passed by reference will require two pieces of data:+--+--  - the reference (returned in the first position)+--  - the actual data (returned in the second position)+computeWinPushArgs :: Platform -> [CmmExpr] -> ([RawStackArg], [CmmExpr])+computeWinPushArgs platform = go+  where+    go :: [CmmExpr] -> ([RawStackArg], [CmmExpr])+    go [] = ([], [])+    go (arg:args) =+      let+        arg_size = argSize platform arg+        (this_arg, add_this_arg)+          | arg_size > 8+          = ( RawStackArgRef OnStack arg_size, (arg :) )+          | otherwise+          = ( RawStackArg arg, id )+        (stk_args, stk_data) = go args+      in+        (this_arg:stk_args, add_this_arg stk_data)++-- | Load arguments into available registers (Windows C X64 calling convention).+loadArgsWin :: NCGConfig -> [CmmExpr] -> StateT [(Reg,Reg)] NatM LoadArgs+loadArgsWin _ [] = return mempty+loadArgsWin config (arg:rest) = do+  regs <- get+  case regs of+    reg:regs' -> do+      put regs'+      this_arg <- lift $ load_arg_win reg+      rest <- loadArgsWin config rest+      return $ this_arg S.<> rest+    [] -> do+      -- No more registers available: pass all (remaining) arguments on the stack.+      let (stk_args, data_args) = computeWinPushArgs platform (arg:rest)+      return $+        LoadArgs+          { stackArgs       = stk_args+          , stackDataArgs   = data_args+          , assignArgsCode  = nilOL+          , usedRegs        = []+          }+  where+    platform = ncgPlatform config+    arg_fmt = cmmTypeFormat $ cmmExprType platform arg+    load_arg_win (ireg, freg)+      | isVecFormat arg_fmt+       -- Vectors are passed by reference.+       -- See Note [The Windows X64 C calling convention].+      = do return $+             LoadArgs+                -- Pass the reference in a register,+                -- and the argument data on the stack.+                { stackArgs       = [RawStackArgRef (InReg ireg) (argSize platform arg)]+                , stackDataArgs   = [arg] -- we don't yet know where the data will reside,+                , assignArgsCode  = nilOL -- so we defer computing the reference and storing it+                                          -- in the register until later+                , usedRegs        = [RegWithFormat ireg II64]+                }+      | otherwise+      = do let arg_reg+                  | isFloatFormat arg_fmt+                  = freg+                  | otherwise+                  = ireg+           assign_code <- loadArgIntoReg arg arg_reg+           -- Recall that, for varargs, we must pass floating-point+           -- arguments in both fp and integer registers.+           let (assign_code', regs')+                | isFloatFormat arg_fmt =+                    ( assign_code `snocOL` MOVD FF64 II64 (OpReg freg) (OpReg ireg),+                      [ RegWithFormat freg FF64+                      , RegWithFormat ireg II64 ])+                | otherwise = (assign_code, [RegWithFormat ireg II64])+           return $+             LoadArgs+               { stackArgs       = [] -- passed in register+               , stackDataArgs   = []+               , assignArgsCode = assign_code'+               , usedRegs = regs'+               }++-- | Load an argument into a register.+--+-- Assumes that the expression does not contain any MachOps,+-- as per Note [Evaluate C-call arguments before placing in destination registers].+loadArgIntoReg :: CmmExpr -> Reg -> NatM InstrBlock+loadArgIntoReg arg reg = do+  when (debugIsOn && loadIntoRegMightClobberOtherReg arg) $ do+    platform <- getPlatform+    massertPpr False $+      vcat [ text "loadArgIntoReg: arg might contain MachOp"+           , text "arg:" <+> pdoc platform arg ]+  arg_code <- getAnyReg arg+  return $ arg_code reg++-- -----------------------------------------------------------------------------+-- Pushing arguments onto the stack for 64-bit C calls.++-- | The size of an argument (in bytes).+--+-- Never smaller than the platform word width.+argSize :: Platform -> CmmExpr -> Int+argSize platform arg =+  max (platformWordSizeInBytes platform) $+    widthInBytes (typeWidth $ cmmExprType platform arg)++-- | Add the given amount of padding on the stack.+addStackPadding :: Int -- ^ padding (in bytes)+                -> NatM InstrBlock+addStackPadding pad_bytes+  | pad_bytes == 0+  = return nilOL+  | otherwise+  = do delta <- getDeltaNat+       setDeltaNat (delta - pad_bytes)+       return $+         toOL [ SUB II64 (OpImm (ImmInt pad_bytes)) (OpReg rsp)+              , DELTA (delta - pad_bytes)+              ]++-- | Push one argument directly to the stack (by value).+--+-- Assumes the current stack pointer fulfills any necessary alignment requirements.+pushArgByValue :: NCGConfig -> CmmExpr -> NatM InstrBlock+pushArgByValue config arg+   -- For 64-bit integer arguments, use PUSH II64.+   --+   -- Note: we *must not* do this for smaller arguments.+   -- For example, if we tried to push an argument such as @CmmLoad addr W32 aln@,+   -- we could end up reading unmapped memory and segfaulting.+   | isIntFormat fmt+   , formatInBytes fmt == 8+   = do+     (arg_op, arg_code) <- getOperand arg+     delta <- getDeltaNat+     setDeltaNat (delta-arg_size)+     return $+       arg_code `appOL` toOL+       [ PUSH II64 arg_op+       , DELTA (delta-arg_size) ]++   | otherwise+   = do+     (arg_reg, arg_code) <- getSomeReg arg+     delta <- getDeltaNat+     setDeltaNat (delta-arg_size)+     return $ arg_code `appOL` toOL+        [ SUB (intFormat (wordWidth platform)) (OpImm (ImmInt arg_size)) (OpReg rsp)+        , DELTA (delta-arg_size)+        , movInstr config fmt (OpReg arg_reg) (OpAddr (spRel platform 0)) ]++    where+      platform = ncgPlatform config+      arg_size = argSize platform arg+      arg_rep = cmmExprType platform arg+      fmt = cmmTypeFormat arg_rep++-- | Load an argument into a register or push it to the stack.+loadOrPushArg :: NCGConfig -> (StackArg, Maybe Int) -> NatM (InstrBlock, InstrBlock)+loadOrPushArg config (stk_arg, mb_off) =+  case stk_arg of+    StackArg arg pad -> do+      push_code <- pushArgByValue config arg+      pad_code  <- addStackPadding pad+      return (nilOL, push_code `appOL` pad_code)+    StackArgRef { stackRef = ref } ->+      case ref of+        -- Pass the reference in a register+        InReg ireg ->+          return (unitOL $ LEA II64 (OpAddr (spRel platform off)) (OpReg ireg), nilOL)+        -- Pass the reference on the stack+        OnStack {} -> do+          tmp <- getNewRegNat II64+          delta <- getDeltaNat+          setDeltaNat (delta-arg_ref_size)+          let push_code = toOL+                [ SUB (intFormat (wordWidth platform)) (OpImm (ImmInt arg_ref_size)) (OpReg rsp)+                , DELTA (delta-arg_ref_size)+                , LEA II64 (OpAddr (spRel platform off)) (OpReg tmp)+                , MOV II64 (OpReg tmp) (OpAddr (spRel platform 0)) ]+          return (nilOL, push_code)+      where off = expectJust mb_off+    where+      arg_ref_size = 8 -- passing a reference to the argument+      platform = ncgPlatform config++-- | Push arguments to the stack, right to left.+--+-- On Windows, some arguments may need to be passed by reference,+-- which requires separately passing the data and the reference.+-- See Note [The Windows X64 C calling convention].+pushArgs :: NCGConfig+         -> [RawStackArg]+            -- ^ arguments proper (i.e. don't include the data for arguments passed by reference)+         -> [StackArg]+            -- ^ arguments we are passing on the stack+         -> NatM (InstrBlock, InstrBlock)+pushArgs config proper_args all_stk_args+  = do { let+            vec_offs :: [Maybe Int]+            vec_offs+              | platformOS platform == OSMinGW32+              = go stack_arg_size all_stk_args+              | otherwise+              = repeat Nothing++    ---------------------+    -- Windows-only code++            -- Size of the arguments we are passing on the stack, counting only+            -- the reference part for arguments passed by reference.+            stack_arg_size = 8 * count not_in_reg proper_args+            not_in_reg (RawStackArg {}) = True+            not_in_reg (RawStackArgRef { stackRef = ref }) =+              case ref of+                InReg {} -> False+                OnStack {} -> True++            -- Check an offset is valid (8-byte aligned), for assertions.+            ok off = off `rem` 8 == 0++            -- Tricky code: compute the stack offset to the vector data+            -- for this argument.+            --+            -- If you're confused, Note [The Windows X64 C calling convention]+            -- contains a helpful diagram.+            go :: Int -> [StackArg] -> [Maybe Int]+            go _ [] = []+            go off (stk_arg:args) =+              assertPpr (ok off) (text "unaligned offset:" <+> ppr off) $+              case stk_arg of+                StackArg {} ->+                  -- Only account for the stack pointer movement.+                  let off' = off - stackArgSpace platform stk_arg+                  in Nothing : go off' args+                StackArgRef+                  { stackRefArgSize    = data_size+                  , stackRefArgPadding = data_pad } ->+                  assertPpr (ok data_size) (text "unaligned data size:" <+> ppr data_size) $+                  assertPpr (ok data_pad) (text "unaligned data padding:" <+> ppr data_pad) $+                  let off' = off+                        -- Next piece of data is after the data for this reference+                           + data_size + data_pad+                        -- ... and account for the stack pointer movement.+                           - stackArgSpace platform stk_arg+                  in Just (data_pad + off) : go off' args++    -- end of Windows-only code+    ----------------------------++         -- Push the stack arguments (right to left),+         -- including both the reference and the data for arguments passed by reference.+       ; (load_regs, push_args) <- foldMapM (loadOrPushArg config) (reverse $ zip all_stk_args vec_offs)+       ; return (load_regs, push_args) }+  where+    platform = ncgPlatform config++{- Note [The Windows X64 C calling convention]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Here are a few facts about the Windows X64 C calling convention that+are important:++  - any argument larger than 8 bytes must be passed by reference,+    and arguments smaller than 8 bytes are padded to 8 bytes.++  - the first four arguments are passed in registers:+      - floating-point scalar arguments are passed in %xmm0, %xmm1, %xmm2, %xmm3+      - other arguments are passed in %rcx, %rdx, %r8, %r9+        (this includes vector arguments, passed by reference)++    For variadic functions, it is additionally expected that floating point+    scalar arguments are copied to the corresponding integer register, e.g.+    the data in xmm2 should also be copied to r8.++    There is no requirement about setting %al like there is for the+    System V AMD64 ABI.++  - subsequent arguments are passed on the stack.++There are also alignment requirements:++  - the data for vectors must be aligned to the size of the vector,+    e.g. a 32 byte vector must be aligned on a 32 byte boundary,++  - the call instruction must be aligned to 16 bytes.+  (This differs from the System V AMD64 ABI, which mandates that the call+  instruction must be aligned to 32 bytes if there are any 32 byte vectors+  passed on the stack.)++This motivates our handling of vector values. Suppose we have a function call+with many arguments, several of them being vectors. We proceed as follows:++ - Add some padding, if necessary, to ensure the stack, when executing the call+    instruction, is 16-byte aligned. Whether this padding is necessary depends+    on what happens next. (Recall also that we start off at 8 (mod 16) alignment,+    as per Note [Stack Alignment on X86] in rts/StgCRun.c)+  - Push all the vectors to the stack first, adding padding after each one+    if necessary.+  - Then push the arguments:+      - for non-vectors, proceed as usual,+      - for vectors, push the address of the vector data we pushed above.+  - Then assign the registers:+      - for non-vectors, proceed as usual,+      - for vectors, store the address in a general-purpose register, as opposed+        to storing the data in an xmm register.++For a concrete example, suppose we have a call of the form:++  f x1 x2 x3 x4 x5 x6 x7++in which:++  - x2, x3, x5 and x7 are 16 byte vectors+  - the other arguments are all 8 byte wide++Now, x1, x2, x3, x4 will get passed in registers, except that we pass+x2 and x3 by reference, because they are vectors. We proceed as follows:++  - push the vectors to the stack: x7, x5, x3, x2 (in that order)+  - push the stack arguments in order: addr(x7), x6, addr(x5)+  - load the remaining arguments into registers: x4, addr(x3), addr(x2), x1++The tricky part is to get the right offsets for the addresses of the vector+data. The following visualisation will hopefully clear things up:++                                  ┌──┐+                                  │▓▓│ ─── padding to align the call instruction+                      ╭─╴         ╞══╡     (ensures Sp, below, is 16-byte aligned)+                      │           │  │+                      │  x7  ───╴ │  │+                      │           ├──┤+                      │           │  │+                      │  x5  ───╴ │  │+                      │           ├──┤+     vector data  ────┤           │  │+(individually padded) │  x3  ───╴ │  │+                      │           ├──┤+                      │           │  │+                      │  x2  ───╴ │  │+                      │           ├┄┄┤+                      │           │▓▓│ ─── padding to align x2 to 16 bytes+               ╭─╴    ╰─╴         ╞══╡+               │    addr(x7) ───╴ │  │    ╭─ from here: x7 is +64+               │                  ├──┤ ╾──╯    = 64 (position of x5)+     stack  ───┤         x6  ───╴ │  │         + 16 (size of x5) + 0 (padding of x7)+   arguments   │                  ├──┤         - 2 * 8 (x7 is 2 arguments higher than x5)+               │    addr(x5) ───╴ │  │+               ╰─╴            ╭─╴ ╞══╡ ╾─── from here:+                              │   │  │       - x2 is +32 = 24 (stack_arg_size) + 8 (padding of x2)+                   shadow  ───┤   │  │       - x3 is +48 = 32 (position of x2) + 16 (size of x2) + 0 (padding of x3)+                    space     │   │  │       - x5 is +64 = 48 (position of x3) + 16 (size of x3) + 0 (padding of x5)+                              │   │  │+                              ╰─╴ └──┘ ╾─── Sp++This is all tested in the simd013 test.+-}++-- -----------------------------------------------------------------------------+-- Generating a table-branch++{-+Note [Sub-word subtlety during jump-table indexing]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Offset the index by the start index of the jump table.+It's important that we do this *before* the widening below. To see+why, consider a switch with a sub-word, signed discriminant such as:++    switch [-5...+2] x::I16 {+        case -5: ...+        ...+        case +2: ...+    }++Consider what happens if we offset *after* widening in the case that+x=-4:++                                         // x == -4 == 0xfffc::I16+    indexWidened = UU_Conv(x);           // == 0xfffc::I64+    indexExpr    = indexWidened - (-5);  // == 0x10000::I64++This index is clearly nonsense given that the jump table only has+eight entries.++By contrast, if we widen *after* we offset then we get the correct+index (1),++                                         // x == -4 == 0xfffc::I16+    indexOffset  = x - (-5);             // == 1::I16+    indexExpr    = UU_Conv(indexOffset); // == 1::I64++See #21186.+-}++genSwitch :: CmmExpr -> SwitchTargets -> NatM InstrBlock++genSwitch expr targets = do+  config <- getConfig+  let platform = ncgPlatform config+      expr_w = cmmExprWidth platform expr+      indexExpr0 = cmmOffset platform expr offset+      -- We widen to a native-width register because we cannot use arbitrary sizes+      -- in x86 addressing modes.+      -- See Note [Sub-word subtlety during jump-table indexing].+      indexExpr = CmmMachOp+        (MO_UU_Conv expr_w (platformWordWidth platform))+        [indexExpr0]+  if ncgPIC config+  then do+        (reg,e_code) <- getNonClobberedReg indexExpr+           -- getNonClobberedReg because it needs to survive across t_code+        lbl <- getNewLabelNat+        let is32bit = target32Bit platform+            os = platformOS platform+            -- Might want to use .rodata.<function we're in> instead, but as+            -- long as it's something unique it'll work out since the+            -- references to the jump table are in the appropriate section.+            rosection = case os of+              -- on Mac OS X/x86_64, put the jump table in the text section to+              -- work around a limitation of the linker.+              -- ld64 is unable to handle the relocations for+              --     .quad L1 - L0+              -- if L0 is not preceded by a non-anonymous label in its section.+              OSDarwin | not is32bit -> Section Text lbl+              _ -> Section ReadOnlyData lbl+        dynRef <- cmmMakeDynamicReference config DataReference lbl+        (tableReg,t_code) <- getSomeReg $ dynRef+        let op = OpAddr (AddrBaseIndex (EABaseReg tableReg)+                                       (EAIndex reg (platformWordSizeInBytes platform)) (ImmInt 0))++        return $ e_code `appOL` t_code `appOL` toOL [+                                ADD (intFormat (platformWordWidth platform)) op (OpReg tableReg),+                                JMP_TBL (OpReg tableReg) ids rosection lbl+                       ]+  else do+        (reg,e_code) <- getSomeReg indexExpr+        lbl <- getNewLabelNat+        let is32bit = target32Bit platform+        if is32bit+          then let op = OpAddr (AddrBaseIndex EABaseNone (EAIndex reg (platformWordSizeInBytes platform)) (ImmCLbl lbl))+                   jmp_code = JMP_TBL op ids (Section ReadOnlyData lbl) lbl+               in return $ e_code `appOL` unitOL jmp_code+          else do+            -- See Note [%rip-relative addressing on x86-64].+            tableReg <- getNewRegNat (intFormat (platformWordWidth platform))+            targetReg <- getNewRegNat (intFormat (platformWordWidth platform))+            let op = OpAddr (AddrBaseIndex (EABaseReg tableReg) (EAIndex reg (platformWordSizeInBytes platform)) (ImmInt 0))+                fmt = archWordFormat is32bit+                code = e_code `appOL` toOL+                    [ LEA fmt (OpAddr (AddrBaseIndex EABaseRip EAIndexNone (ImmCLbl lbl))) (OpReg tableReg)+                    , MOV fmt op (OpReg targetReg)+                    , JMP_TBL (OpReg targetReg) ids (Section ReadOnlyData lbl) lbl+                    ]+            return code+  where+    (offset, blockIds) = switchTargetsToTable targets+    ids = map (fmap DestBlockId) blockIds++generateJumpTableForInstr :: NCGConfig -> Instr -> Maybe (NatCmmDecl (Alignment, RawCmmStatics) Instr)+generateJumpTableForInstr config (JMP_TBL _ ids section lbl)+    = let getBlockId (DestBlockId id) = id+          getBlockId _ = panic "Non-Label target in Jump Table"+          blockIds = map (fmap getBlockId) ids+      in Just (createJumpTable config blockIds section lbl)+generateJumpTableForInstr _ _ = Nothing++createJumpTable :: NCGConfig -> [Maybe BlockId] -> Section -> CLabel+                -> GenCmmDecl (Alignment, RawCmmStatics) h g+createJumpTable config ids section lbl+    = let jumpTable+            | ncgPIC config =+                  let ww = ncgWordWidth config+                      jumpTableEntryRel Nothing+                          = CmmStaticLit (CmmInt 0 ww)+                      jumpTableEntryRel (Just blockid)+                          = CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0 ww)+                          where blockLabel = blockLbl blockid+                  in map jumpTableEntryRel ids+            | otherwise = map (jumpTableEntry config) ids+      in CmmData section (mkAlignment 1, CmmStaticsRaw lbl jumpTable)++extractUnwindPoints :: [Instr] -> [UnwindPoint]+extractUnwindPoints instrs =+    [ UnwindPoint lbl unwinds | UNWIND lbl unwinds <- instrs]++-- -----------------------------------------------------------------------------+-- 'condIntReg' and 'condFltReg': condition codes into registers++-- Turn those condition codes into integers now (when they appear on+-- the right hand side of an assignment).+--+-- (If applicable) Do not fill the delay slots here; you will confuse the+-- register allocator.++condIntReg :: Cond -> CmmExpr -> CmmExpr -> NatM Register++condIntReg cond x y = do+  CondCode _ cond cond_code <- condIntCode cond x y+  tmp <- getNewRegNat II8+  let+        code dst = cond_code `appOL` toOL [+                    SETCC cond (OpReg tmp),+                    MOVZxL II8 (OpReg tmp) (OpReg dst)+                  ]+  return (Any II32 code)+++-- Note [SSE Parity Checks]+-- ~~~~~~~~~~~~~~~~~~~~~~~~+-- We have to worry about unordered operands (eg. comparisons+-- against NaN).  If the operands are unordered, the comparison+-- sets the parity flag, carry flag and zero flag.+-- All comparisons are supposed to return false for unordered+-- operands except for !=, which returns true.+--+-- Optimisation: we don't have to test the parity flag if we+-- know the test has already excluded the unordered case: eg >+-- and >= test for a zero carry flag, which can only occur for+-- ordered operands.+--+-- By reversing comparisons we can avoid testing the parity+-- for < and <= as well. If any of the arguments is an NaN we+-- return false either way. If both arguments are valid then+-- x <= y  <->  y >= x  holds. So it's safe to swap these.+--+-- We invert the condition inside getRegister'and  getCondCode+-- which should cover all invertable cases.+-- All other functions translating FP comparisons to assembly+-- use these to two generate the comparison code.+--+-- As an example consider a simple check:+--+-- func :: Float -> Float -> Int+-- func x y = if x < y then 1 else 0+--+-- Which in Cmm gives the floating point comparison.+--+--  if (%MO_F_Lt_W32(F1, F2)) goto c2gg; else goto c2gf;+--+-- We used to compile this to an assembly code block like this:+-- _c2gh:+--  ucomiss %xmm2,%xmm1+--  jp _c2gf+--  jb _c2gg+--  jmp _c2gf+--+-- Where we have to introduce an explicit+-- check for unordered results (using jmp parity):+--+-- We can avoid this by exchanging the arguments and inverting the direction+-- of the comparison. This results in the sequence of:+--+--  ucomiss %xmm1,%xmm2+--  ja _c2g2+--  jmp _c2g1+--+-- Removing the jump reduces the pressure on the branch prediction system+-- and plays better with the uOP cache.++condFltReg :: Bool -> Cond -> CmmExpr -> CmmExpr -> NatM Register+condFltReg is32Bit cond x y = condFltReg_sse2+ where+++  condFltReg_sse2 = do+    CondCode _ cond cond_code <- condFltCode cond x y+    tmp1 <- getNewRegNat (archWordFormat is32Bit)+    tmp2 <- getNewRegNat (archWordFormat is32Bit)+    let -- See Note [SSE Parity Checks]+        code dst =+           cond_code `appOL`+             (case cond of+                NE  -> or_unordered dst+                GU  -> plain_test   dst+                GEU -> plain_test   dst+                -- Use ASSERT so we don't break releases if these creep in.+                LTT -> assertPpr False (text "Should have been turned into >") $+                       and_ordered  dst+                LE  -> assertPpr False (text "Should have been turned into >=") $+                       and_ordered  dst+                _   -> and_ordered  dst)++        plain_test dst = toOL [+                    SETCC cond (OpReg tmp1),+                    MOVZxL II8 (OpReg tmp1) (OpReg dst)+                 ]+        or_unordered dst = toOL [+                    SETCC cond (OpReg tmp1),+                    SETCC PARITY (OpReg tmp2),+                    OR II8 (OpReg tmp1) (OpReg tmp2),+                    MOVZxL II8 (OpReg tmp2) (OpReg dst)+                  ]+        and_ordered dst = toOL [+                    SETCC cond (OpReg tmp1),+                    SETCC NOTPARITY (OpReg tmp2),+                    AND II8 (OpReg tmp1) (OpReg tmp2),+                    MOVZxL II8 (OpReg tmp2) (OpReg dst)+                  ]+    return (Any II32 code)+++-- -----------------------------------------------------------------------------+-- 'trivial*Code': deal with trivial instructions++-- Trivial (dyadic: 'trivialCode', floating-point: 'trivialFCode',+-- unary: 'trivialUCode', unary fl-pt:'trivialUFCode') instructions.+-- Only look for constants on the right hand side, because that's+-- where the generic optimizer will have put them.++-- Similarly, for unary instructions, we don't have to worry about+-- matching an StInt as the argument, because genericOpt will already+-- have handled the constant-folding.+++{-+The Rules of the Game are:++* You cannot assume anything about the destination register dst;+  it may be anything, including a fixed reg.++* You may compute an operand into a fixed reg, but you may not+  subsequently change the contents of that fixed reg.  If you+  want to do so, first copy the value either to a temporary+  or into dst.  You are free to modify dst even if it happens+  to be a fixed reg -- that's not your problem.++* You cannot assume that a fixed reg will stay live over an+  arbitrary computation.  The same applies to the dst reg.++* Temporary regs obtained from getNewRegNat are distinct from+  each other and from all other regs, and stay live over+  arbitrary computations.++--------------------++SDM's version of The Rules:++* If getRegister returns Any, that means it can generate correct+  code which places the result in any register, period.  Even if that+  register happens to be read during the computation.++  Corollary #1: this means that if you are generating code for an+  operation with two arbitrary operands, you cannot assign the result+  of the first operand into the destination register before computing+  the second operand.  The second operand might require the old value+  of the destination register.++  Corollary #2: A function might be able to generate more efficient+  code if it knows the destination register is a new temporary (and+  therefore not read by any of the sub-computations).++* If getRegister returns Any, then the code it generates may modify only:+        (a) fresh temporaries+        (b) the destination register+        (c) known registers (eg. %ecx is used by shifts)+  In particular, it may *not* modify global registers, unless the global+  register happens to be the destination register.+-}++trivialCode :: Width -> (Operand -> Operand -> Instr)+            -> Maybe (Operand -> Operand -> Instr)+            -> CmmExpr -> CmmExpr -> NatM Register+trivialCode width instr m a b+    = do platform <- getPlatform+         trivialCode' platform width instr m a b++trivialCode' :: Platform -> Width -> (Operand -> Operand -> Instr)+             -> Maybe (Operand -> Operand -> Instr)+             -> CmmExpr -> CmmExpr -> NatM Register+trivialCode' platform width _ (Just revinstr) (CmmLit lit_a) b+  | is32BitLit platform lit_a = do+  b_code <- getAnyReg b+  let+       code dst+         = b_code dst `snocOL`+           revinstr (OpImm (litToImm lit_a)) (OpReg dst)+  return (Any (intFormat width) code)++trivialCode' _ width instr _ a b+  = genTrivialCode (intFormat width) (\op2 -> instr op2 . OpReg) a b++-- This is re-used for floating pt instructions too.+genTrivialCode :: Format -> (Operand -> Reg -> Instr)+               -> CmmExpr -> CmmExpr -> NatM Register+genTrivialCode rep instr a b = do+  (b_op, b_code) <- getNonClobberedOperand b+  a_code <- getAnyReg a+  tmp <- getNewRegNat rep+  let+     -- We want the value of 'b' to stay alive across the computation of 'a'.+     -- But, we want to calculate 'a' straight into the destination register,+     -- because the instruction only has two operands (dst := dst `op` src).+     -- The troublesome case is when the result of 'b' is in the same register+     -- as the destination 'reg'.  In this case, we have to save 'b' in a+     -- new temporary across the computation of 'a'.+     code dst+        | dst `regClashesWithOp` b_op =+                b_code `appOL`+                unitOL (MOV rep b_op (OpReg tmp)) `appOL`+                a_code dst `snocOL`+                instr (OpReg tmp) dst+        | otherwise =+                b_code `appOL`+                a_code dst `snocOL`+                instr b_op dst+  return (Any rep code)++regClashesWithOp :: Reg -> Operand -> Bool+reg `regClashesWithOp` OpReg reg2   = reg == reg2+reg `regClashesWithOp` OpAddr amode = any (==reg) (addrModeRegs amode)+_   `regClashesWithOp` _            = False++-- | Generate code for a fused multiply-add operation, of the form @± x * y ± z@,+-- with 3 operands (FMA3 instruction set).+genFMA3Code :: Length+            -> Width+            -> FMASign+            -> CmmExpr -> CmmExpr -> CmmExpr -> NatM Register+genFMA3Code l w signs x y z = do+  config <- getConfig+  -- For the FMA instruction, we want to compute x * y + z+  --+  -- There are three possible instructions we could emit:+  --+  --   - fmadd213 z y x, result in x, z can be a memory address+  --   - fmadd132 x z y, result in y, x can be a memory address+  --   - fmadd231 y x z, result in z, y can be a memory address+  --+  -- This suggests two possible optimisations:+  --+  --   - OPTIMISATION 1+  --     If one argument is an address, use the instruction that allows+  --     a memory address in that position.+  --+  --   - OPTIMISATION 2+  --     If one argument is in a fixed register, use the instruction that puts+  --     the result in that same register.+  --+  -- Currently we follow neither of these optimisations,+  -- opting to always use fmadd213 for simplicity.+  --+  -- We would like to compute the result directly into the requested register.+  -- To do so we must first compute `x` into the destination register. This is+  -- only possible if the other arguments don't use the destination register.+  -- We check for this and if there is a conflict we move the result only after+  -- the computation. See #24496 how this went wrong in the past.+  let rep+        | l == 1+        = floatFormat w+        | otherwise+        = vecFormat (cmmVec l $ cmmFloat w)+  (y_reg, y_code) <- getNonClobberedReg y+  (z_op, z_code) <- getNonClobberedOperand z+  x_code <- getAnyReg x+  x_tmp <- getNewRegNat rep+  let+     fma213 = FMA3 rep signs FMA213++     code, code_direct, code_mov :: Reg -> InstrBlock+     -- Ideal: Compute the result directly into dst+     code_direct dst = x_code dst `snocOL`+                       fma213 z_op y_reg dst+     -- Fallback: Compute the result into a tmp reg and then move it.+     code_mov dst    = x_code x_tmp `snocOL`+                       fma213 z_op y_reg x_tmp `snocOL`+                       mkRegRegMoveInstr config rep x_tmp dst++     code dst =+        y_code `appOL`+        z_code `appOL`+        ( if arg_regs_conflict then code_mov dst else code_direct dst )++      where++        arg_regs_conflict =+          y_reg == dst ||+          case z_op of+            OpReg z_reg -> z_reg == dst+            OpAddr amode -> dst `elem` addrModeRegs amode+            OpImm {} -> False++  -- NB: Computing the result into a desired register using Any can be tricky.+  -- So for now, we keep it simple. (See #24496).+  return (Any rep code)++-----------++trivialUCode :: Format -> (Operand -> Instr)+             -> CmmExpr -> NatM Register+trivialUCode rep instr x = do+  x_code <- getAnyReg x+  let+     code dst =+        x_code dst `snocOL`+        instr (OpReg dst)+  return (Any rep code)++-----------+++trivialFCode_sse2 :: Width -> (Format -> Operand -> Reg -> Instr)+                  -> CmmExpr -> CmmExpr -> NatM Register+trivialFCode_sse2 ty instr x y+    = genTrivialCode format (instr format) x y+    where format = floatFormat ty+++--------------------------------------------------------------------------------+coerceInt2FP :: Width -> Width -> CmmExpr -> NatM Register+coerceInt2FP from to x =  coerce_sse2+ where++   coerce_sse2 = do+     (x_op, x_code) <- getOperand x  -- ToDo: could be a safe operand+     let+           opc  = case to of W32 -> CVTSI2SS; W64 -> CVTSI2SD+                             n -> panic $ "coerceInt2FP.sse: unhandled width ("+                                         ++ show n ++ ")"+           code dst = x_code `snocOL` opc (intFormat from) x_op dst+     return (Any (floatFormat to) code)+        -- works even if the destination rep is <II32++--------------------------------------------------------------------------------+coerceFP2Int :: Width -> Width -> CmmExpr -> NatM Register+coerceFP2Int from to x =  coerceFP2Int_sse2+ where+   coerceFP2Int_sse2 = do+     (x_op, x_code) <- getOperand x  -- ToDo: could be a safe operand+     let+           opc  = case from of W32 -> CVTTSS2SIQ; W64 -> CVTTSD2SIQ;+                               n -> panic $ "coerceFP2Init.sse: unhandled width ("+                                           ++ show n ++ ")"+           code dst = x_code `snocOL` opc (intFormat to) x_op dst+     return (Any (intFormat to) code)+         -- works even if the destination rep is <II32+++--------------------------------------------------------------------------------+coerceFP2FP :: Width -> CmmExpr -> NatM Register+coerceFP2FP to x = do+  (x_reg, x_code) <- getSomeReg x+  let+        opc  = case to of W32 -> CVTSD2SS; W64 -> CVTSS2SD;+                                     n -> panic $ "coerceFP2FP: unhandled width ("+                                                 ++ show n ++ ")"+        code dst = x_code `snocOL` opc x_reg dst+  return (Any ( floatFormat to) code)++--------------------------------------------------------------------------------++sse2NegCode :: Width -> CmmExpr -> NatM Register+sse2NegCode w x = do+  let fmt = floatFormat w+  x_code <- getAnyReg x+  -- This is how gcc does it, so it can't be that bad:+  let+    const = case fmt of+      FF32 -> CmmInt 0x80000000 W32+      FF64 -> CmmInt 0x8000000000000000 W64+      x@II8  -> wrongFmt x+      x@II16 -> wrongFmt x+      x@II32 -> wrongFmt x+      x@II64 -> wrongFmt x+      x@(VecFormat {}) -> wrongFmt x++      where+        wrongFmt x = panic $ "sse2NegCode: " ++ show x+  Amode amode amode_code <- memConstant (mkAlignment $ widthInBytes w) const+  tmp <- getNewRegNat fmt+  let+    code dst = x_code dst `appOL` amode_code `appOL` toOL [+        MOV fmt (OpAddr amode) (OpReg tmp),+        XOR fmt (OpReg tmp) (OpReg dst)+        ]+  --+  return (Any fmt code)++needLlvm :: MachOp -> NatM a+needLlvm mop =+  sorry $ unlines [ "Unsupported vector instruction for the native code generator:"+                  , show mop+                  , "Please use -fllvm." ]++incorrectOperands :: NatM a+incorrectOperands = sorry "Incorrect number of operands"++invalidConversion :: Width -> Width -> NatM a+invalidConversion from to =+  sorry $ "Invalid conversion operation from " ++ show from ++ " to " ++ show to++-- | This works on the invariant that all jumps in the given blocks are required.+--   Starting from there we try to make a few more jumps redundant by reordering+--   them.+--   We depend on the information in the CFG to do so so without a given CFG+--   we do nothing.+invertCondBranches :: Maybe CFG  -- ^ CFG if present+                   -> LabelMap a -- ^ Blocks with info tables+                   -> [NatBasicBlock Instr] -- ^ List of basic blocks+                   -> [NatBasicBlock Instr]+invertCondBranches Nothing _       bs = bs+invertCondBranches (Just cfg) keep bs =+    invert bs+  where+    invert :: [NatBasicBlock Instr] -> [NatBasicBlock Instr]+    invert (BasicBlock lbl1 ins:b2@(BasicBlock lbl2 _):bs)+      | --pprTrace "Block" (ppr lbl1) True,+        Just (jmp1,jmp2) <- last2 ins+      , JXX cond1 target1 <- jmp1+      , target1 == lbl2+      --, pprTrace "CutChance" (ppr b1) True+      , JXX ALWAYS target2 <- jmp2+      -- We have enough information to check if we can perform the inversion+      -- TODO: We could also check for the last asm instruction which sets+      -- status flags instead. Which I suspect is worse in terms of compiler+      -- performance, but might be applicable to more cases+      , Just edgeInfo1 <- getEdgeInfo lbl1 target1 cfg+      , Just edgeInfo2 <- getEdgeInfo lbl1 target2 cfg+      -- Both jumps come from the same cmm statement+      , transitionSource edgeInfo1 == transitionSource edgeInfo2+      , CmmSource {trans_cmmNode = cmmCondBranch} <- transitionSource edgeInfo1++      --Int comparisons are invertable+      , CmmCondBranch (CmmMachOp op _args) _ _ _ <- cmmCondBranch+      , Just _ <- maybeIntComparison op+      , Just invCond <- maybeInvertCond cond1++      --Swap the last two jumps, invert the conditional jumps condition.+      = let jumps =+              case () of+                -- We are free the eliminate the jmp. So we do so.+                _ | not (mapMember target1 keep)+                    -> [JXX invCond target2]+                -- If the conditional target is unlikely we put the other+                -- target at the front.+                  | edgeWeight edgeInfo2 > edgeWeight edgeInfo1+                    -> [JXX invCond target2, JXX ALWAYS target1]+                -- Keep things as-is otherwise+                  | otherwise+                    -> [jmp1, jmp2]+        in --pprTrace "Cutable" (ppr [jmp1,jmp2] <+> text "=>" <+> ppr jumps) $+           (BasicBlock lbl1+            (dropTail 2 ins ++ jumps))+            : invert (b2:bs)+    invert (b:bs) = b : invert bs+    invert [] = []++genAtomicRMW+  :: BlockId+  -> Width+  -> AtomicMachOp+  -> LocalReg+  -> CmmExpr+  -> CmmExpr+  -> NatM (InstrBlock, Maybe BlockId)+genAtomicRMW bid width amop dst addr n = do+    Amode amode addr_code <-+        if amop `elem` [AMO_Add, AMO_Sub]+        then getAmode addr+        else getSimpleAmode addr  -- See genForeignCall for MO_Cmpxchg+    arg <- getNewRegNat format+    arg_code <- getAnyReg n+    platform <- ncgPlatform <$> getConfig++    let dst_r    = getRegisterReg platform  (CmmLocal dst)+    (code, lbl) <- op_code dst_r arg amode+    return (addr_code `appOL` arg_code arg `appOL` code, Just lbl)+  where+    -- Code for the operation+    op_code :: Reg       -- Destination reg+            -> Reg       -- Register containing argument+            -> AddrMode  -- Address of location to mutate+            -> NatM (OrdList Instr,BlockId) -- TODO: Return Maybe BlockId+    op_code dst_r arg amode = do+        case amop of+          -- In the common case where dst_r is a virtual register the+          -- final move should go away, because it's the last use of arg+          -- and the first use of dst_r.+          AMO_Add  -> return $ (toOL [ LOCK (XADD format (OpReg arg) (OpAddr amode))+                                     , MOV format (OpReg arg) (OpReg dst_r)+                                     ], bid)+          AMO_Sub  -> return $ (toOL [ NEGI format (OpReg arg)+                                     , LOCK (XADD format (OpReg arg) (OpAddr amode))+                                     , MOV format (OpReg arg) (OpReg dst_r)+                                     ], bid)+          -- In these cases we need a new block id, and have to return it so+          -- that later instruction selection can reference it.+          AMO_And  -> cmpxchg_code (\ src dst -> unitOL $ AND format src dst)+          AMO_Nand -> cmpxchg_code (\ src dst -> toOL [ AND format src dst+                                                      , NOT format dst+                                                      ])+          AMO_Or   -> cmpxchg_code (\ src dst -> unitOL $ OR format src dst)+          AMO_Xor  -> cmpxchg_code (\ src dst -> unitOL $ XOR format src dst)+      where+        -- Simulate operation that lacks a dedicated instruction using+        -- cmpxchg.+        cmpxchg_code :: (Operand -> Operand -> OrdList Instr)+                     -> NatM (OrdList Instr, BlockId)+        cmpxchg_code instrs = do+            lbl1 <- getBlockIdNat+            lbl2 <- getBlockIdNat+            tmp <- getNewRegNat format++            --Record inserted blocks+            --  We turn A -> B into A -> A' -> A'' -> B+            --  with a self loop on A'.+            addImmediateSuccessorNat bid lbl1+            addImmediateSuccessorNat lbl1 lbl2+            updateCfgNat (addWeightEdge lbl1 lbl1 0)++            return $ (toOL+                [ MOV format (OpAddr amode) (OpReg eax)+                , JXX ALWAYS lbl1+                , NEWBLOCK lbl1+                  -- Keep old value so we can return it:+                , MOV format (OpReg eax) (OpReg dst_r)+                , MOV format (OpReg eax) (OpReg tmp)+                ]+                `appOL` instrs (OpReg arg) (OpReg tmp) `appOL` toOL+                [ LOCK (CMPXCHG format (OpReg tmp) (OpAddr amode))+                , JXX NE lbl1+                -- See Note [Introducing cfg edges inside basic blocks]+                -- why this basic block is required.+                , JXX ALWAYS lbl2+                , NEWBLOCK lbl2+                ],+                lbl2)+    format = intFormat width++-- | Count trailing zeroes+genCtz :: BlockId -> Width -> LocalReg -> CmmExpr -> NatM (InstrBlock, Maybe BlockId)+genCtz bid width dst src = do+  is32Bit <- is32BitPlatform+  if is32Bit && width == W64+    then genCtz64_32 bid dst src+    else (,Nothing) <$> genCtzGeneric width dst src++-- | Count trailing zeroes+--+-- 64-bit width on 32-bit architecture+genCtz64_32+  :: BlockId+  -> LocalReg+  -> CmmExpr+  -> NatM (InstrBlock, Maybe BlockId)+genCtz64_32 bid dst src = do+  RegCode64 vcode rhi rlo <- iselExpr64 src+  let dst_r = getLocalRegReg dst+  lbl1 <- getBlockIdNat+  lbl2 <- getBlockIdNat+  tmp_r <- getNewRegNat II64++  -- New CFG Edges:+  --  bid -> lbl2+  --  bid -> lbl1 -> lbl2+  --  We also changes edges originating at bid to start at lbl2 instead.+  weights <- getCfgWeights+  updateCfgNat (addWeightEdge bid lbl1 110 .+                addWeightEdge lbl1 lbl2 110 .+                addImmediateSuccessor weights bid lbl2)++  -- The following instruction sequence corresponds to the pseudo-code+  --+  --  if (src) {+  --    dst = src.lo32 ? BSF(src.lo32) : (BSF(src.hi32) + 32);+  --  } else {+  --    dst = 64;+  --  }+  let instrs = vcode `appOL` toOL+           ([ MOV      II32 (OpReg rhi)         (OpReg tmp_r)+            , OR       II32 (OpReg rlo)         (OpReg tmp_r)+            , MOV      II32 (OpImm (ImmInt 64)) (OpReg dst_r)+            , JXX EQQ    lbl2+            , JXX ALWAYS lbl1++            , NEWBLOCK   lbl1+            , BSF     II32 (OpReg rhi)         dst_r+            , ADD     II32 (OpImm (ImmInt 32)) (OpReg dst_r)+            , BSF     II32 (OpReg rlo)         tmp_r+            , CMOV NE II32 (OpReg tmp_r)       dst_r+            , JXX ALWAYS lbl2++            , NEWBLOCK   lbl2+            ])+  return (instrs, Just lbl2)++-- | Count trailing zeroes+--+-- Generic case (width <= word size)+genCtzGeneric :: Width -> LocalReg -> CmmExpr -> NatM InstrBlock+genCtzGeneric width dst src = do+  code_src <- getAnyReg src+  config <- getConfig+  let bw = widthInBits width+  let dst_r = getLocalRegReg dst+  if ncgBmiVersion config >= Just BMI2+  then do+      src_r <- getNewRegNat (intFormat width)+      let instrs = appOL (code_src src_r) $ case width of+              W8 -> toOL+                  [ OR    II32 (OpImm (ImmInteger 0xFFFFFF00)) (OpReg src_r)+                  , TZCNT II32 (OpReg src_r) dst_r+                  ]+              W16 -> toOL+                  [ TZCNT  II16 (OpReg src_r) dst_r+                  , MOVZxL II16 (OpReg dst_r) (OpReg dst_r)+                  ]+              _ -> unitOL $ TZCNT (intFormat width) (OpReg src_r) dst_r+      return instrs+  else do+      -- The following insn sequence makes sure 'ctz 0' has a defined value.+      -- starting with Haswell, one could use the TZCNT insn instead.+      let format = if width == W8 then II16 else intFormat width+      src_r <- getNewRegNat format+      tmp_r <- getNewRegNat format+      let instrs = code_src src_r `appOL` toOL+               ([ MOVZxL  II8    (OpReg src_r)       (OpReg src_r) | width == W8 ] +++                [ BSF     format (OpReg src_r)       tmp_r+                , MOV     II32   (OpImm (ImmInt bw)) (OpReg dst_r)+                , CMOV NE format (OpReg tmp_r)       dst_r+                ]) -- NB: We don't need to zero-extend the result for the+                   -- W8/W16 cases because the 'MOV' insn already+                   -- took care of implicitly clearing the upper bits+      return instrs++++-- | Copy memory+--+-- Unroll memcpy calls if the number of bytes to copy isn't too large (cf+-- ncgInlineThresholdMemcpy).  Otherwise, call C's memcpy.+genMemCpy+  :: BlockId+  -> Int+  -> CmmExpr+  -> CmmExpr+  -> CmmExpr+  -> NatM InstrBlock+genMemCpy bid align dst src arg_n = do++  let libc_memcpy = genLibCCall bid (fsLit "memcpy") [] [dst,src,arg_n]++  case arg_n of+    CmmLit (CmmInt n _) -> do+      -- try to inline it+      mcode <- genMemCpyInlineMaybe align dst src n+      -- if it didn't inline, call the C function+      case mcode of+        Nothing -> libc_memcpy+        Just c  -> pure c++    -- not a literal size argument: call the C function+    _ -> libc_memcpy++++genMemCpyInlineMaybe+  :: Int+  -> CmmExpr+  -> CmmExpr+  -> Integer+  -> NatM (Maybe InstrBlock)+genMemCpyInlineMaybe align dst src n = do+  config <- getConfig+  let+    platform     = ncgPlatform config+    maxAlignment = wordAlignment platform+                   -- only machine word wide MOVs are supported+    effectiveAlignment = min (alignmentOf align) maxAlignment+    format = intFormat . widthFromBytes $ alignmentBytes effectiveAlignment+++  -- The size of each move, in bytes.+  let sizeBytes :: Integer+      sizeBytes = fromIntegral (formatInBytes format)++  -- The number of instructions we will generate (approx). We need 2+  -- instructions per move.+  let insns = 2 * ((n + sizeBytes - 1) `div` sizeBytes)++      go :: Reg -> Reg -> Reg -> Integer -> OrdList Instr+      go dst src tmp i+          | i >= sizeBytes =+              unitOL (MOV format (OpAddr src_addr) (OpReg tmp)) `appOL`+              unitOL (MOV format (OpReg tmp) (OpAddr dst_addr)) `appOL`+              go dst src tmp (i - sizeBytes)+          -- Deal with remaining bytes.+          | i >= 4 =  -- Will never happen on 32-bit+              unitOL (MOV II32 (OpAddr src_addr) (OpReg tmp)) `appOL`+              unitOL (MOV II32 (OpReg tmp) (OpAddr dst_addr)) `appOL`+              go dst src tmp (i - 4)+          | i >= 2 =+              unitOL (MOVZxL II16 (OpAddr src_addr) (OpReg tmp)) `appOL`+              unitOL (MOV    II16  (OpReg tmp) (OpAddr dst_addr)) `appOL`+              go dst src tmp (i - 2)+          | i >= 1 =+              unitOL (MOVZxL II8 (OpAddr src_addr) (OpReg tmp)) `appOL`+              unitOL (MOV    II8 (OpReg tmp) (OpAddr dst_addr)) `appOL`+              go dst src tmp (i - 1)+          | otherwise = nilOL+        where+          src_addr = AddrBaseIndex (EABaseReg src) EAIndexNone+                       (ImmInteger (n - i))++          dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone+                       (ImmInteger (n - i))++  if insns > fromIntegral (ncgInlineThresholdMemcpy config)+    then pure Nothing+    else do+      code_dst <- getAnyReg dst+      dst_r <- getNewRegNat format+      code_src <- getAnyReg src+      src_r <- getNewRegNat format+      tmp_r <- getNewRegNat format+      pure $ Just $ code_dst dst_r `appOL` code_src src_r `appOL`+                      go dst_r src_r tmp_r (fromInteger n)++-- | Set memory to the given byte+--+-- Unroll memset calls if the number of bytes to copy isn't too large (cf+-- ncgInlineThresholdMemset).  Otherwise, call C's memset.+genMemSet+  :: BlockId+  -> Int+  -> CmmExpr+  -> CmmExpr+  -> CmmExpr+  -> NatM InstrBlock+genMemSet bid align dst arg_c arg_n = do++  let libc_memset = genLibCCall bid (fsLit "memset") [] [dst,arg_c,arg_n]++  case (arg_c,arg_n) of+    (CmmLit (CmmInt c _), CmmLit (CmmInt n _)) -> do+      -- try to inline it+      mcode <- genMemSetInlineMaybe align dst c n+      -- if it didn't inline, call the C function+      case mcode of+        Nothing -> libc_memset+        Just c  -> pure c++    -- not literal size arguments: call the C function+    _ -> libc_memset++genMemSetInlineMaybe+  :: Int+  -> CmmExpr+  -> Integer+  -> Integer+  -> NatM (Maybe InstrBlock)+genMemSetInlineMaybe align dst c n = do+  config <- getConfig+  let+    platform = ncgPlatform config+    maxAlignment = wordAlignment platform -- only machine word wide MOVs are supported+    effectiveAlignment = min (alignmentOf align) maxAlignment+    format = intFormat . widthFromBytes $ alignmentBytes effectiveAlignment+    c2 = c `shiftL` 8 .|. c+    c4 = c2 `shiftL` 16 .|. c2+    c8 = c4 `shiftL` 32 .|. c4++    -- The number of instructions we will generate (approx). We need 1+    -- instructions per move.+    insns = (n + sizeBytes - 1) `div` sizeBytes++    -- The size of each move, in bytes.+    sizeBytes :: Integer+    sizeBytes = fromIntegral (formatInBytes format)++    -- Depending on size returns the widest MOV instruction and its+    -- width.+    gen4 :: AddrMode -> Integer -> (InstrBlock, Integer)+    gen4 addr size+        | size >= 4 =+            (unitOL (MOV II32 (OpImm (ImmInteger c4)) (OpAddr addr)), 4)+        | size >= 2 =+            (unitOL (MOV II16 (OpImm (ImmInteger c2)) (OpAddr addr)), 2)+        | size >= 1 =+            (unitOL (MOV II8 (OpImm (ImmInteger c)) (OpAddr addr)), 1)+        | otherwise = (nilOL, 0)++    -- Generates a 64-bit wide MOV instruction from REG to MEM.+    gen8 :: AddrMode -> Reg -> InstrBlock+    gen8 addr reg8byte =+      unitOL (MOV format (OpReg reg8byte) (OpAddr addr))++    -- Unrolls memset when the widest MOV is <= 4 bytes.+    go4 :: Reg -> Integer -> InstrBlock+    go4 dst left =+      if left <= 0 then nilOL+      else curMov `appOL` go4 dst (left - curWidth)+      where+        possibleWidth = min left sizeBytes+        dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone (ImmInteger (n - left))+        (curMov, curWidth) = gen4 dst_addr possibleWidth++    -- Unrolls memset when the widest MOV is 8 bytes (thus another Reg+    -- argument). Falls back to go4 when all 8 byte moves are+    -- exhausted.+    go8 :: Reg -> Reg -> Integer -> InstrBlock+    go8 dst reg8byte left =+      if possibleWidth >= 8 then+        let curMov = gen8 dst_addr reg8byte+        in  curMov `appOL` go8 dst reg8byte (left - 8)+      else go4 dst left+      where+        possibleWidth = min left sizeBytes+        dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone (ImmInteger (n - left))++  if fromInteger insns > ncgInlineThresholdMemset config+    then pure Nothing+    else do+        code_dst <- getAnyReg dst+        dst_r <- getNewRegNat format+        if format == II64 && n >= 8+          then do+            code_imm8byte <- getAnyReg (CmmLit (CmmInt c8 W64))+            imm8byte_r <- getNewRegNat II64+            return $ Just $ code_dst dst_r `appOL`+                              code_imm8byte imm8byte_r `appOL`+                              go8 dst_r imm8byte_r (fromInteger n)+          else+            return $ Just $ code_dst dst_r `appOL`+                              go4 dst_r (fromInteger n)+++genMemMove :: BlockId -> p -> CmmActual -> CmmActual -> CmmActual -> NatM InstrBlock+genMemMove bid _align dst src n = do+  -- TODO: generate inline assembly when under a given threshold (similarly to+  -- memcpy and memset)+  genLibCCall bid (fsLit "memmove") [] [dst,src,n]++genMemCmp :: BlockId -> p -> CmmFormal -> CmmActual -> CmmActual -> CmmActual -> NatM InstrBlock+genMemCmp bid _align res dst src n = do+  -- TODO: generate inline assembly when under a given threshold (similarly to+  -- memcpy and memset)+  genLibCCall bid (fsLit "memcmp") [res] [dst,src,n]++genPrefetchData :: Int -> CmmExpr -> NatM (OrdList Instr)+genPrefetchData n src = do+  is32Bit <- is32BitPlatform+  let+    format = archWordFormat is32Bit+    -- need to know what register width for pointers!+    genPrefetch inRegSrc prefetchCTor = do+      code_src <- getAnyReg inRegSrc+      src_r <- getNewRegNat format+      return $ code_src src_r `appOL`+        (unitOL (prefetchCTor  (OpAddr+                    ((AddrBaseIndex (EABaseReg src_r )   EAIndexNone (ImmInt 0))))  ))+        -- prefetch always takes an address++  -- the c / llvm prefetch convention is 0, 1, 2, and 3+  -- the x86 corresponding names are : NTA, 2 , 1, and 0+  case n of+      0 -> genPrefetch src $ PREFETCH NTA  format+      1 -> genPrefetch src $ PREFETCH Lvl2 format+      2 -> genPrefetch src $ PREFETCH Lvl1 format+      3 -> genPrefetch src $ PREFETCH Lvl0 format+      l -> pprPanic "genPrefetchData: unexpected prefetch level" (ppr l)++genByteSwap :: Width -> LocalReg -> CmmExpr -> NatM InstrBlock+genByteSwap width dst src = do+  is32Bit <- is32BitPlatform+  let format = intFormat width+  case width of+      W64 | is32Bit -> do+        let Reg64 dst_hi dst_lo = localReg64 dst+        RegCode64 vcode rhi rlo <- iselExpr64 src+        tmp <- getNewRegNat II32+        -- Swap the low and high halves of the register.+        --+        -- NB: if dst_hi == rhi, we must make sure to preserve the contents+        -- of rhi before writing to dst_hi (#25601).+        let shuffle = if dst_hi == rhi && dst_lo == rlo then+                        toOL [ MOV II32 (OpReg rhi) (OpReg tmp),+                               MOV II32 (OpReg rlo) (OpReg dst_hi),+                               MOV II32 (OpReg tmp) (OpReg dst_lo) ]+                      else if dst_hi == rhi then+                        toOL [ MOV II32 (OpReg rhi) (OpReg dst_lo),+                               MOV II32 (OpReg rlo) (OpReg dst_hi) ]+                      else+                        toOL [ MOV II32 (OpReg rlo) (OpReg dst_hi),+                               MOV II32 (OpReg rhi) (OpReg dst_lo) ]+        return $ vcode `appOL` shuffle `appOL`+                 toOL [ BSWAP II32 dst_hi,+                        BSWAP II32 dst_lo ]+      W16 -> do+        let dst_r = getLocalRegReg dst+        code_src <- getAnyReg src+        return $ code_src dst_r `appOL`+                 unitOL (BSWAP II32 dst_r) `appOL`+                 unitOL (SHR II32 (OpImm $ ImmInt 16) (OpReg dst_r))+      _   -> do+        let dst_r = getLocalRegReg dst+        code_src <- getAnyReg src+        return $ code_src dst_r `appOL` unitOL (BSWAP format dst_r)++genBitRev :: BlockId -> Width -> CmmFormal -> CmmActual -> NatM InstrBlock+genBitRev bid width dst src = do+  -- Here the C implementation (hs_bitrevN) is used as there is no x86+  -- instruction to reverse a word's bit order.+  genPrimCCall bid (bRevLabel width) [dst] [src]++genPopCnt :: BlockId -> Width -> LocalReg -> CmmExpr -> NatM InstrBlock+genPopCnt bid width dst src = do+  config <- getConfig+  let+    platform = ncgPlatform config+    format = intFormat width++  sse4_2Enabled >>= \case++    True -> do+      code_src <- getAnyReg src+      src_r <- getNewRegNat format+      let dst_r = getRegisterReg platform  (CmmLocal dst)+      return $ code_src src_r `appOL`+          (if width == W8 then+               -- The POPCNT instruction doesn't take a r/m8+               unitOL (MOVZxL II8 (OpReg src_r) (OpReg src_r)) `appOL`+               unitOL (POPCNT II16 (OpReg src_r) dst_r)+           else+               unitOL (POPCNT format (OpReg src_r) dst_r)) `appOL`+          (if width == W8 || width == W16 then+               -- We used a 16-bit destination register above,+               -- so zero-extend+               unitOL (MOVZxL II16 (OpReg dst_r) (OpReg dst_r))+           else nilOL)++    False ->+      -- generate C call to hs_popcntN in ghc-prim+      -- TODO: we could directly generate the assembly to index popcount_tab+      -- here instead of doing it by calling a C function+      genPrimCCall bid (popCntLabel width) [dst] [src]+++genPdep :: BlockId -> Width -> LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock+genPdep bid width dst src mask = do+  config <- getConfig+  let+    platform = ncgPlatform config+    format = intFormat width++  if ncgBmiVersion config >= Just BMI2+    then do+      code_src  <- getAnyReg src+      code_mask <- getAnyReg mask+      src_r     <- getNewRegNat format+      mask_r    <- getNewRegNat format+      let dst_r = getRegisterReg platform  (CmmLocal dst)+      return $ code_src src_r `appOL` code_mask mask_r `appOL`+          -- PDEP only supports > 32 bit args+          ( if width == W8 || width == W16 then+              toOL+                [ MOVZxL format (OpReg src_r ) (OpReg src_r )+                , MOVZxL format (OpReg mask_r) (OpReg mask_r)+                , PDEP   II32 (OpReg mask_r) (OpReg src_r ) dst_r+                , MOVZxL format (OpReg dst_r) (OpReg dst_r) -- Truncate to op width+                ]+            else+              unitOL (PDEP format (OpReg mask_r) (OpReg src_r) dst_r)+          )+    else+      -- generate C call to hs_pdepN in ghc-prim+      genPrimCCall bid (pdepLabel width) [dst] [src,mask]+++genPext :: BlockId -> Width -> LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock+genPext bid width dst src mask = do+  config <- getConfig+  if ncgBmiVersion config >= Just BMI2+    then do+      let format   = intFormat width+      let dst_r    = getLocalRegReg dst+      code_src  <- getAnyReg src+      code_mask <- getAnyReg mask+      src_r     <- getNewRegNat format+      mask_r    <- getNewRegNat format+      return $ code_src src_r `appOL` code_mask mask_r `appOL`+          (if width == W8 || width == W16 then+               -- The PEXT instruction doesn't take a r/m8 or 16+              toOL+                [ MOVZxL format (OpReg src_r ) (OpReg src_r )+                , MOVZxL format (OpReg mask_r) (OpReg mask_r)+                , PEXT   II32   (OpReg mask_r) (OpReg src_r ) dst_r+                , MOVZxL format (OpReg dst_r)  (OpReg dst_r) -- Truncate to op width+                ]+            else+              unitOL (PEXT format (OpReg mask_r) (OpReg src_r) dst_r)+          )+    else+      -- generate C call to hs_pextN in ghc-prim+      genPrimCCall bid (pextLabel width) [dst] [src,mask]++genClz :: BlockId -> Width -> CmmFormal -> CmmActual -> NatM InstrBlock+genClz bid width dst src = do+  is32Bit <- is32BitPlatform+  config <- getConfig+  if is32Bit && width == W64++    then+      -- Fallback to `hs_clz64` on i386+      genPrimCCall bid (clzLabel width) [dst] [src]++    else do+      code_src <- getAnyReg src+      let dst_r = getLocalRegReg dst+      if ncgBmiVersion config >= Just BMI2+        then do+          src_r <- getNewRegNat (intFormat width)+          return $ appOL (code_src src_r) $ case width of+            W8 -> toOL+                [ MOVZxL II8  (OpReg src_r)       (OpReg src_r) -- zero-extend to 32 bit+                , LZCNT  II32 (OpReg src_r)       dst_r         -- lzcnt with extra 24 zeros+                , SUB    II32 (OpImm (ImmInt 24)) (OpReg dst_r) -- compensate for extra zeros+                ]+            W16 -> toOL+                [ LZCNT  II16 (OpReg src_r) dst_r+                , MOVZxL II16 (OpReg dst_r) (OpReg dst_r) -- zero-extend from 16 bit+                ]+            _ -> unitOL (LZCNT (intFormat width) (OpReg src_r) dst_r)+        else do+          let format = if width == W8 then II16 else intFormat width+          let bw = widthInBits width+          src_r <- getNewRegNat format+          tmp_r <- getNewRegNat format+          return $ code_src src_r `appOL` toOL+                   ([ MOVZxL   II8    (OpReg src_r) (OpReg src_r) | width == W8 ] +++                    [ BSR      format (OpReg src_r) tmp_r+                    , MOV      II32   (OpImm (ImmInt (2*bw-1))) (OpReg dst_r)+                    , CMOV NE  format (OpReg tmp_r) dst_r+                    , XOR      format (OpImm (ImmInt (bw-1))) (OpReg dst_r)+                    ]) -- NB: We don't need to zero-extend the result for the+                       -- W8/W16 cases because the 'MOV' insn already+                       -- took care of implicitly clearing the upper bits++genWordToFloat :: BlockId -> Width -> CmmFormal -> CmmActual -> NatM InstrBlock+genWordToFloat bid width dst src =+  -- TODO: generate assembly instead+  genPrimCCall bid (word2FloatLabel width) [dst] [src]++genAtomicRead :: Width -> MemoryOrdering -> LocalReg -> CmmExpr -> NatM InstrBlock+genAtomicRead width _mord dst addr = do+  let fmt = intFormat width+  load_code <- intLoadCode (MOV fmt) addr+  return (load_code (getLocalRegReg dst))++genAtomicWrite :: Width -> MemoryOrdering -> CmmExpr -> CmmExpr -> NatM InstrBlock+genAtomicWrite width mord addr val = do+  code <- assignMem_IntCode (intFormat width) addr val+  let needs_fence = case mord of+        MemOrderSeqCst  -> True+        MemOrderRelease -> False+        MemOrderAcquire -> pprPanic "genAtomicWrite: acquire ordering on write" empty+        MemOrderRelaxed -> False+  return $ if needs_fence then code `snocOL` MFENCE else code++genCmpXchg+  :: BlockId+  -> Width+  -> LocalReg+  -> CmmExpr+  -> CmmExpr+  -> CmmExpr+  -> NatM InstrBlock+genCmpXchg bid width dst addr old new = do+  is32Bit <- is32BitPlatform+  -- On x86 we don't have enough registers to use cmpxchg with a+  -- complicated addressing mode, so on that architecture we+  -- pre-compute the address first.+  if not (is32Bit && width == W64)+    then do+      let format = intFormat width+      Amode amode addr_code <- getSimpleAmode addr+      newval <- getNewRegNat format+      newval_code <- getAnyReg new+      oldval <- getNewRegNat format+      oldval_code <- getAnyReg old+      platform <- getPlatform+      let dst_r    = getRegisterReg platform  (CmmLocal dst)+          code     = toOL+                     [ MOV format (OpReg oldval) (OpReg eax)+                     , LOCK (CMPXCHG format (OpReg newval) (OpAddr amode))+                     , MOV format (OpReg eax) (OpReg dst_r)+                     ]+      return $ addr_code `appOL` newval_code newval `appOL` oldval_code oldval+          `appOL` code+    else+      -- generate C call to hs_cmpxchgN in ghc-prim+      genPrimCCall bid (cmpxchgLabel width) [dst] [addr,old,new]+      -- TODO: implement cmpxchg8b instruction++genXchg :: Width -> LocalReg -> CmmExpr -> CmmExpr -> NatM InstrBlock+genXchg width dst addr value = do+  is32Bit <- is32BitPlatform++  when (is32Bit && width == W64) $+    panic "genXchg: 64bit atomic exchange not supported on 32bit platforms"++  Amode amode addr_code <- getSimpleAmode addr+  (newval, newval_code) <- getSomeReg value+  let format   = intFormat width+  let dst_r    = getLocalRegReg dst+  -- Copy the value into the target register, perform the exchange.+  let code     = toOL+                 [ MOV format (OpReg newval) (OpReg dst_r)+                  -- On X86 xchg implies a lock prefix if we use a memory argument.+                  -- so this is atomic.+                 , XCHG format (OpAddr amode) dst_r+                 ]+  return $ addr_code `appOL` newval_code `appOL` code+++genFloatAbs :: Width -> LocalReg -> CmmExpr -> NatM InstrBlock+genFloatAbs width dst src = do+  let+    format = floatFormat width+    const = case width of+      W32 -> CmmInt 0x7fffffff W32+      W64 -> CmmInt 0x7fffffffffffffff W64+      _   -> pprPanic "genFloatAbs: invalid width" (ppr width)+  src_code <- getAnyReg src+  Amode amode amode_code <- memConstant (mkAlignment $ widthInBytes width) const+  tmp <- getNewRegNat format+  let dst_r = getLocalRegReg dst+  pure $ src_code dst_r `appOL` amode_code `appOL` toOL+           [ MOV format (OpAddr amode) (OpReg tmp)+           , AND format (OpReg tmp) (OpReg dst_r)+           ]+++genFloatSqrt :: Format -> LocalReg -> CmmExpr -> NatM InstrBlock+genFloatSqrt format dst src = do+  let dst_r = getLocalRegReg dst+  src_code <- getAnyReg src+  pure $ src_code dst_r `snocOL` SQRT format (OpReg dst_r) dst_r+++genAddSubRetCarry+  :: Width+  -> (Format -> Operand -> Operand -> Instr)+  -> (Format -> Maybe (Operand -> Operand -> Instr))+  -> Cond+  -> LocalReg+  -> LocalReg+  -> CmmExpr+  -> CmmExpr+  -> NatM InstrBlock+genAddSubRetCarry width instr mrevinstr cond res_r res_c arg_x arg_y = do+  platform <- ncgPlatform <$> getConfig+  let format = intFormat width+  rCode <- anyReg =<< trivialCode width (instr format)+                        (mrevinstr format) arg_x arg_y+  reg_tmp <- getNewRegNat II8+  let reg_c = getRegisterReg platform  (CmmLocal res_c)+      reg_r = getRegisterReg platform  (CmmLocal res_r)+      code = rCode reg_r `snocOL`+             SETCC cond (OpReg reg_tmp) `snocOL`+             MOVZxL II8 (OpReg reg_tmp) (OpReg reg_c)+  return code+++genAddWithCarry+  :: Width+  -> LocalReg+  -> LocalReg+  -> CmmExpr+  -> CmmExpr+  -> NatM InstrBlock+genAddWithCarry width res_h res_l arg_x arg_y = do+  hCode <- getAnyReg (CmmLit (CmmInt 0 width))+  let format = intFormat width+  lCode <- anyReg =<< trivialCode width (ADD_CC format)+                        (Just (ADD_CC format)) arg_x arg_y+  let reg_l = getLocalRegReg res_l+      reg_h = getLocalRegReg res_h+      code = hCode reg_h `appOL`+             lCode reg_l `snocOL`+             ADC format (OpImm (ImmInteger 0)) (OpReg reg_h)+  return code+++genSignedLargeMul+  :: Width+  -> LocalReg+  -> LocalReg+  -> LocalReg+  -> CmmExpr+  -> CmmExpr+  -> NatM (OrdList Instr)+genSignedLargeMul width res_c res_h res_l arg_x arg_y = do+  (y_reg, y_code) <- getRegOrMem arg_y+  x_code <- getAnyReg arg_x+  reg_tmp <- getNewRegNat II8+  let format = intFormat width+      reg_h = getLocalRegReg res_h+      reg_l = getLocalRegReg res_l+      reg_c = getLocalRegReg res_c+      code = y_code `appOL`+             x_code rax `appOL`+             toOL [ IMUL2 format y_reg+                  , MOV format (OpReg rdx) (OpReg reg_h)+                  , MOV format (OpReg rax) (OpReg reg_l)+                  , SETCC CARRY (OpReg reg_tmp)+                  , MOVZxL II8 (OpReg reg_tmp) (OpReg reg_c)+                  ]+  return code++genUnsignedLargeMul+  :: Width+  -> LocalReg+  -> LocalReg+  -> CmmExpr+  -> CmmExpr+  -> NatM (OrdList Instr)+genUnsignedLargeMul width res_h res_l arg_x arg_y = do+  (y_reg, y_code) <- getRegOrMem arg_y+  x_code <- getAnyReg arg_x+  let format = intFormat width+      reg_h = getLocalRegReg res_h+      reg_l = getLocalRegReg res_l+      code = y_code `appOL`+             x_code rax `appOL`+             toOL [MUL2 format y_reg,+                   MOV format (OpReg rdx) (OpReg reg_h),+                   MOV format (OpReg rax) (OpReg reg_l)]+  return code+++genQuotRem+  :: Width+  -> Bool+  -> LocalReg+  -> LocalReg+  -> Maybe CmmExpr+  -> CmmExpr+  -> CmmExpr+  -> NatM InstrBlock+genQuotRem width signed res_q res_r m_arg_x_high arg_x_low arg_y = do+  case width of+    W8 -> do+      -- See Note [DIV/IDIV for bytes]+      let widen | signed = MO_SS_Conv W8 W16+                | otherwise = MO_UU_Conv W8 W16+          arg_x_low_16 = CmmMachOp widen [arg_x_low]+          arg_y_16 = CmmMachOp widen [arg_y]+          m_arg_x_high_16 = (\p -> CmmMachOp widen [p]) <$> m_arg_x_high+      genQuotRem W16 signed res_q res_r m_arg_x_high_16 arg_x_low_16 arg_y_16++    _ -> do+      let format = intFormat width+          reg_q = getLocalRegReg res_q+          reg_r = getLocalRegReg res_r+          widen | signed    = CLTD format+                | otherwise = XOR format (OpReg rdx) (OpReg rdx)+          instr | signed    = IDIV+                | otherwise = DIV+      (y_reg, y_code) <- getRegOrMem arg_y+      x_low_code <- getAnyReg arg_x_low+      x_high_code <- case m_arg_x_high of+                     Just arg_x_high ->+                         getAnyReg arg_x_high+                     Nothing ->+                         return $ const $ unitOL widen+      return $ y_code `appOL`+               x_low_code rax `appOL`+               x_high_code rdx `appOL`+               toOL [instr format y_reg,+                     MOV format (OpReg rax) (OpReg reg_q),+                     MOV format (OpReg rdx) (OpReg reg_r)]
GHC/CmmToAsm/X86/Instr.hs view
@@ -1,1065 +1,1533 @@-{-# LANGUAGE TypeFamilies #-}------------------------------------------------------------------------------------- Machine-dependent assembly language------ (c) The University of Glasgow 1993-2004-----------------------------------------------------------------------------------module GHC.CmmToAsm.X86.Instr-   ( Instr(..)-   , Operand(..)-   , PrefetchVariant(..)-   , JumpDest(..)-   , getJumpDestBlockId-   , canShortcut-   , shortcutStatics-   , shortcutJump-   , allocMoreStack-   , maxSpillSlots-   , archWordFormat-   , takeRegRegMoveInstr-   , regUsageOfInstr-   , takeDeltaInstr-   , mkLoadInstr-   , mkJumpInstr-   , mkStackAllocInstr-   , mkStackDeallocInstr-   , mkSpillInstr-   , mkRegRegMoveInstr-   , jumpDestsOfInstr-   , patchRegsOfInstr-   , patchJumpInstr-   , isMetaInstr-   , isJumpishInstr-   )-where--import GHC.Prelude--import GHC.CmmToAsm.X86.Cond-import GHC.CmmToAsm.X86.Regs-import GHC.CmmToAsm.Format-import GHC.CmmToAsm.Types-import GHC.CmmToAsm.Utils-import GHC.CmmToAsm.Instr (RegUsage(..), noUsage)-import GHC.Platform.Reg.Class-import GHC.Platform.Reg-import GHC.CmmToAsm.Reg.Target-import GHC.CmmToAsm.Config--import GHC.Cmm.BlockId-import GHC.Cmm.Dataflow.Collections-import GHC.Cmm.Dataflow.Label-import GHC.Platform.Regs-import GHC.Cmm-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.Supply-import GHC.Types.Basic (Alignment)-import GHC.Cmm.DebugBlock (UnwindTable)--import Data.Maybe       (fromMaybe)---- Format of an x86/x86_64 memory address, in bytes.----archWordFormat :: Bool -> Format-archWordFormat is32Bit- | is32Bit   = II32- | otherwise = II64---- -------------------------------------------------------------------------------- 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 SDoc--        -- 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--        -- Moves.-        | MOV         Format Operand Operand-             -- ^ N.B. when used with the 'II64' 'Format', the source-             -- operand is interpreted to be a 32-bit sign-extended value.-             -- True 64-bit operands need to be moved with @MOVABS@, which we-             -- currently don't use.-        | CMOV   Cond Format Operand Reg-        | MOVZxL      Format Operand Operand-              -- ^ 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-        | 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---        -- 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 dont 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--        -- use ADD, SUB, and SQRT 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 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-                      [Reg]            -- ^ 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--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.-regUsageOfInstr :: Platform -> Instr -> RegUsage-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--    -- Result of IMULB will be in just in %ax-    IMUL2  II8 src       -> mkRU (eax:use_R src []) [eax]-    -- Result of IMUL for wider values, will be split between %dx/%edx/%rdx and-    -- %ax/%eax/%rax.-    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 [] []--    X87Store    _  dst    -> mkRUR ( use_EA 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-    SQRT _ src dst      -> mkRU (use_R 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]-    LZCNT  _ src dst -> mkRU (use_R src []) [dst]-    TZCNT  _ src dst -> mkRU (use_R src []) [dst]-    BSF    _ src dst -> mkRU (use_R src []) [dst]-    BSR    _ src dst -> mkRU (use_R src []) [dst]--    PDEP   _ src mask dst -> mkRU (use_R src $ use_R mask []) [dst]-    PEXT   _ src mask dst -> mkRU (use_R src $ use_R mask []) [dst]--    -- note: might be a better way to do this-    PREFETCH _  _ src -> mkRU (use_R src []) []-    LOCK i              -> regUsageOfInstr platform i-    XADD _ src dst      -> usageMM src dst-    CMPXCHG _ src dst   -> usageRMM src dst (OpReg eax)-    XCHG _ src dst      -> usageMM src (OpReg dst)-    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 (OpAddr ea) (OpReg dst) = mkRU (use_EA ea [dst]) [dst]-    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------ | Applies the supplied function to all registers in instructions.--- Typically used to change virtual registers to real registers.-patchRegsOfInstr :: Instr -> (Reg -> Reg) -> Instr-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--    -- 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) (patchOp 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--    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 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--    _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------------------------------------------------------------------------------------isJumpishInstr-        :: Instr -> Bool--isJumpishInstr instr- = case instr of-        JMP{}           -> True-        JXX{}           -> True-        JXX_GBL{}       -> True-        JMP_TBL{}       -> True-        CALL{}          -> True-        _               -> 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-    :: NCGConfig-    -> Reg      -- register to spill-    -> Int      -- current stack delta-    -> Int      -- spill slot to use-    -> [Instr]--mkSpillInstr config reg delta slot-  = let off     = spillSlotToOffset platform slot - delta-    in-    case targetClassOfReg platform reg of-           RcInteger   -> [MOV (archWordFormat is32Bit)-                                   (OpReg reg) (OpAddr (spRel platform off))]-           RcDouble    -> [MOV FF64 (OpReg reg) (OpAddr (spRel platform off))]-           _         -> panic "X86.mkSpillInstr: no match"-    where platform = ncgPlatform config-          is32Bit = target32Bit platform---- | Make a spill reload instruction.-mkLoadInstr-    :: NCGConfig-    -> Reg      -- register to load-    -> Int      -- current stack delta-    -> Int      -- spill slot to use-    -> [Instr]--mkLoadInstr config reg delta slot-  = let off     = spillSlotToOffset platform slot - delta-    in-        case targetClassOfReg platform reg of-              RcInteger -> ([MOV (archWordFormat is32Bit)-                                 (OpAddr (spRel platform off)) (OpReg reg)])-              RcDouble  -> ([MOV FF64 (OpAddr (spRel platform off)) (OpReg reg)])-              _         -> panic "X86.mkLoadInstr"-    where platform = ncgPlatform config-          is32Bit = target32Bit platform--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-    :: Platform-    -> Reg-    -> Reg-    -> Instr--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    ->  MOV FF64 (OpReg src) (OpReg dst)-        -- this code is the lie we tell ourselves because both float and double-        -- use the same register class.on x86_64 and x86 32bit with SSE2,-        -- more plainly, both use the XMM registers-        _     -> 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.----takeRegRegMoveInstr-        :: Instr-        -> Maybe (Reg,Reg)--takeRegRegMoveInstr (MOV _ (OpReg r1) (OpReg r2))-        = Just (r1,r2)--takeRegRegMoveInstr _  = 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    -> amount > (4 * 1024)-                    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    | needs_probe_call platform amount ->-                           [ MOV II32 (OpImm (ImmInt amount)) (OpReg eax)-                           , CALL (Left $ strImmLit "___chkstk_ms") [eax]-                           , SUB II32 (OpReg eax) (OpReg esp)-                           ]-                       | otherwise ->-                           [ SUB II32 (OpImm (ImmInt amount)) (OpReg esp)-                           , TEST II32 (OpReg esp) (OpReg esp)-                           ]-            ArchX86_64 | needs_probe_call platform amount ->-                           [ MOV II64 (OpImm (ImmInt amount)) (OpReg rax)-                           , CALL (Left $ strImmLit "___chkstk_ms") [rax]-                           , SUB II64 (OpReg rax) (OpReg rsp)-                           ]-                       | otherwise ->-                           [ SUB II64 (OpImm (ImmInt amount)) (OpReg rsp)-                           , TEST II64 (OpReg rsp) (OpReg rsp)-                           ]-            _ -> panic "X86.mkStackAllocInstr"-      _       ->-        case platformArch platform of-          ArchX86    -> [ SUB II32 (OpImm (ImmInt amount)) (OpReg esp) ]-          ArchX86_64 -> [ SUB II64 (OpImm (ImmInt amount)) (OpReg rsp) ]-          _ -> panic "X86.mkStackAllocInstr"--mkStackDeallocInstr-        :: Platform-        -> Int-        -> [Instr]-mkStackDeallocInstr platform amount-  = case platformArch platform of-      ArchX86    -> [ADD II32 (OpImm (ImmInt amount)) (OpReg esp)]-      ArchX86_64 -> [ADD II64 (OpImm (ImmInt amount)) (OpReg rsp)]-      _ -> panic "X86.mkStackDeallocInstr"----- Note [extra spill slots]--- ~~~~~~~~~~~~~~~~~~~~~~~~--- If the register allocator used more spill slots than we have--- pre-allocated (rESERVED_C_STACK_BYTES), then we must allocate more--- C stack space on entry and exit from this proc.  Therefore we--- insert a "sub $N, %rsp" at every entry point, and an "add $N, %rsp"--- before every non-local jump.------ This became necessary when the new codegen started bundling entire--- functions together into one proc, because the register allocator--- assigns a different stack slot to each virtual reg within a proc.--- To avoid using so many slots we could also:------   - split up the proc into connected components before code generator------   - rename the virtual regs, so that we re-use vreg names and hence---     stack slots for non-overlapping vregs.------ Note that when a block is both a non-local entry point (with an--- info table) and a local branch target, we have to split it into--- two, like so:------    <info table>---    L:---       <code>------ becomes------    <info table>---    L:---       subl $rsp, N---       jmp Lnew---    Lnew:---       <code>------ and all branches pointing to L are retargetted to point to Lnew.--- Otherwise, we would repeat the $rsp adjustment for each branch to--- L.------ Returns a list of (L,Lnew) pairs.----allocMoreStack-  :: Platform-  -> Int-  -> NatCmmDecl statics GHC.CmmToAsm.X86.Instr.Instr-  -> UniqSM (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--    uniqs <- getUniquesM--    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--      retargetList = (zip entries (map mkBlockId uniqs))--      new_blockmap :: LabelMap BlockId-      new_blockmap = mapFromList retargetList--      insert_stack_insns (BasicBlock id insns)-         | Just new_blockid <- mapLookup id new_blockmap-         = [ BasicBlock id $ alloc ++ [JXX ALWAYS new_blockid]-           , BasicBlock new_blockid block' ]-         | otherwise-         = [ BasicBlock id block' ]-         where-           block' = foldr insert_dealloc [] insns--      insert_dealloc insn r = case insn of-         JMP _ _     -> dealloc ++ (insn : r)-         JXX_GBL _ _ -> panic "insert_dealloc: cannot handle JXX_GBL"-         _other      -> patchJumpInstr insn retarget : r-           where retarget b = fromMaybe b (mapLookup b new_blockmap)--      new_code = concatMap insert_stack_insns code-    -- in-    return (CmmProc info lbl live (ListGraph new_code), retargetList)--data JumpDest = DestBlockId BlockId | DestImm Imm---- Debug Instance-instance Outputable JumpDest where-  ppr (DestBlockId bid) = text "jd<blk>:" <> ppr bid-  ppr (DestImm _imm)    = text "jd<imm>:noShow"---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 emptyUniqSet 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)-        -> UniqSet Unique-        -> BlockId-        -> CLabel--shortBlockId fn seen blockid =-  case (elementOfUniqSet uq seen, fn blockid) of-    (True, _)    -> blockLbl blockid-    (_, Nothing) -> blockLbl blockid-    (_, Just (DestBlockId blockid'))  -> shortBlockId fn (addOneToUniqSet seen uq) blockid'+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE TypeFamilies #-}++-----------------------------------------------------------------------------+--+-- Machine-dependent assembly language+--+-- (c) The University of Glasgow 1993-2004+--+-----------------------------------------------------------------------------++module GHC.CmmToAsm.X86.Instr+   ( Instr(..)+   , Operand(..)+   , PrefetchVariant(..)+   , FMAPermutation(..)+   , JumpDest(..)+   , getJumpDestBlockId+   , canShortcut+   , shortcutStatics+   , shortcutJump+   , allocMoreStack+   , maxSpillSlots+   , archWordFormat+   , takeRegRegMoveInstr+   , regUsageOfInstr+   , takeDeltaInstr+   , mkLoadInstr+   , mkJumpInstr+   , mkStackAllocInstr+   , mkStackDeallocInstr+   , mkSpillInstr+   , mkRegRegMoveInstr+   , movInstr+   , jumpDestsOfInstr+   , canFallthroughTo+   , patchRegsOfInstr+   , patchJumpInstr+   , isMetaInstr+   , isJumpishInstr+   , MinOrMax(..), MinMaxType(..)+   )+where++import GHC.Prelude+import GHC.Data.FastString++import GHC.CmmToAsm.X86.Cond+import GHC.CmmToAsm.X86.Regs+import GHC.CmmToAsm.Format+import GHC.CmmToAsm.Reg.Target (targetClassOfReg)+import GHC.CmmToAsm.Types+import GHC.CmmToAsm.Utils+import GHC.CmmToAsm.Instr (RegUsage(..), noUsage)+import GHC.Platform.Reg+import GHC.Platform.Reg.Class.Unified++import GHC.CmmToAsm.Config++import GHC.Cmm.BlockId+import GHC.Cmm.Dataflow.Label+import GHC.Platform.Regs+import GHC.Cmm+import GHC.Utils.Constants ( debugIsOn )+import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Platform++import GHC.Cmm.CLabel+import GHC.Types.Unique.Set+import GHC.Types.Unique+import GHC.Types.Unique.DSM+import GHC.Types.Basic (Alignment)+import GHC.Cmm.DebugBlock (UnwindTable)+import GHC.Utils.Misc ( HasDebugCallStack )++import GHC.Data.Maybe++-- Format of an x86/x86_64 memory address, in bytes.+--+archWordFormat :: Bool -> Format+archWordFormat is32Bit+ | is32Bit   = II32+ | otherwise = II64++-- -----------------------------------------------------------------------------+-- Intel x86 instructions++data Instr+        -- comment pseudo-op+        = COMMENT FastString++        -- location pseudo-op (file, line, col, name)+        | LOCATION Int Int Int String++        -- some static data spat out during code+        -- generation.  Will be extracted before+        -- pretty-printing.+        | LDATA   Section (Alignment, RawCmmStatics)++        -- start a new basic block.  Useful during+        -- codegen, removed later.  Preceding+        -- instruction should be a jump, as per the+        -- invariants for a BasicBlock (see Cmm).+        | NEWBLOCK BlockId++        -- unwinding information+        -- See Note [Unwinding information in the NCG].+        | UNWIND CLabel UnwindTable++        -- specify current stack offset for benefit of subsequent passes.+        -- This carries a BlockId so it can be used in unwinding information.+        | DELTA  Int++        -- | X86 scalar move instruction.+        --+        -- When used at a vector format, only moves the lower 64 bits of data;+        -- the rest of the data in the destination may either be zeroed or+        -- preserved, depending on the specific format and operands.+        | MOV Format Operand Operand+             -- N.B. Due to AT&T assembler quirks, when used with 'II64'+             -- 'Format' immediate source and memory target operand, the source+             -- operand is interpreted to be a 32-bit sign-extended value.+             -- True 64-bit operands need to be either first moved to a register or moved+             -- with @MOVABS@; we currently do not use this instruction in GHC.+             -- See https://stackoverflow.com/questions/52434073/whats-the-difference-between-the-x86-64-att-instructions-movq-and-movabsq.++        -- | MOVD/MOVQ SSE2 instructions+        -- (bitcast between a general purpose register and a float register).+        | MOVD+           Format -- ^ input format+           Format -- ^ output format+           Operand Operand+           -- NB: MOVD stores both the input and output formats. This is because+           -- neither format fully determines the other, as either might be+           -- a vector format, and we need to know the exact format in order to+           -- correctly spill/unspill. See #25659.+        | CMOV   Cond Format Operand Reg+        | MOVZxL      Format Operand Operand+              -- ^ The format argument is the size of operand 1 (the number of bits we keep)+              -- We always zero *all* high bits, even though this isn't how the actual instruction+              -- works. The code generator also seems to rely on this behaviour and it's faster+              -- to execute on many cpus as well so for now I'm just documenting the fact.+        | MOVSxL      Format Operand Operand -- format is the size of operand 1+        -- x86_64 note: plain mov into a 32-bit register always zero-extends+        -- into the 64-bit reg, in contrast to the 8 and 16-bit movs which+        -- don't affect the high bits of the register.++        -- Load effective address (also a very useful three-operand add instruction :-)+        | LEA         Format Operand Operand++        -- Int Arithmetic.+        | ADD         Format Operand Operand+        | ADC         Format Operand Operand+        | SUB         Format Operand Operand+        | SBB         Format Operand Operand++        | MUL         Format Operand Operand+        | MUL2        Format Operand         -- %edx:%eax = operand * %rax+        | IMUL        Format Operand Operand -- signed int mul+        | IMUL2       Format Operand         -- %edx:%eax = operand * %eax++        | DIV         Format Operand         -- eax := eax:edx/op, edx := eax:edx%op+        | IDIV        Format Operand         -- ditto, but signed++        -- Int Arithmetic, where the effects on the condition register+        -- are important. Used in specialized sequences such as MO_Add2.+        -- Do not rewrite these instructions to "equivalent" ones that+        -- have different effect on the condition register! (See #9013.)+        | ADD_CC      Format Operand Operand+        | SUB_CC      Format Operand Operand++        -- Simple bit-twiddling.+        | AND         Format Operand Operand+        | OR          Format Operand Operand+        | XOR         Format Operand Operand+        -- | AVX bitwise logical XOR operation+        | VXOR        Format Operand Reg Reg+        | NOT         Format Operand+        | NEGI        Format Operand         -- NEG instruction (name clash with Cond)+        | BSWAP       Format Reg++        -- Shifts (amount may be immediate or %cl only)+        | SHL         Format Operand{-amount-} Operand+        | SAR         Format Operand{-amount-} Operand+        | SHR         Format Operand{-amount-} Operand+        | SHRD        Format Operand{-amount-} Operand Operand+        | SHLD        Format Operand{-amount-} Operand Operand++        | BT          Format Imm Operand+        | NOP+++        -- We need to support the FSTP (x87 store and pop) instruction+        -- so that we can correctly read off the return value of an+        -- x86 CDECL C function call when its floating point.+        -- so we don't include a register argument, and just use st(0)+        -- this instruction is used ONLY for return values of C ffi calls+        -- in x86_32 abi+        | X87Store         Format  AddrMode -- st(0), dst+++        -- SSE2 floating point: we use a restricted set of the available SSE2+        -- instructions for floating-point.+        -- use MOV for moving (either movss or movsd (movlpd better?))+        | CVTSS2SD      Reg Reg            -- F32 to F64+        | CVTSD2SS      Reg Reg            -- F64 to F32+        | CVTTSS2SIQ    Format Operand Reg -- F32 to I32/I64 (with truncation)+        | CVTTSD2SIQ    Format Operand Reg -- F64 to I32/I64 (with truncation)+        | CVTSI2SS      Format Operand Reg -- I32/I64 to F32+        | CVTSI2SD      Format Operand Reg -- I32/I64 to F64++        -- | FMA3 fused multiply-add operations.+        | FMA3         Format FMASign FMAPermutation Operand Reg Reg+          -- For the FMA213 permutation (the only one we use currently),+          -- this is: src3 (r/m), src2 (r), dst/src1 (r)+          -- (NB: this isexactly reversed from how Intel lists the arguments.)++        -- use ADD, SUB, and SQRT for arithmetic.  In both cases, operands+        -- are  Operand Reg.++        -- SSE2 floating-point division:+        | FDIV          Format Operand Reg   -- divisor, dividend(dst)++        -- use CMP for comparisons.  ucomiss and ucomisd instructions+        -- compare single/double prec floating point respectively.++        | SQRT          Format Operand Reg      -- src, dst+++        -- Comparison+        | TEST          Format Operand Operand+        | CMP           Format Operand Operand+        | SETCC         Cond Operand++        -- Stack Operations.+        | PUSH          Format Operand+        | POP           Format Operand+        -- both unused (SDM):+        --  | PUSHA+        --  | POPA++        -- Jumping around.+        | JMP         Operand [RegWithFormat] -- including live Regs at the call+        | JXX         Cond BlockId  -- includes unconditional branches+        | JXX_GBL     Cond Imm      -- non-local version of JXX+        -- Table jump+        | JMP_TBL     Operand   -- Address to jump to+                      [Maybe JumpDest] -- Targets of the jump table+                      Section   -- Data section jump table should be put in+                      CLabel    -- Label of jump table+        -- | X86 call instruction+        | CALL        (Either Imm Reg) -- ^ Jump target+                      [RegWithFormat]  -- ^ Arguments (required for register allocation)++        -- Other things.+        | CLTD Format            -- sign extend %eax into %edx:%eax++        | FETCHGOT    Reg        -- pseudo-insn for ELF position-independent code+                                 -- pretty-prints as+                                 --       call 1f+                                 -- 1:    popl %reg+                                 --       addl __GLOBAL_OFFSET_TABLE__+.-1b, %reg+        | FETCHPC     Reg        -- pseudo-insn for Darwin position-independent code+                                 -- pretty-prints as+                                 --       call 1f+                                 -- 1:    popl %reg++    -- bit counting instructions+        | POPCNT      Format Operand Reg -- [SSE4.2] count number of bits set to 1+        | LZCNT       Format Operand Reg -- [BMI2] count number of leading zeros+        | TZCNT       Format Operand Reg -- [BMI2] count number of trailing zeros+        | BSF         Format Operand Reg -- bit scan forward+        | BSR         Format Operand Reg -- bit scan reverse++    -- bit manipulation instructions+        | PDEP        Format Operand Operand Reg -- [BMI2] deposit bits to   the specified mask+        | PEXT        Format Operand Operand Reg -- [BMI2] extract bits from the specified mask++    -- prefetch+        | PREFETCH  PrefetchVariant Format Operand -- prefetch Variant, addr size, address to prefetch+                                        -- variant can be NTA, Lvl0, Lvl1, or Lvl2++        | LOCK        Instr -- lock prefix+        | XADD        Format Operand Operand -- src (r), dst (r/m)+        | CMPXCHG     Format Operand Operand -- src (r), dst (r/m), eax implicit+        | XCHG        Format Operand Reg     -- src (r/m), dst (r/m)+        | MFENCE++        -- Vector Instructions --+        -- NOTE: Instructions follow the AT&T syntax+        -- Constructors and deconstructors+        | VBROADCAST  Format Operand Reg+        | VPBROADCAST Format Format Operand Reg -- scalar format, vector format, source, destination+        | VEXTRACT    Format Imm Reg Operand+        | INSERTPS    Format Imm Operand Reg+        | VINSERTPS   Format Imm Operand Reg Reg+        | PINSR       Format Format Imm Operand Reg -- scalar format, vector format, offset, scalar src, vector+        | PEXTR       Format Format Imm Reg Operand -- scalar format, vector format, offset, vector src, scalar dst++        -- move operations++        -- | SSE2 unaligned move of floating-point vectors+        | MOVU        Format Operand Operand+        -- | AVX unaligned move of floating-point vectors+        | VMOVU       Format Operand Operand+        -- | SSE2 move between memory and low-part of an xmm register+        | MOVL        Format Operand Operand+        -- | SSE move between memory and high-part of an xmm register+        | MOVH        Format Operand Operand+        -- | SSE2 unaligned move of integer vectors+        | MOVDQU      Format Operand Operand+        -- | AVX unaligned move of integer vectors+        | VMOVDQU     Format Operand Operand+        -- | Alias for VMOVSS/VMOVSD, used to merge two vectors+        | VMOV_MERGE  Format Reg Reg Reg++        -- logic operations+        | PXOR        Format Operand Reg+        | VPXOR       Format Reg Reg Reg+        | PAND        Format Operand Reg+        | PANDN       Format Operand Reg+        | POR         Format Operand Reg++        -- Arithmetic+        | VADD       Format Operand Reg Reg+        | VSUB       Format Operand Reg Reg+        | VMUL       Format Operand Reg Reg+        | VDIV       Format Operand Reg Reg+        | PADD       Format Operand Reg+        | PSUB       Format Operand Reg+        | PMULL      Format Operand Reg+        | PMULUDQ    Format Operand Reg++        -- SIMD compare+        | PCMPGT     Format Operand Reg++        -- Shuffle+        | SHUF       Format Imm Operand Reg+        | VSHUF      Format Imm Operand Reg Reg+        | PSHUFB     Format Operand Reg+        | PSHUFLW    Format Imm Operand Reg+        | PSHUFHW    Format Imm Operand Reg+        | PSHUFD     Format Imm Operand Reg+        | VPSHUFD    Format Imm Operand Reg+        | BLEND      Format Imm Operand Reg+        | VBLEND     Format Imm Operand Reg Reg+        | PBLENDW    Format Imm Operand Reg++        -- | Move two 32-bit floats from the high part of an xmm register+        -- to the low part of another xmm register.+        --+        -- If the format is a vector format, the destination register is treated as the second source.+        -- If the format is FF32 or FF64, the destination register is not treated as a source.+        | MOVHLPS    Format Reg Reg+        | VMOVHLPS   Format Reg Reg Reg+        | MOVLHPS    Format Reg Reg+        | VMOVLHPS   Format Reg Reg Reg+        | UNPCKL     Format Operand Reg+        | VUNPCKL    Format Operand Reg Reg+        | UNPCKH     Format Operand Reg+        | VUNPCKH    Format Operand Reg Reg+        | PUNPCKLQDQ Format Operand Reg+        | PUNPCKLDQ  Format Operand Reg+        | PUNPCKLWD  Format Operand Reg+        | PUNPCKLBW  Format Operand Reg+        | PUNPCKHQDQ Format Operand Reg+        | PUNPCKHDQ  Format Operand Reg+        | PUNPCKHWD  Format Operand Reg+        | PUNPCKHBW  Format Operand Reg+        | PACKUSWB   Format Operand Reg++        -- Shift+        | PSLL       Format Operand Reg+        | PSLLDQ     Format Imm Reg+        | PSRL       Format Operand Reg+        | PSRLDQ     Format Imm Reg+        | PALIGNR    Format Imm Operand Reg++        -- min/max+        | MINMAX  MinOrMax MinMaxType Format Operand Reg+        | VMINMAX MinOrMax MinMaxType Format Operand Reg Reg++data PrefetchVariant = NTA | Lvl0 | Lvl1 | Lvl2++-- | 'MIN' or 'MAX'+data MinOrMax = Min | Max+  deriving ( Eq, Show )+-- | What kind of min/max operation: signed or unsigned vector integer min/max,+-- or (scalar or vector) floating point min/max?+data MinMaxType =+  IntVecMinMax { minMaxSigned :: Bool } | FloatMinMax+  deriving ( Eq, Show )++data Operand+        = OpReg  Reg            -- register+        | OpImm  Imm            -- immediate value+        | OpAddr AddrMode       -- memory reference++-- NB: As of 2023 we only use the FMA213 permutation.+data FMAPermutation = FMA132 | FMA213 | FMA231++-- | Returns which registers are read and written as a (read, written)+-- pair.+regUsageOfInstr :: Platform -> Instr -> RegUsage+regUsageOfInstr platform instr+ = case instr of+    MOV fmt src dst+      -- MOVSS/MOVSD preserve the upper half of vector registers,+      -- but only for reg-2-reg moves+      | VecFormat _ sFmt <- fmt+      , isFloatScalarFormat sFmt+      , OpReg {} <- src+      , OpReg {} <- dst+      -> usageRM fmt src dst+      -- other MOV instructions zero any remaining upper part of the destination+      -- (largely to avoid partial register stalls)+      | otherwise+      -> usageRW fmt src dst+    MOVD fmt1 fmt2 src dst    ->+      -- NB: MOVD and MOVQ always zero any remaining upper part of destination,+      -- so the destination is "written" not "modified".+      usageRW' fmt1 fmt2 src dst+    CMOV _ fmt src dst    -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst]+    MOVZxL fmt src dst    -> usageRW fmt src dst+    MOVSxL fmt src dst    -> usageRW fmt src dst+    LEA    fmt src dst    -> usageRW fmt src dst+    ADD    fmt src dst    -> usageRM fmt src dst+    ADC    fmt src dst    -> usageRM fmt src dst+    SUB    fmt src dst    -> usageRM fmt src dst+    SBB    fmt src dst    -> usageRM fmt src dst+    IMUL   fmt src dst    -> usageRM fmt src dst++    -- Result of IMULB will be in just in %ax+    IMUL2  II8 src       -> mkRU (mk II8 eax:use_R II8 src []) [mk II8 eax]+    -- Result of IMUL for wider values, will be split between %dx/%edx/%rdx and+    -- %ax/%eax/%rax.+    IMUL2  fmt src        -> mkRU (mk fmt eax:use_R fmt src []) [mk fmt eax,mk fmt edx]++    MUL    fmt src dst    -> usageRM fmt src dst+    MUL2   fmt src        -> mkRU (mk fmt eax:use_R fmt src []) [mk fmt eax,mk fmt edx]+    DIV    fmt op -> mkRU (mk fmt eax:mk fmt edx:use_R fmt op []) [mk fmt eax, mk fmt edx]+    IDIV   fmt op -> mkRU (mk fmt eax:mk fmt edx:use_R fmt op []) [mk fmt eax, mk fmt edx]+    ADD_CC fmt src dst    -> usageRM fmt src dst+    SUB_CC fmt src dst    -> usageRM fmt src dst+    AND    fmt src dst    -> usageRM fmt src dst+    OR     fmt src dst    -> usageRM fmt src dst++    XOR    fmt (OpReg src) (OpReg dst)+      | src == dst+      -> mkRU [] [mk fmt dst]+    XOR    fmt src dst+      -> usageRM fmt src dst+    VXOR fmt (OpReg src1) src2 dst+      | src1 == src2, src1 == dst+      -> mkRU [] [mk fmt dst]+    VXOR fmt src1 src2 dst+      -> mkRU (use_R fmt src1 [mk fmt src2]) [mk fmt dst]++    NOT    fmt op         -> usageM fmt op+    BSWAP  fmt reg        -> mkRU [mk fmt reg] [mk fmt reg]+    NEGI   fmt op         -> usageM fmt op+    SHL    fmt imm dst    -> usageRM fmt imm dst+    SAR    fmt imm dst    -> usageRM fmt imm dst+    SHR    fmt imm dst    -> usageRM fmt imm dst+    SHLD   fmt imm dst1 dst2 -> usageRMM fmt imm dst1 dst2+    SHRD   fmt imm dst1 dst2 -> usageRMM fmt imm dst1 dst2+    BT     fmt _   src    -> mkRUR (use_R fmt src [])++    PUSH   fmt op         -> mkRUR (use_R fmt op [])+    POP    fmt op         -> mkRU [] (def_W fmt op)+    TEST   fmt src dst    -> mkRUR (use_R fmt src $! use_R fmt dst [])+    CMP    fmt src dst    -> mkRUR (use_R fmt src $! use_R fmt dst [])+    SETCC  _ op         -> mkRU [] (def_W II8 op)+    JXX    _ _          -> mkRU [] []+    JXX_GBL _ _         -> mkRU [] []+    JMP     op regs     -> mkRU (use_R addrFmt op regs) []+    JMP_TBL op _ _ _    -> mkRU (use_R addrFmt op []) []+    CALL (Left _)  params   -> mkRU params (map mkFmt $ callClobberedRegs platform)+    CALL (Right reg) params -> mkRU (mk addrFmt reg:params) (map mkFmt $ callClobberedRegs platform)+    CLTD   fmt          -> mkRU [mk fmt eax] [mk fmt edx]+    NOP                 -> mkRU [] []++    X87Store _fmt  dst -> mkRUR (use_EA dst [])++    CVTSS2SD   src dst  -> mkRU [mk FF32 src] [mk FF64 dst]+    CVTSD2SS   src dst  -> mkRU [mk FF64 src] [mk FF32 dst]+    CVTTSS2SIQ fmt src dst -> mkRU (use_R FF32 src []) [mk fmt dst]+    CVTTSD2SIQ fmt src dst -> mkRU (use_R FF64 src []) [mk fmt dst]+    CVTSI2SS   fmt src dst -> mkRU (use_R fmt src []) [mk FF32 dst]+    CVTSI2SD   fmt src dst -> mkRU (use_R fmt src []) [mk FF64 dst]+    FDIV fmt     src dst  -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst]+    SQRT fmt src dst      -> mkRU (use_R fmt src []) [mk fmt dst]++    FETCHGOT reg        -> mkRU [] [mk addrFmt reg]+    FETCHPC  reg        -> mkRU [] [mk addrFmt reg]++    COMMENT _           -> noUsage+    LOCATION{}          -> noUsage+    UNWIND{}            -> noUsage+    DELTA   _           -> noUsage++    POPCNT fmt src dst -> mkRU (use_R fmt src []) [mk fmt dst]+    LZCNT  fmt src dst -> mkRU (use_R fmt src []) [mk fmt dst]+    TZCNT  fmt src dst -> mkRU (use_R fmt src []) [mk fmt dst]+    BSF    fmt src dst -> mkRU (use_R fmt src []) [mk fmt dst]+    BSR    fmt src dst -> mkRU (use_R fmt src []) [mk fmt dst]++    PDEP   fmt src mask dst -> mkRU (use_R fmt src $ use_R fmt mask []) [mk fmt dst]+    PEXT   fmt src mask dst -> mkRU (use_R fmt src $ use_R fmt mask []) [mk fmt dst]++    FMA3 fmt _ _ src3 src2 dst -> usageFMA fmt src3 src2 dst++    -- note: might be a better way to do this+    PREFETCH _  fmt src -> mkRU (use_R fmt src []) []+    LOCK i              -> regUsageOfInstr platform i+    XADD fmt src dst      -> usageMM fmt src dst+    CMPXCHG fmt src dst   -> usageRMM fmt src dst (OpReg eax)+    XCHG fmt src dst      -> usageMM fmt src (OpReg dst)+    MFENCE -> noUsage++    -- vector instructions+    VBROADCAST fmt src dst   -> mkRU (use_R fmt src []) [mk fmt dst]+    VPBROADCAST sFmt vFmt src dst -> mkRU (use_R sFmt src []) [mk vFmt dst]+    VEXTRACT     fmt _off src dst -> usageRW fmt (OpReg src) dst+    INSERTPS     fmt (ImmInt off) src dst+      -> mkRU ((use_R fmt src []) ++ [mk fmt dst | not doesNotReadDst]) [mk fmt dst]+        where+          -- Compute whether the instruction reads the destination register or not.+          -- Immediate bits: ss_dd_zzzz s = src pos, d = dst pos, z = zeroed components.+          doesNotReadDst = and [ testBit off i | i <- [0, 1, 2, 3], i /= pos ]+            -- Check whether the positions in which we are not inserting+            -- are being zeroed.+            where pos = ( off `shiftR` 4 ) .&. 0b11+    INSERTPS fmt _off src dst+      -> mkRU ((use_R fmt src []) ++ [mk fmt dst]) [mk fmt dst]+    VINSERTPS fmt _imm src2 src1 dst+      -> mkRU (use_R fmt src2 [mk fmt src1]) [mk fmt dst]+    PINSR sFmt vFmt _off src dst+      -> mkRU (use_R sFmt src [mk vFmt dst]) [mk vFmt dst]+    PEXTR sFmt vFmt _off src dst+      -> usageRW' vFmt sFmt (OpReg src) dst++    VMOVU        fmt src dst   -> usageRW fmt src dst+    MOVU         fmt src dst   -> usageRW fmt src dst+    MOVL         fmt src dst   -> usageRM fmt src dst+    MOVH         fmt src dst   -> usageRM fmt src dst+    MOVDQU       fmt src dst   -> usageRW fmt src dst+    VMOVDQU      fmt src dst   -> usageRW fmt src dst+    VMOV_MERGE   fmt src2 src1 dst -> mkRU [mk fmt src1, mk fmt src2] [mk fmt dst]++    PXOR fmt (OpReg src) dst+      | src == dst+      -> mkRU [] [mk fmt dst]+      | otherwise+      -> mkRU [mk fmt src, mk fmt dst] [mk fmt dst]++    VPXOR        fmt s1 s2 dst+      | s1 == s2, s1 == dst+      -> mkRU [] [mk fmt dst]+      | otherwise+      -> mkRU [mk fmt s1, mk fmt s2] [mk fmt dst]++    PAND         fmt src dst   -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst]+    PANDN        fmt src dst   -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst]+    POR          fmt src dst   -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst]++    VADD         fmt s1 s2 dst -> mkRU ((use_R fmt s1 []) ++ [mk fmt s2]) [mk fmt dst]+    VSUB         fmt s1 s2 dst -> mkRU ((use_R fmt s1 []) ++ [mk fmt s2]) [mk fmt dst]+    VMUL         fmt s1 s2 dst -> mkRU ((use_R fmt s1 []) ++ [mk fmt s2]) [mk fmt dst]+    VDIV         fmt s1 s2 dst -> mkRU ((use_R fmt s1 []) ++ [mk fmt s2]) [mk fmt dst]+    PADD         fmt src dst   -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst]+    PSUB         fmt src dst   -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst]+    PMULL        fmt src dst   -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst]+    PMULUDQ      fmt src dst   -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst]++    PCMPGT       fmt src dst   -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst]++    SHUF fmt _mask src dst+      -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst]+    VSHUF fmt _mask src1 src2 dst+      -> mkRU (use_R fmt src1 [mk fmt src2]) [mk fmt dst]+    PSHUFB fmt mask dst+      -> mkRU (use_R fmt mask [mk fmt dst]) [mk fmt dst]+    PSHUFLW fmt _mask src dst+      -> mkRU (use_R fmt src []) [mk fmt dst]+    PSHUFHW fmt _mask src dst+      -> mkRU (use_R fmt src []) [mk fmt dst]+    PSHUFD fmt _mask src dst+      -> mkRU (use_R fmt src []) [mk fmt dst]+    VPSHUFD fmt _mask src dst+      -> mkRU (use_R fmt src []) [mk fmt dst]+    BLEND fmt _mask src dst+      -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst]+    VBLEND fmt _mask src2 src1 dst+      -> mkRU (use_R fmt src2 [mk fmt src1]) [mk fmt dst]+    PBLENDW fmt _mask src dst+      -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst]++    PSLL   fmt off dst -> mkRU (use_R fmt off [mk fmt dst]) [mk fmt dst]+    PSLLDQ fmt _off dst -> mkRU [mk fmt dst] [mk fmt dst]+    PSRL   fmt off dst -> mkRU (use_R fmt off [mk fmt dst]) [mk fmt dst]+    PSRLDQ fmt _off dst -> mkRU [mk fmt dst] [mk fmt dst]+    PALIGNR fmt _off src dst -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst]++    MOVHLPS    fmt src dst+      -> case fmt of+           VecFormat {} -> mkRU [mk fmt src, mk fmt dst] [mk fmt dst]+           -- MOVHLPS moves the high 64 bits of src to the low 64 bits of dst,+           -- keeping the high 64 bits of dst intact.+           -- If we only care about the lower 64 bits of the result,+           -- dst is only written to, not read.+           FF64 -> mkRU [mk (VecFormat 2 FmtDouble) src] [mk fmt dst]+           FF32 -> mkRU [mk (VecFormat 4 FmtFloat) src] [mk fmt dst]+           _ -> pprPanic "regUsage: invalid format for MOVHLPS" (ppr fmt)+    VMOVHLPS   fmt src2 src1 dst+      -> mkRU [mk fmt src1, mk fmt src2] [mk fmt dst]+    MOVLHPS    fmt src dst+      -> mkRU [mk fmt src, mk fmt dst] [mk fmt dst]+    VMOVLHPS   fmt src2 src1 dst+      -> mkRU [mk fmt src1, mk fmt src2] [mk fmt dst]+    UNPCKL fmt src dst+      -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst]+    VUNPCKL fmt src2 src1 dst+      -> mkRU (use_R fmt src2 [mk fmt src1]) [mk fmt dst]+    UNPCKH fmt src dst+      -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst]+    VUNPCKH fmt src2 src1 dst+      -> mkRU (use_R fmt src2 [mk fmt src1]) [mk fmt dst]+    PUNPCKLQDQ fmt src dst+      -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst]+    PUNPCKLDQ fmt src dst+      -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst]+    PUNPCKLWD fmt src dst+      -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst]+    PUNPCKLBW fmt src dst+      -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst]+    PUNPCKHQDQ fmt src dst+      -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst]+    PUNPCKHDQ fmt src dst+      -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst]+    PUNPCKHWD fmt src dst+      -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst]+    PUNPCKHBW fmt src dst+      -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst]+    PACKUSWB fmt src dst+      -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst]++    MINMAX _ _ fmt src dst+      -> mkRU (use_R fmt src [mk fmt dst]) [mk fmt dst]+    VMINMAX _ _ fmt src1 src2 dst+      -> mkRU (use_R fmt src1 [mk fmt src2]) [mk fmt dst]+    _other              -> panic "regUsage: unrecognised instr"+ where++    -- # Definitions+    --+    -- Written: If the operand is a register, it's written. If it's an+    -- address, registers mentioned in the address are read.+    --+    -- Modified: If the operand is a register, it's both read and+    -- written. If it's an address, registers mentioned in the address+    -- are read.++    -- 2 operand form; first operand Read; second Written+    usageRW :: HasDebugCallStack => Format -> Operand -> Operand -> RegUsage+    usageRW fmt op (OpReg reg)      = mkRU (use_R fmt op []) [mk fmt reg]+    usageRW fmt op (OpAddr ea)      = mkRUR (use_R fmt op $! use_EA ea [])+    usageRW _ _ _                   = panic "X86.RegInfo.usageRW: no match"++    usageRW' :: HasDebugCallStack => Format -> Format -> Operand -> Operand -> RegUsage+    usageRW' fmt1 fmt2 op (OpReg reg) = mkRU (use_R fmt1 op []) [mk fmt2 reg]+    usageRW' fmt1 _    op (OpAddr ea) = mkRUR (use_R fmt1 op $! use_EA ea [])+    usageRW' _  _ _ _                 = panic "X86.RegInfo.usageRW: no match"++    -- 2 operand form; first operand Read; second Modified+    usageRM :: HasDebugCallStack => Format -> Operand -> Operand -> RegUsage+    usageRM fmt op (OpReg reg)      = mkRU (use_R fmt op [mk fmt reg]) [mk fmt reg]+    usageRM fmt op (OpAddr ea)      = mkRUR (use_R fmt op $! use_EA ea [])+    usageRM _ _ _                   = panic "X86.RegInfo.usageRM: no match"++    -- 2 operand form; first operand Modified; second Modified+    usageMM :: HasDebugCallStack => Format -> Operand -> Operand -> RegUsage+    usageMM fmt (OpReg src) (OpReg dst) = mkRU [mk fmt src, mk fmt dst] [mk fmt src, mk fmt dst]+    usageMM fmt (OpReg src) (OpAddr ea) = mkRU (use_EA ea [mk fmt src]) [mk fmt src]+    usageMM fmt (OpAddr ea) (OpReg dst) = mkRU (use_EA ea [mk fmt dst]) [mk fmt dst]+    usageMM _ _ _                       = panic "X86.RegInfo.usageMM: no match"++    -- 3 operand form; first operand Read; second Modified; third Modified+    usageRMM :: HasDebugCallStack => Format -> Operand -> Operand -> Operand -> RegUsage+    usageRMM fmt (OpReg src) (OpReg dst) (OpReg reg) = mkRU [mk fmt src, mk fmt dst, mk fmt reg] [mk fmt dst, mk fmt reg]+    usageRMM fmt (OpReg src) (OpAddr ea) (OpReg reg) = mkRU (use_EA ea [mk fmt src, mk fmt reg]) [mk fmt reg]+    usageRMM _ _ _ _                                 = panic "X86.RegInfo.usageRMM: no match"++    -- 3 operand form of FMA instructions.+    usageFMA :: HasDebugCallStack => Format -> Operand -> Reg -> Reg -> RegUsage+    usageFMA fmt (OpReg src1) src2 dst =+      mkRU [mk fmt src1, mk fmt src2, mk fmt dst] [mk fmt dst]+    usageFMA fmt (OpAddr ea1) src2 dst+      = mkRU (use_EA ea1 [mk fmt src2, mk fmt  dst]) [mk fmt dst]+    usageFMA _ _ _ _+      = panic "X86.RegInfo.usageFMA: no match"++    -- 1 operand form; operand Modified+    usageM :: HasDebugCallStack => Format -> Operand -> RegUsage+    usageM fmt (OpReg reg) =+      let r' = mk fmt reg+      in mkRU [r'] [r']+    usageM _ (OpAddr ea) = mkRUR (use_EA ea [])+    usageM _ _ = panic "X86.RegInfo.usageM: no match"++    -- Registers defd when an operand is written.+    def_W fmt (OpReg reg)         = [mk fmt reg]+    def_W _   (OpAddr _ )         = []+    def_W _   _                   = panic "X86.RegInfo.def_W: no match"++    -- Registers used when an operand is read.+    use_R :: HasDebugCallStack => Format -> Operand -> [RegWithFormat] -> [RegWithFormat]+    use_R fmt (OpReg reg)  tl = mk fmt reg : tl+    use_R _   (OpImm _)    tl = tl+    use_R _   (OpAddr ea)  tl = use_EA ea tl++    -- Registers used to compute an effective address.+    use_EA (ImmAddr _ _) tl = tl+    use_EA (AddrBaseIndex base index _) tl =+        use_base base $! use_index index tl+        where use_base (EABaseReg r)  tl = mk addrFmt r : tl+              use_base _              tl = tl+              use_index EAIndexNone   tl = tl+              use_index (EAIndex i _) tl = mk addrFmt i : tl++    mkRUR :: [RegWithFormat] -> RegUsage+    mkRUR src = mkRU src []++    mkRU :: [RegWithFormat] -> [RegWithFormat] -> RegUsage+    mkRU src dst = src' `seq` dst' `seq` RU src' dst'+        where src' = filter (interesting platform . regWithFormat_reg) src+              dst' = filter (interesting platform . regWithFormat_reg) dst++    addrFmt = archWordFormat (target32Bit platform)+    mk :: Format -> Reg -> RegWithFormat+    mk fmt r = RegWithFormat r fmt++    mkFmt :: Reg -> RegWithFormat+    mkFmt r = RegWithFormat r $ case targetClassOfReg platform r of+      RcInteger -> addrFmt+      RcFloatOrVector -> FF64++-- | Is this register interesting for the register allocator?+interesting :: Platform -> Reg -> Bool+interesting _        (RegVirtual _)              = True+interesting platform (RegReal (RealRegSingle i)) = freeReg platform i+++-- | Applies the supplied function to all registers in instructions.+-- Typically used to change virtual registers to real registers.+patchRegsOfInstr :: HasDebugCallStack => Platform -> Instr -> (Reg -> Reg) -> Instr+patchRegsOfInstr platform instr env+  = case instr of+    MOV fmt src dst      -> MOV fmt (patchOp src) (patchOp dst)+    MOVD fmt1 fmt2 src dst -> patch2 (MOVD fmt1 fmt2) src dst+    CMOV cc fmt src dst  -> CMOV cc fmt (patchOp src) (env dst)+    MOVZxL fmt src dst   -> patch2 (MOVZxL fmt) src dst+    MOVSxL fmt src dst   -> patch2 (MOVSxL fmt) src dst+    LEA  fmt src dst     -> patch2 (LEA  fmt) src dst+    ADD  fmt src dst     -> patch2 (ADD  fmt) src dst+    ADC  fmt src dst     -> patch2 (ADC  fmt) src dst+    SUB  fmt src dst     -> patch2 (SUB  fmt) src dst+    SBB  fmt src dst     -> patch2 (SBB  fmt) src dst+    IMUL fmt src dst     -> patch2 (IMUL fmt) src dst+    IMUL2 fmt src        -> patch1 (IMUL2 fmt) src+    MUL fmt src dst      -> patch2 (MUL fmt) src dst+    MUL2 fmt src         -> patch1 (MUL2 fmt) src+    IDIV fmt op          -> patch1 (IDIV fmt) op+    DIV fmt op           -> patch1 (DIV fmt) op+    ADD_CC fmt src dst   -> patch2 (ADD_CC fmt) src dst+    SUB_CC fmt src dst   -> patch2 (SUB_CC fmt) src dst+    AND  fmt src dst     -> patch2 (AND  fmt) src dst+    OR   fmt src dst     -> patch2 (OR   fmt) src dst+    XOR  fmt src dst     -> patch2 (XOR  fmt) src dst+    VXOR fmt src1 src2 dst -> VXOR fmt (patchOp src1) (env src2) (env dst)+    NOT  fmt op          -> patch1 (NOT  fmt) op+    BSWAP fmt reg        -> BSWAP fmt (env reg)+    NEGI fmt op          -> patch1 (NEGI fmt) op+    SHL  fmt imm dst     -> patch1 (SHL fmt imm) dst+    SAR  fmt imm dst     -> patch1 (SAR fmt imm) dst+    SHR  fmt imm dst     -> patch1 (SHR fmt imm) dst+    SHLD fmt imm dst1 dst2 -> patch2 (SHLD fmt imm) dst1 dst2+    SHRD fmt imm dst1 dst2 -> patch2 (SHRD fmt imm) dst1 dst2+    BT   fmt imm src     -> patch1 (BT  fmt imm) src+    TEST fmt src dst     -> patch2 (TEST fmt) src dst+    CMP  fmt src dst     -> patch2 (CMP  fmt) src dst+    PUSH fmt op          -> patch1 (PUSH fmt) op+    POP  fmt op          -> patch1 (POP  fmt) op+    SETCC cond op        -> patch1 (SETCC cond) op+    JMP op regs          -> JMP (patchOp op) regs+    JMP_TBL op ids s lbl -> JMP_TBL (patchOp op) ids s lbl++    FMA3 fmt perm var x1 x2 x3 -> patch3 (FMA3 fmt perm var) x1 x2 x3++    -- literally only support storing the top x87 stack value st(0)+    X87Store  fmt  dst     -> X87Store fmt  (lookupAddr dst)++    CVTSS2SD src dst    -> CVTSS2SD (env src) (env dst)+    CVTSD2SS src dst    -> CVTSD2SS (env src) (env dst)+    CVTTSS2SIQ fmt src dst -> CVTTSS2SIQ fmt (patchOp src) (env dst)+    CVTTSD2SIQ fmt src dst -> CVTTSD2SIQ fmt (patchOp src) (env dst)+    CVTSI2SS fmt src dst -> CVTSI2SS fmt (patchOp src) (env dst)+    CVTSI2SD fmt src dst -> CVTSI2SD fmt (patchOp src) (env dst)+    FDIV fmt src dst     -> FDIV fmt (patchOp src) (env dst)+    SQRT fmt src dst    -> SQRT fmt (patchOp src) (env dst)++    CALL (Left _)  _    -> instr+    CALL (Right reg) p  -> CALL (Right (env reg)) p++    FETCHGOT reg        -> FETCHGOT (env reg)+    FETCHPC  reg        -> FETCHPC  (env reg)++    NOP                 -> instr+    COMMENT _           -> instr+    LOCATION {}         -> instr+    UNWIND {}           -> instr+    DELTA _             -> instr+    LDATA {}            -> instr+    NEWBLOCK {}         -> instr++    JXX _ _             -> instr+    JXX_GBL _ _         -> instr+    CLTD _              -> instr++    POPCNT fmt src dst -> POPCNT fmt (patchOp src) (env dst)+    LZCNT  fmt src dst -> LZCNT  fmt (patchOp src) (env dst)+    TZCNT  fmt src dst -> TZCNT  fmt (patchOp src) (env dst)+    PDEP   fmt src mask dst -> PDEP   fmt (patchOp src) (patchOp mask) (env dst)+    PEXT   fmt src mask dst -> PEXT   fmt (patchOp src) (patchOp mask) (env dst)+    BSF    fmt src dst -> BSF    fmt (patchOp src) (env dst)+    BSR    fmt src dst -> BSR    fmt (patchOp src) (env dst)++    PREFETCH lvl format src -> PREFETCH lvl format (patchOp src)++    LOCK i               -> LOCK (patchRegsOfInstr platform i env)+    XADD fmt src dst     -> patch2 (XADD fmt) src dst+    CMPXCHG fmt src dst  -> patch2 (CMPXCHG fmt) src dst+    XCHG fmt src dst     -> XCHG fmt (patchOp src) (env dst)+    MFENCE               -> instr++    -- vector instructions+    VBROADCAST   fmt src dst   -> VBROADCAST fmt (patchOp src) (env dst)+    VPBROADCAST  fmt1 fmt2 src dst+      -> VPBROADCAST fmt1 fmt2 (patchOp src) (env dst)+    VEXTRACT     fmt off src dst+      -> VEXTRACT fmt off (env src) (patchOp dst)+    INSERTPS    fmt off src dst+      -> INSERTPS fmt off (patchOp src) (env dst)+    VINSERTPS   fmt off src2 src1 dst+      -> VINSERTPS fmt off (patchOp src2) (env src1) (env dst)+    PINSR       fmt1 fmt2 off src dst+      -> PINSR fmt1 fmt2 off (patchOp src) (env dst)+    PEXTR       fmt1 fmt2 off src dst+      -> PEXTR fmt1 fmt2 off (env src) (patchOp dst)++    VMOVU      fmt src dst   -> VMOVU fmt (patchOp src) (patchOp dst)+    MOVU       fmt src dst   -> MOVU  fmt (patchOp src) (patchOp dst)+    MOVL       fmt src dst   -> MOVL  fmt (patchOp src) (patchOp dst)+    MOVH       fmt src dst   -> MOVH  fmt (patchOp src) (patchOp dst)+    MOVDQU     fmt src dst   -> MOVDQU  fmt (patchOp src) (patchOp dst)+    VMOVDQU    fmt src dst   -> VMOVDQU fmt (patchOp src) (patchOp dst)+    VMOV_MERGE fmt src2 src1 dst -> VMOV_MERGE fmt (env src2) (env src1) (env dst)++    PXOR       fmt src dst   -> PXOR fmt (patchOp src) (env dst)+    VPXOR      fmt s1 s2 dst -> VPXOR fmt (env s1) (env s2) (env dst)+    PAND       fmt src dst   -> PAND fmt (patchOp src) (env dst)+    PANDN      fmt src dst   -> PANDN fmt (patchOp src) (env dst)+    POR        fmt src dst   -> POR fmt (patchOp src) (env dst)++    VADD       fmt s1 s2 dst -> VADD fmt (patchOp s1) (env s2) (env dst)+    VSUB       fmt s1 s2 dst -> VSUB fmt (patchOp s1) (env s2) (env dst)+    VMUL       fmt s1 s2 dst -> VMUL fmt (patchOp s1) (env s2) (env dst)+    VDIV       fmt s1 s2 dst -> VDIV fmt (patchOp s1) (env s2) (env dst)+    PADD       fmt src dst   -> PADD fmt (patchOp src) (env dst)+    PSUB       fmt src dst   -> PSUB fmt (patchOp src) (env dst)+    PMULL      fmt src dst   -> PMULL fmt (patchOp src) (env dst)+    PMULUDQ    fmt src dst   -> PMULUDQ fmt (patchOp src) (env dst)++    PCMPGT     fmt src dst   -> PCMPGT fmt (patchOp src) (env dst)++    SHUF      fmt off src dst+      -> SHUF fmt off (patchOp src) (env dst)+    VSHUF      fmt off src1 src2 dst+      -> VSHUF fmt off (patchOp src1) (env src2) (env dst)+    PSHUFB       fmt mask dst+      -> PSHUFB fmt (patchOp mask) (env dst)+    PSHUFLW      fmt off src dst+      -> PSHUFLW fmt off (patchOp src) (env dst)+    PSHUFHW      fmt off src dst+      -> PSHUFHW fmt off (patchOp src) (env dst)+    PSHUFD       fmt off src dst+      -> PSHUFD  fmt off (patchOp src) (env dst)+    VPSHUFD      fmt off src dst+      -> VPSHUFD fmt off (patchOp src) (env dst)+    BLEND        fmt mask src dst+      -> BLEND   fmt mask (patchOp src) (env dst)+    VBLEND       fmt mask src2 src1 dst+      -> VBLEND  fmt mask (patchOp src2) (env src1) (env dst)+    PBLENDW      fmt mask src dst+      -> PBLENDW fmt mask (patchOp src) (env dst)++    PSLL         fmt off dst+      -> PSLL    fmt (patchOp off) (env dst)+    PSLLDQ       fmt off dst+      -> PSLLDQ  fmt off (env dst)+    PSRL         fmt off dst+      -> PSRL    fmt (patchOp off) (env dst)+    PSRLDQ       fmt off dst+      -> PSRLDQ  fmt off (env dst)+    PALIGNR      fmt off src dst+      -> PALIGNR fmt off (patchOp src) (env dst)++    MOVHLPS    fmt src dst+      -> MOVHLPS fmt (env src) (env dst)+    VMOVHLPS   fmt src2 src1 dst+      -> VMOVHLPS fmt (env src2) (env src1) (env dst)+    MOVLHPS    fmt src dst+      -> MOVLHPS fmt (env src) (env dst)+    VMOVLHPS   fmt src2 src1 dst+      -> VMOVLHPS fmt (env src2) (env src1) (env dst)+    UNPCKL fmt src dst+      -> UNPCKL fmt (patchOp src) (env dst)+    VUNPCKL fmt src2 src1 dst+      -> VUNPCKL fmt (patchOp src2) (env src1) (env dst)+    UNPCKH fmt src dst+      -> UNPCKH fmt (patchOp src) (env dst)+    VUNPCKH fmt src2 src1 dst+      -> VUNPCKH fmt (patchOp src2) (env src1) (env dst)+    PUNPCKLQDQ fmt src dst+      -> PUNPCKLQDQ fmt (patchOp src) (env dst)+    PUNPCKLDQ fmt src dst+      -> PUNPCKLDQ fmt (patchOp src) (env dst)+    PUNPCKLWD fmt src dst+      -> PUNPCKLWD fmt (patchOp src) (env dst)+    PUNPCKLBW fmt src dst+      -> PUNPCKLBW fmt (patchOp src) (env dst)+    PUNPCKHQDQ fmt src dst+      -> PUNPCKHQDQ fmt (patchOp src) (env dst)+    PUNPCKHDQ fmt src dst+      -> PUNPCKHDQ fmt (patchOp src) (env dst)+    PUNPCKHWD fmt src dst+      -> PUNPCKHWD fmt (patchOp src) (env dst)+    PUNPCKHBW fmt src dst+      -> PUNPCKHBW fmt (patchOp src) (env dst)+    PACKUSWB fmt src dst+      -> PACKUSWB fmt (patchOp src) (env dst)++    MINMAX minMax ty fmt src dst+      -> MINMAX minMax ty fmt (patchOp src) (env dst)+    VMINMAX minMax ty fmt src1 src2 dst+      -> VMINMAX minMax ty fmt (patchOp src1) (env src2) (env dst)++  where+    patch1 :: (Operand -> a) -> Operand -> a+    patch1 insn op      = insn $! patchOp op+    patch2 :: (Operand -> Operand -> a) -> Operand -> Operand -> a+    patch2 insn src dst = (insn $! patchOp src) $! patchOp dst+    patch3 :: (Operand -> Reg -> Reg -> a) -> Operand -> Reg -> Reg -> a+    patch3 insn src1 src2 dst = ((insn $! patchOp src1) $! env src2) $! env dst++    patchOp (OpReg  reg) = OpReg $! env reg+    patchOp (OpImm  imm) = OpImm imm+    patchOp (OpAddr ea)  = OpAddr $! lookupAddr ea++    lookupAddr (ImmAddr imm off) = ImmAddr imm off+    lookupAddr (AddrBaseIndex base index disp)+      = ((AddrBaseIndex $! lookupBase base) $! lookupIndex index) disp+      where+        lookupBase EABaseNone       = EABaseNone+        lookupBase EABaseRip        = EABaseRip+        lookupBase (EABaseReg r)    = EABaseReg $! env r++        lookupIndex EAIndexNone     = EAIndexNone+        lookupIndex (EAIndex r i)   = (EAIndex $! env r) i+++--------------------------------------------------------------------------------+isJumpishInstr+        :: Instr -> Bool++isJumpishInstr instr+ = case instr of+        JMP{}           -> True+        JXX{}           -> True+        JXX_GBL{}       -> True+        JMP_TBL{}       -> True+        CALL{}          -> True+        _               -> False++canFallthroughTo :: Instr -> BlockId -> Bool+canFallthroughTo insn bid+  = case insn of+    JXX _ target          -> bid == target+    JMP_TBL _ targets _ _ -> all isTargetBid targets+    _                     -> False+  where+    isTargetBid target = case target of+      Nothing                      -> True+      Just (DestBlockId target) -> target == bid+      _                  -> False++jumpDestsOfInstr+        :: Instr+        -> [BlockId]++jumpDestsOfInstr insn+  = case insn of+        JXX _ id        -> [id]+        JMP_TBL _ ids _ _ -> [id | Just (DestBlockId id) <- ids]+        _               -> []+++patchJumpInstr+        :: Instr -> (BlockId -> BlockId) -> Instr++patchJumpInstr insn patchF+  = case insn of+        JXX cc id       -> JXX cc (patchF id)+        JMP_TBL op ids section lbl+          -> JMP_TBL op (map (fmap (patchJumpDest patchF)) ids) section lbl+        _               -> insn+    where+        patchJumpDest f (DestBlockId id) = DestBlockId (f id)+        patchJumpDest _ dest             = dest++++++-- -----------------------------------------------------------------------------+-- | Make a spill instruction.+mkSpillInstr+    :: HasDebugCallStack+    => NCGConfig+    -> RegWithFormat -- register to spill+    -> Int       -- current stack delta+    -> Int       -- spill slot to use+    -> [Instr]++mkSpillInstr config (RegWithFormat reg fmt) delta slot =+  [ movInstr config fmt' (OpReg reg) (OpAddr (spRel platform off)) ]+  where+    fmt'+      | isVecFormat fmt+      = fmt+      | otherwise+      = scalarMoveFormat platform fmt+      -- Spill the platform word size, at a minimum+    platform = ncgPlatform config+    off = spillSlotToOffset platform slot - delta++-- | Make a spill reload instruction.+mkLoadInstr+    :: HasDebugCallStack+    => NCGConfig+    -> RegWithFormat      -- register to load+    -> Int      -- current stack delta+    -> Int      -- spill slot to use+    -> [Instr]++mkLoadInstr config (RegWithFormat reg fmt) delta slot =+  [ movInstr config fmt' (OpAddr (spRel platform off)) (OpReg reg) ]+  where+    fmt'+      | isVecFormat fmt+      = fmt+      | otherwise+      = scalarMoveFormat platform fmt+        -- Load the platform word size, at a minimum+    platform = ncgPlatform config+    off = spillSlotToOffset platform slot - delta++-- | A move instruction for moving the entire contents of an operand+-- at the given 'Format'.+movInstr :: HasDebugCallStack => NCGConfig -> Format -> (Operand -> Operand -> Instr)+movInstr config fmt =+  case fmt of+    VecFormat _ sFmt ->+      case formatToWidth fmt of+        W512 ->+          if avx512f+          then avx_move sFmt+          else sorry "512-bit wide vectors require -mavx512f"+        W256 ->+          if avx2+          then avx_move sFmt+          else sorry "256-bit wide vectors require -mavx2"+        W128 ->+          if avx+            -- Prefer AVX instructions over SSE when available+            -- (usually results in better performance).+          then avx_move sFmt+          else sse_move sFmt+        w -> sorry $ "Unhandled SIMD vector width: " ++ show w ++ " bits"+    _ -> MOV fmt+  where++    assertCompatibleRegs :: ( Operand -> Operand -> Instr ) -> Operand -> Operand -> Instr+    assertCompatibleRegs f+      | debugIsOn+      = \ op1 op2 ->+          if | OpReg r1 <- op1+             , OpReg r2 <- op2+             , targetClassOfReg plat r1 /= targetClassOfReg plat r2+             -> assertPpr False+                  ( vcat [ text "movInstr: move between incompatible registers"+                         , text "fmt:" <+> ppr fmt+                         , text "r1:" <+> ppr r1+                         , text "r2:" <+> ppr r2 ]+                  ) f op1 op2+             | otherwise+             -> f op1 op2+      | otherwise+      = f++    plat    = ncgPlatform config+    avx     = ncgAvxEnabled config+    avx2    = ncgAvx2Enabled config+    avx512f = ncgAvx512fEnabled config+    avx_move sFmt =+      if isFloatScalarFormat sFmt+      then assertCompatibleRegs $+           VMOVU   fmt+      else VMOVDQU fmt+    sse_move sFmt =+      if isFloatScalarFormat sFmt+      then assertCompatibleRegs $+           MOVU   fmt+      else MOVDQU fmt+    -- NB: we are using {V}MOVU and not {V}MOVA, because we have no guarantees+    -- about the stack being sufficiently aligned (even for even numbered stack slots).+    --+    -- (Ben Gamari told me that using MOVA instead of MOVU does not make a+    -- difference in practice when moving between registers.)++spillSlotSize :: Platform -> Int+spillSlotSize platform+   | target32Bit platform = 12+   | otherwise            = 8++maxSpillSlots :: NCGConfig -> Int+maxSpillSlots config+    = ((ncgSpillPreallocSize config - 64) `div` spillSlotSize (ncgPlatform config)) - 1+--  = 0 -- useful for testing allocMoreStack++-- number of bytes that the stack pointer should be aligned to+stackAlign :: Int+stackAlign = 16++-- convert a spill slot number to a *byte* offset, with no sign:+-- decide on a per arch basis whether you are spilling above or below+-- the C stack pointer.+spillSlotToOffset :: Platform -> Int -> Int+spillSlotToOffset platform slot+   = 64 + spillSlotSize platform * slot++--------------------------------------------------------------------------------++-- | See if this instruction is telling us the current C stack delta+takeDeltaInstr+        :: Instr+        -> Maybe Int++takeDeltaInstr instr+ = case instr of+        DELTA i         -> Just i+        _               -> Nothing+++isMetaInstr+        :: Instr+        -> Bool++isMetaInstr instr+ = case instr of+        COMMENT{}       -> True+        LOCATION{}      -> True+        LDATA{}         -> True+        NEWBLOCK{}      -> True+        UNWIND{}        -> True+        DELTA{}         -> True+        _               -> False++-- | Make a reg-reg move instruction.+mkRegRegMoveInstr+    :: HasDebugCallStack+    => NCGConfig+    -> Format+    -> Reg+    -> Reg+    -> Instr+mkRegRegMoveInstr config fmt src dst =+  movInstr config fmt' (OpReg src) (OpReg dst)+    -- Move the platform word size, at a minimum.+    --+    -- This ensures the upper part of the register is properly cleared+    -- and avoids partial register stalls.+    --+    -- See also the 'ArithInt8' and 'ArithWord8' tests,+    -- which fail without this logic.+  where+    platform = ncgPlatform config+    fmt'+      | isVecFormat fmt+      = fmt+      | otherwise+      = scalarMoveFormat platform fmt++scalarMoveFormat :: Platform -> Format -> Format+scalarMoveFormat platform fmt+  | isFloatFormat fmt+  = FF64+  | II64 <- fmt+  = II64+  | otherwise+  = archWordFormat (target32Bit platform)++-- | Check whether an instruction represents a reg-reg move.+--      The register allocator attempts to eliminate reg->reg moves whenever it can,+--      by assigning the src and dest temporaries to the same real register.+--+takeRegRegMoveInstr+        :: Platform+        -> Instr+        -> Maybe (Reg,Reg)++takeRegRegMoveInstr platform = \case+  MOV fmt (OpReg r1) (OpReg r2)+    -- When used with vector registers, MOV only moves the lower part,+    -- so it is not a real move. For example, MOVSS/MOVSD between xmm registers+    -- preserves the upper half, and MOVQ between xmm registers zeroes the upper half.+    | not $ isVecFormat fmt+    -- Don't eliminate a move between e.g. RAX and XMM:+    -- even though we might be using XMM to store a scalar integer value,+    -- some instructions only support XMM registers.+    , targetClassOfReg platform r1 == targetClassOfReg platform r2+    -> Just (r1, r2)+  MOVD {}+    -- MOVD moves between xmm registers and general-purpose registers,+    -- and we don't want to eliminate those moves (as noted for MOV).+    -> Nothing++  -- SSE2/AVX move instructions always move the full register.+  MOVU _ (OpReg r1) (OpReg r2)+    -> Just (r1, r2)+  VMOVU _ (OpReg r1) (OpReg r2)+    -> Just (r1, r2)+  MOVDQU _ (OpReg r1) (OpReg r2)+    -> Just (r1, r2)+  VMOVDQU _ (OpReg r1) (OpReg r2)+    -> Just (r1, r2)++  -- TODO: perhaps we can eliminate MOVZxL in certain situations?+  MOVZxL {} -> Nothing+  MOVSxL {} -> Nothing++  -- MOVL, MOVH and MOVHLPS preserve some part of the destination register,+  -- so are not simple moves.+  MOVL {} -> Nothing+  MOVH {} -> Nothing+  MOVHLPS {} -> Nothing++  -- Other instructions are not moves.+  _ -> Nothing++-- | Make an unconditional branch instruction.+mkJumpInstr+        :: BlockId+        -> [Instr]++mkJumpInstr id+        = [JXX ALWAYS id]++-- Note [Windows stack layout]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~++-- | On most OSes the kernel will place a guard page after the current stack+--   page.  If you allocate larger than a page worth you may jump over this+--   guard page.  Not only is this a security issue, but on certain OSes such+--   as Windows a new page won't be allocated if you don't hit the guard.  This+--   will cause a segfault or access fault.+--+--   This function defines if the current allocation amount requires a probe.+--   On Windows (for now) we emit a call to _chkstk for this.  For other OSes+--   this is not yet implemented.+--   See https://docs.microsoft.com/en-us/windows/desktop/DevNotes/-win32-chkstk+--   The Windows stack looks like this:+--+--                         +-------------------++--                         |        SP         |+--                         +-------------------++--                         |                   |+--                         |    GUARD PAGE     |+--                         |                   |+--                         +-------------------++--                         |                   |+--                         |                   |+--                         |     UNMAPPED      |+--                         |                   |+--                         |                   |+--                         +-------------------++--+--   In essence each allocation larger than a page size needs to be chunked and+--   a probe emitted after each page allocation.  You have to hit the guard+--   page so the kernel can map in the next page, otherwise you'll segfault.+--   See Note [Windows stack allocations].+--+needs_probe_call :: Platform -> Int -> Bool+needs_probe_call platform amount+  = case platformOS platform of+     OSMinGW32 -> case platformArch platform of+                    ArchX86_64 -> amount > (4 * 1024)+                    _          -> False+     _         -> False++mkStackAllocInstr+        :: Platform+        -> Int+        -> [Instr]+mkStackAllocInstr platform amount+  = case platformOS platform of+      OSMinGW32 ->+        -- These will clobber AX but this should be ok because+        --+        -- 1. It is the first thing we do when entering the closure and AX is+        --    a caller saved registers on Windows both on x86_64 and x86.+        --+        -- 2. The closures are only entered via a call or longjmp in which case+        --    there are no expectations for volatile registers.+        --+        -- 3. When the target is a local branch point it is re-targeted+        --    after the dealloc, preserving #2.  See Note [extra spill slots].+        --+        -- We emit a call because the stack probes are quite involved and+        -- would bloat code size a lot.  GHC doesn't really have an -Os.+        -- ___chkstk is guaranteed to leave all nonvolatile registers and AX+        -- untouched.  It's part of the standard prologue code for any Windows+        -- function dropping the stack more than a page.+        -- See Note [Windows stack layout]+        case platformArch platform of+            ArchX86_64 | needs_probe_call platform amount ->+                           [ MOV II64 (OpImm (ImmInt amount)) (OpReg rax)+                           , CALL (Left $ strImmLit (fsLit "___chkstk_ms")) [RegWithFormat rax II64]+                           , SUB II64 (OpReg rax) (OpReg rsp)+                           ]+                       | otherwise ->+                           [ SUB II64 (OpImm (ImmInt amount)) (OpReg rsp)+                           , TEST II64 (OpReg rsp) (OpReg rsp)+                           ]+            _ -> panic "X86.mkStackAllocInstr"+      _       ->+        case platformArch platform of+          ArchX86    -> [ SUB II32 (OpImm (ImmInt amount)) (OpReg esp) ]+          ArchX86_64 -> [ SUB II64 (OpImm (ImmInt amount)) (OpReg rsp) ]+          _ -> panic "X86.mkStackAllocInstr"++mkStackDeallocInstr+        :: Platform+        -> Int+        -> [Instr]+mkStackDeallocInstr platform amount+  = case platformArch platform of+      ArchX86    -> [ADD II32 (OpImm (ImmInt amount)) (OpReg esp)]+      ArchX86_64 -> [ADD II64 (OpImm (ImmInt amount)) (OpReg rsp)]+      _ -> panic "X86.mkStackDeallocInstr"+++-- Note [extra spill slots]+-- ~~~~~~~~~~~~~~~~~~~~~~~~+-- If the register allocator used more spill slots than we have+-- pre-allocated (rESERVED_C_STACK_BYTES), then we must allocate more+-- C stack space on entry and exit from this proc.  Therefore we+-- insert a "sub $N, %rsp" at every entry point, and an "add $N, %rsp"+-- before every non-local jump.+--+-- This became necessary when the new codegen started bundling entire+-- functions together into one proc, because the register allocator+-- assigns a different stack slot to each virtual reg within a proc.+-- To avoid using so many slots we could also:+--+--   - split up the proc into connected components before code generator+--+--   - rename the virtual regs, so that we re-use vreg names and hence+--     stack slots for non-overlapping vregs.+--+-- Note that when a block is both a non-local entry point (with an+-- info table) and a local branch target, we have to split it into+-- two, like so:+--+--    <info table>+--    L:+--       <code>+--+-- becomes+--+--    <info table>+--    L:+--       subl $rsp, N+--       jmp Lnew+--    Lnew:+--       <code>+--+-- and all branches pointing to L are retargetted to point to Lnew.+-- Otherwise, we would repeat the $rsp adjustment for each branch to+-- L.+--+-- Returns a list of (L,Lnew) pairs.+--+allocMoreStack+  :: Platform+  -> Int+  -> NatCmmDecl statics GHC.CmmToAsm.X86.Instr.Instr+  -> UniqDSM (NatCmmDecl statics GHC.CmmToAsm.X86.Instr.Instr, [(BlockId,BlockId)])++allocMoreStack _ _ top@(CmmData _ _) = return (top,[])+allocMoreStack platform slots proc@(CmmProc info lbl live (ListGraph code)) = do+    let entries = entryBlocks proc++    retargetList <- mapM (\e -> (e,) <$> newBlockId) entries++    let+      delta = ((x + stackAlign - 1) `quot` stackAlign) * stackAlign -- round up+        where x = slots * spillSlotSize platform -- sp delta++      alloc   = mkStackAllocInstr   platform delta+      dealloc = mkStackDeallocInstr platform delta++      new_blockmap :: LabelMap BlockId+      new_blockmap = mapFromList retargetList++      insert_stack_insns (BasicBlock id insns)+         | Just new_blockid <- mapLookup id new_blockmap+         = [ BasicBlock id $ alloc ++ [JXX ALWAYS new_blockid]+           , BasicBlock new_blockid block' ]+         | otherwise+         = [ BasicBlock id block' ]+         where+           block' = foldr insert_dealloc [] insns++      insert_dealloc insn r = case insn of+         JMP _ _     -> dealloc ++ (insn : r)+         JXX_GBL _ _ -> panic "insert_dealloc: cannot handle JXX_GBL"+         _other      -> patchJumpInstr insn retarget : r+           where retarget b = fromMaybe b (mapLookup b new_blockmap)++      new_code = concatMap insert_stack_insns code+    -- in+    return (CmmProc info lbl live (ListGraph new_code), retargetList)++data JumpDest = DestBlockId BlockId | DestImm Imm++-- Debug Instance+instance Outputable JumpDest where+  ppr (DestBlockId bid) = text "jd<blk>:" <> ppr bid+  ppr (DestImm _imm)    = text "jd<imm>:noShow"++-- Implementations of the methods of 'NgcImpl'++getJumpDestBlockId :: JumpDest -> Maybe BlockId+getJumpDestBlockId (DestBlockId bid) = Just bid+getJumpDestBlockId _                 = Nothing++canShortcut :: Instr -> Maybe JumpDest+canShortcut (JXX ALWAYS id)      = Just (DestBlockId id)+canShortcut (JMP (OpImm imm) _)  = Just (DestImm imm)+canShortcut _                    = Nothing++-- This helper shortcuts a sequence of branches.+-- The blockset helps avoid following cycles.+shortcutJump :: (BlockId -> Maybe JumpDest) -> Instr -> Instr+shortcutJump fn insn = shortcutJump' fn (setEmpty :: LabelSet) insn+  where+    shortcutJump' :: (BlockId -> Maybe JumpDest) -> LabelSet -> Instr -> Instr+    shortcutJump' fn seen insn@(JXX cc id) =+        if setMember id seen then insn+        else case fn id of+            Nothing                -> insn+            Just (DestBlockId id') -> shortcutJump' fn seen' (JXX cc id')+            Just (DestImm imm)     -> shortcutJump' fn seen' (JXX_GBL cc imm)+        where seen' = setInsert id seen+    shortcutJump' fn _ (JMP_TBL addr blocks section tblId) =+        let updateBlock (Just (DestBlockId bid))  =+                case fn bid of+                    Nothing   -> Just (DestBlockId bid )+                    Just dest -> Just dest+            updateBlock dest = dest+            blocks' = map updateBlock blocks+        in  JMP_TBL addr blocks' section tblId+    shortcutJump' _ _ other = other++-- Here because it knows about JumpDest+shortcutStatics :: (BlockId -> Maybe JumpDest) -> (Alignment, RawCmmStatics) -> (Alignment, RawCmmStatics)+shortcutStatics fn (align, CmmStaticsRaw lbl statics)+  = (align, CmmStaticsRaw lbl $ map (shortcutStatic fn) statics)+  -- we need to get the jump tables, so apply the mapping to the entries+  -- of a CmmData too.++shortcutLabel :: (BlockId -> Maybe JumpDest) -> CLabel -> CLabel+shortcutLabel fn lab+  | Just blkId <- maybeLocalBlockLabel lab = shortBlockId fn emptyUniqueSet blkId+  | otherwise                              = lab++shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic+shortcutStatic fn (CmmStaticLit (CmmLabel lab))+  = CmmStaticLit (CmmLabel (shortcutLabel fn lab))+shortcutStatic fn (CmmStaticLit (CmmLabelDiffOff lbl1 lbl2 off w))+  = CmmStaticLit (CmmLabelDiffOff (shortcutLabel fn lbl1) lbl2 off w)+        -- slightly dodgy, we're ignoring the second label, but this+        -- works with the way we use CmmLabelDiffOff for jump tables now.+shortcutStatic _ other_static+        = other_static++shortBlockId+        :: (BlockId -> Maybe JumpDest)+        -> UniqueSet+        -> BlockId+        -> CLabel++shortBlockId fn seen blockid =+  case (memberUniqueSet uq seen, fn blockid) of+    (True, _)    -> blockLbl blockid+    (_, Nothing) -> blockLbl blockid+    (_, Just (DestBlockId blockid'))  -> shortBlockId fn (insertUniqueSet uq seen) blockid'     (_, Just (DestImm (ImmCLbl lbl))) -> lbl     (_, _other) -> panic "shortBlockId"   where uq = getUnique blockid
GHC/CmmToAsm/X86/Ppr.hs view
@@ -1,5 +1,6 @@  {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}  ----------------------------------------------------------------------------- --@@ -11,11 +12,7 @@  module GHC.CmmToAsm.X86.Ppr (         pprNatCmmDecl,-        pprData,         pprInstr,-        pprFormat,-        pprImm,-        pprDataItem, )  where@@ -35,10 +32,10 @@ import GHC.CmmToAsm.Ppr  import GHC.Cmm              hiding (topInfoTable)-import GHC.Cmm.Dataflow.Collections 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 )@@ -46,6 +43,7 @@ import GHC.Utils.Outputable import GHC.Utils.Panic +import Data.List ( intersperse ) import Data.Word  -- Note [Subsections Via Symbols]@@ -65,88 +63,115 @@ -- .subsections_via_symbols and -dead_strip can be found at -- <https://developer.apple.com/library/mac/documentation/DeveloperTools/Reference/Assembler/040-Assembler_Directives/asm_directives.html#//apple_ref/doc/uid/TP30000823-TPXREF101> -pprProcAlignment :: NCGConfig -> SDoc+pprProcAlignment :: IsDoc doc => NCGConfig -> doc pprProcAlignment config = maybe empty (pprAlign platform . mkAlignment) (ncgProcAlignment config)    where       platform = ncgPlatform config -pprNatCmmDecl :: NCGConfig -> NatCmmDecl (Alignment, RawCmmStatics) Instr -> SDoc+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 lbl _ (ListGraph blocks)) =-  let platform = ncgPlatform config in-  pprProcAlignment config $$-  case topInfoTable proc of-    Nothing ->-        -- special case for code without info table:-        pprSectionAlign config (Section Text lbl) $$-        pprProcAlignment config $$-        pprProcLabel config lbl $$-        pprLabel platform lbl $$ -- blocks guaranteed not null, so label needed-        vcat (map (pprBasicBlock config top_info) blocks) $$-        ppWhen (ncgDwarfEnabled config) (pprBlockEndLabel platform lbl $$ pprProcEndLabel platform lbl) $$-        pprSizeDecl platform lbl+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 -    Just (CmmStaticsRaw info_lbl _) ->-      pprSectionAlign config (Section Text info_lbl) $$-      pprProcAlignment config $$-      pprProcLabel config lbl $$-      (if platformHasSubsectionsViaSymbols platform-          then pdoc platform (mkDeadStripPreventer info_lbl) <> colon-          else empty) $$-      vcat (map (pprBasicBlock config top_info) blocks) $$-      ppWhen (ncgDwarfEnabled config) (pprProcEndLabel platform info_lbl) $$-      -- above: Even the first block gets a label, because with branch-chain+      -- 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.-      (if platformHasSubsectionsViaSymbols platform-       then -- See Note [Subsections Via Symbols]-                text "\t.long "-            <+> pdoc platform info_lbl-            <+> char '-'-            <+> pdoc platform (mkDeadStripPreventer info_lbl)-       else empty) $$-      pprSizeDecl platform info_lbl +      -- 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.-pprProcLabel :: NCGConfig -> CLabel -> SDoc-pprProcLabel config lbl+pprExposedInternalProcLabel :: IsDoc doc => NCGConfig -> CLabel -> doc+pprExposedInternalProcLabel config lbl   | ncgExposeInternalSymbols config   , Just lbl' <- ppInternalProcLabel (ncgThisModule config) lbl-  = lbl' <> colon+  = line (lbl' <> colon)   | otherwise   = empty -pprProcEndLabel :: Platform -> CLabel -- ^ Procedure name-                -> SDoc-pprProcEndLabel platform lbl =-    pdoc platform (mkAsmTempProcEndLabel lbl) <> colon+pprProcEndLabel :: IsLine doc => Platform -> CLabel -- ^ Procedure name+                -> doc+pprProcEndLabel platform lbl = pprAsmLabel platform (mkAsmTempProcEndLabel lbl) <> colon -pprBlockEndLabel :: Platform -> CLabel -- ^ Block name-                 -> SDoc+pprBlockEndLabel :: IsLine doc => Platform -> CLabel -- ^ Block name+                 -> doc pprBlockEndLabel platform lbl =-    pdoc platform (mkAsmTempEndLabel lbl) <> colon+    pprAsmLabel platform (mkAsmTempEndLabel lbl) <> colon  -- | Output the ELF .size directive.-pprSizeDecl :: Platform -> CLabel -> SDoc+pprSizeDecl :: IsDoc doc => Platform -> CLabel -> doc pprSizeDecl platform lbl  = if osElfTarget (platformOS platform)-   then text "\t.size" <+> pdoc platform lbl <> text ", .-" <> pdoc platform lbl+   then line (text "\t.size" <+> pprAsmLabel platform lbl <> text ", .-" <> pprAsmLabel platform lbl)    else empty -pprBasicBlock :: NCGConfig -> LabelMap RawCmmStatics -> NatBasicBlock Instr -> SDoc+pprBasicBlock :: IsDoc doc => NCGConfig -> LabelMap RawCmmStatics -> NatBasicBlock Instr -> doc pprBasicBlock config info_env (BasicBlock blockid instrs)   = maybe_infotable $-    pprLabel platform asmLbl $$+    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-      pprBlockEndLabel platform asmLbl-      <> pprProcEndLabel platform asmLbl+      line (pprBlockEndLabel platform block_label) $$+      line (pprProcEndLabel platform block_label)     )   where-    asmLbl = blockLbl blockid+    block_label = blockLbl blockid     platform = ncgPlatform config     maybe_infotable c = case mapLookup blockid info_env of        Nothing -> c@@ -156,7 +181,7 @@            vcat (map (pprData config) info) $$            pprLabel platform infoLbl $$            c $$-           ppWhen (ncgDwarfEnabled config) (pdoc platform (mkAsmTempEndLabel infoLbl) <> colon)+           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]@@ -165,7 +190,7 @@       _other             -> empty  -pprDatas :: NCGConfig -> (Alignment, RawCmmStatics) -> SDoc+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@@ -175,31 +200,32 @@   , Just ind' <- labelInd ind   , alias `mayRedirectTo` ind'   = pprGloblDecl (ncgPlatform config) alias-    $$ text ".equiv" <+> pdoc (ncgPlatform config) alias <> comma <> pdoc (ncgPlatform config) (CmmLabel ind')+    $$ 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 :: NCGConfig -> CmmStatic -> SDoc-pprData _config (CmmString str) = pprString str-pprData _config (CmmFileEmbed path) = pprFileEmbed path+pprData :: IsDoc doc => NCGConfig -> CmmStatic -> doc+pprData _config (CmmString str) = line (pprString str)+pprData _config (CmmFileEmbed path _) = line (pprFileEmbed path)  pprData config (CmmUninitialised bytes)- = let platform = ncgPlatform config+ = 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 :: Platform -> CLabel -> SDoc+pprGloblDecl :: IsDoc doc => Platform -> CLabel -> doc pprGloblDecl platform lbl   | not (externallyVisibleCLabel lbl) = empty-  | otherwise = text ".globl " <> pdoc platform lbl+  | otherwise = line (text ".globl " <> pprAsmLabel platform lbl) -pprLabelType' :: Platform -> CLabel -> SDoc+pprLabelType' :: IsLine doc => Platform -> CLabel -> doc pprLabelType' platform lbl =   if isCFunctionLabel lbl || functionOkInfoTable then     text "@function"@@ -254,24 +280,24 @@     but mess up with the relocation. https://phabricator.haskell.org/D4730     -}     functionOkInfoTable = platformTablesNextToCode platform &&-      isInfoTableLabel lbl && not (isConInfoTableLabel lbl)+      isInfoTableLabel lbl && not (isCmmInfoTableLabel lbl) && not (isConInfoTableLabel lbl)  -pprTypeDecl :: Platform -> CLabel -> SDoc+pprTypeDecl :: IsDoc doc => Platform -> CLabel -> doc pprTypeDecl platform lbl     = if osElfTarget (platformOS platform) && externallyVisibleCLabel lbl-      then text ".type " <> pdoc platform lbl <> text ", " <> pprLabelType' platform lbl+      then line (text ".type " <> pprAsmLabel platform lbl <> text ", " <> pprLabelType' platform lbl)       else empty -pprLabel :: Platform -> CLabel -> SDoc+pprLabel :: IsDoc doc => Platform -> CLabel -> doc pprLabel platform lbl =    pprGloblDecl platform lbl    $$ pprTypeDecl platform lbl-   $$ (pdoc platform lbl <> colon)+   $$ line (pprAsmLabel platform lbl <> colon) -pprAlign :: Platform -> Alignment -> SDoc+pprAlign :: IsDoc doc => Platform -> Alignment -> doc pprAlign platform alignment-        = text ".align " <> int (alignmentOn platform)+        = line $ text ".align " <> int (alignmentOn platform)   where         bytes = alignmentBytes alignment         alignmentOn platform = if platformOS platform == OSDarwin@@ -285,22 +311,22 @@         log2 8 = 3         log2 n = 1 + log2 (n `quot` 2) -pprReg :: Platform -> Format -> Reg -> SDoc+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 (VirtualRegF  u)  -> text "%vF_"   <> pprUniqueAlways u-      RegVirtual (VirtualRegD  u)  -> text "%vD_"   <> pprUniqueAlways u+      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 -> SDoc+    ppr32_reg_no :: Format -> Int -> doc     ppr32_reg_no II8   = ppr32_reg_byte     ppr32_reg_no II16  = ppr32_reg_word-    ppr32_reg_no _     = ppr32_reg_long+    ppr32_reg_no fmt   = ppr32_reg_long fmt      ppr32_reg_byte i =       case i of {@@ -318,20 +344,20 @@         _  -> text "very naughty I386 word register"       } -    ppr32_reg_long i =+    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 i+         _  -> ppr_reg_float fmt i       } -    ppr64_reg_no :: Format -> Int -> SDoc+    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 _     = ppr64_reg_quad+    ppr64_reg_no fmt   = ppr64_reg_quad fmt      ppr64_reg_byte i =       case i of {@@ -372,7 +398,7 @@         _  -> text "very naughty x86_64 register"       } -    ppr64_reg_quad i =+    ppr64_reg_quad fmt i =       case i of {          0 -> text "%rax";     1 -> text "%rbx";          2 -> text "%rcx";     3 -> text "%rdx";@@ -382,11 +408,35 @@         10 -> text "%r10";    11 -> text "%r11";         12 -> text "%r12";    13 -> text "%r13";         14 -> text "%r14";    15 -> text "%r15";-        _  -> ppr_reg_float i+        _  -> ppr_reg_float fmt i       } -ppr_reg_float :: Int -> SDoc-ppr_reg_float i = case i of+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"@@ -396,8 +446,9 @@         28 -> text "%xmm12";   29 -> text "%xmm13"         30 -> text "%xmm14";   31 -> text "%xmm15"         _  -> text "very naughty x86 register"+  where size = formatToWidth fmt -pprFormat :: Format -> SDoc+pprFormat :: IsLine doc => Format -> doc pprFormat x = case x of   II8   -> text "b"   II16  -> text "w"@@ -405,15 +456,22 @@   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 :: Format -> SDoc+pprFormat_x87 :: IsLine doc => Format -> doc pprFormat_x87 x = case x of   FF32  -> text "s"   FF64  -> text "l"   _     -> panic "X86.Ppr.pprFormat_x87"  -pprCond :: Cond -> SDoc+pprCond :: IsLine doc => Cond -> doc pprCond c = case c of {   GEU     -> text "ae";   LU   -> text "b";   EQQ     -> text "e";    GTT  -> text "g";@@ -426,13 +484,13 @@   ALWAYS  -> text "mp"}  -pprImm :: Platform -> Imm -> SDoc+pprImm :: IsLine doc => Platform -> Imm -> doc pprImm platform = \case    ImmInt i            -> int i    ImmInteger i        -> integer i-   ImmCLbl l           -> pdoc platform l-   ImmIndex l i        -> pdoc platform l <> char '+' <> int i-   ImmLit s            -> s+   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@@ -440,7 +498,7 @@   -pprAddr :: Platform -> AddrMode -> SDoc+pprAddr :: IsLine doc => Platform -> AddrMode -> doc pprAddr platform (ImmAddr imm off)   = let pp_imm = pprImm platform imm     in@@ -471,28 +529,26 @@     ppr_disp imm        = pprImm platform imm  -- | Print section header and appropriate alignment for that section.-pprSectionAlign :: NCGConfig -> Section -> SDoc+pprSectionAlign :: IsDoc doc => NCGConfig -> Section -> doc pprSectionAlign _config (Section (OtherSection _) _) =      panic "X86.Ppr.pprSectionAlign: unknown section" pprSectionAlign config sec@(Section seg _) =-    pprSectionHeader config sec $$+    line (pprSectionHeader config sec) $$     pprAlignForSection (ncgPlatform config) seg  -- | Print appropriate alignment for the given section type.-pprAlignForSection :: Platform -> SectionType -> SDoc-pprAlignForSection platform seg =+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-           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.@@ -500,87 +556,67 @@        | 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 :: NCGConfig -> CmmLit -> SDoc-pprDataItem config lit-  = vcat (ppr_item (cmmTypeFormat $ cmmLitType platform lit) lit)+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-        imm = litToImm lit -        -- These seem to be common:-        ppr_item II8   _ = [text "\t.byte\t" <> pprImm platform imm]-        ppr_item II16  _ = [text "\t.word\t" <> pprImm platform imm]-        ppr_item II32  _ = [text "\t.long\t" <> pprImm platform imm]--        ppr_item FF32 _ = [text "\t.float\t" <> pprImm platform imm]-        ppr_item FF64 _ = [text "\t.double\t" <> pprImm platform imm]+        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) -        ppr_item II64 _-            = case platformOS platform of+        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 ->-                  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 platform imm]-              _-               | target32Bit platform ->-                  [text "\t.quad\t" <> pprImm platform 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 rts/include/rts/storage/InfoTables.h-                  ---                  case lit of-                  -- A relative relocation:-                  CmmLabelDiffOff _ _ _ _ ->-                      [text "\t.long\t" <> pprImm platform imm,-                       text "\t.long\t0"]-                  _ ->-                      [text "\t.quad\t" <> pprImm platform imm]-+                | 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 :: SDoc -> SDoc+asmComment :: IsLine doc => doc -> doc asmComment c = whenPprDebug $ text "# " <> c -pprInstr :: Platform -> Instr -> SDoc+pprInstr :: forall doc. IsDoc doc => Platform -> Instr -> doc pprInstr platform i = case i of    COMMENT s-      -> asmComment s+      -> line (asmComment (ftext s)) -   LOCATION file line col _name-      -> text "\t.loc " <> ppr file <+> ppr line <+> ppr col+   LOCATION file line' col _name+      -> line (text "\t.loc " <> int file <+> int line' <+> int col)     DELTA d-      -> asmComment $ text ("\tdelta = " ++ show d)+      -> line (asmComment $ text ("\tdelta = " ++ show d))     NEWBLOCK _       -> panic "pprInstr: NEWBLOCK"     UNWIND lbl d-      -> asmComment (text "\tunwind = " <> pdoc platform d)-         $$ pdoc platform lbl <> colon+      -> line (asmComment (text "\tunwind = " <> pprUnwindTable platform d))+         $$ line (pprAsmLabel platform lbl <> colon)     LDATA _ _       -> panic "pprInstr: LDATA"@@ -611,12 +647,19 @@                 II64 -> II32          -- 32-bit version is equivalent, and smaller                 _    -> format -   MOV format src dst-     -> pprFormatOpOp (text "mov") format src dst+   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@@ -703,14 +746,20 @@    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)+      -> pprOpOp (text "lzcnt") format src (OpReg dst)     TZCNT format src dst       -> pprOpOp (text "tzcnt") format src (OpReg dst)@@ -757,6 +806,12 @@    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 @@ -798,19 +853,19 @@ -- POPA  -> text "\tpopal"     NOP-      -> text "\tnop"+      -> line $ text "\tnop"     CLTD II8-      -> text "\tcbtw"+      -> line $ text "\tcbtw"     CLTD II16-      -> text "\tcwtd"+      -> line $ text "\tcwtd"     CLTD II32-      -> text "\tcltd"+      -> line $ text "\tcltd"     CLTD II64-      -> text "\tcqto"+      -> line $ text "\tcqto"     CLTD x       -> panic $ "pprInstr: CLTD " ++ show x@@ -822,26 +877,26 @@       -> pprFormatOpReg (text "xchg") format src val     JXX cond blockid-      -> pprCondInstr (text "j") cond (pdoc platform lab)+      -> 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) _-      -> text "\tjmp " <> pprImm platform imm+      -> line $ text "\tjmp " <> pprImm platform imm     JMP op _-      -> text "\tjmp *" <> pprOperand platform (archWordFormat (target32Bit platform)) op+      -> line $ text "\tjmp *" <> pprOperand platform (archWordFormat (target32Bit platform)) op     JMP_TBL op _ _ _       -> pprInstr platform (JMP op [])     CALL (Left imm) _-      -> text "\tcall " <> pprImm platform imm+      -> line $ text "\tcall " <> pprImm platform imm     CALL (Right reg) _-      -> text "\tcall *" <> pprReg platform (archWordFormat (target32Bit platform)) reg+      -> line $ text "\tcall *" <> pprReg platform (archWordFormat (target32Bit platform)) reg     IDIV fmt op       -> pprFormatOp (text "idiv") fmt op@@ -860,8 +915,16 @@       -> pprFormatOp (text "mul") format op     FDIV format op1 op2-      -> pprFormatOpOp (text "div") 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 @@ -885,20 +948,20 @@         -- FETCHGOT for PIC on ELF platforms    FETCHGOT reg-      -> vcat [ text "\tcall 1f",-                hcat [ text "1:\tpopl\t", pprReg platform II32 reg ],-                hcat [ text "\taddl\t$_GLOBAL_OFFSET_TABLE_+(.-1b), ",-                       pprReg platform II32 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-      -> vcat [ text "\tcall 1f",-                hcat [ text "1:\tpopl\t", pprReg platform II32 reg ]-              ]+      -> lines_ [ text "\tcall 1f",+                  hcat [ text "1:\tpopl\t", pprReg platform II32 reg ]+                ]     -- the    -- GST fmt src addr ==> FLD dst ; FSTPsz addr@@ -907,10 +970,10 @@     -- Atomics    LOCK i-      -> text "\tlock" $$ pprInstr platform i+      -> line (text "\tlock") $$ pprInstr platform i     MFENCE-      -> text "\tmfence"+      -> line $ text "\tmfence"     XADD format src dst       -> pprFormatOpOp (text "xadd") format src dst@@ -918,48 +981,211 @@    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 :: SDoc+   gtab :: Line doc    gtab  = char '\t' -   gsp :: SDoc+   gsp :: Line doc    gsp   = char ' '   -   pprX87 :: Instr -> SDoc -> SDoc+   pprX87 :: Instr -> Line doc -> doc    pprX87 fake actual-      = (char '#' <> pprX87Instr fake) $$ actual+      = line (char '#' <> pprX87Instr fake) $$ line actual -   pprX87Instr :: Instr -> SDoc+   pprX87Instr :: Instr -> Line doc    pprX87Instr (X87Store fmt dst) = pprFormatAddr (text "gst") fmt dst    pprX87Instr _ = panic "X86.Ppr.pprX87Instr: no match" -   pprDollImm :: Imm -> SDoc+   pprDollImm :: Imm -> Line doc    pprDollImm i = text "$" <> pprImm platform i  -   pprOperand :: Platform -> Format -> Operand -> SDoc+   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_  :: SDoc -> SDoc+   pprMnemonic_  :: Line doc -> Line doc    pprMnemonic_ name =       char '\t' <> name <> space  -   pprMnemonic  :: SDoc -> Format -> SDoc+   pprMnemonic  :: Line doc -> Format -> Line doc    pprMnemonic name format =       char '\t' <> name <> pprFormat format <> space  -   pprFormatImmOp :: SDoc -> Format -> Imm -> Operand -> SDoc+   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-     = hcat [+     = line $ hcat [            pprMnemonic name format,            char '$',            pprImm platform imm,@@ -967,63 +1193,125 @@            pprOperand platform format op1        ] --   pprFormatOp_ :: SDoc -> Format -> Operand -> SDoc+   pprFormatOp_ :: Line doc -> Format -> Operand -> doc    pprFormatOp_ name format op1-     = hcat [+     = line $ hcat [            pprMnemonic_ name ,            pprOperand platform format op1        ] -   pprFormatOp :: SDoc -> Format -> Operand -> SDoc+   pprFormatOp :: Line doc -> Format -> Operand -> doc    pprFormatOp name format op1-     = hcat [+     = line $ hcat [            pprMnemonic name format,            pprOperand platform format op1        ]  -   pprFormatOpOp :: SDoc -> Format -> Operand -> Operand -> SDoc+   pprFormatOpOp :: Line doc -> Format -> Operand -> Operand -> doc    pprFormatOpOp name format op1 op2-     = hcat [+     = 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+           ] -   pprOpOp :: SDoc -> Format -> Operand -> Operand -> SDoc+   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-     = hcat [+     = line $ hcat [            pprMnemonic_ name,            pprOperand platform format op1,            comma,            pprOperand platform format op2        ] -   pprRegReg :: SDoc -> Reg -> Reg -> SDoc+   pprRegReg :: Line doc -> Reg -> Reg -> doc    pprRegReg name reg1 reg2-     = hcat [+     = 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+       ] -   pprFormatOpReg :: SDoc -> Format -> Operand -> Reg -> SDoc+   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-     = hcat [+     = line $ hcat [            pprMnemonic name format,            pprOperand platform format op1,            comma,            pprReg platform (archWordFormat (target32Bit platform)) reg2        ] -   pprCondOpReg :: SDoc -> Format -> Cond -> Operand -> Reg -> SDoc+   pprCondOpReg :: Line doc -> Format -> Cond -> Operand -> Reg -> doc    pprCondOpReg name format cond op1 reg2-     = hcat [+     = line $ hcat [            char '\t',            name,            pprCond cond,@@ -1033,18 +1321,18 @@            pprReg platform format reg2        ] -   pprFormatFormatOpReg :: SDoc -> Format -> Format -> Operand -> Reg -> SDoc+   pprFormatFormatOpReg :: Line doc -> Format -> Format -> Operand -> Reg -> doc    pprFormatFormatOpReg name format1 format2 op1 reg2-     = hcat [+     = line $ hcat [            pprMnemonic name format2,            pprOperand platform format1 op1,            comma,            pprReg platform format2 reg2        ] -   pprFormatOpOpReg :: SDoc -> Format -> Operand -> Operand -> Reg -> SDoc+   pprFormatOpOpReg :: Line doc -> Format -> Operand -> Operand -> Reg -> doc    pprFormatOpOpReg name format op1 op2 reg3-     = hcat [+     = line $ hcat [            pprMnemonic name format,            pprOperand platform format op1,            comma,@@ -1055,7 +1343,7 @@   -   pprFormatAddr :: SDoc -> Format -> AddrMode -> SDoc+   pprFormatAddr :: Line doc -> Format -> AddrMode -> Line doc    pprFormatAddr name format  op      = hcat [            pprMnemonic name format,@@ -1063,25 +1351,212 @@            pprAddr platform op        ] -   pprShift :: SDoc -> Format -> Operand -> Operand -> SDoc+   pprShift :: Line doc -> Format -> Operand -> Operand -> doc    pprShift name format src dest-     = hcat [+     = 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 :: SDoc -> Format -> Format -> Operand -> Operand -> SDoc++   pprFormatOpOpCoerce :: Line doc -> Format -> Format -> Operand -> Operand -> doc    pprFormatOpOpCoerce name format1 format2 op1 op2-     = hcat [ char '\t', name, pprFormat format1, pprFormat format2, space,+     = line $ hcat [ char '\t', name, pprFormat format1, pprFormat format2, space,            pprOperand platform format1 op1,            comma,            pprOperand platform format2 op2        ]  -   pprCondInstr :: SDoc -> Cond -> SDoc -> SDoc+   pprCondInstr :: Line doc -> Cond -> Line doc -> doc    pprCondInstr name cond arg-     = hcat [ char '\t', name, pprCond cond, space, arg]+     = line $ hcat [ char '\t', name, pprCond cond, space, arg]++   -- Custom pretty printers+   -- These instructions currently don't follow a uniform suffix pattern+   -- in their names, so we have custom pretty printers for them.+   pprBroadcast :: Line doc -> Format -> Format -> Operand -> Reg -> doc+   pprBroadcast name scalarFormat vectorFormat op dst+     = line $ hcat [+           pprBroadcastMnemonic name vectorFormat,+           pprOperand platform scalarFormat op,+           comma,+           pprReg platform vectorFormat dst+       ]++   pprXor :: Line doc -> Format -> Reg -> Reg -> Reg -> doc+   pprXor name format reg1 reg2 reg3+     = line $ hcat [+           pprGenMnemonic name format,+           pprReg platform format reg1,+           comma,+           pprReg platform format reg2,+           comma,+           pprReg platform format reg3+       ]++   pprPXor :: Line doc -> Format -> Operand -> Reg -> doc+   pprPXor name format src dst+     = line $ hcat [+           pprGenMnemonic name format,+           pprOperand platform format src,+           comma,+           pprReg platform format dst+       ]++   pprVxor :: Format -> Operand -> Reg -> Reg -> doc+   pprVxor fmt src1 src2 dst+     = line $ hcat [+           pprGenMnemonic mem fmt,+           pprOperand platform fmt src1,+           comma,+           pprReg platform fmt src2,+           comma,+           pprReg platform fmt dst+       ]+     where+      mem = case fmt of+        FF32 -> text "vxorps"+        FF64 -> text "vxorpd"+        VecFormat _ FmtFloat -> text "vxorps"+        VecFormat _ FmtDouble -> text "vxorpd"+        _ -> pprPanic "GHC.CmmToAsm.X86.Ppr.pprVxor: element type must be Float or Double"+              (ppr fmt)++   pprInsert :: Line doc -> Format -> Imm -> Operand -> Reg -> doc+   pprInsert name format off src dst+     = line $ hcat [+           pprGenMnemonic name format,+           pprDollImm off,+           comma,+           pprOperand platform format src,+           comma,+           pprReg platform format dst+       ]++   pprPinsr :: Line doc -> Format -> Format -> Imm -> Operand -> Reg -> doc+   pprPinsr name scalarFormat vectorFormat imm src dst+     = line $ hcat [+           pprMnemonic name vectorFormat,+           pprDollImm imm,+           comma,+           pprOperand platform scalarFormat src,+           comma,+           pprReg platform vectorFormat dst+       ]++   pprPextr :: Line doc -> Format -> Format -> Imm -> Reg -> Operand -> doc+   pprPextr name scalarFormat vectorFormat imm src dst+     = line $ hcat [+           pprMnemonic name vectorFormat,+           pprDollImm imm,+           comma,+           pprReg platform vectorFormat src,+           comma,+           pprOperand platform scalarFormat dst+       ]++   pprShuf :: Line doc -> Format -> Imm -> Operand -> Reg -> doc+   pprShuf name format imm1 op2 reg3+     = line $ hcat [+           pprGenMnemonic name format,+           pprDollImm imm1,+           comma,+           pprOperand platform format op2,+           comma,+           pprReg platform format reg3+       ]++   pprVShuf :: Line doc -> Format -> Imm -> Operand -> Reg -> Reg -> doc+   pprVShuf name format imm1 op2 reg3 reg4+     = line $ hcat [+           pprGenMnemonic name format,+           pprDollImm imm1,+           comma,+           pprOperand platform format op2,+           comma,+           pprReg platform format reg3,+           comma,+           pprReg platform format reg4+       ]++   pprDoubleShift :: Line doc -> Format -> Imm -> Reg -> doc+   pprDoubleShift name format off reg+     = line $ hcat [+           pprGenMnemonic name format,+           pprDollImm off,+           comma,+           pprReg platform format reg+       ]++   pprImmOpReg :: Line doc -> Format -> Imm -> Operand -> Reg -> doc+   pprImmOpReg name format imm1 op2 reg3+     = line $ hcat [+           pprGenMnemonic name format,+           pprDollImm imm1,+           comma,+           pprOperand platform format op2,+           comma,+           pprReg platform format reg3+       ]++   pprFormatImmOpReg :: Line doc -> Format -> Imm -> Operand -> Reg -> doc+   pprFormatImmOpReg name format imm1 op2 reg3+     = line $ hcat [+           pprMnemonic name format,+           pprDollImm imm1,+           comma,+           pprOperand platform format op2,+           comma,+           pprReg platform format reg3+       ]++   pprImmOpRegReg :: Line doc -> Format -> Imm -> Operand -> Reg -> Reg -> doc+   pprImmOpRegReg name format imm1 op2 reg3 reg4+     = line $ hcat [+           pprGenMnemonic name format,+           pprDollImm imm1,+           comma,+           pprOperand platform format op2,+           comma,+           pprReg platform format reg3,+           comma,+           pprReg platform format reg4+       ]++   pprFormatImmOpRegReg :: Line doc -> Format -> Imm -> Operand -> Reg -> Reg -> doc+   pprFormatImmOpRegReg name format imm1 op2 reg3 reg4+     = line $ hcat [+           pprMnemonic name format,+           pprDollImm imm1,+           comma,+           pprOperand platform format op2,+           comma,+           pprReg platform format reg3,+           comma,+           pprReg platform format reg4+       ]++   pprMinMax :: Bool -> MinOrMax -> MinMaxType -> Format -> [Operand] -> doc+   pprMinMax wantV minOrMax mmTy fmt regs+     = line $ hcat ( instr : intersperse comma ( map ( pprOperand platform fmt ) regs ) )+      where+        instr =  (if wantV then text "v" else empty)+              <> (case mmTy of { IntVecMinMax {} -> text "p"; FloatMinMax -> empty })+              <> (case minOrMax of { Min -> text "min"; Max -> text "max" })+              <> (case mmTy of { IntVecMinMax wantSigned -> if wantSigned then text "s" else text "u"; FloatMinMax -> empty })+              <> pprFormat fmt+              <> space
GHC/CmmToAsm/X86/RegInfo.hs view
@@ -24,11 +24,10 @@ mkVirtualReg u format    = case format of         FF32    -> VirtualRegD u-        -- for scalar F32, we use the same xmm as F64!-        -- this is a hack that needs some improvement.-        -- For now we map both to being allocated as "Double" Registers-        -- on X86/X86_64+        -- 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@@ -68,5 +67,4 @@ --             ,"#8c8c8c","#939393","#9a9a9a","#a1a1a1","#a8a8a8" --             ,"#afafaf","#b6b6b6","#bdbdbd","#c4c4c4","#cbcbcb" --             ,"#d2d2d2","#d9d9d9","#e0e0e0"]-
GHC/CmmToAsm/X86/Regs.hs view
@@ -23,7 +23,6 @@         instrClobberedRegs,         allMachRegNos,         classOfRealReg,-        showReg,          -- machine specific         EABase(..), EAIndex(..), addrModeRegs,@@ -38,6 +37,7 @@         xmm8, xmm9, xmm10, xmm11, xmm12, xmm13, xmm14, xmm15,         xmm,         firstxmm, lastxmm,+        intregnos, xmmregnos,          ripRel,         allFPArgRegs,@@ -48,19 +48,17 @@ where  import GHC.Prelude+import GHC.Data.FastString  import GHC.Platform.Regs import GHC.Platform.Reg-import GHC.Platform.Reg.Class+import GHC.Platform.Reg.Class.Unified  import GHC.Cmm import GHC.Cmm.CLabel           ( CLabel )-import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Platform -import qualified Data.Array as A- -- | 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@@ -77,15 +75,13 @@                 VirtualRegHi{}          -> 1                 _other                  -> 0 -        RcDouble+        RcFloatOrVector          -> case vr of                 VirtualRegD{}           -> 1-                VirtualRegF{}           -> 0+                VirtualRegV128{}        -> 1                 _other                  -> 0  -        _other -> 0- {-# INLINE realRegSqueeze #-} realRegSqueeze :: RegClass -> RealReg -> Int realRegSqueeze cls rr@@ -96,14 +92,12 @@                         | regNo < firstxmm -> 1                         | otherwise     -> 0 -        RcDouble+        RcFloatOrVector          -> case rr of                 RealRegSingle regNo                         | regNo >= firstxmm  -> 1                         | otherwise     -> 0 -        _other -> 0- -- ----------------------------------------------------------------------------- -- Immediates @@ -111,15 +105,15 @@   = ImmInt      Int   | ImmInteger  Integer     -- Sigh.   | ImmCLbl     CLabel      -- AbstractC Label (with baggage)-  | ImmLit      SDoc        -- Simple string+  | ImmLit      FastString   | ImmIndex    CLabel Int   | ImmFloat    Rational   | ImmDouble   Rational   | ImmConstantSum Imm Imm   | ImmConstantDiff Imm Imm -strImmLit :: String -> Imm-strImmLit s = ImmLit (text s)+strImmLit :: FastString -> Imm+strImmLit s = ImmLit s   litToImm :: CmmLit -> Imm@@ -242,25 +236,9 @@     = case reg of         RealRegSingle i             | i <= lastint platform -> RcInteger-            | i <= lastxmm platform -> RcDouble+            | i <= lastxmm platform -> RcFloatOrVector             | otherwise             -> panic "X86.Reg.classOfRealReg registerSingle too high" --- | Get the name of the register with this number.--- NOTE: fixme, we dont track which "way" the XMM registers are used-showReg :: Platform -> RegNo -> String-showReg platform n-        | n >= firstxmm && n <= lastxmm  platform = "%xmm" ++ show (n-firstxmm)-        | n >= 8   && n < firstxmm      = "%r" ++ show n-        | otherwise      = regNames platform A.! n--regNames :: Platform -> A.Array Int String-regNames platform-    = if target32Bit platform-      then A.listArray (0,8) ["%eax", "%ebx", "%ecx", "%edx", "%esi", "%edi", "%ebp", "%esp"]-      else A.listArray (0,8) ["%rax", "%rbx", "%rcx", "%rdx", "%rsi", "%rdi", "%rbp", "%rsp"]--- -- machine specific ------------------------------------------------------------  @@ -271,11 +249,8 @@ - Registers 0-7 have 16-bit counterparts (ax, bx etc.) - Registers 0-3 have 8 bit counterparts (ah, bh etc.) -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.--TODO: cleanup modelling float vs double registers and how they are the same class.+The fp registers support Float, Doubles and vectors of those, as well+as vectors of integer values. -}  @@ -385,7 +360,7 @@    -- 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]+   ++ map xmm [0 .. 5]  | otherwise     -- all xmm regs are caller-saves     -- caller-saves registers
GHC/CmmToC.hs view
@@ -1,6 +1,9 @@ {-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DerivingVia   #-} {-# LANGUAGE GADTs         #-} {-# LANGUAGE LambdaCase    #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ViewPatterns #-}  ----------------------------------------------------------------------------- --@@ -33,11 +36,10 @@  import GHC.Cmm.BlockId import GHC.Cmm.CLabel-import GHC.Cmm hiding (pprBBlock)-import GHC.Cmm.Ppr () -- For Outputable instances+import GHC.Cmm hiding (pprBBlock, pprStatic) import GHC.Cmm.Dataflow.Block-import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Graph+import GHC.Cmm.Dataflow.Label import GHC.Cmm.Utils import GHC.Cmm.Switch import GHC.Cmm.InitFini@@ -49,16 +51,16 @@  import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Monad.State.Strict (State (..), runState, state) import GHC.Utils.Misc-import GHC.Utils.Trace  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 Control.Monad (ap) import GHC.Float  -- --------------------------------------------------------------------------@@ -85,7 +87,7 @@            blankLine,            extern_decls,            (if (externallyVisibleCLabel clbl)-                    then mkFN_ else mkIF_) (pprCLabel platform CStyle clbl) <+> lbrace,+                    then mkFN_ else mkIF_) (pprCLabel platform clbl) <+> lbrace,            nest 8 temp_decls,            vcat (map (pprBBlock platform) blocks),            rbrace ]@@ -107,14 +109,14 @@   (CmmData section (CmmStaticsRaw lbl [CmmString str])) ->     pprExternDecl platform lbl $$     hcat [-      pprLocalness lbl, pprConstness (isSecConstant section), text "char ", pprCLabel platform CStyle lbl,+      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 CStyle lbl,+      pprLocalness lbl, pprConstness (isSecConstant section), text "char ", pprCLabel platform lbl,       brackets (int size), semi     ] @@ -131,7 +133,7 @@ -- 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.+-- as many jumps as possible into fallthroughs. --  pprBBlock :: Platform -> CmmBlock -> SDoc@@ -150,7 +152,7 @@   = -- TODO: align closures only     pprExternDecl platform lbl $$     hcat [ pprLocalness lbl, pprConstness is_ro, text "StgWord"-         , space, pprCLabel platform CStyle lbl, text "[]"+         , space, pprCLabel platform lbl, text "[]"          -- See Note [StgWord alignment]          , pprAlignment (wordWidth platform)          , text "= {" ]@@ -241,17 +243,10 @@         fnCall =             case fn of               CmmLit (CmmLabel lbl)-                | StdCallConv <- cconv ->-                    pprCall platform (pprCLabel platform CStyle 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 platform cast_fn cconv hresults hargs <> semi-                | not (isMathFun lbl) ->-                    pprForeignCall platform (pprCLabel platform CStyle lbl) cconv hresults hargs+                    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.@@ -259,6 +254,13 @@     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@@ -345,7 +347,7 @@     rep = typeWidth (cmmExprType platform e)      -- fall through case-    caseify (ix:ixs, ident) = vcat (map do_fallthrough ixs) $$ final_branch ix+    caseify (ix:|ixs, ident) = vcat (map do_fallthrough ixs) $$ final_branch ix         where         do_fallthrough ix =                  hsep [ text "case" , pprHexVal platform ix rep <> colon ,@@ -355,8 +357,6 @@                 hsep [ text "case" , pprHexVal platform ix rep <> colon ,                        text "goto" , (pprBlockId ident) <> semi ] -    caseify (_     , _    ) = panic "pprSwitch: switch with no cases!"-     def | Just l <- mbdef = text "default: goto" <+> pprBlockId l <> semi         | otherwise       = text "default: __builtin_unreachable();" @@ -382,8 +382,8 @@     CmmRegOff reg 0    -> pprCastReg reg      -- CmmRegOff is an alias of MO_Add-    CmmRegOff reg i -> pprCastReg reg <> char '+' <>-                       pprHexVal platform (fromIntegral i) (wordWidth platform)+    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 @@ -430,10 +430,12 @@ pprMachOpApp platform op args   | isMulMayOfloOp op   = text "mulIntMayOflo" <> parens (commafy (map (pprExpr platform) args))-  where isMulMayOfloOp (MO_U_MulMayOflo _) = True-        isMulMayOfloOp (MO_S_MulMayOflo _) = True+  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)@@ -530,11 +532,23 @@ 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-    [x,y] -> pprArg x <+> pprMachOp_for_C platform mop <+> pprArg y+    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]   -> pprMachOp_for_C platform mop <> parens (pprArg x)+    [x]   ->+      let (_fixity, op) = pprMachOp_for_C platform mop+      in op <> parens (pprArg x)      _     -> panic "PprC.pprMachOp : machop with wrong number of args" @@ -594,7 +608,7 @@         -> mkW_ <> pprCLabelAddr clbl1 <> char '+' <> int i      where-        pprCLabelAddr lbl = char '&' <> pprCLabel platform CStyle lbl+        pprCLabelAddr lbl = char '&' <> pprCLabel platform lbl  pprLit1 :: Platform -> CmmLit -> SDoc pprLit1 platform lit = case lit of@@ -694,60 +708,85 @@ -- Print a MachOp in a way suitable for emitting via C. -- -pprMachOp_for_C :: Platform -> MachOp -> SDoc+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          _ -> char '+'-        MO_Sub          _ -> char '-'-        MO_Eq           _ -> text "=="-        MO_Ne           _ -> text "!="-        MO_Mul          _ -> char '*'+        MO_Add          _ -> (Infix, char '+')+        MO_Sub          _ -> (Infix, char '-')+        MO_Eq           _ -> (Infix, text "==")+        MO_Ne           _ -> (Infix, text "!=")+        MO_Mul          _ -> (Infix, char '*') -        MO_S_Quot       _ -> char '/'-        MO_S_Rem        _ -> char '%'-        MO_S_Neg        _ -> char '-'+        MO_S_Quot       _ -> (Infix, char '/')+        MO_S_Rem        _ -> (Infix, char '%')+        MO_S_Neg        _ -> (Infix, char '-') -        MO_U_Quot       _ -> char '/'-        MO_U_Rem        _ -> char '%'+        MO_U_Quot       _ -> (Infix, char '/')+        MO_U_Rem        _ -> (Infix, char '%') -        -- & Floating-point operations-        MO_F_Add        _ -> char '+'-        MO_F_Sub        _ -> char '-'-        MO_F_Neg        _ -> char '-'-        MO_F_Mul        _ -> char '*'-        MO_F_Quot       _ -> 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         _ -> text ">="-        MO_S_Le         _ -> text "<="-        MO_S_Gt         _ -> char '>'-        MO_S_Lt         _ -> char '<'+        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         _ -> text ">="-        MO_U_Le         _ -> text "<="-        MO_U_Gt         _ -> char '>'-        MO_U_Lt         _ -> char '<'+        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         _ -> text "=="-        MO_F_Ne         _ -> text "!="-        MO_F_Ge         _ -> text ">="-        MO_F_Le         _ -> text "<="-        MO_F_Gt         _ -> char '>'-        MO_F_Lt         _ -> char '<'+        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          _ -> 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+        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.@@ -755,106 +794,149 @@ -- 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 -> empty-        MO_UU_Conv _from to -> parens (machRep_U_CType platform to)+        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 -> empty-        MO_SS_Conv _from to -> parens (machRep_S_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 -> empty-        MO_XX_Conv _from to -> parens (machRep_U_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 -> empty-        MO_FF_Conv _from to -> parens (machRep_F_CType to)+        MO_FF_Conv from to | from == to -> (Prefix, empty)+        MO_FF_Conv _from to -> (Prefix,parens (machRep_F_CType to)) -        MO_SF_Conv _from to -> parens (machRep_F_CType to)-        MO_FS_Conv _from to -> parens (machRep_S_CType platform 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_U_MulMayOflo _ -> pprTrace "offending mop:"-                                (text "MO_U_MulMayOflo")-                                (panic $ "PprC.pprMachOp_for_C: MO_U_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"-                                      ++ " should have been handled earlier!")+                                      ++ "unsupported by the unregisterised backend")         MO_V_Extract {}   -> pprTrace "offending mop:"                                 (text "MO_V_Extract")                                 (panic $ "PprC.pprMachOp_for_C: MO_V_Extract"-                                      ++ " should have been handled earlier!")-+                                      ++ "unsupported by the unregisterised backend")         MO_V_Add {}       -> pprTrace "offending mop:"                                 (text "MO_V_Add")                                 (panic $ "PprC.pprMachOp_for_C: MO_V_Add"-                                      ++ " should have been handled earlier!")+                                      ++ "unsupported by the unregisterised backend")         MO_V_Sub {}       -> pprTrace "offending mop:"                                 (text "MO_V_Sub")                                 (panic $ "PprC.pprMachOp_for_C: MO_V_Sub"-                                      ++ " should have been handled earlier!")+                                      ++ "unsupported by the unregisterised backend")         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!")+                                      ++ "unsupported by the unregisterised backend")         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!")-+                                      ++ "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"-                                      ++ " should have been handled earlier!")+                                      ++ "unsupported by the unregisterised backend")         MO_VF_Extract {}  -> pprTrace "offending mop:"                                 (text "MO_VF_Extract")                                 (panic $ "PprC.pprMachOp_for_C: MO_VF_Extract"-                                      ++ " should have been handled earlier!")-+                                      ++ "unsupported by the unregisterised backend")         MO_VF_Add {}      -> pprTrace "offending mop:"                                 (text "MO_VF_Add")                                 (panic $ "PprC.pprMachOp_for_C: MO_VF_Add"-                                      ++ " should have been handled earlier!")+                                      ++ "unsupported by the unregisterised backend")         MO_VF_Sub {}      -> pprTrace "offending mop:"                                 (text "MO_VF_Sub")                                 (panic $ "PprC.pprMachOp_for_C: MO_VF_Sub"-                                      ++ " should have been handled earlier!")+                                      ++ "unsupported by the unregisterised backend")         MO_VF_Neg {}      -> pprTrace "offending mop:"                                 (text "MO_VF_Neg")                                 (panic $ "PprC.pprMachOp_for_C: MO_VF_Neg"-                                      ++ " should have been handled earlier!")+                                      ++ "unsupported by the unregisterised backend")         MO_VF_Mul {}      -> pprTrace "offending mop:"                                 (text "MO_VF_Mul")                                 (panic $ "PprC.pprMachOp_for_C: MO_VF_Mul"-                                      ++ " should have been handled earlier!")+                                      ++ "unsupported by the unregisterised backend")         MO_VF_Quot {}     -> pprTrace "offending mop:"                                 (text "MO_VF_Quot")                                 (panic $ "PprC.pprMachOp_for_C: MO_VF_Quot"-                                      ++ " should have been handled earlier!")--        MO_AlignmentCheck {} -> panic "-falignment-santisation not supported by unregisterised backend"+                                      ++ "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@@ -866,7 +948,7 @@ signedOp (MO_S_Lt   _)    = True signedOp (MO_S_Shr  _)    = True signedOp (MO_SS_Conv _ _) = True-signedOp (MO_SF_Conv _ _) = True+signedOp (MO_SF_Round _ _) = True signedOp _                = False  shiftOp :: MachOp -> Maybe Width@@ -929,8 +1011,9 @@         MO_F32_ExpM1    -> text "expm1f"         MO_F32_Sqrt     -> text "sqrtf"         MO_F32_Fabs     -> text "fabsf"-        MO_ReadBarrier  -> text "load_load_barrier"-        MO_WriteBarrier -> text "write_barrier"+        MO_AcquireFence -> unsupported+        MO_ReleaseFence -> unsupported+        MO_SeqCstFence  -> unsupported         MO_Memcpy _     -> text "__builtin_memcpy"         MO_Memset _     -> text "__builtin_memset"         MO_Memmove _    -> text "__builtin_memmove"@@ -949,8 +1032,9 @@         MO_AtomicRMW w amop -> ftext (atomicRMWLabel w amop)         MO_Cmpxchg w        -> ftext (cmpxchgLabel w)         MO_Xchg w           -> ftext (xchgLabel w)-        MO_AtomicRead w     -> ftext (atomicReadLabel w)-        MO_AtomicWrite w    -> ftext (atomicWriteLabel w)+        -- 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@@ -963,44 +1047,50 @@         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   -> 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+        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!")-          dontReach64 = panic ("pprCallishMachOp_for_C: " ++ show mop-                            ++ " should be not be encountered because the regular primop for this 64-bit operation is used instead.")  -- --------------------------------------------------------------------- -- Useful #defines@@ -1050,9 +1140,11 @@   | 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 = if r1 == CmmGlobal BaseReg-                       then text "ASSIGN_BaseReg" <> parens x <> semi-                       else pprReg r1 <> text " = " <> x <> semi+    where mkAssign x =+            case r1 of+              CmmGlobal (GlobalRegUse BaseReg _) ->+                text "ASSIGN_BaseReg" <> parens x <> semi+              _ -> pprReg r1 <> text " = " <> x <> semi  -- --------------------------------------------------------------------- -- Registers@@ -1067,17 +1159,16 @@ -- StgPtr. isFixedPtrReg :: CmmReg -> Bool isFixedPtrReg (CmmLocal _) = False-isFixedPtrReg (CmmGlobal r) = isFixedPtrGlobalReg r+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 (VanillaReg _ VGcPtr))    = True  -- if we print via pprAsPtrReg-isPtrReg (CmmGlobal (VanillaReg _ VNonGcPtr)) = False -- if we print via pprAsPtrReg-isPtrReg (CmmGlobal reg)                      = isFixedPtrGlobalReg reg+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@@ -1091,7 +1182,7 @@ -- (machRepCType (cmmRegType reg)), so it has to be cast. isStrangeTypeReg :: CmmReg -> Bool isStrangeTypeReg (CmmLocal _)   = False-isStrangeTypeReg (CmmGlobal g)  = isStrangeTypeGlobal g+isStrangeTypeReg (CmmGlobal (GlobalRegUse g _)) = isStrangeTypeGlobal g  isStrangeTypeGlobal :: GlobalReg -> Bool isStrangeTypeGlobal CCCS                = True@@ -1101,10 +1192,10 @@ 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 (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.@@ -1112,16 +1203,16 @@ pprReg :: CmmReg -> SDoc pprReg r = case r of         CmmLocal  local  -> pprLocalReg local-        CmmGlobal global -> pprGlobalReg global+        CmmGlobal (GlobalRegUse global _ ) -> pprGlobalReg global  pprAsPtrReg :: CmmReg -> SDoc-pprAsPtrReg (CmmGlobal (VanillaReg n gcp))-  = warnPprTrace (gcp /= VGcPtr) "pprAsPtrReg" (ppr n) $ char 'R' <> int n <> text ".p"+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"+    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);@@ -1207,9 +1298,8 @@ pprExternDecl platform 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, pprCLabel platform CStyle lbl, text ");"+        hcat [ visibility, label_type lbl , lparen, pprCLabel platform lbl, text ");"              -- occasionally useful to see label type              -- , text "/* ", pprDebugCLabel lbl, text " */"              ]@@ -1228,23 +1318,15 @@      | 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 =-        text "extern __attribute__((stdcall)) void " <> pprCLabel platform CStyle lbl-        <> parens (commafy (replicate (sz `quot` platformWordSizeInBytes platform) (machRep_U_CType platform (wordWidth platform))))-        <> semi- type TEState = (UniqSet LocalReg, Map CLabel ())-newtype TE a = TE { unTE :: TEState -> (a, TEState) } deriving (Functor)--instance Applicative TE where-      pure a = TE $ \s -> (a, s)-      (<*>) = ap+newtype TE a = TE' (State TEState a)+  deriving stock (Functor)+  deriving (Applicative, Monad) via State TEState -instance Monad TE where-   TE m >>= k  = TE $ \s -> case m s of (a, s') -> unTE (k a) s'+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))@@ -1416,7 +1498,6 @@ doubleToWord64 :: Rational -> CmmLit doubleToWord64 r = CmmInt (toInteger (castDoubleToWord64 (fromRational r))) W64 - -- --------------------------------------------------------------------------- -- Utils @@ -1498,12 +1579,15 @@ pprCtorArray :: Platform -> InitOrFini -> [CLabel] -> SDoc pprCtorArray platform initOrFini lbls =        decls-    <> text "static __attribute__((" <> attribute <> text "))"-    <> text "void _hs_" <> attribute <> text "()"+    <> text "static __attribute__((" <> text attribute <> text "))"+    <> text "void _hs_" <> text suffix <> text "()"     <> braces body   where-    body = vcat [ pprCLabel platform CStyle lbl <> text " ();" | lbl <- lbls ]-    decls = vcat [ text "void" <+> pprCLabel platform CStyle lbl <> text " (void);" | lbl <- lbls ]-    attribute = case initOrFini of-                  IsInitArray -> text "constructor"-                  IsFiniArray -> text "destructor"+    body = vcat [ pprCLabel platform lbl <> text " ();" | lbl <- lbls ]+    decls = vcat [ text "void" <+> pprCLabel platform lbl <> text " (void);" | lbl <- lbls ]+    (attribute, suffix) = case initOrFini of+                  IsInitArray+                    -- See Note [JSFFI initialization] for details+                    | ArchWasm32 <- platformArch platform -> ("constructor(101)", "constructor")+                    | otherwise -> ("constructor", "constructor")+                  IsFiniArray -> ("destructor", "destructor")
GHC/CmmToLlvm.hs view
@@ -21,14 +21,15 @@ import GHC.CmmToLlvm.Ppr import GHC.CmmToLlvm.Regs import GHC.CmmToLlvm.Mangler+import GHC.CmmToLlvm.Version -import GHC.StgToCmm.CgUtils ( fixStgRegisters )+import GHC.StgToCmm.CgUtils ( fixStgRegisters, CgStream ) import GHC.Cmm-import GHC.Cmm.Dataflow.Collections-import GHC.Cmm.Ppr+import GHC.Cmm.Dataflow.Label +import GHC.Types.Unique.DSM import GHC.Utils.BufHandle-import GHC.Driver.Session+import GHC.Driver.DynFlags import GHC.Platform ( platformArch, Arch(..) ) import GHC.Utils.Error import GHC.Data.FastString@@ -38,16 +39,18 @@ import qualified GHC.Data.Stream as Stream  import Control.Monad ( when, forM_ )-import Data.Maybe ( fromMaybe, catMaybes )+import Data.Maybe ( fromMaybe, catMaybes, isNothing ) import System.IO  -- ----------------------------------------------------------------------------- -- | Top-level of the LLVM Code generator -- llvmCodeGen :: Logger -> LlvmCgConfig -> Handle-               -> Stream.Stream IO RawCmmGroup a-               -> IO a-llvmCodeGen logger cfg h cmm_stream+            -> 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 @@ -68,12 +71,14 @@            "up to" <+> text (llvmVersionStr supportedLlvmVersionUpperBound) <+> "(non inclusive) is supported." <+>            "System LLVM version: " <> text (llvmVersionStr ver) $$            "We will try though..."-         let isS390X = platformArch (llvmCgPlatform cfg)  == ArchS390X-         let major_ver = head . llvmVersionList $ ver-         when (isS390X && major_ver < 10 && doWarn) $ putMsg logger $-           "Warning: For s390x the GHC calling convention is only supported since LLVM version 10." <+>-           "You are using LLVM version: " <> text (llvmVersionStr ver) +       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.@@ -81,38 +86,42 @@            llvm_ver = fromMaybe supportedLlvmVersionLowerBound mb_ver         -- run code generation-       a <- runLlvm logger cfg llvm_ver bufh $+       (a, _) <- runLlvm logger cfg llvm_ver bufh dus $          llvmCodeGen' cfg cmm_stream         bFlush bufh         return a -llvmCodeGen' :: LlvmCgConfig -> Stream.Stream IO RawCmmGroup a -> LlvmM a+llvmCodeGen' :: LlvmCgConfig+             -> CgStream RawCmmGroup a -> LlvmM a llvmCodeGen' cfg cmm_stream   = do  -- Preamble-        renderLlvm header+        renderLlvm (llvmHeader cfg) (llvmHeader cfg)         ghcInternalFunctions         cmmMetaLlvmPrelude          -- Procedures-        a <- Stream.consume cmm_stream liftIO llvmGroupLlvmGens+        a <- Stream.consume cmm_stream (GHC.CmmToLlvm.Base.liftUDSMT) (llvmGroupLlvmGens)          -- Declare aliases for forward references-        renderLlvm . pprLlvmData cfg =<< generateExternDecls+        decls <- generateExternDecls+        renderLlvm (pprLlvmData cfg decls)+                   (pprLlvmData cfg decls)          -- Postamble         cmmUsedLlvmGens          return a-  where-    header :: SDoc-    header =-      let target  = llvmCgLlvmTarget cfg-          llvmCfg = llvmCgLlvmConfig cfg-      in     text ("target datalayout = \"" ++ getDataLayout llvmCfg target ++ "\"")-         $+$ text ("target triple = \"" ++ target ++ "\"") +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@@ -121,6 +130,8 @@                    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@@ -156,10 +167,11 @@                         = funInsert l ty            regGlobal _  = pure ()        mapM_ regGlobal gs-       gss' <- mapM aliasify $ gs+       gss' <- mapM aliasify gs         cfg <- getConfig-       renderLlvm $ pprLlvmData cfg (concat gss', concat tss)+       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 ()@@ -175,12 +187,12 @@     -- 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+    -- 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 () @@ -190,7 +202,7 @@  cmmMetaLlvmPrelude :: LlvmM () cmmMetaLlvmPrelude = do-  metas <- flip mapM stgTBAA $ \(uniq, name, parent) -> do+  tbaa_metas <- flip mapM stgTBAA $ \(uniq, name, parent) -> do     -- Generate / lookup meta data IDs     tbaaId <- getMetaUniqueId     setUniqMeta uniq tbaaId@@ -203,9 +215,51 @@               -- just a name on its own. Previously `null` was accepted as the               -- name.               Nothing -> [ MetaStr name ]++  platform <- getPlatform   cfg <- getConfig-  renderLlvm $ ppLlvmMetas cfg metas+  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 --@@ -229,4 +283,7 @@       lmUsed    = LMGlobal lmUsedVar (Just usedArray)   if null ivars      then return ()-     else getConfig >>= renderLlvm . flip pprLlvmData ([lmUsed], [])+     else do+      cfg <- getConfig+      renderLlvm (pprLlvmData cfg ([lmUsed], []))+                 (pprLlvmData cfg ([lmUsed], []))
GHC/CmmToLlvm/Base.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DerivingVia #-}  {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} @@ -12,13 +12,9 @@ module GHC.CmmToLlvm.Base (          LlvmCmmDecl, LlvmBasicBlock,-        LiveGlobalRegs,+        LiveGlobalRegs, LiveGlobalRegUses,         LlvmUnresData, LlvmData, UnresLabel, UnresStatic, -        LlvmVersion, supportedLlvmVersionLowerBound, supportedLlvmVersionUpperBound,-        llvmVersionSupported, parseLlvmVersion,-        llvmVersionStr, llvmVersionList,-         LlvmM,         runLlvm, withClearVars, varLookup, varInsert,         markStackReg, checkStackReg,@@ -27,49 +23,51 @@         ghcInternalFunctions, getPlatform, getConfig,          getMetaUniqueId,-        setUniqMeta, getUniqMeta, liftIO,+        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 -#include "ghc-llvm-version.h"- import GHC.Prelude import GHC.Utils.Panic  import GHC.Llvm import GHC.CmmToLlvm.Regs import GHC.CmmToLlvm.Config+import GHC.CmmToLlvm.Version  import GHC.Cmm.CLabel-import GHC.Cmm.Ppr.Expr () import GHC.Platform.Regs ( activeStgRegs, globalRegMaybe )-import GHC.Driver.Session+import GHC.Driver.DynFlags import GHC.Data.FastString import GHC.Cmm              hiding ( succ )-import GHC.Cmm.Utils (regsOverlap)+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 GHC.Types.Unique.Supply+import qualified GHC.Types.Unique.DSM as DSM import GHC.Utils.Logger -import Data.Maybe (fromJust)-import Control.Monad (ap)-import Data.Char (isDigit)-import Data.List (sortBy, groupBy, intercalate)-import Data.Ord (comparing)+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@@ -80,6 +78,7 @@  -- | Global registers live on proc entry type LiveGlobalRegs = [GlobalReg]+type LiveGlobalRegUses = [GlobalRegUse]  -- | Unresolved code. -- Of the form: (data label, data type, unresolved data)@@ -123,16 +122,16 @@  | otherwise                       = CC_Ghc  -- | Llvm Function type for Cmm function-llvmFunTy :: LiveGlobalRegs -> LlvmM LlvmType+llvmFunTy :: LiveGlobalRegUses -> LlvmM LlvmType llvmFunTy live = return . LMFunction =<< llvmFunSig' live (fsLit "a") ExternallyVisible  -- | Llvm Function signature-llvmFunSig :: LiveGlobalRegs ->  CLabel -> LlvmLinkageType -> LlvmM LlvmFunctionDecl+llvmFunSig :: LiveGlobalRegUses ->  CLabel -> LlvmLinkageType -> LlvmM LlvmFunctionDecl llvmFunSig live lbl link = do   lbl' <- strCLabel_llvm lbl   llvmFunSig' live lbl' link -llvmFunSig' :: LiveGlobalRegs -> LMString -> LlvmLinkageType -> LlvmM LlvmFunctionDecl+llvmFunSig' :: LiveGlobalRegUses -> LMString -> LlvmLinkageType -> LlvmM LlvmFunctionDecl llvmFunSig' live lbl link   = do let toParams x | isPointer x = (x, [NoAlias, NoCapture])                       | otherwise   = (x, [])@@ -156,16 +155,25 @@     | otherwise               = Nothing  -- | A Function's arguments-llvmFunArgs :: Platform -> LiveGlobalRegs -> [LlvmVar]+llvmFunArgs :: Platform -> LiveGlobalRegUses -> [LlvmVar] llvmFunArgs platform live =-    map (lmGlobalRegArg platform) (filter isPassed allRegs)+    map (lmGlobalRegArg platform) (mapMaybe isPassed allRegs)     where allRegs = activeStgRegs platform           paddingRegs = padLiveArgs platform live-          isLive r = r `elem` alwaysLive-                     || r `elem` live-                     || r `elem` paddingRegs-          isPassed r = not (isFPR r) || isLive r+          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@@ -186,7 +194,7 @@ -- 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 -> LiveGlobalRegs -> LiveGlobalRegs+padLiveArgs :: Platform -> LiveGlobalRegUses -> LiveGlobalRegUses padLiveArgs platform live =       if platformUnregisterised platform         then [] -- not using GHC's register convention for platform.@@ -195,48 +203,52 @@     ----------------------------------     -- handle floating-point registers (FPR) -    fprLive = filter isFPR live  -- real live FPR registers+    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         = groupBy sharesClass fprLive-    sharesClass a b = regsOverlap platform (norm a) (norm b) -- check if mapped to overlapping registers-    norm x          = CmmGlobal ((fpr_ctor x) 1)             -- get the first register of the family+    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 rs = go sortedRs [1..]++    padClass :: NE.NonEmpty GlobalRegUse -> [GlobalRegUse]+    padClass rs = go (NE.toList sortedRs) 1       where-         sortedRs = sortBy (comparing fpr_num) rs-         maxr     = last sortedRs+         sortedRs = NE.sortBy (comparing (fpr_num . globalRegUse_reg)) rs+         maxr     = NE.last sortedRs          ctor     = fpr_ctor maxr           go [] _ = []-         go (c1:c2:_) _   -- detect bogus case (see #17920)+         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 (c:cs) (f:fs)-            | fpr_num c == f = go cs fs              -- already covered by a real register-            | otherwise      = ctor f : go (c:cs) fs -- add padding register-         go _ _ = undefined -- unreachable+         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 :: GlobalReg -> Int -> GlobalReg-    fpr_ctor (FloatReg _)  = FloatReg-    fpr_ctor (DoubleReg _) = DoubleReg-    fpr_ctor (XmmReg _)    = XmmReg-    fpr_ctor (YmmReg _)    = YmmReg-    fpr_ctor (ZmmReg _)    = ZmmReg-    fpr_ctor _ = error "fpr_ctor expected only FPR regs"+    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@@ -261,42 +273,6 @@ llvmPtrBits platform = widthInBits $ typeWidth $ gcWord platform  -- ------------------------------------------------------------------------------- * Llvm Version-----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---- | The (inclusive) lower bound on the LLVM Version that is currently supported.-supportedLlvmVersionLowerBound :: LlvmVersion-supportedLlvmVersionLowerBound = LlvmVersion (sUPPORTED_LLVM_VERSION_MIN NE.:| [])---- | The (not-inclusive) upper bound  bound on the LLVM Version that is currently supported.-supportedLlvmVersionUpperBound :: LlvmVersion-supportedLlvmVersionUpperBound = LlvmVersion (sUPPORTED_LLVM_VERSION_MAX NE.:| [])--llvmVersionSupported :: LlvmVersion -> Bool-llvmVersionSupported v =-  v >= supportedLlvmVersionLowerBound && v < supportedLlvmVersionUpperBound--llvmVersionStr :: LlvmVersion -> String-llvmVersionStr = intercalate "." . map show . llvmVersionList--llvmVersionList :: LlvmVersion -> [Int]-llvmVersionList = NE.toList . llvmVersionNE---- ---------------------------------------------------------------------------- -- * Environment Handling -- @@ -305,7 +281,7 @@   , envConfig    :: !LlvmCgConfig    -- ^ Configuration for LLVM code gen   , envLogger    :: !Logger          -- ^ Logger   , envOutput    :: BufHandle        -- ^ Output buffer-  , envMask      :: !Char            -- ^ Mask for creating unique values+  , 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@@ -314,27 +290,19 @@      -- 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)+  , 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 -> IO (a, LlvmEnv) }-    deriving (Functor)--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'+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@@ -342,25 +310,31 @@ getConfig :: LlvmM LlvmCgConfig getConfig = LlvmM $ \env -> return (envConfig env, env) -instance MonadUnique LlvmM where-    getUniqueSupplyM = do-        mask <- getEnv envMask-        liftIO $! mkSplitUniqSupply mask -    getUniqueM = do-        mask <- getEnv envMask-        liftIO $! uniqFromMask mask+-- 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 <- m+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 -> LlvmM a -> IO a-runLlvm logger cfg ver out m = do-    (a, _) <- runLlvmM m env-    return a+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 = []@@ -370,7 +344,7 @@                       , envConfig    = cfg                       , envLogger    = logger                       , envOutput    = out-                      , envMask      = 'n'+                      , envTag       = 'n'                       , envFreshMeta = MetaId 0                       , envUniqMeta  = emptyUFM                       }@@ -400,12 +374,14 @@ funLookup s = getEnv (flip lookupUFM (getUnique s) . envFunMap)  -- | Set a register as allocated on the stack-markStackReg :: GlobalReg -> LlvmM ()+markStackReg :: GlobalRegUse -> 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)+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@@ -423,13 +399,13 @@   liftIO $ putDumpFileMaybe logger flag hdr fmt doc  -- | Prints the given contents to the output handle-renderLlvm :: Outp.SDoc -> LlvmM ()-renderLlvm sdoc = do+renderLlvm :: Outp.HDoc -> Outp.SDoc -> LlvmM ()+renderLlvm hdoc sdoc = do      -- Write to output     ctx <- llvmCgContext <$> getConfig     out <- getEnv envOutput-    liftIO $ Outp.bufLeftRenderSDoc ctx out sdoc+    liftIO $ Outp.bPutHDoc out ctx hdoc      -- Dump, if requested     dumpIfSetLlvm Opt_D_dump_llvm "LLVM Code" FormatLLVM sdoc@@ -464,7 +440,7 @@ -- 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.+-- 'void *'). Fixes #5486. ghcInternalFunctions :: LlvmM () ghcInternalFunctions = do     platform <- getPlatform@@ -480,7 +456,7 @@       let n' = fsLit n           decl = LlvmFunctionDecl n' ExternallyVisible CC_Ccc ret                                  FixedArgs (tysToParams args) Nothing-      renderLlvm $ ppLlvmFunctionDecl decl+      renderLlvm (ppLlvmFunctionDecl decl) (ppLlvmFunctionDecl decl)       funInsert n' (LMFunction decl)  -- ----------------------------------------------------------------------------@@ -492,8 +468,8 @@ strCLabel_llvm lbl = do     ctx <- llvmCgContext <$> getConfig     platform <- getPlatform-    let sdoc = pprCLabel platform CStyle lbl-        str = Outp.renderWithContext ctx sdoc+    let sdoc = pprCLabel platform lbl+        str = Outp.showSDocOneLine ctx sdoc     return (fsLit str)  -- ----------------------------------------------------------------------------@@ -550,6 +526,12 @@   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]@@ -557,8 +539,9 @@ -- 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 (LMGlobalVar lbl ty@LMAlias{} link sect align Alias)-                   (Just orig)) = do+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@@ -571,7 +554,8 @@     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) = do+aliasify (LMGlobal var val)+  | not $ isBuiltinLlvmVar var = do     let LMGlobalVar lbl ty link sect align const = var          defLbl = llvmDefLabel lbl@@ -589,6 +573,7 @@     return [ LMGlobal defVar val            , LMGlobal aliasVar (Just aliasVal)            ]+aliasify global = pure [global]  -- Note [Llvm Forward References] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -647,3 +632,6 @@ -- away with casting the alias to the desired type in @getSymbolPtr@ -- and instead just emit a reference to the definition symbol directly. -- This is the @Just@ case in @getSymbolPtr@.+--+-- Note that we must take care not to turn LLVM's builtin variables into+-- aliases (e.g. $llvm.global_ctors) since this confuses LLVM.
GHC/CmmToLlvm/CodeGen.hs view
@@ -1,7 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE GADTs, MultiWayIf #-} {-# OPTIONS_GHC -fno-warn-type-defaults #-}-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}  -- | Handle conversion of CmmProc to LLVM code. module GHC.CmmToLlvm.CodeGen ( genLlvmProc ) where@@ -12,6 +11,7 @@ import GHC.Platform.Regs ( activeStgRegs )  import GHC.Llvm+import GHC.Llvm.Types import GHC.CmmToLlvm.Base import GHC.CmmToLlvm.Config import GHC.CmmToLlvm.Regs@@ -19,34 +19,37 @@ import GHC.Cmm.BlockId import GHC.Cmm.CLabel import GHC.Cmm-import GHC.Cmm.Ppr as PprCmm import GHC.Cmm.Utils import GHC.Cmm.Switch import GHC.Cmm.Dataflow.Block import GHC.Cmm.Dataflow.Graph-import GHC.Cmm.Dataflow.Collections+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.Supply+import GHC.Types.Unique.DSM import GHC.Types.Unique  import GHC.Utils.Outputable-import GHC.Utils.Panic.Plain (massert) import qualified GHC.Utils.Panic as Panic import GHC.Utils.Misc +import Control.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 = Bool+type Atomic = Maybe MemoryOrdering type LlvmStatements = OrdList LlvmStatement  data Signage = Signed | Unsigned deriving (Eq, Show)@@ -55,8 +58,8 @@ -- | Top-level of the LLVM proc Code generator -- genLlvmProc :: RawCmmDecl -> LlvmM [LlvmCmmDecl]-genLlvmProc (CmmProc infos lbl live graph) = do-    let blocks = toBlockListEntryFirstFalseFallthrough graph+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)@@ -68,12 +71,16 @@ -- * 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 :: LiveGlobalRegs -> [CmmBlock]+basicBlocksCodeGen :: LiveGlobalRegUses -> NonEmpty CmmBlock                       -> LlvmM ([LlvmBasicBlock], [LlvmCmmDecl])-basicBlocksCodeGen _    []                     = panic "no entry block!" basicBlocksCodeGen live cmmBlocks   = do -- Emit the prologue        -- N.B. this must be its own block to ensure that the entry block of the@@ -83,20 +90,27 @@        (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 cmmBlocks+       (blocks, topss) <- fmap unzip $ mapM (basicBlockCodeGen ubid) $ toList cmmBlocks         -- Compose-       return (entryBlock : blocks, prologueTops ++ concat topss)+       return (entryBlock : ubblock : blocks, prologueTops ++ concat topss)   -- | Generate code for one block-basicBlockCodeGen :: CmmBlock -> LlvmM ( LlvmBasicBlock, [LlvmCmmDecl] )-basicBlockCodeGen block+basicBlockCodeGen :: UnreachableBlockId -> CmmBlock -> LlvmM ( LlvmBasicBlock, [LlvmCmmDecl] )+basicBlockCodeGen ubid block   = do let (_, nodes, tail)  = blockSplit block            id = entryLabel block-       (mid_instrs, top) <- stmtsToInstrs $ blockToList nodes-       (tail_instrs, top')  <- stmtToInstrs tail+       (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) @@ -111,15 +125,15 @@   -- | 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+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 :: CmmNode e x -> LlvmM StmtData-stmtToInstrs stmt = case stmt of+stmtToInstrs :: UnreachableBlockId -> CmmNode e x -> LlvmM StmtData+stmtToInstrs ubid stmt = case stmt of      CmmComment _         -> return (nilOL, []) -- nuke comments     CmmTick    _         -> return (nilOL, [])@@ -132,7 +146,7 @@     CmmBranch id         -> genBranch id     CmmCondBranch arg true false likely                          -> genCondBranch arg true false likely-    CmmSwitch arg ids    -> genSwitch arg ids+    CmmSwitch arg ids    -> genSwitch ubid arg ids      -- Foreign Call     CmmUnsafeForeignCall target res args@@ -172,43 +186,28 @@         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, [])---- | Insert a 'barrier', unless the target platform is in the provided list of---   exceptions (where no code will be emitted instead).-barrierUnless :: [Arch] -> LlvmM StmtData-barrierUnless exs = do-    platform <- getPlatform-    if platformArch platform `elem` exs-        then return (nilOL, [])-        else barrier- -- | 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_ReadBarrier) _ _ =-    barrierUnless [ArchX86, ArchX86_64]--genCall (PrimTarget MO_WriteBarrier) _ _ =-    barrierUnless [ArchX86, ArchX86_64]+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 <- getCmmRegW (CmmLocal dst)-    let ty = cmmToLlvmType $ localRegType dst-        width = widthToLlvmFloat w+    (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+    statement $ Store castV dstV Nothing []  genCall (PrimTarget (MO_UF_Conv _)) [_] args =     panic $ "genCall: Too many arguments to MO_UF_Conv. " ++@@ -231,23 +230,22 @@     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_Pdep w)) dsts args =-    genCallSimpleCast2 w t dsts args-genCall t@(PrimTarget (MO_Pext w)) dsts args =-    genCallSimpleCast2 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 t@(PrimTarget (MO_BRev w)) dsts args =-    genCallSimpleCast w t dsts args+-- 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@@ -255,7 +253,7 @@     let targetTy = widthToLlvmInt width         ptrExpr = Cast LM_Inttoptr addrVar (pLift targetTy)     ptrVar <- doExprW (pLift targetTy) ptrExpr-    dstVar <- getCmmRegW (CmmLocal dst)+    (dstVar, _dst_ty) <- getCmmRegW (CmmLocal dst)     let op = case amop of                AMO_Add  -> LAO_Add                AMO_Sub  -> LAO_Sub@@ -264,12 +262,12 @@                AMO_Or   -> LAO_Or                AMO_Xor  -> LAO_Xor     retVar <- doExprW targetTy $ AtomicRMW op ptrVar nVar SyncSeqCst-    statement $ Store retVar dstVar Nothing+    statement $ Store retVar dstVar Nothing [] -genCall (PrimTarget (MO_AtomicRead _)) [dst] [addr] = runStmtsDecls $ do-    dstV <- getCmmRegW (CmmLocal dst)-    v1 <- genLoadW True addr (localRegType dst) NaturallyAligned-    statement $ Store v1 dstV 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@@ -279,29 +277,30 @@     let targetTy = getVarType oldVar         ptrExpr = Cast LM_Inttoptr addrVar (pLift targetTy)     ptrVar <- doExprW (pLift targetTy) ptrExpr-    dstVar <- getCmmRegW (CmmLocal dst)+    (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+    statement $ Store retVar' dstVar Nothing []  genCall (PrimTarget (MO_Xchg _width)) [dst] [addr, val] = runStmtsDecls $ do-    dstV <- getCmmRegW (CmmLocal dst) :: WriterT LlvmAccum LlvmM LlvmVar+    (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+    statement $ Store resVar dstV Nothing [] -genCall (PrimTarget (MO_AtomicWrite _width)) [] [addr, val] = runStmtsDecls $ do+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-    statement $ Expr $ AtomicRMW LAO_Xchg ptrVar valVar SyncSeqCst+    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.@@ -351,10 +350,10 @@     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 Nothing-    statement $ Store retH dstRegH Nothing+    (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@@ -382,12 +381,12 @@     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 <- getCmmRegW (CmmLocal dstL)-    dstRegH <- getCmmRegW (CmmLocal dstH)-    dstRegC <- getCmmRegW (CmmLocal dstC)-    statement $ Store retL dstRegL Nothing-    statement $ Store retH dstRegH Nothing-    statement $ Store retC dstRegC Nothing+    (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@@ -419,10 +418,10 @@     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 Nothing-    statement $ Store retRem dstRegR Nothing+    (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.@@ -444,6 +443,34 @@ 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@@ -453,10 +480,7 @@     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+                 StdCallConv  -> panic "GHC.CmmToLlvm.CodeGen.genCall: StdCallConv"                  CCallConv    -> CC_Ccc                  CApiConv     -> CC_Ccc                  PrimCallConv       -> panic "GHC.CmmToLlvm.CodeGen.genCall: PrimCallConv"@@ -506,7 +530,6 @@     let funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible                              lmconv retTy FixedArgs argTy (llvmFunAlign platform) -     argVars <- arg_varsW args_hints ([], nilOL, [])     fptr    <- getFunPtrW funTy target @@ -526,23 +549,21 @@                 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 Nothing-                    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 Nothing-                    doReturn+            (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@@ -559,7 +580,7 @@                             , MO_AddWordC w                             , MO_SubWordC w                             ]-    massert valid+    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.@@ -568,10 +589,10 @@     -- value is i<width>, but overflowBit is i1, so we need to cast (Cmm expects     -- both to be i<width>)     (overflow, zext) <- doExpr width $ Cast LM_Zext overflowBit width-    dstRegV <- getCmmReg (CmmLocal dstV)-    dstRegO <- getCmmReg (CmmLocal dstO)-    let storeV = Store value dstRegV Nothing-        storeO = Store overflow dstRegO Nothing+    (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"@@ -618,64 +639,29 @@ -- 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)+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 -    let (_, arg_hints) = foreignTargetHints t-    let args_hints = zip args arg_hints-    (argsV, stmts2, top2)       <- arg_vars args_hints ([], nilOL, [])-    (argsV', stmts4)            <- castVars Signed $ zip argsV [width]-    (retV, s1)                  <- doExpr width $ Call StdCall fptr argsV' []-    (retVs', stmts5)            <- castVars (cmmPrimOpRetValSignage op) [(retV,dstTy)]-    let retV'                    = singletonPanic "genCallSimpleCast" retVs'-    let s2                       = Store retV' dstV Nothing+    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 `appOL` stmts5 `snocOL` s2+                s1 `snocOL` stmts5 `snocOL` s2     return (stmts, top2 ++ top3)-genCallSimpleCast _ _ dsts _ =-    panic ("genCallSimpleCast: " ++ show (length dsts) ++ " dsts") --- 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.-genCallSimpleCast2 :: Width -> ForeignTarget -> [CmmFormal] -> [CmmActual]-              -> LlvmM StmtData-genCallSimpleCast2 w t@(PrimTarget op) [dst] args = do-    let width = widthToLlvmInt w-        dstTy = cmmToLlvmType $ localRegType dst--    fname                       <- cmmPrimOpFunctions op-    (fptr, _, top3)             <- getInstrinct fname width (const width <$> args)--    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 Signed $ zip argsV (const width <$> argsV)-    (retV, s1)                  <- doExpr width $ Call StdCall fptr argsV' []-    (retVs', stmts5)             <- castVars (cmmPrimOpRetValSignage op) [(retV,dstTy)]-    let retV'                    = singletonPanic "genCallSimpleCast2" retVs'-    let s2                       = Store retV' dstV Nothing--    let stmts = stmts2 `appOL` stmts4 `snocOL`-                s1 `appOL` stmts5 `snocOL` s2-    return (stmts, top2 ++ top3)-genCallSimpleCast2 _ _ dsts _ =-    panic ("genCallSimpleCast2: " ++ show (length dsts) ++ " dsts")- -- | Create a function pointer from a target. getFunPtrW :: (LMString -> LlvmType) -> ForeignTarget            -> WriterT LlvmAccum LlvmM LlvmVar@@ -759,7 +745,7 @@                 let (vars', stmts) = unzip done                 return (vars', toOL stmts) --- | Cast an LLVM variable to a specific type, panicing if it can't be done.+-- | 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)@@ -789,11 +775,47 @@             Signed      -> LM_Sext             Unsigned    -> LM_Zext - cmmPrimOpRetValSignage :: CallishMachOp -> Signage cmmPrimOpRetValSignage mop = case mop of-    MO_Pdep _   -> Unsigned-    MO_Pext _   -> Unsigned+    -- 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@@ -1008,16 +1030,28 @@     -- We support MO_U_Mul2 through ordinary LLVM mul instruction, see the     -- appropriate case of genCall.     MO_U_Mul2 {}     -> unsupported-    MO_ReadBarrier   -> unsupported-    MO_WriteBarrier  -> 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_AtomicRead _ _  -> unsupported+    MO_AtomicRMW _ _   -> unsupported+    MO_AtomicWrite _ _ -> unsupported+    MO_Cmpxchg _       -> unsupported+    MO_Xchg _          -> unsupported      MO_I64_ToI       -> dontReach64     MO_I64_FromI     -> dontReach64@@ -1051,7 +1085,7 @@   -- | Tail function calls-genJump :: CmmExpr -> [GlobalReg] -> LlvmM StmtData+genJump :: CmmExpr -> LiveGlobalRegUses -> LlvmM StmtData  -- Call to known function genJump (CmmLit (CmmLabel lbl)) live = do@@ -1088,26 +1122,24 @@ -- these with registers when possible. genAssign :: CmmReg -> CmmExpr -> LlvmM StmtData genAssign reg val = do-    vreg <- getCmmReg reg+    (vreg, ty) <- getCmmReg reg     (vval, stmts2, top2) <- exprToVar val     let stmts = stmts2--    let ty = (pLower . getVarType) vreg     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+          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+          let s2 = mkStore v vreg NaturallyAligned []           return (stmts `snocOL` s1 `snocOL` s2, top2)        _ -> do-          let s1 = Store vval vreg Nothing+          let s1 = Store vval vreg Nothing []           return (stmts `snocOL` s1, top2)  @@ -1143,12 +1175,12 @@ -- | 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 -> AlignmentSpec+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 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@@ -1158,7 +1190,7 @@                 case pLower grt == getVarType vval of                      -- were fine                      True  -> do-                         let s3 = MetaStmt meta $ mkStore vval ptr alignment+                         let s3 = mkStore vval ptr alignment meta                          return (stmts `appOL` s1 `snocOL` s2                                  `snocOL` s3, top) @@ -1166,7 +1198,7 @@                      False -> do                          let ty = (pLift . getVarType) vval                          (ptr', s3) <- doExpr ty $ Cast LM_Bitcast ptr ty-                         let s4 = MetaStmt meta $ mkStore vval ptr' alignment+                         let s4 = mkStore vval ptr' alignment meta                          return (stmts `appOL` s1 `snocOL` s2                                  `snocOL` s3 `snocOL` s4, top) @@ -1189,29 +1221,29 @@         -- 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 = MetaStmt meta $ mkStore v vaddr alignment+            let s2 = mkStore v vaddr alignment meta             return (stmts `snocOL` s1 `snocOL` s2, top1 ++ top2)          LMPointer _ -> do-            let s1 = MetaStmt meta $ mkStore vval vaddr alignment+            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 = MetaStmt meta $ mkStore vval vptr alignment+            let s2 = mkStore vval vptr alignment meta             return (stmts `snocOL` s1 `snocOL` s2, top1 ++ top2)          other ->             pprPanic "genStore: ptr not right type!"-                    (PprCmm.pprExpr platform addr <+> text (-                        "Size of Ptr: "   ++ show (llvmPtrBits platform) ++-                        ", Size of var: " ++ show (llvmWidthInBits platform other) ++-                        ", Var: "         ++ renderWithContext (llvmCgContext cfg) (ppVar cfg vaddr)))+                    (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 -> LlvmStatement-mkStore vval vptr alignment =-    Store vval vptr align+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@@ -1256,7 +1288,7 @@     lit = LMLitVar $ LMIntLit expLit expTy      llvmExpectName-      | isInt expTy = fsLit $ "llvm.expect." ++ renderWithContext (llvmCgContext cfg) (ppr expTy)+      | isInt expTy = fsLit $ "llvm.expect." ++ showSDocOneLine (llvmCgContext cfg) (ppr expTy)       | otherwise   = panic "genExpectedLit: Type not an int!"    (llvmExpect, stmts, top) <-@@ -1316,21 +1348,38 @@   -- | Switch branch-genSwitch :: CmmExpr -> SwitchTargets -> LlvmM StmtData-genSwitch cond ids = do+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 ]-    -- 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)+               | 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 --@@ -1369,7 +1418,7 @@         -> genLit opt lit      CmmLoad e' ty align-        -> genLoad False 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.@@ -1388,8 +1437,7 @@         -> genMachOp opt op exprs      CmmRegOff r i-        -> do platform <- getPlatform-              exprToVar $ expandCmmReg platform (r, i)+        -> exprToVar $ expandCmmReg (r, i)      CmmStackSlot _ _         -> panic "exprToVar: CmmStackSlot not supported!"@@ -1413,8 +1461,8 @@         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_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@@ -1428,6 +1476,9 @@     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@@ -1442,6 +1493,11 @@             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@@ -1452,7 +1508,6 @@     MO_S_MulMayOflo _ -> panicOp     MO_S_Quot _       -> panicOp     MO_S_Rem _        -> panicOp-    MO_U_MulMayOflo _ -> panicOp     MO_U_Quot _       -> panicOp     MO_U_Rem _        -> panicOp @@ -1471,6 +1526,11 @@     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@@ -1492,19 +1552,24 @@     MO_V_Sub      _ _ -> panicOp     MO_V_Mul      _ _ -> panicOp -    MO_VS_Quot    _ _ -> panicOp-    MO_VS_Rem     _ _ -> panicOp+    MO_VS_Min     _ _ -> panicOp+    MO_VS_Max     _ _ -> panicOp -    MO_VU_Quot    _ _ -> panicOp-    MO_VU_Rem     _ _ -> 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@@ -1555,7 +1620,7 @@ -- | 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]+genMachOp_fast :: EOption -> MachOp -> GlobalRegUse -> Int -> [CmmExpr]                -> LlvmM ExprData genMachOp_fast opt op r n e   = do (gv, grt, s1) <- getCmmRegVal (CmmGlobal r)@@ -1634,8 +1699,6 @@     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@@ -1656,6 +1719,8 @@     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@@ -1667,12 +1732,6 @@     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@@ -1682,31 +1741,44 @@     MO_S_Neg _     -> panicOp     MO_F_Neg _     -> panicOp -    MO_SF_Conv _ _ -> panicOp-    MO_FS_Conv _ _ -> 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_V_Insert  {} -> 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 -    MO_AlignmentCheck {} -> 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 -#if __GLASGOW_HASKELL__ < 811-    MO_VF_Extract {} -> panicOp-    MO_V_Extract {} -> panicOp-#endif+    MO_RelaxedRead {} -> panicOp +    MO_AlignmentCheck {} -> panicOp+     where         binLlvmOp ty binOp allow_y_cast = do-          cfg      <- getConfig           platform <- getPlatform           runExprData $ do             vx <- exprToVarW x@@ -1722,13 +1794,7 @@                     doExprW (ty vx) $ binOp vx vy'                 | otherwise-               -> do-                    -- Error. Continue anyway so we can debug the generated ll file.-                    let render   = renderWithContext (llvmCgContext cfg)-                        cmmToStr = (lines . render . PprCmm.pprExpr platform)-                    statement $ Comment $ map fsLit $ cmmToStr x-                    statement $ Comment $ map fsLit $ cmmToStr y-                    doExprW (ty vx) $ binOp vx vy+               -> pprPanic "binLlvmOp types" (pdoc platform x $$ pdoc platform y)          binCastLlvmOp ty binOp = runExprData $ do             vx <- exprToVarW x@@ -1761,6 +1827,19 @@          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.@@ -1793,13 +1872,87 @@                     pprPanic "isSMulOK: Not bit type! " $                         lparen <> ppr word <> rparen -        panicOp = panic $ "LLVM.CodeGen.genMachOp_slow: unary op encountered"+        panicOp = panic $ "LLVM.CodeGen.genMachOp_slow: non-binary op encountered "                        ++ "with two arguments! (" ++ show op ++ ")" --- More than two expression, invalid!-genMachOp_slow _ _ _ = panic "genMachOp: More than 2 expressions in MachOp!"+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 @@ -1832,12 +1985,12 @@ -- | 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+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 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@@ -1882,10 +2035,10 @@                     doExprW (cmmToLlvmType ty) (MExpr meta $ mkLoad atomic ptr align)          other -> pprPanic "exprToVar: CmmLoad expression is not right type!"-                     (PprCmm.pprExpr platform e <+> text (-                         "Size of Ptr: "   ++ show (llvmPtrBits platform) ++-                         ", Size of var: " ++ show (llvmWidthInBits platform other) ++-                         ", Var: " ++ renderWithContext (llvmCgContext cfg) (ppVar cfg iptr)))+                     (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]@@ -1901,7 +2054,8 @@  mkLoad :: Atomic -> LlvmVar -> AlignmentSpec -> LlvmExpression mkLoad atomic vptr alignment-  | atomic      = ALoad SyncSeqCst False vptr+  | Just mem_ord <- atomic+                = ALoad (convertMemoryOrdering mem_ord) False vptr   | otherwise   = Load vptr align   where     ty = pLower (getVarType vptr)@@ -1914,42 +2068,58 @@ -- | 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 :: CmmReg -> LlvmM (LlvmVar, LlvmType) getCmmReg (CmmLocal (LocalReg un _))   = do exists <- varLookup un        case exists of-         Just ety -> return (LMLocalVar un $ pLift ety)+         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 g)-  = do onStack  <- checkStackReg g+getCmmReg (CmmGlobal (GlobalRegUse reg _reg_ty))+  = do onStack  <- checkStackReg reg        platform <- getPlatform-       if onStack-         then return (lmGlobalRegVar platform g)-         else pprPanic "getCmmReg: Cmm register " $-                ppr g <> text " not stack-allocated!"+       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 g -> do+    CmmGlobal gu@(GlobalRegUse g _) -> do       onStack <- checkStackReg g       platform <- getPlatform-      if onStack then loadFromStack else do-        let r = lmGlobalRegArg platform g-        return (r, getVarType r, nilOL)+      case onStack of+        Just {} ->+          loadFromStack+        Nothing -> do+          let r = lmGlobalRegArg platform gu+          return (r, getVarType r, nilOL)     _ -> loadFromStack- where loadFromStack = do-         ptr <- getCmmReg reg-         let ty = pLower $ getVarType ptr-         (v, s) <- doExpr ty (Load ptr Nothing)-         return (v, ty, unitOL s)+ 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)@@ -1975,10 +2145,17 @@         --                 ]     in return (mkIntLit width i, nilOL, []) -genLit _ (CmmFloat r w)-  = return (LMLitVar $ LMFloatLit (fromRational r) (widthToLlvmFloat w),+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, [])@@ -2038,6 +2215,12 @@ -- * 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@@ -2049,8 +2232,9 @@ -- 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 :: LiveGlobalRegUses -> NonEmpty CmmBlock -> LlvmM StmtData funPrologue live cmmBlocks = do+  platform <- getPlatform    let getAssignedRegs :: CmmNode O O -> [CmmReg]       getAssignedRegs (CmmAssign reg _)  = [reg]@@ -2058,7 +2242,8 @@       getAssignedRegs _                  = []       getRegsBlock (_, body, _)          = concatMap getAssignedRegs $ blockToList body       assignedRegs = nub $ concatMap (getRegsBlock . blockSplit) cmmBlocks-      isLive r     = r `elem` alwaysLive || r `elem` live+      mbLive r     =+        lookupRegUse r (alwaysLive platform) <|> lookupRegUse r live    platform <- getPlatform   stmtss <- forM assignedRegs $ \reg ->@@ -2067,24 +2252,38 @@         let (newv, stmts) = allocReg reg         varInsert un (pLower $ getVarType newv)         return stmts-      CmmGlobal r -> do-        let reg   = lmGlobalRegVar platform r-            arg   = lmGlobalRegArg platform r+      CmmGlobal ru@(GlobalRegUse r ty0) -> do+        let reg   = lmGlobalRegVar platform ru             ty    = (pLower . getVarType) reg             trash = LMLitVar $ LMUndefLit ty-            rval  = if isLive r then arg else trash+            rval  = case mbLive r of+              Just (GlobalRegUse _ ty') ->+                lmGlobalRegArg platform (GlobalRegUse r ty')+              _ -> trash             alloc = Assignment reg $ Alloca (pLower $ getVarType reg) 1-        markStackReg r-        return $ toOL [alloc, Store rval reg Nothing]+        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+    entryBlk :| _ = cmmBlocks     jumpToEntry = Branch $ blockIdToLlvm (entryLabel entryBlk)  -- | Function epilogue. Load STG variables to use as argument for call. -- STG Liveness optimisation done here.-funEpilogue :: LiveGlobalRegs -> LlvmM ([LlvmVar], LlvmStatements)+funEpilogue :: LiveGlobalRegUses -> LlvmM ([LlvmVar], LlvmStatements) funEpilogue live = do     platform <- getPlatform @@ -2110,12 +2309,16 @@     let allRegs = activeStgRegs platform     loads <- forM allRegs $ \r -> if       -- load live registers-      | r `elem` alwaysLive  -> loadExpr r-      | r `elem` live        -> loadExpr r+      | 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 r+      | not (isFPR r)+      -> loadUndef (GlobalRegUse r (globalRegSpillType platform r))       -- load padding Floating-Point Registers-      | r `elem` paddingRegs -> loadUndef r+      | Just ru <- lookupRegUse r paddingRegs+      -> loadUndef ru       | otherwise            -> return (Nothing, nilOL)      let (vars, stmts) = unzip loads@@ -2125,7 +2328,7 @@ -- -- This is for Haskell functions, function type is assumed, so doesn't work -- with foreign functions.-getHsFunc :: LiveGlobalRegs -> CLabel -> LlvmM ExprData+getHsFunc :: LiveGlobalRegUses -> CLabel -> LlvmM ExprData getHsFunc live lbl   = do fty <- llvmFunTy live        name <- strCLabel_llvm lbl@@ -2155,9 +2358,9 @@   -- | Expand CmmRegOff-expandCmmReg :: Platform -> (CmmReg, Int) -> CmmExpr-expandCmmReg platform (reg, off)-  = let width = typeWidth (cmmRegType platform reg)+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] @@ -2188,9 +2391,8 @@  -- | 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]+getTBAAMeta u =+    List.singleton . MetaAnnot tbaa . MetaNode . expectJust <$> getUniqMeta u  -- | Returns TBAA meta data for given register getTBAARegMeta :: GlobalReg -> LlvmM [MetaAnnot]@@ -2236,7 +2438,7 @@     LlvmAccum stmts decls <- execWriterT action     return (stmts, decls) -getCmmRegW :: CmmReg -> WriterT LlvmAccum LlvmM LlvmVar+getCmmRegW :: CmmReg -> WriterT LlvmAccum LlvmM (LlvmVar, LlvmType) getCmmRegW = lift . getCmmReg  genLoadW :: Atomic -> CmmExpr -> CmmType -> AlignmentSpec -> WriterT LlvmAccum LlvmM LlvmVar
GHC/CmmToLlvm/Config.hs view
@@ -1,7 +1,9 @@ -- | Llvm code generator configuration module GHC.CmmToLlvm.Config   ( LlvmCgConfig(..)-  , LlvmVersion(..)+  , LlvmConfig(..)+  , LlvmTarget(..)+  , initLlvmConfig   ) where @@ -9,23 +11,72 @@ import GHC.Platform  import GHC.Utils.Outputable-import GHC.Driver.Session--import qualified Data.List.NonEmpty as NE+import GHC.Settings.Utils+import GHC.Utils.Panic+import GHC.CmmToLlvm.Version.Type (LlvmVersion) -newtype LlvmVersion = LlvmVersion { llvmVersionNE :: NE.NonEmpty Int }-  deriving (Eq, Ord)+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   -- ^ mirror DynFlags LlvmConfig.-    -- see Note [LLVM configuration] in "GHC.SysTools". This can be strict since-    -- GHC.Driver.Config.CmmToLlvm.initLlvmCgConfig verifies the files are present.+  , llvmCgLlvmConfig        :: !LlvmConfig   -- ^ Supported LLVM configurations.+                                             -- see Note [LLVM configuration]+  }++data LlvmTarget = LlvmTarget+  { lDataLayout :: String+  , lCPU        :: String+  , lAttributes :: [String]+  }++-- Note [LLVM configuration]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~+-- The `llvm-targets` and `llvm-passes` files are shipped with GHC and contain+-- information needed by the LLVM backend to invoke `llc` and `opt`.+-- Specifically:+--+--  * llvm-targets maps autoconf host triples to the corresponding LLVM+--    `data-layout` declarations. This information is extracted from clang using+--    the script in utils/llvm-targets/gen-data-layout.sh and should be updated+--    whenever we target a new version of LLVM.+--+--  * llvm-passes maps GHC optimization levels to sets of LLVM optimization+--    flags that GHC should pass to `opt`.+--+-- This information is contained in files rather the GHC source to allow users+-- to add new targets to GHC without having to recompile the compiler.+--++initLlvmConfig :: FilePath -> IO LlvmConfig+initLlvmConfig top_dir+  = do+      targets <- readAndParse "llvm-targets"+      passes <- readAndParse "llvm-passes"+      return $ LlvmConfig+        { llvmTargets = fmap mkLlvmTarget <$> targets+        , llvmPasses = passes+        }+  where+    readAndParse :: Read a => String -> IO a+    readAndParse name = do+      let f = top_dir </> name+      llvmConfigStr <- readFile f+      case maybeReadFuzzy llvmConfigStr of+        Just s -> return s+        Nothing -> pgmError ("Can't parse LLVM config file: " ++ show f)++    mkLlvmTarget :: (String, String, String) -> LlvmTarget+    mkLlvmTarget (dl, cpu, attrs) = LlvmTarget dl cpu (words attrs)++data LlvmConfig = LlvmConfig+  { llvmTargets :: [(String, LlvmTarget)]+  , llvmPasses  :: [(Int, String)]   }
GHC/CmmToLlvm/Data.hs view
@@ -10,6 +10,7 @@ import GHC.Prelude  import GHC.Llvm+import GHC.Llvm.Types (widenFp) import GHC.CmmToLlvm.Base import GHC.CmmToLlvm.Config @@ -89,6 +90,7 @@         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@@ -123,7 +125,7 @@             prio = LMStaticLit $ LMIntLit 0xffff i32         in LMStaticStrucU [prio, fn, null] entry_ty -    arr_var = LMGlobalVar var_nm arr_ty Internal Nothing Nothing Global+    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@@ -138,9 +140,6 @@     RelocatableReadOnlyData -> case platformOS p of                                  OSMinGW32 -> fsLit ".rdata$rel.ro"                                  _         -> fsLit ".data.rel.ro"-    ReadOnlyData16          -> case platformOS p of-                                 OSMinGW32 -> fsLit ".rdata$cst16"-                                 _         -> fsLit ".rodata.cst16"     Data                    -> fsLit ".data"     UninitialisedData       -> fsLit ".bss"     CString                 -> case platformOS p of@@ -195,8 +194,14 @@ genStaticLit (CmmInt i w)     = return $ LMStaticLit (LMIntLit i (LMInt $ widthInBits w)) -genStaticLit (CmmFloat r w)-    = return $ LMStaticLit (LMFloatLit (fromRational r) (widthToLlvmFloat 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
GHC/CmmToLlvm/Mangler.hs view
@@ -38,7 +38,7 @@  -- | These are the rewrites that the mangler will perform rewrites :: [Rewrite]-rewrites = [rewriteSymType, rewriteAVX, rewriteCall]+rewrites = [rewriteSymType, rewriteAVX, rewriteCall, rewriteJump]  type Rewrite = Platform -> B.ByteString -> Maybe B.ByteString @@ -121,6 +121,29 @@         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
GHC/CmmToLlvm/Ppr.hs view
@@ -26,22 +26,28 @@ --  -- | Pretty print LLVM data code-pprLlvmData :: LlvmCgConfig -> LlvmData -> SDoc+pprLlvmData :: IsDoc doc => LlvmCgConfig -> LlvmData -> doc pprLlvmData cfg (globals, types) =-    let ppLlvmTys (LMAlias    a) = ppLlvmAlias a+    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'+    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-pprLlvmCmmDecl :: LlvmCmmDecl -> LlvmM (SDoc, [LlvmVar])+-- 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, [])+  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@@ -56,7 +62,7 @@        funDec   <- llvmFunSig live lbl link        cfg      <- getConfig        platform <- getPlatform-       let buildArg = fsLit . renderWithContext (llvmCgContext cfg). ppPlainName cfg+       let buildArg = fsLit . showSDocOneLine (llvmCgContext cfg). ppPlainName cfg            funArgs = map buildArg (llvmFunArgs platform live)            funSect = llvmFunSection cfg (decName funDec) @@ -92,7 +98,8 @@                             (Just $ LMBitc (LMStaticPointer defVar)                                            i8Ptr) -       return (ppLlvmGlobal cfg alias $+$ ppLlvmFunction cfg fun', [])+       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
GHC/CmmToLlvm/Regs.hs view
@@ -14,39 +14,41 @@ 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 -> GlobalReg -> LlvmVar+lmGlobalRegVar :: Platform -> GlobalRegUse -> LlvmVar lmGlobalRegVar platform = pVarLift . lmGlobalReg platform "_Var"  -- | Get the LlvmVar function argument storing the real register-lmGlobalRegArg :: Platform -> GlobalReg -> LlvmVar+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 -> GlobalReg -> LlvmVar-lmGlobalReg platform suf reg+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+        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@@ -88,13 +90,26 @@         ptrGlobal    name = LMNLocalVar (fsLit name) (llvmWordPtr platform)         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))+        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 :: [GlobalReg]-alwaysLive = [BaseReg, Sp, Hp, SpLim, HpLim, node]+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)]@@ -129,8 +144,8 @@  -- | 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+getTBAA BaseReg        = baseN+getTBAA Sp             = stackN+getTBAA Hp             = heapN+getTBAA (VanillaReg _) = rxN+getTBAA _              = topN
+ GHC/CmmToLlvm/Version.hs view
@@ -0,0 +1,43 @@+module GHC.CmmToLlvm.Version+  ( LlvmVersion(..)+  , supportedLlvmVersionLowerBound+  , supportedLlvmVersionUpperBound+  , parseLlvmVersion+  , llvmVersionSupported+  , llvmVersionStr+  , llvmVersionList+  )+where++import GHC.Prelude++import GHC.CmmToLlvm.Version.Type+import GHC.CmmToLlvm.Version.Bounds++import Data.Char (isDigit)+import Data.List (intercalate)+import qualified Data.List.NonEmpty as NE++parseLlvmVersion :: String -> Maybe LlvmVersion+parseLlvmVersion =+    fmap LlvmVersion . NE.nonEmpty . go [] . dropWhile (not . isDigit)+  where+    go vs s+      | null ver_str+      = reverse vs+      | '.' : rest' <- rest+      = go (read ver_str : vs) rest'+      | otherwise+      = reverse (read ver_str : vs)+      where+        (ver_str, rest) = span isDigit s++llvmVersionSupported :: LlvmVersion -> Bool+llvmVersionSupported v =+  v >= supportedLlvmVersionLowerBound && v < supportedLlvmVersionUpperBound++llvmVersionStr :: LlvmVersion -> String+llvmVersionStr = intercalate "." . map show . llvmVersionList++llvmVersionList :: LlvmVersion -> [Int]+llvmVersionList = NE.toList . llvmVersionNE
+ GHC/CmmToLlvm/Version/Bounds.hs view
@@ -0,0 +1,19 @@+module GHC.CmmToLlvm.Version.Bounds+  ( supportedLlvmVersionLowerBound+  , supportedLlvmVersionUpperBound+  )+where++import GHC.Prelude ()++import GHC.CmmToLlvm.Version.Type++import qualified Data.List.NonEmpty as NE++-- | The (inclusive) lower bound on the LLVM Version that is currently supported.+supportedLlvmVersionLowerBound :: LlvmVersion+supportedLlvmVersionLowerBound = LlvmVersion (13 NE.:| [])++-- | The (not-inclusive) upper bound  bound on the LLVM Version that is currently supported.+supportedLlvmVersionUpperBound :: LlvmVersion+supportedLlvmVersionUpperBound = LlvmVersion (21 NE.:| [])
+ GHC/CmmToLlvm/Version/Type.hs view
@@ -0,0 +1,11 @@+module GHC.CmmToLlvm.Version.Type+  ( LlvmVersion(..)+  )+where++import GHC.Prelude++import qualified Data.List.NonEmpty as NE++newtype LlvmVersion = LlvmVersion { llvmVersionNE :: NE.NonEmpty Int }+  deriving (Eq, Ord)
GHC/Core.hs view
@@ -3,12 +3,7 @@ (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -} -{-# LANGUAGE DeriveDataTypeable, FlexibleContexts #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE BangPatterns #-}--{-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}-{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}+{-# LANGUAGE NoPolyKinds #-}  -- | GHC.Core holds all the main data types for use by for the Glasgow Haskell Compiler midsection module GHC.Core (@@ -19,9 +14,10 @@          -- * In/Out type synonyms         InId, InBind, InExpr, InAlt, InArg, InType, InKind,-               InBndr, InVar, InCoercion, InTyVar, InCoVar,+               InBndr, InVar, InCoercion, InTyVar, InCoVar, InTyCoVar,         OutId, OutBind, OutExpr, OutAlt, OutArg, OutType, OutKind,-               OutBndr, OutVar, OutCoercion, OutTyVar, OutCoVar, MOutCoercion,+               OutBndr, OutVar, OutCoercion, OutTyVar, OutCoVar,+               OutTyCoVar, MOutCoercion,          -- ** 'Expr' construction         mkLet, mkLets, mkLetNonRec, mkLetRec, mkLams,@@ -30,7 +26,7 @@         mkIntLit, mkIntLitWrap,         mkWordLit, mkWordLitWrap,         mkWord8Lit,-        mkWord64LitWord64, mkInt64LitInt64,+        mkWord32LitWord32, mkWord64LitWord64, mkInt64LitInt64,         mkCharLit, mkStringLit,         mkFloatLit, mkFloatLitFloat,         mkDoubleLit, mkDoubleLitDouble,@@ -38,13 +34,17 @@         mkConApp, mkConApp2, mkTyBind, mkCoBind,         varToCoreExpr, varsToCoreExprs, +        mkBinds,+         isId, cmpAltCon, cmpAlt, ltAlt,          -- ** Simple 'Expr' access functions and predicates-        bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts,+        bindersOf, bindersOfBinds, rhssOfBind, rhssOfBinds, rhssOfAlts,+        foldBindersOfBindStrict, foldBindersOfBindsStrict,         collectBinders, collectTyBinders, collectTyAndValBinders,-        collectNBinders,-        collectArgs, stripNArgs, collectArgsTicks, flattenBinds,+        collectNBinders, collectNValBinders_maybe,+        collectArgs, collectValArgs, stripNArgs, collectArgsTicks, flattenBinds,+        collectFunSimple,          exprToType,         wrapLamBody,@@ -53,18 +53,19 @@         isRuntimeArg, isRuntimeVar,          -- * Unfolding data types-        Unfolding(..),  UnfoldingGuidance(..), UnfoldingSource(..),+        Unfolding(..),  UnfoldingCache(..), UnfoldingGuidance(..), UnfoldingSource(..),          -- ** Constructing 'Unfolding's         noUnfolding, bootUnfolding, evaldUnfolding, mkOtherCon,         unSaturatedOk, needSaturated, boringCxtOk, boringCxtNotOk,          -- ** Predicates and deconstruction on 'Unfolding'-        unfoldingTemplate, expandUnfolding_maybe,+        expandUnfolding_maybe,         maybeUnfoldingTemplate, otherCons,         isValueUnfolding, isEvaldUnfolding, isCheapUnfolding,         isExpandableUnfolding, isConLikeUnfolding, isCompulsoryUnfolding,-        isStableUnfolding, isInlineUnfolding, isBootUnfolding,+        isStableUnfolding, isStableUserUnfolding, isStableSystemUnfolding,+        isInlineUnfolding, isBootUnfolding, isBetterUnfoldingThan,         hasCoreUnfolding, hasSomeUnfolding,         canUnfold, neverUnfoldGuidance, isStableSource, @@ -82,9 +83,8 @@         IsOrphan(..), isOrphan, notOrphan, chooseOrphanAnchor,          -- * Core rule data types-        CoreRule(..), RuleBase,-        RuleName, RuleFun, IdUnfoldingFun, InScopeEnv,-        RuleEnv(..), RuleOpts(..), mkRuleEnv, emptyRuleEnv,+        CoreRule(..),+        RuleName, RuleFun, IdUnfoldingFun, InScopeEnv(..), RuleOpts,          -- ** Operations on 'CoreRule's         ruleArity, ruleName, ruleIdName, ruleActivation,@@ -99,9 +99,9 @@ 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.Name.Env( NameEnv ) import GHC.Types.Literal import GHC.Types.Tickish import GHC.Core.DataCon@@ -113,12 +113,15 @@ import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Utils.Panic.Plain  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) @@ -156,7 +159,7 @@ --      f_1 x_2 = let f_3 x_4 = x_4 + 1 --                in f_3 (x_2 - 2) -- @---    But see Note [Shadowing] below.+--    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.@@ -175,7 +178,6 @@ -- *  Primitive literals -- -- *  Applications: note that the argument may be a 'Type'.---    See Note [Core let/app invariant] --    See Note [Representation polymorphism invariants] -- -- *  Lambda abstraction@@ -186,7 +188,7 @@ --    bound and then executing the sub-expression. -- --    See Note [Core letrec invariant]---    See Note [Core let/app invariant]+--    See Note [Core let-can-float invariant] --    See Note [Representation polymorphism invariants] --    See Note [Core type and coercion invariant] --@@ -294,7 +296,7 @@ -- 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 [Core case invariants]+-- 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) $@@ -314,27 +316,18 @@             | 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 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.+-- | 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.@@ -366,20 +359,124 @@ 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 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/).+The Core letrec invariant: -There is one exception to this rule, top-level @let@s are-allowed to bind primitive string literals: see-Note [Core top-level string literals].+  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#) of type Addr# at the+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,@@ -414,6 +511,8 @@   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. @@ -421,36 +520,45 @@   in the object file, the content of the exported literal is given a label with   the _bytes suffix. -Note [Core 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.+Note [NON-BOTTOM-DICTS invariant]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It is a global invariant (not checkable by Lint) that -This means that the let can be floated around-without difficulty. For example, this is OK:+     every non-newtype dictionary-typed expression is non-bottom. -   y::Int# = x +# 1#+These conditions are captured by GHC.Core.Type.isTerminatingType. -But this is not, as it may affect termination if the-expression is floated out:+How are we so sure about this?  Dictionaries are built by GHC in only two ways: -   y::Int# = fac 4#+* 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. -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+  Exception: newtype dictionaries. -The let/app invariant is initially enforced by mkCoreLet and mkCoreApp in-GHC.Core.Make.+  Plus: see the Very Nasty Wrinkle in Note [Speculative evaluation]+  in GHC.CoreToStg.Prep -For discussion of some implications of the let/app invariant primops see-Note [Checking versus non-checking primops] in GHC.Builtin.PrimOps.+* 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@@ -539,18 +647,14 @@       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.Canonical--Note [Core case invariants]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-See Note [Case expression invariants]+  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 -> b+  ($) :: 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@@ -565,13 +669,6 @@       (except for join points: See Note [Invariants on join points])   I2. The type of a function argument must have a fixed runtime representation. -On top of these two invariants, GHC's internal eta-expansion mechanism also requires:--  I3. In any partial application `f e_1 .. e_n`, where `f` is `hasNoBinding`,-      it must be the case that the application can be eta-expanded to match-      the arity of `f`.-      See Note [checkCanEtaExpand] in GHC.Core.Lint for more details.- Example of I1:    \(r::RuntimeRep). \(a::TYPE r). \(x::a). e@@ -586,38 +683,32 @@     This contravenes I2: we are applying the function `f` to a value     with an unknown runtime representation. -Examples of I3:+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 -  myUnsafeCoerce# :: forall {r1} (a :: TYPE r1) {r2} (b :: TYPE r2). a -> b-  myUnsafeCoerce# = unsafeCoerce#+  myCoerce :: forall {r} (a :: TYPE r) (b :: TYPE r). Coercible a b => a -> b+  myCoerce = coerce -    This contravenes I3: we are instantiating `unsafeCoerce#` without any-    value arguments, and with a remaining argument type, `a`, which does not-    have a fixed runtime representation.-    But `unsafeCorce#` has no binding (see Note [Wiring in unsafeCoerce#]-    in GHC.HsToCore).  So before code-generation we must saturate it-    by eta-expansion (see GHC.CoreToStg.Prep.maybeSaturate), thus-       myUnsafeCoerce# = \x. unsafeCoerce# x-    But we can't do that because now the \x binding would violate I1.+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): -  bar :: forall (a :: TYPE) r (b :: TYPE r). a -> b-  bar = unsafeCoerce#+  myCoerce = \ (x :: TYPE r) -> coerce x -    OK: eta expand to `\ (x :: Type) -> unsafeCoerce# x`,-    and `x` has a fixed RuntimeRep.+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 [Core 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 [Empty case alternatives] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The alternatives of a case expression should be exhaustive.  But@@ -662,10 +753,14 @@   its scrutinee is (see GHC.Core.Utils.exprIsTrivial).  This is actually   important; see Note [Empty case is trivial] in GHC.Core.Utils -* 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.+* 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@@ -728,17 +823,18 @@          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 is the number of value-         binders in the top n lambdas, where n is the join arity.+     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. -         So arity <= join arity; the former counts only value binders-         while the latter counts all binders.-         e.g. Suppose $j has join arity 1-               let j = \x y. e in case x of { A -> j 1; B -> j 2 }-         Then its ordinary arity is also 1, not 2.+         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] -         The arity of a join point isn't very important; but short of setting-         it to zero, it is helpful to have an invariant.  E.g. #17294.+         Historical note: see #17294.    3. If the binding is recursive, then all other bindings in the recursive group      must also be join points.@@ -749,11 +845,11 @@ 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)+     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 void# in ...+     e.g.  let j :: r :: TYPE l = fail (##) in ...      This happened in an intermediate program #13394  Examples:@@ -938,6 +1034,73 @@ 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@@ -1006,11 +1169,9 @@ -- -- 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+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@@ -1026,6 +1187,10 @@                 n <- get bh                 return $ NotOrphan n +instance NFData IsOrphan where+  rnf IsOrphan = ()+  rnf (NotOrphan n) = rnf n+ {- Note [Orphans] ~~~~~~~~~~~~~~@@ -1041,6 +1206,12 @@    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@@ -1055,12 +1226,20 @@  Orphan-hood is computed   * For class instances:-      when we make a ClsInst-    (because it is needed during instance lookup)+    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 and family instances:-       when we generate an IfaceRule (GHC.Iface.Make.coreRuleToIfaceRule)-                     or IfaceFamInst (GHC.Iface.Make.instanceToIfaceInst)+  * 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.+ -}  {-@@ -1075,50 +1254,7 @@ 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] -- See Note [Why re_base is a list]-              , re_visible_orphs :: ModuleSet-              }--mkRuleEnv :: RuleBase -> [Module] -> RuleEnv-mkRuleEnv rules vis_orphs = RuleEnv [rules] (mkModuleSet vis_orphs)--emptyRuleEnv :: RuleEnv-emptyRuleEnv = RuleEnv [] emptyModuleSet--{--Note [Why re_base is a list]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~--In Note [Overall plumbing for rules], it is explained that the final-RuleBase which we must consider is combined from 4 different sources.--During simplifier runs, the fourth source of rules is constantly being updated-as new interfaces are loaded into the EPS. Therefore just before we check to see-if any rules match we get the EPS RuleBase and combine it with the existing RuleBase-and then perform exactly 1 lookup into the new map.--It is more efficient to avoid combining the environments and store the uncombined-environments as we can instead perform 1 lookup into each environment and then combine-the results.--Essentially we use the identity:--> lookupNameEnv n (plusNameEnv_C (++) rb1 rb2)->   = lookupNameEnv n rb1 ++ lookupNameEnv n rb2--The latter being more efficient as we don't construct an intermediate-map.--}- -- | A 'CoreRule' is: -- -- * \"Local\" if the function it is a rule for is defined in the@@ -1133,7 +1269,7 @@          -- 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_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@@ -1184,18 +1320,11 @@     }                 -- See Note [Extra args in the target] in GHC.Core.Rules --- | Rule options-data RuleOpts = RuleOpts-   { roPlatform                :: !Platform -- ^ Target platform-   , roNumConstantFolding      :: !Bool     -- ^ Enable more advanced numeric constant folding-   , roExcessRationalPrecision :: !Bool     -- ^ Cut down precision of Rational values to that of Float/Double if disabled-   , roBignumRules             :: !Bool     -- ^ Enable rules for bignums-   }+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].-type RuleFun = RuleOpts -> InScopeEnv -> Id -> [CoreExpr] -> Maybe CoreExpr-type InScopeEnv = (InScopeSet, IdUnfoldingFun)+data InScopeEnv = ISE InScopeSet IdUnfoldingFun  type IdUnfoldingFun = Id -> Unfolding -- A function that embodies how to unfold an Id if you need@@ -1212,7 +1341,7 @@  -- | The number of arguments the 'ru_fn' must be applied -- to before the rule can match on it-ruleArity :: CoreRule -> Int+ruleArity :: CoreRule -> FullArgCount ruleArity (BuiltinRule {ru_nargs = n}) = n ruleArity (Rule {ru_args = args})      = length args @@ -1232,7 +1361,8 @@ ruleIdName = ru_fn  isLocalRule :: CoreRule -> Bool-isLocalRule = ru_local+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@@ -1291,23 +1421,19 @@         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.+  | 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:   --@@ -1326,36 +1452,21 @@   --  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 "GHC.Types.Id.Make", calls to mkCompulsoryUnfolding).-                       -- Inline absolutely always, however boring the context.--+-- | 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@@ -1386,7 +1497,23 @@   | 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@@ -1461,18 +1588,8 @@ 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+-- 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@@ -1493,44 +1610,47 @@ -- 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+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 (CoreUnfolding { uf_is_value = is_evald }) = is_evald-isEvaldUnfolding _                                          = False+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 (OtherCon _)                             = True-isConLikeUnfolding (CoreUnfolding { uf_is_conlike = con })  = con-isConLikeUnfolding _                                        = False+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_is_work_free = is_wf }) = is_wf-isCheapUnfolding _                                           = False+isCheapUnfolding (CoreUnfolding { uf_cache = cache }) = uf_is_work_free cache+isCheapUnfolding _                                    = False  isExpandableUnfolding :: Unfolding -> Bool-isExpandableUnfolding (CoreUnfolding { uf_expandable = is_expable }) = is_expable-isExpandableUnfolding _                                              = False+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_expandable = True, uf_tmpl = rhs }) = Just rhs-expandUnfolding_maybe _                                                       = Nothing+expandUnfolding_maybe (CoreUnfolding { uf_cache = cache, uf_tmpl = rhs })+  | uf_expandable cache+    = Just rhs+expandUnfolding_maybe _ = Nothing  isCompulsoryUnfolding :: Unfolding -> Bool-isCompulsoryUnfolding (CoreUnfolding { uf_src = InlineCompulsory }) = True-isCompulsoryUnfolding _                                             = False+isCompulsoryUnfolding (CoreUnfolding { uf_src = src }) = isCompulsorySource src+isCompulsoryUnfolding _                                = False  isStableUnfolding :: Unfolding -> Bool -- True of unfoldings that should not be overwritten@@ -1539,6 +1659,16 @@ 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@@ -1581,6 +1711,33 @@ 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@@ -1595,8 +1752,22 @@  We consider even a StableUnfolding as fragile, because it needs substitution. -Note [InlineStable]-~~~~~~~~~~~~~~~~~+Note [Better unfolding]+~~~~~~~~~~~~~~~~~~~~~~~+(unf1 `isBetterUnfoldingThan` unf2) is used when we have+    let x = <rhs> in   -- unf2+    let $j y = ...x...+    in case x of+          K a -> ...$j v....++At the /call site/ of $j, `x` has a better unfolding than it does at the+/defnition site/ of $j; so we are keener to inline $j.  See+Note [Inlining join points] in GHC.Core.Opt.Simplify.Inline for discussion.++The notion of "better" is encapsulated here.++Note [Stable unfoldings]+~~~~~~~~~~~~~~~~~~~~~~~~ When you say       {-# INLINE f #-}       f x = <rhs>@@ -1606,10 +1777,11 @@ 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.+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 an InlineRule, which captures the original RHS.+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@@ -1623,21 +1795,41 @@ 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 GHC.Core.Unfold.-- 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 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+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@@ -1820,6 +2012,9 @@ 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)) @@ -1857,8 +2052,8 @@ 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/app invariant.  Prefer to use 'GHC.Core.Make.mkCoreLets' if--- possible, which does guarantee the invariant+-- 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@@ -1940,10 +2135,30 @@ 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] @@ -1961,10 +2176,12 @@ 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) +-- | 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@@ -1996,6 +2213,18 @@     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])@@ -2005,6 +2234,30 @@     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@@ -2023,7 +2276,7 @@ stripNArgs n (App f _) = stripNArgs (n - 1) f stripNArgs _ _ = Nothing --- | Like @collectArgs@, but also collects looks through floatable+-- | 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])
+ GHC/Core.hs-boot view
@@ -0,0 +1,9 @@+{-# LANGUAGE NoPolyKinds #-}+module GHC.Core where+import {-# SOURCE #-} GHC.Types.Var++data Expr a++type CoreBndr = Var++type CoreExpr = Expr CoreBndr
GHC/Core/Class.hs view
@@ -8,7 +8,7 @@ module GHC.Core.Class (         Class,         ClassOpItem,-        ClassATItem(..), ATValidityInfo(..),+        ClassATItem(..), TyFamEqnValidityInfo(..),         ClassMinimalDef,         DefMethInfo, pprDefMethInfo, @@ -17,8 +17,13 @@         mkClass, mkAbstractClass, classTyVars, classArity,         classKey, className, classATs, classATItems, classTyCon, classMethods,         classOpItems, classBigSig, classExtraBigSig, classTvsFds, classSCTheta,-        classAllSelIds, classSCSelId, classSCSelIds, classMinimalDef, classHasFds,-        isAbstractClass,+        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@@ -26,16 +31,17 @@ 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.Utils.Panic.Plain import GHC.Types.SrcLoc+import GHC.Types.Var.Set import GHC.Utils.Outputable-import GHC.Data.BooleanFormula (BooleanFormula, mkTrue)+import Language.Haskell.Syntax.BooleanFormula ( BooleanFormula, mkTrue )  import qualified Data.Data as Data @@ -76,10 +82,6 @@ -- >  class C a b c | a b -> c, a c -> b where... -- --  Here fun-deps are [([a,b],[c]), ([a,c],[b])]------  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnRarrow'',---- For details on above see Note [exact print annotations] in GHC.Parser.Annotation type FunDep a = ([a],[a])  type ClassOpItem = (Id, DefMethInfo)@@ -96,22 +98,46 @@  data ClassATItem   = ATI TyCon         -- See Note [Associated type tyvar names]-        (Maybe (Type, ATValidityInfo))-                      -- Default associated type (if any) from this template-                      -- Note [Associated type defaults]+        (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 an associated type family default implementation. This--- is used solely for validity checking.+-- | 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 ATValidityInfo-  = NoATVI               -- Used for associated type families that are imported-                         -- from another module, for which we don't need to-                         -- perform any validity checking.+data TyFamEqnValidityInfo+  -- | Used for equations which don't need any validity checking,+  -- for example equations imported from another module.+  = NoVI -  | ATVI SrcSpan [Type]  -- Used for locally defined associated type families.-                         -- The [Type] are the LHS patterns.+  -- | 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 Name -- Required methods+type ClassMinimalDef = BooleanFormula GhcRn -- Required methods  data ClassBody   = AbstractClass@@ -166,10 +192,15 @@  * 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 +        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.@@ -294,6 +325,9 @@ 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)
GHC/Core/Coercion.hs view
@@ -1,2757 +1,2807 @@-{-# 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,-        UnivCoProvenance, CoercionHole(..),-        coHoleCoVar, setCoHoleCoVar,-        LeftOrRight(..),-        Var, CoVar, TyCoVar,-        Role(..), ltRole,--        -- ** Functions over coercions-        coVarRType, coVarLType, coVarTypes,-        coVarKind, coVarKindsTypesRole, coVarRole,-        coercionType, mkCoercionType,-        coercionKind, coercionLKind, coercionRKind,coercionKinds,-        coercionRole, coercionKindRole,--        -- ** Constructing coercions-        mkGReflCo, mkReflCo, mkRepReflCo, mkNomReflCo,-        mkCoVarCo, mkCoVarCos,-        mkAxInstCo, mkUnbranchedAxInstCo,-        mkAxInstRHS, mkUnbranchedAxInstRHS,-        mkAxInstLHS, mkUnbranchedAxInstLHS,-        mkPiCo, mkPiCos, mkCoCast,-        mkSymCo, mkTransCo,-        mkNthCo, mkNthCoFunCo, nthCoRole, mkLRCo,-        mkInstCo, mkAppCo, mkAppCos, mkTyConAppCo, mkFunCo, mkFunResCo,-        mkForAllCo, mkForAllCos, mkHomoForAllCos,-        mkPhantomCo,-        mkHoleCo, mkUnivCo, mkSubCo,-        mkAxiomInstCo, mkProofIrrelCo,-        downgradeRole, mkAxiomRuleCo,-        mkGReflRightCo, mkGReflLeftCo, mkCoherenceLeftCo, mkCoherenceRightCo,-        mkKindCo,-        castCoercionKind, castCoercionKind1, castCoercionKind2,-        mkFamilyTyConAppCo,--        mkHeteroCoercionType,-        mkPrimEqPred, mkReprPrimEqPred, mkPrimEqPredRole,-        mkHeteroPrimEqPred, mkHeteroReprPrimEqPred,--        -- ** Decomposition-        instNewTyCon_maybe,--        NormaliseStepper, NormaliseStepResult(..), composeSteppers,-        mapStepResult, unwrapNewTypeStepper,-        topNormaliseNewType_maybe, topNormaliseTypeX,--        decomposeCo, decomposeFunCo, decomposePiCos, getCoVar_maybe,-        splitTyConAppCo_maybe,-        splitAppCo_maybe,-        splitFunCo_maybe,-        splitForAllCo_maybe,-        splitForAllCo_ty_maybe, splitForAllCo_co_maybe,--        nthRole, tyConRolesX, tyConRolesRepresentational, setNominalRole_maybe,--        pickLR,--        isGReflCo, isReflCo, isReflCo_maybe, isGReflCo_maybe, isReflexiveCo, isReflexiveCo_maybe,-        isReflCoVar_maybe, isGReflMCo, mkGReflLeftMCo, mkGReflRightMCo,-        mkCoherenceRightMCo,--        coToMCo, mkTransMCo, mkTransMCoL, mkTransMCoR, mkCastTyMCo, mkSymMCo,-        mkHomoForAllMCo, mkFunResMCo, mkPiMCos,-        isReflMCo, checkReflexiveMCo,--        -- ** Coercion variables-        mkCoVar, isCoVar, coVarName, setCoVarName, setCoVarUnique,-        isCoVar_maybe,--        -- ** 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,--        mkSubstLiftingContext, zapLiftingContext,-        substForAllCoBndrUsingLC, lcTCvSubst, 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,--        hasCoercionHoleTy, hasCoercionHoleCo, hasThisCoercionHoleTy,--        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.Type-import GHC.Core.TyCon-import GHC.Core.TyCon.RecWalk-import GHC.Core.Coercion.Axiom-import {-# SOURCE #-} GHC.Core.Utils ( mkFunctionType )-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.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.Utils.Misc-import GHC.Utils.Outputable-import GHC.Utils.Panic-import GHC.Utils.Panic.Plain--import Control.Monad (foldM, zipWithM)-import Data.Function ( on )-import Data.Char( isDigit )-import qualified Data.Monoid as Monoid--{--%************************************************************************-%*                                                                      *-     -- 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 <+> dcolon)-       2 (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 (mkTyCoVarBinders Inferred bndrs')-         -- See Note [Printing foralls in type family instances] in GHC.Iface.Type-    , pp_lhs <+> ppr_rhs tidy_env ee_rhs-    , text "-- Defined" <+> pp_loc ]-  where-    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) (mkTyVarOcc "_")-                    -- 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 dicussion 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    = GRefl r ty mco---- | 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--mkHomoForAllMCo :: TyCoVar -> MCoercion -> MCoercion-mkHomoForAllMCo _   MRefl    = MRefl-mkHomoForAllMCo tcv (MCo co) = MCo (mkHomoForAllCos [tcv] co)--mkPiMCos :: [Var] -> MCoercion -> MCoercion-mkPiMCos _ MRefl = MRefl-mkPiMCos vs (MCo co) = MCo (mkPiCos Representational vs co)--mkFunResMCo :: Scaled Type -> MCoercionR -> MCoercionR-mkFunResMCo _      MRefl    = MRefl-mkFunResMCo arg_ty (MCo co) = MCo (mkFunResCo Representational arg_ty 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-%*                                                                      *-%************************************************************************--Note [Function coercions]-~~~~~~~~~~~~~~~~~~~~~~~~~-Remember that-  (->) :: forall {r1} {r2}. TYPE r1 -> TYPE r2 -> TYPE LiftedRep-whose `RuntimeRep' arguments are intentionally marked inferred to-avoid type application.--Hence-  FunCo r mult co1 co2 :: (s1->t1) ~r (s2->t2)-is short for-  TyConAppCo (->) mult 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 [r1, r2, r3] = [nth r1 0 c, nth r2 1 c, nth r3 2 c]-decomposeCo :: Arity -> Coercion-            -> [Role]  -- the roles of the output coercions-                       -- this must have at least as many-                       -- entries as the Arity provided-            -> [Coercion]-decomposeCo arity co rs-  = [mkNthCo r n co | (n,r) <- [0..(arity-1)] `zip` rs ]-           -- Remember, Nth is zero-indexed--decomposeFunCo :: HasDebugCallStack-               => Role      -- Role of the input coercion-               -> Coercion  -- Input coercion-               -> (CoercionN, Coercion, Coercion)--- Expects co :: (s1 -> t1) ~ (s2 -> t2)--- Returns (co1 :: s1~s2, co2 :: t1~t2)--- See Note [Function coercions] for the "3" and "4"--decomposeFunCo _ (FunCo _ w co1 co2) = (w, co1, co2)-   -- Short-circuits the calls to mkNthCo--decomposeFunCo r co = assertPpr all_ok (ppr co)-                      (mkNthCo Nominal 0 co, mkNthCo r 3 co, mkNthCo r 4 co)-  where-    Pair s1t1 s2t2 = coercionKind co-    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 = mkEmptyTCvSubst $ mkInScopeSet $-                 tyCoVarsOfTypes orig_args `unionVarSet` tyCoVarsOfCo orig_co--    go :: [CoercionN]      -- accumulator for argument coercions, reversed-       -> (TCvSubst,Kind)  -- Lhs kind of coercion-       -> CoercionN        -- coercion originally applied to the function-       -> (TCvSubst,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  = mkNthCo Nominal 0 (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 (_w1, _s1, t1) <- splitFunTy_maybe k1-      , Just (_w1, _s2, t2) <- splitFunTy_maybe k2-        -- 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 Nominal 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 (zapTCvSubst subst1, substTy subst1 k1)-                       co-                       (zapTCvSubst 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)---- | 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 co-  | Just (ty, r) <- isReflCo_maybe co-  = 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 _ w arg res)     = Just (funTyCon, cos)-  where cos = [w, mkRuntimeRepCo arg, mkRuntimeRepCo res, arg, res]-splitTyConAppCo_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 (mustBeSaturated tc)-    -- Never create unsaturated type family apps!-  , Just (args', arg') <- snocView args-  , Just arg'' <- setNominalRole_maybe (nthRole 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 _ _ arg res) = Just (arg, res)-splitFunCo_maybe _ = Nothing--splitForAllCo_maybe :: Coercion -> Maybe (TyCoVar, Coercion, Coercion)-splitForAllCo_maybe (ForAllCo tv k_co co) = Just (tv, k_co, co)-splitForAllCo_maybe _                     = Nothing---- | Like 'splitForAllCo_maybe', but only returns Just for tyvar binder-splitForAllCo_ty_maybe :: Coercion -> Maybe (TyVar, Coercion, Coercion)-splitForAllCo_ty_maybe (ForAllCo tv k_co co)-  | isTyVar tv = Just (tv, k_co, co)-splitForAllCo_ty_maybe _ = Nothing---- | Like 'splitForAllCo_maybe', but only returns Just for covar binder-splitForAllCo_co_maybe :: Coercion -> Maybe (CoVar, Coercion, Coercion)-splitForAllCo_co_maybe (ForAllCo cv k_co co)-  | isCoVar cv = Just (cv, k_co, co)-splitForAllCo_co_maybe _ = Nothing------------------------------------------------------------ and some coercion kind stuff--coVarLType, coVarRType :: HasDebugCallStack => CoVar -> Type-coVarLType cv | (_, _, ty1, _, _) <- coVarKindsTypesRole cv = ty1-coVarRType cv | (_, _, _, ty2, _) <- coVarKindsTypesRole cv = ty2--coVarTypes :: HasDebugCallStack => CoVar -> Pair Type-coVarTypes cv-  | (_, _, ty1, ty2, _) <- coVarKindsTypesRole cv-  = Pair ty1 ty2--coVarKindsTypesRole :: HasDebugCallStack => CoVar -> (Kind,Kind,Type,Type,Role)-coVarKindsTypesRole cv- | Just (tc, [k1,k2,ty1,ty2]) <- splitTyConApp_maybe (varType cv)- = (k1, k2, ty1, ty2, eqTyConRole tc)- | 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-  = 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 @co1 :: (a :: TYPE r1) ~ (b :: TYPE r2)@,--- produce a coercion @rep_co :: r1 ~ r2@.-mkRuntimeRepCo :: HasDebugCallStack => Coercion -> Coercion-mkRuntimeRepCo co-  = mkNthCo Nominal 0 kind_co-  where-    kind_co = mkKindCo co  -- kind_co :: TYPE r1 ~ TYPE r2-                           -- (up to silliness with Constraint)--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-  | [w, _rep1, _rep2, co1, co2] <- cos   -- See Note [Function coercions]-  , isFunTyCon tc-  = -- (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 w 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-  = mkReflCo 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 -> CoercionN -> Coercion -> Coercion -> Coercion-mkFunCo r w co1 co2-    -- See Note [Refl invariant]-  | Just (ty1, _) <- isReflCo_maybe co1-  , Just (ty2, _) <- isReflCo_maybe co2-  , Just (w, _) <- isReflCo_maybe w-  = mkReflCo r (mkVisFunTy w ty1 ty2)-  | otherwise = FunCo r w co1 co2---- | 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 (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 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--{- Note [Unused coercion variable in ForAllCo]-   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-See Note [Unused coercion variable in ForAllTy] in GHC.Core.TyCo.Rep for the-motivation for checking coercion variable in types.-To lift the design choice to (ForAllCo cv kind_co body_co), we have two options:--(1) In mkForAllCo, we check whether cv is a coercion variable-    and whether it is not used in body_co. If so we construct a FunCo.-(2) We don't do this check in mkForAllCo.-    In coercionKind, we use mkTyCoForAllTy to perform the check and construct-    a FunTy when necessary.--We chose (2) for two reasons:--* for a coercion, all that matters is its kind, So ForAllCo or 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.--The last wrinkle is that there are restrictions around the use of the cv in the-coercion, as described in 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. As an approximation of this (and keeping close to the-published theory), we currently allow the cv 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.--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-list. We *have* proved that the-problem does not occur with homogeneous equality, so this check can be dropped-once ~# is made to be homogeneous.--}----- | Make a Coercion from a tycovar, a kind coercion, and a body coercion.--- The kind of the tycovar should be the left-hand kind of the kind coercion.--- See Note [Unused coercion variable in ForAllCo]-mkForAllCo :: TyCoVar -> CoercionN -> Coercion -> Coercion-mkForAllCo v kind_co co-  | assert (varType v `eqType` (pFst $ coercionKind kind_co)) True-  , assert (isTyVar v || almostDevoidCoVarOfCo v co) True-  , Just (ty, r) <- isReflCo_maybe co-  , isGReflCo kind_co-  = mkReflCo r (mkTyCoInvForAllTy v ty)-  | otherwise-  = ForAllCo v kind_co co---- | Like 'mkForAllCo', but the inner coercion shouldn't be an obvious--- reflexive coercion. For example, it is guaranteed in 'mkForAllCos'.--- The kind of the tycovar should be the left-hand kind of the kind coercion.-mkForAllCo_NoRefl :: TyCoVar -> CoercionN -> Coercion -> Coercion-mkForAllCo_NoRefl v kind_co co-  | assert (varType v `eqType` (pFst $ coercionKind kind_co)) True-  , assert (isTyVar v || almostDevoidCoVarOfCo v co) True-  , assert (not (isReflCo co)) True-  , isCoVar v-  , not (v `elemVarSet` tyCoVarsOfCo co)-  = FunCo (coercionRole co) (multToCo Many) kind_co co-      -- Functions from coercions are always unrestricted-  | otherwise-  = ForAllCo v kind_co co---- | Make nested ForAllCos-mkForAllCos :: [(TyCoVar, CoercionN)] -> Coercion -> Coercion-mkForAllCos bndrs co-  | Just (ty, r ) <- isReflCo_maybe co-  = let (refls_rev'd, non_refls_rev'd) = span (isReflCo . snd) (reverse bndrs) in-    foldl' (flip $ uncurry mkForAllCo_NoRefl)-           (mkReflCo r (mkTyCoInvForAllTys (reverse (map fst refls_rev'd)) ty))-           non_refls_rev'd-  | otherwise-  = foldr (uncurry mkForAllCo_NoRefl) co bndrs---- | Make a Coercion quantified over a type/coercion variable;--- the variable has the same type in both sides of the coercion-mkHomoForAllCos :: [TyCoVar] -> Coercion -> Coercion-mkHomoForAllCos vs co-  | Just (ty, r) <- isReflCo_maybe co-  = mkReflCo r (mkTyCoInvForAllTys vs ty)-  | otherwise-  = mkHomoForAllCos_NoRefl vs co---- | Like 'mkHomoForAllCos', but the inner coercion shouldn't be an obvious--- reflexive coercion. For example, it is guaranteed in 'mkHomoForAllCos'.-mkHomoForAllCos_NoRefl :: [TyCoVar] -> Coercion -> Coercion-mkHomoForAllCos_NoRefl vs orig_co-  = assert (not (isReflCo orig_co))-    foldr go orig_co vs-  where-    go v co = mkForAllCo_NoRefl v (mkNomReflCo (varType v)) 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.--}---- | 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-mkAxiomInstCo :: CoAxiom Branched -> BranchIndex -> [Coercion] -> Coercion-mkAxiomInstCo ax index args-  = assert (args `lengthIs` coAxiomArity ax index) $-    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---- | Make a coercion from a coercion hole-mkHoleCo :: CoercionHole -> Coercion-mkHoleCo h = HoleCo h---- | 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 = mkReflCo 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 | isReflCo co          = 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 co2 | isReflCo co1 = co2-                  | isReflCo co2 = co1-mkTransCo (GRefl r t1 (MCo co1)) (GRefl _ _ (MCo co2))-  = GRefl r t1 (MCo $ mkTransCo co1 co2)-mkTransCo co1 co2                = TransCo co1 co2--mkNthCo :: HasDebugCallStack-        => Role  -- The role of the coercion you're creating-        -> Int   -- Zero-indexed-        -> Coercion-        -> Coercion-mkNthCo r n co-  = assertPpr good_call bad_call_msg $-    go n co-  where-    Pair ty1 ty2 = coercionKind co--    go 0 co-      | Just (ty, _) <- isReflCo_maybe co-      , Just (tv, _) <- splitForAllTyCoVar_maybe ty-      = -- works for both tyvar and covar-        assert (r == Nominal) $-        mkNomReflCo (varType tv)--    go n co-      | Just (ty, r0) <- isReflCo_maybe co-      , let tc = tyConAppTyCon ty-      = assertPpr (ok_tc_app ty n) (ppr n $$ ppr ty) $-        assert (nthRole r0 tc n == r) $-        mkReflCo r (tyConAppArgN n ty)-      where ok_tc_app :: Type -> Int -> Bool-            ok_tc_app ty n-              | 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--    go 0 (ForAllCo _ kind_co _)-      = assert (r == Nominal)-        kind_co-      -- If co :: (forall a1:k1. t1) ~ (forall a2:k2. t2)-      -- then (nth 0 co :: k1 ~N k2)-      -- If co :: (forall a1:t1 ~ t2. t1) ~ (forall a2:t3 ~ t4. t2)-      -- then (nth 0 co :: (t1 ~ t2) ~N (t3 ~ t4))--    go n (FunCo _ w arg res)-      = mkNthCoFunCo n w arg res--    go n (TyConAppCo r0 tc arg_cos) = assertPpr (r == nthRole r0 tc n)-                                                  (vcat [ ppr tc-                                                        , ppr arg_cos-                                                        , ppr r0-                                                        , ppr n-                                                        , ppr r ]) $-                                             arg_cos `getNth` n--    go n (SymCo co)  -- Recurse, hoping to get to a TyConAppCo or FunCo-      = mkSymCo (go n co)--    go n co-      = NthCo r n co--    -- Assertion checking-    bad_call_msg = vcat [ text "Coercion =" <+> ppr co-                        , text "LHS ty =" <+> ppr ty1-                        , text "RHS ty =" <+> ppr ty2-                        , text "n =" <+> ppr n, text "r =" <+> ppr r-                        , text "coercion role =" <+> ppr (coercionRole co) ]-    good_call-      -- If the Coercion passed in is between forall-types, then the Int must-      -- be 0 and the role must be Nominal.-      | Just (_tv1, _) <- splitForAllTyCoVar_maybe ty1-      , Just (_tv2, _) <- splitForAllTyCoVar_maybe ty2-      = n == 0 && r == Nominal--      -- If the Coercion passed in is between T tys and T tys', then the Int-      -- must be less than the length of tys/tys' (which must be the same-      -- lengths).-      ---      -- If the role of the Coercion is nominal, then the role passed in must-      -- be nominal. If the role of the Coercion is representational, then the-      -- role passed in must be tyConRolesRepresentational T !! n. If the role-      -- of the Coercion is Phantom, then the role passed in must be Phantom.-      ---      -- See also Note [NthCo Cached Roles] if you're wondering why it's-      -- blaringly obvious that we should be *computing* this role instead of-      -- passing it in.-      | Just (tc1, tys1) <- splitTyConApp_maybe ty1-      , Just (tc2, tys2) <- splitTyConApp_maybe ty2-      , tc1 == tc2-      = let len1 = length tys1-            len2 = length tys2-            good_role = case coercionRole co of-                          Nominal -> r == Nominal-                          Representational -> r == (tyConRolesRepresentational tc1 !! n)-                          Phantom -> r == Phantom-        in len1 == len2 && n < len1 && good_role--      | otherwise-      = True---- | Extract the nth field of a FunCo-mkNthCoFunCo :: Int         -- ^ "n"-             -> CoercionN   -- ^ multiplicity coercion-             -> Coercion    -- ^ argument coercion-             -> Coercion    -- ^ result coercion-             -> Coercion    -- ^ nth coercion from a FunCo--- See Note [Function coercions]--- If FunCo _ mult arg_co res_co ::   (s1:TYPE sk1 :mult-> s2:TYPE sk2)---                                  ~ (t1:TYPE tk1 :mult-> t2:TYPE tk2)--- Then we want to behave as if co was---    TyConAppCo mult 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-mkNthCoFunCo n w co1 co2 = case n of-  0 -> w-  1 -> mkRuntimeRepCo co1-  2 -> mkRuntimeRepCo co2-  3 -> co1-  4 -> co2-  _ -> pprPanic "mkNthCo(FunCo)" (ppr n $$ ppr w $$ ppr co1 $$ ppr co2)---- | If you're about to call @mkNthCo r n co@, then @r@ should be--- whatever @nthCoRole n co@ returns.-nthCoRole :: Int -> Coercion -> Role-nthCoRole n co-  | Just (tc, _) <- splitTyConApp_maybe lty-  = nthRole r tc n--  | Just _ <- splitForAllTyCoVar_maybe lty-  = Nominal--  | otherwise-  = pprPanic "nthCoRole" (ppr co)--  where-    lty = coercionLKind co-    r   = coercionRole co--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'.-mkInstCo :: Coercion -> Coercion -> Coercion-mkInstCo (ForAllCo tcv _kind_co body_co) co-  | Just (arg, _) <- isReflCo_maybe co-      -- works for both tyvar and covar-  = 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 = GRefl r ty (MCo co)---- | Given @ty :: k1@, @co :: k1 ~ 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 $ GRefl r ty (MCo 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 $ GRefl r ty (MCo 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 :: Role -> Type -> CoercionN -> Coercion -> Coercion-mkCoherenceRightCo r ty co co2-  | isGReflCo co = co2-  | otherwise    = co2 `mkTransCo` GRefl r ty (MCo 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 (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 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 (FunCo Nominal w arg res)-  = FunCo Representational w-          (downgradeRole Representational Nominal arg)-          (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)--mkAxiomRuleCo :: CoAxiomRule -> [Coercion] -> Coercion-mkAxiomRuleCo = AxiomRuleCo---- | 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 Coercion-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 (tyConRolesX Representational tc) cos-           ; return $ TyConAppCo Nominal tc cos' }-    setNominalRole_maybe_helper (FunCo Representational w co1 co2)-      = do { co1' <- setNominalRole_maybe Representational co1-           ; co2' <- setNominalRole_maybe Representational co2-           ; return $ FunCo Nominal w co1' 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 (ForAllCo tv kind_co co)-      = ForAllCo tv kind_co <$> setNominalRole_maybe_helper co-    setNominalRole_maybe_helper (NthCo _r n co)-      -- NB, this case recurses via setNominalRole_maybe, not-      -- setNominalRole_maybe_helper!-      = NthCo Nominal n <$> setNominalRole_maybe (coercionRole co) co-    setNominalRole_maybe_helper (InstCo co arg)-      = InstCo <$> setNominalRole_maybe_helper co <*> pure arg-    setNominalRole_maybe_helper (UnivCo prov _ co1 co2)-      | case prov of PhantomProv _    -> False  -- should always be phantom-                     ProofIrrelProv _ -> True   -- it's always safe-                     PluginProv _     -> False  -- who knows? This choice is conservative.-                     CorePrepProv _   -> True-      = Just $ UnivCo prov Nominal co1 co2-    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 tc cos-  = zipWith (\r -> downgradeRole r Nominal) (tyConRolesRepresentational tc) cos---- 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 -> [Role]-tyConRolesX Representational tc = tyConRolesRepresentational tc-tyConRolesX role             _  = repeat role---- Returns the roles of the parameters of a tycon, with an infinite tail--- of Nominal-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 -> CoercionN---- 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 _ -> assert False $-              mkNomReflCo ki1--    GRefl _ _ MRefl -> assert False $-                       mkNomReflCo ki1--    GRefl _ _ (MCo co) -> co--    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 tv _ g-      | isTyVar tv-      -> promoteCoercion g--    ForAllCo _ _ _-      -> assert False $-         mkNomReflCo liftedTypeKind-      -- See Note [Weird typing rule for ForAllTy] in GHC.Core.TyCo.Rep--    FunCo _ _ _ _-      -> assert False $-         mkNomReflCo liftedTypeKind--    CoVarCo {}     -> mkKindCo co-    HoleCo {}      -> mkKindCo co-    AxiomInstCo {} -> mkKindCo co-    AxiomRuleCo {} -> mkKindCo co--    UnivCo (PhantomProv kco)    _ _ _ -> kco-    UnivCo (ProofIrrelProv kco) _ _ _ -> kco-    UnivCo (PluginProv _)       _ _ _ -> mkKindCo co-    UnivCo (CorePrepProv _)     _ _ _ -> mkKindCo co--    SymCo g-      -> mkSymCo (promoteCoercion g)--    TransCo co1 co2-      -> mkTransCo (promoteCoercion co1) (promoteCoercion co2)--    NthCo _ n co1-      | Just (_, args) <- splitTyConAppCo_maybe co1-      , args `lengthExceeds` n-      -> 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 _-      | 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 $-         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 $ mkNthCo Nominal 4 g -- extract result type, which is the 5th argument to (->)-  | 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 -> GRefl r (mkCastTy t1 h) $-                          MCo (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--mkFamilyTyConAppCo :: TyCon -> [CoercionN] -> CoercionN--- ^ Given a family instance 'TyCon' and its arg 'Coercion's, return the--- corresponding family 'Coercion'.  E.g:------ > data family T a--- > data instance T (Maybe b) = MkT b------ Where the instance 'TyCon' is :RTL, so:------ > mkFamilyTyConAppCo :RTL (co :: a ~# Int) = T (Maybe a) ~# T (Maybe Int)------ cf. 'mkFamilyTyConApp'-mkFamilyTyConAppCo tc cos-  | Just (fam_tc, fam_tys) <- tyConFamInst_maybe tc-  , let tvs = tyConTyVars tc-        fam_cos = assertPpr (tvs `equalLength` cos) (ppr tc <+> ppr cos) $-                  map (liftCoSubstWith Nominal tvs cos) fam_tys-  = mkTyConAppCo Nominal fam_tc fam_cos-  | otherwise-  = mkTyConAppCo Nominal tc cos---- See Note [Newtype coercions] in GHC.Core.TyCon--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 [v] co-              | isCoVar v = assert (not (v `elemVarSet` tyCoVarsOfCo co)) $-                  -- We didn't call mkForAllCo here because if v does not appear-                  -- in co, the argement coercion will be nominal. But here we-                  -- want it to be r. It is only called in 'mkPiCos', which is-                  -- only used in GHC.Core.Opt.Simplify.Utils, where we are sure for-                  -- now (Aug 2018) v won't occur in co.-                            mkFunResCo r scaled_ty co-              | otherwise = mkFunResCo r scaled_ty co-              where-                scaled_ty = Scaled (varMult v) (varType v)--mkFunResCo :: Role -> Scaled Type -> 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 (Scaled mult arg_ty) res_co-  = mkFunCo role (multToCo mult) (mkReflCo role arg_ty) res_co---- 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--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]--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-  = -- 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 ~ 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  =  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--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 |-> Nth 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 TCvSubst 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 :: Role          -- desired role for output coercion-                  -> [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 -> 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, substTys (lcSubstRight psi) (mkTyCoVarTys exs))--liftCoSubstWith :: Role -> [TyCoVar] -> [Coercion] -> Type -> Coercion-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 :: 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 (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 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 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 (extendTCvInScopeSet 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 `extendTCvInScopeSet` 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) = coVarKindsTypesRole 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 `extendTCvInScopeSet` 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 (zapTCvSubst subst) emptyVarEnv---- | Like 'substForAllCoBndr', but works on a lifting context-substForAllCoBndrUsingLC :: Bool-                            -> (Coercion -> Coercion)-                            -> LiftingContext -> TyCoVar -> Coercion-                            -> (LiftingContext, TyCoVar, Coercion)-substForAllCoBndrUsingLC sym sco (LC subst lc_env) tv co-  = (LC subst' lc_env, tv', co')-  where-    (subst', tv', co') = substForAllCoBndrUsing 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-    -- !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 "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 _ w ty1 ty2) = mkFunCo r (go Nominal w) (go r ty1) (go r ty2)-    go r t@(ForAllTy (Bndr v _) 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 last-           -- wrinkle in Note [Unused coercion variable in ForAllCo].-           -- We specifically check for this and panic because we know that-           -- there's a hole in the type system here, and we'd rather panic than-           -- fall into it.-         then mkForAllCo v' h body_co-         else pprPanic "ty_co_subst: covar is not almost devoid" (ppr t)-    go r ty@(LitTy {})     = assert (r == Nominal) $-                             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 `extendTCvInScope` 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 (getTCvInScope subst) (setVarType old_var k1)--    lifted   = mkGReflRightCo Nominal (TyVarTy new_var) eta-               -- :: new_var ~ new_var |> eta-    new_cenv = extendVarEnv cenv old_var lifted---- Works for covar binder-liftCoSubstCoVarBndrUsing :: (r -> CoercionN)              -- ^ coercion getter-                          -> (LiftingContext -> Type -> r) -- ^ callback-                          -> LiftingContext -> CoVar-                          -> (LiftingContext, CoVar, r)-liftCoSubstCoVarBndrUsing view_co fun lc@(LC subst cenv) old_var-  = assert (isCoVar old_var) $-    ( LC (subst `extendTCvInScope` new_var) new_cenv-    , new_var, stuff )-  where-    old_kind = coVarKind old_var-    stuff    = fun lc old_kind-    eta      = view_co stuff-    k1       = coercionLKind eta-    new_var  = uniqAway (getTCvInScope subst) (setVarType old_var k1)--    -- old_var :: s1  ~r s2-    -- eta     :: (s1' ~r s2') ~N (t1 ~r t2)-    -- 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   = mkNthCo role 2 eta'-    eta2   = mkNthCo role 3 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 -> 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-%*                                                                      *-%************************************************************************--}--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 (ForAllCo tv k co)        = seqType (varType tv) `seq` seqCo k-                                                       `seq` seqCo co-seqCo (FunCo r w co1 co2)       = r `seq` seqCo w `seq` seqCo co1 `seq` seqCo co2-seqCo (CoVarCo cv)              = cv `seq` ()-seqCo (HoleCo h)                = coHoleCoVar h `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 r n co)            = r `seq` 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 (AxiomRuleCo _ cs)        = seqCos cs--seqProv :: UnivCoProvenance -> ()-seqProv (PhantomProv co)    = seqCo co-seqProv (ProofIrrelProv co) = seqCo co-seqProv (PluginProv _)      = ()-seqProv (CorePrepProv _)    = ()--seqCos :: [Coercion] -> ()-seqCos []       = ()-seqCos (co:cos) = seqCo co `seq` seqCos cos--{--%************************************************************************-%*                                                                      *-             The kind of a type, and of a coercion-%*                                                                      *-%************************************************************************--}---- | 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 :: Coercion -> Pair Type-coercionKind co = Pair (coercionLKind co) (coercionRKind co)--coercionLKind :: Coercion -> Type-coercionLKind co-  = go co-  where-    go (Refl ty)                = ty-    go (GRefl _ ty _)           = ty-    go (TyConAppCo _ tc cos)    = mkTyConApp tc (map go cos)-    go (AppCo co1 co2)          = mkAppTy (go co1) (go co2)-    go (ForAllCo tv1 _ co1)     = mkTyCoInvForAllTy tv1 (go co1)-    go (FunCo _ w co1 co2)      = mkFunctionType (go w) (go co1) (go co2)-    go (CoVarCo cv)             = coVarLType cv-    go (HoleCo h)               = coVarLType (coHoleCoVar h)-    go (UnivCo _ _ ty1 _)       = ty1-    go (SymCo co)               = coercionRKind co-    go (TransCo co1 _)          = go co1-    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 (NthCo _ d co)           = go_nth d (go co)-    go (AxiomInstCo ax ind cos) = go_ax_inst ax ind (map go cos)-    go (AxiomRuleCo ax cos)     = pFst $ expectJust "coercionKind" $-                                  coaxrProves ax $ map coercionKind cos--    go_ax_inst ax ind tys-      | CoAxBranch { cab_tvs = tvs, cab_cvs = cvs-                   , cab_lhs = lhs } <- coAxiomNthBranch ax ind-      , let (tys1, cotys1) = splitAtList tvs tys-            cos1           = map stripCoercionTy cotys1-      = assert (tys `equalLength` (tvs ++ cvs)) $-                  -- Invariant of AxiomInstCo: cos should-                  -- exactly saturate the axiom branch-        substTyWith tvs tys1       $-        substTyWithCoVars cvs cos1 $-        mkTyConApp (coAxiomTyCon ax) lhs--    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_nth :: Int -> Type -> Type-go_nth d ty-  | Just args <- tyConAppArgs_maybe ty-  = assert (args `lengthExceeds` d) $-    args `getNth` d--  | d == 0-  , Just (tv,_) <- splitForAllTyCoVar_maybe ty-  = tyVarKind tv--  | otherwise-  = pprPanic "coercionLKind:nth" (ppr d <+> ppr ty)--coercionRKind :: Coercion -> Type-coercionRKind co-  = go co-  where-    go (Refl ty)                = ty-    go (GRefl _ ty MRefl)       = ty-    go (GRefl _ ty (MCo co1))   = mkCastTy ty co1-    go (TyConAppCo _ tc cos)    = mkTyConApp tc (map go cos)-    go (AppCo co1 co2)          = mkAppTy (go co1) (go co2)-    go (CoVarCo cv)             = coVarRType cv-    go (HoleCo h)               = coVarRType (coHoleCoVar h)-    go (FunCo _ w co1 co2)      = mkFunctionType (go w) (go co1) (go co2)-    go (UnivCo _ _ _ ty2)       = ty2-    go (SymCo co)               = coercionLKind co-    go (TransCo _ co2)          = 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 (NthCo _ d co)           = go_nth d (go co)-    go (AxiomInstCo ax ind cos) = go_ax_inst ax ind (map go cos)-    go (AxiomRuleCo ax cos)     = pSnd $ expectJust "coercionKind" $-                                  coaxrProves ax $ map coercionKind cos--    go co@(ForAllCo tv1 k_co co1) -- works for both tyvar and covar-       | isGReflCo k_co           = mkTyCoInvForAllTy tv1 (go co1)-         -- kind_co always has kind @Type@, thus @isGReflCo@-       | otherwise                = go_forall empty_subst co-       where-         empty_subst = mkEmptyTCvSubst (mkInScopeSet $ tyCoVarsOfCo co)--    go_ax_inst ax ind tys-      | CoAxBranch { cab_tvs = tvs, cab_cvs = cvs-                   , cab_rhs = rhs } <- coAxiomNthBranch ax ind-      , let (tys2, cotys2) = splitAtList tvs tys-            cos2           = map stripCoercionTy cotys2-      = assert (tys `equalLength` (tvs ++ cvs)) $-                  -- Invariant of AxiomInstCo: cos should-                  -- exactly saturate the axiom branch-        substTyWith tvs tys2 $-        substTyWithCoVars cvs cos2 rhs--    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_forall subst (ForAllCo tv1 k_co co)-      -- See Note [Nested ForAllCos]-      | isTyVar tv1-      = mkInfForAllTy tv2 (go_forall subst' co)-      where-        k2  = coercionRKind k_co-        tv2 = setTyVarKind tv1 (substTy subst k2)-        subst' | isGReflCo k_co = extendTCvInScope subst tv1-                 -- kind_co always has kind @Type@, thus @isGReflCo@-               | otherwise      = extendTvSubst (extendTCvInScope subst tv2) tv1 $-                                  TyVarTy tv2 `mkCastTy` mkSymCo k_co--    go_forall subst (ForAllCo cv1 k_co co)-      | isCoVar cv1-      = mkTyCoInvForAllTy cv2 (go_forall subst' co)-      where-        k2 = coercionRKind k_co-        r         = coVarRole cv1-        eta1      = mkNthCo r 2 (downgradeRole r Nominal k_co)-        eta2      = mkNthCo r 3 (downgradeRole r Nominal 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 = extendTCvInScope subst cv1-                | otherwise     = extendCvSubst (extendTCvInScope subst cv2)-                                                cv1 n_subst--    go_forall 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.---}---- | 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 _ _ co) = go co-    go (FunCo r _ _ _) = r-    go (CoVarCo cv) = coVarRole cv-    go (HoleCo h)   = coVarRole (coHoleCoVar h)-    go (AxiomInstCo ax _ _) = coAxiomRole ax-    go (UnivCo _ r _ _)  = r-    go (SymCo co) = go co-    go (TransCo co1 _co2) = go co1-    go (NthCo r _d _co) = r-    go (LRCo {}) = Nominal-    go (InstCo co _) = go co-    go (KindCo {}) = Nominal-    go (SubCo _) = Representational-    go (AxiomRuleCo ax _) = coaxrRole ax--{--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).---}---- | 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"---- | Creates a primitive type equality predicate.--- Invariant: the types are not Coercions-mkPrimEqPred :: Type -> Type -> Type-mkPrimEqPred ty1 ty2-  = mkTyConApp eqPrimTyCon [k1, k2, ty1, ty2]-  where-    k1 = typeKind ty1-    k2 = typeKind ty2---- | 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 with explicit kinds-mkHeteroPrimEqPred :: Kind -> Kind -> Type -> Type -> Type-mkHeteroPrimEqPred k1 k2 ty1 ty2 = mkTyConApp 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-  = mkTyConApp eqReprPrimTyCon [k1, k2, ty1, ty2]--mkReprPrimEqPred :: Type -> Type -> Type-mkReprPrimEqPred ty1  ty2-  = mkTyConApp eqReprPrimTyCon [k1, k2, ty1, ty2]-  where-    k1 = typeKind ty1-    k2 = typeKind 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 :: 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_mult = w1, ft_arg = arg1, ft_res = res1 })-       (FunTy { ft_mult = w2, ft_arg = arg2, ft_res = res2 })-      = mkFunCo Nominal (go w1 w2) (go arg1 arg2) (go res1 res2)--    go (TyConApp tc1 args1) (TyConApp tc2 args2)-      = assert (tc1 == tc2) $-        mkTyConAppCo Nominal tc1 (zipWith go args1 args2)--    go (AppTy ty1a ty1b) ty2-      | Just (ty2a, ty2b) <- repSplitAppTy_maybe ty2-      = mkAppCo (go ty1a ty2a) (go ty1b ty2b)--    go ty1 (AppTy ty2a ty2b)-      | Just (ty1a, ty1b) <- repSplitAppTy_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 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 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 = mkNthCo r 2 kind_co'-            eta2 = mkNthCo r 3 kind_co'--            subst = mkEmptyTCvSubst $ 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_co :: Coercion -> Monoid.Any-(has_co_hole_ty, _, has_co_hole_co, _)-  = foldTyCo folder ()-  where-    folder = TyCoFolder { tcf_view  = noView-                        , tcf_tyvar = const2 (Monoid.Any False)-                        , tcf_covar = const2 (Monoid.Any False)-                        , tcf_hole  = const2 (Monoid.Any True)-                        , tcf_tycobinder = const2-                        }---- | Is there a coercion hole in this type?-hasCoercionHoleTy :: Type -> Bool-hasCoercionHoleTy = Monoid.getAny . has_co_hole_ty---- | Is there a coercion hole in this coercion?-hasCoercionHoleCo :: Coercion -> Bool-hasCoercionHoleCo = Monoid.getAny . has_co_hole_co--hasThisCoercionHoleTy :: Type -> CoercionHole -> Bool-hasThisCoercionHoleTy ty hole = Monoid.getAny (f ty)-  where-    (f, _, _, _) = foldTyCo folder ()--    folder = TyCoFolder { tcf_view  = noView-                        , tcf_tyvar = const2 (Monoid.Any False)-                        , tcf_covar = const2 (Monoid.Any False)-                        , tcf_hole  = \ _ h -> Monoid.Any (getUnique h == getUnique hole)-                        , tcf_tycobinder = const2-                        }---- | Set the type of a 'CoercionHole'-setCoHoleType :: CoercionHole -> Type -> CoercionHole-setCoHoleType h t = setCoHoleCoVar h (setVarType (coHoleCoVar h) t)+{-# LANGUAGE DeriveFunctor       #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE ScopedTypeVariables #-}++{-+(c) The University of Glasgow 2006+-}++-- | Module for (a) type kinds and (b) type coercions,+-- as used in System FC. See 'GHC.Core.Expr' for+-- more on System FC and how coercions fit into it.+--+module GHC.Core.Coercion (+        -- * Main data type+        Coercion, CoercionN, CoercionR, CoercionP,+        MCoercion(..), MCoercionN, MCoercionR,+        CoSel(..), FunSel(..),+        UnivCoProvenance, CoercionHole(..),+        coHoleCoVar, setCoHoleCoVar,+        LeftOrRight(..),+        Var, CoVar, TyCoVar,+        Role(..), ltRole,++        -- ** Functions over coercions+        coVarRType, coVarLType, coVarTypes,+        coVarKind, coVarTypesRole, coVarRole,+        coercionType, mkCoercionType,+        coercionKind, coercionLKind, coercionRKind,coercionKinds,+        coercionRole, coercionKindRole,++        -- ** Constructing coercions+        mkGReflCo, mkGReflMCo, mkReflCo, mkRepReflCo, mkNomReflCo,+        mkCoVarCo, mkCoVarCos,+        mkAxInstCo, mkUnbranchedAxInstCo,+        mkAxInstRHS, mkUnbranchedAxInstRHS,+        mkAxInstLHS, mkUnbranchedAxInstLHS,+        mkPiCo, mkPiCos, mkCoCast,+        mkSymCo, mkTransCo,+        mkSelCo, mkSelCoResRole, getNthFun, selectFromType, mkLRCo,+        mkInstCo, mkAppCo, mkAppCos, mkTyConAppCo,+        mkFunCo, mkFunCo2, mkFunCoNoFTF, mkFunResCo,+        mkNakedFunCo,+        mkNakedForAllCo, mkForAllCo, mkForAllVisCos, mkHomoForAllCos,+        mkPhantomCo, mkAxiomCo,+        mkHoleCo, mkUnivCo, mkSubCo,+        mkProofIrrelCo,+        downgradeRole,+        mkGReflRightCo, mkGReflLeftCo, mkCoherenceLeftCo, mkCoherenceRightCo,+        mkKindCo,+        castCoercionKind, castCoercionKind1, castCoercionKind2,++        -- ** Decomposition+        instNewTyCon_maybe,++        NormaliseStepper, NormaliseStepResult(..), composeSteppers, unwrapNewTypeStepper,+        topNormaliseNewType_maybe, topNormaliseTypeX,++        decomposeCo, decomposeFunCo, decomposePiCos, getCoVar_maybe,+        splitAppCo_maybe,+        splitFunCo_maybe,+        splitForAllCo_maybe,+        splitForAllCo_ty_maybe, splitForAllCo_co_maybe,++        tyConRole, tyConRolesX, tyConRolesRepresentational, setNominalRole_maybe,+        tyConRoleListX, tyConRoleListRepresentational, funRole,+        pickLR,++        isGReflCo, isReflCo, isReflCo_maybe, isGReflCo_maybe, isReflexiveCo, isReflexiveCo_maybe,+        isReflCoVar_maybe, isGReflMCo, mkGReflLeftMCo, mkGReflRightMCo,+        mkCoherenceRightMCo,++        coToMCo, mkTransMCo, mkTransMCoL, mkTransMCoR, mkCastTyMCo, mkSymMCo,+        mkFunResMCo, mkPiMCos,+        isReflMCo, checkReflexiveMCo,++        -- ** Coercion variables+        mkCoVar, isCoVar, coVarName, setCoVarName, setCoVarUnique,++        -- ** Free variables+        tyCoVarsOfCo, tyCoVarsOfCos, coVarsOfCo,+        tyCoFVsOfCo, tyCoFVsOfCos, tyCoVarsOfCoDSet,+        coercionSize, anyFreeVarsOfCo,++        -- ** Substitution+        CvSubstEnv, emptyCvSubstEnv,+        lookupCoVar,+        substCo, substCos, substCoVar, substCoVars, substCoWith,+        substCoVarBndr,+        extendTvSubstAndInScope, getCvSubstEnv,++        -- ** Lifting+        liftCoSubst, liftCoSubstTyVar, liftCoSubstWith, liftCoSubstWithEx,+        emptyLiftingContext, extendLiftingContext, extendLiftingContextAndInScope,+        liftCoSubstVarBndrUsing, isMappedByLC, extendLiftingContextCvSubst,+        updateLCSubst,++        mkSubstLiftingContext, liftingContextSubst, zapLiftingContext,+        lcLookupCoVar, lcInScopeSet,++        LiftCoEnv, LiftingContext(..), liftEnvSubstLeft, liftEnvSubstRight,+        substRightCo, substLeftCo, swapLiftCoEnv, lcSubstLeft, lcSubstRight,++        -- ** Comparison+        eqCoercion, eqCoercionX,++        -- ** Forcing evaluation of coercions+        seqCo,++        -- * Pretty-printing+        pprCo, pprParendCo,+        pprCoAxiom, pprCoAxBranch, pprCoAxBranchLHS,+        pprCoAxBranchUser, tidyCoAxBndrsForUser,+        etaExpandCoAxBranch,++        -- * Tidying+        tidyCo, tidyCos,++        -- * Other+        promoteCoercion, buildCoercion,++        multToCo, mkRuntimeRepCo,++        hasCoercionHole,+        setCoHoleType+       ) where++import {-# SOURCE #-} GHC.CoreToIface (toIfaceTyCon, tidyToIfaceTcArgs)++import GHC.Prelude++import GHC.Iface.Type+import GHC.Core.TyCo.Rep+import GHC.Core.TyCo.FVs+import GHC.Core.TyCo.Ppr+import GHC.Core.TyCo.Subst+import GHC.Core.TyCo.Tidy+import GHC.Core.TyCo.Compare+import GHC.Core.Type+import GHC.Core.Predicate( mkNomEqPred, mkReprEqPred )+import GHC.Core.TyCon+import GHC.Core.TyCon.RecWalk+import GHC.Core.Coercion.Axiom+import GHC.Types.Var+import GHC.Types.Var.Env+import GHC.Types.Var.Set+import GHC.Types.Name hiding ( varName )+import GHC.Types.Basic+import GHC.Types.Unique+import GHC.Data.FastString+import GHC.Data.Pair+import GHC.Types.SrcLoc+import GHC.Builtin.Names+import GHC.Builtin.Types.Prim+import GHC.Data.List.SetOps+import GHC.Data.Maybe+import GHC.Types.Unique.FM+import GHC.Data.List.Infinite (Infinite (..))+import qualified GHC.Data.List.Infinite as Inf++import GHC.Utils.Misc+import GHC.Utils.Outputable+import GHC.Utils.Panic++import Control.Monad (foldM, zipWithM)+import Data.Function ( on )+import Data.Char( isDigit )+import qualified Data.Monoid as Monoid+import Data.List.NonEmpty ( NonEmpty (..) )+import Control.DeepSeq++{-+%************************************************************************+%*                                                                      *+     -- The coercion arguments always *precisely* saturate+     -- arity of (that branch of) the CoAxiom.  If there are+     -- any left over, we use AppCo.  See+     -- See [Coercion axioms applied to coercions] in GHC.Core.TyCo.Rep++\subsection{Coercion variables}+%*                                                                      *+%************************************************************************+-}++coVarName :: CoVar -> Name+coVarName = varName++setCoVarUnique :: CoVar -> Unique -> CoVar+setCoVarUnique = setVarUnique++setCoVarName :: CoVar -> Name -> CoVar+setCoVarName   = setVarName++{-+%************************************************************************+%*                                                                      *+                   Pretty-printing CoAxioms+%*                                                                      *+%************************************************************************++Defined here to avoid module loops. CoAxiom is loaded very early on.++-}++etaExpandCoAxBranch :: CoAxBranch -> ([TyVar], [Type], Type)+-- Return the (tvs,lhs,rhs) after eta-expanding,+-- to the way in which the axiom was originally written+-- See Note [Eta reduction for data families] in GHC.Core.Coercion.Axiom+etaExpandCoAxBranch (CoAxBranch { cab_tvs = tvs+                                , cab_eta_tvs = eta_tvs+                                , cab_lhs = lhs+                                , cab_rhs = rhs })+  -- ToDo: what about eta_cvs?+  = (tvs ++ eta_tvs, lhs ++ eta_tys, mkAppTys rhs eta_tys)+ where+    eta_tys = mkTyVarTys eta_tvs++pprCoAxiom :: CoAxiom br -> SDoc+-- Used in debug-printing only+pprCoAxiom ax@(CoAxiom { co_ax_tc = tc, co_ax_branches = branches })+  = hang (text "axiom" <+> ppr ax)+       2 (braces $ vcat (map (pprCoAxBranchUser tc) (fromBranches branches)))++pprCoAxBranchUser :: TyCon -> CoAxBranch -> SDoc+-- Used when printing injectivity errors (FamInst.reportInjectivityErrors)+-- and inaccessible branches (GHC.Tc.Validity.inaccessibleCoAxBranch)+-- This happens in error messages: don't print the RHS of a data+--   family axiom, which is meaningless to a user+pprCoAxBranchUser tc br+  | isDataFamilyTyCon tc = pprCoAxBranchLHS tc br+  | otherwise            = pprCoAxBranch    tc br++pprCoAxBranchLHS :: TyCon -> CoAxBranch -> SDoc+-- Print the family-instance equation when reporting+--   a conflict between equations (FamInst.conflictInstErr)+-- For type families the RHS is important; for data families not so.+--   Indeed for data families the RHS is a mysterious internal+--   type constructor, so we suppress it (#14179)+-- See FamInstEnv Note [Family instance overlap conflicts]+pprCoAxBranchLHS = ppr_co_ax_branch pp_rhs+  where+    pp_rhs _ _ = empty++pprCoAxBranch :: TyCon -> CoAxBranch -> SDoc+pprCoAxBranch = ppr_co_ax_branch ppr_rhs+  where+    ppr_rhs env rhs = equals <+> pprPrecTypeX env topPrec rhs++ppr_co_ax_branch :: (TidyEnv -> Type -> SDoc)+                 -> TyCon -> CoAxBranch -> SDoc+ppr_co_ax_branch ppr_rhs fam_tc branch+  = foldr1 (flip hangNotEmpty 2) $+    pprUserForAll (mkForAllTyBinders Inferred bndrs') :|+         -- See Note [Printing foralls in type family instances] in GHC.Iface.Type+    (pp_lhs <+> ppr_rhs tidy_env ee_rhs) :+    ( vcat [ text "-- Defined" <+> pp_loc+           , ppUnless (null incomps) $ whenPprDebug $+             text "-- Incomps:" <+> vcat (map (pprCoAxBranch fam_tc) incomps) ] ) :+    []+  where+    incomps = coAxBranchIncomps branch+    loc = coAxBranchSpan branch+    pp_loc | isGoodSrcSpan loc = text "at" <+> ppr (srcSpanStart loc)+           | otherwise         = text "in" <+> ppr loc++    -- Eta-expand LHS and RHS types, because sometimes data family+    -- instances are eta-reduced.+    -- See Note [Eta reduction for data families] in GHC.Core.Coercion.Axiom.+    (ee_tvs, ee_lhs, ee_rhs) = etaExpandCoAxBranch branch++    pp_lhs = pprIfaceTypeApp topPrec (toIfaceTyCon fam_tc)+                             (tidyToIfaceTcArgs tidy_env fam_tc ee_lhs)++    (tidy_env, bndrs') = tidyCoAxBndrsForUser emptyTidyEnv ee_tvs++tidyCoAxBndrsForUser :: TidyEnv -> [Var] -> (TidyEnv, [Var])+-- Tidy wildcards "_1", "_2" to "_", and do not return them+-- in the list of binders to be printed+-- This is so that in error messages we see+--     forall a. F _ [a] _ = ...+-- rather than+--     forall a _1 _2. F _1 [a] _2 = ...+--+-- This is a rather disgusting function+-- See Note [Wildcard names] in GHC.Tc.Gen.HsType+tidyCoAxBndrsForUser init_env tcvs+  = (tidy_env, reverse tidy_bndrs)+  where+    (tidy_env, tidy_bndrs) = foldl tidy_one (init_env, []) tcvs++    tidy_one (env@(occ_env, subst), rev_bndrs') bndr+      | is_wildcard bndr = (env_wild, rev_bndrs')+      | otherwise        = (env',     bndr' : rev_bndrs')+      where+        (env', bndr') = tidyVarBndr env bndr+        env_wild = (occ_env, extendVarEnv subst bndr wild_bndr)+        wild_bndr = setVarName bndr $+                    tidyNameOcc (varName bndr) (mkTyVarOccFS (fsLit "_"))+                    -- Tidy the binder to "_"++    is_wildcard :: Var -> Bool+    is_wildcard tv = case occNameString (getOccName tv) of+                       ('_' : rest) -> all isDigit rest+                       _            -> False+++{- *********************************************************************+*                                                                      *+              MCoercion+*                                                                      *+********************************************************************* -}++coToMCo :: Coercion -> MCoercion+-- Convert a coercion to a MCoercion,+-- It's not clear whether or not isReflexiveCo would be better here+--    See #19815 for a bit of data and discussion on this point+coToMCo co | isReflCo co = MRefl+           | otherwise   = MCo co++checkReflexiveMCo :: MCoercion -> MCoercion+checkReflexiveMCo MRefl                       = MRefl+checkReflexiveMCo (MCo co) | isReflexiveCo co = MRefl+                           | otherwise        = MCo co++-- | Tests if this MCoercion is obviously generalized reflexive+-- Guaranteed to work very quickly.+isGReflMCo :: MCoercion -> Bool+isGReflMCo MRefl = True+isGReflMCo (MCo co) | isGReflCo co = True+isGReflMCo _ = False++-- | Make a generalized reflexive coercion+mkGReflCo :: Role -> Type -> MCoercionN -> Coercion+mkGReflCo r ty mco+  | isGReflMCo mco = if r == Nominal then Refl ty+                                     else GRefl r ty MRefl+  | otherwise+  = -- I'd like to have this assert, but sadly it's not true during type+    -- inference because the types are not fully zonked+    -- assertPpr (case mco of+    --              MCo co -> typeKind ty `eqType` coercionLKind co+    --              MRefl  -> True)+    --          (vcat [ text "ty" <+> ppr ty <+> dcolon <+> ppr (typeKind ty)+    --                , case mco of+    --                     MCo co -> text "co" <+> ppr co+    --                                  <+> dcolon <+> ppr (coercionKind co)+    --                     MRefl  -> text "MRefl"+    --                , callStackDoc ]) $+    GRefl r ty mco++mkGReflMCo :: HasDebugCallStack => Role -> Type -> CoercionN -> Coercion+mkGReflMCo r ty co = mkGReflCo r ty (MCo co)++-- | Compose two MCoercions via transitivity+mkTransMCo :: MCoercion -> MCoercion -> MCoercion+mkTransMCo MRefl     co2       = co2+mkTransMCo co1       MRefl     = co1+mkTransMCo (MCo co1) (MCo co2) = MCo (mkTransCo co1 co2)++mkTransMCoL :: MCoercion -> Coercion -> MCoercion+mkTransMCoL MRefl     co2 = coToMCo co2+mkTransMCoL (MCo co1) co2 = MCo (mkTransCo co1 co2)++mkTransMCoR :: Coercion -> MCoercion -> MCoercion+mkTransMCoR co1 MRefl     = coToMCo co1+mkTransMCoR co1 (MCo co2) = MCo (mkTransCo co1 co2)++-- | Get the reverse of an 'MCoercion'+mkSymMCo :: MCoercion -> MCoercion+mkSymMCo MRefl    = MRefl+mkSymMCo (MCo co) = MCo (mkSymCo co)++-- | Cast a type by an 'MCoercion'+mkCastTyMCo :: Type -> MCoercion -> Type+mkCastTyMCo ty MRefl    = ty+mkCastTyMCo ty (MCo co) = ty `mkCastTy` co++mkPiMCos :: [Var] -> MCoercion -> MCoercion+mkPiMCos _ MRefl = MRefl+mkPiMCos vs (MCo co) = MCo (mkPiCos Representational vs co)++mkFunResMCo :: Id -> MCoercionR -> MCoercionR+mkFunResMCo _      MRefl    = MRefl+mkFunResMCo arg_id (MCo co) = MCo (mkFunResCo Representational arg_id co)++mkGReflLeftMCo :: Role -> Type -> MCoercionN -> Coercion+mkGReflLeftMCo r ty MRefl    = mkReflCo r ty+mkGReflLeftMCo r ty (MCo co) = mkGReflLeftCo r ty co++mkGReflRightMCo :: Role -> Type -> MCoercionN -> Coercion+mkGReflRightMCo r ty MRefl    = mkReflCo r ty+mkGReflRightMCo r ty (MCo co) = mkGReflRightCo r ty co++-- | Like 'mkCoherenceRightCo', but with an 'MCoercion'+mkCoherenceRightMCo :: Role -> Type -> MCoercionN -> Coercion -> Coercion+mkCoherenceRightMCo _ _  MRefl    co2 = co2+mkCoherenceRightMCo r ty (MCo co) co2 = mkCoherenceRightCo r ty co co2++isReflMCo :: MCoercion -> Bool+isReflMCo MRefl = True+isReflMCo _     = False++{-+%************************************************************************+%*                                                                      *+        Destructing coercions+%*                                                                      *+%************************************************************************+-}++-- | This breaks a 'Coercion' with type @T A B C ~ T D E F@ into+-- a list of 'Coercion's of kinds @A ~ D@, @B ~ E@ and @E ~ F@. Hence:+--+-- > decomposeCo 3 c [r1, r2, r3] = [nth r1 0 c, nth r2 1 c, nth r3 2 c]+decomposeCo :: Arity -> Coercion+            -> Infinite Role  -- the roles of the output coercions+            -> [Coercion]+decomposeCo arity co rs+  = [mkSelCo (SelTyCon n r) co | (n,r) <- [0..(arity-1)] `zip` Inf.toList rs ]+     -- Remember, SelTyCon is zero-indexed++decomposeFunCo :: HasDebugCallStack+               => Coercion  -- Input coercion+               -> (CoercionN, Coercion, Coercion)+-- Expects co :: (s1 %m1-> t1) ~ (s2 %m2-> t2)+-- Returns (cow :: m1 ~N m2, co1 :: s1~s2, co2 :: t1~t2)+-- actually cow will be a Phantom coercion if the input is a Phantom coercion++decomposeFunCo (FunCo { fco_mult = w, fco_arg = co1, fco_res = co2 })+  = (w, co1, co2)+   -- Short-circuits the calls to mkSelCo++decomposeFunCo co+  = assertPpr all_ok (ppr co) $+    ( mkSelCo (SelFun SelMult) co+    , mkSelCo (SelFun SelArg) co+    , mkSelCo (SelFun SelRes) co )+  where+    Pair s1t1 s2t2 = coercionKind co+    all_ok = isFunTy s1t1 && isFunTy s2t2++{- Note [Pushing a coercion into a pi-type]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have this:+    (f |> co) t1 .. tn+Then we want to push the coercion into the arguments, so as to make+progress. For example of why you might want to do so, see Note+[Respecting definitional equality] in GHC.Core.TyCo.Rep.++This is done by decomposePiCos.  Specifically, if+    decomposePiCos co [t1,..,tn] = ([co1,...,cok], cor)+then+    (f |> co) t1 .. tn   =   (f (t1 |> co1) ... (tk |> cok)) |> cor) t(k+1) ... tn++Notes:++* k can be smaller than n! That is decomposePiCos can return *fewer*+  coercions than there are arguments (ie k < n), if the kind provided+  doesn't have enough binders.++* If there is a type error, we might see+       (f |> co) t1+  where co :: (forall a. ty) ~ (ty1 -> ty2)+  Here 'co' is insoluble, but we don't want to crash in decoposePiCos.+  So decomposePiCos carefully tests both sides of the coercion to check+  they are both foralls or both arrows.  Not doing this caused #15343.+-}++decomposePiCos :: HasDebugCallStack+               => CoercionN -> Pair Type  -- Coercion and its kind+               -> [Type]+               -> ([CoercionN], CoercionN)+-- See Note [Pushing a coercion into a pi-type]+decomposePiCos orig_co (Pair orig_k1 orig_k2) orig_args+  = go [] (orig_subst,orig_k1) orig_co (orig_subst,orig_k2) orig_args+  where+    orig_subst = mkEmptySubst $ mkInScopeSet $+                 tyCoVarsOfTypes orig_args `unionVarSet` tyCoVarsOfCo orig_co++    go :: [CoercionN]      -- accumulator for argument coercions, reversed+       -> (Subst,Kind)  -- Lhs kind of coercion+       -> CoercionN        -- coercion originally applied to the function+       -> (Subst,Kind)  -- Rhs kind of coercion+       -> [Type]           -- Arguments to that function+       -> ([CoercionN], Coercion)+    -- Invariant:  co :: subst1(k1) ~ subst2(k2)++    go acc_arg_cos (subst1,k1) co (subst2,k2) (ty:tys)+      | Just (a, t1) <- splitForAllTyCoVar_maybe k1+      , Just (b, t2) <- splitForAllTyCoVar_maybe k2+        -- know     co :: (forall a:s1.t1) ~ (forall b:s2.t2)+        --    function :: forall a:s1.t1   (the function is not passed to decomposePiCos)+        --           a :: s1+        --           b :: s2+        --          ty :: s2+        -- need arg_co :: s2 ~ s1+        --      res_co :: t1[ty |> arg_co / a] ~ t2[ty / b]+      = let arg_co  = mkSelCo SelForAll (mkSymCo co)+            res_co  = mkInstCo co (mkGReflLeftCo Nominal ty arg_co)+            subst1' = extendTCvSubst subst1 a (ty `CastTy` arg_co)+            subst2' = extendTCvSubst subst2 b ty+        in+        go (arg_co : acc_arg_cos) (subst1', t1) res_co (subst2', t2) tys++      | Just (af1, _w1, _s1, t1) <- splitFunTy_maybe k1+      , Just (af2, _w1, _s2, t2) <- splitFunTy_maybe k2+      , af1 == af2  -- Same sort of arrow+        -- know     co :: (s1 -> t1) ~ (s2 -> t2)+        --    function :: s1 -> t1+        --          ty :: s2+        -- need arg_co :: s2 ~ s1+        --      res_co :: t1 ~ t2+      = let (_, sym_arg_co, res_co) = decomposeFunCo co+            -- It should be fine to ignore the multiplicity bit+            -- of the coercion for a Nominal coercion.+            arg_co = mkSymCo sym_arg_co+        in+        go (arg_co : acc_arg_cos) (subst1,t1) res_co (subst2,t2) tys++      | not (isEmptyTCvSubst subst1) || not (isEmptyTCvSubst subst2)+      = go acc_arg_cos (zapSubst subst1, substTy subst1 k1)+                       co+                       (zapSubst subst2, substTy subst1 k2)+                       (ty:tys)++      -- tys might not be empty, if the left-hand type of the original coercion+      -- didn't have enough binders+    go acc_arg_cos _ki1 co _ki2 _tys = (reverse acc_arg_cos, co)++-- | Extract a covar, if possible. This check is dirty. Be ashamed+-- of yourself. (It's dirty because it cares about the structure of+-- a coercion, which is morally reprehensible.)+getCoVar_maybe :: Coercion -> Maybe CoVar+getCoVar_maybe (CoVarCo cv) = Just cv+getCoVar_maybe _            = Nothing++multToCo :: Mult -> Coercion+multToCo r = mkNomReflCo r++-- first result has role equal to input; third result is Nominal+splitAppCo_maybe :: Coercion -> Maybe (Coercion, Coercion)+-- ^ Attempt to take a coercion application apart.+splitAppCo_maybe (AppCo co arg) = Just (co, arg)+splitAppCo_maybe (TyConAppCo r tc args)+  | args `lengthExceeds` tyConArity tc+  , Just (args', arg') <- snocView args+  = Just ( mkTyConAppCo r tc args', arg' )++  | not (tyConMustBeSaturated tc)+    -- Never create unsaturated type family apps!+  , Just (args', arg') <- snocView args+  , Just arg'' <- setNominalRole_maybe (tyConRole r tc (length args')) arg'+  = Just ( mkTyConAppCo r tc args', arg'' )+       -- Use mkTyConAppCo to preserve the invariant+       --  that identity coercions are always represented by Refl++splitAppCo_maybe co+  | Just (ty, r) <- isReflCo_maybe co+  , Just (ty1, ty2) <- splitAppTy_maybe ty+  = Just (mkReflCo r ty1, mkNomReflCo ty2)+splitAppCo_maybe _ = Nothing++-- Only used in specialise/Rules+splitFunCo_maybe :: Coercion -> Maybe (Coercion, Coercion)+splitFunCo_maybe (FunCo { fco_arg = arg, fco_res = res }) = Just (arg, res)+splitFunCo_maybe _ = Nothing++splitForAllCo_maybe :: Coercion -> Maybe (TyCoVar, ForAllTyFlag, ForAllTyFlag, Coercion, Coercion)+splitForAllCo_maybe (ForAllCo { fco_tcv = tv, fco_visL = vL, fco_visR = vR+                              , fco_kind = k_co, fco_body = co })+  = Just (tv, vL, vR, k_co, co)+splitForAllCo_maybe co+  | Just (ty, r)        <- isReflCo_maybe co+  , Just (Bndr tcv vis, body_ty) <- splitForAllForAllTyBinder_maybe ty+  = Just (tcv, vis, vis, mkNomReflCo (varType tcv), mkReflCo r body_ty)+splitForAllCo_maybe _ = Nothing++-- | Like 'splitForAllCo_maybe', but only returns Just for tyvar binder+splitForAllCo_ty_maybe :: Coercion -> Maybe (TyVar, ForAllTyFlag, ForAllTyFlag, Coercion, Coercion)+splitForAllCo_ty_maybe co+  | Just stuff@(tv, _, _, _, _) <- splitForAllCo_maybe co+  , isTyVar tv+  = Just stuff+splitForAllCo_ty_maybe _ = Nothing++-- | Like 'splitForAllCo_maybe', but only returns Just for covar binder+splitForAllCo_co_maybe :: Coercion -> Maybe (CoVar, ForAllTyFlag, ForAllTyFlag, Coercion, Coercion)+splitForAllCo_co_maybe co+  | Just stuff@(cv, _, _, _, _) <- splitForAllCo_maybe co+  , isCoVar cv+  = Just stuff+splitForAllCo_co_maybe _ = Nothing++-------------------------------------------------------+-- and some coercion kind stuff++coVarLType, coVarRType :: HasDebugCallStack => CoVar -> Type+coVarLType cv | (ty1, _, _) <- coVarTypesRole cv = ty1+coVarRType cv | (_, ty2, _) <- coVarTypesRole cv = ty2++coVarTypes :: HasDebugCallStack => CoVar -> Pair Type+coVarTypes cv | (ty1, ty2, _) <- coVarTypesRole cv = Pair ty1 ty2++coVarTypesRole :: HasDebugCallStack => CoVar -> (Type,Type,Role)+coVarTypesRole cv+ | Just (tc, [_,_,ty1,ty2]) <- splitTyConApp_maybe (varType cv)+ = (ty1, ty2, eqTyConRole tc)+ | otherwise+ = pprPanic "coVarTypesRole, non coercion variable"+            (ppr cv $$ ppr (varType cv))++coVarKind :: CoVar -> Type+coVarKind cv+  = assert (isCoVar cv )+    varType cv++coVarRole :: CoVar -> Role+coVarRole cv+  = eqTyConRole (case tyConAppTyCon_maybe (varType cv) of+                   Just tc0 -> tc0+                   Nothing  -> pprPanic "coVarRole: not tyconapp" (ppr cv))++eqTyConRole :: TyCon -> Role+-- Given (~#) or (~R#) return the Nominal or Representational respectively+eqTyConRole tc+  | tc `hasKey` eqPrimTyConKey+  = Nominal+  | tc `hasKey` eqReprPrimTyConKey+  = Representational+  | otherwise+  = pprPanic "eqTyConRole: unknown tycon" (ppr tc)++-- | Given a coercion `co :: (t1 :: TYPE r1) ~ (t2 :: TYPE r2)`+-- produce a coercion `rep_co :: r1 ~ r2`+-- But actually it is possible that+--     co :: (t1 :: CONSTRAINT r1) ~ (t2 :: CONSTRAINT r2)+-- or  co :: (t1 :: TYPE r1)       ~ (t2 :: CONSTRAINT r2)+-- or  co :: (t1 :: CONSTRAINT r1) ~ (t2 :: TYPE r2)+-- See Note [mkRuntimeRepCo]+mkRuntimeRepCo :: HasDebugCallStack => Coercion -> Coercion+mkRuntimeRepCo co+  = assert (isTYPEorCONSTRAINT k1 && isTYPEorCONSTRAINT k2) $+    mkSelCo (SelTyCon 0 Nominal) kind_co+  where+    kind_co = mkKindCo co  -- kind_co :: TYPE r1 ~ TYPE r2+    Pair k1 k2 = coercionKind kind_co++{- Note [mkRuntimeRepCo]+~~~~~~~~~~~~~~~~~~~~~~~~+Given+   class C a where { op :: Maybe a }+we will get an axiom+   axC a :: (C a :: CONSTRAINT r1) ~ (Maybe a :: TYPE r2)+(See Note [Type and Constraint are not apart] in GHC.Builtin.Types.Prim.)++Then we may call mkRuntimeRepCo on (axC ty), and that will return+   mkSelCo (SelTyCon 0 Nominal) (Kind (axC ty)) :: r1 ~ r2++So mkSelCo needs to be happy with decomposing a coercion of kind+   CONSTRAINT r1 ~ TYPE r2++Hence the use of `tyConIsTYPEorCONSTRAINT` in the assertion `good_call`+in `mkSelCo`. See #23018 for a concrete example.  (In this context it's+important that TYPE and CONSTRAINT have the same arity and kind, not+merely that they are not-apart; otherwise SelCo would not make sense.)+-}++isReflCoVar_maybe :: Var -> Maybe Coercion+-- If cv :: t~t then isReflCoVar_maybe cv = Just (Refl t)+-- Works on all kinds of Vars, not just CoVars+isReflCoVar_maybe cv+  | isCoVar cv+  , Pair ty1 ty2 <- coVarTypes cv+  , ty1 `eqType` ty2+  = Just (mkReflCo (coVarRole cv) ty1)+  | otherwise+  = Nothing++-- | Tests if this coercion is obviously a generalized reflexive coercion.+-- Guaranteed to work very quickly.+isGReflCo :: Coercion -> Bool+isGReflCo (GRefl{}) = True+isGReflCo (Refl{})  = True -- Refl ty == GRefl N ty MRefl+isGReflCo _         = False++-- | Tests if this coercion is obviously reflexive. Guaranteed to work+-- very quickly. Sometimes a coercion can be reflexive, but not obviously+-- so. c.f. 'isReflexiveCo'+isReflCo :: Coercion -> Bool+isReflCo (Refl{}) = True+isReflCo (GRefl _ _ mco) | isGReflMCo mco = True+isReflCo _ = False++-- | Returns the type coerced if this coercion is a generalized reflexive+-- coercion. Guaranteed to work very quickly.+isGReflCo_maybe :: Coercion -> Maybe (Type, Role)+isGReflCo_maybe (GRefl r ty _) = Just (ty, r)+isGReflCo_maybe (Refl ty)      = Just (ty, Nominal)+isGReflCo_maybe _ = Nothing++-- | Returns the type coerced if this coercion is reflexive. Guaranteed+-- to work very quickly. Sometimes a coercion can be reflexive, but not+-- obviously so. c.f. 'isReflexiveCo_maybe'+isReflCo_maybe :: Coercion -> Maybe (Type, Role)+isReflCo_maybe (Refl ty) = Just (ty, Nominal)+isReflCo_maybe (GRefl r ty mco) | isGReflMCo mco = Just (ty, r)+isReflCo_maybe _ = Nothing++-- | Slowly checks if the coercion is reflexive. Don't call this in a loop,+-- as it walks over the entire coercion.+isReflexiveCo :: Coercion -> Bool+isReflexiveCo = isJust . isReflexiveCo_maybe++-- | Extracts the coerced type from a reflexive coercion. This potentially+-- walks over the entire coercion, so avoid doing this in a loop.+isReflexiveCo_maybe :: Coercion -> Maybe (Type, Role)+isReflexiveCo_maybe (Refl ty) = Just (ty, Nominal)+isReflexiveCo_maybe (GRefl r ty mco) | isGReflMCo mco = Just (ty, r)+isReflexiveCo_maybe co+  | ty1 `eqType` ty2+  = Just (ty1, r)+  | otherwise+  = Nothing+  where (Pair ty1 ty2, r) = coercionKindRole co+++{-+%************************************************************************+%*                                                                      *+            Building coercions+%*                                                                      *+%************************************************************************++These "smart constructors" maintain the invariants listed in the definition+of Coercion, and they perform very basic optimizations.++Note [Role twiddling functions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There are a plethora of functions for twiddling roles:++mkSubCo: Requires a nominal input coercion and always produces a+representational output. This is used when you (the programmer) are sure you+know exactly that role you have and what you want.++downgradeRole_maybe: This function takes both the input role and the output role+as parameters. (The *output* role comes first!) It can only *downgrade* a+role -- that is, change it from N to R or P, or from R to P. This one-way+behavior is why there is the "_maybe". If an upgrade is requested, this+function produces Nothing. This is used when you need to change the role of a+coercion, but you're not sure (as you're writing the code) of which roles are+involved.++This function could have been written using coercionRole to ascertain the role+of the input. But, that function is recursive, and the caller of downgradeRole_maybe+often knows the input role. So, this is more efficient.++downgradeRole: This is just like downgradeRole_maybe, but it panics if the+conversion isn't a downgrade.++setNominalRole_maybe: This is the only function that can *upgrade* a coercion.+The result (if it exists) is always Nominal. The input can be at any role. It+works on a "best effort" basis, as it should never be strictly necessary to+upgrade a coercion during compilation. It is currently only used within GHC in+splitAppCo_maybe. In order to be a proper inverse of mkAppCo, the second+coercion that splitAppCo_maybe returns must be nominal. But, it's conceivable+that splitAppCo_maybe is operating over a TyConAppCo that uses a+representational coercion. Hence the need for setNominalRole_maybe.+splitAppCo_maybe, in turn, is used only within coercion optimization -- thus,+it is not absolutely critical that setNominalRole_maybe be complete.++Note that setNominalRole_maybe will never upgrade a phantom UnivCo. Phantom+UnivCos are perfectly type-safe, whereas representational and nominal ones are+not. (Nominal ones are no worse than representational ones, so this function *will*+change a UnivCo Representational to a UnivCo Nominal.)++Conal Elliott also came across a need for this function while working with the+GHC API, as he was decomposing Core casts. The Core casts use representational+coercions, as they must, but his use case required nominal coercions (he was+building a GADT). So, that's why this function is exported from this module.++One might ask: shouldn't downgradeRole_maybe just use setNominalRole_maybe as+appropriate? I (Richard E.) have decided not to do this, because upgrading a+role is bizarre and a caller should have to ask for this behavior explicitly.++-}++-- | Make a reflexive coercion+mkReflCo :: Role -> Type -> Coercion+mkReflCo Nominal ty = Refl ty+mkReflCo r       ty = GRefl r ty MRefl++-- | Make a representational reflexive coercion+mkRepReflCo :: Type -> Coercion+mkRepReflCo ty = GRefl Representational ty MRefl++-- | Make a nominal reflexive coercion+mkNomReflCo :: Type -> Coercion+mkNomReflCo = Refl++-- | Apply a type constructor to a list of coercions. It is the+-- caller's responsibility to get the roles correct on argument coercions.+mkTyConAppCo :: HasDebugCallStack => Role -> TyCon -> [Coercion] -> Coercion+mkTyConAppCo r tc cos+  | Just co <- tyConAppFunCo_maybe r tc cos+  = co++  -- Expand type synonyms+  | ExpandsSyn tv_co_prs rhs_ty leftover_cos <- expandSynTyCon_maybe tc cos+  = mkAppCos (liftCoSubst r (mkLiftingContext tv_co_prs) rhs_ty) leftover_cos++  | Just tys_roles <- traverse isReflCo_maybe cos+  = mkReflCo r (mkTyConApp tc (map fst tys_roles))+  -- See Note [Refl invariant]++  | otherwise = TyConAppCo r tc cos++mkFunCoNoFTF :: HasDebugCallStack => Role -> CoercionN -> Coercion -> Coercion -> Coercion+-- This version of mkFunCo takes no FunTyFlags; it works them out+mkFunCoNoFTF r w arg_co res_co+  = mkFunCo2 r afl afr w arg_co res_co+  where+    afl = chooseFunTyFlag argl_ty resl_ty+    afr = chooseFunTyFlag argr_ty resr_ty+    Pair argl_ty argr_ty = coercionKind arg_co+    Pair resl_ty resr_ty = coercionKind res_co++-- | Build a function 'Coercion' from two other 'Coercion's. That is,+-- given @co1 :: a ~ b@ and @co2 :: x ~ y@ produce @co :: (a -> x) ~ (b -> y)@+-- or @(a => x) ~ (b => y)@, depending on the kind of @a@/@b@.+-- This (most common) version takes a single FunTyFlag, which is used+--   for both fco_afl and ftf_afr of the FunCo+mkFunCo :: Role -> FunTyFlag -> CoercionN -> Coercion -> Coercion -> Coercion+mkFunCo r af w arg_co res_co+  = mkFunCo2 r af af w arg_co res_co++mkNakedFunCo :: Role -> FunTyFlag -> CoercionN -> Coercion -> Coercion -> Coercion+-- This version of mkFunCo does not check FunCo invariants (checkFunCo)+-- It's a historical vestige; See Note [No assertion check on mkFunCo]+mkNakedFunCo = mkFunCo++mkFunCo2 :: Role -> FunTyFlag -> FunTyFlag+         -> CoercionN -> Coercion -> Coercion -> Coercion+-- This is the smart constructor for FunCo; it checks invariants+mkFunCo2 r afl afr w arg_co res_co+  -- See Note [No assertion check on mkFunCo]+  | Just (ty1, _) <- isReflCo_maybe arg_co+  , Just (ty2, _) <- isReflCo_maybe res_co+  , Just (w, _)   <- isReflCo_maybe w+  = mkReflCo r (mkFunTy afl w ty1 ty2)  -- See Note [Refl invariant]++  | otherwise+  = FunCo { fco_role = r, fco_afl = afl, fco_afr = afr+          , fco_mult = w, fco_arg = arg_co, fco_res = res_co }+++{- Note [No assertion check on mkFunCo]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We used to have a checkFunCo assertion on mkFunCo, but during typechecking+we can (legitimately) have not-full-zonked types or coercion variables, so+the assertion spuriously fails (test T11480b is a case in point).  Lint+checks all these things anyway.++We used to get around the problem by calling mkNakedFunCo from within the+typechecker, which dodged the assertion check.  But then mkAppCo calls+mkTyConAppCo, which calls tyConAppFunCo_maybe, which calls mkFunCo.+Duplicating this stack of calls with "naked" versions of each seems too much.++-- Commented out: see Note [No assertion check on mkFunCo]+checkFunCo :: Role -> FunTyFlag -> FunTyFlag+           -> CoercionN -> Coercion -> Coercion+           -> Maybe SDoc+-- Checks well-formed-ness for FunCo+-- Used only in assertions and Lint+{-# NOINLINE checkFunCo #-}+checkFunCo _r afl afr _w arg_co res_co+  | not (ok argl_ty && ok argr_ty && ok resl_ty && ok resr_ty)+  = Just (hang (text "Bad arg or res types") 2 pp_inputs)++  | afl == computed_afl+  , afr == computed_afr+  = Nothing+  | otherwise+  = Just (vcat [ text "afl (provided,computed):" <+> ppr afl <+> ppr computed_afl+               , text "afr (provided,computed):" <+> ppr afr <+> ppr computed_afr+               , pp_inputs ])+  where+    computed_afl = chooseFunTyFlag argl_ty resl_ty+    computed_afr = chooseFunTyFlag argr_ty resr_ty+    Pair argl_ty argr_ty = coercionKind arg_co+    Pair resl_ty resr_ty = coercionKind res_co++    pp_inputs = vcat [ pp_ty "argl" argl_ty, pp_ty "argr" argr_ty+                     , pp_ty "resl" resl_ty, pp_ty "resr" resr_ty+                     , text "arg_co:" <+> ppr arg_co+                     , text "res_co:" <+> ppr res_co ]++    ok ty = isTYPEorCONSTRAINT (typeKind ty)+    pp_ty str ty = text str <> colon <+> hang (ppr ty)+                                            2 (dcolon <+> ppr (typeKind ty))+-}++-- | Apply a 'Coercion' to another 'Coercion'.+-- The second coercion must be Nominal, unless the first is Phantom.+-- If the first is Phantom, then the second can be either Phantom or Nominal.+mkAppCo :: Coercion     -- ^ :: t1 ~r t2+        -> Coercion     -- ^ :: s1 ~N s2, where s1 :: k1, s2 :: k2+        -> Coercion     -- ^ :: t1 s1 ~r t2 s2+mkAppCo co arg+  | Just (ty1, r) <- isReflCo_maybe co+  , Just (ty2, _) <- isReflCo_maybe arg+  = mkReflCo r (mkAppTy ty1 ty2)++  | Just (ty1, r) <- isReflCo_maybe co+  , Just (tc, tys) <- splitTyConApp_maybe ty1+    -- Expand type synonyms; a TyConAppCo can't have a type synonym (#9102)+  = mkTyConAppCo r tc (zip_roles (tyConRolesX r tc) tys)+  where+    zip_roles (Inf r1 _)  []            = [downgradeRole r1 Nominal arg]+    zip_roles (Inf r1 rs) (ty1:tys)     = mkReflCo r1 ty1 : zip_roles rs tys++mkAppCo (TyConAppCo r tc args) arg+  = case r of+      Nominal          -> mkTyConAppCo Nominal tc (args ++ [arg])+      Representational -> mkTyConAppCo Representational tc (args ++ [arg'])+        where new_role = tyConRolesRepresentational tc Inf.!! length args+              arg'     = downgradeRole new_role Nominal arg+      Phantom          -> mkTyConAppCo Phantom tc (args ++ [toPhantomCo arg])+mkAppCo co arg = AppCo co  arg+-- Note, mkAppCo is careful to maintain invariants regarding+-- where Refl constructors appear; see the comments in the definition+-- of Coercion and the Note [Refl invariant] in GHC.Core.TyCo.Rep.++-- | Applies multiple 'Coercion's to another 'Coercion', from left to right.+-- See also 'mkAppCo'.+mkAppCos :: Coercion+         -> [Coercion]+         -> Coercion+mkAppCos co1 cos = foldl' mkAppCo co1 cos+++-- | Make a Coercion from a tycovar, a kind coercion, and a body coercion.+mkForAllCo :: HasDebugCallStack => TyCoVar -> ForAllTyFlag -> ForAllTyFlag -> CoercionN -> Coercion -> Coercion+mkForAllCo v visL visR kind_co co+  | Just (ty, r) <- isReflCo_maybe co+  , isReflCo kind_co+  , visL `eqForAllVis` visR+  = mkReflCo r (mkTyCoForAllTy v visL ty)++  | otherwise+  = mkForAllCo_NoRefl v visL visR kind_co co++-- mkForAllVisCos [tv{vis}] constructs a cast+--   forall tv. res  ~R#   forall tv{vis} res`.+-- See Note [Required foralls in Core] in GHC.Core.TyCo.Rep+mkForAllVisCos :: HasDebugCallStack => [ForAllTyBinder] -> Coercion -> Coercion+mkForAllVisCos bndrs orig_co = foldr go orig_co bndrs+  where+    go (Bndr tv vis)+      = mkForAllCo tv coreTyLamForAllTyFlag vis (mkNomReflCo (varType tv))++-- | Make a Coercion quantified over a type/coercion variable;+-- the variable has the same kind and visibility in both sides of the coercion+mkHomoForAllCos :: [ForAllTyBinder] -> Coercion -> Coercion+mkHomoForAllCos vs orig_co+  | Just (ty, r) <- isReflCo_maybe orig_co+  = mkReflCo r (mkTyCoForAllTys vs ty)+  | otherwise+  = foldr go orig_co vs+  where+    go (Bndr var vis) co+      = mkForAllCo_NoRefl var vis vis (mkNomReflCo (varType var)) co++-- | Like 'mkForAllCo', but there is no need to check that the inner coercion isn't Refl;+--   the caller has done that. (For example, it is guaranteed in 'mkHomoForAllCos'.)+-- The kind of the tycovar should be the left-hand kind of the kind coercion.+mkForAllCo_NoRefl :: TyCoVar -> ForAllTyFlag -> ForAllTyFlag -> CoercionN -> Coercion -> Coercion+mkForAllCo_NoRefl tcv visL visR kind_co co+  = assertGoodForAllCo tcv visL visR kind_co co $+    assertPpr (not (isReflCo co && isReflCo kind_co && visL == visR)) (ppr co) $+    ForAllCo { fco_tcv = tcv, fco_visL = visL, fco_visR = visR+             , fco_kind = kind_co, fco_body = co }++assertGoodForAllCo :: HasDebugCallStack+                   =>  TyCoVar -> ForAllTyFlag -> ForAllTyFlag+                   -> CoercionN -> Coercion -> a -> a+-- Check ForAllCo invariants; see Note [ForAllCo] in GHC.Core.TyCo.Rep+assertGoodForAllCo tcv visL visR kind_co co+  | isTyVar tcv+  = assertPpr (tcv_type `eqType` kind_co_lkind) doc++  | otherwise+  = assertPpr (tcv_type `eqType` kind_co_lkind) doc+        -- The kind of the tycovar should be the left-hand kind of the kind coercion.+  . assertPpr (almostDevoidCoVarOfCo tcv co) doc+        -- See (FC6) in Note [ForAllCo] in GHC.Core.TyCo.Rep+  . assertPpr (visL == coreTyLamForAllTyFlag+            && visR == coreTyLamForAllTyFlag) doc+        -- See (FC7) in Note [ForAllCo] in GHC.Core.TyCo.Rep+  where+    tcv_type      = varType tcv+    kind_co_lkind = coercionLKind kind_co++    doc = vcat [ text "Var:" <+> ppr tcv <+> dcolon <+> ppr tcv_type+               , text "Vis:" <+> ppr visL <+> ppr visR+               , text "kind_co:" <+> ppr kind_co+               , text "kind_co_lkind" <+> ppr kind_co_lkind+               , text "body_co" <+> ppr co ]+++mkNakedForAllCo :: TyVar    -- Never a CoVar+                -> ForAllTyFlag -> ForAllTyFlag+                -> CoercionN -> Coercion -> Coercion+-- This version lacks the assertion checks.+-- Used during type checking when the arguments may (legitimately) not be zonked+-- and so the assertions might (bogusly) fail+-- NB: since the coercions are un-zonked, we can't really deal with+--     (FC6) and (FC7) in Note [ForAllCo] in GHC.Core.TyCo.Rep.+--     Fortunately we don't have to: this function is needed only for /type/ variables.+mkNakedForAllCo tv visL visR kind_co co+  | assertPpr (isTyVar tv) (ppr tv) True+  , Just (ty, r) <- isReflCo_maybe co+  , isReflCo kind_co+  , visL `eqForAllVis` visR+  = mkReflCo r (mkForAllTy (Bndr tv visL) ty)+  | otherwise+  = ForAllCo { fco_tcv = tv, fco_visL = visL, fco_visR = visR+             , fco_kind = kind_co, fco_body = co }+++mkCoVarCo :: CoVar -> Coercion+-- cv :: s ~# t+-- See Note [mkCoVarCo]+mkCoVarCo cv = CoVarCo cv++mkCoVarCos :: [CoVar] -> [Coercion]+mkCoVarCos = map mkCoVarCo++{- Note [mkCoVarCo]+~~~~~~~~~~~~~~~~~~~+In the past, mkCoVarCo optimised (c :: t~t) to (Refl t).  That is+valid (although see Note [Unbound RULE binders] in GHC.Core.Rules), but+it's a relatively expensive test and perhaps better done in+optCoercion.  Not a big deal either way.+-}++mkAxInstCo :: Role+           -> CoAxiomRule   -- Always BranchedAxiom or UnbranchedAxiom+           -> [Type] -> [Coercion]+           -> Coercion+-- mkAxInstCo can legitimately be called over-saturated;+-- i.e. with more type arguments than the coercion requires+-- Only called with BranchedAxiom or UnbranchedAxiom+mkAxInstCo role axr tys cos+  | arity == n_tys = downgradeRole role ax_role $+                     AxiomCo axr (rtys `chkAppend` cos)+  | otherwise      = assert (arity < n_tys) $+                     downgradeRole role ax_role $+                     mkAppCos (AxiomCo axr (ax_args `chkAppend` cos))+                              leftover_args+  where+    (ax_role, branch)        = case coAxiomRuleBranch_maybe axr of+                                  Just (_tc, ax_role, branch) -> (ax_role, branch)+                                  Nothing -> pprPanic "mkAxInstCo" (ppr axr)+    n_tys                    = length tys+    arity                    = length (coAxBranchTyVars branch)+    arg_roles                = coAxBranchRoles branch+    rtys                     = zipWith mkReflCo (arg_roles ++ repeat Nominal) tys+    (ax_args, leftover_args) = splitAt arity rtys++-- worker function+mkAxiomCo :: CoAxiomRule -> [Coercion] -> Coercion+mkAxiomCo = AxiomCo++-- to be used only with unbranched axioms+mkUnbranchedAxInstCo :: Role -> CoAxiom Unbranched+                     -> [Type] -> [Coercion] -> Coercion+mkUnbranchedAxInstCo role ax tys cos+  = mkAxInstCo role (UnbranchedAxiom ax) tys cos++mkAxInstRHS :: CoAxiom br -> BranchIndex -> [Type] -> [Coercion] -> Type+-- Instantiate the axiom with specified types,+-- returning the instantiated RHS+-- A companion to mkAxInstCo:+--    mkAxInstRhs ax index tys = snd (coercionKind (mkAxInstCo ax index tys))+mkAxInstRHS ax index tys cos+  = assert (tvs `equalLength` tys1) $+    mkAppTys rhs' tys2+  where+    branch       = coAxiomNthBranch ax index+    tvs          = coAxBranchTyVars branch+    cvs          = coAxBranchCoVars branch+    (tys1, tys2) = splitAtList tvs tys+    rhs'         = substTyWith tvs tys1 $+                   substTyWithCoVars cvs cos $+                   coAxBranchRHS branch++mkUnbranchedAxInstRHS :: CoAxiom Unbranched -> [Type] -> [Coercion] -> Type+mkUnbranchedAxInstRHS ax = mkAxInstRHS ax 0++-- | Return the left-hand type of the axiom, when the axiom is instantiated+-- at the types given.+mkAxInstLHS :: CoAxiom br -> BranchIndex -> [Type] -> [Coercion] -> Type+mkAxInstLHS ax index tys cos+  = assert (tvs `equalLength` tys1) $+    mkTyConApp fam_tc (lhs_tys `chkAppend` tys2)+  where+    branch       = coAxiomNthBranch ax index+    tvs          = coAxBranchTyVars branch+    cvs          = coAxBranchCoVars branch+    (tys1, tys2) = splitAtList tvs tys+    lhs_tys      = substTysWith tvs tys1 $+                   substTysWithCoVars cvs cos $+                   coAxBranchLHS branch+    fam_tc       = coAxiomTyCon ax++-- | Instantiate the left-hand side of an unbranched axiom+mkUnbranchedAxInstLHS :: CoAxiom Unbranched -> [Type] -> [Coercion] -> Type+mkUnbranchedAxInstLHS ax = mkAxInstLHS ax 0++-- | Make a coercion from a coercion hole+mkHoleCo :: CoercionHole -> Coercion+mkHoleCo h = HoleCo h++-- | Make a universal coercion between two arbitrary types.+mkUnivCo :: UnivCoProvenance+         -> [Coercion] -- ^ Coercions on which this depends+         -> Role       -- ^ role of the built coercion, "r"+         -> Type       -- ^ t1 :: k1+         -> Type       -- ^ t2 :: k2+         -> Coercion   -- ^ :: t1 ~r t2+mkUnivCo prov deps role ty1 ty2+  | ty1 `eqType` ty2 = mkReflCo role ty1+  | otherwise        = UnivCo { uco_prov = prov, uco_role = role+                              , uco_lty = ty1, uco_rty = ty2+                              , uco_deps = deps }++-- | Create a symmetric version of the given 'Coercion' that asserts+--   equality between the same types but in the other "direction", so+--   a kind of @t1 ~ t2@ becomes the kind @t2 ~ t1@.+mkSymCo :: Coercion -> Coercion++-- Do a few simple optimizations, mainly to expose the underlying+-- constructors to other 'mk' functions.  E.g.+--   mkInstCo (mkSymCo (ForAllCo ...)) ty+-- We want to push the SymCo inside the ForallCo, so that we can instantiate+-- This can make a big difference.  E.g without coercion optimisation, GHC.Read+-- totally explodes; but when we push Sym inside ForAll, it's fine.+mkSymCo co | isReflCo co   = co+mkSymCo (SymCo co)         = co+mkSymCo (SubCo (SymCo co)) = SubCo co+mkSymCo co@(ForAllCo { fco_kind = kco, fco_body = body_co })+  | isReflCo kco           = co { fco_body = mkSymCo body_co }+mkSymCo co                 = SymCo co++-- | mkTransCo creates a new 'Coercion' by composing the two+--   given 'Coercion's transitively: (co1 ; co2)+mkTransCo :: HasDebugCallStack => Coercion -> Coercion -> Coercion+mkTransCo co1 co2+   | isReflCo co1 = co2+   | isReflCo co2 = co1++   | GRefl r t1 (MCo kco1) <- co1+   , GRefl _ _  (MCo kco2) <- co2+   = GRefl r t1 (MCo $ mkTransCo kco1 kco2)++   | otherwise+   = TransCo co1 co2++--------------------+{- Note [mkSelCo precondition]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+To satisfy the Purely Kinded Type Invariant (PKTI), we require that+  in any call (mkSelCo cs co)+  * selectFromType cs (coercionLKind co) works+  * selectFromType cs (coercionRKind co) works+  * and hence coercionKind (SelCo cs co) works (PKTI)+-}++mkSelCo :: HasDebugCallStack+        => CoSel+        -> Coercion+        -> Coercion+-- See Note [mkSelCo precondition]+mkSelCo n co = mkSelCo_maybe n co `orElse` SelCo n co++mkSelCo_maybe :: HasDebugCallStack+        => CoSel+        -> Coercion+        -> Maybe Coercion+-- Note [mkSelCo precondition]+mkSelCo_maybe cs co+  = assertPpr (good_call cs) bad_call_msg $+    go cs co+  where++    go SelForAll (ForAllCo { fco_kind = kind_co })+      = Just kind_co+      -- If co :: (forall a1:k1. t1) ~ (forall a2:k2. t2)+      -- then (nth SelForAll co :: k1 ~N k2)+      -- If co :: (forall a1:t1 ~ t2. t1) ~ (forall a2:t3 ~ t4. t2)+      -- then (nth SelForAll co :: (t1 ~ t2) ~N (t3 ~ t4))++    go (SelFun fs) (FunCo _ _ _ w arg res)+      = Just (getNthFun fs w arg res)++    go (SelTyCon i r) (TyConAppCo r0 tc arg_cos)+      = assertPpr (r == tyConRole r0 tc i)+                  (vcat [ ppr tc, ppr arg_cos, ppr r0, ppr i, ppr r ]) $+        Just (arg_cos `getNth` i)++    go cs (SymCo co)  -- Recurse, hoping to get to a TyConAppCo or FunCo+      = do { co' <- go cs co; return (mkSymCo co') }++    go cs co+      | Just (ty, co_role) <- isReflCo_maybe co+      = Just (mkReflCo (mkSelCoResRole cs co_role) (selectFromType cs ty))+        -- mkSelCoreResRole: The role of the result may not be+        -- be equal to co_role, the role of co, per Note [SelCo].+        -- This was revealed by #23938.++      | Pair ty1 ty2 <- coercionKind co+      , let sty1    = selectFromType cs ty1+            sty2    = selectFromType cs ty2+            co_role = coercionRole co+      , sty1 `eqType` sty2+      = Just (mkReflCo (mkSelCoResRole cs co_role) sty1)+            -- Checking for fully reflexive-ness (by seeing if sty1=sty2)+            -- is worthwhile, because a non-Refl coercion `co` may well have a+            -- reflexive (SelCo cs co).+            -- E.g. co :: Either a b ~ Either a c+            --      Then (SubCo (SelTyCon 0) co) is reflexive++      | otherwise = Nothing++    ----------- Assertion checking --------------+    -- NB: using coercionKind requires Note [mkSelCo precondition]+    Pair ty1 ty2 = coercionKind co+    bad_call_msg = vcat [ text "Coercion =" <+> ppr co+                        , text "LHS ty =" <+> ppr ty1+                        , text "RHS ty =" <+> ppr ty2+                        , text "cs =" <+> ppr cs+                        , text "coercion role =" <+> ppr (coercionRole co) ]++    -- good_call checks the typing rules given in Note [SelCo]+    good_call SelForAll+      | Just (_tv1, _) <- splitForAllTyCoVar_maybe ty1+      , Just (_tv2, _) <- splitForAllTyCoVar_maybe ty2+      =  True++    good_call (SelFun {})+       = isFunTy ty1 && isFunTy ty2++    good_call (SelTyCon n r)+       | Just (tc1, tys1) <- splitTyConApp_maybe ty1+       , Just (tc2, tys2) <- splitTyConApp_maybe ty2+       , let { len1 = length tys1+             ; len2 = length tys2 }+       =  (tc1 == tc2 || (tyConIsTYPEorCONSTRAINT tc1 && tyConIsTYPEorCONSTRAINT tc2))+                      -- tyConIsTYPEorCONSTRAINT: see Note [mkRuntimeRepCo]+       && len1 == len2+       && n < len1+       && r == tyConRole (coercionRole co) tc1 n++    good_call _ = False++mkSelCoResRole :: CoSel -> Role -> Role+-- What is the role of (SelCo cs co), if co has role 'r'?+-- It is not just 'r'!+-- c.f. the SelCo case of coercionRole+mkSelCoResRole SelForAll       _ = Nominal+mkSelCoResRole (SelTyCon _ r') _ = r'+mkSelCoResRole (SelFun fs)     r = funRole r fs++-- | Extract the nth field of a FunCo+getNthFun :: FunSel+          -> a    -- ^ multiplicity+          -> a    -- ^ argument+          -> a    -- ^ result+          -> a    -- ^ One of the above three+getNthFun SelMult mult _   _   = mult+getNthFun SelArg _     arg _   = arg+getNthFun SelRes _     _   res = res++selectFromType :: HasDebugCallStack => CoSel -> Type -> Type+selectFromType (SelFun fs) ty+  | Just (_af, mult, arg, res) <- splitFunTy_maybe ty+  = getNthFun fs mult arg res++selectFromType (SelTyCon n _) ty+  | Just args <- tyConAppArgs_maybe ty+  = assertPpr (args `lengthExceeds` n) (ppr n $$ ppr ty) $+    args `getNth` n++selectFromType SelForAll ty       -- Works for both tyvar and covar+  | Just (tv,_) <- splitForAllTyCoVar_maybe ty+  = tyVarKind tv++selectFromType cs ty+  = pprPanic "selectFromType" (ppr cs $$ ppr ty)++--------------------+mkLRCo :: LeftOrRight -> Coercion -> Coercion+mkLRCo lr co+  | Just (ty, eq) <- isReflCo_maybe co+  = mkReflCo eq (pickLR lr (splitAppTy ty))+  | otherwise+  = LRCo lr co++-- | Instantiates a 'Coercion'.+-- Works for both tyvar and covar+mkInstCo :: Coercion -> CoercionN -> Coercion+mkInstCo co_fun co_arg+  | Just (tcv, _, _, kind_co, body_co) <- splitForAllCo_maybe co_fun+  , Just (arg, _) <- isReflCo_maybe co_arg+  = assertPpr (isReflexiveCo kind_co) (ppr co_fun $$ ppr co_arg) $+       -- If the arg is Refl, then kind_co must be reflexive too+    substCoUnchecked (zipTCvSubst [tcv] [arg]) body_co+mkInstCo co arg = InstCo co arg++-- | Given @ty :: k1@, @co :: k1 ~ k2@,+-- produces @co' :: ty ~r (ty |> co)@+mkGReflRightCo :: Role -> Type -> CoercionN -> Coercion+mkGReflRightCo r ty co+  | isGReflCo co = mkReflCo r ty+    -- the kinds of @k1@ and @k2@ are the same, thus @isGReflCo@+    -- instead of @isReflCo@+  | otherwise = mkGReflMCo r ty co++-- | Given @r@, @ty :: k1@, and @co :: k1 ~N k2@,+-- produces @co' :: (ty |> co) ~r ty@+mkGReflLeftCo :: Role -> Type -> CoercionN -> Coercion+mkGReflLeftCo r ty co+  | isGReflCo co = mkReflCo r ty+    -- the kinds of @k1@ and @k2@ are the same, thus @isGReflCo@+    -- instead of @isReflCo@+  | otherwise    = mkSymCo $ mkGReflMCo r ty co++-- | Given @ty :: k1@, @co :: k1 ~ k2@, @co2:: ty ~r ty'@,+-- produces @co' :: (ty |> co) ~r ty'+-- It is not only a utility function, but it saves allocation when co+-- is a GRefl coercion.+mkCoherenceLeftCo :: Role -> Type -> CoercionN -> Coercion -> Coercion+mkCoherenceLeftCo r ty co co2+  | isGReflCo co = co2+  | otherwise    = (mkSymCo $ mkGReflMCo r ty co) `mkTransCo` co2++-- | Given @ty :: k1@, @co :: k1 ~ k2@, @co2:: ty' ~r ty@,+-- produces @co' :: ty' ~r (ty |> co)+-- It is not only a utility function, but it saves allocation when co+-- is a GRefl coercion.+mkCoherenceRightCo :: HasDebugCallStack => Role -> Type -> CoercionN -> Coercion -> Coercion+mkCoherenceRightCo r ty co co2+  | isGReflCo co = co2+  | otherwise    = co2 `mkTransCo` mkGReflMCo r ty co++-- | Given @co :: (a :: k) ~ (b :: k')@ produce @co' :: k ~ k'@.+mkKindCo :: Coercion -> Coercion+mkKindCo co | Just (ty, _) <- isReflCo_maybe co = Refl (typeKind ty)+mkKindCo (GRefl _ _ (MCo co)) = co+mkKindCo co+  | Pair ty1 ty2 <- coercionKind co+       -- Generally, calling coercionKind during coercion creation is a bad idea,+       -- as it can lead to exponential behavior. But, we don't have nested mkKindCos,+       -- so it's OK here.+  , let tk1 = typeKind ty1+        tk2 = typeKind ty2+  , tk1 `eqType` tk2+  = Refl tk1+  | otherwise+  = KindCo co++mkSubCo :: HasDebugCallStack => Coercion -> Coercion+-- Input coercion is Nominal, result is Representational+-- see also Note [Role twiddling functions]+mkSubCo (Refl ty) = GRefl Representational ty MRefl+mkSubCo (GRefl Nominal ty co) = GRefl Representational ty co+mkSubCo (TyConAppCo Nominal tc cos)+  = TyConAppCo Representational tc (applyRoles tc cos)+mkSubCo co@(FunCo { fco_role = Nominal, fco_arg = arg, fco_res = res })+  = co { fco_role = Representational+       , fco_arg = downgradeRole Representational Nominal arg+       , fco_res = downgradeRole Representational Nominal res }+mkSubCo co = assertPpr (coercionRole co == Nominal) (ppr co <+> ppr (coercionRole co)) $+             SubCo co++-- | Changes a role, but only a downgrade. See Note [Role twiddling functions]+downgradeRole_maybe :: Role   -- ^ desired role+                    -> Role   -- ^ current role+                    -> Coercion -> Maybe Coercion+-- In (downgradeRole_maybe dr cr co) it's a precondition that+--                                   cr = coercionRole co++downgradeRole_maybe Nominal          Nominal          co = Just co+downgradeRole_maybe Nominal          _                _  = Nothing++downgradeRole_maybe Representational Nominal          co = Just (mkSubCo co)+downgradeRole_maybe Representational Representational co = Just co+downgradeRole_maybe Representational Phantom          _  = Nothing++downgradeRole_maybe Phantom          Phantom          co = Just co+downgradeRole_maybe Phantom          _                co = Just (toPhantomCo co)++-- | Like 'downgradeRole_maybe', but panics if the change isn't a downgrade.+-- See Note [Role twiddling functions]+downgradeRole :: Role  -- desired role+              -> Role  -- current role+              -> Coercion -> Coercion+downgradeRole r1 r2 co+  = case downgradeRole_maybe r1 r2 co of+      Just co' -> co'+      Nothing  -> pprPanic "downgradeRole" (ppr co)++-- | Make a "coercion between coercions".+mkProofIrrelCo :: Role       -- ^ role of the created coercion, "r"+               -> CoercionN  -- ^ :: phi1 ~N phi2+               -> Coercion   -- ^ g1 :: phi1+               -> Coercion   -- ^ g2 :: phi2+               -> Coercion   -- ^ :: g1 ~r g2++-- if the two coercion prove the same fact, I just don't care what+-- the individual coercions are.+mkProofIrrelCo r co g  _ | isGReflCo co  = mkReflCo r (mkCoercionTy g)+  -- kco is a kind coercion, thus @isGReflCo@ rather than @isReflCo@+mkProofIrrelCo r kco g1 g2 = mkUnivCo ProofIrrelProv [kco] r+                                      (mkCoercionTy g1) (mkCoercionTy g2)++{-+%************************************************************************+%*                                                                      *+   Roles+%*                                                                      *+%************************************************************************+-}++-- | Converts a coercion to be nominal, if possible.+-- See Note [Role twiddling functions]+setNominalRole_maybe :: Role -- of input coercion+                     -> Coercion -> Maybe CoercionN+setNominalRole_maybe r co+  | r == Nominal = Just co+  | otherwise = setNominalRole_maybe_helper co+  where+    setNominalRole_maybe_helper (SubCo co)  = Just co+    setNominalRole_maybe_helper co@(Refl _) = Just co+    setNominalRole_maybe_helper (GRefl _ ty co) = Just $ GRefl Nominal ty co+    setNominalRole_maybe_helper (TyConAppCo Representational tc cos)+      = do { cos' <- zipWithM setNominalRole_maybe (tyConRoleListX Representational tc) cos+           ; return $ TyConAppCo Nominal tc cos' }+    setNominalRole_maybe_helper co@(FunCo { fco_role = Representational+                                          , fco_arg = co1, fco_res = co2 })+      = do { co1' <- setNominalRole_maybe Representational co1+           ; co2' <- setNominalRole_maybe Representational co2+           ; return $ co { fco_role = Nominal, fco_arg = co1', fco_res = co2' }+           }+    setNominalRole_maybe_helper (SymCo co)+      = SymCo <$> setNominalRole_maybe_helper co+    setNominalRole_maybe_helper (TransCo co1 co2)+      = TransCo <$> setNominalRole_maybe_helper co1 <*> setNominalRole_maybe_helper co2+    setNominalRole_maybe_helper (AppCo co1 co2)+      = AppCo <$> setNominalRole_maybe_helper co1 <*> pure co2+    setNominalRole_maybe_helper co@(ForAllCo { fco_visL = visL, fco_visR = visR, fco_body = body_co })+      | visL `eqForAllVis` visR -- See (FC3) in Note [ForAllCo] in GHC.Core.TyCo.Rep+      = do { body_co' <- setNominalRole_maybe_helper body_co+           ; return (co { fco_body = body_co' }) }+    setNominalRole_maybe_helper (SelCo cs co) =+      -- NB, this case recurses via setNominalRole_maybe, not+      -- setNominalRole_maybe_helper!+      case cs of+        SelTyCon n _r ->+          -- Remember to update the role in SelTyCon to nominal;+          -- not doing this caused #23362.+          -- See the typing rule in Note [SelCo] in GHC.Core.TyCo.Rep.+          SelCo (SelTyCon n Nominal) <$> setNominalRole_maybe (coercionRole co) co+        SelFun fs ->+          SelCo (SelFun fs) <$> setNominalRole_maybe (coercionRole co) co+        SelForAll ->+          pprPanic "setNominalRole_maybe: the coercion should already be nominal" (ppr co)+    setNominalRole_maybe_helper (InstCo co arg)+      = InstCo <$> setNominalRole_maybe_helper co <*> pure arg+    setNominalRole_maybe_helper co@(UnivCo { uco_prov = prov })+      | case prov of PhantomProv {}    -> False  -- should always be phantom+                     ProofIrrelProv {} -> True   -- it's always safe+                     PluginProv {}     -> False  -- who knows? This choice is conservative.+      = Just $ co { uco_role = Nominal }+    setNominalRole_maybe_helper _ = Nothing++-- | Make a phantom coercion between two types. The coercion passed+-- in must be a nominal coercion between the kinds of the+-- types.+mkPhantomCo :: Coercion -> Type -> Type -> Coercion+mkPhantomCo h t1 t2+  = mkUnivCo PhantomProv [h] Phantom t1 t2++-- takes any coercion and turns it into a Phantom coercion+toPhantomCo :: Coercion -> Coercion+toPhantomCo co+  = mkPhantomCo (mkKindCo co) ty1 ty2+  where Pair ty1 ty2 = coercionKind co++-- Convert args to a TyConAppCo Nominal to the same TyConAppCo Representational+applyRoles :: TyCon -> [Coercion] -> [Coercion]+applyRoles = zipWith (`downgradeRole` Nominal) . tyConRoleListRepresentational++-- The Role parameter is the Role of the TyConAppCo+-- defined here because this is intimately concerned with the implementation+-- of TyConAppCo+-- Always returns an infinite list (with a infinite tail of Nominal)+tyConRolesX :: Role -> TyCon -> Infinite Role+tyConRolesX Representational tc = tyConRolesRepresentational tc+tyConRolesX role             _  = Inf.repeat role++tyConRoleListX :: Role -> TyCon -> [Role]+tyConRoleListX role = Inf.toList . tyConRolesX role++-- Returns the roles of the parameters of a tycon, with an infinite tail+-- of Nominal+tyConRolesRepresentational :: TyCon -> Infinite Role+tyConRolesRepresentational tc = tyConRoles tc Inf.++ Inf.repeat Nominal++-- Returns the roles of the parameters of a tycon, with an infinite tail+-- of Nominal+tyConRoleListRepresentational :: TyCon -> [Role]+tyConRoleListRepresentational = Inf.toList . tyConRolesRepresentational++tyConRole :: Role -> TyCon -> Int -> Role+tyConRole Nominal          _  _ = Nominal+tyConRole Phantom          _  _ = Phantom+tyConRole Representational tc n = tyConRolesRepresentational tc Inf.!! n++funRole :: Role -> FunSel -> Role+funRole Nominal          _  = Nominal+funRole Phantom          _  = Phantom+funRole Representational fs = funRoleRepresentational fs++funRoleRepresentational :: FunSel -> Role+funRoleRepresentational SelMult = Nominal+funRoleRepresentational SelArg  = Representational+funRoleRepresentational SelRes  = Representational++ltRole :: Role -> Role -> Bool+-- Is one role "less" than another?+--     Nominal < Representational < Phantom+ltRole Phantom          _       = False+ltRole Representational Phantom = True+ltRole Representational _       = False+ltRole Nominal          Nominal = False+ltRole Nominal          _       = True++-------------------------------++-- | like mkKindCo, but aggressively & recursively optimizes to avoid using+-- a KindCo constructor. The output role is nominal.+promoteCoercion :: HasDebugCallStack => Coercion -> CoercionN++-- First cases handles anything that should yield refl.+promoteCoercion co = case co of++    Refl _ -> mkNomReflCo ki1++    GRefl _ _ MRefl -> mkNomReflCo ki1++    GRefl _ _ (MCo co) -> co++    _ | ki1 `eqType` ki2+      -> mkNomReflCo (typeKind ty1)+     -- No later branch should return refl+     -- The assert (False )s throughout+     -- are these cases explicitly, but they should never fire.++    TyConAppCo _ tc args+      | Just co' <- instCoercions (mkNomReflCo (tyConKind tc)) args+      -> co'+      | otherwise+      -> mkKindCo co++    AppCo co1 arg+      | Just co' <- instCoercion (coercionKind (mkKindCo co1))+                                 (promoteCoercion co1) arg+      -> co'+      | otherwise+      -> mkKindCo co++    ForAllCo { fco_tcv = tv, fco_body = g }+      | isTyVar tv+      -> promoteCoercion g++    ForAllCo {}+      -> assert False $+            -- (ForAllCo {} :: (forall cv.t1) ~ (forall cv.t2)+            -- The tyvar case is handled above, so the bound var is a+            -- a coercion variable. So both sides have kind Type+            -- (Note [Weird typing rule for ForAllTy] in GHC.Core.TyCo.Rep).+            -- So the result is Refl, and that should have been caught by+            -- the first equation above.  Hence `assert False`+         mkNomReflCo liftedTypeKind++    FunCo {} -> mkKindCo co+       -- We can get Type~Constraint or Constraint~Type+       -- from FunCo {} :: (a -> (b::Type)) ~ (a -=> (b'::Constraint))++    CoVarCo {} -> mkKindCo co+    HoleCo {}  -> mkKindCo co+    AxiomCo {} -> mkKindCo co+    UnivCo {}  -> mkKindCo co  -- We could instead return the (single) `uco_deps` coercion in+                               -- the `ProofIrrelProv` and `PhantomProv` cases, but it doesn't+                               -- quite seem worth doing.++    SymCo g+      -> mkSymCo (promoteCoercion g)++    TransCo co1 co2+      -> mkTransCo (promoteCoercion co1) (promoteCoercion co2)++    SelCo n co1+      | Just co' <- mkSelCo_maybe n co1+      -> promoteCoercion co'++      | otherwise+      -> mkKindCo co++    LRCo lr co1+      | Just (lco, rco) <- splitAppCo_maybe co1+      -> case lr of+           CLeft  -> promoteCoercion lco+           CRight -> promoteCoercion rco++      | otherwise+      -> mkKindCo co++    InstCo g _+      | isForAllTy_ty ty1+      -> assert (isForAllTy_ty ty2) $+         promoteCoercion g+      | otherwise+      -> assert False $+         mkNomReflCo liftedTypeKind+           -- See Note [Weird typing rule for ForAllTy] in GHC.Core.TyCo.Rep++    KindCo _+      -> assert False $ -- See the first equation above+         mkNomReflCo liftedTypeKind++    SubCo g+      -> promoteCoercion g++  where+    Pair ty1 ty2 = coercionKind co+    ki1 = typeKind ty1+    ki2 = typeKind ty2++-- | say @g = promoteCoercion h@. Then, @instCoercion g w@ yields @Just g'@,+-- where @g' = promoteCoercion (h w)@.+-- fails if this is not possible, if @g@ coerces between a forall and an ->+-- or if second parameter has a representational role and can't be used+-- with an InstCo.+instCoercion :: Pair Type -- g :: lty ~ rty+             -> CoercionN  -- ^  must be nominal+             -> Coercion+             -> Maybe CoercionN+instCoercion (Pair lty rty) g w+  | (isForAllTy_ty lty && isForAllTy_ty rty)+  || (isForAllTy_co lty && isForAllTy_co rty)+  , Just w' <- setNominalRole_maybe (coercionRole w) w+    -- g :: (forall t1. t2) ~ (forall t1. t3)+    -- w :: s1 ~ s2+    -- returns mkInstCo g w' :: t2 [t1 |-> s1 ] ~ t3 [t1 |-> s2]+  = Just $ mkInstCo g w'++  | isFunTy lty && isFunTy rty+    -- g :: (t1 -> t2) ~ (t3 -> t4)+    -- returns t2 ~ t4+  = Just $ mkSelCo (SelFun SelRes) g -- extract result type++  | otherwise -- one forall, one funty...+  = Nothing++-- | Repeated use of 'instCoercion'+instCoercions :: CoercionN -> [Coercion] -> Maybe CoercionN+instCoercions g ws+  = let arg_ty_pairs = map coercionKind ws in+    snd <$> foldM go (coercionKind g, g) (zip arg_ty_pairs ws)+  where+    go :: (Pair Type, Coercion) -> (Pair Type, Coercion)+       -> Maybe (Pair Type, Coercion)+    go (g_tys, g) (w_tys, w)+      = do { g' <- instCoercion g_tys g w+           ; return (piResultTy <$> g_tys <*> w_tys, g') }++-- | Creates a new coercion with both of its types casted by different casts+-- @castCoercionKind2 g r t1 t2 h1 h2@, where @g :: t1 ~r t2@,+-- has type @(t1 |> h1) ~r (t2 |> h2)@.+-- @h1@ and @h2@ must be nominal.+castCoercionKind2 :: Coercion -> Role -> Type -> Type+                 -> CoercionN -> CoercionN -> Coercion+castCoercionKind2 g r t1 t2 h1 h2+  = mkCoherenceRightCo r t2 h2 (mkCoherenceLeftCo r t1 h1 g)++-- | @castCoercionKind1 g r t1 t2 h@ = @coercionKind g r t1 t2 h h@+-- That is, it's a specialised form of castCoercionKind, where the two+--          kind coercions are identical+-- @castCoercionKind1 g r t1 t2 h@, where @g :: t1 ~r t2@,+-- has type @(t1 |> h) ~r (t2 |> h)@.+-- @h@ must be nominal.+-- See Note [castCoercionKind1]+castCoercionKind1 :: Coercion -> Role -> Type -> Type+                  -> CoercionN -> Coercion+castCoercionKind1 g r t1 t2 h+  = case g of+      Refl {} -> assert (r == Nominal) $ -- Refl is always Nominal+                 mkNomReflCo (mkCastTy t2 h)+      GRefl _ _ mco -> case mco of+           MRefl       -> mkReflCo r (mkCastTy t2 h)+           MCo kind_co -> mkGReflMCo r (mkCastTy t1 h)+                               (mkSymCo h `mkTransCo` kind_co `mkTransCo` h)+      _ -> castCoercionKind2 g r t1 t2 h h++-- | Creates a new coercion with both of its types casted by different casts+-- @castCoercionKind g h1 h2@, where @g :: t1 ~r t2@,+-- has type @(t1 |> h1) ~r (t2 |> h2)@.+-- @h1@ and @h2@ must be nominal.+-- It calls @coercionKindRole@, so it's quite inefficient (which 'I' stands for)+-- Use @castCoercionKind2@ instead if @t1@, @t2@, and @r@ are known beforehand.+castCoercionKind :: Coercion -> CoercionN -> CoercionN -> Coercion+castCoercionKind g h1 h2+  = castCoercionKind2 g r t1 t2 h1 h2+  where+    (Pair t1 t2, r) = coercionKindRole g++mkPiCos :: Role -> [Var] -> Coercion -> Coercion+mkPiCos r vs co = foldr (mkPiCo r) co vs++-- | Make a forall 'Coercion', where both types related by the coercion+-- are quantified over the same variable.+mkPiCo  :: Role -> Var -> Coercion -> Coercion+mkPiCo r v co | isTyVar v = mkHomoForAllCos [Bndr v coreTyLamForAllTyFlag] co+              | isCoVar v = assert (not (v `elemVarSet` tyCoVarsOfCo co)) $+                  -- We didn't call mkForAllCo here because if v does not appear+                  -- in co, the argument coercion will be nominal. But here we+                  -- want it to be r. It is only called in 'mkPiCos', which is+                  -- only used in GHC.Core.Opt.Simplify.Utils, where we are sure for+                  -- now (Aug 2018) v won't occur in co.+                            mkFunResCo r v co+              | otherwise = mkFunResCo r v co++mkFunResCo :: Role -> Id -> Coercion -> Coercion+-- Given res_co :: res1 ~ res2,+--   mkFunResCo r m arg res_co :: (arg -> res1) ~r (arg -> res2)+-- Reflexive in the multiplicity argument+mkFunResCo role id res_co+  = mkFunCoNoFTF role mult arg_co res_co+  where+    arg_co = mkReflCo role (varType id)+    mult   = multToCo (idMult id)++-- mkCoCast (c :: s1 ~?r t1) (g :: (s1 ~?r t1) ~#R (s2 ~?r t2)) :: s2 ~?r t2+-- The first coercion might be lifted or unlifted; thus the ~? above+-- Lifted and unlifted equalities take different numbers of arguments,+-- so we have to make sure to supply the right parameter to decomposeCo.+-- Also, note that the role of the first coercion is the same as the role of+-- the equalities related by the second coercion. The second coercion is+-- itself always representational.+mkCoCast :: Coercion -> CoercionR -> Coercion+mkCoCast c g+  | (g2:g1:_) <- reverse co_list+  = mkSymCo g1 `mkTransCo` c `mkTransCo` g2++  | otherwise+  = pprPanic "mkCoCast" (ppr g $$ ppr (coercionKind g))+  where+    -- g  :: (s1 ~# t1) ~# (s2 ~# t2)+    -- g1 :: s1 ~# s2+    -- g2 :: t1 ~# t2+    (tc, _) = splitTyConApp (coercionLKind g)+    co_list = decomposeCo (tyConArity tc) g (tyConRolesRepresentational tc)++{- Note [castCoercionKind1]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+castCoercionKind1 deals with the very important special case of castCoercionKind2+where the two kind coercions are identical.  In that case we can exploit the+situation where the main coercion is reflexive, via the special cases for Refl+and GRefl.++This is important when rewriting  (ty |> co). We rewrite ty, yielding+   fco :: ty ~ ty'+and now we want a coercion xco between+   xco :: (ty |> co) ~ (ty' |> co)+That's exactly what castCoercionKind1 does.  And it's very very common for+fco to be Refl.  In that case we do NOT want to get some terrible composition+of mkLeftCoherenceCo and mkRightCoherenceCo, which is what castCoercionKind2+has to do in its full generality.  See #18413.+-}++{-+%************************************************************************+%*                                                                      *+            Newtypes+%*                                                                      *+%************************************************************************+-}++-- | If `instNewTyCon_maybe T ts = Just (rep_ty, co)`+--   then `co :: T ts ~R# rep_ty`+--+-- Checks for a newtype, and for being saturated+instNewTyCon_maybe :: TyCon -> [Type] -> Maybe (Type, Coercion)+instNewTyCon_maybe tc tys+  | Just (tvs, ty, co_tc) <- unwrapNewTyConEtad_maybe tc  -- Check for newtype+  , tvs `leLength` tys                                    -- Check saturated enough+  = Just (applyTysX tvs ty tys, mkUnbranchedAxInstCo Representational co_tc tys [])+  | otherwise+  = Nothing++{-+************************************************************************+*                                                                      *+         Type normalisation+*                                                                      *+************************************************************************+-}++-- | A function to check if we can reduce a type by one step. Used+-- with 'topNormaliseTypeX'.+type NormaliseStepper ev = RecTcChecker+                         -> TyCon     -- tc+                         -> [Type]    -- tys+                         -> NormaliseStepResult ev++-- | The result of stepping in a normalisation function.+-- See 'topNormaliseTypeX'.+data NormaliseStepResult ev+  = NS_Done   -- ^ Nothing more to do+  | NS_Abort  -- ^ Utter failure. The outer function should fail too.+  | NS_Step RecTcChecker Type ev    -- ^ We stepped, yielding new bits;+                                    -- ^ ev is evidence;+                                    -- Usually a co :: old type ~ new type+  deriving (Functor)++instance Outputable ev => Outputable (NormaliseStepResult ev) where+  ppr NS_Done           = text "NS_Done"+  ppr NS_Abort          = text "NS_Abort"+  ppr (NS_Step _ ty ev) = sep [text "NS_Step", ppr ty, ppr ev]++-- | Try one stepper and then try the next, if the first doesn't make+-- progress.+-- So if it returns NS_Done, it means that both steppers are satisfied+composeSteppers :: NormaliseStepper ev -> NormaliseStepper ev+                -> NormaliseStepper ev+composeSteppers step1 step2 rec_nts tc tys+  = case step1 rec_nts tc tys of+      success@(NS_Step {}) -> success+      NS_Done              -> step2 rec_nts tc tys+      NS_Abort             -> NS_Abort++-- | A 'NormaliseStepper' that unwraps newtypes, careful not to fall into+-- a loop. If it would fall into a loop, it produces 'NS_Abort'.+unwrapNewTypeStepper :: NormaliseStepper Coercion+unwrapNewTypeStepper rec_nts tc tys+  | Just (ty', co) <- instNewTyCon_maybe tc tys+  = -- pprTrace "unNS" (ppr tc <+> ppr (getUnique tc) <+> ppr tys $$ ppr ty' $$ ppr rec_nts) $+    case checkRecTc rec_nts tc of+      Just rec_nts' -> NS_Step rec_nts' ty' co+      Nothing       -> NS_Abort++  | otherwise+  = NS_Done++-- | A general function for normalising the top-level of a type. It continues+-- to use the provided 'NormaliseStepper' until that function fails, and then+-- this function returns. The roles of the coercions produced by the+-- 'NormaliseStepper' must all be the same, which is the role returned from+-- the call to 'topNormaliseTypeX'.+--+-- Typically ev is Coercion.+--+-- If topNormaliseTypeX step plus ty = Just (ev, ty')+-- then ty ~ev1~ t1 ~ev2~ t2 ... ~evn~ ty'+-- and ev = ev1 `plus` ev2 `plus` ... `plus` evn+-- If it returns Nothing then no newtype unwrapping could happen+topNormaliseTypeX :: NormaliseStepper ev+                  -> (ev -> ev -> ev)+                  -> Type -> Maybe (ev, Type)+topNormaliseTypeX stepper plus ty+ | Just (tc, tys) <- splitTyConApp_maybe ty+ -- SPJ: The default threshold for initRecTc is 100 which is extremely dangerous+ --      for certain type synonyms, we should think about reducing it (see #20990)+ , NS_Step rec_nts ty' ev <- stepper initRecTc tc tys+ = go rec_nts ev ty'+ | otherwise+ = Nothing+ where+    go rec_nts ev ty+      | Just (tc, tys) <- splitTyConApp_maybe ty+      = case stepper rec_nts tc tys of+          NS_Step rec_nts' ty' ev' -> go rec_nts' (ev `plus` ev') ty'+          NS_Done  -> Just (ev, ty)+          NS_Abort -> Nothing++      | otherwise+      = Just (ev, ty)++topNormaliseNewType_maybe :: Type -> Maybe (Coercion, Type)+-- ^ Sometimes we want to look through a @newtype@ and get its associated coercion.+-- This function strips off @newtype@ layers enough to reveal something that isn't+-- a @newtype@.  Specifically, here's the invariant:+--+-- > topNormaliseNewType_maybe rec_nts ty = Just (co, ty')+--+-- then (a)  @co : ty ~R ty'@.+--      (b)  ty' is not a newtype.+--+-- The function returns @Nothing@ for non-@newtypes@,+-- or unsaturated applications+--+-- This function does *not* look through type families, because it has no access to+-- the type family environment. If you do have that at hand, consider to use+-- topNormaliseType_maybe, which should be a drop-in replacement for+-- topNormaliseNewType_maybe+-- If topNormliseNewType_maybe ty = Just (co, ty'), then co : ty ~R ty'+topNormaliseNewType_maybe ty+  = topNormaliseTypeX unwrapNewTypeStepper mkTransCo ty++{-+%************************************************************************+%*                                                                      *+                   Comparison of coercions+%*                                                                      *+%************************************************************************+-}++-- | Syntactic equality of coercions+eqCoercion :: Coercion -> Coercion -> Bool+eqCoercion = eqType `on` coercionType++-- | Compare two 'Coercion's, with respect to an RnEnv2+eqCoercionX :: RnEnv2 -> Coercion -> Coercion -> Bool+eqCoercionX env = eqTypeX env `on` coercionType++{-+%************************************************************************+%*                                                                      *+                   "Lifting" substitution+           [(TyCoVar,Coercion)] -> Type -> Coercion+%*                                                                      *+%************************************************************************++Note [Lifting coercions over types: liftCoSubst]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The KPUSH rule deals with this situation+   data T a = K (a -> Maybe a)+   g :: T t1 ~ T t2+   x :: t1 -> Maybe t1++   case (K @t1 x) |> g of+     K (y:t2 -> Maybe t2) -> rhs++We want to push the coercion inside the constructor application.+So we do this++   g' :: t1~t2  =  SelCo (SelTyCon 0) g++   case K @t2 (x |> g' -> Maybe g') of+     K (y:t2 -> Maybe t2) -> rhs++The crucial operation is that we+  * take the type of K's argument: a -> Maybe a+  * and substitute g' for a+thus giving *coercion*.  This is what liftCoSubst does.++In the presence of kind coercions, this is a bit+of a hairy operation. So, we refer you to the paper introducing kind coercions,+available at www.cis.upenn.edu/~sweirich/papers/fckinds-extended.pdf++Note [extendLiftingContextEx]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider we have datatype+  K :: /\k. /\a::k. P -> T k  -- P be some type+  g :: T k1 ~ T k2++  case (K @k1 @t1 x) |> g of+    K y -> rhs++We want to push the coercion inside the constructor application.+We first get the coercion mapped by the universal type variable k:+   lc = k |-> SelCo (SelTyCon 0) g :: k1~k2++Here, the important point is that the kind of a is coerced, and P might be+dependent on the existential type variable a.+Thus we first get the coercion of a's kind+   g2 = liftCoSubst lc k :: k1 ~ k2++Then we store a new mapping into the lifting context+   lc2 = a |-> (t1 ~ t1 |> g2), lc++So later when we can correctly deal with the argument type P+   liftCoSubst lc2 P :: P [k|->k1][a|->t1] ~ P[k|->k2][a |-> (t1|>g2)]++This is exactly what extendLiftingContextEx does.+* For each (tyvar:k, ty) pair, we product the mapping+    tyvar |-> (ty ~ ty |> (liftCoSubst lc k))+* For each (covar:s1~s2, ty) pair, we produce the mapping+    covar |-> (co ~ co')+    co' = Sym (liftCoSubst lc s1) ;; covar ;; liftCoSubst lc s2 :: s1'~s2'++This follows the lifting context extension definition in the+"FC with Explicit Kind Equality" paper.+-}++-- ----------------------------------------------------+-- See Note [Lifting coercions over types: liftCoSubst]+-- ----------------------------------------------------++data LiftingContext = LC Subst LiftCoEnv+  -- in optCoercion, we need to lift when optimizing InstCo.+  -- See Note [Optimising InstCo] in GHC.Core.Coercion.Opt+  -- We thus propagate the substitution from GHC.Core.Coercion.Opt here.++instance Outputable LiftingContext where+  ppr (LC _ env) = hang (text "LiftingContext:") 2 (ppr env)++type LiftCoEnv = VarEnv Coercion+     -- Maps *type variables* to *coercions*.+     -- That's the whole point of this function!+     -- Also maps coercion variables to ProofIrrelCos.++-- like liftCoSubstWith, but allows for existentially-bound types as well+liftCoSubstWithEx :: [TyVar]       -- universally quantified tyvars+                  -> [Coercion]    -- coercions to substitute for those+                  -> [TyCoVar]     -- existentially quantified tycovars+                  -> [Type]        -- types and coercions to be bound to ex vars+                  -> (Type -> CoercionR, [Type]) -- (lifting function, converted ex args)+                      -- Returned coercion has Representational role+liftCoSubstWithEx univs omegas exs rhos+  = let theta = mkLiftingContext (zipEqual univs omegas)+        psi   = extendLiftingContextEx theta (zipEqual exs rhos)+    in (ty_co_subst psi Representational, substTys (lcSubstRight psi) (mkTyCoVarTys exs))++liftCoSubstWith :: Role -> [TyCoVar] -> [Coercion] -> Type -> Coercion+liftCoSubstWith r tvs cos ty+  = liftCoSubst r (mkLiftingContext $ zipEqual tvs cos) ty++-- | @liftCoSubst role lc ty@ produces a coercion (at role @role@)+-- that coerces between @lc_left(ty)@ and @lc_right(ty)@, where+-- @lc_left@ is a substitution mapping type variables to the left-hand+-- types of the mapped coercions in @lc@, and similar for @lc_right@.+liftCoSubst :: HasDebugCallStack => Role -> LiftingContext -> Type -> Coercion+{-# INLINE liftCoSubst #-}+-- Inlining this function is worth 2% of allocation in T9872d,+liftCoSubst r lc@(LC subst env) ty+  | isEmptyVarEnv env = mkReflCo r (substTy subst ty)+  | otherwise         = ty_co_subst lc r ty++emptyLiftingContext :: InScopeSet -> LiftingContext+emptyLiftingContext in_scope = LC (mkEmptySubst in_scope) emptyVarEnv++mkLiftingContext :: [(TyCoVar,Coercion)] -> LiftingContext+mkLiftingContext pairs+  = LC (mkEmptySubst $ mkInScopeSet $ tyCoVarsOfCos (map snd pairs))+       (mkVarEnv pairs)++mkSubstLiftingContext :: Subst -> LiftingContext+mkSubstLiftingContext subst = LC subst emptyVarEnv++liftingContextSubst :: LiftingContext -> Subst+liftingContextSubst (LC subst _) = subst++-- | Extend a lifting context with a new mapping.+extendLiftingContext :: LiftingContext  -- ^ original LC+                     -> TyCoVar         -- ^ new variable to map...+                     -> Coercion        -- ^ ...to this lifted version+                     -> LiftingContext+    -- mappings to reflexive coercions are just substitutions+extendLiftingContext (LC subst env) tv arg+  | Just (ty, _) <- isReflCo_maybe arg+  = LC (extendTCvSubst subst tv ty) env+  | otherwise+  = LC subst (extendVarEnv env tv arg)++-- | Extend the substitution component of a lifting context with+-- a new binding for a coercion variable. Used during coercion optimisation.+extendLiftingContextCvSubst :: LiftingContext+                            -> CoVar+                            -> Coercion+                            -> LiftingContext+extendLiftingContextCvSubst (LC subst env) cv co+  = LC (extendCvSubst subst cv co) env++-- | Extend a lifting context with a new mapping, and extend the in-scope set+extendLiftingContextAndInScope :: LiftingContext  -- ^ Original LC+                               -> TyCoVar         -- ^ new variable to map...+                               -> Coercion        -- ^ to this coercion+                               -> LiftingContext+extendLiftingContextAndInScope (LC subst env) tv co+  = extendLiftingContext (LC (extendSubstInScopeSet subst (tyCoVarsOfCo co)) env) tv co++-- | Extend a lifting context with existential-variable bindings.+-- See Note [extendLiftingContextEx]+extendLiftingContextEx :: LiftingContext    -- ^ original lifting context+                       -> [(TyCoVar,Type)]  -- ^ ex. var / value pairs+                       -> LiftingContext+-- Note that this is more involved than extendLiftingContext. That function+-- takes a coercion to extend with, so it's assumed that the caller has taken+-- into account any of the kind-changing stuff worried about here.+extendLiftingContextEx lc [] = lc+extendLiftingContextEx lc@(LC subst env) ((v,ty):rest)+-- This function adds bindings for *Nominal* coercions. Why? Because it+-- works with existentially bound variables, which are considered to have+-- nominal roles.+  | isTyVar v+  = let lc' = LC (subst `extendSubstInScopeSet` tyCoVarsOfType ty)+                 (extendVarEnv env v $+                  mkGReflRightCo Nominal+                                 ty+                                 (ty_co_subst lc Nominal (tyVarKind v)))+    in extendLiftingContextEx lc' rest+  | CoercionTy co <- ty+  = -- co      :: s1 ~r s2+    -- lift_s1 :: s1 ~r s1'+    -- lift_s2 :: s2 ~r s2'+    -- kco     :: (s1 ~r s2) ~N (s1' ~r s2')+    assert (isCoVar v) $+    let (s1, s2, r) = coVarTypesRole v+        lift_s1 = ty_co_subst lc r s1+        lift_s2 = ty_co_subst lc r s2+        kco     = mkTyConAppCo Nominal (equalityTyCon r)+                               [ mkKindCo lift_s1, mkKindCo lift_s2+                               , lift_s1         , lift_s2          ]+        lc'     = LC (subst `extendSubstInScopeSet` tyCoVarsOfCo co)+                     (extendVarEnv env v+                        (mkProofIrrelCo Nominal kco co $+                          (mkSymCo lift_s1) `mkTransCo` co `mkTransCo` lift_s2))+    in extendLiftingContextEx lc' rest+  | otherwise+  = pprPanic "extendLiftingContextEx" (ppr v <+> text "|->" <+> ppr ty)+++-- | Erase the environments in a lifting context+zapLiftingContext :: LiftingContext -> LiftingContext+zapLiftingContext (LC subst _) = LC (zapSubst subst) emptyVarEnv++updateLCSubst :: LiftingContext -> (Subst -> (Subst, a)) -> (LiftingContext, a)+-- Lift a Subst-update function over LiftingContext+updateLCSubst (LC subst lc_env) upd = (LC subst' lc_env, res)+  where+    (subst', res) = upd subst++-- | The \"lifting\" operation which substitutes coercions for type+--   variables in a type to produce a coercion.+--+--   For the inverse operation, see 'liftCoMatch'+ty_co_subst :: LiftingContext -> Role -> Type -> Coercion+ty_co_subst !lc role ty+    -- !lc: making this function strict in lc allows callers to+    -- pass its two components separately, rather than boxing them.+    -- Unfortunately, Boxity Analysis concludes that we need lc boxed+    -- because it's used that way in liftCoSubstTyVarBndrUsing.+  = go role ty+  where+    go :: Role -> Type -> Coercion+    go r ty                 | Just ty' <- coreView ty+                            = go r ty'+    go Phantom ty           = lift_phantom ty+    go r (TyVarTy tv)       = expectJust $+                              liftCoSubstTyVar lc r tv+    go r (AppTy ty1 ty2)    = mkAppCo (go r ty1) (go Nominal ty2)+    go r (TyConApp tc tys)  = mkTyConAppCo r tc (zipWith go (tyConRoleListX r tc) tys)+    go r (FunTy af w t1 t2) = mkFunCo r af (go Nominal w) (go r t1) (go r t2)+    go r t@(ForAllTy (Bndr v vis) ty)+       = let (lc', v', h) = liftCoSubstVarBndr lc v+             body_co = ty_co_subst lc' r ty in+         if isTyVar v' || almostDevoidCoVarOfCo v' body_co+           -- Lifting a ForAllTy over a coercion variable could fail as ForAllCo+           -- imposes an extra restriction on where a covar can appear. See+           -- (FC6) of Note [ForAllCo] in GHC.Tc.TyCo.Rep+            -- We specifically check for this and panic because we know that+           -- there's a hole in the type system here (see (FC6), and we'd rather+           -- panic than fall into it.+         then mkForAllCo v' vis vis h body_co+         else pprPanic "ty_co_subst: covar is not almost devoid" (ppr t)+    go r ty@(LitTy {})     = assert (r == Nominal) $+                             mkNomReflCo ty+    go r (CastTy ty co)    = castCoercionKind (go r ty) (substLeftCo lc co)+                                                        (substRightCo lc co)+    go r (CoercionTy co)   = mkProofIrrelCo r kco (substLeftCo lc co)+                                                  (substRightCo lc co)+      where kco = go Nominal (coercionType co)++    lift_phantom ty = mkPhantomCo (go Nominal (typeKind ty))+                                  (substTy (lcSubstLeft  lc) ty)+                                  (substTy (lcSubstRight lc) ty)++{-+Note [liftCoSubstTyVar]+~~~~~~~~~~~~~~~~~~~~~~~~~+This function can fail if a coercion in the environment is of too low a role.++liftCoSubstTyVar is called from two places: in liftCoSubst (naturally), and+also in matchAxiom in GHC.Core.Coercion.Opt. From liftCoSubst, the so-called lifting+lemma guarantees that the roles work out. If we fail in this+case, we really should panic -- something is deeply wrong. But, in matchAxiom,+failing is fine. matchAxiom is trying to find a set of coercions+that match, but it may fail, and this is healthy behavior.+-}++-- See Note [liftCoSubstTyVar]+liftCoSubstTyVar :: LiftingContext -> Role -> TyVar -> Maybe Coercion+liftCoSubstTyVar (LC subst env) r v+  | Just co_arg <- lookupVarEnv env v+  = downgradeRole_maybe r (coercionRole co_arg) co_arg++  | otherwise+  = Just $ mkReflCo r (substTyVar subst v)++{- Note [liftCoSubstVarBndr]+   ~~~~~~~~~~~~~~~~~~~~~~~~~+callback:+  'liftCoSubstVarBndrUsing' needs to be general enough to work in two+  situations:++    - in this module, which manipulates 'Coercion's, and+    - in GHC.Core.FamInstEnv, where we work with 'Reduction's, which contain+      a coercion as well as a type.++  To achieve this, we require that the return type of the 'callback' function+  contain a coercion within it. This is witnessed by the first argument+  to 'liftCoSubstVarBndrUsing': a getter, which allows us to retrieve+  the coercion inside the return type. Thus:++    - in this module, we simply pass 'id' as the getter,+    - in GHC.Core.FamInstEnv, we pass 'reductionCoercion' as the getter.++liftCoSubstTyVarBndrUsing:+  Given+    forall tv:k. t+  We want to get+    forall (tv:k1) (kind_co :: k1 ~ k2) body_co++  We lift the kind k to get the kind_co+    kind_co = ty_co_subst k :: k1 ~ k2++  Now in the LiftingContext, we add the new mapping+    tv |-> (tv :: k1) ~ ((tv |> kind_co) :: k2)++liftCoSubstCoVarBndrUsing:+  Given+    forall cv:(s1 ~ s2). t+  We want to get+    forall (cv:s1'~s2') (kind_co :: (s1'~s2') ~ (t1 ~ t2)) body_co++  We lift s1 and s2 respectively to get+    eta1 :: s1' ~ t1+    eta2 :: s2' ~ t2+  And+    kind_co = TyConAppCo Nominal (~#) eta1 eta2++  Now in the liftingContext, we add the new mapping+    cv |-> (cv :: s1' ~ s2') ~ ((sym eta1;cv;eta2) :: t1 ~ t2)+-}++-- See Note [liftCoSubstVarBndr]+liftCoSubstVarBndr :: LiftingContext -> TyCoVar+                   -> (LiftingContext, TyCoVar, Coercion)+liftCoSubstVarBndr lc tv+  = liftCoSubstVarBndrUsing id callback lc tv+  where+    callback lc' ty' = ty_co_subst lc' Nominal ty'++-- the callback must produce a nominal coercion+liftCoSubstVarBndrUsing :: (r -> CoercionN)              -- ^ coercion getter+                        -> (LiftingContext -> Type -> r) -- ^ callback+                        -> LiftingContext -> TyCoVar+                        -> (LiftingContext, TyCoVar, r)+liftCoSubstVarBndrUsing view_co fun lc old_var+  | isTyVar old_var+  = liftCoSubstTyVarBndrUsing view_co fun lc old_var+  | otherwise+  = liftCoSubstCoVarBndrUsing view_co fun lc old_var++-- Works for tyvar binder+liftCoSubstTyVarBndrUsing :: (r -> CoercionN)              -- ^ coercion getter+                          -> (LiftingContext -> Type -> r) -- ^ callback+                          -> LiftingContext -> TyVar+                          -> (LiftingContext, TyVar, r)+liftCoSubstTyVarBndrUsing view_co fun lc@(LC subst cenv) old_var+  = assert (isTyVar old_var) $+    ( LC (subst `extendSubstInScope` new_var) new_cenv+    , new_var, stuff )+  where+    old_kind = tyVarKind old_var+    stuff    = fun lc old_kind+    eta      = view_co stuff+    k1       = coercionLKind eta+    new_var  = uniqAway (substInScopeSet subst) (setVarType old_var k1)++    lifted   = mkGReflRightCo Nominal (TyVarTy new_var) eta+               -- :: new_var ~ new_var |> eta+    new_cenv = extendVarEnv cenv old_var lifted++-- Works for covar binder+liftCoSubstCoVarBndrUsing :: (r -> CoercionN)              -- ^ coercion getter+                          -> (LiftingContext -> Type -> r) -- ^ callback+                          -> LiftingContext -> CoVar+                          -> (LiftingContext, CoVar, r)+liftCoSubstCoVarBndrUsing view_co fun lc@(LC subst cenv) old_var+  = assert (isCoVar old_var) $+    ( LC (subst `extendSubstInScope` new_var) new_cenv+    , new_var, stuff )+  where+    old_kind = coVarKind old_var+    stuff    = fun lc old_kind+    eta      = view_co stuff+    k1       = coercionLKind eta+    new_var  = uniqAway (substInScopeSet subst) (setVarType old_var k1)++    -- old_var :: s1  ~r s2+    -- eta     :: (s1' ~r s2') ~N (t1 ~r t2)+    -- eta1    :: s1' ~r t1+    -- eta2    :: s2' ~r t2+    -- co1     :: s1' ~r s2'+    -- co2     :: t1  ~r t2+    -- lifted  :: co1 ~N co2++    role   = coVarRole old_var+    eta'   = downgradeRole role Nominal eta+    eta1   = mkSelCo (SelTyCon 2 role) eta'+    eta2   = mkSelCo (SelTyCon 3 role) eta'++    co1     = mkCoVarCo new_var+    co2     = mkSymCo eta1 `mkTransCo` co1 `mkTransCo` eta2+    lifted  = mkProofIrrelCo Nominal eta co1 co2++    new_cenv = extendVarEnv cenv old_var lifted++-- | Is a var in the domain of a lifting context?+isMappedByLC :: TyCoVar -> LiftingContext -> Bool+isMappedByLC tv (LC _ env) = tv `elemVarEnv` env++-- If [a |-> g] is in the substitution and g :: t1 ~ t2, substitute a for t1+-- If [a |-> (g1, g2)] is in the substitution, substitute a for g1+substLeftCo :: LiftingContext -> Coercion -> Coercion+substLeftCo lc co+  = substCo (lcSubstLeft lc) co++-- Ditto, but for t2 and g2+substRightCo :: LiftingContext -> Coercion -> Coercion+substRightCo lc co+  = substCo (lcSubstRight lc) co++-- | Apply "sym" to all coercions in a 'LiftCoEnv'+swapLiftCoEnv :: LiftCoEnv -> LiftCoEnv+swapLiftCoEnv = mapVarEnv mkSymCo++lcSubstLeft :: LiftingContext -> Subst+lcSubstLeft (LC subst lc_env) = liftEnvSubstLeft subst lc_env++lcSubstRight :: LiftingContext -> Subst+lcSubstRight (LC subst lc_env) = liftEnvSubstRight subst lc_env++liftEnvSubstLeft :: Subst -> LiftCoEnv -> Subst+liftEnvSubstLeft = liftEnvSubst pFst++liftEnvSubstRight :: Subst -> LiftCoEnv -> Subst+liftEnvSubstRight = liftEnvSubst pSnd++liftEnvSubst :: (forall a. Pair a -> a) -> Subst -> LiftCoEnv -> Subst+liftEnvSubst selector subst lc_env+  = composeTCvSubst (Subst in_scope emptyIdSubstEnv tenv cenv) subst+  where+    pairs            = nonDetUFMToList lc_env+                       -- It's OK to use nonDetUFMToList here because we+                       -- immediately forget the ordering by creating+                       -- a VarEnv+    (tpairs, cpairs) = partitionWith ty_or_co pairs+    -- Make sure the in-scope set is wide enough to cover the range of the+    -- substitution (#22235).+    in_scope         = mkInScopeSet $+                       tyCoVarsOfTypes (map snd tpairs) `unionVarSet`+                       tyCoVarsOfCos (map snd cpairs)+    tenv             = mkVarEnv_Directly tpairs+    cenv             = mkVarEnv_Directly cpairs++    ty_or_co :: (Unique, Coercion) -> Either (Unique, Type) (Unique, Coercion)+    ty_or_co (u, co)+      | Just equality_co <- isCoercionTy_maybe equality_ty+      = Right (u, equality_co)+      | otherwise+      = Left (u, equality_ty)+      where+        equality_ty = selector (coercionKind co)++-- | Lookup a 'CoVar' in the substitution in a 'LiftingContext'+lcLookupCoVar :: LiftingContext -> CoVar -> Maybe Coercion+lcLookupCoVar (LC subst _) cv = lookupCoVar subst cv++-- | Get the 'InScopeSet' from a 'LiftingContext'+lcInScopeSet :: LiftingContext -> InScopeSet+lcInScopeSet (LC subst _) = substInScopeSet subst++{-+%************************************************************************+%*                                                                      *+            Sequencing on coercions+%*                                                                      *+%************************************************************************+-}++seqMCo :: MCoercion -> ()+seqMCo MRefl    = ()+seqMCo (MCo co) = seqCo co++seqCo :: Coercion -> ()+seqCo (Refl ty)             = seqType ty+seqCo (GRefl r ty mco)      = r `seq` seqType ty `seq` seqMCo mco+seqCo (TyConAppCo r tc cos) = r `seq` tc `seq` seqCos cos+seqCo (AppCo co1 co2)       = seqCo co1 `seq` seqCo co2+seqCo (CoVarCo cv)          = cv `seq` ()+seqCo (HoleCo h)            = coHoleCoVar h `seq` ()+seqCo (SymCo co)            = seqCo co+seqCo (TransCo co1 co2)     = seqCo co1 `seq` seqCo co2+seqCo (SelCo n co)          = n `seq` seqCo co+seqCo (LRCo lr co)          = lr `seq` seqCo co+seqCo (InstCo co arg)       = seqCo co `seq` seqCo arg+seqCo (KindCo co)           = seqCo co+seqCo (SubCo co)            = seqCo co+seqCo (AxiomCo _ cs)        = seqCos cs+seqCo (ForAllCo tv visL visR k co)+  = seqType (varType tv) `seq` rnf visL `seq` rnf visR `seq`+    seqCo k `seq` seqCo co+seqCo (FunCo r af1 af2 w co1 co2)+  = r `seq` af1 `seq` af2 `seq` seqCo w `seq` seqCo co1 `seq` seqCo co2+seqCo (UnivCo { uco_prov = p, uco_role = r+              , uco_lty = t1, uco_rty = t2, uco_deps = deps })+  = p `seq` r `seq` seqType t1 `seq` seqType t2 `seq` seqCos deps++seqCos :: [Coercion] -> ()+seqCos []       = ()+seqCos (co:cos) = seqCo co `seq` seqCos cos++{-+%************************************************************************+%*                                                                      *+             The kind of a type, and of a coercion+%*                                                                      *+%************************************************************************+-}++{- Note [coercionKind performance]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+coercionKind, coercionLKind, and coercionRKind are very "hot" functions; in some+coercion-heavy programs they can have a material effect on compile time/allocation.++Hence+* Rather than making one function which returns a pair (lots of allocation and+  de-allocation) we have two functions, coercionLKind and coercionRKind, which+  return the left and right kind respectively.++* Both are defined by a single worker function `coercion_lr_kind`, which takes a+  flag of type `LeftOrRight`.  This worker function is marked INLINE, and inlined+  at its precisely-two call-sites in coercionLKind and coercionRKind.++Take care when making changes here... it's easy to accidentally add allocation!+-}++-- | Apply 'coercionKind' to multiple 'Coercion's+coercionKinds :: [Coercion] -> Pair [Type]+coercionKinds tys = sequenceA $ map coercionKind tys++-- | Get a coercion's kind and role.+coercionKindRole :: Coercion -> (Pair Type, Role)+coercionKindRole co = (coercionKind co, coercionRole co)++coercionType :: Coercion -> Type+coercionType co = case coercionKindRole co of+  (Pair ty1 ty2, r) -> mkCoercionType r ty1 ty2++------------------+-- | If it is the case that+--+-- > c :: (t1 ~ t2)+--+-- i.e. the kind of @c@ relates @t1@ and @t2@, then @coercionKind c = Pair t1 t2@.++coercionKind :: HasDebugCallStack => Coercion -> Pair Type+-- See Note [coercionKind performance]+coercionKind co = Pair (coercionLKind co) (coercionRKind co)++coercionLKind, coercionRKind :: HasDebugCallStack => Coercion -> Type+-- See Note [coercionKind performance]+coercionLKind co = coercion_lr_kind CLeft  co+coercionRKind co = coercion_lr_kind CRight co++coercion_lr_kind :: HasDebugCallStack => LeftOrRight -> Coercion -> Type+{-# INLINE coercion_lr_kind #-}+-- See Note [coercionKind performance]+coercion_lr_kind which orig_co+  = go orig_co+  where+    go (Refl ty)              = ty+    go (GRefl _ ty MRefl)     = ty+    go (GRefl _ ty (MCo co1)) = pickLR which (ty, mkCastTy ty co1)+    go (TyConAppCo _ tc cos)  = mkTyConApp tc (map go cos)+    go (AppCo co1 co2)        = mkAppTy (go co1) (go co2)+    go (CoVarCo cv)           = go_covar cv+    go (HoleCo h)             = go_covar (coHoleCoVar h)+    go (SymCo co)             = pickLR which (coercionRKind co, coercionLKind co)+    go (TransCo co1 co2)      = pickLR which (go co1,           go co2)+    go (LRCo lr co)           = pickLR lr (splitAppTy (go co))+    go (InstCo aco arg)       = go_app aco [go arg]+    go (KindCo co)            = typeKind (go co)+    go (SubCo co)             = go co+    go (SelCo d co)           = selectFromType d (go co)+    go (AxiomCo ax cos)       = go_ax ax cos++    go (UnivCo { uco_lty = lty, uco_rty = rty})+      = pickLR which (lty, rty)+    go (FunCo { fco_afl = afl, fco_afr = afr, fco_mult = mult+              , fco_arg = arg, fco_res = res})+      = -- See Note [FunCo]+        FunTy { ft_af = pickLR which (afl, afr), ft_mult = go mult+              , ft_arg = go arg, ft_res = go res }++    go co@(ForAllCo { fco_tcv = tv1, fco_visL = visL, fco_visR = visR+                    , fco_kind = k_co, fco_body = co1 })+      = case which of+          CLeft  -> mkTyCoForAllTy tv1 visL (go co1)+          CRight | isGReflCo k_co  -- kind_co always has kind `Type`, thus `isGReflCo`+                 -> mkTyCoForAllTy tv1 visR (go co1)+                 | otherwise+                 -> go_forall_right empty_subst co+      where+         empty_subst = mkEmptySubst (mkInScopeSet $ tyCoVarsOfCo co)++    -------------+    go_covar cv = pickLR which (coVarLType cv, coVarRType cv)++    -------------+    go_app :: Coercion -> [Type] -> Type+    -- Collect up all the arguments and apply all at once+    -- See Note [Nested InstCos]+    go_app (InstCo co arg) args = go_app co (go arg:args)+    go_app co              args = piResultTys (go co) args++    -------------+    go_ax axr@(BuiltInFamRew  bif) cos  = check_bif_res axr (bifrw_proves  bif (map coercionKind cos))+    go_ax axr@(BuiltInFamInj bif) [co]  = check_bif_res axr (bifinj_proves bif (coercionKind co))+    go_ax axr@(BuiltInFamInj {})  _     = crash axr+    go_ax     (UnbranchedAxiom ax) cos  = go_branch ax (coAxiomSingleBranch ax) cos+    go_ax     (BranchedAxiom ax i) cos  = go_branch ax (coAxiomNthBranch ax i)  cos++    -------------+    check_bif_res _   (Just (Pair lhs rhs)) = pickLR which (lhs,rhs)+    check_bif_res axr Nothing               = crash axr++    crash :: CoAxiomRule -> Type+    crash axr = pprPanic "coercionKind" (ppr axr)++    -------------+    go_branch :: CoAxiom br -> CoAxBranch -> [Coercion] -> Type+    go_branch ax (CoAxBranch { cab_tvs = tvs, cab_cvs = cvs+                             , cab_lhs = lhs_tys, cab_rhs = rhs_ty }) cos+      = assert (cos `equalLength` tcvs) $+                  -- Invariant of AxiomRuleCo: cos should+                  -- exactly saturate the axiom branch+        let (tys1, cotys1) = splitAtList tvs tys+            cos1           = map stripCoercionTy cotys1+        in+        -- You might think to use+        --        substTy (zipTCvSubst tcvs ltys) (pickLR ...)+        -- but #25066 makes it much less efficient than the silly calls below+        substTyWith tvs tys1       $+        substTyWithCoVars cvs cos1 $+        pickLR which (mkTyConApp tc lhs_tys, rhs_ty)+     where+       tc   = coAxiomTyCon ax+       tcvs | null cvs  = tvs  -- Very common case (currently always!)+            | otherwise = tvs ++ cvs+       tys = map go cos++    -------------+    go_forall_right subst (ForAllCo { fco_tcv = tv1, fco_visR = visR+                                    , fco_kind = k_co, fco_body = co })+      -- See Note [Nested ForAllCos]+      | isTyVar tv1+      = mkForAllTy (Bndr tv2 visR) (go_forall_right subst' co)+      where+        k2  = coercionRKind k_co+        tv2 = setTyVarKind tv1 (substTy subst k2)+        subst' | isGReflCo k_co = extendSubstInScope subst tv1+                 -- kind_co always has kind @Type@, thus @isGReflCo@+               | otherwise      = extendTvSubst (extendSubstInScope subst tv2) tv1 $+                                  TyVarTy tv2 `mkCastTy` mkSymCo k_co++    go_forall_right subst (ForAllCo { fco_tcv = cv1, fco_visR = visR+                                    , fco_kind = k_co, fco_body = co })+      | isCoVar cv1+      = mkTyCoForAllTy cv2 visR (go_forall_right subst' co)+      where+        k2    = coercionRKind k_co+        r     = coVarRole cv1+        k_co' = downgradeRole r Nominal k_co+        eta1  = mkSelCo (SelTyCon 2 r) k_co'+        eta2  = mkSelCo (SelTyCon 3 r) k_co'++        -- k_co :: (t1 ~r t2) ~N (s1 ~r s2)+        -- k1    = t1 ~r t2+        -- k2    = s1 ~r s2+        -- cv1  :: t1 ~r t2+        -- cv2  :: s1 ~r s2+        -- eta1 :: t1 ~r s1+        -- eta2 :: t2 ~r s2+        -- n_subst  = (eta1 ; cv2 ; sym eta2) :: t1 ~r t2++        cv2     = setVarType cv1 (substTy subst k2)+        n_subst = eta1 `mkTransCo` (mkCoVarCo cv2) `mkTransCo` (mkSymCo eta2)+        subst'  | isReflCo k_co = extendSubstInScope subst cv1+                | otherwise     = extendCvSubst (extendSubstInScope subst cv2)+                                                cv1 n_subst++    go_forall_right subst other_co+      -- when other_co is not a ForAllCo+      = substTy subst (go other_co)++{- Note [Nested ForAllCos]+~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we need `coercionKind (ForAllCo a1 (ForAllCo a2 ... (ForAllCo an co)...) )`.+We do not want to perform `n` single-type-variable substitutions over the kind+of `co`; rather we want to do one substitution which substitutes for all of+`a1`, `a2` ... simultaneously.  If we do one at a time we get the performance+hole reported in #11735.++Solution: gather up the type variables for nested `ForAllCos`, and+substitute for them all at once.  Remarkably, for #11735 this single+change reduces /total/ compile time by a factor of more than ten.++Note [Nested InstCos]+~~~~~~~~~~~~~~~~~~~~~+In #5631 we found that 70% of the entire compilation time was+being spent in coercionKind!  The reason was that we had+   (g @ ty1 @ ty2 .. @ ty100)    -- The "@s" are InstCos+where+   g :: forall a1 a2 .. a100. phi+If we deal with the InstCos one at a time, we'll do this:+   1.  Find the kind of (g @ ty1 .. @ ty99) : forall a100. phi'+   2.  Substitute phi'[ ty100/a100 ], a single tyvar->type subst+But this is a *quadratic* algorithm, and the blew up #5631.+So it's very important to do the substitution simultaneously;+cf Type.piResultTys (which in fact we call here).+-}++-- | Retrieve the role from a coercion.+coercionRole :: Coercion -> Role+coercionRole = go+  where+    go (Refl _)                     = Nominal+    go (GRefl r _ _)                = r+    go (TyConAppCo r _ _)           = r+    go (AppCo co1 _)                = go co1+    go (ForAllCo { fco_body = co }) = go co+    go (FunCo { fco_role = r })     = r+    go (CoVarCo cv)                 = coVarRole cv+    go (HoleCo h)                   = coVarRole (coHoleCoVar h)+    go (UnivCo { uco_role = r })    = r+    go (SymCo co)                   = go co+    go (TransCo co1 _co2)           = go co1+    go (SelCo cs co)                = mkSelCoResRole cs (coercionRole co)+    go (LRCo {})                    = Nominal+    go (InstCo co _)                = go co+    go (KindCo {})                  = Nominal+    go (SubCo _)                    = Representational+    go (AxiomCo ax _)               = coAxiomRuleRole ax++-- | Makes a coercion type from two types: the types whose equality+-- is proven by the relevant 'Coercion'+mkCoercionType :: Role -> Type -> Type -> Type+mkCoercionType Nominal          = mkNomEqPred+mkCoercionType Representational = mkReprEqPred+mkCoercionType Phantom          = \ty1 ty2 ->+  let ki1 = typeKind ty1+      ki2 = typeKind ty2+  in+  TyConApp eqPhantPrimTyCon [ki1, ki2, ty1, ty2]++-- | Assuming that two types are the same, ignoring coercions, find+-- a nominal coercion between the types. This is useful when optimizing+-- transitivity over coercion applications, where splitting two+-- AppCos might yield different kinds. See Note [EtaAppCo] in+-- "GHC.Core.Coercion.Opt".+buildCoercion :: HasDebugCallStack => Type -> Type -> CoercionN+buildCoercion orig_ty1 orig_ty2 = go orig_ty1 orig_ty2+  where+    go ty1 ty2 | Just ty1' <- coreView ty1 = go ty1' ty2+               | Just ty2' <- coreView ty2 = go ty1 ty2'++    go (CastTy ty1 co) ty2+      = let co' = go ty1 ty2+            r = coercionRole co'+        in  mkCoherenceLeftCo r ty1 co co'++    go ty1 (CastTy ty2 co)+      = let co' = go ty1 ty2+            r = coercionRole co'+        in  mkCoherenceRightCo r ty2 co co'++    go ty1@(TyVarTy tv1) _tyvarty+      = assert (case _tyvarty of+                  { TyVarTy tv2 -> tv1 == tv2+                  ; _           -> False      }) $+        mkNomReflCo ty1++    go (FunTy { ft_af = af1, ft_mult = w1, ft_arg = arg1, ft_res = res1 })+       (FunTy { ft_af = af2, ft_mult = w2, ft_arg = arg2, ft_res = res2 })+      = assert (af1 == af2) $+        mkFunCo Nominal af1 (go w1 w2) (go arg1 arg2) (go res1 res2)++    go (TyConApp tc1 args1) (TyConApp tc2 args2)+      = assertPpr (tc1 == tc2) (vcat [ ppr tc1 <+> ppr tc2+                                     , text "orig_ty1:" <+> ppr orig_ty1+                                     , text "orig_ty2:" <+> ppr orig_ty2+                                     ]) $+        mkTyConAppCo Nominal tc1 (zipWith go args1 args2)++    go (AppTy ty1a ty1b) ty2+      | Just (ty2a, ty2b) <- splitAppTyNoView_maybe ty2+      = mkAppCo (go ty1a ty2a) (go ty1b ty2b)++    go ty1 (AppTy ty2a ty2b)+      | Just (ty1a, ty1b) <- splitAppTyNoView_maybe ty1+      = mkAppCo (go ty1a ty2a) (go ty1b ty2b)++    go (ForAllTy (Bndr tv1 flag1) ty1) (ForAllTy (Bndr tv2 flag2) ty2)+      | isTyVar tv1+      = assert (isTyVar tv2) $+        mkForAllCo tv1 flag1 flag2 kind_co (go ty1 ty2')+      where kind_co  = go (tyVarKind tv1) (tyVarKind tv2)+            in_scope = mkInScopeSet $ tyCoVarsOfType ty2 `unionVarSet` tyCoVarsOfCo kind_co+            ty2'     = substTyWithInScope in_scope [tv2]+                         [mkTyVarTy tv1 `mkCastTy` kind_co]+                         ty2++    go (ForAllTy (Bndr cv1 flag1) ty1) (ForAllTy (Bndr cv2 flag2) ty2)+      = assert (isCoVar cv1 && isCoVar cv2) $+        mkForAllCo cv1 flag1 flag2 kind_co (go ty1 ty2')+      where s1 = varType cv1+            s2 = varType cv2+            kind_co = go s1 s2++            -- s1 = t1 ~r t2+            -- s2 = t3 ~r t4+            -- kind_co :: (t1 ~r t2) ~N (t3 ~r t4)+            -- eta1 :: t1 ~r t3+            -- eta2 :: t2 ~r t4++            r    = coVarRole cv1+            kind_co' = downgradeRole r Nominal kind_co+            eta1 = mkSelCo (SelTyCon 2 r) kind_co'+            eta2 = mkSelCo (SelTyCon 3 r) kind_co'++            subst = mkEmptySubst $ mkInScopeSet $+                      tyCoVarsOfType ty2 `unionVarSet` tyCoVarsOfCo kind_co+            ty2'  = substTy (extendCvSubst subst cv2 $ mkSymCo eta1 `mkTransCo`+                                                       mkCoVarCo cv1 `mkTransCo`+                                                       eta2)+                            ty2++    go ty1@(LitTy lit1) _lit2+      = assert (case _lit2 of+                  { LitTy lit2 -> lit1 == lit2+                  ; _          -> False        }) $+        mkNomReflCo ty1++    go (CoercionTy co1) (CoercionTy co2)+      = mkProofIrrelCo Nominal kind_co co1 co2+      where+        kind_co = go (coercionType co1) (coercionType co2)++    go ty1 ty2+      = pprPanic "buildKindCoercion" (vcat [ ppr orig_ty1, ppr orig_ty2+                                           , ppr ty1, ppr ty2 ])+++{-+%************************************************************************+%*                                                                      *+       Coercion holes+%*                                                                      *+%************************************************************************+-}++has_co_hole_ty :: Type -> Monoid.Any+(has_co_hole_ty, _, _, _)+  = foldTyCo folder ()+  where+    folder = TyCoFolder { tcf_view  = noView+                        , tcf_tyvar = const2 (Monoid.Any False)+                        , tcf_covar = const2 (Monoid.Any False)+                        , tcf_hole  = \_ _ -> Monoid.Any True+                        , tcf_tycobinder = const2+                        }++-- | Is there a coercion hole in this type?+-- See wrinkle (DE6) of Note [Defaulting equalities] in GHC.Tc.Solver.Default+hasCoercionHole :: Type -> Bool+hasCoercionHole = Monoid.getAny . has_co_hole_ty++-- | Set the type of a 'CoercionHole'+setCoHoleType :: CoercionHole -> Type -> CoercionHole+setCoHoleType h t = setCoHoleCoVar h (setVarType (coHoleCoVar h) t)+
GHC/Core/Coercion.hs-boot view
@@ -16,15 +16,16 @@ mkReflCo :: Role -> Type -> Coercion mkTyConAppCo :: HasDebugCallStack => Role -> TyCon -> [Coercion] -> Coercion mkAppCo :: Coercion -> Coercion -> Coercion-mkForAllCo :: TyCoVar -> Coercion -> Coercion -> Coercion-mkFunCo :: Role -> CoercionN -> 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-mkAxiomInstCo :: CoAxiom Branched -> BranchIndex -> [Coercion] -> Coercion mkPhantomCo :: Coercion -> Type -> Type -> Coercion-mkUnivCo :: UnivCoProvenance -> Role -> Type -> Type -> Coercion+mkUnivCo :: UnivCoProvenance -> [Coercion] -> Role -> Type -> Type -> Coercion mkSymCo :: Coercion -> Coercion-mkTransCo :: Coercion -> Coercion -> Coercion-mkNthCo :: HasDebugCallStack => Role -> Int -> 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@@ -32,24 +33,24 @@ mkKindCo :: Coercion -> Coercion mkSubCo :: HasDebugCallStack => Coercion -> Coercion mkProofIrrelCo :: Role -> Coercion -> Coercion -> Coercion -> Coercion-mkAxiomRuleCo :: CoAxiomRule -> [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)-coVarKindsTypesRole :: HasDebugCallStack => CoVar -> (Kind, Kind, Type, Type, Role)+coVarTypesRole :: HasDebugCallStack => CoVar -> (Type, Type, Role) coVarRole :: CoVar -> Role  mkCoercionType :: Role -> Type -> Type -> Type -data LiftingContext-liftCoSubst :: HasDebugCallStack => Role -> LiftingContext -> Type -> Coercion seqCo :: Coercion -> () -coercionKind :: Coercion -> Pair Type-coercionLKind :: Coercion -> Type-coercionRKind :: Coercion -> Type+coercionKind  :: HasDebugCallStack => Coercion -> Pair Type+coercionLKind :: HasDebugCallStack => Coercion -> Type+coercionRKind :: HasDebugCallStack => Coercion -> Type coercionType :: Coercion -> Type  topNormaliseNewType_maybe :: Type -> Maybe (Coercion, Type)
GHC/Core/Coercion/Axiom.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -Wno-orphans     #-} -- Outputable {-# LANGUAGE DataKinds           #-} {-# LANGUAGE DeriveDataTypeable  #-} {-# LANGUAGE GADTs               #-}@@ -29,15 +30,19 @@         Role(..), fsFromRole, -       CoAxiomRule(..), TypeEqn,+       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 )-import {-# SOURCE #-} GHC.Core.TyCon    ( TyCon )+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@@ -46,7 +51,6 @@ import GHC.Utils.Misc import GHC.Utils.Binary import GHC.Utils.Panic-import GHC.Utils.Panic.Plain import GHC.Data.Pair import GHC.Types.Basic import Data.Typeable ( Typeable )@@ -54,6 +58,7 @@ import qualified Data.Data as Data import Data.Array import Data.List ( mapAccumL )+import Control.DeepSeq  {- Note [Coercion axiom branches]@@ -77,12 +82,12 @@        ; forall (k :: *) (a :: k -> *) (b :: k). F (a b) ~ Char        } -The axiom is used with the AxiomInstCo constructor of Coercion. If we wish+The axiom is used with the AxiomCo constructor of Coercion. If we wish to have a coercion showing that F (Maybe Int) ~ Char, it will look like  axF[2] <*> <Maybe> <Int> :: F (Maybe Int) ~ Char -- or, written using concrete-ish syntax ---AxiomInstCo axF 2 [Refl *, Refl Maybe, Refl Int]+AxiomRuleCo axF 2 [Refl *, Refl Maybe, Refl Int]  Note that the index is 0-based. @@ -125,9 +130,22 @@ ************************************************************************ -} -type BranchIndex = Int  -- The index of the branch in the list of branches-                        -- Counting from zero+{- 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@@ -233,49 +251,54 @@          -- 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]+    { 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 (CoAxiom unique name role tc branches implicit)-  = CoAxiom unique name role tc (toBranched branches) implicit+toBranchedAxiom ax@(CoAxiom { co_ax_branches = branches })+  = ax { co_ax_branches = toBranched branches }  toUnbranchedAxiom :: CoAxiom br -> CoAxiom Unbranched-toUnbranchedAxiom (CoAxiom unique name role tc branches implicit)-  = CoAxiom unique name role tc (toUnbranched branches) implicit+toUnbranchedAxiom ax@(CoAxiom { co_ax_branches = branches })+  = ax { co_ax_branches = toUnbranched branches }  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 @@ -285,6 +308,14 @@ 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@@ -292,10 +323,6 @@   | otherwise   = Nothing -coAxiomSingleBranch :: CoAxiom Unbranched -> CoAxBranch-coAxiomSingleBranch (CoAxiom { co_ax_branches = MkBranches arr })-  = arr ! 0- coAxiomTyCon :: CoAxiom br -> TyCon coAxiomTyCon = co_ax_tc @@ -331,7 +358,7 @@ 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+we use the *same* type variables in cab_tvs (where possible) as the enclosing class or instance.  Consider    instance C Int [z] where@@ -341,8 +368,11 @@ same 'z', so that it's easy to check that that type is the same as that in the instance header. -So, unlike FamInsts, there is no expectation that the cab_tvs-are fresh wrt each other, or any other CoAxBranch.+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] ~~~~~~~~~~~~~~~~~~~~~~~@@ -458,6 +488,12 @@ * 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@@ -465,9 +501,6 @@ 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 @@ -477,13 +510,22 @@     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-  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+  -- This instance doesn't know the name of the type family+  -- If possible, use GHC.Core.Coercion.pprCoAxBranch instead+  ppr (CoAxBranch { cab_tvs = tvs, cab_cvs = cvs+                  , cab_lhs = lhs_tys, cab_rhs = rhs, cab_incomps = incomps })+    = text "CoAxBranch" <+> braces payload+    where+      payload = hang (text "forall" <+> pprWithCommas pprTyVar (tvs ++ cvs) <> dot)+                   2 (vcat [ text "<tycon>" <+> sep (map pprType lhs_tys)+                           , nest 2 (text "=" <+> ppr rhs)+                           , ppUnless (null incomps) $+                             text "incomps:" <+> vcat (map ppr incomps) ])  {- ************************************************************************@@ -495,14 +537,6 @@ Roles are defined here to avoid circular dependencies. -} --- See Note [Roles] in GHC.Core.Coercion--- defined here to avoid cyclic dependency with 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.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@@ -526,6 +560,11 @@                           3 -> return Phantom                           _ -> panic ("get Role " ++ show tag) +instance NFData Role where+  rnf Nominal = ()+  rnf Representational = ()+  rnf Phantom = ()+ {- ************************************************************************ *                                                                      *@@ -534,76 +573,177 @@ *                                                                      * ************************************************************************ -Conditional axioms.  The general idea is that a `CoAxiomRule` looks like this:+Note [CoAxiomRule]+~~~~~~~~~~~~~~~~~~+A CoAxiomRule is a built-in axiom, one that we assume to be true:+CoAxiomRules come in four flavours: -    forall as. (r1 ~ r2, s1 ~ s2) => t1 ~ t2+* 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). -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.+* 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. -} --- | A more explicit representation for `t1 ~ t2`.-type TypeEqn = Pair Type+-- | 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 --- | 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.-  }+  | 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 Uniquable CoAxiomRule where-  getUnique = getUnique . coaxrName+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) -instance Eq CoAxiomRule where-  x == y = coaxrName x == coaxrName y+{- *********************************************************************+*                                                                      *+                    Built-in families+*                                                                      *+********************************************************************* -} -instance Ord CoAxiomRule where-  -- we compare lexically to avoid non-deterministic output when sets of rules-  -- are printed-  compare x y = lexicalCompareFS (coaxrName x) (coaxrName y) -instance Outputable CoAxiomRule where-  ppr = ppr . coaxrName-+-- | A more explicit representation for `t1 ~ t2`.+type TypeEqn = Pair Type  -- Type checking of built-in families data BuiltInSynFamily = BuiltInSynFamily-  { sfMatchFam      :: [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: mkAxiomRuleCo coax (zipWith mkReflCo (coaxrAsmpRoles coax) ts)-    --              :: F tys ~r rhs,-    -- where the r in the output is coaxrRole of the rule. It is up to the-    -- caller to ensure that this role is appropriate.--  , sfInteractTop   :: [Type] -> Type -> [TypeEqn]+  { sfMatchFam :: [BuiltInFamRewrite]+  , sfInteract :: [BuiltInFamInjectivity]     -- If given these type arguments and RHS, returns the equalities that-    -- are guaranteed to hold.--  , sfInteractInert :: [Type] -> Type ->-                       [Type] -> Type -> [TypeEqn]-    -- If given one set of arguments and result, and another set of arguments-    -- and result, returns the equalities that are guaranteed to hold.+    -- 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      = \_ -> Nothing-  , sfInteractTop   = \_ _ -> []-  , sfInteractInert = \_ _ _ _ -> []-  }+trivialBuiltInFamily = BuiltInSynFamily { sfMatchFam = [], sfInteract = [] }
GHC/Core/Coercion/Opt.hs view
@@ -4,1248 +4,1510 @@  module GHC.Core.Coercion.Opt    ( optCoercion-   , checkAxInstCo-   , OptCoercionOpts (..)-   )-where--import GHC.Prelude--import GHC.Tc.Utils.TcType   ( exactTyCoVarsOfType )--import GHC.Core.TyCo.Rep-import GHC.Core.TyCo.Subst-import GHC.Core.Coercion-import GHC.Core.Type as Type hiding( substTyVarBndr, substTy )-import GHC.Core.TyCon-import GHC.Core.Coercion.Axiom-import GHC.Core.Unify--import GHC.Types.Var.Set-import GHC.Types.Var.Env--import GHC.Data.Pair-import GHC.Data.List.SetOps ( getNth )--import GHC.Utils.Outputable-import GHC.Utils.Constants (debugIsOn)-import GHC.Utils.Misc-import GHC.Utils.Panic-import GHC.Utils.Panic.Plain-import GHC.Utils.Trace--import Control.Monad   ( zipWithM )--{--%************************************************************************-%*                                                                      *-                 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]-~~~~~~~~~~~~~~~~~~~~~~~~-(1) tv is a type variable-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 ; t2 ~ t2 |> 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 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.--(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.--}---- | Coercion optimisation options-newtype OptCoercionOpts = OptCoercionOpts-   { optCoercionEnabled :: Bool  -- ^ Enable coercion optimisation (reduce its size)-   }--optCoercion :: OptCoercionOpts -> TCvSubst -> 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-  | otherwise               = substCo env co--optCoercion' :: TCvSubst -> Coercion -> NormalCo-optCoercion' 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-    assertPpr (substTyUnchecked env in_ty1 `eqType` out_ty1 &&-               substTyUnchecked env in_ty2 `eqType` out_ty2 &&-               in_role == out_role)-              ( text "optCoercion changed types!"-                 $$ hang (text "in_co:") 2 (ppr co)-                 $$ hang (text "in_ty1:") 2 (ppr in_ty1)-                 $$ hang (text "in_ty2:") 2 (ppr in_ty2)-                 $$ hang (text "out_co:") 2 (ppr out_co)-                 $$ hang (text "out_ty1:") 2 (ppr out_ty1)-                 $$ hang (text "out_ty2:") 2 (ppr out_ty2)-                 $$ hang (text "subst:") 2 (ppr env))-              out_co--  | otherwise         = opt_co1 lc False co-  where-    lc = mkSubstLiftingContext env---type NormalCo    = Coercion-  -- Invariants:-  --  * The substitution has been fully applied-  --  * 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 ty)-  = assertPpr (r == Nominal)-              (text "Expected role:" <+> ppr r    $$-               text "Found role:" <+> ppr Nominal $$-               text "Type:" <+> ppr ty) $-    liftCoSubst (chooseRole rep r) env ty--opt_co4 env _   rep r (GRefl _r ty MRefl)-  = assertPpr (r == _r)-              (text "Expected role:" <+> ppr r $$-               text "Found role:" <+> ppr _r   $$-               text "Type:" <+> ppr ty) $-    liftCoSubst (chooseRole rep r) env ty--opt_co4 env sym  rep r (GRefl _r ty (MCo co))-  = assertPpr (r == _r)-              (text "Expected role:" <+> ppr r $$-               text "Found role:" <+> ppr _r   $$-               text "Type:" <+> ppr ty) $-    if isGReflCo co || isGReflCo co'-    then liftCoSubst r' env ty-    else wrapSym sym $ mkCoherenceRightCo r' ty' co' (liftCoSubst r' env ty)-  where-    r'  = chooseRole rep r-    ty' = substTy (lcSubstLeft env) ty-    co' = opt_co4 env False False Nominal co--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 cow co1 co2)-  = assert (r == _r) $-    if rep-    then mkFunCo Representational cow' co1' co2'-    else mkFunCo r cow' co1' co2'-  where-    co1' = opt_co4_wrap env sym rep r co1-    co2' = opt_co4_wrap env sym rep r co2-    cow' = opt_co1 env sym cow--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]-  = 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 (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 (NthCo _r n co)-  | Just (ty, _) <- isReflCo_maybe co-  , Just (_tc, args) <- assert (r == _r )-                        splitTyConApp_maybe ty-  = liftCoSubst (chooseRole rep r) env (args `getNth` n)--  | Just (ty, _) <- isReflCo_maybe co-  , n == 0-  , Just (tv, _) <- splitForAllTyCoVar_maybe ty-      -- works for both tyvar and covar-  = liftCoSubst (chooseRole rep r) env (varType tv)--opt_co4 env sym rep r (NthCo r1 n (TyConAppCo _ _ cos))-  = assert (r == r1 )-    opt_co4_wrap env sym rep r (cos `getNth` n)---- see the definition of GHC.Builtin.Types.Prim.funTyCon-opt_co4 env sym rep r (NthCo r1 n (FunCo _r2 w co1 co2))-  = assert (r == r1 )-    opt_co4_wrap env sym rep r (mkNthCoFunCo n w co1 co2)--opt_co4 env sym rep r (NthCo _r n (ForAllCo _ eta _))-      -- works for both tyvar and covar-  = assert (r == _r )-    assert (n == 0 )-    opt_co4_wrap env sym rep Nominal eta--opt_co4 env sym rep r (NthCo _r n co)-  | Just nth_co <- case co' of-      TyConAppCo _ _ cos -> Just (cos `getNth` n)-      FunCo _ w co1 co2  -> Just (mkNthCoFunCo n w co1 co2)-      ForAllCo _ eta _   -> Just eta-      _                  -> Nothing-  = if rep && (r == Nominal)-      -- keep propagating the SubCo-    then opt_co4_wrap (zapLiftingContext env) False True Nominal nth_co-    else nth_co--  | otherwise-  = wrapRole rep r $ NthCo r n co'-  where-    co' = 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_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_ty_maybe co1-  = opt_co4_wrap (extendLiftingContext env tv-                    (mkCoherenceRightCo Nominal t2 (mkSymCo kind_co) sym_arg))-                   -- mkSymCo kind_co :: k1 ~ k2-                   -- sym_arg :: (t1 :: k1) ~ (t2 :: k2)-                   -- tv |-> (t1 :: k1) ~ (((t2 :: k2) |> (sym kind_co)) :: k1)-                 sym rep r co_body--    -- forall over coercion...-  | Just (cv, kind_co, co_body) <- splitForAllCo_co_maybe co1-  , CoercionTy h1 <- t1-  , CoercionTy h2 <- t2-  = let new_co = mk_new_co cv (opt_co4_wrap env sym False Nominal kind_co) h1 h2-    in opt_co4_wrap (extendLiftingContext env cv new_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_ty_maybe co1'-  = opt_co4_wrap (extendLiftingContext (zapLiftingContext env) tv'-                    (mkCoherenceRightCo Nominal t2' (mkSymCo kind_co') arg'))-            False False r' co_body'--    -- forall over coercion...-  | Just (cv', kind_co', co_body') <- splitForAllCo_co_maybe co1'-  , CoercionTy h1' <- t1'-  , CoercionTy h2' <- t2'-  = let new_co = mk_new_co cv' kind_co' h1' h2'-    in opt_co4_wrap (extendLiftingContext (zapLiftingContext env) cv' new_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-    sym_arg = wrapSym sym arg'--    -- Performance note: don't be alarmed by the two calls to coercionKind-    -- here, as only one call to coercionKind is actually demanded per guard.-    -- t1/t2 are used when checking if co1 is a forall, and t1'/t2' are used-    -- when checking if co1' (i.e., co1 post-optimization) is a forall.-    ---    -- t1/t2 must come from sym_arg, not arg', since it's possible that arg'-    -- might have an extra Sym at the front (after being optimized) that co1-    -- lacks, so we need to use sym_arg to balance the number of Syms. (#15725)-    Pair t1  t2  = coercionKind sym_arg-    Pair t1' t2' = coercionKind arg'--    mk_new_co cv kind_co h1 h2-      = let -- h1 :: (t1 ~ t2)-            -- h2 :: (t3 ~ t4)-            -- kind_co :: (t1 ~ t2) ~ (t3 ~ t4)-            -- n1 :: t1 ~ t3-            -- n2 :: t2 ~ t4-            -- new_co = (h1 :: t1 ~ t2) ~ ((n1;h2;sym n2) :: t1 ~ t2)-            r2  = coVarRole cv-            kind_co' = downgradeRole r2 Nominal kind_co-            n1 = mkNthCo r2 2 kind_co'-            n2 = mkNthCo r2 3 kind_co'-         in mkProofIrrelCo Nominal (Refl (coercionType h1)) h1-                           (n1 `mkTransCo` h2 `mkTransCo` (mkSymCo n2))--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 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 -> 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 #13658--Note [opt_univ needs injectivity]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If opt_univ sees a coercion between `T a1 a2` and `T b1 b2` it will optimize it-by producing a TyConAppCo for T, and pushing the UnivCo into the arguments.  But-this works only if T is injective. Otherwise we can have something like--  type family F x where-    F Int  = Int-    F Bool = Int--where `UnivCo :: F Int ~ F Bool` is reasonable (it is effectively just an-alternative representation for a couple of uses of AxiomInstCos) but we do not-want to produce `F (UnivCo :: Int ~ Bool)` where the inner coercion is clearly-inconsistent.  Hence the opt_univ case for TyConApps checks isInjectiveTyCon.-See #19509.-- -}--opt_univ :: LiftingContext -> SymFlag -> UnivCoProvenance -> Role-         -> 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-  , 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    = 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) <- splitForAllTyVar_maybe oty1-  , Just (tv2, ty2) <- splitForAllTyVar_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')--  | Just (cv1, ty1) <- splitForAllCoVar_maybe oty1-  , Just (cv2, ty2) <- splitForAllCoVar_maybe oty2-      -- NB: prov isn't interesting here either-  = let k1    = varType cv1-        k2    = varType cv2-        r'    = coVarRole cv1-        eta   = mkUnivCo prov' Nominal k1 k2-        eta_d = downgradeRole r' Nominal eta-          -- eta gets opt'ed soon, but not yet.-        n_co  = (mkSymCo $ mkNthCo r' 2 eta_d) `mkTransCo`-                (mkCoVarCo cv1) `mkTransCo`-                (mkNthCo r' 3 eta_d)-        ty2'  = substTyWithCoVars [cv2] [n_co] ty2--        (env', cv1', eta') = optForAllCoBndr env sym cv1 eta-    in-    mkForAllCo cv1' 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-#if __GLASGOW_HASKELL__ < 901--- This alt is redundant with the first match of the FunDef-      PhantomProv kco    -> PhantomProv $ opt_co4_wrap env sym False Nominal kco-#endif-      ProofIrrelProv kco -> ProofIrrelProv $ opt_co4_wrap env sym False Nominal kco-      PluginProv _       -> prov-      CorePrepProv _     -> prov----------------opt_transList :: HasDebugCallStack => InScopeSet -> [NormalCo] -> [NormalCo] -> [NormalCo]-opt_transList is = zipWithEqual "opt_transList" (opt_trans is)-  -- The input lists must have identical length.--opt_trans :: 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 :: 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 :: 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--opt_trans_rule is in_co1@(GRefl r1 t1 (MCo co1)) in_co2@(GRefl r2 _ (MCo co2))-  = assert (r1 == r2) $-    fireTransRule "GRefl" in_co1 in_co2 $-    mkGReflRightCo r1 t1 (opt_trans is co1 co2)---- Push transitivity through matching destructors-opt_trans_rule is in_co1@(NthCo r1 d1 co1) in_co2@(NthCo r2 d2 co2)-  | d1 == d2-  , coercionRole co1 == coercionRole co2-  , co1 `compatible_co` co2-  = assert (r1 == r2) $-    fireTransRule "PushNth" in_co1 in_co2 $-    mkNthCo r1 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 (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@(FunCo r1 w1 co1a co1b) in_co2@(FunCo r2 w2 co2a co2b)-  = assert (r1 == r2) $   -- Just like the TyConAppCo/TyConAppCo case-    fireTransRule "PushFun" in_co1 in_co2 $-    mkFunCo r1 (opt_trans is w1 w2) (opt_trans is co1a co2a) (opt_trans is co1b co2b)--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, eta1, r1) <- splitForAllCo_ty_maybe co1-  , Just (tv2, eta2, r2) <- etaForAllCo_ty_maybe co2-  = push_trans tv1 eta1 r1 tv2 eta2 r2--  | Just (tv2, eta2, r2) <- splitForAllCo_ty_maybe co2-  , Just (tv1, eta1, r1) <- etaForAllCo_ty_maybe co1-  = push_trans tv1 eta1 r1 tv2 eta2 r2--  where-  push_trans tv1 eta1 r1 tv2 eta2 r2-    -- 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 (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, eta1, r1) <- splitForAllCo_co_maybe co1-  , Just (cv2, eta2, r2) <- etaForAllCo_co_maybe co2-  = push_trans cv1 eta1 r1 cv2 eta2 r2--  | Just (cv2, eta2, r2) <- splitForAllCo_co_maybe co2-  , Just (cv1, eta1, r1) <- etaForAllCo_co_maybe co1-  = push_trans cv1 eta1 r1 cv2 eta2 r2--  where-  push_trans cv1 eta1 r1 cv2 eta2 r2-    -- 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 (opt_trans is eta1 eta2) (opt_trans is' r1 r2')-    where-      is'  = is `extendInScopeSet` cv1-      role = coVarRole cv1-      eta1' = downgradeRole role Nominal eta1-      n1   = mkNthCo role 2 eta1'-      n2   = mkNthCo role 3 eta1'-      r2'  = substCo (zipCvSubst [cv2] [(mkSymCo n1) `mkTransCo`-                                        (mkCoVarCo cv1) `mkTransCo` n2])-                    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 _ 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 mkTransCo 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 [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] <*> <Int> <Int). (Recall that the index is-0-based, so this is the second branch of the axiom.) The problem is that, on-the surface, it seems that (axEqual[1] <*> <Int> <Int>) :: (Equal * Int Int ~-False) and that all is OK. But, all is not OK: we want to use the first branch-of the axiom in this case, not the second. The problem is that the parameters-of the first branch can unify with the supplied coercions, thus meaning that-the first branch should be taken. See also Note [Apartness] in-"GHC.Core.FamInstEnv".--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] <Int> <Bool>-  :: Equal Int Bool ~ False--We wish to optimise (co1 ; co2). We end up in rule TrPushAxL, noting that-co2 is an axiom and that matchAxiom succeeds when looking at co1. But, what-happens when we push the coercions inside? We get--co3 = axEq[1] (axId[0] Int) (axId[0] Bool)-  :: Equal (Id Int) (Id Bool) ~ False--which is bogus! This is because the type system isn't smart enough to know-that (Id Int) and (Id Bool) are 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.--Note [EtaAppCo]-~~~~~~~~~~~~~~~-Suppose we're trying to optimize (co1a co1b ; co2a co2b). Ideally, we'd-like to rewrite this to (co1a ; co2a) (co1b ; co2b). The problem is that-the resultant coercions might not be well kinded. Here is an example (things-labeled with x don't matter in this example):--  k1 :: Type-  k2 :: Type--  a :: k1 -> Type-  b :: k1--  h :: k1 ~ k2--  co1a :: x1 ~ (a |> (h -> <Type>)-  co1b :: x2 ~ (b |> h)--  co2a :: a ~ x3-  co2b :: b ~ x4--First, convince yourself of the following:--  co1a co1b :: x1 x2 ~ (a |> (h -> <Type>)) (b |> h)-  co2a co2b :: a b   ~ x3 x4--  (a |> (h -> <Type>)) (b |> h) `eqType` a b--That last fact is due to Note [Non-trivial definitional equality] in GHC.Core.TyCo.Rep,-where we ignore coercions in types as long as two types' kinds are the same.-In our case, we meet this last condition, because--  (a |> (h -> <Type>)) (b |> h) :: Type-    and-  a b :: Type--So the input coercion (co1a co1b ; co2a co2b) is well-formed. But the-suggested output coercions (co1a ; co2a) and (co1b ; co2b) are not -- the-kinds don't match up.--The solution here is to twiddle the kinds in the output coercions. First, we-need to find coercions--  ak :: kind(a |> (h -> <Type>)) ~ kind(a)-  bk :: kind(b |> h)             ~ kind(b)--This can be done with mkKindCo and buildCoercion. The latter assumes two-types are identical modulo casts and builds a coercion between them.--Then, we build (co1a ; co2a |> sym ak) and (co1b ; co2b |> sym bk) as the-output coercions. These are well-kinded.--Also, note that all of this is done after accumulated any nested AppCo-parameters. This step is to avoid quadratic behavior in calling coercionKind.--The problem described here was first found in dependent/should_compile/dynamic-paper.---}---- | 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 GHC.Core.Coercion--- If you edit this function, you may need to update the GHC formalism--- See Note [GHC Formalism] in GHC.Core.Lint-checkAxInstCo (AxiomInstCo ax ind cos)-  = let branch       = coAxiomNthBranch ax ind-        tvs          = coAxBranchTyVars branch-        cvs          = coAxBranchCoVars branch-        incomps      = coAxBranchIncomps branch-        (tys, cotys) = splitAtList tvs (map coercionLKind 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 GHC.Core.FamInstEnv-      | SurelyApart <- tcUnifyTysFG alwaysBindFun flat lhs_incomp-      = check_no_conflict flat rest-      | otherwise-      = Just b-checkAxInstCo _ = Nothing---------------wrapSym :: SymFlag -> Coercion -> Coercion-wrapSym sym co | sym       = mkSymCo 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----------------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   = mkNthCo Nominal 0 g :: (s1~s2)~(s3~s4)-  eta1 = mkNthCo r 2 h1      :: (s1 ~ s3)-  eta2 = mkNthCo r 3 h1      :: (s2 ~ s4)-  h2   = mkInstCo g (cv1 ~ (sym eta1;c1;eta2))--}-etaForAllCo_ty_maybe :: Coercion -> Maybe (TyVar, Coercion, Coercion)--- Try to make the coercion be of form (forall tv:kind_co. co)-etaForAllCo_ty_maybe co-  | Just (tv, kind_co, r) <- splitForAllCo_ty_maybe co-  = Just (tv, kind_co, r)--  | Pair ty1 ty2  <- coercionKind co-  , Just (tv1, _) <- splitForAllTyVar_maybe ty1-  , isForAllTy_ty ty2-  , let kind_co = mkNthCo Nominal 0 co-  = Just ( tv1, kind_co-         , mkInstCo co (mkGReflRightCo Nominal (TyVarTy tv1) kind_co))--  | otherwise-  = Nothing--etaForAllCo_co_maybe :: Coercion -> Maybe (CoVar, Coercion, Coercion)--- Try to make the coercion be of form (forall cv:kind_co. co)-etaForAllCo_co_maybe co-  | Just (cv, kind_co, r) <- splitForAllCo_co_maybe co-  = Just (cv, kind_co, r)--  | Pair ty1 ty2  <- coercionKind co-  , Just (cv1, _) <- splitForAllCoVar_maybe ty1-  , isForAllTy_co ty2-  = let kind_co  = mkNthCo Nominal 0 co-        r        = coVarRole cv1-        l_co     = mkCoVarCo cv1-        kind_co' = downgradeRole r Nominal kind_co-        r_co     = (mkSymCo (mkNthCo r 2 kind_co')) `mkTransCo`-                   l_co `mkTransCo`-                   (mkNthCo r 3 kind_co')-    in Just ( cv1, 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 [ 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-  | not (mustBeSaturated 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 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---}--optForAllCoBndr :: LiftingContext -> Bool-                -> TyCoVar -> Coercion -> (LiftingContext, TyCoVar, Coercion)-optForAllCoBndr env sym-  = substForAllCoBndrUsingLC sym (opt_co4_wrap env sym False Nominal) env+   , OptCoercionOpts (..)+   )+where++import GHC.Prelude++import GHC.Tc.Utils.TcType   ( exactTyCoVarsOfType )++import GHC.Core.TyCo.Rep+import GHC.Core.TyCo.Subst+import GHC.Core.TyCo.Compare( eqType, eqForAllVis )+import GHC.Core.Coercion+import GHC.Core.Type as Type hiding( substTyVarBndr, substTy )+import GHC.Core.TyCon+import GHC.Core.Coercion.Axiom+import GHC.Core.Unify++import GHC.Types.Basic( SwapFlag(..), flipSwap, isSwapped, pickSwap, notSwapped )+import GHC.Types.Var+import GHC.Types.Var.Set+import GHC.Types.Var.Env++import GHC.Data.Pair++import GHC.Utils.Outputable+import GHC.Utils.Constants (debugIsOn)+import GHC.Utils.Misc+import GHC.Utils.Panic++import Control.Monad   ( zipWithM )++{-+%************************************************************************+%*                                                                      *+                 Optimising coercions+%*                                                                      *+%************************************************************************++This module does coercion optimisation.  See the paper++   Evidence normalization in Systtem FV (RTA'13)+   https://simon.peytonjones.org/evidence-normalization/++The paper is also in the GHC repo, in docs/opt-coercion.++Note [Optimising coercion optimisation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Looking up a coercion's role or kind is linear in the size of the+coercion. Thus, doing this repeatedly during the recursive descent+of coercion optimisation is disastrous. We must be careful to avoid+doing this if at all possible.++Because it is generally easy to know a coercion's components' roles+from the role of the outer coercion, we pass down the known role of+the input in the algorithm below. We also keep functions opt_co2+and opt_co3 separate from opt_co4, so that the former two do Phantom+checks that opt_co4 can avoid. This is a big win because Phantom coercions+rarely appear within non-phantom coercions -- only in some TyConAppCos+and some AxiomInstCos. We handle these cases specially by calling+opt_co2.++Note [Optimising InstCo]+~~~~~~~~~~~~~~~~~~~~~~~~+Optimising InstCo is pretty subtle: #15725, #25387.++(1) tv is a type variable. We want to optimise++  InstCo (ForAllCo tv kco g) g2  -->   S(g)++where S is some substitution. Let's look at the typing rules.++    kco : k1 ~ k2+    tv:k1 |- g : t1 ~ t2+    -----------------------------+    ForAllCo tv kco g : (all tv:k1.t1) ~ (all tv:k2.t2[tv |-> tv |> sym kco])++    g1 : (all tv:k1.t1') ~ (all tv:k2.t2')+    g2 : (s1:k1) ~ (s2:k2)+    --------------------+    InstCo g1 g2 : t1'[tv |-> s1] ~ t2'[tv |-> s2]++Putting these two together++    kco : k1 ~ k2+    tv:k1 |- g : t1 ~ t2+    g2 : (s1:k1) ~ (s2:k2)+    --------------------+    InstCo (ForAllCo tv kco g) g2 : t1[tv |-> s1] ~ t2[tv |-> s2 |> sym kco]++We thus want S(g) to have kind++  S(g) :: (t1[tv |-> s1]) ~ (t2[tv |-> s2 |> sym kco])++All we need do is to substitute the coercion tv_co for tv:+  S = [tv :-> tv_co]+where+  tv_co : s1 ~ (s2 |> sym kco)+This looks bizarre, because we're substituting a /type variable/ with a+/coercion/. However, this operation already exists: it's called *lifting*, and+defined in GHC.Core.Coercion.  We just need to enhance the lifting operation to+be able to deal with an ambient substitution, which is why a LiftingContext+stores a TCvSubst.++In general if+  S = [tv :-> tv_co]+  tv_co : r1 ~ r2+  g     : t1 ~ t2+then+  S(g) : t1[tv :-> r1] ~ t2[tv :-> r2]++The substitution S is embodied in the LiftingContext argument of `opt_co4`;+See Note [The LiftingContext in optCoercion]++(2) cv is a coercion variable+Now consider we have (InstCo (ForAllCo cv h g) g2), we want to optimise.++h : (t1 ~r t2) ~N (t3 ~r t4)+cv : t1 ~r t2 |- g : t1' ~r2 t2'+n1 = nth r 2 (downgradeRole r N h) :: t1 ~r t3+n2 = nth r 3 (downgradeRole r N h) :: t2 ~r t4+------------------------------------------------+ForAllCo cv h g : (all cv:t1 ~r t2. t1') ~r2+                  (all cv:t3 ~r t4. t2'[cv |-> n1 ; cv ; sym n2])++g1 : (all cv:t1 ~r t2. t1') ~ (all cv: t3 ~r t4. t2')+g2 : h1 ~N h2+h1 : t1 ~r t2+h2 : t3 ~r t4+------------------------------------------------+InstCo g1 g2 : t1'[cv |-> h1] ~ t2'[cv |-> h2]++We thus want some coercion proving this:++  t1'[cv |-> h1] ~ t2'[cv |-> n1 ; h2; sym n2]++So we substitute the coercion variable c for the coercion+(h1 ~N (n1; h2; sym n2)) in g.++Note [The LiftingContext in optCoercion]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+To suppport Note [Optimising InstCo] the coercion optimiser carries a+GHC.Core.Coercion.LiftingContext, which comprises+  * An ordinary Subst+  * The `lc_env`: a mapping from /type variables/ to /coercions/++We don't actually have a separate function+   liftCoSubstCo :: LiftingContext -> Coercion -> Coercion+The substitution of a type variable by a coercion is done by the calls to+`liftCoSubst` (on a type) in the Refl and GRefl cases of `opt_co4`.++We use the following invariants:+ (LC1) The coercions in the range of `lc_env` have already had all substitutions+       applied; they are "OutCoercions".  If you re-optimise these coercions, you+       must zap the LiftingContext first.++ (LC2) However they have /not/ had the "ambient sym" (the second argument of+       `opt_co4`) applied.  The ambient sym applies to the entire coercion not+       to the little bits being substituted.+-}++-- | Coercion optimisation options+newtype OptCoercionOpts = OptCoercionOpts+   { optCoercionEnabled :: Bool  -- ^ Enable coercion optimisation (reduce its size)+   }++optCoercion :: OptCoercionOpts -> Subst -> Coercion -> NormalCo+-- ^ optCoercion applies a substitution to a coercion,+--   *and* optimises it to reduce its size+optCoercion opts env co+  | optCoercionEnabled opts+  = optCoercion' env co++{-+  = pprTrace "optCoercion {" (text "Co:" <> ppr (coercionSize co)) $+    let result = optCoercion' env co in+    pprTrace "optCoercion }"+       (vcat [ text "Co:"    <+> ppr (coercionSize co)+             , text "Optco:" <+> ppWhen (isReflCo result) (text "(refl)")+                             <+> ppr (coercionSize result) ]) $+    result+-}++  | otherwise+  = substCo env co++optCoercion' :: Subst -> Coercion -> NormalCo+optCoercion' env co+  | debugIsOn+  = let out_co = opt_co1 lc NotSwapped co+        (Pair in_ty1  in_ty2,  in_role)  = coercionKindRole co+        (Pair out_ty1 out_ty2, out_role) = coercionKindRole out_co++        details = vcat [ text "in_co:" <+> ppr co+                       , text "in_ty1:" <+> ppr in_ty1+                       , text "in_ty2:" <+> ppr in_ty2+                       , text "out_co:" <+> ppr out_co+                       , text "out_ty1:" <+> ppr out_ty1+                       , text "out_ty2:" <+> ppr out_ty2+                       , text "in_role:" <+> ppr in_role+                       , text "out_role:" <+> ppr out_role+                       ]+    in+    warnPprTrace (not (isReflCo out_co) && isReflexiveCo out_co)+                 "optCoercion: reflexive but not refl" details $+    -- The coercion optimiser should usually optimise+    --     co:ty~ty   -->  Refl ty+    -- But given a silly `newtype N = MkN N`, the axiom has type (N ~ N),+    -- and so that can trigger this warning (e.g. test str002).+    -- Maybe we should optimise that coercion to (Refl N), but it+    -- just doesn't seem worth the bother+    out_co++  | otherwise+  = opt_co1 lc NotSwapped co+  where+    lc = mkSubstLiftingContext env+--    ppr_one cv = ppr cv <+> dcolon <+> ppr (coVarKind cv)+++type NormalCo    = Coercion+  -- Invariants:+  --  * The substitution has been fully applied+  --  * For trans coercions (co1 `trans` co2)+  --       co1 is not a trans, and neither co1 nor co2 is identity++type NormalNonIdCo = NormalCo  -- Extra invariant: not the identity++-- | Do we force the result to be representational?+type ReprFlag = Bool++-- | Optimize a coercion, making no assumptions. All coercions in+-- the lifting context are already optimized (and sym'd if nec'y)+opt_co1 :: LiftingContext+        -> SwapFlag   -- IsSwapped => apply Sym to the result+        -> Coercion -> NormalCo+opt_co1 env sym co = opt_co2 env sym (coercionRole co) co++-- See Note [Optimising coercion optimisation]+-- | Optimize a coercion, knowing the coercion's role. No other assumptions.+opt_co2 :: LiftingContext+        -> SwapFlag   -- ^IsSwapped => apply Sym to the result+        -> Role       -- ^ The role of the input coercion+        -> Coercion -> NormalCo+opt_co2 env sym Phantom co = opt_phantom env sym co+opt_co2 env sym r       co = opt_co4 env sym False r co++-- See Note [Optimising coercion optimisation]+-- | Optimize a coercion, knowing the coercion's non-Phantom role,+--   and with an optional downgrade+opt_co3 :: LiftingContext -> SwapFlag -> Maybe Role -> Role -> Coercion -> NormalCo+opt_co3 env sym (Just Phantom)          _ co = opt_phantom env sym co+opt_co3 env sym (Just Representational) r co = opt_co4 env sym True  r co+  -- if mrole is Just Nominal, that can't be a downgrade, so we can ignore+opt_co3 env sym _                       r co = opt_co4 env sym False r co++-- See Note [Optimising coercion optimisation]+-- | Optimize a non-phantom coercion.+opt_co4, opt_co4' :: LiftingContext -> SwapFlag -> ReprFlag+                  -> Role -> Coercion -> NormalCo+-- Precondition:  In every call (opt_co4 lc sym rep role co)+--                we should have role = coercionRole co+-- Precondition:  role is not Phantom+-- Postcondition: The resulting coercion is equivalant to+--                     wrapsub (wrapsym (mksub co)+--                 where wrapsym is SymCo if sym=True+--                       wrapsub is SubCo if rep=True++-- opt_co4 is there just to support tracing, when debugging+-- Usually it just goes straight to opt_co4'+opt_co4 = opt_co4'++{-+opt_co4 env sym rep r co+  = pprTrace "opt_co4 {"+   ( vcat [ text "Sym:" <+> ppr sym+          , text "Rep:" <+> ppr rep+          , text "Role:" <+> ppr r+          , text "Co:" <+> ppr co ]) $+   assert (r == coercionRole co )    $+   let result = opt_co4' env sym rep r co in+   pprTrace "opt_co4 }" (ppr co $$ text "---" $$ ppr result) $+   assertPpr (res_role == coercionRole result)+             (vcat [ text "Role:" <+> ppr r+                   , text "Result: " <+>  ppr result+                   , text "Result type:" <+> ppr (coercionType result) ]) $+   result++  where+    res_role | rep       = Representational+             | otherwise = r+-}++opt_co4' env sym rep r (Refl ty)+  = assertPpr (r == Nominal)+              (text "Expected role:" <+> ppr r    $$+               text "Found role:" <+> ppr Nominal $$+               text "Type:" <+> ppr ty) $+    wrapSym sym $ liftCoSubst (chooseRole rep r) env ty+        -- wrapSym: see (LC2) of Note [The LiftingContext in optCoercion]++opt_co4' env sym rep r (GRefl _r ty MRefl)+  = assertPpr (r == _r)+              (text "Expected role:" <+> ppr r $$+               text "Found role:" <+> ppr _r   $$+               text "Type:" <+> ppr ty) $+    wrapSym sym $ liftCoSubst (chooseRole rep r) env ty+        -- wrapSym: see (LC2) of Note [The LiftingContext in optCoercion]++opt_co4' env sym  rep r (GRefl _r ty (MCo kco))+  = assertPpr (r == _r)+              (text "Expected role:" <+> ppr r $$+               text "Found role:" <+> ppr _r   $$+               text "Type:" <+> ppr ty) $+    if isGReflCo kco || isGReflCo kco'+    then wrapSym sym ty_co+    else wrapSym sym $ mk_coherence_right_co r' (coercionRKind ty_co) kco' ty_co+            -- ty :: k1+            -- kco :: k1 ~ k2+            -- Desired result coercion:   ty ~ ty |> co+  where+    r'    = chooseRole rep r+    ty_co = liftCoSubst r' env ty+    kco'  = opt_co4 env NotSwapped False Nominal kco++opt_co4' env sym rep r (SymCo co)  = opt_co4 env (flipSwap sym) rep r co+  -- surprisingly, we don't have to do anything to the env here. This is+  -- because any "lifting" substitutions in the env are tied to ForAllCos,+  -- which treat their left and right sides differently. We don't want to+  -- exchange them.++opt_co4' env sym rep r g@(TyConAppCo _r tc cos)+  = assert (r == _r) $+    case (rep, r) of+      (True, Nominal) ->+        mkTyConAppCo Representational tc+                     (zipWith3 (opt_co3 env sym)+                               (map Just (tyConRoleListRepresentational tc))+                               (repeat Nominal)+                               cos)+      (False, Nominal) ->+        mkTyConAppCo Nominal tc (map (opt_co4 env sym False Nominal) cos)+      (_, Representational) ->+                      -- must use opt_co2 here, because some roles may be P+                      -- See Note [Optimising coercion optimisation]+        mkTyConAppCo r tc (zipWith (opt_co2 env sym)+                                   (tyConRoleListRepresentational tc)  -- the current roles+                                   cos)+      (_, Phantom) -> pprPanic "opt_co4 sees a phantom!" (ppr g)++opt_co4' env sym rep r (AppCo co1 co2)+  = mkAppCo (opt_co4 env sym rep r co1)+            (opt_co4 env sym False Nominal co2)++opt_co4' env sym rep r (ForAllCo { fco_tcv = tv, fco_visL = visL, fco_visR = visR+                                 , fco_kind = k_co, fco_body = co })+  = mkForAllCo tv' visL' visR' k_co' $+    opt_co4 env' sym rep r co+     -- Use the "mk" functions to check for nested Refls+  where+    !(env', tv', k_co') = optForAllCoBndr env sym tv k_co+    !(visL', visR') = swapSym sym (visL, visR)++opt_co4' env sym rep r (FunCo _r afl afr cow co1 co2)+  = assert (r == _r) $+    mkFunCo2 r' afl' afr' cow' co1' co2'+  where+    co1' = opt_co4 env sym rep r co1+    co2' = opt_co4 env sym rep r co2+    cow' = opt_co1 env sym cow+    !r' | rep       = Representational+        | otherwise = r+    !(afl', afr') = swapSym sym (afl, afr)++opt_co4' env sym rep r (CoVarCo cv)+  | Just co <- lcLookupCoVar env cv   -- see Note [Forall over coercion] for why+                                      -- this is the right thing here+  = -- pprTrace "CoVarCo" (ppr cv $$ ppr co) $+    opt_co4 (zapLiftingContext env) sym rep r co++  | ty1 `eqType` ty2   -- See Note [Optimise CoVarCo to Refl]+  = mkReflCo (chooseRole rep r) ty1++  | otherwise+  = assert (isCoVar cv1) $+    wrapRole rep r $ wrapSym sym $+    CoVarCo cv1++  where+    Pair ty1 ty2 = coVarTypes cv1++    cv1 = case lookupInScope (lcInScopeSet env) cv of+             Just cv1 -> cv1+             Nothing  -> warnPprTrace True+                          "opt_co: not in scope"+                          (ppr cv $$ ppr env)+                          cv+          -- cv1 might have a substituted kind!++opt_co4' _ _ _ _ (HoleCo h)+  = pprPanic "opt_univ fell into a hole" (ppr h)++opt_co4' env sym rep r (AxiomCo con cos)+    -- Do *not* push sym inside top-level axioms+    -- e.g. if g is a top-level axiom+    --   g a : f a ~ a+    -- then (sym (g ty)) /= g (sym ty) !!+  = assert (r == coAxiomRuleRole con )+    wrapRole rep (coAxiomRuleRole con) $+    wrapSym sym $+                       -- some sub-cos might be P: use opt_co2+                       -- See Note [Optimising coercion optimisation]+    AxiomCo con (zipWith (opt_co2 env NotSwapped)+                         (coAxiomRuleArgRoles con)+                         cos)+      -- Note that the_co does *not* have sym pushed into it++opt_co4' env sym rep r (UnivCo { uco_prov = prov, uco_lty = t1+                              , uco_rty = t2, uco_deps = deps })+  = opt_univ env sym prov deps (chooseRole rep r) t1 t2++opt_co4' env sym rep r (TransCo co1 co2)+  -- sym (g `o` h) = sym h `o` sym g+  | isSwapped sym = opt_trans in_scope co2' co1'+  | otherwise     = opt_trans in_scope co1' co2'+  where+    co1' = opt_co4 env sym rep r co1+    co2' = opt_co4 env sym rep r co2+    in_scope = lcInScopeSet env++opt_co4' env sym rep r (SelCo cs co)+  -- Historical note 1: we used to check `co` for Refl, TyConAppCo etc+  -- before optimising `co`; but actually the SelCo will have been built+  -- with mkSelCo, so these tests always fail.++  -- Historical note 2: if rep=True and r=Nominal, we used to recursively+  -- call opt_co4 to re-optimse the result. But (a) that is inefficient+  -- and (b) wrapRole uses mkSubCo which does much the same job+  = wrapRole rep r $ mkSelCo cs $ opt_co1 env sym co++opt_co4' env sym rep r (LRCo lr co)+  | Just pr_co <- splitAppCo_maybe co+  = assert (r == Nominal )+    opt_co4 env sym rep Nominal (pick_lr lr pr_co)+  | Just pr_co <- splitAppCo_maybe co'+  = assert (r == Nominal) $+    if rep+    then opt_co4 (zapLiftingContext env) NotSwapped True Nominal (pick_lr lr pr_co)+    else pick_lr lr pr_co+  | otherwise+  = wrapRole rep Nominal $ LRCo lr co'+  where+    co' = opt_co4 env sym False Nominal co++    pick_lr CLeft  (l, _) = l+    pick_lr CRight (_, r) = r++{-+Note [Forall over coercion]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Example:+  type (:~:) :: forall k. k -> k -> Type+  Refl :: forall k (a :: k) (b :: k). forall (cv :: (~#) k k a b). (:~:) k a b+  k1,k2,k3,k4 :: Type+  eta :: (k1 ~# k2) ~# (k3 ~# k4)    ==    ((~#) Type Type k1 k2) ~# ((~#) Type Type k3 k4)+  co1_3 :: k1 ~# k3+  co2_4 :: k2 ~# k4+  nth 2 eta :: k1 ~# k3+  nth 3 eta :: k2 ~# k4+  co11_31 :: <k1> ~# (sym co1_3)+  co22_24 :: <k2> ~# co2_4+  (forall (cv :: eta). Refl <Type> co1_3 co2_4 (co11_31 ;; cv ;; co22_24)) ::+    (forall (cv :: k1 ~# k2). Refl Type k1 k2 (<k1> ;; cv ;; <k2>) ~#+    (forall (cv :: k3 ~# k4). Refl Type k3 k4+       (sym co1_3 ;; nth 2 eta ;; cv ;; sym (nth 3 eta) ;; co2_4))+  co1_2 :: k1 ~# k2+  co3_4 :: k3 ~# k4+  co5 :: co1_2 ~# co3_4+  InstCo (forall (cv :: eta). Refl <Type> co1_3 co2_4 (co11_31 ;; cv ;; co22_24)) co5 ::+   (Refl Type k1 k2 (<k1> ;; cv ;; <k2>))[cv |-> co1_2] ~#+   (Refl Type k3 k4 (sym co1_3 ;; nth 2 eta ;; cv ;; sym (nth 3 eta) ;; co2_4))[cv |-> co3_4]+      ==+   (Refl Type k1 k2 (<k1> ;; co1_2 ;; <k2>)) ~#+    (Refl Type k3 k4 (sym co1_3 ;; nth 2 eta ;; co3_4 ;; sym (nth 3 eta) ;; co2_4))+      ==>+   Refl <Type> co1_3 co2_4 (co11_31 ;; co1_2 ;; co22_24)+Conclusion: Because of the way this all works, we want to put in the *left-hand*+coercion in co5's type. (In the code, co5 is called `arg`.)+So we extend the environment binding cv to arg's left-hand type.+-}++-- See Note [Optimising InstCo]+opt_co4' env sym rep r (InstCo fun_co arg_co)+    -- forall over type...+  | Just (tv, _visL, _visR, k_co, body_co) <- splitForAllCo_ty_maybe fun_co+    -- tv      :: k1+    -- k_co    :: k1 ~ k2+    -- body_co :: t1 ~ t2+    -- arg_co  :: (s1:k1) ~ (s2:k2)+  , let arg_co'  = opt_co4 env NotSwapped False Nominal arg_co+                  -- Do /not/ push Sym into the arg_co, hence sym=False+                  -- see (LC2) of Note [The LiftingContext in optCoercion]+        k_co' = opt_co4 env NotSwapped False Nominal k_co+        s2'   = coercionRKind arg_co'+        tv_co = mk_coherence_right_co Nominal s2' (mkSymCo k_co') arg_co'+                   -- mkSymCo kind_co :: k2 ~ k1+                   -- tv_co   :: (s1 :: k1) ~ (((s2 :: k2) |> (sym kind_co)) :: k1)+  = opt_co4 (extendLiftingContext env tv tv_co) sym rep r body_co++    -- See Note [Forall over coercion]+  | Just (cv, _visL, _visR, _kind_co, body_co) <- splitForAllCo_co_maybe fun_co+  , CoercionTy h1 <- coercionLKind arg_co+  , let h1' = opt_co4 env NotSwapped False Nominal h1+  = opt_co4 (extendLiftingContextCvSubst env cv h1') sym rep r body_co++  -- OK so those cases didn't work.  See if it is a forall /after/ optimization+  -- If so, do an inefficient one-variable substitution, then re-optimize++    -- forall over type...+  | Just (tv', _visL, _visR, k_co', body_co') <- splitForAllCo_ty_maybe fun_co'+  , let s2'   = coercionRKind arg_co'+        tv_co = mk_coherence_right_co Nominal s2' (mkSymCo k_co') arg_co'+        env'  = extendLiftingContext (zapLiftingContext env) tv' tv_co+  = opt_co4 env' NotSwapped False r' body_co'++    -- See Note [Forall over coercion]+  | Just (cv', _visL, _visR, _kind_co', body_co') <- splitForAllCo_co_maybe fun_co'+  , CoercionTy h1' <- coercionLKind arg_co'+  , let env' = extendLiftingContextCvSubst (zapLiftingContext env) cv' h1'+  = opt_co4 env' NotSwapped False r' body_co'++  -- Those cases didn't work either, so rebuild the InstCo+  -- Push Sym into /both/ function /and/ arg_coument+  | otherwise = InstCo fun_co' arg_co'++  where+    -- fun_co' arg_co' are both optimised, /and/ we have pushed `sym` into both+    -- So no more sym'ing on th results of fun_co' arg_co'+    fun_co' = opt_co4 env sym rep r fun_co+    arg_co' = opt_co4 env sym False Nominal arg_co+    r'   = chooseRole rep r++opt_co4' env sym _rep r (KindCo co)+  = assert (r == Nominal) $+    let kco' = promoteCoercion co in+    case kco' of+      KindCo co' -> promoteCoercion (opt_co1 env sym co')+      _          -> opt_co4 env sym False Nominal kco'+  -- This might be able to be optimized more to do the promotion+  -- and substitution/optimization at the same time++opt_co4' env sym _ r (SubCo co)+  = assert (r == Representational) $+    opt_co4 env sym True Nominal co++{- Note [Optimise CoVarCo to Refl]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we have (c :: t~t) we can optimise it to Refl. That increases the+chances of floating the Refl upwards; e.g. Maybe c --> Refl (Maybe t)++We do so here in optCoercion, not in mkCoVarCo; see Note [mkCoVarCo]+in GHC.Core.Coercion.+-}++-------------+-- | Optimize a phantom coercion. The input coercion may not necessarily+-- be a phantom, but the output sure will be.+opt_phantom :: LiftingContext -> SwapFlag -> Coercion -> NormalCo+opt_phantom env sym (UnivCo { uco_prov = prov, uco_lty = t1+                            , uco_rty = t2, uco_deps = deps })+  = opt_univ env sym prov deps Phantom t1 t2++opt_phantom env sym co+  = opt_univ env sym PhantomProv [mkKindCo co] Phantom ty1 ty2+  where+    Pair ty1 ty2 = coercionKind co++{- Note [Differing kinds]+   ~~~~~~~~~~~~~~~~~~~~~~+The two types may not have the same kind (although that would be very unusual).+But even if they have the same kind, and the same type constructor, the number+of arguments in a `CoTyConApp` can differ. Consider++  Any :: forall k. k++  Any @Type Int                :: Type+  Any @(Type->Type) Maybe Int  :: Type++Hence the need to compare argument lengths; see #13658++Note [opt_univ needs injectivity]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If opt_univ sees a coercion between `T a1 a2` and `T b1 b2` it will optimize it+by producing a TyConAppCo for T, and pushing the UnivCo into the arguments.  But+this works only if T is injective. Otherwise we can have something like++  type family F x where+    F Int  = Int+    F Bool = Int++where `UnivCo :: F Int ~ F Bool` is reasonable (it is effectively just an+alternative representation for a couple of uses of AxiomInstCos) but we do not+want to produce `F (UnivCo :: Int ~ Bool)` where the inner coercion is clearly+inconsistent.  Hence the opt_univ case for TyConApps checks isInjectiveTyCon.+See #19509.++ -}++opt_univ :: LiftingContext -> SwapFlag -> UnivCoProvenance+         -> [Coercion]+         -> Role -> Type -> Type -> Coercion+opt_univ env sym prov deps role ty1 ty2+  = let ty1'  = substTyUnchecked (lcSubstLeft  env) ty1+        ty2'  = substTyUnchecked (lcSubstRight env) ty2+        deps' = map (opt_co1 env sym) deps+        (ty1'', ty2'') = swapSym sym (ty1', ty2')+    in+    mkUnivCo prov deps' role ty1'' ty2''++{-+opt_univ env PhantomProv cvs _r ty1 ty2+  = mkUnivCo PhantomProv cvs Phantom ty1' ty2'+  where+    ty1' = substTy (lcSubstLeft  env) ty1+    ty2' = substTy (lcSubstRight env) ty2++opt_univ1 env prov cvs' role oty1 oty2+  | Just (tc1, tys1) <- splitTyConApp_maybe oty1+  , Just (tc2, tys2) <- splitTyConApp_maybe oty2+  , tc1 == tc2+  , isInjectiveTyCon tc1 role  -- see Note [opt_univ needs injectivity]+  , equalLength tys1 tys2 -- see Note [Differing kinds]+      -- NB: prov must not be the two interesting ones (ProofIrrel & Phantom);+      -- Phantom is already taken care of, and ProofIrrel doesn't relate tyconapps+  = let roles    = tyConRoleListX role tc1+        arg_cos  = zipWith3 (mkUnivCo prov cvs') roles tys1 tys2+        arg_cos' = zipWith (opt_co4 env False False) roles arg_cos+    in+    mkTyConAppCo role tc1 arg_cos'++  -- can't optimize the AppTy case because we can't build the kind coercions.++  | Just (Bndr tv1 vis1, ty1) <- splitForAllForAllTyBinder_maybe oty1+  , isTyVar tv1+  , Just (Bndr tv2 vis2, ty2) <- splitForAllForAllTyBinder_maybe oty2+  , isTyVar tv2+      -- NB: prov isn't interesting here either+  = let k1   = tyVarKind tv1+        k2   = tyVarKind tv2+        eta  = mkUnivCo prov cvs' Nominal k1 k2+          -- eta gets opt'ed soon, but not yet.+        ty2' = substTyWith [tv2] [TyVarTy tv1 `mkCastTy` eta] ty2++        (env', tv1', eta') = optForAllCoBndr env False tv1 eta+    in+    mkForAllCo tv1' vis1 vis2 eta' (opt_univ1 env' prov cvs' role ty1 ty2')++  | Just (Bndr cv1 vis1, ty1) <- splitForAllForAllTyBinder_maybe oty1+  , isCoVar cv1+  , Just (Bndr cv2 vis2, ty2) <- splitForAllForAllTyBinder_maybe oty2+  , isCoVar cv2+      -- NB: prov isn't interesting here either+  = let k1    = varType cv1+        k2    = varType cv2+        r'    = coVarRole cv1+        eta   = mkUnivCo prov cvs' Nominal k1 k2+        eta_d = downgradeRole r' Nominal eta+          -- eta gets opt'ed soon, but not yet.+        n_co  = (mkSymCo $ mkSelCo (SelTyCon 2 r') eta_d) `mkTransCo`+                (mkCoVarCo cv1) `mkTransCo`+                (mkSelCo (SelTyCon 3 r') eta_d)+        ty2'  = substTyWithCoVars [cv2] [n_co] ty2++        (env', cv1', eta') = optForAllCoBndr env False cv1 eta+    in+    mkForAllCo cv1' vis1 vis2 eta' (opt_univ1 env' prov cvs' role ty1 ty2')++  | otherwise+  = let ty1 = substTyUnchecked (lcSubstLeft  env) oty1+        ty2 = substTyUnchecked (lcSubstRight env) oty2+    in+    mkUnivCo prov cvs' role ty1 ty2+-}++-------------+opt_transList :: HasDebugCallStack => InScopeSet -> [NormalCo] -> [NormalCo] -> [NormalCo]+opt_transList is = zipWithEqual (opt_trans is)+  -- The input lists must have identical length.++opt_trans :: HasDebugCallStack => InScopeSet -> NormalCo -> NormalCo -> NormalCo++-- opt_trans just allows us to add some debug tracing+-- Usually it just goes to opt_trans'+opt_trans is co1 co2+  = -- (if coercionRKind co1 `eqType` coercionLKind co2+    --  then (\x -> x) else+    --  pprTrace "opt_trans" (vcat [ text "co1" <+> ppr co1+    --                             , text "co2" <+> ppr co2+    --                             , text "co1 kind" <+> ppr (coercionKind co1)+    --                             , text "co2 kind" <+> ppr (coercionKind co2)+    --                             , callStackDoc ])) $+    opt_trans' is co1 co2++{-+opt_trans is co1 co2+  = assertPpr (r1==r2) (vcat [ ppr r1 <+> ppr co1, ppr r2 <+> ppr co2]) $+    assertPpr (rres == r1) (vcat [ ppr r1 <+> ppr co1, ppr r2 <+> ppr co2, text "res" <+> ppr rres <+> ppr res ]) $+    res+  where+    res = opt_trans' is co1 co2+    rres = coercionRole res+    r1 = coercionRole co1+    r2 = coercionRole co1+-}++opt_trans' :: HasDebugCallStack => InScopeSet -> NormalCo -> NormalCo -> NormalCo+opt_trans' is co1 co2+  | isReflCo co1 = co2+    -- optimize when co1 is a Refl Co+  | otherwise    = opt_trans1 is co1 co2++opt_trans1 :: HasDebugCallStack => InScopeSet -> NormalNonIdCo -> NormalCo -> NormalCo+-- First arg is not the identity+opt_trans1 is co1 co2+  | isReflCo co2 = co1+    -- optimize when co2 is a Refl Co+  | otherwise    = opt_trans2 is co1 co2++opt_trans2 :: HasDebugCallStack => InScopeSet -> NormalNonIdCo -> NormalNonIdCo -> NormalCo+-- Neither arg is the identity+opt_trans2 is (TransCo co1a co1b) co2+    -- Don't know whether the sub-coercions are the identity+  = opt_trans is co1a (opt_trans is co1b co2)++opt_trans2 is co1 co2+  | Just co <- opt_trans_rule is co1 co2+  = co++opt_trans2 is co1 (TransCo co2a co2b)+  | Just co1_2a <- opt_trans_rule is co1 co2a+  = if isReflCo co1_2a+    then co2b+    else opt_trans1 is co1_2a co2b++opt_trans2 _ co1 co2+  = mk_trans_co co1 co2+++------+-- Optimize coercions with a top-level use of transitivity.+opt_trans_rule :: HasDebugCallStack => InScopeSet -> NormalNonIdCo -> NormalNonIdCo -> Maybe NormalCo++opt_trans_rule _ in_co1 in_co2+  | assertPpr (coercionRKind in_co1 `eqType` coercionLKind in_co2)+              (vcat [ text "in_co1" <+> ppr in_co1+                   , text "in_co2" <+> ppr in_co2+                   , text "in_co1 kind" <+> ppr (coercionKind in_co1)+                   , text "in_co2 kind" <+> ppr (coercionKind in_co2)+                   , callStackDoc ]) $+    False+  = panic "opt_trans_rule"  -- This entire equation is purely assertion checking++opt_trans_rule is in_co1@(GRefl r1 t1 (MCo co1)) in_co2@(GRefl r2 _t2 (MCo co2))+  = assert (r1 == r2) $+    fireTransRule "GRefl" in_co1 in_co2 $+    mk_grefl_right_co r1 t1 (opt_trans is co1 co2)++-- Push transitivity through matching destructors+opt_trans_rule is in_co1@(SelCo d1 co1) in_co2@(SelCo d2 co2)+  | d1 == d2+  , coercionRole co1 == coercionRole co2+  , co1 `compatible_co` co2+  = fireTransRule "PushNth" in_co1 in_co2 $+    mkSelCo d1 (opt_trans is co1 co2)++opt_trans_rule is in_co1@(LRCo d1 co1) in_co2@(LRCo d2 co2)+  | d1 == d2+  , co1 `compatible_co` co2+  = fireTransRule "PushLR" in_co1 in_co2 $+    mkLRCo d1 (opt_trans is co1 co2)++-- Push transitivity inside instantiation+opt_trans_rule is in_co1@(InstCo co1 ty1) in_co2@(InstCo co2 ty2)+  | ty1 `eqCoercion` ty2+  , co1 `compatible_co` co2+  = fireTransRule "TrPushInst" in_co1 in_co2 $+    mkInstCo (opt_trans is co1 co2) ty1++opt_trans_rule _+    in_co1@(UnivCo { uco_prov = p1, uco_role = r1, uco_lty = tyl1, uco_deps = deps1 })+    in_co2@(UnivCo { uco_prov = p2, uco_role = r2, uco_rty = tyr2, uco_deps = deps2 })+  | p1 == p2    -- If the provenances are different, opt'ing will be very confusing+  = assert (r1 == r2) $+    fireTransRule "UnivCo" in_co1 in_co2 $+    mkUnivCo p1 (deps1 ++ deps2) r1 tyl1 tyr2++-- Push transitivity down through matching top-level constructors.+opt_trans_rule is in_co1@(TyConAppCo r1 tc1 cos1) in_co2@(TyConAppCo r2 tc2 cos2)+  | tc1 == tc2+  = assert (r1 == r2) $+    fireTransRule "PushTyConApp" in_co1 in_co2 $+    mkTyConAppCo r1 tc1 (opt_transList is cos1 cos2)++opt_trans_rule is in_co1@(FunCo r1 afl1 afr1 w1 co1a co1b)+                  in_co2@(FunCo r2 afl2 afr2 w2 co2a co2b)+  = assert (r1 == r2)     $     -- Just like the TyConAppCo/TyConAppCo case+    assert (afr1 == afl2) $+    fireTransRule "PushFun" in_co1 in_co2 $+    mkFunCo2 r1 afl1 afr2 (opt_trans is w1 w2)+                          (opt_trans is co1a co2a)+                          (opt_trans is co1b co2b)++opt_trans_rule is in_co1@(AppCo co1a co1b) in_co2@(AppCo co2a co2b)+  -- Must call opt_trans_rule_app; see Note [EtaAppCo]+  = opt_trans_rule_app is in_co1 in_co2 co1a [co1b] co2a [co2b]++-- Eta rules+opt_trans_rule is co1@(TyConAppCo r tc cos1) co2+  | Just cos2 <- etaTyConAppCo_maybe tc co2+  = fireTransRule "EtaCompL" co1 co2 $+    mkTyConAppCo r tc (opt_transList is cos1 cos2)++opt_trans_rule is co1 co2@(TyConAppCo r tc cos2)+  | Just cos1 <- etaTyConAppCo_maybe tc co1+  = fireTransRule "EtaCompR" co1 co2 $+    mkTyConAppCo r tc (opt_transList is cos1 cos2)++opt_trans_rule is co1@(AppCo co1a co1b) co2+  | Just (co2a,co2b) <- etaAppCo_maybe co2+  = opt_trans_rule_app is co1 co2 co1a [co1b] co2a [co2b]++opt_trans_rule is co1 co2@(AppCo co2a co2b)+  | Just (co1a,co1b) <- etaAppCo_maybe co1+  = opt_trans_rule_app is co1 co2 co1a [co1b] co2a [co2b]++-- Push transitivity inside forall+-- forall over types.+opt_trans_rule is co1 co2+  | Just (tv1, visL1, _visR1, eta1, r1) <- splitForAllCo_ty_maybe co1+  , Just (tv2, _visL2, visR2, eta2, r2) <- etaForAllCo_ty_maybe co2+  = push_trans tv1 eta1 r1 tv2 eta2 r2 visL1 visR2++  | Just (tv2, _visL2, visR2, eta2, r2) <- splitForAllCo_ty_maybe co2+  , Just (tv1, visL1, _visR1, eta1, r1) <- etaForAllCo_ty_maybe co1+  = push_trans tv1 eta1 r1 tv2 eta2 r2 visL1 visR2++  where+  push_trans tv1 eta1 r1 tv2 eta2 r2 visL visR+    -- Given:+    --   co1 = /\ tv1 : eta1 <visL, visM>. r1+    --   co2 = /\ tv2 : eta2 <visM, visR>. r2+    -- Wanted:+    --   /\tv1 : (eta1;eta2) <visL, visR>.  (r1; r2[tv2 |-> tv1 |> eta1])+    = fireTransRule "EtaAllTy_ty" co1 co2 $+      mkForAllCo tv1 visL visR (opt_trans is eta1 eta2) (opt_trans is' r1 r2')+    where+      is' = is `extendInScopeSet` tv1+      r2' = substCoWithUnchecked [tv2] [mkCastTy (TyVarTy tv1) eta1] r2++-- Push transitivity inside forall+-- forall over coercions.+opt_trans_rule is co1 co2+  | Just (cv1, visL1, _visR1, eta1, r1) <- splitForAllCo_co_maybe co1+  , Just (cv2, _visL2, visR2, eta2, r2) <- etaForAllCo_co_maybe co2+  = push_trans cv1 eta1 r1 cv2 eta2 r2 visL1 visR2++  | Just (cv2, _visL2, visR2, eta2, r2) <- splitForAllCo_co_maybe co2+  , Just (cv1, visL1, _visR1, eta1, r1) <- etaForAllCo_co_maybe co1+  = push_trans cv1 eta1 r1 cv2 eta2 r2 visL1 visR2++  where+  push_trans cv1 eta1 r1 cv2 eta2 r2 visL visR+    -- Given:+    --   co1 = /\ (cv1 : eta1) <visL, visM>. r1+    --   co2 = /\ (cv2 : eta2) <visM, visR>. r2+    -- Wanted:+    --   n1 = nth 2 eta1+    --   n2 = nth 3 eta1+    --   nco = /\ cv1 : (eta1;eta2). (r1; r2[cv2 |-> (sym n1);cv1;n2])+    = fireTransRule "EtaAllTy_co" co1 co2 $+      mkForAllCo cv1 visL visR (opt_trans is eta1 eta2) (opt_trans is' r1 r2')+    where+      is'  = is `extendInScopeSet` cv1+      role = coVarRole cv1+      eta1' = downgradeRole role Nominal eta1+      n1   = mkSelCo (SelTyCon 2 role) eta1'+      n2   = mkSelCo (SelTyCon 3 role) eta1'+      r2'  = substCo (zipCvSubst [cv2] [(mkSymCo n1) `mk_trans_co`+                                        (mkCoVarCo cv1) `mk_trans_co` n2])+                    r2++-- Push transitivity inside axioms+opt_trans_rule is co1 co2++  -- TrPushAxSym/TrPushSymAx+  -- Put this first!  Otherwise (#23619) we get+  --    newtype N a = MkN a+  --    axN :: forall a. N a ~ a+  -- Now consider (axN ty ; sym (axN ty))+  -- If we put TrPushSymAxR first, we'll get+  --    (axN ty ; sym (axN ty)) :: N ty ~ N ty -- Obviously Refl+  --    --> axN (sym (axN ty))  :: N ty ~ N ty -- Very stupid+  | Just (sym1, axr1, cos1) <- isAxiomCo_maybe co1+  , Just (sym2, axr2, cos2) <- isAxiomCo_maybe co2+  , axr1 == axr2+  , sym1 == flipSwap sym2+  , Just (tc, role, branch) <- coAxiomRuleBranch_maybe axr1+  , let qtvs   = coAxBranchTyVars branch ++ coAxBranchCoVars branch+        lhs    = mkTyConApp tc (coAxBranchLHS branch)+        rhs    = coAxBranchRHS branch+        pivot_tvs = exactTyCoVarsOfType (pickSwap sym2 lhs rhs)+  , all (`elemVarSet` pivot_tvs) qtvs+  = fireTransRule "TrPushAxSym" co1 co2 $+    if isSwapped sym2+       -- TrPushAxSym+    then liftCoSubstWith role qtvs (opt_transList is cos1 (map mkSymCo cos2)) lhs+       -- TrPushSymAx+    else liftCoSubstWith role qtvs (opt_transList is (map mkSymCo cos1) cos2) rhs++  -- See Note [Push transitivity inside axioms] and+  -- Note [Push transitivity inside newtype axioms only]+  -- TrPushSymAxR+  | Just (sym, axr, cos1) <- isAxiomCo_maybe co1+  , isSwapped sym+  , Just cos2 <- matchNewtypeBranch sym axr co2+  , let newAxInst = AxiomCo axr (opt_transList is (map mkSymCo cos2) cos1)+  = fireTransRule "TrPushSymAxR" co1 co2 $ SymCo newAxInst++  -- TrPushAxR+  | Just (sym, axr, cos1) <- isAxiomCo_maybe co1+  , notSwapped sym+  , Just cos2 <- matchNewtypeBranch sym axr co2+  , let newAxInst = AxiomCo axr (opt_transList is cos1 cos2)+  = fireTransRule "TrPushAxR" co1 co2 newAxInst++  -- TrPushSymAxL+  | Just (sym, axr, cos2) <- isAxiomCo_maybe co2+  , isSwapped sym+  , Just cos1 <- matchNewtypeBranch (flipSwap sym) axr co1+  , let newAxInst = AxiomCo axr (opt_transList is cos2 (map mkSymCo cos1))+  = fireTransRule "TrPushSymAxL" co1 co2 $ SymCo newAxInst++  -- TrPushAxL+  | Just (sym, axr, cos2) <- isAxiomCo_maybe co2+  , notSwapped sym+  , Just cos1 <- matchNewtypeBranch (flipSwap sym) axr co1+  , let newAxInst = AxiomCo axr (opt_transList is cos1 cos2)+  = fireTransRule "TrPushAxL" co1 co2 newAxInst+++opt_trans_rule _ co1 co2        -- Identity rule+  | let ty1 = coercionLKind co1+        r   = coercionRole co1+        ty2 = coercionRKind co2+  , ty1 `eqType` ty2+  = fireTransRule "RedTypeDirRefl" co1 co2 $+    mkReflCo r ty2++opt_trans_rule _ _ _ = Nothing++-- See Note [EtaAppCo]+opt_trans_rule_app :: InScopeSet+                   -> Coercion   -- original left-hand coercion (printing only)+                   -> Coercion   -- original right-hand coercion (printing only)+                   -> Coercion   -- left-hand coercion "function"+                   -> [Coercion] -- left-hand coercion "args"+                   -> Coercion   -- right-hand coercion "function"+                   -> [Coercion] -- right-hand coercion "args"+                   -> Maybe Coercion+opt_trans_rule_app is orig_co1 orig_co2 co1a co1bs co2a co2bs+  | AppCo co1aa co1ab <- co1a+  , Just (co2aa, co2ab) <- etaAppCo_maybe co2a+  = opt_trans_rule_app is orig_co1 orig_co2 co1aa (co1ab:co1bs) co2aa (co2ab:co2bs)++  | AppCo co2aa co2ab <- co2a+  , Just (co1aa, co1ab) <- etaAppCo_maybe co1a+  = opt_trans_rule_app is orig_co1 orig_co2 co1aa (co1ab:co1bs) co2aa (co2ab:co2bs)++  | otherwise+  = assert (co1bs `equalLength` co2bs) $+    fireTransRule ("EtaApps:" ++ show (length co1bs)) orig_co1 orig_co2 $+    let rt1a = coercionRKind co1a++        lt2a = coercionLKind co2a+        rt2a = coercionRole  co2a++        rt1bs = map coercionRKind co1bs+        lt2bs = map coercionLKind co2bs+        rt2bs = map coercionRole co2bs++        kcoa = mkKindCo $ buildCoercion lt2a rt1a+        kcobs = map mkKindCo $ zipWith buildCoercion lt2bs rt1bs++        co2a'   = mkCoherenceLeftCo rt2a lt2a kcoa co2a+        co2bs'  = zipWith3 mkGReflLeftCo rt2bs lt2bs kcobs+        co2bs'' = zipWith mk_trans_co co2bs' co2bs+    in+    mkAppCos (opt_trans is co1a co2a')+             (zipWith (opt_trans is) co1bs co2bs'')++fireTransRule :: String -> Coercion -> Coercion -> Coercion -> Maybe Coercion+fireTransRule _rule _co1 _co2 res+  = Just res++{-+Note [Push transitivity inside axioms]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+opt_trans_rule tries to push transitivity inside axioms to deal with cases like+the following:++    newtype N a = MkN a++    axN :: N a ~R# a++    covar :: a ~R# b+    co1 = axN <a> :: N a ~R# a+    co2 = axN <b> :: N b ~R# b++    co :: a ~R# b+    co = sym co1 ; N covar ; co2++When we are optimising co, we want to notice that the two axiom instantiations+cancel out. This is implemented by rules such as TrPushSymAxR, which transforms+    sym (axN <a>) ; N covar+into+    sym (axN covar)+so that TrPushSymAx can subsequently transform+    sym (axN covar) ; axN <b>+into+    covar+which is much more compact. In some perf test cases this kind of pattern can be+generated repeatedly during simplification, so it is very important we squash it+to stop coercions growing exponentially.  For more details see the paper:++    Evidence normalisation in System FC+    Dimitrios Vytiniotis and Simon Peyton Jones+    RTA'13, 2013+    https://www.microsoft.com/en-us/research/publication/evidence-normalization-system-fc-2/+++Note [Push transitivity inside newtype axioms only]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The optimization described in Note [Push transitivity inside axioms] is possible+for both newtype and type family axioms.  However, for type family axioms it is+relatively common to have transitive sequences of axioms instantiations, for+example:++    data Nat = Zero | Suc Nat++    type family Index (n :: Nat) (xs :: [Type]) :: Type where+      Index Zero    (x : xs) = x+      Index (Suc n) (x : xs) = Index n xs++    axIndex :: { forall x::Type. forall xs::[Type]. Index Zero (x : xs) ~ x+               ; forall n::Nat. forall x::Type. forall xs::[Type]. Index (Suc n) (x : xs) ~ Index n xs }++    co :: Index (Suc (Suc Zero)) [a, b, c] ~ c+    co = axIndex[1] <Suc Zero> <a> <[b, c]>+       ; axIndex[1] <Zero> <b> <[c]>+       ; axIndex[0] <c> <[]>++Not only are there no cancellation opportunities here, but calling matchAxiom+repeatedly down the transitive chain is very expensive.  Hence we do not attempt+to push transitivity inside type family axioms.  See #8095, !9210 and related tickets.++This is implemented by opt_trans_rule checking that the axiom is for a newtype+constructor (i.e. not a type family).  Adding these guards substantially+improved performance (reduced bytes allocated by more than 10%) for the tests+CoOpt_Singletons, LargeRecord, T12227, T12545, T13386, T15703, T5030, T8095.++A side benefit is that we do not risk accidentally creating an ill-typed+coercion; see Note [Why call checkAxInstCo during optimisation].++There may exist programs that previously relied on pushing transitivity inside+type family axioms to avoid creating huge coercions, which will regress in+compile time performance as a result of this change.  We do not currently know+of any examples, but if any come to light we may need to reconsider this+behaviour.+++Note [Why call checkAxInstCo during optimisation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+NB: The following is no longer relevant, because we no longer push transitivity+into type family axioms (Note [Push transitivity inside newtype axioms only]).+It is retained for reference in case we change this behaviour in the future.++It is possible that otherwise-good-looking optimisations meet with disaster+in the presence of axioms with multiple equations. Consider++type family Equal (a :: *) (b :: *) :: Bool where+  Equal a a = True+  Equal a b = False+type family Id (a :: *) :: * where+  Id a = a++axEq :: { [a::*].       Equal a a ~ True+        ; [a::*, b::*]. Equal a b ~ False }+axId :: [a::*]. Id a ~ a++co1 = Equal (axId[0] Int) (axId[0] Bool)+  :: Equal (Id Int) (Id Bool) ~  Equal Int Bool+co2 = axEq[1] <Int> <Bool>+  :: Equal Int Bool ~ False++We wish to optimise (co1 ; co2). We end up in rule TrPushAxL, noting that+co2 is an axiom and that matchAxiom succeeds when looking at co1. But, what+happens when we push the coercions inside? We get++co3 = axEq[1] (axId[0] Int) (axId[0] Bool)+  :: Equal (Id Int) (Id Bool) ~ False++which is bogus! This is because the type system isn't smart enough to know+that (Id Int) and (Id Bool) are SurelyApart, as they're headed by type+families. At the time of writing, I (Richard Eisenberg) couldn't think of+a way of detecting this any more efficient than just building the optimised+coercion and checking.++Note [EtaAppCo]+~~~~~~~~~~~~~~~+Suppose we're trying to optimize (co1a co1b ; co2a co2b). Ideally, we'd+like to rewrite this to (co1a ; co2a) (co1b ; co2b). The problem is that+the resultant coercions might not be well kinded. Here is an example (things+labeled with x don't matter in this example):++  k1 :: Type+  k2 :: Type++  a :: k1 -> Type+  b :: k1++  h :: k1 ~ k2++  co1a :: x1 ~ (a |> (h -> <Type>)+  co1b :: x2 ~ (b |> h)++  co2a :: a ~ x3+  co2b :: b ~ x4++First, convince yourself of the following:++  co1a co1b :: x1 x2 ~ (a |> (h -> <Type>)) (b |> h)+  co2a co2b :: a b   ~ x3 x4++  (a |> (h -> <Type>)) (b |> h) `eqType` a b++That last fact is due to Note [Non-trivial definitional equality] in GHC.Core.TyCo.Rep,+where we ignore coercions in types as long as two types' kinds are the same.+In our case, we meet this last condition, because++  (a |> (h -> <Type>)) (b |> h) :: Type+    and+  a b :: Type++So the input coercion (co1a co1b ; co2a co2b) is well-formed. But the+suggested output coercions (co1a ; co2a) and (co1b ; co2b) are not -- the+kinds don't match up.++The solution here is to twiddle the kinds in the output coercions. First, we+need to find coercions++  ak :: kind(a |> (h -> <Type>)) ~ kind(a)+  bk :: kind(b |> h)             ~ kind(b)++This can be done with mkKindCo and buildCoercion. The latter assumes two+types are identical modulo casts and builds a coercion between them.++Then, we build (co1a ; co2a |> sym ak) and (co1b ; co2b |> sym bk) as the+output coercions. These are well-kinded.++Also, note that all of this is done after accumulated any nested AppCo+parameters. This step is to avoid quadratic behavior in calling coercionKind.++The problem described here was first found in dependent/should_compile/dynamic-paper.++-}++-----------+swapSym :: SwapFlag -> (a,a) -> (a,a)+swapSym IsSwapped  (x,y) = (y,x)+swapSym NotSwapped (x,y) = (x,y)++wrapSym :: SwapFlag -> Coercion -> Coercion+wrapSym IsSwapped  co = mkSymCo co+wrapSym NotSwapped co = co++-- | Conditionally set a role to be representational+wrapRole :: ReprFlag+         -> Role         -- ^ current role+         -> Coercion -> Coercion+wrapRole False _       = id+wrapRole True  current = downgradeRole Representational current++-- | If we require a representational role, return that. Otherwise,+-- return the "default" role provided.+chooseRole :: ReprFlag+           -> Role    -- ^ "default" role+           -> Role+chooseRole True _ = Representational+chooseRole _    r = r++-----------+isAxiomCo_maybe :: Coercion -> Maybe (SwapFlag, CoAxiomRule, [Coercion])+-- We don't expect to see nested SymCo; and that lets us write a simple,+-- non-recursive function. (If we see a nested SymCo we'll just fail,+-- which is ok.)+isAxiomCo_maybe (SymCo (AxiomCo ax cos)) = Just (IsSwapped,  ax, cos)+isAxiomCo_maybe (AxiomCo ax cos)         = Just (NotSwapped, ax, cos)+isAxiomCo_maybe _                        = Nothing++matchNewtypeBranch :: SwapFlag -- IsSwapped = match LHS, NotSwapped = match RHS+                   -> CoAxiomRule+                   -> Coercion -> Maybe [Coercion]+matchNewtypeBranch sym axr co+  | Just (tc,branch) <- isNewtypeAxiomRule_maybe axr+  , CoAxBranch { cab_tvs = qtvs+               , cab_cvs = []   -- can't infer these, so fail if there are any+               , cab_roles = roles+               , cab_lhs = lhs+               , cab_rhs = rhs } <- branch+  , Just subst <- liftCoMatch (mkVarSet qtvs)+                              (pickSwap sym rhs (mkTyConApp tc lhs))+                              co+  , all (`isMappedByLC` subst) qtvs+  = zipWithM (liftCoSubstTyVar subst) roles qtvs++  | otherwise+  = Nothing++-------------+compatible_co :: Coercion -> Coercion -> Bool+-- Check whether (co1 . co2) will be well-kinded+compatible_co co1 co2+  = x1 `eqType` x2+  where+    x1 = coercionRKind co1+    x2 = coercionLKind co2++-------------+{-+etaForAllCo+~~~~~~~~~~~~~~~~~+(1) etaForAllCo_ty_maybe+Suppose we have++  g : all a1:k1.t1  ~  all a2:k2.t2++but g is *not* a ForAllCo. We want to eta-expand it. So, we do this:++  g' = all a1:(ForAllKindCo g).(InstCo g (a1 ~ a1 |> ForAllKindCo g))++Call the kind coercion h1 and the body coercion h2. We can see that++  h2 : t1 ~ t2[a2 |-> (a1 |> h1)]++According to the typing rule for ForAllCo, we get that++  g' : all a1:k1.t1  ~  all a1:k2.(t2[a2 |-> (a1 |> h1)][a1 |-> a1 |> sym h1])++or++  g' : all a1:k1.t1  ~  all a1:k2.(t2[a2 |-> a1])++as desired.++(2) etaForAllCo_co_maybe+Suppose we have++  g : all c1:(s1~s2). t1 ~ all c2:(s3~s4). t2++Similarly, we do this++  g' = all c1:h1. h2+     : all c1:(s1~s2). t1 ~ all c1:(s3~s4). t2[c2 |-> (sym eta1;c1;eta2)]+                                              [c1 |-> eta1;c1;sym eta2]++Here,++  h1   = mkSelCo Nominal 0 g       :: (s1~s2)~(s3~s4)+  eta1 = mkSelCo (SelTyCon 2 r) h1 :: (s1 ~ s3)+  eta2 = mkSelCo (SelTyCon 3 r) h1 :: (s2 ~ s4)+  h2   = mkInstCo g (cv1 ~ (sym eta1;c1;eta2))+-}+etaForAllCo_ty_maybe :: Coercion -> Maybe (TyVar, ForAllTyFlag, ForAllTyFlag, Coercion, Coercion)+-- Try to make the coercion be of form (forall tv:kind_co. co)+etaForAllCo_ty_maybe co+  | Just (tv, visL, visR, kind_co, r) <- splitForAllCo_ty_maybe co+  = Just (tv, visL, visR, kind_co, r)++  | (Pair ty1 ty2, role)  <- coercionKindRole co+  , Just (Bndr tv1 vis1, _) <- splitForAllForAllTyBinder_maybe ty1+  , isTyVar tv1+  , Just (Bndr tv2 vis2, _) <- splitForAllForAllTyBinder_maybe ty2+  , isTyVar tv2+  -- can't eta-expand at nominal role unless visibilities match+  , (role /= Nominal) || (vis1 `eqForAllVis` vis2)+  , let kind_co = mkSelCo SelForAll co+  = Just ( tv1, vis1, vis2, kind_co+         , mkInstCo co (mk_grefl_right_co Nominal (TyVarTy tv1) kind_co))++  | otherwise+  = Nothing++etaForAllCo_co_maybe :: Coercion -> Maybe (CoVar, ForAllTyFlag, ForAllTyFlag, Coercion, Coercion)+-- Try to make the coercion be of form (forall cv:kind_co. co)+etaForAllCo_co_maybe co+  | Just (cv, visL, visR, kind_co, r) <- splitForAllCo_co_maybe co+  = Just (cv, visL, visR, kind_co, r)++  | (Pair ty1 ty2, role)  <- coercionKindRole co+  , Just (Bndr cv1 vis1, _) <- splitForAllForAllTyBinder_maybe ty1+  , isCoVar cv1+  , Just (Bndr cv2 vis2, _) <- splitForAllForAllTyBinder_maybe ty2+  , isCoVar cv2+  -- can't eta-expand at nominal role unless visibilities match+  , (role /= Nominal)+  = let kind_co  = mkSelCo SelForAll co+        r        = coVarRole cv1+        l_co     = mkCoVarCo cv1+        kind_co' = downgradeRole r Nominal kind_co+        r_co     = mkSymCo (mkSelCo (SelTyCon 2 r) kind_co')+                   `mk_trans_co` l_co+                   `mk_trans_co` mkSelCo (SelTyCon 3 r) kind_co'+    in Just ( cv1, vis1, vis2, kind_co+            , mkInstCo co (mkProofIrrelCo Nominal kind_co l_co r_co))++  | otherwise+  = Nothing++etaAppCo_maybe :: Coercion -> Maybe (Coercion,Coercion)+-- If possible, split a coercion+--   g :: t1a t1b ~ t2a t2b+-- into a pair of coercions (left g, right g)+etaAppCo_maybe co+  | Just (co1,co2) <- splitAppCo_maybe co+  = Just (co1,co2)+  | (Pair ty1 ty2, Nominal) <- coercionKindRole co+  , Just (_,t1) <- splitAppTy_maybe ty1+  , Just (_,t2) <- splitAppTy_maybe ty2+  , let isco1 = isCoercionTy t1+  , let isco2 = isCoercionTy t2+  , isco1 == isco2+  = Just (LRCo CLeft co, LRCo CRight co)+  | otherwise+  = Nothing++etaTyConAppCo_maybe :: TyCon -> Coercion -> Maybe [Coercion]+-- If possible, split a coercion+--       g :: T s1 .. sn ~ T t1 .. tn+-- into [ SelCo (SelTyCon 0)     g :: s1~t1+--      , ...+--      , SelCo (SelTyCon (n-1)) g :: sn~tn ]+etaTyConAppCo_maybe tc (TyConAppCo _ tc2 cos2)+  = assert (tc == tc2) $ Just cos2++etaTyConAppCo_maybe tc co+  | not (tyConMustBeSaturated tc)+  , (Pair ty1 ty2, r) <- coercionKindRole co+  , Just (tc1, tys1)  <- splitTyConApp_maybe ty1+  , Just (tc2, tys2)  <- splitTyConApp_maybe ty2+  , tc1 == tc2+  , isInjectiveTyCon tc r  -- See Note [SelCo and newtypes] in GHC.Core.TyCo.Rep+  , let n = length tys1+  , tys2 `lengthIs` n      -- This can fail in an erroneous program+                           -- E.g. T a ~# T a b+                           -- #14607+  = assert (tc == tc1) $+    Just (decomposeCo n co (tyConRolesX r tc1))+    -- NB: n might be <> tyConArity tc+    -- e.g.   data family T a :: * -> *+    --        g :: T a b ~ T c d++  | otherwise+  = Nothing++{-+Note [Eta for AppCo]+~~~~~~~~~~~~~~~~~~~~+Suppose we have+   g :: s1 t1 ~ s2 t2++Then we can't necessarily make+   left  g :: s1 ~ s2+   right g :: t1 ~ t2+because it's possible that+   s1 :: * -> *         t1 :: *+   s2 :: (*->*) -> *    t2 :: * -> *+and in that case (left g) does not have the same+kind on either side.++It's enough to check that+  kind t1 = kind t2+because if g is well-kinded then+  kind (s1 t2) = kind (s2 t2)+and these two imply+  kind s1 = kind s2++-}++{- Note [Optimising ForAllCo]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If sym=NotSwapped, optimising ForAllCo is relatively easy:+   opt env (ForAllCo tcv kco bodyco)+     = ForAllCo tcv' (opt env kco) (opt env' bodyco)+     where+       (env', tcv') = substBndr env tcv++Just apply the substitution to the kind of the binder, deal with+shadowing etc, and recurse.  Remember in (ForAllCo tcv kco bodyco)+    varKind tcv = coercionLKind kco++But if sym=Swapped, things are trickier.  Here is an identity that helps:+   Sym (ForAllCo (tv:k1) (kco:k1~k2) bodyco)+   = ForAllCo (tv:k2) (Sym kco : k2~k1)+              (Sym (bodyco[tv:->tv:k2 |> Sym kco]))++* We re-type tv:k1 to become tv:k2.+* We push Sym into kco+* We push Sym into bodyco+* BUT we must /also/ remember to replace all occurrences of+      of tv:k1 in bodyco by (tv:k2 |> Sym kco)+  This mirrors what happens in the typing rule for ForAllCo+  See Note [ForAllCo] in GHC.Core.TyCo.Rep++-}+optForAllCoBndr :: LiftingContext -> SwapFlag+                -> TyCoVar -> Coercion+                -> (LiftingContext, TyCoVar, Coercion)+-- See Note [Optimising ForAllCo]+optForAllCoBndr env sym tcv kco+  = (env', tcv', kco')+  where+    kco' = opt_co4 env sym False Nominal kco  -- Push sym into kco+    (env', tcv') = updateLCSubst env upd_subst++    upd_subst :: Subst -> (Subst, TyCoVar)+    upd_subst subst+      | isTyVar tcv = upd_subst_tv subst+      | otherwise   = upd_subst_cv subst++    upd_subst_tv subst+      | notSwapped sym || isReflCo kco' = (subst1, tv1)+      | otherwise                       = (subst2, tv2)+      where+        -- subst1,tv1: apply the substitution to the binder and its kind+        -- NB: varKind tv = coercionLKind kco+        (subst1, tv1) = substTyVarBndr subst tcv+        -- In the Swapped case, we re-kind the type variable, AND+        -- override the substitution for the original variable to the+        -- re-kinded one, suitably casted+        tv2    = tv1 `setTyVarKind` coercionLKind kco'+        subst2 = (extendTvSubst subst1 tcv (mkTyVarTy tv2 `CastTy` kco'))+                 `extendSubstInScope` tv2++    upd_subst_cv subst   -- ToDo: probably not right yet+      | notSwapped sym || isReflCo kco' = (subst1, cv1)+      | otherwise                       = (subst2, cv2)+      where+        (subst1, cv1) = substCoVarBndr subst tcv+        cv2    = cv1 `setTyVarKind` coercionLKind kco'+        subst2 = subst1 `extendSubstInScope` cv2+++{- **********************************************************************+%*                                                                      *+       Assertion-checking versions of functions in Coercion.hs+%*                                                                      *+%********************************************************************* -}++-- We can't check the assertions in the "main" functions of these+-- functions, because the assertions don't hold during zonking.+-- But they are fantastically helpful in finding bugs in the coercion+-- optimiser itself, so I have copied them here with assertions.++mk_trans_co :: HasDebugCallStack => Coercion -> Coercion -> Coercion+-- Do assertion checking in mk_trans_co+mk_trans_co co1 co2+  = assertPpr (coercionRKind co1 `eqType` coercionLKind co2)+              (vcat [ text "co1" <+> ppr co1+                    , text "co2" <+> ppr co2+                    , text "co1 kind" <+> ppr (coercionKind co1)+                    , text "co2 kind" <+> ppr (coercionKind co2)+                    , callStackDoc ]) $+    mkTransCo co1 co2++mk_coherence_right_co :: HasDebugCallStack => Role -> Type -> CoercionN -> Coercion -> Coercion+mk_coherence_right_co r ty co co2+  = assertGRefl ty co $+    mkCoherenceRightCo r ty co co2++assertGRefl :: HasDebugCallStack => Type -> Coercion -> r -> r+assertGRefl ty co res+  = assertPpr (typeKind ty `eqType` coercionLKind co)+              (vcat [ pp_ty "ty" ty+                    , pp_co "co" co+                    , callStackDoc ]) $+    res++mk_grefl_right_co :: Role -> Type -> CoercionN -> Coercion+mk_grefl_right_co r ty co+  = assertGRefl ty co $+    mkGReflRightCo r ty co++pp_co :: String -> Coercion -> SDoc+pp_co s co = text s <+> hang (ppr co) 2 (dcolon <+> ppr (coercionKind co))++pp_ty :: String -> Type -> SDoc+pp_ty s ty = text s <+> hang (ppr ty) 2 (dcolon <+> ppr (typeKind ty))+
GHC/Core/ConLike.hs view
@@ -9,9 +9,12 @@  module GHC.Core.ConLike (           ConLike(..)+        , conLikeConLikeName         , isVanillaConLike         , conLikeArity+        , conLikeVisArity         , conLikeFieldLabels+        , conLikeConInfo         , conLikeInstOrigArgTys         , conLikeUserTyVarBinders         , conLikeExTyCoVars@@ -21,7 +24,6 @@         , conLikeFullSig         , conLikeResTy         , conLikeFieldType-        , conLikesWithFields         , conLikeIsInfix         , conLikeHasBuilder     ) where@@ -29,16 +31,20 @@ import GHC.Prelude  import GHC.Core.DataCon+import GHC.Core.Multiplicity import GHC.Core.PatSyn-import GHC.Utils.Outputable+import GHC.Core.TyCo.Rep (Type, ThetaType)+import GHC.Core.TyCon (tyConDataCons)+import GHC.Core.Type(mkTyConApp) import GHC.Types.Unique-import GHC.Utils.Misc import GHC.Types.Name+import GHC.Types.Name.Reader import GHC.Types.Basic-import GHC.Core.TyCo.Rep (Type, ThetaType)++import GHC.Types.GREInfo import GHC.Types.Var-import GHC.Core.Type(mkTyConApp)-import GHC.Core.Multiplicity+import GHC.Utils.Misc+import GHC.Utils.Outputable  import Data.Maybe( isJust ) import qualified Data.Data as Data@@ -61,6 +67,10 @@ 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)+ {- ************************************************************************ *                                                                      *@@ -103,16 +113,33 @@     gunfold _ _  = error "gunfold"     dataTypeOf _ = mkNoRepType "ConLike" --- | Number of arguments+-- | 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]@@ -126,10 +153,11 @@ -- 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 -> [InvisTVBinder]+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`. @@ -185,10 +213,14 @@ -- -- 7) The original result type conLikeFullSig :: ConLike-               -> ([TyVar], [TyCoVar], [EqSpec]+               -> ([TyVar], [TyCoVar]                    -- Why tyvars for universal but tycovars for existential?                    -- See Note [Existential coercion variables] in GHC.Core.DataCon-                  , ThetaType, ThetaType, [Scaled Type], Type)+                  , [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@@ -203,13 +235,6 @@ 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
GHC/Core/DataCon.hs view
@@ -6,6 +6,7 @@ -}  {-# LANGUAGE DeriveDataTypeable #-}+{-# OPTIONS_GHC -Wno-orphans #-} -- Outputable, Binary  module GHC.Core.DataCon (         -- * Main data types@@ -19,10 +20,9 @@         -- ** Equality specs         EqSpec, mkEqSpec, eqSpecTyVar, eqSpecType,         eqSpecPair, eqSpecPreds,-        substEqSpec, filterEqSpec,          -- ** Field labels-        FieldLabel(..), FieldLabelString,+        FieldLabel(..), flLabel, FieldLabelString,          -- ** Type construction         mkDataCon, fIRST_TAG,@@ -35,30 +35,34 @@         dataConNonlinearType,         dataConDisplayType,         dataConUnivTyVars, dataConExTyCoVars, dataConUnivAndExTyCoVars,+        dataConConcreteTyVars,         dataConUserTyVars, dataConUserTyVarBinders,-        dataConEqSpec, dataConTheta,+        dataConTheta,         dataConStupidTheta,         dataConOtherTheta,         dataConInstArgTys, dataConOrigArgTys, dataConOrigResTy,-        dataConInstOrigArgTys, dataConRepArgTys,+        dataConInstOrigArgTys, dataConRepArgTys, dataConResRepTyArgs,         dataConInstUnivs,         dataConFieldLabels, dataConFieldType, dataConFieldType_maybe,         dataConSrcBangs,-        dataConSourceArity, dataConRepArity,+        dataConSourceArity, dataConVisArity, dataConRepArity,         dataConIsInfix,         dataConWorkId, dataConWrapId, dataConWrapId_maybe,         dataConImplicitTyThings,-        dataConRepStrictness, dataConImplBangs, dataConBoxer,+        dataConRepStrictness,+        dataConImplBangs, dataConBoxer,          splitDataProductType_maybe,          -- ** Predicates on DataCons         isNullarySrcDataCon, isNullaryRepDataCon,+        isLazyDataConRep,         isTupleDataCon, isBoxedTupleDataCon, isUnboxedTupleDataCon,-        isUnboxedSumDataCon,-        isVanillaDataCon, isNewDataCon, classDataCon, dataConCannotMatch,-        dataConUserTyVarsArePermuted,-        isBanged, isMarkedStrict, cbvFromStrictMark, eqHsBang, isSrcStrict, isSrcUnpacked,+        isUnboxedSumDataCon, isCovertGadtDataCon, isUnaryClassDataCon,+        isVanillaDataCon, isNewDataCon, isTypeDataCon,+        classDataCon, dataConCannotMatch,+        dataConUserTyVarBindersNeedWrapper, checkDataConTyVars,+        isBanged, isUnpacked, isMarkedStrict, cbvFromStrictMark, eqHsBang, isSrcStrict, isSrcUnpacked,         specialPromotedDc,          -- ** Promotion related functions@@ -67,12 +71,16 @@  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@@ -86,17 +94,17 @@ import GHC.Types.Basic import GHC.Data.FastString import GHC.Unit.Types-import GHC.Unit.Module.Name import GHC.Utils.Binary import GHC.Types.Unique.FM ( UniqFM ) import GHC.Types.Unique.Set import GHC.Builtin.Uniques( mkAlphaTyVarUnique )+import GHC.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 GHC.Utils.Panic.Plain  import Data.ByteString (ByteString) import qualified Data.ByteString.Builder as BSB@@ -104,10 +112,11 @@ import qualified Data.Data as Data import Data.Char import Data.List( find )+import Control.DeepSeq  {--Data constructor representation-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Note [Data constructor representation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider the following Haskell data type declaration          data T = T !Int ![Int]@@ -136,9 +145,21 @@         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.+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:@@ -204,11 +225,12 @@ * See Note [Data Constructor Naming] for how the worker and wrapper   are named -* Neither_ the worker _nor_ the wrapper take the dcStupidTheta dicts as arguments+* The 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 worker is absent, dataConRepArgTys is the same as dcOrigArgTys+  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@@ -228,7 +250,7 @@         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+  Notice that the worker has two fields where the wrapper has   just one.  That is, the worker has type                 MkT :: Int -> Int -> T @@ -250,6 +272,8 @@ * 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] ~~~~~~~~~~~~~~~~~~~~~~~~~@@ -282,7 +306,7 @@  I say the context is "stupid" because the dictionaries passed are immediately discarded -- they do nothing and have no benefit.-(See Note [Instantiating stupid theta] in GHC.Tc.Gen.Head.)+(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@@ -326,6 +350,30 @@   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}@@ -334,11 +382,6 @@ -}  -- | A data constructor------ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen',---             'GHC.Parser.Annotation.AnnClose','GHC.Parser.Annotation.AnnComma'---- For details on above see Note [exact print annotations] in GHC.Parser.Annotation data DataCon   = MkData {         dcName    :: Name,      -- This is the name of the *source data con*@@ -391,7 +434,7 @@                 --       syntax, provided its type looks like the above.                 --       The declaration format is held in the TyCon (algTcGadtSyntax) -        -- Universally-quantified type vars [a,b,c]+        -- 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@@ -400,18 +443,27 @@          -- Existentially-quantified type and coercion vars [x,y]         -- For an example involving coercion variables,-        -- Why tycovars? See Note [Existential 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: 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+        -- 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 :: [InvisTVBinder],+        dcUserTyVarBinders :: [TyVarBinder],          dcEqSpec :: [EqSpec],   -- Equalities derived from the result type,                                 -- _as written by the programmer_.@@ -470,6 +522,18 @@                 -- 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;@@ -496,7 +560,7 @@                                 --      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)+                                --  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@@ -516,52 +580,107 @@   }  -{- 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 TyCoBinder in terms] in GHC.Core.TyCo.Rep.)--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 correct visibility.  That in turn governs whether you-can use visible type application at a call of the data constructor.--See also [DataCon user type variable binders] for an extended discussion on the-order in which TyVarBinders appear in a DataCon.--Note [Existential coercion variables]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-+{- 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+    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)]+  dcEqSpec           = [b ~# (c|>co)]   dcOtherTheta       = []   dcOrigArgTys       = []   dcRepTyCon         = T -  Function call 'dataConKindEqSpec' returns [k'~k]+Function call 'dataConKindEqSpec' returns [k'~k]  Note [DataCon arities] ~~~~~~~~~~~~~~~~~~~~~~-dcSourceArity does not take constraints into account,-but dcRepArity does.  For example:+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@@ -604,36 +723,70 @@ performs a stable topological sort on the type variables in the user-written type signature, which would place `b` before `a`. -But as noted above, enacting this behavior is not entirely trivial, as System-FC demands the variables go in universal-then-existential order under the hood.-Our solution is thus to equip DataCon with two different sets of type-variables:+--- Reason (R2): GADT constructors quantify over different variables --- -* dcUnivTyVars and dcExTyCoVars, for the universal type variable and existential-  type/coercion variables, respectively. Their order is irrelevant for the-  purposes of TypeApplications, and as a consequence, they do not come equipped-  with visibilities (that is, they are TyVars/TyCoVars instead of-  TyCoVarBinders).+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 -* dcUserTyVarBinders, for the type variables binders in the order in which they-  originally arose in the user-written type signature. Their order *does* matter-  for TypeApplications, so they are full TyVarBinders, complete with-  visibilities.+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. -This encoding has some redundancy. The set of tyvars in dcUserTyVarBinders-consists precisely of:+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".+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@@ -686,13 +839,6 @@                                           -- 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]--        , 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]-     }  type DataConEnv a = UniqFM DataCon a     -- Keyed by DataCon@@ -701,17 +847,18 @@  -- | Haskell Source Bang ----- Bangs on data constructor arguments as the user wrote them in the--- source code.+-- 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)@-data HsSrcBang =-  HsSrcBang SourceText -- Note [Pragma source text] in GHC.Types.SourceText-            SrcUnpackedness-            SrcStrictness+--+-- 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@@ -720,30 +867,17 @@ -- after consulting HsSrcBang, flags, etc. data HsImplBang   = HsLazy    -- ^ Lazy field, or one with an unlifted type-  | HsStrict  -- ^ Strict but not unpacked field+  | 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 --- | 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 used to indicate strictness -- of the DataCon *worker* fields@@ -752,8 +886,7 @@  -- | An 'EqSpec' is a tyvar/type pair representing an equality made in -- rejigging a GADT constructor-data EqSpec = EqSpec TyVar-                     Type+data EqSpec = EqSpec TyVar Type  -- | Make a non-dependent 'EqSpec' mkEqSpec :: TyVar -> Type -> EqSpec@@ -769,48 +902,14 @@ eqSpecPair (EqSpec tv ty) = (tv, ty)  eqSpecPreds :: [EqSpec] -> ThetaType-eqSpecPreds spec = [ mkPrimEqPred (mkTyVarTy tv) ty+eqSpecPreds spec = [ mkNomEqPred (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 'TyVar's mentioned in an 'EqSpec'.-filterEqSpec :: [EqSpec] -> [TyVar] -> [TyVar]-filterEqSpec eq_spec-  = filter not_in_eq_spec-  where-    not_in_eq_spec var = all (not . (== var) . eqSpecTyVar) eq_spec- instance Outputable EqSpec where   ppr (EqSpec tv ty) = ppr (tv, ty) -{- 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.--Note [Bangs on data constructor arguments]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+{- Note [Bangs on data constructor arguments]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider   data T = MkT !Int {-# UNPACK #-} !Int Bool @@ -836,61 +935,64 @@   the flag settings in the importing module.   Also see Note [Bangs on imported data constructors] in GHC.Types.Id.Make -* 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]+* 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]+    [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.--So whenever this module talks about the representation of a data constructor-what it means is the DataCon with all Unpacking having been applied.-We can think of this as the Core representation.--Here's an example illustrating the Core representation:-        data Ord a => T a = MkT Int! a Void#-Here-        T :: Ord a => Int -> a -> Void# -> T a-but the rep type is-        Trep :: Int# -> a -> Void# -> T a-Actually, the unboxed part isn't implemented yet!+    [HsStrict _, HsUnpack _, HsStrict _] -Not that this representation is still *different* from runtime-representation. (Which is what STG uses afer unarise).+* 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. -This is how T would end up being used in STG post-unarise:+  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. -  let x = T 1# y-  in ...-      case x of-        T int a -> ...+  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)`. -The Void# argument is dropped and the boxed int is replaced by an unboxed-one. In essence we only generate binders for runtime relevant values.+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: -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+  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: -    MkS bool tag tpl_field ->+                    1) UNPACK without a bang+                    Example: data T = MkT {-# UNPACK #-} Int+                    This will produce a warning about missing ! before UNPACK. -See Note [Translating unboxed sums to unboxed tuples] and Note [Unarisation]-for the details of this transformation.+                    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.  ************************************************************************ *                                                                      *@@ -929,7 +1031,7 @@     ppr HsLazy                  = text "Lazy"     ppr (HsUnpack Nothing)      = text "Unpacked"     ppr (HsUnpack (Just co))    = text "Unpacked" <> parens (ppr co)-    ppr HsStrict                = text "StrictNotUnpacked"+    ppr (HsStrict b)            = text "StrictNotUnpacked" <> parens (ppr b)  instance Outputable SrcStrictness where     ppr SrcLazy     = char '~'@@ -979,10 +1081,20 @@            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 (HsStrict _)         (HsStrict _)        = True eqHsBang (HsUnpack Nothing)   (HsUnpack Nothing)  = True eqHsBang (HsUnpack (Just c1)) (HsUnpack (Just c2))   = eqType (coercionType c1) (coercionType c2)@@ -993,6 +1105,11 @@ 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@@ -1018,21 +1135,24 @@  -- | 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-          -> [TyVar]        -- ^ Universals.-          -> [TyCoVar]      -- ^ Existentials.-          -> [InvisTVBinder]    -- ^ User-written 'TyVarBinder's.-                                --   These must be Inferred/Specified.-                                --   See @Note [TyVarBinders in DataCons]@+          -> 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-          -> RuntimeRepInfo     -- ^ See comments on 'GHC.Core.TyCon.RuntimeRepInfo'+          -> PromDataConInfo    -- ^ See comments on 'GHC.Core.TyCon.PromDataConInfo'           -> KnotTied TyCon     -- ^ Representation type constructor           -> ConTag             -- ^ Constructor tag           -> ThetaType          -- ^ The "stupid theta", context of the data@@ -1043,9 +1163,11 @@   -- Can get the tag from the TyCon  mkDataCon name declared_infix prom_info-          arg_stricts   -- Must match orig_arg_tys 1-1+          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 user_tvbs+          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@@ -1060,18 +1182,22 @@   = 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,+                  dcSrcBangs = arg_stricts, dcImplBangs = impl_bangs,+                  dcStricts = str_marks',                   dcFields = fields, dcTag = tag, dcRepType = rep_ty,                   dcWorkId = work_id,                   dcRep = rep,@@ -1093,22 +1219,23 @@         -- 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 $-                 mkVisFunTys rep_arg_tys $+                 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 (Invisible spec) tv-                    | Bndr tv spec <- user_tvbs ]+    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_theta_bndrs = [ mkAnonTyConBinder InvisArg (mkTyVar n t)-     {- Invisible -}   | (n,t) <- fresh_names `zip` theta ]-    prom_arg_bndrs   = [ mkAnonTyConBinder VisArg (mkTyVar n t)+    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_theta_bndrs ++ prom_arg_bndrs+    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@@ -1126,12 +1253,12 @@     , let uniq = mkAlphaTyVarUnique n           occ = mkTyVarOccFS (mkFastString ('x' : show n)) -    , not (uniq `elementOfUniqSet` avoid_uniqs)+    , not (uniq `memberUniqueSet` avoid_uniqs)     , not (occ `elemOccSet` avoid_occs) ]    where-    avoid_uniqs :: UniqSet Unique-    avoid_uniqs = mkUniqSet (map getUnique avoids)+    avoid_uniqs :: UniqueSet+    avoid_uniqs = fromListUniqueSet (map getUnique avoids)      avoid_occs :: OccSet     avoid_occs = mkOccSet (map getOccName avoids)@@ -1182,41 +1309,26 @@ 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]--- | 'InvisTVBinder's for the type variables of the constructor, in the order the+-- | 'TyVarBinder's for the type variables of the constructor, in the order the -- user wrote them-dataConUserTyVarBinders :: DataCon -> [InvisTVBinder]+dataConUserTyVarBinders :: DataCon -> [TyVarBinder] dataConUserTyVarBinders = dcUserTyVarBinders --- | 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 con@(MkData { dcEqSpec = eq_spec, dcOtherTheta = theta })-  = dataConKindEqSpec con-    ++ 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]-                    _             -> []-    ]- -- | Dependent (kind-level) equalities in a constructor. -- There are extracted from the existential variables. -- See Note [Existential coercion variables]@@ -1231,8 +1343,8 @@   = [ EqSpec tv ty     | cv <- ex_tcvs     , isCoVar cv-    , let (_, _, ty1, ty, _) = coVarKindsTypesRole cv-          tv = getTyVar "dataConKindEqSpec" ty1+    , let (ty1, ty, _) = coVarTypesRole cv+          tv = getTyVar ty1     ]  -- | The *full* constraints on the constructor type, including dependent GADT@@ -1301,13 +1413,22 @@ dataConSrcBangs :: DataCon -> [HsSrcBang] dataConSrcBangs = dcSrcBangs --- | Source-level arity of the data constructor+-- | Number of value arguments 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+-- | 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 @@ -1316,25 +1437,36 @@ 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]+-- | 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 arguments of a--- Core constructor application (Con dc args)-dataConRepStrictness dc = case dcRep dc of-                            NoDataConRep -> [NotMarkedStrict | _ <- dataConRepArgTys dc]-                            DCR { dcr_stricts = strs } -> strs+-- ^ 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-  = case dcRep dc of-      NoDataConRep              -> replicate (dcSourceArity dc) HsLazy-      DCR { dcr_bangs = bangs } -> bangs+dataConImplBangs dc = dcImplBangs dc  dataConBoxer :: DataCon -> Maybe DataConBoxer dataConBoxer (MkData { dcRep = DCR { dcr_boxer = boxer } }) = Just boxer@@ -1449,21 +1581,26 @@ -- mentions the family tycon, not the internal one. dataConWrapperType (MkData { dcUserTyVarBinders = user_tvbs,                              dcOtherTheta = theta, dcOrigArgTys = arg_tys,-                             dcOrigResTy = res_ty })-  = mkInvisForAllTys user_tvbs $-    mkInvisFunTysMany theta $-    mkVisFunTys 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 })-  = let arg_tys' = map (\(Scaled w t) -> Scaled (case w of One -> Many; _ -> w) t) arg_tys-    in mkInvisForAllTys user_tvbs $-       mkInvisFunTysMany theta $-       mkVisFunTys arg_tys' $-       res_ty+                               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@@ -1555,7 +1692,7 @@                                     (text "dataConInstUnivs"                                       <+> ppr dc_args                                       <+> ppr (dataConUnivTyVars dc)) $-                          splitAt (length dc_args) $ 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@@ -1574,13 +1711,25 @@ -- 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+dataConRepArgTys (MkData { dcRep        = rep+                         , dcEqSpec     = eq_spec                          , dcOtherTheta = theta-                         , dcOrigArgTys = orig_arg_tys })+                         , dcOrigArgTys = orig_arg_tys+                         , dcRepTyCon   = tc })   = case rep of-      NoDataConRep -> assert (null eq_spec) $ (map unrestricted theta) ++ orig_arg_tys       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@@ -1619,6 +1768,71 @@ 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@@ -1659,17 +1873,98 @@ -- -- 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 'dataConUserTyVarsArePermuted' is only called at most once+-- "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.-dataConUserTyVarsArePermuted :: DataCon -> Bool-dataConUserTyVarsArePermuted (MkData { dcUnivTyVars = univ_tvs-                                     , dcExTyCoVars = ex_tvs, dcEqSpec = eq_spec-                                     , dcUserTyVarBinders = user_tvbs }) =-  (filterEqSpec eq_spec univ_tvs ++ ex_tvs) /= binderVars user_tvbs+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].+-}  {- %************************************************************************
GHC/Core/DataCon.hs-boot view
@@ -1,7 +1,7 @@ module GHC.Core.DataCon where  import GHC.Prelude-import {-# SOURCE #-} GHC.Types.Var( Id, TyVar, TyCoVar, InvisTVBinder )+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 )@@ -19,7 +19,7 @@ dataConTyCon     :: DataCon -> TyCon dataConExTyCoVars :: DataCon -> [TyCoVar] dataConUserTyVars :: DataCon -> [TyVar]-dataConUserTyVarBinders :: DataCon -> [InvisTVBinder]+dataConUserTyVarBinders :: DataCon -> [TyVarBinder] dataConSourceArity  :: DataCon -> Arity dataConFieldLabels :: DataCon -> [FieldLabel] dataConInstOrigArgTys  :: DataCon -> [Type] -> [Scaled Type]@@ -27,6 +27,7 @@ dataConFullSig :: DataCon                -> ([TyVar], [TyCoVar], [EqSpec], ThetaType, [Scaled Type], Type) isUnboxedSumDataCon :: DataCon -> Bool+isTypeDataCon :: DataCon -> Bool  instance Eq DataCon instance Uniquable DataCon
GHC/Core/FVs.hs view
@@ -36,12 +36,11 @@         ruleLhsFreeIds, ruleLhsFreeIdsList,         ruleRhsFreeVars, rulesRhsFreeIds, -        expr_fvs,+        exprFVs, exprLocalFVs, addBndrFV, addBndrsFV,          -- * Orphan names-        orphNamesOfType, orphNamesOfCo, orphNamesOfAxiom,-        orphNamesOfTypes, orphNamesOfCoCon,-        exprsOrphNames, orphNamesOfFamInst,+        orphNamesOfType, orphNamesOfTypes, orphNamesOfAxiomLHS,+        orphNamesOfExprs,          -- * Core syntax tree annotation with free variables         FVAnn,                  -- annotation, abstract@@ -70,9 +69,8 @@ import GHC.Core.TyCo.FVs import GHC.Core.TyCon import GHC.Core.Coercion.Axiom-import GHC.Core.FamInstEnv import GHC.Builtin.Types( unrestrictedFunTyConName )-import GHC.Builtin.Types.Prim( funTyConName )+import GHC.Builtin.Types.Prim( fUNTyCon ) import GHC.Data.Maybe( orElse )  import GHC.Utils.FV as FV@@ -98,23 +96,23 @@ -- | Find all locally-defined free Ids or type variables in an expression -- returning a non-deterministic set. exprFreeVars :: CoreExpr -> VarSet-exprFreeVars = fvVarSet . exprFVs+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.-exprFVs :: CoreExpr -> FV-exprFVs = filterFV isLocalVar . expr_fvs+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 . exprFVs+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 . exprFVs+exprFreeVarsList = fvVarList . exprLocalFVs  -- | Find all locally-defined free Ids in an expression exprFreeIds :: CoreExpr -> IdSet        -- Find all locally-defined free Ids@@ -146,68 +144,65 @@ -- | Find all locally-defined free Ids or type variables in several expressions -- returning a non-deterministic set. exprsFreeVars :: [CoreExpr] -> VarSet-exprsFreeVars = fvVarSet . exprsFVs+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.-exprsFVs :: [CoreExpr] -> FV-exprsFVs exprs = mapUnionFV exprFVs exprs+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 . exprsFVs+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 $-                                addBndrs (map fst prs)+                                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 $ expr_fvs e+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 $ expr_fvs e+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 $ expr_fvs e+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 expr_fvs es+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 expr_fvs es+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 expr_fvs e+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@@ -237,108 +232,90 @@ --                          | otherwise                    = set --      SLPJ Feb06 -addBndr :: CoreBndr -> FV -> FV-addBndr bndr fv fv_cand in_scope acc+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 -addBndrs :: [CoreBndr] -> FV -> FV-addBndrs bndrs fv = foldr addBndr fv bndrs+addBndrsFV :: [CoreBndr] -> FV -> FV+addBndrsFV bndrs fv = foldr addBndrFV fv bndrs -expr_fvs :: CoreExpr -> FV-expr_fvs (Type ty) fv_cand in_scope acc =+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-expr_fvs (Coercion co) fv_cand in_scope acc =+exprFVs (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+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 -expr_fvs (Case scrut bndr ty alts) fv_cand in_scope acc-  = (expr_fvs scrut `unionFV` tyCoFVsOfType ty `unionFV` addBndr bndr+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) = addBndrs bndrs (expr_fvs rhs)+    alt_fvs (Alt _ bndrs rhs) = addBndrsFV bndrs (exprFVs rhs) -expr_fvs (Let (NonRec bndr rhs) body) fv_cand in_scope acc-  = (rhs_fvs (bndr, rhs) `unionFV` addBndr bndr (expr_fvs body))+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 -expr_fvs (Let (Rec pairs) body) fv_cand in_scope acc-  = addBndrs (map fst pairs)-             (mapUnionFV rhs_fvs pairs `unionFV` expr_fvs body)+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) = expr_fvs rhs `unionFV`+rhs_fvs (bndr, rhs) = exprFVs 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 :: CoreTickish -> 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 (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-+                    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@@ -349,97 +326,90 @@                 -- 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+                       arg:_ | tycon == fUNTyCon -> orph_names_of_fun_ty_con arg                        _ -> emptyNameSet-orphNamesOfType (ForAllTy bndr res)  = orphNamesOfType (binderType bndr)-                                       `unionNameSet` orphNamesOfType res-orphNamesOfType (FunTy _ w arg res)  =  orph_names_of_fun_ty_con w-                                       `unionNameSet` unitNameSet funTyConName++orphNamesOfType (FunTy af w arg res) =  func+                                       `unionNameSet` unitNameSet fun_tc                                        `unionNameSet` orphNamesOfType w                                        `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+        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 -orphNamesOfMCo :: MCoercion -> NameSet-orphNamesOfMCo MRefl    = emptyNameSet-orphNamesOfMCo (MCo co) = orphNamesOfCo co--orphNamesOfCo :: Coercion -> NameSet-orphNamesOfCo (Refl ty)             = orphNamesOfType ty-orphNamesOfCo (GRefl _ ty mco)      = orphNamesOfType ty `unionNameSet` orphNamesOfMCo mco-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 _ co_mult co1 co2) = orphNamesOfCo co_mult `unionNameSet` 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 (KindCo co)           = orphNamesOfCo co-orphNamesOfCo (SubCo co)            = orphNamesOfCo co-orphNamesOfCo (AxiomRuleCo _ cs)    = orphNamesOfCos cs-orphNamesOfCo (HoleCo _)            = emptyNameSet--orphNamesOfProv :: UnivCoProvenance -> NameSet-orphNamesOfProv (PhantomProv co)    = orphNamesOfCo co-orphNamesOfProv (ProofIrrelProv co) = orphNamesOfCo co-orphNamesOfProv (PluginProv _)      = emptyNameSet-orphNamesOfProv (CorePrepProv _)    = 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+-- | `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 in the implementation of ":info" in GHCi.-orphNamesOfFamInst :: FamInst -> NameSet-orphNamesOfFamInst fam_inst = orphNamesOfAxiom (famInstAxiom fam_inst)+-- 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+-- 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 Many = unitNameSet unrestrictedFunTyConName-orph_names_of_fun_ty_con _ = emptyNameSet+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++ {- ************************************************************************ *                                                                      *@@ -461,7 +431,7 @@                      -- See Note [Rule free var hack]                    , ru_bndrs = bndrs                    , ru_rhs = rhs, ru_args = args })-  = filterFV isLocalVar $ addBndrs bndrs (exprs_fvs exprs)+  = filterFV isLocalVar $ addBndrsFV bndrs (exprsFVs exprs)   where     exprs = case from of       LhsOnly   -> args@@ -680,9 +650,9 @@   = case unf of       CoreUnfolding { uf_tmpl = rhs, uf_src = src }          | isStableSource src-         -> Just (filterFV isLocalVar $ expr_fvs rhs)+         -> Just (exprLocalFVs rhs)       DFunUnfolding { df_bndrs = bndrs, df_args = args }-         -> Just (filterFV isLocalVar $ FV.delFVs (mkVarSet bndrs) $ exprs_fvs args)+         -> Just (filterFV isLocalVar $ FV.delFVs (mkVarSet bndrs) $ exprsFVs args)             -- DFuns are top level, so no fvs from types of bndrs       _other -> Nothing @@ -729,7 +699,7 @@       | isLocalVar v = (aFreeVar v `unionFVs` ty_fvs `unionFVs` mult_vars, AnnVar v)       | otherwise    = (emptyDVarSet,                 AnnVar v)       where-        mult_vars = tyCoVarsOfTypeDSet (varMult v)+        mult_vars = tyCoVarsOfTypeDSet (idMult v)         ty_fvs = dVarTypeTyCoVars v                  -- See Note [The FVAnn invariant]
GHC/Core/FamInstEnv.hs view
@@ -3,7 +3,6 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections       #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} -- (c) The University of Glasgow 2006 -- -- FamInstEnv: Type checked family instance declarations@@ -11,8 +10,8 @@ module GHC.Core.FamInstEnv (         FamInst(..), FamFlavor(..), famInstAxiom, famInstTyCon, famInstRHS,         famInstsRepTyCons, famInstRepTyCon_maybe, dataFamInstRepTyCon,-        pprFamInst, pprFamInsts,-        mkImportedFamInst,+        pprFamInst, pprFamInsts, orphNamesOfFamInst,+        mkImportedFamInst, mkLocalFamInst,          FamInstEnvs, FamInstEnv, emptyFamInstEnv, emptyFamInstEnvs,         unionFamInstEnv, extendFamInstEnv, extendFamInstEnvList,@@ -25,7 +24,7 @@         FamInstMatch(..),         lookupFamInstEnv, lookupFamInstEnvConflicts, lookupFamInstEnvByTyCon, -        isDominatedBy, apartnessCheck,+        isDominatedBy, apartnessCheck, compatibleBranches,          -- Injectivity         InjectivityCheckResult(..),@@ -39,30 +38,42 @@  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.Data.Maybe import GHC.Types.Var import GHC.Types.SrcLoc-import Control.Monad-import Data.List( mapAccumL )-import Data.Array( Array, assocs )+import GHC.Types.Name.Set  import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Utils.Panic.Plain++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 )+ {- ************************************************************************ *                                                                      *@@ -120,6 +131,8 @@             -- in GHC.Core.Coercion.Axiom              , fi_rhs :: Type         --   the RHS, with its freshened vars++            , fi_orphan :: IsOrphan             }  data FamFlavor@@ -204,6 +217,10 @@        DataFamilyInst tycon -> tycon        SynFamilyInst        -> pprPanic "dataFamInstRepTyCon" (ppr fi) +orphNamesOfFamInst :: FamInst -> NameSet+orphNamesOfFamInst (FamInst { fi_axiom = ax }) = orphNamesOfAxiomLHS ax++ {- ************************************************************************ *                                                                      *@@ -231,10 +248,10 @@     ppr_tc_sort = 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+                       | 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@@ -244,6 +261,36 @@ 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] ~~~~~~~~~~~~~~~~~~~~~~~@@ -267,8 +314,9 @@ mkImportedFamInst :: Name               -- Name of the family                   -> [RoughMatchTc]     -- Rough match info                   -> CoAxiom Unbranched -- Axiom introduced+                  -> IsOrphan                   -> FamInst            -- Resulting family instance-mkImportedFamInst fam mb_tcs axiom+mkImportedFamInst fam mb_tcs axiom orphan   = FamInst {       fi_fam    = fam,       fi_tcs    = mb_tcs,@@ -277,7 +325,8 @@       fi_tys    = tys,       fi_rhs    = rhs,       fi_axiom  = axiom,-      fi_flavor = flavor }+      fi_flavor = flavor,+      fi_orphan = orphan }   where      -- See Note [Lazy axiom match]      ~(CoAxBranch { cab_lhs = tys@@ -325,7 +374,7 @@  - For finding overlaps and conflicts   - For finding the representation type...see FamInstEnv.topNormaliseType-   and its call site in GHC.Core.Opt.Simplify+   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]@@ -366,7 +415,7 @@  data FamInstEnv   = FamIE !Int -- The number of instances, used to choose the smaller environment-               -- when checking type family consistnecy of home modules.+               -- when checking type family consistency of home modules.           !(RoughMap FamInst)      -- See Note [FamInstEnv]      -- See Note [FamInstEnv determinism]@@ -439,8 +488,8 @@ 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 type-family applications when matching instances] in GHC.Core.Unify.)+applications into fresh variables. (See Note [Apartness and type families]+in GHC.Core.Unify.)  Note [Compatibility] ~~~~~~~~~~~~~~~~~~~~@@ -464,11 +513,11 @@ 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+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:@@ -531,15 +580,16 @@ compatibleBranches :: CoAxBranch -> CoAxBranch -> Bool compatibleBranches (CoAxBranch { cab_lhs = lhs1, cab_rhs = rhs1 })                    (CoAxBranch { cab_lhs = lhs2, cab_rhs = rhs2 })-  = let (commonlhs1, commonlhs2) = zipAndUnzip lhs1 lhs2-             -- See Note [Compatibility of eta-reduced axioms]-    in case tcUnifyTysFG alwaysBindFun commonlhs1 commonlhs2 of-      SurelyApart -> True-      Unifiable subst-        | Type.substTyAddInScope subst rhs1 `eqType`-          Type.substTyAddInScope subst rhs2-        -> True-      _ -> False+  = 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@@ -549,38 +599,43 @@    | 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+    -- 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_lhs = lhs1, cab_rhs = rhs1 })-                  ax2@(CoAxBranch { cab_lhs = lhs2, cab_rhs = rhs2 })+                  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 case tcUnifyTyWithTFs True rhs1 rhs2 of -- True = two-way pre-unification+        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-        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  -- check case 1B1 from Note.-           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 })-                -- payload of InjectivityUnified used only for check 1B2, only-                -- for closed type families +       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@@ -590,7 +645,7 @@   where     go :: [CoAxBranch] -> CoAxBranch -> ([CoAxBranch], CoAxBranch)     go prev_brs cur_br-       = (cur_br : prev_brs, new_br)+       = (new_br : prev_brs, new_br)        where          new_br = cur_br { cab_incomps = mk_incomps prev_brs cur_br } @@ -682,7 +737,7 @@     -- See Note [Tidy axioms when we build them]     -- See also Note [CoAxBranch type variables] in GHC.Core.Coercion.Axiom -    init_occ_env = initTidyOccEnv [mkTyVarOcc "_"]+    init_occ_env = initTidyOccEnv [mkTyVarOccFS (fsLit "_")]     init_tidy_env = mkEmptyTidyEnv init_occ_env     -- See Note [Always number wildcard types in CoAxBranch] @@ -916,7 +971,7 @@ lookupFamInstEnvInjectivityConflicts     :: [Bool]         -- injectivity annotation for this type family instance                       -- INVARIANT: list contains at least one True value-    ->  FamInstEnvs   -- all type instances seens so far+    ->  FamInstEnvs   -- all type instances seen so far     ->  FamInst       -- new type instance that we're checking     -> [CoAxBranch]   -- conflicting instance declarations lookupFamInstEnvInjectivityConflicts injList fam_inst_envs@@ -1140,13 +1195,12 @@    | Just ax <- isClosedSynFamilyTyConWithAxiom_maybe tc   , Just (ind, inst_tys, inst_cos) <- chooseBranch ax tys-  = let co = mkAxInstCo role ax ind inst_tys inst_cos+  = let co = mkAxInstCo role (BranchedAxiom ax ind) inst_tys inst_cos     in Just $ coercionRedn co -  | Just ax           <- isBuiltInSynFamTyCon_maybe tc-  , Just (coax,ts,ty) <- sfMatchFam ax tys-  , role == coaxrRole coax-  = let co = mkAxiomRuleCo coax (zipWith mkReflCo (coaxrAsmpRoles coax) ts)+  | 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@@ -1176,22 +1230,16 @@        -> Maybe (BranchIndex, [Type], [Coercion])     go (index, branch) other       = let (CoAxBranch { cab_tvs = tpl_tvs, cab_cvs = tpl_cvs-                        , cab_lhs = tpl_lhs-                        , cab_incomps = incomps }) = branch-            in_scope = mkInScopeSet (unionVarSets $-                            map (tyCoVarsOfTypes . coAxBranchLHS) incomps)-            -- See Note [Flattening type-family applications when matching instances]-            -- in GHC.Core.Unify-            flattened_target = flattenTys in_scope target_tys+                        , cab_lhs = tpl_lhs }) = branch         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.+        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+        -- Failure. keep looking         _ -> other  -- | Do an apartness check, as described in the "Closed Type Families" paper@@ -1199,15 +1247,12 @@ -- ('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 type-family applications when matching instances]-  -- in GHC.Core.Unify.-               -> CoAxBranch -- ^ the candidate equation we wish to use+               -> 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 })+apartnessCheck target (CoAxBranch { cab_incomps = incomps })   = all (isSurelyApart-         . tcUnifyTysFG alwaysBindFun flattened_target+         . tcUnifyTysFG alwaysBindFam alwaysBindTv target          . coAxBranchLHS) incomps   where     isSurelyApart SurelyApart = True@@ -1291,7 +1336,7 @@ --      * newtypes -- returning an appropriate Representational coercion.  Specifically, if --   topNormaliseType_maybe env ty = Just (co, ty')--- then+-- then postconditions: --   (a) co :: ty ~R ty' --   (b) ty' is not a newtype, and is not a type-family or data-family redex --@@ -1311,7 +1356,7 @@      unwrapNewTypeStepper' :: NormaliseStepper (Coercion, MCoercionN)     unwrapNewTypeStepper' rec_nts tc tys-      = mapStepResult (, MRefl) $ 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@@ -1323,16 +1368,50 @@           _ -> 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-  | Just (tenv, rhs, tys') <- expandSynTyCon_maybe 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@@ -1371,41 +1450,11 @@     assemble_result r redn kind_co       = mkCoherenceRightMRedn r redn (mkSymMCo kind_co) ------------------- | Try to simplify a type-family application, by *one* step--- If topReduceTyFamApp_maybe env r F tys = Just (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- normalise_tc_args :: TyCon -> [Type] -> NormM ArgsReductions normalise_tc_args tc tys   = do { role <- getRole        ; normalise_args (tyConKind tc) (tyConRolesX role tc) tys } -----------------normaliseType :: FamInstEnvs-              -> Role  -- desired role of coercion-              -> Type -> Reduction-normaliseType env role ty-  = initNormM env role (tyCoVarsOfType ty) $ normalise_type ty- normalise_type :: Type -> NormM Reduction -- Normalise the input type, by eliminating *all* type-function redexes -- but *not* newtypes (which are visible to the programmer)@@ -1468,7 +1517,7 @@                Nothing ->                  do { ArgsReductions redns res_co                         <- normalise_args (typeKind nfun)-                                          (repeat Nominal)+                                          (Inf.repeat Nominal)                                           arg_tys                     ; role <- getRole                     ; return $@@ -1477,7 +1526,7 @@                           (mkSymMCo res_co) } }  normalise_args :: Kind    -- of the function-               -> [Role]  -- roles at which to normalise args+               -> Infinite Role  -- roles at which to normalise args                -> [Type]  -- args                -> NormM ArgsReductions -- returns ArgsReductions (Reductions cos xis) res_co,@@ -1487,7 +1536,7 @@ -- but the resulting application *will* be well-kinded -- cf. GHC.Tc.Solver.Rewrite.rewrite_args_slow normalise_args fun_ki roles args-  = do { normed_args <- zipWithM normalise1 roles args+  = 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
GHC/Core/InstEnv.hs view
@@ -7,18 +7,19 @@ The bits common to GHC.Tc.TyCl.Instance and GHC.Tc.Deriv. -} -{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveDataTypeable, DeriveGeneric #-}  module GHC.Core.InstEnv (         DFunId, InstMatch, ClsInstLookupResult,-        PotentialUnifiers(..), getPotentialUnifiers, nullUnifiers,+        CanonicalEvidence(..), PotentialUnifiers(..), getCoherentUnifiers, nullUnifiers,         OverlapFlag(..), OverlapMode(..), setOverlapModeMaybe,-        ClsInst(..), DFunInstType, pprInstance, pprInstanceHdr, pprInstances,-        instanceHead, instanceSig, mkLocalInstance, mkImportedInstance,+        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,@@ -32,29 +33,35 @@         isOverlappable, isOverlapping, isIncoherent     ) where -import GHC.Prelude+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.Core.Class import GHC.Types.Var import GHC.Types.Unique.DSet import GHC.Types.Var.Set import GHC.Types.Name import GHC.Types.Name.Set-import GHC.Core.Unify 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+import GHC.Utils.Outputable hiding ((<>)) import GHC.Utils.Panic-import GHC.Utils.Panic.Plain import Data.Semigroup  {-@@ -102,6 +109,10 @@              , 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 @@ -116,10 +127,11 @@     cmp (RM_KnownTc _, RM_WildCard)   = GT     cmp (RM_KnownTc x, RM_KnownTc y) = stableNameCmp x y -isOverlappable, isOverlapping, isIncoherent :: ClsInst -> Bool+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]@@ -162,7 +174,7 @@ 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'.+The invariant is checked by the ASSERT in instEnvMatchesAndUnifiers.  Note [Proper-match fields] ~~~~~~~~~~~~~~~~~~~~~~~~~@@ -211,6 +223,16 @@ 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@@ -222,17 +244,22 @@ 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)+  = 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_tys = tys, is_dfun = dfun })+instanceHead (ClsInst { is_tvs = tvs, is_cls = cls, is_tys = tys })    = (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`:@@ -254,19 +281,20 @@ -- Decomposes the DFunId instanceSig ispec = tcSplitDFunTy (idType (is_dfun ispec)) -mkLocalInstance :: DFunId -> OverlapFlag-                -> [TyVar] -> Class -> [Type]-                -> ClsInst+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.-mkLocalInstance dfun oflag tvs cls tys+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_orphan = orph, is_warn = warn             }   where     cls_name = className cls@@ -280,46 +308,52 @@      -- 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+         | all notOrphan mb_ns = NE.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+    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) -mkImportedInstance :: 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?-                   -> ClsInst+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-mkImportedInstance cls_nm mb_tcs dfun_name dfun oflag orphan+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_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 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. @@ -565,57 +599,93 @@ 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+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 as follows:+instance declaration itself, controlled by its `OverlapMode`, 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 "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"-   if it has an OVERLAPPABLE or OVERLAPS pragma, or-   if it appears in a module compiled with -XOverlappingInstances, or+ * 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"-   if it has an OVERLAPPING or OVERLAPS pragma, or-   if it appears in a module compiled with -XOverlappingInstances, or+ * 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.-     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*.+(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. -*  Eliminate any candidate `IX` for which both of the following hold:+(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. -   -  There is another candidate `IY` that is strictly more specific; that-      is, `IY` is a substitution instance of `IX` but not vice versa.+(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). -   -  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.)+(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.) --  If exactly one non-incoherent candidate remains, select it. If all-   remaining candidates are incoherent, select an arbitrary one.-   Otherwise the search fails (i.e. when more than one surviving-   candidate is not incoherent).+      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.) --  If the selected candidate (from the previous step) is incoherent, the-   search succeeds, returning that candidate.+      This is implemented by `pruneOverlappedMatches`, producing final_matches in+      lookupInstEnv.  See Note [Instance overlap and guards] and+      Note [Incoherent instances]. --  If not, find all instances that *unify* with the target constraint,-   but do not *match* it. Such non-candidate instances might match when-   the target constraint is further instantiated. If all of them are-   incoherent, the search succeeds, returning the selected candidate; if-   not, the search fails.+(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@@ -742,6 +812,185 @@ 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@@ -821,51 +1070,131 @@ -- yield 'Left errorMessage'. lookupUniqueInstEnv :: InstEnvs                     -> Class -> [Type]-                    -> Either SDoc (ClsInst, [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 $ text "flexible type variable:" <+>-                                    (ppr $ mkTyConApp (classTyCon cls) tys)+             | otherwise  -> Left $ LookupInstErrFlexiVar              where                inst_tys'  = [ty | Just ty <- inst_tys]                noFlexiVar = all isJust inst_tys-      _other -> Left $ text "instance not found" <+>-                       (ppr $ mkTyConApp (classTyCon cls) tys)+      _other -> Left $ LookupInstErrNotFound -data PotentialUnifiers = NoUnifiers-                       | OneOrMoreUnifiers [ClsInst]-                       -- This list is lazy as we only look at all the unifiers when-                       -- printing an error message. It can be expensive to compute all-                       -- the unifiers because if you are matching something like C a[sk] then-                       -- all instances will unify.+-- | 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 = text "NoUnifiers"-  ppr xs = ppr (getPotentialUnifiers xs)+  ppr (NoUnifiers c) = text "NoUnifiers" <+> ppr c+  ppr xs = ppr (getCoherentUnifiers xs)  instance Semigroup PotentialUnifiers where-  NoUnifiers <> u = u-  u <> NoUnifiers = u-  u1 <> u2 = OneOrMoreUnifiers (getPotentialUnifiers u1 ++ getPotentialUnifiers u2)--instance Monoid PotentialUnifiers where-  mempty = NoUnifiers+  NoUnifiers c1 <> NoUnifiers c2 = NoUnifiers (c1 `andCanEv` c2)+  NoUnifiers _ <> u = u+  OneOrMoreUnifiers (unifier :| unifiers) <> u+    = OneOrMoreUnifiers (unifier :| (unifiers <> getCoherentUnifiers u)) -getPotentialUnifiers :: PotentialUnifiers -> [ClsInst]-getPotentialUnifiers NoUnifiers = []-getPotentialUnifiers (OneOrMoreUnifiers cls) = cls+getCoherentUnifiers :: PotentialUnifiers -> [ClsInst]+getCoherentUnifiers NoUnifiers{} = []+getCoherentUnifiers (OneOrMoreUnifiers cls) = NE.toList cls +-- | Are there no *coherent* unifiers? nullUnifiers :: PotentialUnifiers -> Bool-nullUnifiers NoUnifiers = True+nullUnifiers NoUnifiers{} = True nullUnifiers _ = False -lookupInstEnv' :: InstEnv          -- InstEnv to look in-               -> VisibleOrphanModules   -- But filter against this-               -> Class -> [Type]  -- What we are looking for-               -> ([InstMatch],    -- Successful matches-                   PotentialUnifiers)      -- These don't match but do unify+-- | 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]@@ -877,8 +1206,8 @@ -- but Foo [Int] is a unifier.  This gives the caller a better chance of -- giving a suitable error message -lookupInstEnv' (InstEnv rm) vis_mods cls tys-  = (foldr check_match [] rough_matches, check_unifier rough_unifiers)+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@@ -891,22 +1220,23 @@        | 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) -    check_unifier :: [ClsInst] -> PotentialUnifiers-    check_unifier [] = NoUnifiers-    check_unifier (item@ClsInst { is_tvs = tpl_tvs, is_tys = tpl_tys }:items)       | not (instIsVisible vis_mods item)-      = check_unifier items  -- See Note [Instance lookup and orphan instances]-      | Just {} <- tcMatchTys tpl_tys tys = check_unifier items-        -- Does not match, so next check whether the things unify-        -- See Note [Overlapping instances]-        -- Ignore ones that are incoherent: Note [Incoherent instances]-      | isIncoherent item-      = check_unifier items+      = 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) $$@@ -914,20 +1244,38 @@                 -- 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 instanceBindFun tpl_tys tys of+        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.-            SurelyApart              -> check_unifier items+          -- 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_unifier items-            _                        ->-              OneOrMoreUnifiers (item: getPotentialUnifiers (check_unifier items))+            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@@ -945,10 +1293,13 @@               tys   = (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   `mappend` pkg_unifs+    -- (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@@ -961,11 +1312,21 @@            _       -> []      -- If the selected match is incoherent, discard all unifiers+    -- See (IL4) of Note [Rules for instance lookup]     final_unifs = case final_matches of-                    (m:_) | isIncoherent (fst m) -> NoUnifiers-                    _                            -> all_unifs+                    (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]+    -- 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@@ -1059,7 +1420,7 @@       A2. M is not overlapping,       A3. G is overlapping. -    This means that we eliminate G from the set of matches (it is overriden by M),+    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. @@ -1067,7 +1428,7 @@      There are two situations in which guards can eliminate a match: -      B1. We want to add a new instance, but it is overriden by a guard.+      B1. We want to add a new instance, but it is overridden by a guard.           We can immediately discard the instance.            Example for B1:@@ -1080,7 +1441,7 @@            Processing them in order: we add J1 as a match, then J2 as a guard.           Now, when we come across J3, we can immediately discard it because-          it is overriden by the guard J2.+          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@@ -1096,7 +1457,7 @@              We start by considering K1 and K2. Neither has any overlapping flag set,             so we end up with two matches, {K1, K2}.-            Next we look at K3: it is overriden by K1, but as K1 is not+            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.@@ -1140,7 +1501,10 @@ pruneOverlappedMatches :: [InstMatch] -> [InstMatch] -- ^ Remove from the argument list any InstMatches for which another -- element of the list is more specific, and overlaps it, using the--- rules of Nove [Rules for instance lookup]+-- 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 @@ -1274,8 +1638,8 @@ 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+        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@@ -1293,7 +1657,12 @@ 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.  ************************************************************************ *                                                                      *@@ -1302,14 +1671,14 @@ ************************************************************************ -} -instanceBindFun :: BindFun-instanceBindFun tv _rhs_ty | isOverlappableTyVar tv = Apart+instanceBindFun :: BindTvFun+instanceBindFun tv _rhs_ty | isOverlappableTyVar tv = DontBindMe                            | otherwise              = BindMe-   -- Note [Binding when looking up instances]+   -- Note [Super skolems: binding when looking up instances]  {--Note [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]@@ -1325,9 +1694,9 @@         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+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 Apart in instanceBindFun, above, means+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
GHC/Core/LateCC.hs view
@@ -1,167 +1,94 @@-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE TupleSections #-}+{-# LANGUAGE RecordWildCards #-} --- | Adds cost-centers after the core piple has run.+-- | Adds cost-centers after the core pipline has run. module GHC.Core.LateCC-    ( addLateCostCentresMG-    , addLateCostCentresPgm-    , addLateCostCentres -- Might be useful for API users-    , Env(..)+    ( -- * Inserting cost centres+      addLateCostCenters     ) where -import Control.Applicative-import GHC.Utils.Monad.State.Strict-import Control.Monad- import GHC.Prelude-import GHC.Driver.Session-import GHC.Types.CostCentre-import GHC.Types.CostCentre.State-import GHC.Types.Name hiding (varName)-import GHC.Types.Tickish-import GHC.Unit.Module.ModGuts-import GHC.Types.Var-import GHC.Unit.Types-import GHC.Data.FastString-import GHC.Core-import GHC.Core.Opt.Monad-import GHC.Types.Id-import GHC.Core.Utils (mkTick) -import qualified Data.Set as S+import GHC.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.Utils.Misc-import GHC.Utils.Error (withTiming)---{- Note [Collecting late cost centres]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Usually cost centres defined by a module are collected-during tidy by collectCostCentres. However with `-fprof-late`-we insert cost centres after inlining. So we keep a list of-all the cost centres we inserted and combine that with the list-of cost centres found during tidy.--To avoid overhead when using -fprof-inline there is a flag to stop-us from collecting them here when we run this pass before tidy.--Note [Adding late cost centres]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The basic idea is very simple. For every top level binder-`f = rhs` we compile it as if the user had written-`f = {-# SCC f #-} rhs`.--If we do this after unfoldings for `f` have been created this-doesn't impact core-level optimizations at all. If we do it-before the cost centre will be included in the unfolding and-might inhibit optimizations at the call site. For this reason-we provide flags for both approaches as they have different-tradeoffs.--We also don't add a cost centre for any binder that is a constructor-worker or wrapper. These will never meaningfully enrich the resulting-profile so we improve efficiency by omitting those.---}--addLateCostCentresMG :: ModGuts -> CoreM ModGuts-addLateCostCentresMG guts = do-  dflags <- getDynFlags-  let env :: Env-      env = Env-        { thisModule = mg_module guts-        , ccState = newCostCentreState-        , countEntries = gopt Opt_ProfCountEntries dflags-        , collectCCs = False -- See Note [Collecting late cost centres]-        }-  let guts' = guts { mg_binds = fst (addLateCostCentres env (mg_binds guts))-                   }-  return guts'+import GHC.Types.RepType (mightBeFunTy) -addLateCostCentresPgm :: DynFlags -> Logger -> Module -> CoreProgram -> IO (CoreProgram, S.Set CostCentre)-addLateCostCentresPgm dflags logger mod binds =-  withTiming logger-               (text "LateCC"<+>brackets (ppr mod))-               (\(a,b) -> a `seqList` (b `seq` ())) $ do-  let env = Env-        { thisModule = mod-        , ccState = newCostCentreState-        , countEntries = gopt Opt_ProfCountEntries dflags-        , collectCCs = True -- See Note [Collecting late cost centres]-        }-      (binds', ccs) = addLateCostCentres env binds-  when (dopt Opt_D_dump_late_cc dflags || dopt Opt_D_verbose_core2core dflags) $-    putDumpFileMaybe logger Opt_D_dump_late_cc "LateCC" FormatCore (vcat (map ppr binds'))-  return (binds', ccs)+-- | 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 -addLateCostCentres :: Env -> CoreProgram -> (CoreProgram,S.Set CostCentre)-addLateCostCentres env binds =-  let (binds', state) = runState (mapM (doBind env) binds) initLateCCState-  in (binds',lcs_ccs state)+    -- 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 }+          ) -doBind :: Env -> CoreBind -> M CoreBind-doBind env (NonRec b rhs) = NonRec b <$> doBndr env b rhs-doBind env (Rec bs) = Rec <$> mapM doPair bs+    return (late_cc_binds, late_cc_state)   where-    doPair :: ((Id, CoreExpr) -> M (Id, CoreExpr))-    doPair (b,rhs) = (b,) <$> doBndr env b rhs--doBndr :: Env -> Id -> CoreExpr -> M CoreExpr-doBndr env bndr rhs-  -- Cost centres on constructor workers are pretty much useless-  -- so we don't emit them if we are looking at the rhs of a constructor-  -- binding.-  | Just _ <- isDataConId_maybe bndr = pure rhs-  | otherwise = doBndr' env bndr rhs----- We want to put the cost centra below the lambda as we only care about executions of the RHS.-doBndr' :: Env -> Id -> CoreExpr -> State LateCCState CoreExpr-doBndr' env bndr (Lam b rhs) = Lam b <$> doBndr' env bndr rhs-doBndr' env bndr rhs = do-    let name = idName bndr-        name_loc = nameSrcSpan name-        cc_name = getOccFS name-        count = countEntries env-    cc_flavour <- getCCFlavour cc_name-    let cc_mod = thisModule env-        bndrCC = NormalCC cc_flavour cc_name cc_mod name_loc-        note = ProfNote bndrCC count True-    addCC env bndrCC-    return $ mkTick note rhs--data LateCCState = LateCCState-    { lcs_state :: !CostCentreState-    , lcs_ccs   :: S.Set CostCentre-    }-type M = State LateCCState--initLateCCState :: LateCCState-initLateCCState = LateCCState newCostCentreState mempty--getCCFlavour :: FastString -> M CCFlavour-getCCFlavour name = LateCC <$> getCCIndex' name--getCCIndex' :: FastString -> M CostCentreIndex-getCCIndex' name = do-  state <- get-  let (index,cc_state') = getCCIndex name (lcs_state state)-  put (state { lcs_state = cc_state'})-  return index--addCC :: Env -> CostCentre -> M ()-addCC !env cc = do-    state <- get-    when (collectCCs env) $ do-        let ccs' = S.insert cc (lcs_ccs state)-        put (state { lcs_ccs = ccs'})--data Env = Env-  { thisModule  :: !Module-  , countEntries:: !Bool-  , ccState     :: !CostCentreState-  , collectCCs  :: !Bool-  }+    top_level_cc_pred :: CoreExpr -> Bool+    top_level_cc_pred =+        case lateCCConfig_whichBinds of+          LateCCBinds -> \rhs ->+            -- Make sure we record any functions. Even if it's something like `f = g`.+            mightBeFunTy (exprType rhs) ||+            -- If the RHS is a CAF doing work also insert a CC.+            not (exprIsWorkFree rhs)+          LateCCOverloadedBinds ->+            isOverloadedTy . exprType+          LateCCNone ->+            -- This is here for completeness, we won't actually use this+            -- predicate in this case since we'll shortcut.+            const False +    this_mod = lateCCEnv_module lateCCConfig_env
+ GHC/Core/LateCC/OverloadedCalls.hs view
@@ -0,0 +1,227 @@+{-# LANGUAGE LambdaCase    #-}+{-# LANGUAGE TupleSections #-}++module GHC.Core.LateCC.OverloadedCalls+  ( overloadedCallsCC+  ) where++import GHC.Prelude++import Control.Monad.Trans.Class+import Control.Monad.Trans.Reader+import Control.Monad.Trans.State.Strict+import qualified GHC.Data.Strict as Strict++import GHC.Data.FastString+import GHC.Core+import GHC.Core.LateCC.Utils+import GHC.Core.LateCC.Types+import GHC.Core.Make+import GHC.Core.Predicate+import GHC.Core.Type+import GHC.Core.Utils+import GHC.Types.Id+import GHC.Types.Name+import GHC.Types.SrcLoc+import GHC.Types.Tickish+import GHC.Types.Var++type OverloadedCallsCCState = Strict.Maybe SrcSpan++{- Note [Overloaded Calls and join points]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Currently GHC considers cost centres as destructive to+join contexts. Or in other words this is not considered valid:++    join f x = ...+    in+              ... -> scc<tick> jmp++This makes the functionality of `-fprof-late-overloaded-calls` not feasible+for join points in general. We used to try to work around this by putting the+ticks on the rhs of the join point rather than around the jump. However beyond+the loss of accuracy this was broken for recursive join points as we ended up+with something like:++    rec-join f x = scc<tick> ... jmp f x++Which similarly is not valid as the tick once again destroys the tail call.+One might think we could limit ourselves to non-recursive tail calls and do+something clever like:++  join f x = scc<tick> ...+  in ... jmp f x++And sometimes this works! But sometimes the full rhs would look something like:++  join g x = ....+  join f x = scc<tick> ... -> jmp g x++Which, would again no longer be valid. I believe in the long run we can make+cost centre ticks non-destructive to join points. Or we could keep track of+where we are/are not allowed to insert a cost centre. But in the short term I will+simply disable the annotation of join calls under this flag.+-}++-- | Insert cost centres on function applications with dictionary arguments. The+-- source locations attached to the cost centres is approximated based on the+-- "closest" source note encountered in the traversal.+overloadedCallsCC :: CoreBind -> LateCCM OverloadedCallsCCState CoreBind+overloadedCallsCC =+    processBind+  where+    processBind :: CoreBind -> LateCCM OverloadedCallsCCState CoreBind+    processBind core_bind =+        case core_bind of+          NonRec b e ->+            NonRec b <$> wrap_if_join b (processExpr e)+          Rec es ->+            Rec <$> mapM (\(b,e) -> (b,) <$> wrap_if_join b (processExpr e)) es+      where+        -- If an overloaded function is turned into a join point, we won't add+        -- SCCs directly to calls since it makes them non-tail calls. Instead,+        -- we look for join points here and add an SCC to their RHS if they are+        -- overloaded.+        wrap_if_join ::+             CoreBndr+          -> LateCCM OverloadedCallsCCState CoreExpr+          -> LateCCM OverloadedCallsCCState CoreExpr+        wrap_if_join _b pexpr = do+            -- See Note [Overloaded Calls and join points]+            expr <- pexpr+            return expr++    processExpr :: CoreExpr -> LateCCM OverloadedCallsCCState CoreExpr+    processExpr expr =+      case expr of+        -- The case we care about: Application+        app@App{} -> do+          -- Here we have some application like `f v1 ... vN`, where v1 ... vN+          -- should be the function's type arguments followed by the value+          -- arguments. To determine if the `f` is an overloaded function, we+          -- check if any of the arguments v1 ... vN are dictionaries.+          let+            (f, xs) = collectArgs app+            resultTy = applyTypeToArgs (exprType f) xs++          -- Recursively process the arguments first for no particular reason+          args <- mapM processExpr xs+          let app' = mkCoreApps f args++          if+              -- Check if any of the arguments are dictionaries+              any isDictExpr args++              -- Avoid instrumenting dictionary functions, which may be+              -- overloaded if there are superclasses, by checking if the result+              -- type of the function is a dictionary type.+            && not (isDictTy resultTy)++              -- Avoid instrumenting constraint selectors like eq_sel+            && (typeTypeOrConstraint resultTy /= ConstraintLike)++              -- Avoid instrumenting join points.+              -- (See comment in processBind above)+              -- Also see Note [Overloaded Calls and join points]+            && not (isJoinVarExpr f)+          then do+            -- Extract a name and source location from the function being+            -- applied+            let+              cc_name :: FastString+              cc_name =+                maybe (fsLit "<no name available>") getOccFS (exprName app)++            cc_srcspan <-+              fmap (Strict.fromMaybe (UnhelpfulSpan UnhelpfulNoLocationInfo)) $+                lift $ gets lateCCState_extra++            insertCC cc_name cc_srcspan app'+          else+            return app'++        -- For recursive constructors of Expr, we traverse the nested Exprs+        Lam b e ->+          mkCoreLams [b] <$> processExpr e+        Let b e ->+          mkCoreLet <$> processBind b <*> processExpr e+        Case e b t alts ->+              Case+          <$> processExpr e+          <*> pure b+          <*> pure t+          <*> mapM processAlt alts+        Cast e co ->+          mkCast <$> processExpr e <*> pure co+        Tick t e -> do+          trackSourceNote t $+            mkTick t <$> processExpr e++        -- For non-recursive constructors of Expr, we do nothing+        x -> return x++    processAlt :: CoreAlt -> LateCCM OverloadedCallsCCState CoreAlt+    processAlt (Alt c bs e) = Alt c bs <$> processExpr e++    trackSourceNote :: CoreTickish -> LateCCM OverloadedCallsCCState a -> LateCCM OverloadedCallsCCState a+    trackSourceNote tick act =+      case tick of+        SourceNote rss _ -> do+          -- Prefer source notes from the current file+          in_current_file <-+            maybe False ((== EQ) . lexicalCompareFS (srcSpanFile rss)) <$>+              asks lateCCEnv_file+          if not in_current_file then+            act+          else do+            loc <- lift $ gets lateCCState_extra+            lift . modify $ \s ->+              s { lateCCState_extra =+                    Strict.Just $ RealSrcSpan rss mempty+                }+            x <- act+            lift . modify $ \s ->+              s { lateCCState_extra = loc+                }+            return x+        _ ->+          act++    -- Utility functions++    -- Extract a Name from an expression. If it is an application, attempt to+    -- extract a name from the applied function. If it is a variable, return the+    -- Name of the variable. If it is a tick/cast, attempt to extract a Name+    -- from the expression held in the tick/cast. Otherwise return Nothing.+    exprName :: CoreExpr -> Maybe Name+    exprName =+        \case+          App f _ ->+            exprName f+          Var f ->+            Just (idName f)+          Tick _ e ->+            exprName e+          Cast e _ ->+            exprName e+          _ ->+            Nothing++    -- Determine whether an expression is a dictionary+    isDictExpr :: CoreExpr -> Bool+    isDictExpr =+        maybe False isDictTy . exprType'+      where+        exprType' :: CoreExpr -> Maybe Type+        exprType' = \case+            Type{} -> Nothing+            expr -> Just $ exprType expr++    -- Determine whether an expression is a join variable+    isJoinVarExpr :: CoreExpr -> Bool+    isJoinVarExpr =+        \case+          Var var -> isJoinId var+          Tick _ e -> isJoinVarExpr e+          Cast e _ -> isJoinVarExpr e+          _ -> False
+ GHC/Core/LateCC/TopLevelBinds.hs view
@@ -0,0 +1,128 @@+{-# LANGUAGE TupleSections #-}+module GHC.Core.LateCC.TopLevelBinds where++import GHC.Prelude++import GHC.Core.LateCC.Types+import GHC.Core.LateCC.Utils++import GHC.Core+import GHC.Core.Opt.Monad+import GHC.Driver.DynFlags+import GHC.Types.Id+import GHC.Types.Name+import GHC.Unit.Module.ModGuts++import Data.Maybe++{- Note [Collecting late cost centres]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Usually cost centres defined by a module are collected+during tidy by collectCostCentres. However with `-fprof-late`+we insert cost centres after inlining. So we keep a list of+all the cost centres we inserted and combine that with the list+of cost centres found during tidy.++To avoid overhead when using -fprof-inline there is a flag to stop+us from collecting them here when we run this pass before tidy.++Note [Adding late cost centres to top level bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The basic idea is very simple. For a top level binder+`f = rhs` we compile it as if the user had written+`f = {-# SCC f #-} rhs`.++If we do this after unfoldings for `f` have been created this+doesn't impact core-level optimizations at all. If we do it+before the cost centre will be included in the unfolding and+might inhibit optimizations at the call site. For this reason+we provide flags for both approaches as they have different+tradeoffs.++To reduce overhead we ignore workfree bindings because they don't contribute+meaningfully to a performance profile. This reduces code size massively as it+allows us to allocate definitions like `val = Just 32` at compile time instead+of turning them into a CAF of the form `val = <scc val> let x = Just 32 in x` which+would be the alternative.++We make an exception for rhss with function types. This allows us to get+cost centres on eta-reduced definitions like `f = g`. By putting a tick onto+`f`s rhs we end up with++    f = \eta1 eta2 ... etan ->+        <scc f> g eta1 ... etan++Which can make it easier to understand call graphs of an application.++We also don't add a cost centre for any binder that is a constructor+worker or wrapper. These will never meaningfully enrich the resulting+profile so we improve efficiency by omitting those.++-}++-- | Add late cost centres directly to the 'ModGuts'. This is used inside the+-- core pipeline with the -fprof-late-inline flag. It should not be used after+-- tidy, since it does not manually track inserted cost centers. See+-- Note [Collecting late cost centres].+topLevelBindsCCMG :: ModGuts -> CoreM ModGuts+topLevelBindsCCMG guts = do+    dflags <- getDynFlags+    let+      env =+        LateCCEnv+          { lateCCEnv_module = mg_module guts++            -- We don't use this for topLevelBindsCC, so Nothing is okay+          , lateCCEnv_file = Nothing++          , lateCCEnv_countEntries= gopt Opt_ProfCountEntries dflags+          , lateCCEnv_collectCCs = False+          }+      guts' =+        guts+          { mg_binds =+              fst+                ( doLateCostCenters+                    env+                    (initLateCCState ())+                    (topLevelBindsCC (const True))+                    (mg_binds guts)+                )+          }+    return guts'++-- | Insert cost centres on top-level bindings in the module, depending on+-- whether or not they satisfy the given predicate.+topLevelBindsCC :: (CoreExpr -> Bool) -> CoreBind -> LateCCM s CoreBind+topLevelBindsCC pred core_bind =+    case core_bind of+      NonRec b rhs ->+        NonRec b <$> doBndr b rhs+      Rec bs ->+        Rec <$> mapM doPair bs+  where+    doPair :: ((Id, CoreExpr) -> LateCCM s (Id, CoreExpr))+    doPair (b,rhs) = (b,) <$> doBndr b rhs++    doBndr :: Id -> CoreExpr -> LateCCM s CoreExpr+    doBndr bndr rhs+      -- Not a constructor worker.+      -- Cost centres on constructor workers are pretty much useless so we don't emit them+      -- if we are looking at the rhs of a constructor binding.+      | isNothing (isDataConId_maybe bndr)+      , pred rhs+      = addCC bndr rhs+      | otherwise = pure rhs++    -- We want to put the cost centre below the lambda as we only care about+    -- executions of the RHS. Note that the lambdas might be hidden under ticks+    -- or casts. So look through these as well.+    addCC :: Id -> CoreExpr -> LateCCM s CoreExpr+    addCC bndr (Cast rhs co) = pure Cast <*> addCC bndr rhs <*> pure co+    addCC bndr (Tick t rhs) = (Tick t) <$> addCC bndr rhs+    addCC bndr (Lam b rhs) = Lam b <$> addCC bndr rhs+    addCC bndr rhs = do+      let name = idName bndr+          cc_loc = nameSrcSpan name+          cc_name = getOccFS name+      insertCC cc_name cc_loc rhs
+ GHC/Core/LateCC/Types.hs view
@@ -0,0 +1,74 @@+-- | Types related to late cost center insertion+module GHC.Core.LateCC.Types+  ( LateCCConfig(..)+  , LateCCBindSpec(..)+  , LateCCEnv(..)+  , LateCCState(..)+  , initLateCCState+  , LateCCM+  ) where++import GHC.Prelude++import Control.Monad.Trans.Reader+import Control.Monad.Trans.State.Strict+import qualified Data.Set as S++import GHC.Data.FastString+import GHC.Types.CostCentre+import GHC.Types.CostCentre.State+import GHC.Unit.Types++-- | Late cost center insertion configuration.+--+-- Specifies whether cost centers are added to overloaded function call sites+-- and/or top-level bindings, and which top-level bindings they are added to.+-- Also holds the cost center insertion environment.+data LateCCConfig =+      LateCCConfig+        { lateCCConfig_whichBinds :: !LateCCBindSpec+        , lateCCConfig_overloadedCalls :: !Bool+        , lateCCConfig_env :: !LateCCEnv+        }++-- | The types of top-level bindings we support adding cost centers to.+data LateCCBindSpec =+      LateCCNone+    | LateCCBinds+    | LateCCOverloadedBinds++-- | Late cost centre insertion environment+data LateCCEnv = LateCCEnv+  { lateCCEnv_module :: !Module+    -- ^ Current module+  , lateCCEnv_file :: Maybe FastString+    -- ^ Current file, if we have one+  , lateCCEnv_countEntries:: !Bool+    -- ^ Whether the inserted cost centers should count entries+  , lateCCEnv_collectCCs  :: !Bool+    -- ^ Whether to collect the cost centres we insert. See+    -- Note [Collecting late cost centres]++  }++-- | Late cost centre insertion state, indexed by some extra state type that an+-- insertion method may require.+data LateCCState s = LateCCState+    { lateCCState_ccs :: !(S.Set CostCentre)+      -- ^ Cost centres that have been inserted+    , lateCCState_ccState :: !CostCentreState+      -- ^ Per-module state tracking for cost centre indices+    , lateCCState_extra :: !s+    }++-- | The empty late cost centre insertion state+initLateCCState :: s -> LateCCState s+initLateCCState s =+    LateCCState+      { lateCCState_ccState = newCostCentreState+      , lateCCState_ccs = mempty+      , lateCCState_extra = s+      }++-- | Late cost centre insertion monad+type LateCCM s = ReaderT LateCCEnv (State (LateCCState s))
+ GHC/Core/LateCC/Utils.hs view
@@ -0,0 +1,80 @@+module GHC.Core.LateCC.Utils+  ( -- * Inserting cost centres+    doLateCostCenters -- Might be useful for API users++    -- ** Helpers for defining insertion methods+  , getCCFlavour+  , insertCC+  ) where++import GHC.Prelude++import Control.Monad+import Control.Monad.Trans.Class+import Control.Monad.Trans.Reader+import Control.Monad.Trans.State.Strict+import qualified Data.Set as S++import GHC.Core+import GHC.Core.LateCC.Types+import GHC.Core.Utils+import GHC.Data.FastString+import GHC.Types.CostCentre+import GHC.Types.CostCentre.State+import GHC.Types.SrcLoc+import GHC.Types.Tickish++-- | Insert cost centres into the 'CoreProgram' using the provided environment,+-- initial state, and insertion method.+doLateCostCenters+  :: LateCCEnv+  -- ^ Environment to run the insertion in+  -> LateCCState s+  -- ^ Initial state to run the insertion with+  -> (CoreBind -> LateCCM s CoreBind)+  -- ^ Insertion method+  -> CoreProgram+  -- ^ Bindings to consider+  -> (CoreProgram, LateCCState s)+doLateCostCenters env state method binds =+    runLateCC env state $ mapM method binds++-- | Evaluate late cost centre insertion+runLateCC :: LateCCEnv -> LateCCState s -> LateCCM s a -> (a, LateCCState s)+runLateCC env state = (`runState` state) . (`runReaderT` env)++-- | Given the name of a cost centre, get its flavour+getCCFlavour :: FastString -> LateCCM s CCFlavour+getCCFlavour name = mkLateCCFlavour <$> getCCIndex' name+  where+    getCCIndex' :: FastString -> LateCCM s CostCentreIndex+    getCCIndex' name = do+      cc_state <- lift $ gets lateCCState_ccState+      let (index, cc_state') = getCCIndex name cc_state+      lift . modify $ \s -> s { lateCCState_ccState = cc_state'}+      return index++-- | Insert a cost centre with the specified name and source span on the given+-- expression. The inserted cost centre will be appropriately tracked in the+-- late cost centre state.+insertCC+  :: FastString+  -- ^ Name of the cost centre to insert+  -> SrcSpan+  -- ^ Source location to associate with the cost centre+  -> CoreExpr+  -- ^ Expression to wrap in the cost centre+  -> LateCCM s CoreExpr+insertCC cc_name cc_loc expr = do+    cc_flavour <- getCCFlavour cc_name+    env <- ask+    let+      cc_mod = lateCCEnv_module env+      cc = NormalCC cc_flavour cc_name cc_mod cc_loc+      note = ProfNote cc (lateCCEnv_countEntries env) True+    when (lateCCEnv_collectCCs env) $ do+        lift . modify $ \s ->+          s { lateCCState_ccs = S.insert cc (lateCCState_ccs s)+            }+    return $ mkTick note expr+
GHC/Core/Lint.hs view
@@ -1,3485 +1,4017 @@-{-# LANGUAGE DeriveFunctor       #-}-{-# LANGUAGE MultiWayIf          #-}-{-# 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 (-    lintCoreBindings, lintUnfolding,-    lintPassResult, lintInteractiveExpr, lintExpr,-    lintAnnots, lintAxioms,--    interactiveInScope,--    -- ** Debug output-    endPass, endPassIO,-    displayLintResults, dumpPassResult- ) where--import GHC.Prelude--import GHC.Driver.Session-import GHC.Driver.Ppr-import GHC.Driver.Env-import GHC.Driver.Config.Diagnostic--import GHC.Tc.Utils.TcType ( isFloatingPrimTy, isTyFamFree )-import GHC.Unit.Module.ModGuts-import GHC.Runtime.Context--import GHC.Core-import GHC.Core.FVs-import GHC.Core.Utils-import GHC.Core.Stats ( coreBindsStats )-import GHC.Core.Opt.Monad-import GHC.Core.DataCon-import GHC.Core.Ppr-import GHC.Core.Coercion-import GHC.Core.Type as Type-import GHC.Core.Multiplicity-import GHC.Core.UsageEnv-import GHC.Core.TyCo.Rep   -- checks validity of types/coercions-import GHC.Core.TyCo.Subst-import GHC.Core.TyCo.FVs-import GHC.Core.TyCo.Ppr ( pprTyVar, pprTyVars )-import GHC.Core.TyCon as TyCon-import GHC.Core.Coercion.Axiom-import GHC.Core.Unify-import GHC.Core.InstEnv      ( instanceDFunId, instEnvElts )-import GHC.Core.Coercion.Opt ( checkAxInstCo )-import GHC.Core.Opt.Arity    ( typeArity )--import GHC.Types.Literal-import GHC.Types.Var as Var-import GHC.Types.Var.Env-import GHC.Types.Var.Set-import GHC.Types.Unique.Set( nonDetEltsUniqSet )-import GHC.Types.Name-import GHC.Types.Name.Env-import GHC.Types.Id-import GHC.Types.Id.Info-import GHC.Types.SrcLoc-import GHC.Types.Tickish-import GHC.Types.RepType-import GHC.Types.Basic-import GHC.Types.Demand      ( splitDmdSig, isDeadEndDiv )-import GHC.Types.TypeEnv--import GHC.Builtin.Names-import GHC.Builtin.Types.Prim-import GHC.Builtin.Types ( multiplicityTy )--import GHC.Data.Bag-import GHC.Data.List.SetOps--import GHC.Utils.Monad-import GHC.Utils.Outputable as Outputable-import GHC.Utils.Panic-import GHC.Utils.Constants (debugIsOn)-import GHC.Utils.Misc-import GHC.Utils.Trace-import GHC.Utils.Error-import qualified GHC.Utils.Error as Err-import GHC.Utils.Logger--import Control.Monad-import Data.Foldable      ( toList )-import Data.List.NonEmpty ( NonEmpty(..), groupWith )-import Data.List          ( partition )-import Data.Maybe-import GHC.Data.Pair-import qualified GHC.LanguageExtensions as LangExt--{--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]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-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 Bool in-        let x::a = True in <body>-That is, use a type let.  See Note [Core type and coercion invariant] in "GHC.Core".-One place it is used is in mkWwBodies; see Note [Join points and beta-redexes]-in GHC.Core.Opt.WorkWrap.Utils.  (Maybe there are other "clients" of this feature; I'm not sure).--* Hence when linting <body> we need to remember that a=Int, else we-  might reject a correct program.  So we carry a type substitution (in-  this example [a -> Bool]) and apply this substitution before-  comparing types. In effect, in Lint, type equality is always-  equality-modulo-le-subst.  This is in the le_subst field of-  LintEnv.  But nota bene:--  (SI1) The le_subst substitution is applied to types and coercions only--  (SI2) The result of that substitution is used only to check for type-        equality, to check well-typed-ness, /but is then discarded/.-        The result of substittion 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).--************************************************************************-*                                                                      *-                 Beginning and ending passes-*                                                                      *-************************************************************************--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-       ; 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 logger dump_core_sizes print_unqual mb_flag-                        (showSDoc dflags (ppr pass)) (pprPassDetails pass) binds rules-       ; lintPassResult hsc_env pass binds }-  where-    dump_core_sizes = not (gopt Opt_SuppressCoreSizes dflags)-    logger  = hsc_logger hsc_env-    dflags  = hsc_dflags hsc_env-    mb_flag = case coreDumpFlag pass of-                Just flag | logHasDumpFlag logger flag                    -> Just flag-                          | logHasDumpFlag logger Opt_D_verbose_core2core -> Just flag-                _ -> Nothing--dumpPassResult :: Logger-               -> Bool                  -- dump core sizes?-               -> PrintUnqualified-               -> 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 unqual mb_flag hdr extra_info binds rules-  = do { forM_ mb_flag $ \flag -> do-           logDumpFile logger (mkDumpStyle unqual) flag hdr FormatCore dump_doc--         -- Report result size-         -- This has the side effect of forcing the intermediate to be evaluated-         -- if it's not already forced by a -ddump flag.-       ; Err.debugTraceMsg logger 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 ]--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 CoreDoExitify            = Just Opt_D_dump_exitify-coreDumpFlag CoreDoDemand             = Just Opt_D_dump_stranal-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-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 CoreAddLateCcs           = Just Opt_D_dump_late_cc--coreDumpFlag CoreAddCallerCcs         = Nothing-coreDumpFlag CoreOccurAnal            = Nothing-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_and_errs = lintCoreBindings dflags pass (interactiveInScope $ hsc_IC hsc_env) binds-       ; Err.showPass logger ("Core Linted result of " ++ showPpr dflags pass)-       ; displayLintResults logger (showLintWarnings pass) (ppr pass)-                            (pprCoreBindings binds) warns_and_errs }-  where-    dflags = hsc_dflags hsc_env-    logger = hsc_logger hsc_env--displayLintResults :: Logger-                   -> 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.MCDump noSrcSpan-           $ withPprStyle defaultDumpStyle-           (vcat [ lint_banner "errors" pp_what, Err.pprMessageBag errs-                 , text "*** Offending Program ***"-                 , pp_pgm-                 , text "*** End of Offense ***" ])-       ; Err.ghcExit logger 1 }--  | not (isEmptyBag warns)-  , log_enable_debug (logFlags logger)-  , display_warnings-  -- If the Core linter encounters an error, output to stderr instead of-  -- stdout (#13342)-  = logMsg logger Err.MCInfo noSrcSpan-      $ 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 "***"--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 :: SDoc -- ^ The source of the linted expression-                    -> HscEnv -> CoreExpr -> IO ()-lintInteractiveExpr what hsc_env expr-  | not (gopt Opt_DoCoreLinting dflags)-  = return ()-  | Just err <- lintExpr 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--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)---- | Type-check a 'CoreProgram'. See Note [Core Lint guarantee].-lintCoreBindings :: DynFlags -> CoreToDo -> [Var] -> CoreProgram -> WarnsAndErrs---   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 local_in_scope $-    addLoc TopLevelBindings           $-    do { checkL (null dups) (dupVars dups)-       ; checkL (null ext_dups) (dupExtVars ext_dups)-       ; 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--    flags = (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 }--    -- In the output of the desugarer, before optimisation,-    -- we have eta-expanded data constructors with representation-polymorphic-    -- bindings; so we switch off the representation-polymorphism checks.-    -- The very simple optimiser will beta-reduce them away.-    -- See Note [Checking for representation-polymorphic built-ins]-    -- in GHC.HsToCore.Expr.-    check_fixed_rep = case pass of-                        CoreDesugar -> False-                        _           -> True--    -- See Note [Checking for global Ids]-    check_globals = case pass of-                      CoreTidy -> False-                      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)--    (_, dups) = removeDups compare binders--    -- dups_ext 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 (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--{--************************************************************************-*                                                                      *-\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-              -> DynFlags-              -> SrcLoc-              -> VarSet           -- ^ Treat these as in scope-              -> CoreExpr-              -> Maybe (Bag SDoc) -- Nothing => OK--lintUnfolding is_compulsory dflags locn var_set expr-  | isEmptyBag errs = Nothing-  | otherwise       = Just errs-  where-    vars = nonDetEltsUniqSet var_set-    (_warns, errs) = initL dflags (defaultLintFlags dflags) vars $-                     if is_compulsory-                       -- See Note [Checking for representation polymorphism]-                     then noFixedRuntimeRepChecks linter-                     else linter-    linter = addLoc (ImportedUnfolding locn) $-             lintCoreExpr expr--lintExpr :: DynFlags-         -> [Var]               -- Treat these as in scope-         -> CoreExpr-         -> Maybe (Bag SDoc)  -- Nothing => OK--lintExpr dflags vars expr-  | isEmptyBag errs = Nothing-  | otherwise       = Just errs-  where-    (_warns, errs) = initL dflags (defaultLintFlags dflags) vars 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)]-                -> ([LintedId] -> 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 :: [LintedId] -> CoreExpr -> LintM (LintedType, UsageEnv)-lintLetBody bndrs body-  = do { (body_ty, body_ue) <- addLoc (BodyOfLetRec bndrs) (lintCoreExpr body)-       ; mapM_ (lintJoinBndrType body_ty) bndrs-       ; return (body_ty, body_ue) }--lintLetBind :: TopLevelFlag -> RecFlag -> LintedId-              -> CoreExpr -> LintedType -> 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/app invariant-        -- See Note [Core let/app 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 isJoinId_maybe binder of-            Nothing    -> return ()-            Just 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 [exprArity invariant]-       -- and Note [Trimming arity]-       ; checkL (typeArity (idType binder) `lengthAtLeast` idArity binder)-           (text "idArity" <+> ppr (idArity binder) <+>-           text "exceeds typeArity" <+>-           ppr (length (typeArity (idType binder))) <> colon <+>-           ppr binder)--       ; case splitDmdSig (idDmdSig binder) of-           (demands, result_info) | isDeadEndDiv result_info ->-             checkL (demands `lengthAtLeast` idArity binder)-               (text "idArity" <+> ppr (idArity binder) <+>-               text "exceeds arity imposed by the strictness signature" <+>-               ppr (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 (LintedType, UsageEnv)--- NB: the Id can be Linted or not -- it's only used for---     its OccInfo and join-pointer-hood-lintRhs bndr rhs-    | Just arity <- isJoinId_maybe 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 (LintedType, 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.--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)----************************************************************************-*                                                                      *-\subsection[lintCoreExpr]{lintCoreExpr}-*                                                                      *-************************************************************************--}---- Linted things: substitution applied, and type is linted-type LintedType     = Type-type LintedKind     = Kind-type LintedCoercion = Coercion-type LintedTyCoVar  = TyCoVar-type LintedId       = Id---- | Lint an expression cast through the given coercion, returning the type--- resulting from the cast.-lintCastExpr :: CoreExpr -> LintedType -> Coercion -> LintM LintedType-lintCastExpr expr expr_ty co-  = do { co' <- lintCoercion co-       ; let (Pair from_ty to_ty, role) = coercionKindRole co'-       ; checkValueType to_ty $-         text "target of cast" <+> quotes (ppr co')-       ; lintRole co' Representational role-       ; ensureEqTys from_ty expr_ty (mkCastErr expr co' from_ty expr_ty)-       ; return to_ty }--lintCoreExpr :: CoreExpr -> LintM (LintedType, 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-      checkCanEtaExpand (Var var) [] var_ty-      return var_pair--lintCoreExpr (Lit lit)-  = return (literalType lit, zeroUE)--lintCoreExpr (Cast expr co)-  = do (expr_ty, ue) <- markAllJoinsBad   $ lintCoreExpr expr-       to_ty <- lintCastExpr expr expr_ty co-       return (to_ty, ue)--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' <- lintType ty-        ; lintTyBndr 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 (BodyOfLetRec [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 [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 bndrs' body-        ; return (body_type, body_ue  `addUE` scaleUE Many (foldr1 addUE ues)) }-  where-    bndrs = map fst pairs--lintCoreExpr e@(App _ _)-  | Var fun <- fun-  , fun `hasKey` runRWKey-    -- N.B. we may have an over-saturated application of the form:-    --   runRW (\s -> \x -> ...) y-  , ty_arg1 : ty_arg2 : arg3 : rest <- args-  = do { fun_pair1 <- lintCoreArg (idType fun, zeroUE) ty_arg1-       ; (fun_ty2, ue2) <- lintCoreArg fun_pair1       ty_arg2-         -- See Note [Linting of runRW#]-       ; let lintRunRWCont :: CoreArg -> LintM (LintedType, UsageEnv)-             lintRunRWCont expr@(Lam _ _) =-                lintJoinLams 1 (Just fun) expr-             lintRunRWCont other = markAllJoinsBad $ lintCoreExpr other-             -- TODO: Look through ticks?-       ; (arg3_ty, ue3) <- lintRunRWCont arg3-       ; app_ty <- lintValApp arg3 fun_ty2 arg3_ty ue2 ue3-       ; lintCoreArgs app_ty rest }--  | otherwise-  = do { fun_pair <- lintCoreFun fun (length args)-       ; app_pair@(app_ty, _) <- lintCoreArgs fun_pair args-       ; checkCanEtaExpand fun args app_ty-       ; return app_pair}-  where-    (fun, args, _source_ticks) = collectArgsTicks tickishFloatable e-      -- We must look through source ticks to avoid #21152, for example:-      ---      -- reallyUnsafePtrEquality-      --   = \ @a ->-      --       (src<loc> reallyUnsafePtrEquality#)-      --         @Lifted @a @Lifted @a-      ---      -- To do this, we use `collectArgsTicks tickishFloatable` to match-      -- the eta expansion behaviour, as per Note [Eta expansion and source notes]-      -- in GHC.Core.Opt.Arity.--lintCoreExpr (Lam var expr)-  = markAllJoinsBad $-    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--- lintCoreArgs-lintCoreExpr (Type ty)-  = failWithL (text "Type found as expression" <+> ppr ty)--lintCoreExpr (Coercion co)-  = do { co' <- addLoc (InCo co) $-                lintCoercion co-       ; return (coercionType co', zeroUE) }-------------------------lintIdOcc :: Var -> Int -- Number of arguments (type or value) being passed-           -> LintM (LintedType, UsageEnv) -- returns type of the *variable*-lintIdOcc var nargs-  = addLoc (OccOf var) $-    do  { checkL (isNonCoVarId var)-                 (text "Non term variable" <+> ppr var)-                 -- 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-        ; (bndr, linted_bndr_ty) <- lookupIdInScope var-        ; let occ_ty  = idType var-              bndr_ty = idType bndr-        ; ensureEqTys occ_ty bndr_ty $-          mkBndrOccTypeMismatchMsg bndr var bndr_ty occ_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--        ; usage <- varCallSiteUsage var--        ; return (linted_bndr_ty, usage) }--lintCoreFun :: CoreExpr-            -> Int                          -- Number of arguments (type or val) being passed-            -> LintM (LintedType, 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 :: LintedType -- Type of the body-                 -> LintedId   -- 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-  | Just arity <- isJoinId_maybe 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-  | 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-                      do { join_set <- getValidJoins-                         ; addErrL (text "join set " <+> ppr join_set $$-                                    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 ()---- | This function checks that we are able to perform eta expansion for--- functions with no binding, in order to satisfy invariant I3--- from Note [Representation polymorphism invariants] in GHC.Core.-checkCanEtaExpand :: CoreExpr   -- ^ the function (head of the application) we are checking-                  -> [CoreArg]  -- ^ the arguments to the application-                  -> LintedType -- ^ the instantiated type of the overall application-                  -> LintM ()-checkCanEtaExpand (Var fun_id) args app_ty-  | hasNoBinding fun_id-  = checkL (null bad_arg_tys) err_msg-    where-      arity :: Arity-      arity = idArity fun_id--      nb_val_args :: Int-      nb_val_args = count isValArg args--      -- Check the remaining argument types, past the-      -- given arguments and up to the arity of the 'Id'.-      -- Returns the types that couldn't be determined to have-      -- a fixed RuntimeRep.-      check_args :: [Type] -> [Type]-      check_args = go (nb_val_args + 1)-        where-          go :: Int    -- index of the argument (starting from 1)-             -> [Type] -- arguments-             -> [Type] -- value argument types that could not be-                       -- determined to have a fixed runtime representation-          go i _-            | i > arity-            = []-          go _ []-            -- The Arity of an Id should never exceed the number of value arguments-            -- that can be read off from the Id's type.-            -- See Note [Arity and function types] in GHC.Types.Id.Info.-            = pprPanic "checkCanEtaExpand: arity larger than number of value arguments apparent in type"-                $ vcat-                  [ text "fun_id =" <+> ppr fun_id-                  , text "arity =" <+> ppr arity-                  , text "app_ty =" <+> ppr app_ty-                  , text "args = " <+> ppr args-                  , text "nb_val_args =" <+> ppr nb_val_args ]-          go i (ty : bndrs)-            | typeHasFixedRuntimeRep ty-            = go (i+1) bndrs-            | otherwise-            = ty : go (i+1) bndrs--      bad_arg_tys :: [Type]-      bad_arg_tys = check_args . map fst $ getRuntimeArgTys app_ty-        -- We use 'getRuntimeArgTys' to find all the argument types,-        -- including those hidden under newtypes. For example,-        -- if `FunNT a b` is a newtype around `a -> b`, then-        -- when checking-        ---        -- foo :: forall r (a :: TYPE r) (b :: TYPE r) c. a -> FunNT b c-        ---        -- we should check that the instantiations of BOTH `a` AND `b`-        -- have a fixed runtime representation.--      err_msg :: SDoc-      err_msg-        = vcat [ text "Cannot eta expand" <+> quotes (ppr fun_id)-               , text "The following type" <> plural bad_arg_tys-                 <+> doOrDoes bad_arg_tys <+> text "not have a fixed runtime representation:"-               , nest 2 $ vcat $ map ppr_ty_ki bad_arg_tys ]--      ppr_ty_ki :: Type -> SDoc-      ppr_ty_ki ty = bullet <+> ppr ty <+> dcolon <+> ppr (typeKind ty)-checkCanEtaExpand _ _ _-  = return ()---- Check that the usage of var is consistent with var itself, and pop the var--- from the usage environment (this is important because of shadowing).-checkLinearity :: UsageEnv -> Var -> LintM UsageEnv-checkLinearity body_ue lam_var =-  case varMultMaybe lam_var of-    Just mult -> do ensureSubUsage lhs mult (err_msg mult)-                    return $ deleteUE body_ue lam_var-    Nothing    -> return body_ue -- A type variable-  where-    lhs = lookupUE body_ue lam_var-    err_msg mult = text "Linearity failure in lambda:" <+> ppr lam_var-                $$ ppr lhs <+> text "⊈" <+> ppr mult--{--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.--}---lintCoreArgs  :: (LintedType, UsageEnv) -> [CoreArg] -> LintM (LintedType, UsageEnv)-lintCoreArgs (fun_ty, fun_ue) args = foldM lintCoreArg (fun_ty, fun_ue) args--lintCoreArg  :: (LintedType, UsageEnv) -> CoreArg -> LintM (LintedType, UsageEnv)-lintCoreArg (fun_ty, ue) (Type arg_ty)-  = do { checkL (not (isCoercionTy arg_ty))-                (text "Unnecessary coercion-to-type injection:"-                  <+> ppr arg_ty)-       ; arg_ty' <- lintType arg_ty-       ; res <- lintTyApp fun_ty arg_ty'-       ; return (res, ue) }--lintCoreArg (fun_ty, fun_ue) arg-  = 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)))--            ; checkL (mightBeLiftedType arg_ty || exprOkForSpeculation arg)-                     (mkLetAppMsg arg) }--       ; lintValApp arg fun_ty arg_ty fun_ue arg_ue }--------------------lintAltBinders :: UsageEnv-               -> Var         -- Case binder-               -> LintedType     -- Scrutinee type-               -> LintedType     -- 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) (varMult 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 = varMult case_bndr-    case_bndr_usage = lookupUE ue case_bndr-    bndr_usage = lookupUE ue bndr----------------------lintTyApp :: LintedType -> LintedType -> LintM LintedType-lintTyApp fun_ty arg_ty-  | Just (tv,body_ty) <- splitForAllTyCoVar_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 -> LintedType -> LintedType -> UsageEnv -> UsageEnv -> LintM (LintedType, UsageEnv)-lintValApp arg fun_ty arg_ty fun_ue arg_ue-  | Just (w, arg_ty', res_ty') <- splitFunTy_maybe fun_ty-  = do { ensureEqTys arg_ty' arg_ty (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 -> LintedType -> 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 -> Id -> Type -> [CoreAlt] -> LintM (LintedType, UsageEnv)-lintCaseExpr scrut var alt_ty alts =-  do { let e = Case scrut var 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-     ; let scrut_mult = varMult var--     ; alt_ty <- addLoc (CaseTy scrut) $-                 lintValueType alt_ty-     ; var_ty <- addLoc (IdTy var) $-                 lintValueType (idType var)--     -- 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.--     -- 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-     ; let isLitPat (Alt (LitAlt _) _  _) = True-           isLitPat _                     = False-     ; checkL (not $ isFloatingPrimTy scrut_ty && any isLitPat alts)-         (text "Lint warning: Scrutinising floating-point expression with literal pattern in case analysis (see #9238)."-          $$ text "scrut" <+> ppr scrut)--     ; case tyConAppTyCon_maybe (idType var) of-         Just tycon-              | debugIsOn-              , isAlgTyCon tycon-              , not (isAbstractTyCon tycon)-              , null (tyConDataCons tycon)-              , not (exprIsDeadEnd scrut)-              -> 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)-       -- See GHC.Core Note [Case expression invariants] item (7)--     ; lintBinder CaseBind var $ \_ ->-       do { -- Check the alternatives-          ; alt_ues <- mapM (lintCoreAlt var scrut_ty scrut_mult alt_ty) alts-          ; let case_ue = (scaleUE scrut_mult scrut_ue) `addUE` supUEs alt_ues-          ; checkCaseAlts e scrut_ty alts-          ; return (alt_ty, case_ue) } }--checkCaseAlts :: CoreExpr -> LintedType -> [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)-         -- 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) }-  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_infinite_ty = case tyConAppTyCon_maybe ty of-                        Nothing    -> False-                        Just tycon -> isPrimTyCon tycon--lintAltExpr :: CoreExpr -> LintedType -> 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 :: Var              -- Case binder-            -> LintedType       -- Type of scrutinee-            -> Mult             -- Multiplicity of scrutinee-            -> LintedType       -- 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 _ _ _ alt_ty (Alt DEFAULT args rhs) =-  do { lintL (null args) (mkDefaultArgsMsg args)-     ; lintAltExpr rhs alt_ty }--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)-       ; lintAltExpr rhs alt_ty }-  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-    {   -- 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-          ; binderMult (Named _)   = Many-          ; 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 "lintCoreAlt" 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 :: 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-  | isTyCoVar var = lintTyCoBndr var linterF-  | otherwise     = lintIdBndr NotTopLevel site var linterF--lintTyBndr :: TyVar -> (LintedTyCoVar -> LintM a) -> LintM a-lintTyBndr = lintTyCoBndr  -- We could specialise it, I guess---- lintCoBndr :: CoVar -> (LintedTyCoVar -> LintM a) -> LintM a--- lintCoBndr = lintTyCoBndr  -- We could specialise it, I guess--lintTyCoBndr :: TyCoVar -> (LintedTyCoVar -> LintM a) -> LintM a-lintTyCoBndr tcv thing_inside-  = do { subst <- getTCvSubst-       ; kind' <- lintType (varType tcv)-       ; let tcv' = uniqAway (getTCvInScope subst) $-                    setVarType tcv kind'-             subst' = extendTCvSubstWithClone subst tcv tcv'-       ; when (isCoVar tcv) $-         lintL (isCoVarType kind')-               (text "CoVar with non-coercion type:" <+> pprTyVar tcv)-       ; updateTCvSubst subst' (thing_inside tcv') }--lintIdBndrs :: forall a. TopLevelFlag -> [Id] -> ([LintedId] -> 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.")--       ; linted_ty <- addLoc (IdTy id) (lintValueType id_ty)--       ; addInScopeId id linted_ty $-         thing_inside (setIdType id linted_ty) }-  where-    id_ty = idType id--    is_top_lvl = isTopLevel top_lvl-    is_let_bind = case bind_site of-                    LetBind -> True-                    _       -> False--{--%************************************************************************-%*                                                                      *-             Types-%*                                                                      *-%************************************************************************--}--lintValueType :: Type -> LintM LintedType--- 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' <- lintType ty-        ; let sk = typeKind ty'-        ; lintL (classifiesTypeWithValues 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)----------------------lintType :: Type -> LintM LintedType---- 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 { subst <- getTCvSubst-       ; case lookupTyVar subst tv of-           Just linted_ty -> return linted_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-           Nothing | tv `isInScope` subst-                   -> return (TyVarTy tv)-                   | otherwise-                   -> failWithL $-                      hang (text "The type variable" <+> pprBndr LetBind tv)-                         2 (text "is out of scope")-     }--lintType ty@(AppTy t1 t2)-  | TyConApp {} <- t1-  = failWithL $ text "TyConApp to the left of AppTy:" <+> ppr ty-  | otherwise-  = do { t1' <- lintType t1-       ; t2' <- lintType t2-       ; lint_ty_app ty (typeKind t1') [t2']-       ; return (AppTy t1' t2') }--lintType ty@(TyConApp tc tys)-  | isTypeSynonymTyCon tc || isTypeFamilyTyCon tc-  = do { report_unsat <- lf_report_unsat_syns <$> getLintFlags-       ; lintTySynFamApp report_unsat ty tc tys }--  | isFunTyCon tc-  , tys `lengthIs` 5-    -- 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].-  = failWithL (hang (text "Saturated application of (->)") 2 (ppr ty))--  | otherwise  -- Data types, data families, primitive types-  = do { checkTyCon tc-       ; tys' <- mapM lintType tys-       ; lint_ty_app ty (tyConKind tc) tys'-       ; return (TyConApp 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 { t1' <- lintType t1-       ; t2' <- lintType t2-       ; tw' <- lintType tw-       ; lintArrow (text "type or kind" <+> quotes (ppr ty)) t1' t2' tw'-       ; return (FunTy af tw' t1' t2') }--lintType ty@(ForAllTy (Bndr tcv vis) body_ty)-  | not (isTyCoVar tcv)-  = failWithL (text "Non-Tyvar or Non-Covar bound in type:" <+> ppr ty)-  | otherwise-  = lintTyCoBndr tcv $ \tcv' ->-    do { body_ty' <- lintType body_ty-       ; lintForAllBody tcv' body_ty'--       ; when (isCoVar tcv) $-         lintL (tcv `elemVarSet` tyCoVarsOfType body_ty) $-         text "Covar does not occur in the body:" <+> (ppr tcv $$ ppr body_ty)-         -- See GHC.Core.TyCo.Rep Note [Unused coercion variable in ForAllTy]-         -- and cf GHC.Core.Coercion Note [Unused coercion variable in ForAllCo]--       ; return (ForAllTy (Bndr tcv' vis) body_ty') }--lintType ty@(LitTy l)-  = do { lintTyLit l; return ty }--lintType (CastTy ty co)-  = do { ty' <- lintType ty-       ; co' <- lintStarCoercion co-       ; let tyk = typeKind ty'-             cok = coercionLKind co'-       ; ensureEqTys tyk cok (mkCastTyErr ty co tyk cok)-       ; return (CastTy ty' co') }--lintType (CoercionTy co)-  = do { co' <- lintCoercion co-       ; return (CoercionTy co') }--------------------lintForAllBody :: LintedTyCoVar -> LintedType -> LintM ()--- Do the checks for the body of a forall-type-lintForAllBody tcv body_ty-  = do { checkValueType body_ty (text "the body of forall:" <+> ppr body_ty)--         -- 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-       ; let body_kind = typeKind body_ty-       ; when (isTyVar tcv) $-         case occCheckExpand [tcv] body_kind of-           Just {} -> return ()-           Nothing -> failWithL $-                      hang (text "Variable escape in forall:")-                         2 (vcat [ text "tyvar:" <+> ppr tcv-                                 , text "type:" <+> ppr body_ty-                                 , text "kind:" <+> ppr body_kind ])-    }--------------------lintTySynFamApp :: Bool -> InType -> TyCon -> [InType] -> LintM LintedType--- 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-  | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc tys-  , let expanded_ty = mkAppTys (substTy (mkTvSubstPrs tenv) rhs) tys'-  = do { -- Kind-check the argument types, but without reporting-         -- un-saturated type families/synonyms-         tys' <- setReportUnsat False (mapM lintType tys)--       ; when report_unsat $-         do { _ <- lintType expanded_ty-            ; return () }--       ; lint_ty_app ty (tyConKind tc) tys'-       ; return (TyConApp tc tys') }--  -- Otherwise this must be a type family-  | otherwise-  = do { tys' <- mapM lintType tys-       ; lint_ty_app ty (tyConKind tc) tys'-       ; return (TyConApp tc tys') }---------------------- Confirms that a type is really TYPE r or Constraint-checkValueType :: LintedType -> SDoc -> LintM ()-checkValueType ty doc-  = lintL (classifiesTypeWithValues kind)-          (text "Non-Type-like kind when Type-like expected:" <+> ppr kind $$-           text "when checking" <+> doc)-  where-    kind = typeKind ty--------------------lintArrow :: SDoc -> LintedType -> LintedType -> LintedType -> LintM ()--- If you edit this function, you may need to update the GHC formalism--- See Note [GHC Formalism]-lintArrow what t1 t2 tw  -- Eg lintArrow "type or kind `blah'" k1 k2 kw-                         -- or lintArrow "coercion `blah'" k1 k2 kw-  = do { unless (classifiesTypeWithValues k1) (addErrL (msg (text "argument") k1))-       ; unless (classifiesTypeWithValues k2) (addErrL (msg (text "result")   k2))-       ; unless (isMultiplicityTy kw) (addErrL (msg (text "multiplicity") kw)) }-  where-    k1 = typeKind t1-    k2 = typeKind t2-    kw = typeKind tw-    msg ar k-      = vcat [ hang (text "Ill-kinded" <+> ar)-                  2 (text "in" <+> what)-             , what <+> text "kind:" <+> ppr k ]--------------------lint_ty_app :: Type -> LintedKind -> [LintedType] -> LintM ()-lint_ty_app ty k tys-  = lint_app (text "type" <+> quotes (ppr ty)) k tys-------------------lint_co_app :: Coercion -> LintedKind -> [LintedType] -> LintM ()-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 ()-lintTyLit (CharTyLit _) = return ()--lint_app :: SDoc -> LintedKind -> [LintedType] -> LintM ()--- (lint_app d fun_kind arg_tys)---    We have an application (f arg_ty1 .. arg_tyn),---    where f :: fun_kind---- If you edit this function, you may need to update the GHC formalism--- See Note [GHC Formalism]-lint_app doc kfn arg_tys-    = do { in_scope <- getInScope-         -- We need the in_scope set to satisfy the invariant in-         -- Note [The substitution invariant] in GHC.Core.TyCo.Subst-         ; _ <- foldlM (go_app in_scope) kfn arg_tys-         ; return () }-  where-    fail_msg extra = vcat [ hang (text "Kind application error in") 2 doc-                          , nest 2 (text "Function kind =" <+> ppr kfn)-                          , nest 2 (text "Arg types =" <+> ppr arg_tys)-                          , extra ]--    go_app in_scope kfn ta-      | Just kfn' <- coreView kfn-      = go_app in_scope kfn' ta--    go_app _ fun_kind@(FunTy _ _ kfa kfb) ta-      = do { let ka = typeKind ta-           ; unless (ka `eqType` kfa) $-             addErrL (fail_msg (text "Fun:" <+> (ppr fun_kind $$ ppr ta <+> dcolon <+> ppr ka)))-           ; return kfb }--    go_app in_scope (ForAllTy (Bndr kv _vis) kfn) ta-      = do { let kv_kind = varType kv-                 ka      = typeKind ta-           ; unless (ka `eqType` kv_kind) $-             addErrL (fail_msg (text "Forall:" <+> (ppr kv $$ ppr kv_kind $$-                                                    ppr ta <+> dcolon <+> ppr ka)))-           ; return $ substTy (extendTCvSubst (mkEmptyTCvSubst in_scope) kv ta) kfn }--    go_app _ kfn ta-       = failWithL (fail_msg (text "Not a fun:" <+> (ppr kfn $$ ppr ta)))--{- *********************************************************************-*                                                                      *-        Linting rules-*                                                                      *-********************************************************************* -}--lintCoreRule :: OutVar -> LintedType -> 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 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-                            , 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-* NthCo (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.--}----- lints a coercion, confirming that its lh kind and its rh kind are both *--- also ensures that the role is Nominal-lintStarCoercion :: InCoercion -> LintM LintedCoercion-lintStarCoercion g-  = do { g' <- lintCoercion g-       ; let Pair t1 t2 = coercionKind g'-       ; checkValueType t1 (text "the kind of the left type in" <+> ppr g)-       ; checkValueType t2 (text "the kind of the right type in" <+> ppr g)-       ; lintRole g Nominal (coercionRole g)-       ; return g' }--lintCoercion :: InCoercion -> LintM LintedCoercion--- 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-  = do { subst <- getTCvSubst-       ; case lookupCoVar subst cv of-           Just linted_co -> return linted_co ;-           Nothing-              | cv `isInScope` subst-                   -> return (CoVarCo cv)-              | otherwise-                   ->-                      -- lintCoBndr always extends the substitition-                      failWithL $-                      hang (text "The coercion variable" <+> pprBndr LetBind cv)-                         2 (text "is out of scope")-     }---lintCoercion (Refl ty)-  = do { ty' <- lintType ty-       ; return (Refl ty') }--lintCoercion (GRefl r ty MRefl)-  = do { ty' <- lintType ty-       ; return (GRefl r ty' MRefl) }--lintCoercion (GRefl r ty (MCo co))-  = do { ty' <- lintType ty-       ; co' <- lintCoercion co-       ; let tk = typeKind ty'-             tl = 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')-       ; return (GRefl r ty' (MCo co')) }--lintCoercion co@(TyConAppCo r tc cos)-  | tc `hasKey` funTyConKey-  , [_w, _rep1,_rep2,_co1,_co2] <- cos-  = 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-       ; cos' <- mapM lintCoercion cos-       ; let (co_kinds, co_roles) = unzip (map coercionKindRole cos')-       ; lint_co_app co (tyConKind tc) (map pFst co_kinds)-       ; lint_co_app co (tyConKind tc) (map pSnd co_kinds)-       ; zipWithM_ (lintRole co) (tyConRolesX r tc) co_roles-       ; return (TyConAppCo r tc 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 { co1' <- lintCoercion co1-       ; co2' <- lintCoercion co2-       ; let (Pair lk1 rk1, r1) = coercionKindRole co1'-             (Pair lk2 rk2, r2) = coercionKindRole co2'-       ; lint_co_app co (typeKind lk1) [lk2]-       ; lint_co_app co (typeKind rk1) [rk2]--       ; 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 (AppCo co1' co2') }-------------lintCoercion co@(ForAllCo tcv kind_co body_co)-  | not (isTyCoVar tcv)-  = failWithL (text "Non tyco binder in ForAllCo:" <+> ppr co)-  | otherwise-  = do { kind_co' <- lintStarCoercion kind_co-       ; lintTyCoBndr tcv $ \tcv' ->-    do { body_co' <- lintCoercion body_co-       ; ensureEqTys (varType tcv') (coercionLKind kind_co') $-         text "Kind mis-match in ForallCo" <+> ppr co--       -- Assuming kind_co :: k1 ~ k2-       -- Need to check that-       --    (forall (tcv:k1). lty) and-       --    (forall (tcv:k2). rty[(tcv:k2) |> sym kind_co/tcv])-       -- are both well formed.  Easiest way is to call lintForAllBody-       -- for each; there is actually no need to do the funky substitution-       ; let Pair lty rty = coercionKind body_co'-       ; lintForAllBody tcv' lty-       ; lintForAllBody tcv' rty--       ; when (isCoVar tcv) $-         lintL (almostDevoidCoVarOfCo tcv body_co) $-         text "Covar can only appear in Refl and GRefl: " <+> ppr co-         -- See "last wrinkle" in GHC.Core.Coercion-         -- Note [Unused coercion variable in ForAllCo]-         -- and c.f. GHC.Core.TyCo.Rep Note [Unused coercion variable in ForAllTy]--       ; return (ForAllCo tcv' kind_co' body_co') } }--lintCoercion co@(FunCo r cow co1 co2)-  = do { co1' <- lintCoercion co1-       ; co2' <- lintCoercion co2-       ; cow' <- lintCoercion cow-       ; let Pair lt1 rt1 = coercionKind co1-             Pair lt2 rt2 = coercionKind co2-             Pair ltw rtw = coercionKind cow-       ; lintArrow (text "coercion" <+> quotes (ppr co)) lt1 lt2 ltw-       ; lintArrow (text "coercion" <+> quotes (ppr co)) rt1 rt2 rtw-       ; lintRole co1 r (coercionRole co1)-       ; lintRole co2 r (coercionRole co2)-       ; ensureEqTys (typeKind ltw) multiplicityTy (text "coercion" <> quotes (ppr co))-       ; ensureEqTys (typeKind rtw) multiplicityTy (text "coercion" <> quotes (ppr co))-       ; let expected_mult_role = case r of-                                    Phantom -> Phantom-                                    _ -> Nominal-       ; lintRole cow expected_mult_role (coercionRole cow)-       ; return (FunCo r cow' co1' co2') }---- See Note [Bad unsafe coercion]-lintCoercion co@(UnivCo prov r ty1 ty2)-  = do { ty1' <- lintType ty1-       ; ty2' <- lintType ty2-       ; let k1 = typeKind ty1'-             k2 = typeKind ty2'-       ; prov' <- lint_prov k1 k2 prov--       ; when (r /= Phantom && classifiesTypeWithValues k1-                            && classifiesTypeWithValues k2)-              (checkTypes ty1 ty2)--       ; return (UnivCo prov' r ty1' ty2') }-   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-       | allow_ill_kinded_univ_co prov-       = return ()  -- Skip kind checks-       | otherwise-       = 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--     -- CorePrep deliberately makes ill-kinded casts-     --  e.g (case error @Int "blah" of {}) :: Int#-     --     ==> (error @Int "blah") |> Unsafe Int Int#-     -- See Note [Unsafe coercions] in GHC.Core.CoreToStg.Prep-     allow_ill_kinded_univ_co (CorePrepProv homo_kind) = not homo_kind-     allow_ill_kinded_univ_co _                        = False--     validateCoercion :: PrimRep -> PrimRep -> LintM ()-     validateCoercion rep1 rep2-       = do { platform <- targetPlatform <$> getDynFlags-            ; 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 ()-            }--     lint_prov k1 k2 (PhantomProv kco)-       = do { kco' <- lintStarCoercion kco-            ; lintRole co Phantom r-            ; check_kinds kco' k1 k2-            ; return (PhantomProv kco') }--     lint_prov k1 k2 (ProofIrrelProv kco)-       = do { lintL (isCoercionTy ty1) (mkBadProofIrrelMsg ty1 co)-            ; lintL (isCoercionTy ty2) (mkBadProofIrrelMsg ty2 co)-            ; kco' <- lintStarCoercion kco-            ; check_kinds kco k1 k2-            ; return (ProofIrrelProv kco') }--     lint_prov _ _ prov@(PluginProv _)   = return prov-     lint_prov _ _ prov@(CorePrepProv _) = return prov--     check_kinds kco k1 k2-       = do { let Pair k1' k2' = coercionKind kco-            ; ensureEqTys k1 k1' (mkBadUnivCoMsg CLeft  co)-            ; ensureEqTys k2 k2' (mkBadUnivCoMsg CRight co) }---lintCoercion (SymCo co)-  = do { co' <- lintCoercion co-       ; return (SymCo co') }--lintCoercion co@(TransCo co1 co2)-  = do { co1' <- lintCoercion co1-       ; co2' <- lintCoercion co2-       ; let ty1b = coercionRKind co1'-             ty2a = coercionLKind co2'-       ; ensureEqTys ty1b ty2a-               (hang (text "Trans coercion mis-match:" <+> ppr co)-                   2 (vcat [ppr (coercionKind co1'), ppr (coercionKind co2')]))-       ; lintRole co (coercionRole co1) (coercionRole co2)-       ; return (TransCo co1' co2') }--lintCoercion the_co@(NthCo r0 n co)-  = do { co' <- lintCoercion co-       ; let (Pair s t, r) = coercionKindRole co'-       ; case (splitForAllTyCoVar_maybe s, splitForAllTyCoVar_maybe t) of-         { (Just _, Just _)-             -- works for both tyvar and covar-             | n == 0-             ,  (isForAllTy_ty s && isForAllTy_ty t)-             || (isForAllTy_co s && isForAllTy_co t)-             -> do { lintRole the_co Nominal r0-                   ; return (NthCo r0 n co') }--         ; _ -> 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 GHC.Core.TyCo.Rep-             , tys_s `equalLength` tys_t-             , tys_s `lengthExceeds` n-             -> do { lintRole the_co tr r0-                   ; return (NthCo r0 n co') }-                where-                  tr = nthRole r tc_s n--         ; _ -> failWithL (hang (text "Bad getNth:")-                              2 (ppr the_co $$ ppr s $$ ppr t)) }}}--lintCoercion the_co@(LRCo lr co)-  = do { co' <- lintCoercion co-       ; let Pair s t = coercionKind co'-             r        = coercionRole co'-       ; lintRole co Nominal r-       ; case (splitAppTy_maybe s, splitAppTy_maybe t) of-           (Just _, Just _) -> return (LRCo lr co')-           _ -> failWithL (hang (text "Bad LRCo:")-                              2 (ppr the_co $$ ppr s $$ ppr t)) }--lintCoercion (InstCo co arg)-  = do { co'  <- lintCoercion co-       ; arg' <- lintCoercion arg-       ; let Pair t1 t2 = coercionKind co'-             Pair s1 s2 = coercionKind arg'--       ; lintRole arg Nominal (coercionRole arg')--      ; case (splitForAllTyVar_maybe t1, splitForAllTyVar_maybe t2) of-         -- forall over tvar-         { (Just (tv1,_), Just (tv2,_))-             | typeKind s1 `eqType` tyVarKind tv1-             , typeKind s2 `eqType` tyVarKind tv2-             -> return (InstCo co' arg')-             | otherwise-             -> failWithL (text "Kind mis-match in inst coercion1" <+> ppr co)--         ; _ -> case (splitForAllCoVar_maybe t1, splitForAllCoVar_maybe t2) of-         -- forall over covar-         { (Just (cv1, _), Just (cv2, _))-             | typeKind s1 `eqType` varType cv1-             , typeKind s2 `eqType` varType cv2-             , CoercionTy _ <- s1-             , CoercionTy _ <- s2-             -> return (InstCo co' arg')-             | otherwise-             -> failWithL (text "Kind mis-match in inst coercion2" <+> ppr co)--         ; _ -> 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 } = coAxiomNthBranch con ind-       ; unless (cos `equalLength` (ktvs ++ cvs)) $-           bad_ax (text "lengths")-       ; cos' <- mapM lintCoercion cos-       ; subst <- getTCvSubst-       ; let empty_subst = zapTCvSubst subst-       ; _ <- foldlM check_ki (empty_subst, empty_subst)-                              (zip3 (ktvs ++ cvs) roles cos')-       ; let fam_tc = coAxiomTyCon con-       ; case checkAxInstCo co of-           Just bad_branch -> bad_ax $ text "inconsistent with" <+>-                                       pprCoAxBranch fam_tc bad_branch-           Nothing -> return ()-       ; return (AxiomInstCo con ind cos') }-  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 { let Pair s' t' = coercionKind arg'-                 sk' = typeKind s'-                 tk' = typeKind t'-           ; lintRole arg' role (coercionRole arg')-           ; let ktv_kind_l = substTy subst_l (tyVarKind ktv)-                 ktv_kind_r = substTy subst_r (tyVarKind ktv)-           ; unless (sk' `eqType` ktv_kind_l)-                    (bad_ax (text "check_ki1" <+> vcat [ ppr co, ppr sk', ppr ktv, ppr ktv_kind_l ] ))-           ; unless (tk' `eqType` ktv_kind_r)-                    (bad_ax (text "check_ki2" <+> vcat [ ppr co, ppr tk', ppr ktv, ppr ktv_kind_r ] ))-           ; return (extendTCvSubst subst_l ktv s',-                     extendTCvSubst subst_r ktv t') }--lintCoercion (KindCo co)-  = do { co' <- lintCoercion co-       ; return (KindCo co') }--lintCoercion (SubCo co')-  = do { co' <- lintCoercion co'-       ; lintRole co' Nominal (coercionRole co')-       ; return (SubCo co') }--lintCoercion this@(AxiomRuleCo ax cos)-  = do { cos' <- mapM lintCoercion cos-       ; lint_roles 0 (coaxrAsmpRoles ax) cos'-       ; case coaxrProves ax (map coercionKind cos') of-           Nothing -> err "Malformed use of AxiomRuleCo" [ ppr this ]-           Just _  -> return (AxiomRuleCo ax cos') }-  where-  err :: forall a. String -> [SDoc] -> LintM a-  err m xs  = failWithL $-              hang (text m) 2 $ vcat (text "Rule:" <+> ppr (coaxrName 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 (HoleCo h)-  = do { addErrL $ text "Unfilled coercion hole:" <+> ppr h-       ; lintCoercion (CoVarCo (coHoleCoVar h)) }--{--************************************************************************-*                                                                      *-              Axioms-*                                                                      *-************************************************************************--}--lintAxioms :: Logger-           -> DynFlags-           -> SDoc -- ^ The source of the linted axioms-           -> [CoAxiom Branched]-           -> IO ()-lintAxioms logger dflags what axioms =-  displayLintResults logger True what (vcat $ map pprCoAxiom axioms) $-  initL dflags (defaultLintFlags dflags) [] $-  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     = 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")-           ; let ax_lhs = mkInfForAllTys tvs $-                          mkTyConApp tc lhs_tys-                 nt_tvs = takeList tvs (tyConTyVars tc)-                    -- axiom may be eta-reduced: Note [Newtype eta] in GHC.Core.TyCon-                 nt_lhs = mkInfForAllTys nt_tvs $-                          mkTyConApp tc (mkTyVarTys nt_tvs)-                 -- See Note [Newtype eta] in GHC.Core.TyCon-           ; lintL (ax_lhs `eqType` nt_lhs)-                   (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` 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-       ; lhs' <- lintType lhs-       ; rhs' <- lintType rhs-       ; let lhs_kind = typeKind lhs'-             rhs_kind = typeKind rhs'-       ; lintL (lhs_kind `eqType` rhs_kind) $-         hang (text "Inhomogeneous axiom")-            2 (text "lhs:" <+> ppr lhs <+> dcolon <+> ppr lhs_kind $$-               text "rhs:" <+> ppr rhs <+> dcolon <+> ppr rhs_kind) }---- 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 (compatible_branches br br')) $-           text "Incorrect incompatible branch:" <+> 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 (compatible_branches 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)--compatible_branches :: CoAxBranch -> CoAxBranch -> Bool--- True <=> branches are compatible. See Note [Compatibility] in GHC.Core.FamInstEnv.-compatible_branches (CoAxBranch { cab_tvs = tvs1-                                , cab_lhs = lhs1-                                , cab_rhs = rhs1 })-                    (CoAxBranch { cab_tvs = tvs2-                                , cab_lhs = lhs2-                                , cab_rhs = rhs2 })-  = -- we need to freshen ax2 w.r.t. ax1-    -- do this by pretending tvs1 are in scope when processing tvs2-    let in_scope       = mkInScopeSet (mkVarSet tvs1)-        subst0         = mkEmptyTCvSubst in_scope-        (subst, _)     = substTyVarBndrs subst0 tvs2-        lhs2'          = substTys subst lhs2-        rhs2'          = substTy  subst rhs2-    in-    case tcUnifyTys alwaysBindFun lhs1 lhs2' of-      Just unifying_subst -> substTy unifying_subst rhs1  `eqType`-                             substTy unifying_subst rhs2'-      Nothing             -> True--{--************************************************************************-*                                                                      *-\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 TyCo substitution-                               --    See Note [Linting type lets]-            -- /Only/ substitutes for type variables;-            --        but might clone CoVars-            -- We also use le_subst to keep track of-            -- in-scope TyVars and CoVars (but not Ids)-            -- Range of the TCvSubst is LintedType/LintedCo--       , le_ids   :: VarEnv (Id, LintedType)    -- In-scope Ids-            -- Used to check that occurrences have an enclosing binder.-            -- The Id is /pre-substitution/, used to check that-            -- the occurrence has an identical type to the binder-            -- The LintedType is used to return the type of the occurrence,-            -- without having to lint it again.--       , le_joins :: IdSet     -- Join points in scope that are valid-                               -- A subset of the InScopeSet in le_subst-                               -- See Note [Join points]--       , le_dynflags :: DynFlags     -- DynamicFlags-       , le_ue_aliases :: NameEnv UsageEnv -- Assigns usage environments to the-                                           -- alias-like binders, as found in-                                           -- non-recursive lets.-       }--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--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-                             }--newtype LintM a =-   LintM { unLintM ::-            LintEnv ->-            WarnsAndErrs ->           -- Warning and error messages so far-            (Maybe a, WarnsAndErrs) } -- Result and messages (if any)-   deriving (Functor)--type WarnsAndErrs = (Bag SDoc, Bag SDoc)--{- 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]-~~~~~~~~~~~~~~~~~~~~~~~~-There is one known optimisations that have not yet been updated-to work with Linear Lint:--* 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.-  Plan: make let-bound variables remember the usage environment.-  See ticket #18694.--We plan to fix this issue in the very near future.-For now, -dcore-lint enables only linting output of the desugarer,-and full Linear Lint has to be enabled separately with -dlinear-core-lint.-Ticket #19165 concerns enabling Linear Lint with -dcore-lint.--Note [checkCanEtaExpand]-~~~~~~~~~~~~~~~~~~~~~~~~-The checkCanEtaExpand function is responsible for enforcing invariant I3-from Note [Representation polymorphism invariants] in GHC.Core: in any-partial application `f e_1 .. e_n`, if `f` has no binding, we must be able to-eta expand `f` to match the declared arity of `f`.--Wrinkle 1: eta-expansion and newtypes--  Most of the time, when we have a partial application `f e_1 .. e_n`-  in which `f` is `hasNoBinding`, we eta-expand it up to its arity-  as follows:--    \ x_{n+1} ... x_arity -> f e_1 .. e_n x_{n+1} ... x_arity--  However, we might need to insert casts if some of the arguments-  that `f` takes are under a newtype.-  For example, suppose `f` `hasNoBinding`, has arity 1 and type--    f :: forall r (a :: TYPE r). Identity (a -> a)--  then we eta-expand the nullary application `f` to--    ( \ x -> f x ) |> co--  where--    co :: ( forall r (a :: TYPE r). a -> a ) ~# ( forall r (a :: TYPE r). Identity (a -> a) )--  In this case we would have to perform a representation-polymorphism check on the instantiation-  of `a`.--Wrinkle 2: 'hasNoBinding' and laziness--  It's important that we able to compute 'hasNoBinding' for an 'Id' without ever forcing-  the unfolding of the 'Id'. Otherwise, we could end up with a loop, as outlined in-    Note [Lazily checking Unfoldings] in GHC.IfaceToCore.--}--instance Applicative LintM where-      pure x = LintM $ \ _ errs -> (Just x, errs)-      (<*>) = ap--instance Monad LintM where-  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'))--instance MonadFail LintM where-    fail err = failWithL (text err)--instance HasDynFlags LintM where-  getDynFlags = LintM (\ e errs -> (Just (le_dynflags 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-  | BodyOfLetRec [Id]   -- One of the binders-  | 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--initL :: DynFlags-      -> LintFlags-      -> [Var]              -- ^ 'Id's that should be treated as being in scope-      -> LintM a            -- ^ Action to run-      -> WarnsAndErrs-initL dflags flags vars m-  = case unLintM m env (emptyBag, emptyBag) of-      (Just _, errs) -> errs-      (Nothing, errs@(_, e)) | not (isEmptyBag e) -> errs-                             | otherwise -> pprPanic ("Bug in Lint: a failure occurred " ++-                                                      "without reporting an error message") empty-  where-    (tcvs, ids) = partition isTyCoVar vars-    env = LE { le_flags = flags-             , le_subst = mkEmptyTCvSubst (mkInScopeSet (mkVarSet tcvs))-             , le_ids   = mkVarEnv [(id, (id,idType id)) | id <- ids]-             , le_joins = emptyVarSet-             , le_loc = []-             , le_dynflags = dflags-             , le_ue_aliases = emptyNameEnv }--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 -> (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) ->-                (Nothing, (warns, addMsg True env errs msg))--addErrL :: SDoc -> LintM ()-addErrL msg = LintM $ \ env (warns,errs) ->-              (Just (), (warns, addMsg True env errs msg))--addWarnL :: SDoc -> LintM ()-addWarnL msg = LintM $ \ env (warns,errs) ->-              (Just (), (addMsg False env warns msg, errs))--addMsg :: Bool -> LintEnv ->  Bag SDoc -> SDoc -> Bag SDoc-addMsg is_error 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 | is_error  = 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 = initDiagOpts (le_dynflags env)-   mk_msg msg = mkLocMessage (mkMCDiagnostic diag_opts WarningWithoutFlag) 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 -> (Just (is_case_pat env), errs)-  where-    is_case_pat (LE { le_loc = CasePat {} : _ }) = True-    is_case_pat _other                           = False--addInScopeId :: Id -> LintedType -> LintM a -> LintM a-addInScopeId id linted_ty m-  = LintM $ \ env@(LE { le_ids = id_set, le_joins = join_set }) errs ->-    unLintM m (env { le_ids   = extendVarEnv id_set id (id, linted_ty)-                   , le_joins = add_joins join_set }) errs-  where-    add_joins join_set-      | isJoinId id = extendVarSet join_set id -- Overwrite with new arity-      | otherwise   = delVarSet    join_set id -- Remove any existing binding--getInScopeIds :: LintM (VarEnv (Id,LintedType))-getInScopeIds = LintM (\env errs -> (Just (le_ids 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--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--getValidJoins :: LintM IdSet-getValidJoins = LintM (\ env errs -> (Just (le_joins env), errs))--getTCvSubst :: LintM TCvSubst-getTCvSubst = LintM (\ env errs -> (Just (le_subst env), errs))--getUEAliases :: LintM (NameEnv UsageEnv)-getUEAliases = LintM (\ env errs -> (Just (le_ue_aliases env), errs))--getInScope :: LintM InScopeSet-getInScope = LintM (\ env errs -> (Just (getTCvInScope $ le_subst env), errs))--lookupIdInScope :: Id -> LintM (Id, LintedType)-lookupIdInScope id_occ-  = do { in_scope_ids <- getInScopeIds-       ; case lookupVarEnv in_scope_ids id_occ of-           Just (id_bndr, linted_ty)-             -> do { checkL (not (bad_global id_bndr)) global_in_scope-                   ; return (id_bndr, linted_ty) }-           Nothing -> do { checkL (not is_local) local_out_of_scope-                         ; return (id_occ, idType id_occ) } }-                      -- We don't bother to lint the type-                      -- of global (i.e. imported) Ids-  where-    is_local = mustHaveLocalBinding id_occ-    local_out_of_scope = text "Out of scope:" <+> pprBndr LetBind id_occ-    global_in_scope    = hang (text "Occurrence is GlobalId, but binding is LocalId")-                            2 (pprBndr LetBind id_occ)-    bad_global id_bnd = isGlobalId id_occ-                     && isLocalId id_bnd-                     && not (isWiredIn id_occ)-       -- '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--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 }--addAliasUE :: Id -> 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 :: Id -> LintM UsageEnv-varCallSiteUsage id =-  do m <- getUEAliases-     return $ case lookupNameEnv m (getName id) of-         Nothing -> unitUE id One-         Just id_ue -> id_ue--ensureEqTys :: LintedType -> LintedType -> 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-ensureEqTys ty1 ty2 msg = lintL (ty1 `eqType` ty2) msg--ensureSubUsage :: Usage -> Mult -> SDoc -> LintM ()-ensureSubUsage Bottom     _              _ = return ()-ensureSubUsage Zero       described_mult err_msg = ensureSubMult Many described_mult err_msg-ensureSubUsage (MUsage m) described_mult err_msg = ensureSubMult m described_mult err_msg--ensureSubMult :: Mult -> Mult -> SDoc -> LintM ()-ensureSubMult actual_usage described_usage err_msg = do-    flags <- getLintFlags-    when (lf_check_linearity flags) $ case actual_usage' `submult` described_usage' of-      Submult -> return ()-      Unknown -> case isMultMul actual_usage' of-                     Just (m1, m2) -> ensureSubMult m1 described_usage' err_msg >>-                                      ensureSubMult m2 described_usage' err_msg-                     Nothing -> when (not (actual_usage' `eqType` described_usage')) (addErrL err_msg)--   where actual_usage' = normalize actual_usage-         described_usage' = normalize described_usage--         normalize :: Mult -> Mult-         normalize m = case isMultMul m of-                         Just (m1, m2) -> mkMultMul (normalize m1) (normalize m2)-                         Nothing -> m--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 (BodyOfLetRec [])-  = (noSrcLoc, text "In body of a letrec with no binders")--dumpLoc (BodyOfLetRec bs@(_:_))-  = ( getSrcLoc (head bs), text "In the body of 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_name, text "In the coercion axiom" <+> ppr ax_name <+> dcolon <+> pp_ax)-  where-    CoAxiom { co_ax_name     = ax_name-            , co_ax_tc       = tc-            , co_ax_role     = ax_role-            , co_ax_branches = branches } = ax-    branch_list = fromBranches branches--    pp_ax-      | [branch] <- branch_list-      = pp_branch branch--      | otherwise-      = braces $ vcat (map pp_branch branch_list)--    pp_branch (CoAxBranch { cab_tvs = tvs-                          , cab_cvs = cvs-                          , cab_lhs = lhs_tys-                          , cab_rhs = rhs_ty })-      = sep [ brackets (pprWithCommas pprTyVar (tvs ++ cvs)) <> dot-            , ppr (mkTyConApp tc lhs_tys)-            , text "~_" <> pp_role ax_role-            , ppr rhs_ty ]--    pp_role Nominal          = text "N"-    pp_role Representational = text "R"-    pp_role Phantom          = text "P"--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 -> TCvSubst -> SDoc-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 -> 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 :: Type -> Type -> SDoc-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 -> 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]]--mkLetAppMsg :: CoreExpr -> SDoc-mkLetAppMsg e-  = hang (text "This argument does not satisfy the let/app invariant:")-       2 (ppr e)--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--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 -> 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 :: Var -> Var -> LintedType -> LintedType -> SDoc-mkBndrOccTypeMismatchMsg bndr var bndr_ty var_ty-  = vcat [ text "Mismatch in type between binder and occurrence"-         , text "Binder:" <+> ppr bndr <+> dcolon <+> ppr bndr_ty-         , text "Occurrence:" <+> ppr var <+> dcolon <+> 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 -> SDoc-pprLeftOrRight CLeft  = text "left"-pprLeftOrRight CRight = text "right"--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"-  nguts <- pass guts-  -- If appropriate re-run it without debug annotations to make sure-  -- that they made no difference.-  when (gopt Opt_DoAnnotationLinting dflags) $ do-    liftIO $ Err.showPass logger "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 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 = hscSetFlags (dflags { debugLevel = 0}) env-      withoutFlag corem =-          -- TODO: supply tag here as well ?-        liftIO =<< runCoreM <$> fmap removeFlag getHscEnv <*> getRuleBase <*>-                                getUniqMask <*> 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)+{-# LANGUAGE MultiWayIf          #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE UnboxedTuples #-}++{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1993-1998+++A ``lint'' pass to check for Core correctness.+See Note [Core Lint guarantee].+-}++module GHC.Core.Lint (+    LintPassResultConfig (..),+    LintFlags (..),+    StaticPtrCheck (..),+    LintConfig (..),+    WarnsAndErrs,++    lintCoreBindings', lintUnfolding,+    lintPassResult, lintExpr,+    lintAnnots, lintAxioms,++    -- ** Debug output+    EndPassConfig (..),+    endPassIO,+    displayLintResults, dumpPassResult+ ) where++import GHC.Prelude++import GHC.Driver.DynFlags++import GHC.Tc.Utils.TcType+  ( ConcreteTvOrigin(..), ConcreteTyVars+  , isFloatingPrimTy, isTyFamFree )+import GHC.Tc.Types.Origin+  ( FixedRuntimeRepOrigin(..) )+import GHC.Unit.Module.ModGuts+import GHC.Platform++import GHC.Core+import GHC.Core.FVs+import GHC.Core.Utils+import GHC.Core.Stats ( coreBindsStats )+import GHC.Core.DataCon+import GHC.Core.Ppr+import GHC.Core.Coercion+import GHC.Core.Type as Type+import GHC.Core.Predicate( isCoVarType )+import GHC.Core.Multiplicity+import GHC.Core.UsageEnv+import GHC.Core.TyCo.Rep   -- checks validity of types/coercions+import GHC.Core.TyCo.Compare ( eqType, eqTypes, eqTypeIgnoringMultiplicity, eqForAllVis )+import GHC.Core.TyCo.Subst+import GHC.Core.TyCo.FVs+import GHC.Core.TyCo.Ppr+import GHC.Core.TyCon as TyCon+import GHC.Core.Coercion.Axiom+import GHC.Core.FamInstEnv( compatibleBranches )+import GHC.Core.Unify+import GHC.Core.Opt.Arity    ( typeArity, exprIsDeadEnd )++import GHC.Core.Opt.Monad++import GHC.Types.Literal+import GHC.Types.Var as Var+import GHC.Types.Var.Env+import GHC.Types.Var.Set+import GHC.Types.Name+import GHC.Types.Name.Env+import GHC.Types.Id+import GHC.Types.Id.Info+import GHC.Types.SrcLoc+import GHC.Types.Tickish+import GHC.Types.Unique.FM ( isNullUFM, sizeUFM )+import GHC.Types.RepType+import GHC.Types.Basic+import GHC.Types.Demand      ( splitDmdSig, isDeadEndDiv )++import GHC.Builtin.Names+import GHC.Builtin.Types.Prim++import GHC.Data.Bag+import GHC.Data.List.SetOps++import GHC.Utils.Monad+import GHC.Utils.Outputable as Outputable+import GHC.Utils.Panic+import GHC.Utils.Constants (debugIsOn)+import GHC.Utils.Misc+import GHC.Utils.Error+import qualified GHC.Utils.Error as Err+import GHC.Utils.Logger++import GHC.Data.Pair+import GHC.Base (oneShot)+import GHC.Data.Unboxed++import Control.Monad+import Data.Foldable      ( for_, toList )+import Data.List.NonEmpty ( NonEmpty(..), groupWith, nonEmpty )+import Data.Maybe+import Data.IntMap.Strict ( IntMap )+import qualified Data.IntMap.Strict as IntMap ( lookup, keys, empty, fromList )++{-+Note [Core Lint guarantee]+~~~~~~~~~~~~~~~~~~~~~~~~~~+Core Lint is the type-checker for Core. Using it, we get the following guarantee:++If all of:+1. Core Lint passes,+2. there are no unsafe coercions (i.e. unsafeEqualityProof),+3. all plugin-supplied coercions (i.e. PluginProv) are valid, and+4. all case-matches are complete+then running the compiled program will not seg-fault, assuming no bugs downstream+(e.g. in the code generator). This guarantee is quite powerful, in that it allows us+to decouple the safety of the resulting program from the type inference algorithm.++However, do note point (4) above. Core Lint does not check for incomplete case-matches;+see Note [Case expression invariants] in GHC.Core, invariant (4). As explained there,+an incomplete case-match might slip by Core Lint and cause trouble at runtime.++Note [GHC Formalism]+~~~~~~~~~~~~~~~~~~~~+This file implements the type-checking algorithm for System FC, the "official"+name of the Core language. Type safety of FC is heart of the claim that+executables produced by GHC do not have segmentation faults. Thus, it is+useful to be able to reason about System FC independently of reading the code.+To this purpose, there is a document core-spec.pdf built in docs/core-spec that+contains a formalism of the types and functions dealt with here. If you change+just about anything in this file or you change other types/functions throughout+the Core language (all signposted to this note), you should update that+formalism. See docs/core-spec/README for more info about how to do so.++Note [check vs lint]+~~~~~~~~~~~~~~~~~~~~+This file implements both a type checking algorithm and also general sanity+checking. For example, the "sanity checking" checks for TyConApp on the left+of an AppTy, which should never happen. These sanity checks don't really+affect any notion of type soundness. Yet, it is convenient to do the sanity+checks at the same time as the type checks. So, we use the following naming+convention:++- Functions that begin with 'lint'... are involved in type checking. These+  functions might also do some sanity checking.++- Functions that begin with 'check'... are *not* involved in type checking.+  They exist only for sanity checking.++Issues surrounding variable naming, shadowing, and such are considered *not*+to be part of type checking, as the formalism omits these details.++Summary of checks+~~~~~~~~~~~~~~~~~+Checks that a set of core bindings is well-formed.  The PprStyle and String+just control what we print in the event of an error.  The Bool value+indicates whether we have done any specialisation yet (in which case we do+some extra checks).++We check for+        (a) type errors+        (b) Out-of-scope type variables+        (c) Out-of-scope local variables+        (d) Ill-kinded types+        (e) Incorrect unsafe coercions++If we have done specialisation the we check that there are+        (a) No top-level bindings of primitive (unboxed type)++Note [Linting function types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+All saturated applications of funTyCon are represented with the FunTy constructor.+See Note [Function type constructors and FunTy] in GHC.Builtin.Types.Prim++ We check this invariant in lintType.++Note [Linting type lets]+~~~~~~~~~~~~~~~~~~~~~~~~+In the desugarer, it's very very convenient to be able to say (in effect)+        let a = Type Bool in+        let x::a = True in <body>+That is, use a type let.  See Note [Core type and coercion invariant] in "GHC.Core".+One place it is used is in mkWwBodies; see Note [Join points and beta-redexes]+in GHC.Core.Opt.WorkWrap.Utils.  (Maybe there are other "clients" of this feature; I'm not sure).++* Hence when linting <body> we need to remember that a=Int, else we+  might reject a correct program.  So we carry a type substitution (in+  this example [a -> Bool]) and apply this substitution before+  comparing types. In effect, in Lint, type equality is always+  equality-modulo-le-subst.  This is in the le_subst field of+  LintEnv.  But nota bene:++  (SI1) The le_subst substitution is applied to types and coercions only++  (SI2) The result of that substitution is used only to check for type+        equality, to check well-typed-ness, /but is then discarded/.+        The result of substitution does not outlive the CoreLint pass.++  (SI3) The InScopeSet of le_subst includes only TyVar and CoVar binders.++* The function+        lintInTy :: Type -> LintM (Type, Kind)+  returns a substituted type.++* When we encounter a binder (like x::a) we must apply the substitution+  to the type of the binding variable.  lintBinders does this.++* Clearly we need to clone tyvar binders as we go.++* But take care (#17590)! We must also clone CoVar binders:+    let a = TYPE (ty |> cv)+    in \cv -> blah+  blindly substituting for `a` might capture `cv`.++* Alas, when cloning a coercion variable we might choose a unique+  that happens to clash with an inner Id, thus+      \cv_66 -> let wild_X7 = blah in blah+  We decide to clone `cv_66` because it's already in scope.  Fine,+  choose a new unique.  Aha, X7 looks good.  So we check the lambda+  body with le_subst of [cv_66 :-> cv_X7]++  This is all fine, even though we use the same unique as wild_X7.+  As (SI2) says, we do /not/ return a new lambda+     (\cv_X7 -> let wild_X7 = blah in ...)+  We simply use the le_subst substitution in types/coercions only, when+  checking for equality.++* We still need to check that Id occurrences are bound by some+  enclosing binding.  We do /not/ use the InScopeSet for the le_subst+  for this purpose -- it contains only TyCoVars.  Instead we have a separate+  le_ids for the in-scope Id binders.++Sigh.  We might want to explore getting rid of type-let!++Note [Bad unsafe coercion]+~~~~~~~~~~~~~~~~~~~~~~~~~~+For discussion see https://gitlab.haskell.org/ghc/ghc/wikis/bad-unsafe-coercions+Linter introduces additional rules that checks improper coercion between+different types, called bad coercions. Following coercions are forbidden:++  (a) coercions between boxed and unboxed values;+  (b) coercions between unlifted values of the different sizes, here+      active size is checked, i.e. size of the actual value but not+      the space allocated for value;+  (c) coercions between floating and integral boxed values, this check+      is not yet supported for unboxed tuples, as no semantics were+      specified for that;+  (d) coercions from / to vector type+  (e) If types are unboxed tuples then tuple (# A_1,..,A_n #) can be+      coerced to (# B_1,..,B_m #) if n=m and for each pair A_i, B_i rules+      (a-e) holds.++Note [Join points]+~~~~~~~~~~~~~~~~~~+We check the rules listed in Note [Invariants on join points] in GHC.Core. The+only one that causes any difficulty is the first: All occurrences must be tail+calls. To this end, along with the in-scope set, we remember in le_joins the+subset of in-scope Ids that are valid join ids. For example:++  join j x = ... in+  case e of+    A -> jump j y -- good+    B -> case (jump j z) of -- BAD+           C -> join h = jump j w in ... -- good+           D -> let x = jump j v in ... -- BAD++A join point remains valid in case branches, so when checking the A+branch, j is still valid. When we check the scrutinee of the inner+case, however, we set le_joins to empty, and catch the+error. Similarly, join points can occur free in RHSes of other join+points but not the RHSes of value bindings (thunks and functions).++Note [Avoiding compiler perf traps when constructing error messages.]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It's quite common to put error messages into a where clause when it might+be triggered by multiple branches. E.g.++  checkThing x y z =+    case x of+      X -> unless (correctX x) $ failWithL errMsg+      Y -> unless (correctY y) $ failWithL errMsg+    where+      errMsg = text "My error involving:" $$ ppr x <+> ppr y++However ghc will compile this to:++  checkThink x y z =+    let errMsg = text "My error involving:" $$ ppr x <+> ppr y+    in case x of+      X -> unless (correctX x) $ failWithL errMsg+      Y -> unless (correctY y) $ failWithL errMsg++Putting the allocation of errMsg into the common non-error path.+One way to work around this is to turn errMsg into a function:++  checkThink x y z =+    case x of+      X -> unless (correctX x) $ failWithL (errMsg x y)+      Y -> unless (correctY y) $ failWithL (errMsg x y)+    where+      errMsg x y = text "My error involving:" $$ ppr x <+> ppr y++This way `errMsg` is a static function and it being defined in the common+path does not result in allocation in the hot path. This can be surprisingly+impactful. Changing `lint_app` reduced allocations for one test program I was+looking at by ~4%.++Note [MCInfo for Lint]+~~~~~~~~~~~~~~~~~~~~~~+When printing a Lint message, use the MCInfo severity so that the+message is printed on stderr rather than stdout (#13342).++************************************************************************+*                                                                      *+                 Beginning and ending passes+*                                                                      *+************************************************************************+-}++-- | Configuration for boilerplate operations at the end of a+-- compilation pass producing Core.+data EndPassConfig = EndPassConfig+  { ep_dumpCoreSizes :: !Bool+  -- ^ Whether core bindings should be dumped with the size of what they+  -- are binding (i.e. the size of the RHS of the binding).++  , ep_lintPassResult :: !(Maybe LintPassResultConfig)+  -- ^ Whether we should lint the result of this pass.++  , ep_namePprCtx :: !NamePprCtx++  , ep_dumpFlag :: !(Maybe DumpFlag)++  , ep_prettyPass :: !SDoc++  , ep_passDetails :: !SDoc+  }++endPassIO :: Logger+          -> EndPassConfig+          -> CoreProgram -> [CoreRule]+          -> IO ()+-- Used by the IO-is CorePrep too+endPassIO logger cfg binds rules+  = do { dumpPassResult logger (ep_dumpCoreSizes cfg) (ep_namePprCtx cfg) mb_flag+                        (renderWithContext defaultSDocContext (ep_prettyPass cfg))+                        (ep_passDetails cfg) binds rules+       ; for_ (ep_lintPassResult cfg) $ \lp_cfg ->+           lintPassResult logger lp_cfg binds+       }+  where+    mb_flag = case ep_dumpFlag cfg of+                Just flag | logHasDumpFlag logger flag                    -> Just flag+                          | logHasDumpFlag logger Opt_D_verbose_core2core -> Just flag+                _ -> Nothing++dumpPassResult :: Logger+               -> Bool                  -- dump core sizes?+               -> NamePprCtx+               -> Maybe DumpFlag        -- Just df => show details in a file whose+                                        --            name is specified by df+               -> String                -- Header+               -> SDoc                  -- Extra info to appear after header+               -> CoreProgram -> [CoreRule]+               -> IO ()+dumpPassResult logger dump_core_sizes name_ppr_ctx mb_flag hdr extra_info binds rules+  = do { forM_ mb_flag $ \flag -> do+           logDumpFile logger (mkDumpStyle name_ppr_ctx) flag hdr FormatCore dump_doc++         -- Report result size+         -- This has the side effect of forcing the intermediate to be evaluated+         -- if it's not already forced by a -ddump flag.+       ; Err.debugTraceMsg logger 2 size_doc+       }++  where+    size_doc = sep [text "Result size of" <+> text hdr, nest 2 (equals <+> ppr (coreBindsStats binds))]++    dump_doc  = vcat [ nest 2 extra_info+                     , size_doc+                     , blankLine+                     , if dump_core_sizes+                        then pprCoreBindingsWithSize binds+                        else pprCoreBindings         binds+                     , ppUnless (null rules) pp_rules ]+    pp_rules = vcat [ blankLine+                    , text "------ Local rules for imported ids --------"+                    , pprRules rules ]++{-+************************************************************************+*                                                                      *+                 Top-level interfaces+*                                                                      *+************************************************************************+-}++data LintPassResultConfig = LintPassResultConfig+  { lpr_diagOpts         :: !DiagOpts+  , lpr_platform         :: !Platform+  , lpr_makeLintFlags    :: !LintFlags+  , lpr_showLintWarnings :: !Bool+  , lpr_passPpr          :: !SDoc+  , lpr_localsInScope    :: ![Var]+  }++lintPassResult :: Logger -> LintPassResultConfig+               -> CoreProgram -> IO ()+lintPassResult logger cfg binds+  = do { let warns_and_errs = lintCoreBindings'+               (LintConfig+                { l_diagOpts = lpr_diagOpts cfg+                , l_platform = lpr_platform cfg+                , l_flags    = lpr_makeLintFlags cfg+                , l_vars     = lpr_localsInScope cfg+                })+               binds+       ; Err.showPass logger $+           "Core Linted result of " +++           renderWithContext defaultSDocContext (lpr_passPpr cfg)+       ; displayLintResults logger+                            (lpr_showLintWarnings cfg) (lpr_passPpr cfg)+                            (pprCoreBindings binds) warns_and_errs+       }++displayLintResults :: Logger+                   -> Bool -- ^ If 'True', display linter warnings.+                           --   If 'False', ignore linter warnings.+                   -> SDoc -- ^ The source of the linted program+                   -> SDoc -- ^ The linted program, pretty-printed+                   -> WarnsAndErrs+                   -> IO ()+displayLintResults logger display_warnings pp_what pp_pgm (warns, errs)+  | not (isEmptyBag errs)+  = do { logMsg logger Err.MCInfo noSrcSpan  -- See Note [MCInfo for Lint]+           $ withPprStyle defaultDumpStyle+           (vcat [ lint_banner "errors" pp_what, Err.pprMessageBag errs+                 , text "*** Offending Program ***"+                 , pp_pgm+                 , text "*** End of Offense ***" ])+       ; Err.ghcExit logger 1 }++  | not (isEmptyBag warns)+  , log_enable_debug (logFlags logger)+  , display_warnings+  = logMsg logger Err.MCInfo noSrcSpan  -- See Note [MCInfo for Lint]+      $ withPprStyle defaultDumpStyle+        (lint_banner "warnings" pp_what $$ Err.pprMessageBag (mapBag ($$ blankLine) warns))++  | otherwise = return ()++lint_banner :: String -> SDoc -> SDoc+lint_banner string pass = text "*** Core Lint"      <+> text string+                          <+> text ": in result of" <+> pass+                          <+> text "***"++-- | Type-check a 'CoreProgram'. See Note [Core Lint guarantee].+lintCoreBindings' :: LintConfig -> CoreProgram -> WarnsAndErrs+--   Returns (warnings, errors)+-- If you edit this function, you may need to update the GHC formalism+-- See Note [GHC Formalism]+lintCoreBindings' cfg binds+  = initL cfg $+    addLoc TopLevelBindings           $+    do { -- Check that all top-level binders are distinct+         -- We do not allow  [NonRec x=1, NonRec y=x, NonRec x=2]+         -- because of glomming; see Note [Glomming] in GHC.Core.Opt.OccurAnal+         checkL (null dups) (dupVars dups)++         -- Check for External top level binders with the same M.n name+       ; checkL (null ext_dups) (dupExtVars ext_dups)++         -- Typecheck the bindings+       ; lintRecBindings TopLevel all_pairs $ \_ ->+         return () }+  where+    all_pairs = flattenBinds binds+     -- Put all the top-level binders in scope at the start+     -- This is because rewrite rules can bring something+     -- into use 'unexpectedly'; see Note [Glomming] in "GHC.Core.Opt.OccurAnal"+    binders = map fst all_pairs++    (_, dups) = removeDups compare binders++    -- ext_dups checks for names with different uniques+    -- but the same External name M.n.  We don't+    -- allow this at top level:+    --    M.n{r3}  = ...+    --    M.n{r29} = ...+    -- because they both get the same linker symbol+    ext_dups = snd $ removeDupsOn ord_ext $+               filter isExternalName $ map Var.varName binders+    ord_ext n = (nameModule n, nameOccName n)++{-+************************************************************************+*                                                                      *+\subsection[lintUnfolding]{lintUnfolding}+*                                                                      *+************************************************************************++Note [Linting Unfoldings from Interfaces]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We use this to check all top-level unfoldings that come in from interfaces+(it is very painful to catch errors otherwise).++We do not need to call lintUnfolding on unfoldings that are nested within+top-level unfoldings; they are linted when we lint the top-level unfolding;+hence the `TopLevelFlag` on `tcPragExpr` in GHC.IfaceToCore.++-}++lintUnfolding :: Bool             -- ^ True <=> is a compulsory unfolding+              -> LintConfig+              -> SrcLoc+              -> CoreExpr+              -> Maybe (Bag SDoc) -- Nothing => OK++lintUnfolding is_compulsory cfg locn expr+  | isEmptyBag errs = Nothing+  | otherwise       = Just errs+  where+    (_warns, errs) = initL cfg $+                     if is_compulsory+                       -- See Note [Checking for representation polymorphism]+                     then noFixedRuntimeRepChecks linter+                     else linter+    linter = addLoc (ImportedUnfolding locn) $+             lintCoreExpr expr++lintExpr :: LintConfig+         -> CoreExpr+         -> Maybe (Bag SDoc)  -- Nothing => OK++lintExpr cfg expr+  | isEmptyBag errs = Nothing+  | otherwise       = Just errs+  where+    (_warns, errs) = initL cfg linter+    linter = addLoc TopLevelBindings $+             lintCoreExpr expr++{-+************************************************************************+*                                                                      *+\subsection[lintCoreBinding]{lintCoreBinding}+*                                                                      *+************************************************************************++Check a core binding, returning the list of variables bound.+-}++-- Returns a UsageEnv because this function is called in lintCoreExpr for+-- Let++lintRecBindings :: TopLevelFlag -> [(Id, CoreExpr)]+                -> ([OutId] -> LintM a) -> LintM (a, [UsageEnv])+lintRecBindings top_lvl pairs thing_inside+  = lintIdBndrs top_lvl bndrs $ \ bndrs' ->+    do { ues <- zipWithM lint_pair bndrs' rhss+       ; a <- thing_inside bndrs'+       ; return (a, ues) }+  where+    (bndrs, rhss) = unzip pairs+    lint_pair bndr' rhs+      = addLoc (RhsOf bndr') $+        do { (rhs_ty, ue) <- lintRhs bndr' rhs         -- Check the rhs+           ; lintLetBind top_lvl Recursive bndr' rhs rhs_ty+           ; return ue }++lintLetBody :: LintLocInfo -> [OutId] -> CoreExpr -> LintM (OutType, UsageEnv)+lintLetBody loc bndrs body+  = do { (body_ty, body_ue) <- addLoc loc (lintCoreExpr body)+       ; mapM_ (lintJoinBndrType body_ty) bndrs+       ; return (body_ty, body_ue) }++lintLetBind :: TopLevelFlag -> RecFlag -> OutId+              -> CoreExpr -> OutType -> LintM ()+-- Binder's type, and the RHS, have already been linted+-- This function checks other invariants+lintLetBind top_lvl rec_flag binder rhs rhs_ty+  = do { let binder_ty = idType binder+       ; ensureEqTys binder_ty rhs_ty (mkRhsMsg binder (text "RHS") rhs_ty)++       -- If the binding is for a CoVar, the RHS should be (Coercion co)+       -- See Note [Core type and coercion invariant] in GHC.Core+       ; checkL (not (isCoVar binder) || isCoArg rhs)+                (mkLetErr binder rhs)++        -- Check the let-can-float invariant+        -- See Note [Core let-can-float invariant] in GHC.Core+       ; checkL ( isJoinId binder+               || mightBeLiftedType binder_ty+               || (isNonRec rec_flag && exprOkForSpeculation rhs)+               || isDataConWorkId binder || isDataConWrapId binder -- until #17521 is fixed+               || exprIsTickedString rhs)+           (badBndrTyMsg binder (text "unlifted"))++        -- Check that if the binder is at the top level and has type Addr#,+        -- that it is a string literal.+        -- See Note [Core top-level string literals].+       ; checkL (not (isTopLevel top_lvl && binder_ty `eqType` addrPrimTy)+                 || exprIsTickedString rhs)+           (mkTopNonLitStrMsg binder)++       ; flags <- getLintFlags++         -- Check that a join-point binder has a valid type+         -- NB: lintIdBinder has checked that it is not top-level bound+       ; case idJoinPointHood binder of+            NotJoinPoint    -> return ()+            JoinPoint arity ->  checkL (isValidJoinPointType arity binder_ty)+                                       (mkInvalidJoinPointMsg binder binder_ty)++       ; when (lf_check_inline_loop_breakers flags+               && isStableUnfolding (realIdUnfolding binder)+               && isStrongLoopBreaker (idOccInfo binder)+               && isInlinePragma (idInlinePragma binder))+              (addWarnL (text "INLINE binder is (non-rule) loop breaker:" <+> ppr binder))+              -- Only non-rule loop breakers inhibit inlining++       -- We used to check that the dmdTypeDepth of a demand signature never+       -- exceeds idArity, but that is an unnecessary complication, see+       -- Note [idArity varies independently of dmdTypeDepth] in GHC.Core.Opt.DmdAnal++       -- Check that the binder's arity is within the bounds imposed by the type+       -- and the strictness signature. See Note [Arity invariants for bindings]+       -- and Note [Trimming arity]++       ; checkL (typeArity (idType binder) >= idArity binder)+           (text "idArity" <+> ppr (idArity binder) <+>+           text "exceeds typeArity" <+>+           ppr (typeArity (idType binder)) <> colon <+>+           ppr binder)++       -- See Note [idArity varies independently of dmdTypeDepth]+       --     in GHC.Core.Opt.DmdAnal+       ; case splitDmdSig (idDmdSig binder) of+           (demands, result_info) | isDeadEndDiv result_info ->+              if (demands `lengthAtLeast` idArity binder)+              then return ()+              else pprTrace "Hack alert: lintLetBind #24623"+                       (ppr (idArity binder) $$ ppr (idDmdSig binder)) $+                   return ()+--             checkL (demands `lengthAtLeast` idArity binder)+--               (text "idArity" <+> ppr (idArity binder) <+>+--               text "exceeds arity imposed by the strictness signature" <+>+--               ppr (idDmdSig binder) <> colon <+>+--               ppr binder)++           _ -> return ()++       ; addLoc (RuleOf binder) $ mapM_ (lintCoreRule binder binder_ty) (idCoreRules binder)++       ; addLoc (UnfoldingOf binder) $+         lintIdUnfolding binder binder_ty (idUnfolding binder)+       ; return () }++        -- We should check the unfolding, if any, but this is tricky because+        -- the unfolding is a SimplifiableCoreExpr. Give up for now.++-- | Checks the RHS of bindings. It only differs from 'lintCoreExpr'+-- in that it doesn't reject occurrences of the function 'makeStatic' when they+-- appear at the top level and @lf_check_static_ptrs == AllowAtTopLevel@, and+-- for join points, it skips the outer lambdas that take arguments to the+-- join point.+--+-- See Note [Checking StaticPtrs].+lintRhs :: Id -> CoreExpr -> LintM (OutType, UsageEnv)+-- NB: the Id can be Linted or not -- it's only used for+--     its OccInfo and join-pointer-hood+lintRhs bndr rhs+    | JoinPoint arity <- idJoinPointHood bndr+    = lintJoinLams arity (Just bndr) rhs+    | AlwaysTailCalled arity <- tailCallInfo (idOccInfo bndr)+    = lintJoinLams arity Nothing rhs++-- Allow applications of the data constructor @StaticPtr@ at the top+-- but produce errors otherwise.+lintRhs _bndr rhs = fmap lf_check_static_ptrs getLintFlags >>= go+  where+    -- Allow occurrences of 'makeStatic' at the top-level but produce errors+    -- otherwise.+    go :: StaticPtrCheck -> LintM (OutType, UsageEnv)+    go AllowAtTopLevel+      | (binders0, rhs') <- collectTyBinders rhs+      , Just (fun, t, info, e) <- collectMakeStaticArgs rhs'+      = markAllJoinsBad $+        foldr+        -- imitate @lintCoreExpr (Lam ...)@+        lintLambda+        -- imitate @lintCoreExpr (App ...)@+        (do fun_ty_ue <- lintCoreExpr fun+            lintCoreArgs fun_ty_ue [Type t, info, e]+        )+        binders0+    go _ = markAllJoinsBad $ lintCoreExpr rhs++-- | Lint the RHS of a join point with expected join arity of @n@ (see Note+-- [Join points] in "GHC.Core").+lintJoinLams :: JoinArity -> Maybe Id -> CoreExpr -> LintM (OutType, UsageEnv)+lintJoinLams join_arity enforce rhs+  = go join_arity rhs+  where+    go 0 expr            = lintCoreExpr expr+    go n (Lam var body)  = lintLambda var $ go (n-1) body+    go n expr | Just bndr <- enforce -- Join point with too few RHS lambdas+              = failWithL $ mkBadJoinArityMsg bndr join_arity n rhs+              | otherwise -- Future join point, not yet eta-expanded+              = markAllJoinsBad $ lintCoreExpr expr+                -- Body of lambda is not a tail position++lintIdUnfolding :: Id -> Type -> Unfolding -> LintM ()+lintIdUnfolding bndr bndr_ty uf+  | isStableUnfolding uf+  , Just rhs <- maybeUnfoldingTemplate uf+  = do { ty <- fst <$> (if isCompulsoryUnfolding uf+                        then noFixedRuntimeRepChecks $ lintRhs bndr rhs+            --               ^^^^^^^^^^^^^^^^^^^^^^^+            -- See Note [Checking for representation polymorphism]+                        else lintRhs bndr rhs)+       ; ensureEqTys bndr_ty ty (mkRhsMsg bndr (text "unfolding") ty) }+lintIdUnfolding  _ _ _+  = return ()       -- Do not Lint unstable unfoldings, because that leads+                    -- to exponential behaviour; c.f. GHC.Core.FVs.idUnfoldingVars++{- Note [Checking for INLINE loop breakers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It's very suspicious if a strong loop breaker is marked INLINE.++However, the desugarer generates instance methods with INLINE pragmas+that form a mutually recursive group.  Only after a round of+simplification are they unravelled.  So we suppress the test for+the desugarer.  Here is an example:+  instance Eq T where+    t1 == t2 = blah+    t1 /= t2 = not (t1 == t2)+    {-# INLINE (/=) #-}++This will generate something like+    -- From the class decl for Eq+    data Eq a = EqDict (a->a->Bool) (a->a->Bool)+    eq_sel :: Eq a -> (a->a->Bool)+    eq_sel (EqDict eq _) = eq++    -- From the instance Eq T+    $ceq :: T -> T -> Bool+    $ceq = blah++    Rec { $dfEqT :: Eq T {-# DFunId #-}+          $dfEqT = EqDict $ceq $cnoteq++          $cnoteq :: T -> T -> Bool  {-# INLINE #-}+          $cnoteq x y = not (eq_sel $dfEqT x y) }++Notice that++* `$dfEqT` and `$cnotEq` are mutually recursive.++* We do not want `$dfEqT` to be the loop breaker: it's a DFunId, and+  we want to let it "cancel" with "eq_sel" (see Note [ClassOp/DFun+  selection] in GHC.Tc.TyCl.Instance, which it can't do if it's a loop+  breaker.++So we make `$cnoteq` into the loop breaker. That means it can't+inline, despite the INLINE pragma. That's what gives rise to the+warning, which is perfectly appropriate for, say+   Rec { {-# INLINE f #-}  f = \x -> ...f.... }+We can't inline a recursive function -- it's a loop breaker.++But now we can optimise `eq_sel $dfEqT` to `$ceq`, so we get+  Rec {+    $dfEqT :: Eq T {-# DFunId #-}+    $dfEqT = EqDict $ceq $cnoteq++    $cnoteq :: T -> T -> Bool  {-# INLINE #-}+    $cnoteq x y = not ($ceq x y) }++and now the dependencies of the Rec have gone, and we can split it up to give+    NonRec {  $dfEqT :: Eq T {-# DFunId #-}+              $dfEqT = EqDict $ceq $cnoteq }++    NonRec {  $cnoteq :: T -> T -> Bool  {-# INLINE #-}+              $cnoteq x y = not ($ceq x y) }++Now $cnoteq is not a loop breaker any more, so the INLINE pragma can+take effect -- the warning turned out to be temporary.++To stop excessive warnings, this warning for INLINE loop breakers is+switched off when linting the result of the desugarer.  See+lf_check_inline_loop_breakers in GHC.Core.Lint.+++Note [Checking for representation polymorphism]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We ordinarily want to check for bad representation polymorphism. See+Note [Representation polymorphism invariants] in GHC.Core. However, we do *not*+want to do this in a compulsory unfolding. Compulsory unfoldings arise+only internally, for things like newtype wrappers, dictionaries, and+(notably) unsafeCoerce#. These might legitimately be representation-polymorphic;+indeed representation-polymorphic unfoldings are a primary reason for the+very existence of compulsory unfoldings (we can't compile code for+the original, representation-polymorphic, binding).++It is vitally important that we do representation polymorphism checks *after*+performing the unfolding, but not beforehand. This is all safe because+we will check any unfolding after it has been unfolded; checking the+unfolding beforehand is merely an optimization, and one that actively+hurts us here.++Note [Linting of runRW#]+~~~~~~~~~~~~~~~~~~~~~~~~+runRW# has some very special behavior (see Note [runRW magic] in+GHC.CoreToStg.Prep) which CoreLint must accommodate, by allowing+join points in its argument.  For example, this is fine:++    join j x = ...+    in runRW#  (\s. case v of+                       A -> j 3+                       B -> j 4)++Usually those calls to the join point 'j' would not be valid tail calls,+because they occur in a function argument.  But in the case of runRW#+they are fine, because runRW# (\s.e) behaves operationally just like e.+(runRW# is ultimately inlined in GHC.CoreToStg.Prep.)++In the case that the continuation is /not/ a lambda we simply disable this+special behaviour.  For example, this is /not/ fine:++    join j = ...+    in runRW# @r @ty (jump j)++Note [Coercions in terms]+~~~~~~~~~~~~~~~~~~~~~~~~~+The expression (Type ty) can occur only as the argument of an application,+or the RHS of a non-recursive Let.  But what about (Coercion co)?++Currently it appears in ghc-prim:GHC.Types.coercible_sel, a WiredInId whose+definition is:+   coercible_sel :: Coercible a b => (a ~R# b)+   coercible_sel d = case d of+                         MkCoercibleDict (co :: a ~# b) -> Coercion co++So this function has a (Coercion co) in the alternative of a case.++Richard says (!11908): it shouldn't appear outside of arguments, but we've been+loose about this. coercible_sel is some thin ice. Really we should be unpacking+Coercible using case, not a selector. I recall looking into this a few years+back and coming to the conclusion that the fix was worse than the disease. Don't+remember the details, but could probably recover it if we want to revisit.++So Lint current accepts (Coercion co) in arbitrary places.  There is no harm in+that: it really is a value, albeit a zero-bit value.++************************************************************************+*                                                                      *+\subsection[lintCoreExpr]{lintCoreExpr}+*                                                                      *+************************************************************************+-}++lintCoreExpr :: InExpr -> LintM (OutType, UsageEnv)+-- The returned type has the substitution from the monad+-- already applied to it:+--      lintCoreExpr e subst = exprType (subst e)+--+-- The returned "type" can be a kind, if the expression is (Type ty)++-- If you edit this function, you may need to update the GHC formalism+-- See Note [GHC Formalism]++lintCoreExpr (Var var)+  = do {  var_pair@(var_ty, _) <- lintIdOcc var 0+           -- See Note [Linting representation-polymorphic builtins]+       ; checkRepPolyBuiltin (Var var) [] var_ty+           --checkDataToTagPrimOpTyCon (Var var) []+       ; return var_pair }++lintCoreExpr (Lit lit)+  = return (literalType lit, zeroUE)++lintCoreExpr (Cast expr co)+  = do { (expr_ty, ue) <- markAllJoinsBad (lintCoreExpr expr)+            -- markAllJoinsBad: see Note [Join points and casts]++       ; lintCoercion co+       ; lintRole co Representational (coercionRole co)+       ; Pair from_ty to_ty <- substCoKindM co+       ; checkValueType (typeKind to_ty) $+         text "target of cast" <+> quotes (ppr co)+       ; ensureEqTys from_ty expr_ty (mkCastErr expr co from_ty expr_ty)+       ; return (to_ty, ue) }++lintCoreExpr (Tick tickish expr)+  = do { case tickish of+           Breakpoint _ _ ids -> forM_ ids $ \id -> lintIdOcc id 0+           _                  -> return ()+       ; markAllJoinsBadIf block_joins $ lintCoreExpr expr }+  where+    block_joins = not (tickish `tickishScopesLike` SoftScope)+      -- TODO Consider whether this is the correct rule. It is consistent with+      -- the simplifier's behaviour - cost-centre-scoped ticks become part of+      -- the continuation, and thus they behave like part of an evaluation+      -- context, but soft-scoped and non-scoped ticks simply wrap the result+      -- (see Simplify.simplTick).++lintCoreExpr (Let (NonRec tv (Type ty)) body)+  | isTyVar tv+  =     -- See Note [Linting type lets]+    do  { ty' <- lintTypeAndSubst ty+        ; lintTyCoBndr tv              $ \ tv' ->+    do  { addLoc (RhsOf tv) $ lintTyKind tv' ty'+                -- Now extend the substitution so we+                -- take advantage of it in the body+        ; extendTvSubstL tv ty' $+          addLoc (BodyOfLet tv) $+          lintCoreExpr body } }++lintCoreExpr (Let (NonRec bndr rhs) body)+  | isId bndr+  = do { -- First Lint the RHS, before bringing the binder into scope+         (rhs_ty, let_ue) <- lintRhs bndr rhs++          -- See Note [Multiplicity of let binders] in Var+         -- Now lint the binder+       ; lintBinder LetBind bndr $ \bndr' ->+    do { lintLetBind NotTopLevel NonRecursive bndr' rhs rhs_ty+       ; addAliasUE bndr' let_ue $+         lintLetBody (BodyOfLet bndr') [bndr'] body } }++  | otherwise+  = failWithL (mkLetErr bndr rhs)       -- Not quite accurate++lintCoreExpr e@(Let (Rec pairs) body)+  = do  { -- Check that the list of pairs is non-empty+          checkL (not (null pairs)) (emptyRec e)++          -- Check that there are no duplicated binders+        ; let (_, dups) = removeDups compare bndrs+        ; checkL (null dups) (dupVars dups)++          -- Check that either all the binders are joins, or none+        ; checkL (all isJoinId bndrs || all (not . isJoinId) bndrs) $+          mkInconsistentRecMsg bndrs++          -- See Note [Multiplicity of let binders] in Var+        ; ((body_type, body_ue), ues) <-+            lintRecBindings NotTopLevel pairs $ \ bndrs' ->+            lintLetBody (BodyOfLetRec bndrs') bndrs' body+        ; return (body_type, body_ue  `addUE` scaleUE ManyTy (foldr1WithDefault zeroUE addUE ues)) }+  where+    bndrs = map fst pairs++lintCoreExpr e@(App _ _)+  | Var fun <- fun+  , fun `hasKey` runRWKey+    -- See Note [Linting of runRW#]+    -- N.B. we may have an over-saturated application of the form:+    --   runRW (\s -> \x -> ...) y+  , ty_arg1 : ty_arg2 : cont_arg : rest <- args+  = do { let lint_rw_cont :: CoreArg -> Mult -> UsageEnv -> LintM (OutType, UsageEnv)+             lint_rw_cont expr@(Lam _ _) mult fun_ue+                = do { (arg_ty, arg_ue) <- lintJoinLams 1 (Just fun) expr+                     ; let app_ue = addUE fun_ue (scaleUE mult arg_ue)+                     ; return (arg_ty, app_ue) }++             lint_rw_cont expr mult ue+                = lintValArg expr mult ue+             -- TODO: Look through ticks?++       ; runrw_pr <- lintApp (text "runRW# expression")+                               lintTyArg lint_rw_cont+                               (idType fun) [ty_arg1,ty_arg2,cont_arg] zeroUE+       ; lintCoreArgs runrw_pr rest }++  | otherwise+  = do { fun_pair <- lintCoreFun fun (length args)+       ; app_pair@(app_ty, _) <- lintCoreArgs fun_pair args++       -- See Note [Linting representation-polymorphic builtins]+       ; checkRepPolyBuiltin fun args app_ty+       ; --checkDataToTagPrimOpTyCon fun args++       ; return app_pair}+  where+    skipTick t = case collectFunSimple e of+      (Var v) -> etaExpansionTick v t+      _ -> tickishFloatable t+    (fun, args, _source_ticks) = collectArgsTicks skipTick e+      -- We must look through source ticks to avoid #21152, for example:+      --+      -- reallyUnsafePtrEquality+      --   = \ @a ->+      --       (src<loc> reallyUnsafePtrEquality#)+      --         @Lifted @a @Lifted @a+      --+      -- To do this, we use `collectArgsTicks tickishFloatable` to match+      -- the eta expansion behaviour, as per Note [Eta expansion and source notes]+      -- in GHC.Core.Opt.Arity.+      -- Sadly this was not quite enough. So we now also accept things that CorePrep will allow.+      -- See Note [Ticks and mandatory eta expansion]++lintCoreExpr (Lam var expr)+  = markAllJoinsBad $+    lintLambda var $ lintCoreExpr expr++lintCoreExpr (Case scrut var alt_ty alts)+  = lintCaseExpr scrut var alt_ty alts++-- This case can't happen; linting types in expressions gets routed through lintTyArg+lintCoreExpr (Type ty)+  = failWithL (text "Type found as expression" <+> ppr ty)++lintCoreExpr (Coercion co)+  -- See Note [Coercions in terms]+  = do { addLoc (InCo co) $ lintCoercion co+       ; ty <- substTyM (coercionType co)+       ; return (ty, zeroUE) }++----------------------+lintIdOcc :: InId -> Int -- Number of arguments (type or value) being passed+          -> LintM (OutType, UsageEnv) -- returns type of the *variable*+lintIdOcc in_id nargs+  = addLoc (OccOf in_id) $+    do  { checkL (isNonCoVarId in_id)+                 (text "Non term variable" <+> ppr in_id)+                 -- See GHC.Core Note [Variable occurrences in Core]++        -- Check that the type of the occurrence is the same+        -- as the type of the binding site.  The inScopeIds are+        -- /un-substituted/, so this checks that the occurrence type+        -- is identical to the binder type.+        -- This makes things much easier for things like:+        --    /\a. \(x::Maybe a). /\a. ...(x::Maybe a)...+        -- The "::Maybe a" on the occurrence is referring to the /outer/ a.+        -- If we compared /substituted/ types we'd risk comparing+        -- (Maybe a) from the binding site with bogus (Maybe a1) from+        -- the occurrence site.  Comparing un-substituted types finesses+        -- this altogether+        ; out_ty <- lintVarOcc in_id++          -- Check for a nested occurrence of the StaticPtr constructor.+          -- See Note [Checking StaticPtrs].+        ; lf <- getLintFlags+        ; when (nargs /= 0 && lf_check_static_ptrs lf /= AllowAnywhere) $+            checkL (idName in_id /= makeStaticName) $+              text "Found makeStatic nested in an expression"++        ; checkDeadIdOcc in_id++        ; case isDataConId_maybe in_id of+             Nothing -> return ()+             Just dc -> checkTypeDataConOcc "expression" dc++        ; checkJoinOcc in_id nargs+        ; usage <- varCallSiteUsage in_id++        ; return (out_ty, usage) }++++lintCoreFun :: CoreExpr+            -> Int                          -- Number of arguments (type or val) being passed+            -> LintM (OutType, UsageEnv) -- Returns type of the *function*+lintCoreFun (Var var) nargs+  = lintIdOcc var nargs++lintCoreFun (Lam var body) nargs+  -- Act like lintCoreExpr of Lam, but *don't* call markAllJoinsBad;+  -- See Note [Beta redexes]+  | nargs /= 0+  = lintLambda var $ lintCoreFun body (nargs - 1)++lintCoreFun expr nargs+  = markAllJoinsBadIf (nargs /= 0) $+      -- See Note [Join points are less general than the paper]+    lintCoreExpr expr+------------------+lintLambda :: Var -> LintM (Type, UsageEnv) -> LintM (Type, UsageEnv)+lintLambda var lintBody =+    addLoc (LambdaBodyOf var) $+    lintBinder LambdaBind var $ \ var' ->+    do { (body_ty, ue) <- lintBody+       ; ue' <- checkLinearity ue var'+       ; return (mkLamType var' body_ty, ue') }+------------------+checkDeadIdOcc :: Id -> LintM ()+-- Occurrences of an Id should never be dead....+-- except when we are checking a case pattern+checkDeadIdOcc id+  | isDeadOcc (idOccInfo id)+  = do { in_case <- inCasePat+       ; checkL in_case+                (text "Occurrence of a dead Id" <+> ppr id) }+  | otherwise+  = return ()++------------------+lintJoinBndrType :: OutType -- Type of the body+                 -> OutId   -- Possibly a join Id+                -> LintM ()+-- Checks that the return type of a join Id matches the body+-- E.g. join j x = rhs in body+--      The type of 'rhs' must be the same as the type of 'body'+lintJoinBndrType body_ty bndr+  | JoinPoint arity <- idJoinPointHood bndr+  , let bndr_ty = idType bndr+  , (bndrs, res) <- splitPiTys bndr_ty+  = checkL (length bndrs >= arity+            && body_ty `eqType` mkPiTys (drop arity bndrs) res) $+    hang (text "Join point returns different type than body")+       2 (vcat [ text "Join bndr:" <+> ppr bndr <+> dcolon <+> ppr (idType bndr)+               , text "Join arity:" <+> ppr arity+               , text "Body type:" <+> ppr body_ty ])+  | otherwise+  = return ()++checkJoinOcc :: Id -> JoinArity -> LintM ()+-- Check that if the occurrence is a JoinId, then so is the+-- binding site, and it's a valid join Id+checkJoinOcc var n_args+  | JoinPoint join_arity_occ <- idJoinPointHood var+  = do { mb_join_arity_bndr <- lookupJoinId var+       ; case mb_join_arity_bndr of {+           NotJoinPoint -> do { join_set <- getValidJoins+                              ; addErrL (text "join set " <+> ppr join_set $$+                                invalidJoinOcc var) } ;++           JoinPoint join_arity_bndr ->++    do { checkL (join_arity_bndr == join_arity_occ) $+           -- Arity differs at binding site and occurrence+         mkJoinBndrOccMismatchMsg var join_arity_bndr join_arity_occ++       ; checkL (n_args == join_arity_occ) $+           -- Arity doesn't match #args+         mkBadJumpMsg var join_arity_occ n_args } } }++  | otherwise+  = return ()++checkTypeDataConOcc :: String -> DataCon -> LintM ()+-- Check that the Id is not a data constructor of a `type data` declaration+-- Invariant (I1) of Note [Type data declarations] in GHC.Rename.Module+checkTypeDataConOcc what dc+  = checkL (not (isTypeDataTyCon (dataConTyCon dc))) $+    (text "type data constructor found in a" <+> text what <> colon <+> ppr dc)++{-+-- | Check that a use of a dataToTag# primop satisfies conditions DTT2+-- and DTT3 from Note [DataToTag overview] in GHC.Tc.Instance.Class+--+-- Ignores applications not headed by dataToTag# primops.++-- Commented out because GHC.PrimopWrappers doesn't respect this condition yet.+-- See wrinkle DTW7 in Note [DataToTag overview].+checkDataToTagPrimOpTyCon+  :: CoreExpr   -- ^ the function (head of the application) we are checking+  -> [CoreArg]  -- ^ The arguments to the application+  -> LintM ()+checkDataToTagPrimOpTyCon (Var fun_id) args+  | Just op <- isPrimOpId_maybe fun_id+  , op == DataToTagSmallOp || op == DataToTagLargeOp+  = case args of+      Type _levity : Type dty : _rest+        | Just (tc, _) <- splitTyConApp_maybe dty+        , isValidDTT2TyCon tc+          -> do  platform <- getPlatform+                 let  numConstrs = tyConFamilySize tc+                      isSmallOp = op == DataToTagSmallOp+                 checkL (isSmallFamily platform numConstrs == isSmallOp) $+                   text "dataToTag# primop-size/tycon-family-size mismatch"+        | otherwise -> failWithL $ text "dataToTagLarge# used at non-ADT type:"+                                   <+> ppr dty+      _ -> failWithL $ text "dataToTagLarge# needs two type arguments but has args:"+                       <+> ppr (take 2 args)++checkDataToTagPrimOpTyCon _ _ = pure ()+-}++-- | Check representation-polymorphic invariants in an application of a+-- built-in function or newtype constructor.+--+-- See Note [Linting representation-polymorphic builtins].+checkRepPolyBuiltin :: CoreExpr   -- ^ the function (head of the application) we are checking+                    -> [CoreArg]  -- ^ the arguments to the application+                    -> OutType -- ^ the instantiated type of the overall application+                    -> LintM ()+checkRepPolyBuiltin (Var fun_id) args app_ty+  = do { do_rep_poly_checks <- lf_check_fixed_rep <$> getLintFlags+       ; when (do_rep_poly_checks && hasNoBinding fun_id) $+           if+             -- (2) representation-polymorphic unlifted newtypes+             | Just dc <- isDataConId_maybe fun_id+             , isNewDataCon dc+             -> if tcHasFixedRuntimeRep $ dataConTyCon dc+                then return ()+                else checkRepPolyNewtypeApp dc args app_ty++             -- (1) representation-polymorphic builtins+             | otherwise+             -> checkRepPolyBuiltinApp fun_id args+       }+checkRepPolyBuiltin _ _ _ = return ()++checkRepPolyNewtypeApp :: DataCon -> [CoreArg] -> OutType -> LintM ()+checkRepPolyNewtypeApp nt args app_ty+  -- If the newtype is saturated, we're OK.+  | any isValArg args+  = return ()+  -- Otherwise, check we can eta-expand.+  | otherwise+  = case getRuntimeArgTys app_ty of+      (Scaled _ first_val_arg_ty, _):_+        | not $ typeHasFixedRuntimeRep first_val_arg_ty+        -> failWithL (err_msg first_val_arg_ty)+      _ -> return ()++  where++      err_msg :: Type -> SDoc+      err_msg bad_arg_ty+        = vcat [ text "Cannot eta expand unlifted newtype constructor" <+> quotes (ppr nt) <> dot+               , text "Its argument type does not have a fixed runtime representation:"+               , nest 2 $ ppr_ty_ki bad_arg_ty ]++      ppr_ty_ki :: Type -> SDoc+      ppr_ty_ki ty = bullet <+> ppr ty <+> dcolon <+> ppr (typeKind ty)++checkRepPolyBuiltinApp :: Id -> [CoreArg] -> LintM ()+checkRepPolyBuiltinApp fun_id args = checkL (null not_concs) err_msg+  where++    conc_binder_positions :: IntMap ConcreteTvOrigin+    conc_binder_positions+      = concreteTyVarPositions fun_id+      $ idDetailsConcreteTvs+      $ idDetails fun_id++    max_pos :: Int+    max_pos =+      case nonEmpty $ IntMap.keys conc_binder_positions of+        Nothing -> 0+        Just positions -> maximum positions++    not_concs :: [(SDoc, ConcreteTvOrigin)]+    not_concs =+      mapMaybe is_bad (zip [1..max_pos] (map Just args ++ repeat Nothing))+        -- NB: 1-indexed++    is_bad :: (Int, Maybe CoreArg) -> Maybe (SDoc, ConcreteTvOrigin)+    is_bad (pos, mb_arg)+      | Just conc_reason <- IntMap.lookup pos conc_binder_positions+      , Just bad_ty <- case mb_arg of+          Just (Type ki)+            | isConcreteType ki+            -> Nothing+            | otherwise+            -- Here we handle the situation in which a "must be concrete" TyVar+            -- has been instantiated with a type that is not concrete.+            -> Just $ quotes (ppr ki) <+> text "is not concrete."+          -- We expected a type argument in this position, and got something else: panic!+          Just arg ->+            pprPanic "checkRepPolyBuiltinApp: expected a type in this position" $+              vcat [ text "fun_id:" <+> ppr fun_id <+> dcolon <+> ppr (idType fun_id)+                   , text "pos:" <+> ppr pos+                   , text "arg:" <+> ppr arg ]+          Nothing ->+            -- Here we handle the situation in which a "must be concrete" TyVar+            -- has not been instantiated at all.+            case conc_reason of+              ConcreteFRR frr_orig ->+                let ty = frr_type frr_orig+                in  Just $ ppr ty <+> dcolon <+> ppr (typeKind ty)+      = Just (bad_ty, conc_reason)+      | otherwise+      = Nothing++    err_msg :: SDoc+    err_msg+      = vcat $ map ((bullet <+>) . ppr_not_conc) not_concs++    ppr_not_conc :: (SDoc, ConcreteTvOrigin) -> SDoc+    ppr_not_conc (bad_ty, conc) =+      vcat+       [ ppr_conc_orig conc+       , nest 2 bad_ty ]++    ppr_conc_orig :: ConcreteTvOrigin -> SDoc+    ppr_conc_orig (ConcreteFRR frr_orig) =+      case frr_orig of+        FixedRuntimeRepOrigin { frr_context = ctxt } ->+          hsep [ ppr ctxt, text "does not have a fixed runtime representation:" ]++-- | Compute the 1-indexed positions in the outer forall'd quantified type variables+-- of the type in which the concrete type variables occur.+--+-- See Note [Representation-polymorphism checking built-ins] in GHC.Tc.Utils.Concrete.+concreteTyVarPositions :: Id -> ConcreteTyVars -> IntMap ConcreteTvOrigin+concreteTyVarPositions fun_id conc_tvs+  | isNullUFM conc_tvs+  = IntMap.empty+  | otherwise+  = case splitForAllTyCoVars (idType fun_id) of+    ([], _)  -> IntMap.empty+    (tvs, _) ->+      let positions =+            IntMap.fromList+              [ (pos, conc_orig)+              | (tv, pos) <- zip tvs [1..]+              , conc_orig <- maybeToList $ lookupNameEnv conc_tvs (tyVarName tv)+              ]+         -- Assert that we have as many positions as concrete type variables,+         -- i.e. we are not missing any concreteness information.+      in assertPpr (sizeUFM conc_tvs == length positions)+           (vcat [ text "concreteTyVarPositions: missing concreteness information"+                 , text "fun_id:" <+> ppr fun_id+                 , text "tvs:" <+> ppr tvs+                 , text "Expected # of concrete tvs:" <+> ppr (sizeUFM conc_tvs)+                 , text "  Actual # of concrete tvs:" <+> ppr (length positions) ])+           positions++-- Check that the usage of var is consistent with var itself, and pop the var+-- from the usage environment (this is important because of shadowing).+checkLinearity :: UsageEnv -> OutVar -> LintM UsageEnv+checkLinearity body_ue lam_var =+  case varMultMaybe lam_var of+    Just mult -> do+      let (lhs, body_ue') = popUE body_ue lam_var+          err_msg = vcat [ text "Linearity failure in lambda:" <+> ppr lam_var+                         , ppr lhs <+> text "⊈" <+> ppr mult+                         , ppr body_ue ]+      ensureSubUsage lhs mult err_msg+      return body_ue'+    Nothing    -> return body_ue -- A type variable++{- Note [Join points and casts]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+You might think that this should be OK:+   join j x = rhs+   in (case e of+          A   -> alt1+          B x -> (jump j x) |> co)++You might think that, since the cast is ultimately erased, the jump to+`j` should still be OK as a join point.  But no!  See #21716. Suppose++  newtype Age = MkAge Int   -- axAge :: Age ~ Int+  f :: Int -> ...           -- f strict in it's first argument++and consider the expression++  f (join j :: Bool -> Age+          j x = (rhs1 :: Age)+     in case v of+         Just x  -> (j x |> axAge :: Int)+         Nothing -> rhs2)++Then, if the Simplifier pushes the strict call into the join points+and alternatives we'll get++   join j' x = f (rhs1 :: Age)+   in case v of+      Just x  -> j' x |> axAge+      Nothing -> f rhs2++Utterly bogus.  `f` expects an `Int` and we are giving it an `Age`.+No no no.  Casts destroy the tail-call property.  Henc markAllJoinsBad+in the (Cast expr co) case of lintCoreExpr.++Note [No alternatives lint check]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Case expressions with no alternatives are odd beasts, and it would seem+like they would worth be looking at in the linter (cf #10180). We+used to check two things:++* exprIsHNF is false: it would *seem* to be terribly wrong if+  the scrutinee was already in head normal form.++* exprIsDeadEnd is true: we should be able to see why GHC believes the+  scrutinee is diverging for sure.++It was already known that the second test was not entirely reliable.+Unfortunately (#13990), the first test turned out not to be reliable+either. Getting the checks right turns out to be somewhat complicated.++For example, suppose we have (comment 8)++  data T a where+    TInt :: T Int++  absurdTBool :: T Bool -> a+  absurdTBool v = case v of++  data Foo = Foo !(T Bool)++  absurdFoo :: Foo -> a+  absurdFoo (Foo x) = absurdTBool x++GHC initially accepts the empty case because of the GADT conditions. But then+we inline absurdTBool, getting++  absurdFoo (Foo x) = case x of++x is in normal form (because the Foo constructor is strict) but the+case is empty. To avoid this problem, GHC would have to recognize+that matching on Foo x is already absurd, which is not so easy.++More generally, we don't really know all the ways that GHC can+lose track of why an expression is bottom, so we shouldn't make too+much fuss when that happens.+++Note [Beta redexes]+~~~~~~~~~~~~~~~~~~~+Consider:++  join j @x y z = ... in+  (\@x y z -> jump j @x y z) @t e1 e2++This is clearly ill-typed, since the jump is inside both an application and a+lambda, either of which is enough to disqualify it as a tail call (see Note+[Invariants on join points] in GHC.Core). However, strictly from a+lambda-calculus perspective, the term doesn't go wrong---after the two beta+reductions, the jump *is* a tail call and everything is fine.++Why would we want to allow this when we have let? One reason is that a compound+beta redex (that is, one with more than one argument) has different scoping+rules: naively reducing the above example using lets will capture any free+occurrence of y in e2. More fundamentally, type lets are tricky; many passes,+such as Float Out, tacitly assume that the incoming program's type lets have+all been dealt with by the simplifier. Thus we don't want to let-bind any types+in, say, GHC.Core.Subst.simpleOptPgm, which in some circumstances can run immediately+before Float Out.++All that said, currently GHC.Core.Subst.simpleOptPgm is the only thing using this+loophole, doing so to avoid re-traversing large functions (beta-reducing a type+lambda without introducing a type let requires a substitution). TODO: Improve+simpleOptPgm so that we can forget all this ever happened.++************************************************************************+*                                                                      *+\subsection[lintCoreArgs]{lintCoreArgs}+*                                                                      *+************************************************************************++The basic version of these functions checks that the argument is a+subtype of the required type, as one would expect.+-}++-- Takes the functions type and arguments as argument.+-- Returns the *result* of applying the function to arguments.+-- e.g. f :: Int -> Bool -> Int would return `Int` as result type.+lintCoreArgs  :: (OutType, UsageEnv) -> [InExpr] -> LintM (OutType, UsageEnv)+lintCoreArgs (fun_ty, fun_ue) args+  = lintApp (text "expression")+              lintTyArg lintValArg fun_ty args fun_ue++lintTyArg :: InExpr -> LintM OutType++-- Type argument+lintTyArg (Type arg_ty)+  = do { checkL (not (isCoercionTy arg_ty))+                (text "Unnecessary coercion-to-type injection:"+                  <+> ppr arg_ty)+       ; lintTypeAndSubst arg_ty }+lintTyArg arg+  = failWithL (hang (text "Expected type argument but found") 2 (ppr arg))++lintValArg  :: InExpr -> Mult -> UsageEnv -> LintM (OutType, UsageEnv)+lintValArg arg mult fun_ue+  = do { (arg_ty, arg_ue) <- markAllJoinsBad $ lintCoreExpr arg+           -- See Note [Representation polymorphism invariants] in GHC.Core++       ; flags <- getLintFlags+       ; when (lf_check_fixed_rep flags) $+         -- Only check that 'arg_ty' has a fixed RuntimeRep+         -- if 'lf_check_fixed_rep' is on.+         do { checkL (typeHasFixedRuntimeRep arg_ty)+                     (text "Argument does not have a fixed runtime representation"+                      <+> ppr arg <+> dcolon+                      <+> parens (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))) }++       ; let app_ue = addUE fun_ue (scaleUE mult arg_ue)+       ; return (arg_ty, app_ue) }++-----------------+lintAltBinders :: UsageEnv+               -> Var         -- Case binder+               -> OutType     -- Scrutinee type+               -> OutType     -- Constructor type+               -> [(Mult, OutVar)]    -- Binders+               -> LintM UsageEnv+-- If you edit this function, you may need to update the GHC formalism+-- See Note [GHC Formalism]+lintAltBinders rhs_ue _case_bndr scrut_ty con_ty []+  = do { ensureEqTys con_ty scrut_ty (mkBadPatMsg con_ty scrut_ty)+       ; return rhs_ue }+lintAltBinders rhs_ue case_bndr scrut_ty con_ty ((var_w, bndr):bndrs)+  | isTyVar bndr+  = do { con_ty' <- lintTyApp con_ty (mkTyVarTy bndr)+       ; lintAltBinders rhs_ue case_bndr scrut_ty con_ty'  bndrs }+  | otherwise+  = do { (con_ty', _) <- lintValApp (Var bndr) con_ty (idType bndr) zeroUE zeroUE+         -- We can pass zeroUE to lintValApp because we ignore its usage+         -- calculation and compute it in the call for checkCaseLinearity below.+       ; rhs_ue' <- checkCaseLinearity rhs_ue case_bndr var_w bndr+       ; lintAltBinders rhs_ue' case_bndr scrut_ty con_ty' bndrs }++-- | Implements the case rules for linearity+checkCaseLinearity :: UsageEnv -> Var -> Mult -> Var -> LintM UsageEnv+checkCaseLinearity ue case_bndr var_w bndr = do+  ensureSubUsage lhs rhs err_msg+  lintLinearBinder (ppr bndr) (case_bndr_w `mkMultMul` var_w) (idMult bndr)+  return $ deleteUE ue bndr+  where+    lhs = bndr_usage `addUsage` (var_w `scaleUsage` case_bndr_usage)+    rhs = case_bndr_w `mkMultMul` var_w+    err_msg  = (text "Linearity failure in variable:" <+> ppr bndr+                $$ ppr lhs <+> text "⊈" <+> ppr rhs+                $$ text "Computed by:"+                <+> text "LHS:" <+> lhs_formula+                <+> text "RHS:" <+> rhs_formula)+    lhs_formula = ppr bndr_usage <+> text "+"+                                 <+> parens (ppr case_bndr_usage <+> text "*" <+> ppr var_w)+    rhs_formula = ppr case_bndr_w <+> text "*" <+> ppr var_w+    case_bndr_w = idMult case_bndr+    case_bndr_usage = lookupUE ue case_bndr+    bndr_usage = lookupUE ue bndr++++-----------------+lintTyApp :: OutType -> OutType -> LintM OutType+lintTyApp fun_ty arg_ty+  | Just (tv,body_ty) <- splitForAllTyVar_maybe fun_ty+  = do  { lintTyKind tv arg_ty+        ; in_scope <- getInScope+        -- substTy needs the set of tyvars in scope to avoid generating+        -- uniques that are already in scope.+        -- See Note [The substitution invariant] in GHC.Core.TyCo.Subst+        ; return (substTyWithInScope in_scope [tv] [arg_ty] body_ty) }++  | otherwise+  = failWithL (mkTyAppMsg fun_ty arg_ty)++-----------------++-- | @lintValApp arg fun_ty arg_ty@ lints an application of @fun arg@+-- where @fun :: fun_ty@ and @arg :: arg_ty@, returning the type of the+-- application.+lintValApp :: CoreExpr -> OutType -> OutType -> UsageEnv -> UsageEnv+           -> LintM (OutType, UsageEnv)+lintValApp arg fun_ty arg_ty fun_ue arg_ue+  | Just (_, w, arg_ty', res_ty') <- splitFunTy_maybe fun_ty+  = do { ensureEqTys arg_ty' arg_ty (mkAppMsg arg_ty' arg_ty arg)+       ; let app_ue =  addUE fun_ue (scaleUE w arg_ue)+       ; return (res_ty', app_ue) }+  | otherwise+  = failWithL err2+  where+    err2 = mkNonFunAppMsg fun_ty arg_ty arg++lintTyKind :: OutTyVar -> OutType -> LintM ()+-- Both args have had substitution applied++-- If you edit this function, you may need to update the GHC formalism+-- See Note [GHC Formalism]+lintTyKind tyvar arg_ty+  = unless (arg_kind `eqType` tyvar_kind) $+    addErrL (mkKindErrMsg tyvar arg_ty $$ (text "Linted Arg kind:" <+> ppr arg_kind))+  where+    tyvar_kind = tyVarKind tyvar+    arg_kind   = typeKind arg_ty++{-+************************************************************************+*                                                                      *+\subsection[lintCoreAlts]{lintCoreAlts}+*                                                                      *+************************************************************************+-}++lintCaseExpr :: CoreExpr -> InId -> InType -> [CoreAlt] -> LintM (OutType, UsageEnv)+lintCaseExpr scrut case_bndr alt_ty alts+  = do { let e = Case scrut case_bndr alt_ty alts   -- Just for error messages++       -- Check the scrutinee+       ; (scrut_ty', scrut_ue) <- markAllJoinsBad $ lintCoreExpr scrut+            -- See Note [Join points are less general than the paper]+            -- in GHC.Core++       ; alt_ty' <- addLoc (CaseTy scrut) $ lintValueType alt_ty++       ; checkCaseAlts e scrut scrut_ty' alts++       -- Lint the case-binder. Must do this after linting the scrutinee+       -- because the case-binder isn't in scope in the scrutineex+       ; lintBinder CaseBind case_bndr $ \case_bndr' ->+      -- Don't use lintIdBndr on case_bndr, because unboxed tuple is legitimate++    do { let case_bndr_ty' = idType case_bndr'+             scrut_mult    = idMult case_bndr'++       ; ensureEqTys case_bndr_ty' scrut_ty' (mkScrutMsg case_bndr case_bndr_ty' scrut_ty')+         -- See GHC.Core Note [Case expression invariants] item (7)++       ; -- Check the alternatives+       ; alt_ues <- mapM (lintCoreAlt case_bndr' scrut_ty' scrut_mult alt_ty') alts+       ; let case_ue = (scaleUE scrut_mult scrut_ue) `addUE` supUEs alt_ues+       ; return (alt_ty', case_ue) } }++checkCaseAlts :: InExpr -> InExpr -> OutType -> [CoreAlt] -> LintM ()+-- a) Check that the alts are non-empty+-- b1) Check that the DEFAULT comes first, if it exists+-- b2) Check that the others are in increasing order+-- c) Check that there's a default for infinite types+-- d) Check that the scrutinee is not a floating-point type+--    if there are any literal alternatives+-- e) Check if the scrutinee type has no constructors+--+-- We used to try to check whether a case expression with no+-- alternatives was legitimate, but this didn't work.+-- See Note [No alternatives lint check] for details.+--+-- NB: Algebraic cases are not necessarily exhaustive, because+--     the simplifier correctly eliminates case that can't+--     possibly match.+checkCaseAlts e scrut scrut_ty alts+  = do { checkL (all non_deflt con_alts) (mkNonDefltMsg e)+           -- See GHC.Core Note [Case expression invariants] item (2)++       ; checkL (increasing_tag con_alts) (mkNonIncreasingAltsMsg e)+           -- See GHC.Core Note [Case expression invariants] item (3)++            -- For types Int#, Word# with an infinite (well, large!) number of+            -- possible values, there should usually be a DEFAULT case+            -- But (see Note [Empty case alternatives] in GHC.Core) it's ok to+            -- have *no* case alternatives.+            -- In effect, this is a kind of partial test. I suppose it's possible+            -- that we might *know* that 'x' was 1 or 2, in which case+            --   case x of { 1 -> e1; 2 -> e2 }+            -- would be fine.+       ; checkL (isJust maybe_deflt || not is_infinite_ty || null alts)+                (nonExhaustiveAltsMsg e)++       -- Check that the scrutinee is not a floating-point type+       -- if there are any literal alternatives+       -- See GHC.Core Note [Case expression invariants] item (5)+       -- See Note [Rules for floating-point comparisons] in GHC.Core.Opt.ConstantFold+       ; checkL (not $ isFloatingPrimTy scrut_ty && any is_lit_alt alts)+           (text "Lint warning: Scrutinising floating-point expression with literal pattern in case analysis (see #9238)."+            $$ text "scrut" <+> ppr scrut)++       -- Check if scrutinee type has no constructors+       -- Just a trace message for now+       ; case tyConAppTyCon_maybe scrut_ty of+           Just tycon+                | debugIsOn+                , isAlgTyCon tycon+                , not (isAbstractTyCon tycon)+                , null (tyConDataCons tycon)+                , not (exprIsDeadEnd scrut)+                -> pprTrace "Lint warning: case scrutinee type has no constructors"+                        (ppr scrut_ty)+                          -- This can legitimately happen for type families+                        $ return ()+           _otherwise -> return ()+        }+  where+    (con_alts, maybe_deflt) = findDefault alts++        -- Check that successive alternatives have strictly increasing tags+    increasing_tag (alt1 : rest@( alt2 : _)) = alt1 `ltAlt` alt2 && increasing_tag rest+    increasing_tag _                         = True++    non_deflt (Alt DEFAULT _ _) = False+    non_deflt _                 = True++    is_lit_alt (Alt (LitAlt _) _  _) = True+    is_lit_alt _                     = False++    is_infinite_ty = case tyConAppTyCon_maybe scrut_ty of+                        Nothing    -> False+                        Just tycon -> isPrimTyCon tycon++lintAltExpr :: CoreExpr -> OutType -> LintM UsageEnv+lintAltExpr expr ann_ty+  = do { (actual_ty, ue) <- lintCoreExpr expr+       ; ensureEqTys actual_ty ann_ty (mkCaseAltMsg expr actual_ty ann_ty)+       ; return ue }+         -- See GHC.Core Note [Case expression invariants] item (6)++lintCoreAlt :: OutId         -- Case binder+            -> OutType       -- Type of scrutinee+            -> Mult          -- Multiplicity of scrutinee+            -> OutType       -- Type of the alternative+            -> CoreAlt+            -> LintM UsageEnv+-- If you edit this function, you may need to update the GHC formalism+-- See Note [GHC Formalism]+lintCoreAlt case_bndr _ scrut_mult alt_ty (Alt DEFAULT args rhs) =+  do { lintL (null args) (mkDefaultArgsMsg args)+     ; rhs_ue <- lintAltExpr rhs alt_ty+     ; let (case_bndr_usage, rhs_ue') = popUE rhs_ue case_bndr+           err_msg = vcat [ text "Linearity failure in the DEFAULT clause:" <+> ppr case_bndr+                          , ppr case_bndr_usage <+> text "⊈" <+> ppr scrut_mult ]+     ; ensureSubUsage case_bndr_usage scrut_mult err_msg+     ; return rhs_ue' }++lintCoreAlt case_bndr scrut_ty _ alt_ty (Alt (LitAlt lit) args rhs)+  | litIsLifted lit+  = failWithL integerScrutinisedMsg+  | otherwise+  = do { lintL (null args) (mkDefaultArgsMsg args)+       ; ensureEqTys lit_ty scrut_ty (mkBadPatMsg lit_ty scrut_ty)+       ; rhs_ue <- lintAltExpr rhs alt_ty+       ; return (deleteUE rhs_ue case_bndr) -- No need for linearity checks+       }+  where+    lit_ty = literalType lit++lintCoreAlt case_bndr scrut_ty _scrut_mult alt_ty alt@(Alt (DataAlt con) args rhs)+  | isNewTyCon (dataConTyCon con)+  = zeroUE <$ addErrL (mkNewTyDataConAltMsg scrut_ty alt)+  | Just (tycon, tycon_arg_tys) <- splitTyConApp_maybe scrut_ty+  = addLoc (CaseAlt alt) $  do+    { checkTypeDataConOcc "pattern" con+    ; lintL (tycon == dataConTyCon con) (mkBadConMsg tycon con)++      -- Instantiate the universally quantified+      -- type variables of the data constructor+    ; let { con_payload_ty = piResultTys (dataConRepType con) tycon_arg_tys+          ; binderMult (Named _)   = ManyTy+          ; binderMult (Anon st _) = scaledMult st+          -- See Note [Validating multiplicities in a case]+          ; multiplicities = map binderMult $ fst $ splitPiTys con_payload_ty }++        -- And now bring the new binders into scope+    ; lintBinders CasePatBind args $ \ args' -> do+      { rhs_ue <- lintAltExpr rhs alt_ty+      ; rhs_ue' <- addLoc (CasePat alt) $+                   lintAltBinders rhs_ue case_bndr scrut_ty con_payload_ty+                                  (zipEqual multiplicities  args')+      ; return $ deleteUE rhs_ue' case_bndr+      }+   }++  | otherwise   -- Scrut-ty is wrong shape+  = zeroUE <$ addErrL (mkBadAltMsg scrut_ty alt)++{-+Note [Validating multiplicities in a case]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose 'MkT :: a %m -> T m a'.+If we are validating 'case (x :: T Many a) of MkT y -> ...',+we have to substitute m := Many in the type of MkT - in particular,+y can be used Many times and that expression would still be linear in x.+We do this by looking at con_payload_ty, which is the type of the datacon+applied to the surrounding arguments.+Testcase: linear/should_compile/MultConstructor++Data constructors containing existential tyvars will then have+Named binders, which are always multiplicity Many.+Testcase: indexed-types/should_compile/GADT1+-}++lintLinearBinder :: SDoc -> Mult -> Mult -> LintM ()+lintLinearBinder doc actual_usage described_usage+  = ensureSubMult actual_usage described_usage err_msg+    where+      err_msg = (text "Multiplicity of variable does not agree with its context"+                $$ doc+                $$ ppr actual_usage+                $$ text "Annotation:" <+> ppr described_usage)++{-+************************************************************************+*                                                                      *+\subsection[lint-types]{Types}+*                                                                      *+************************************************************************+-}++-- When we lint binders, we (one at a time and in order):+--  1. Lint var types or kinds (possibly substituting)+--  2. Add the binder to the in scope set, and if its a coercion var,+--     we may extend the substitution to reflect its (possibly) new kind+lintBinders :: HasDebugCallStack => BindingSite -> [InVar] -> ([OutVar] -> LintM a) -> LintM a+lintBinders _    []         linterF = linterF []+lintBinders site (var:vars) linterF = lintBinder site var $ \var' ->+                                      lintBinders site vars $ \ vars' ->+                                      linterF (var':vars')++-- If you edit this function, you may need to update the GHC formalism+-- See Note [GHC Formalism]+lintBinder :: HasDebugCallStack => BindingSite -> InVar -> (OutVar -> LintM a) -> LintM a+lintBinder site var linterF+  | isTyCoVar var = lintTyCoBndr var linterF+  | otherwise     = lintIdBndr NotTopLevel site var linterF++lintTyCoBndr :: HasDebugCallStack => TyCoVar -> (OutTyCoVar -> LintM a) -> LintM a+lintTyCoBndr tcv thing_inside+  = do { tcv_type' <- lintTypeAndSubst (varType tcv)+       ; let tcv_kind' = typeKind tcv_type'++         -- See (FORALL1) and (FORALL2) in GHC.Core.Type+       ; if (isTyVar tcv)+         then -- Check that in (forall (a:ki). blah) we have ki:Type+              lintL (isLiftedTypeKind tcv_kind') $+              hang (text "TyVar whose kind does not have kind Type:")+                 2 (ppr tcv <+> dcolon <+> ppr tcv_type' <+> dcolon <+> ppr tcv_kind')+         else -- Check that in (forall (cv::ty). blah),+              -- then ty looks like (t1 ~# t2)+              lintL (isCoVarType tcv_type') $+              text "CoVar with non-coercion type:" <+> pprTyVar tcv++       ; addInScopeTyCoVar tcv tcv_type' thing_inside }++lintIdBndrs :: forall a. TopLevelFlag -> [InId] -> ([OutId] -> LintM a) -> LintM a+lintIdBndrs top_lvl ids thing_inside+  = go ids thing_inside+  where+    go :: [Id] -> ([Id] -> LintM a) -> LintM a+    go []       thing_inside = thing_inside []+    go (id:ids) thing_inside = lintIdBndr top_lvl LetBind id  $ \id' ->+                               go ids                         $ \ids' ->+                               thing_inside (id' : ids')++lintIdBndr :: TopLevelFlag -> BindingSite+           -> InVar -> (OutVar -> LintM a) -> LintM a+-- Do substitution on the type of a binder and add the var with this+-- new type to the in-scope set of the second argument+-- ToDo: lint its rules+lintIdBndr top_lvl bind_site id thing_inside+  = assertPpr (isId id) (ppr id) $+    do { flags <- getLintFlags+       ; checkL (not (lf_check_global_ids flags) || isLocalId id)+                (text "Non-local Id binder" <+> ppr id)+                -- See Note [Checking for global Ids]++       -- Check that if the binder is nested, it is not marked as exported+       ; checkL (not (isExportedId id) || is_top_lvl)+           (mkNonTopExportedMsg id)++       -- Check that if the binder is nested, it does not have an external name+       ; checkL (not (isExternalName (Var.varName id)) || is_top_lvl)+           (mkNonTopExternalNameMsg id)++          -- See Note [Representation polymorphism invariants] in GHC.Core+       ; lintL (isJoinId id || not (lf_check_fixed_rep flags)+                || typeHasFixedRuntimeRep id_ty) $+         text "Binder does not have a fixed runtime representation:" <+> ppr id <+> dcolon <+>+            parens (ppr id_ty <+> dcolon <+> ppr (typeKind id_ty))++       -- Check that a join-id is a not-top-level let-binding+       ; when (isJoinId id) $+         checkL (not is_top_lvl && is_let_bind) $+         mkBadJoinBindMsg id++       -- Check that the Id does not have type (t1 ~# t2) or (t1 ~R# t2);+       -- if so, it should be a CoVar, and checked by lintCoVarBndr+       ; lintL (not (isCoVarType id_ty))+               (text "Non-CoVar has coercion type" <+> ppr id <+> dcolon <+> ppr id_ty)++       -- Check that the lambda binder has no value or OtherCon unfolding.+       -- See #21496+       ; lintL (not (bind_site == LambdaBind && isEvaldUnfolding (idUnfolding id)))+                (text "Lambda binder with value or OtherCon unfolding.")++       ; out_ty <- addLoc (IdTy id) (lintValueType id_ty)++       ; addInScopeId id out_ty thing_inside }+  where+    id_ty = idType id++    is_top_lvl = isTopLevel top_lvl+    is_let_bind = case bind_site of+                    LetBind -> True+                    _       -> False++{-+%************************************************************************+%*                                                                      *+             Types+%*                                                                      *+%************************************************************************+-}++{- Note [Linting types and coercions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Notice that+   lintType     :: InType     -> LintM ()+   lintCoercion :: InCoercion -> LintM ()+Neither returns anything.++If you need the kind of the type, then do `typeKind` and then apply+the ambient substitution using `substTyM`.  Note that the substitution+empty unless there is shadowing or type-lets; and if the substitution is+empty, the `substTyM` is a no-op.++It is better to take the kind and then substitute, rather than substitute+and then take the kind, becaues the kind is usually smaller.++Note: you might wonder if we should apply the same logic to expressions.+Why do we have+  lintExpr :: InExpr -> LintM OutType+Partly inertia; but also taking the type of an expresison involve looking+down a deep chain of let's, whereas that is not true of taking the kind+of a type.  It'd be worth an experiment though.++Historical note: in the olden days we had+   lintType :: InType -> LintM OutType+but that burned a huge amount of allocation building an OutType that was+often discarded, or used only to get its kind.++I also experimented with+   lintType :: InType -> LintM OutKind+but that too was slower.  It is also much simpler to return ()!  If we+return the kind we have to duplicate the logic in `typeKind`; and it is+much worse for coercions.+-}++lintValueType :: Type -> LintM OutType+-- Types only, not kinds+-- Check the type, and apply the substitution to it+-- See Note [Linting type lets]+lintValueType ty+  = addLoc (InType ty) $+    do  { ty' <- lintTypeAndSubst ty+        ; let sk = typeKind ty'+        ; lintL (isTYPEorCONSTRAINT sk) $+          hang (text "Ill-kinded type:" <+> ppr ty)+             2 (text "has kind:" <+> ppr sk)+        ; return ty' }++checkTyCon :: TyCon -> LintM ()+checkTyCon tc+  = checkL (not (isTcTyCon tc)) (text "Found TcTyCon:" <+> ppr tc)++-------------------+lintTypeAndSubst :: InType -> LintM OutType+lintTypeAndSubst ty = do { lintType ty; substTyM ty }+           -- In GHCi we may lint an expression with a free+           -- type variable.  Then it won't be in the+           -- substitution, but it should be in scope++lintType :: InType -> LintM ()+-- See Note [Linting types and coercions]+--+-- If you edit this function, you may need to update the GHC formalism+-- See Note [GHC Formalism]+lintType (TyVarTy tv)+  | not (isTyVar tv)+  = failWithL (mkBadTyVarMsg tv)++  | otherwise+  = do { _ <- lintVarOcc tv+       ; return () }++lintType ty@(AppTy t1 t2)+  | TyConApp {} <- t1+  = failWithL $ text "TyConApp to the left of AppTy:" <+> ppr ty+  | otherwise+  = do { let (fun_ty, arg_tys) = collect t1 [t2]+       ; lintType fun_ty+       ; fun_kind <- substTyM (typeKind fun_ty)+       ; lint_ty_app ty fun_kind arg_tys }+  where+    collect (AppTy f a) as = collect f (a:as)+    collect fun         as = (fun, as)++lintType ty@(TyConApp tc tys)+  | isTypeSynonymTyCon tc || isTypeFamilyTyCon tc+  = do { report_unsat <- lf_report_unsat_syns <$> getLintFlags+       ; lintTySynFamApp report_unsat ty tc tys }++  | Just {} <- tyConAppFunTy_maybe tc tys+    -- We should never see a saturated application of funTyCon; such+    -- applications should be represented with the FunTy constructor.+    -- See Note [Linting function types]+  = failWithL (hang (text "Saturated application of" <+> quotes (ppr tc)) 2 (ppr ty))++  | otherwise  -- Data types, data families, primitive types+  = do { checkTyCon tc+       ; lint_ty_app ty (tyConKind tc) tys }++-- arrows can related *unlifted* kinds, so this has to be separate from+-- a dependent forall.+lintType ty@(FunTy af tw t1 t2)+  = do { lintType t1+       ; lintType t2+       ; lintType tw+       ; lintArrow (text "type or kind" <+> quotes (ppr ty)) af t1 t2 tw }++lintType ty@(ForAllTy {})+  = go [] ty+  where+    go :: [OutTyCoVar] -> InType -> LintM ()+    -- Loop, collecting the forall-binders+    go tcvs ty@(ForAllTy (Bndr tcv _) body_ty)+      | not (isTyCoVar tcv)+      = failWithL (text "Non-TyVar or Non-CoVar bound in type:" <+> ppr ty)++      | otherwise+      = lintTyCoBndr tcv $ \tcv' ->+        do { -- See GHC.Core.TyCo.Rep Note [Unused coercion variable in ForAllTy]+             -- Suspicious because it works on InTyCoVar; c.f. ForAllCo+             when (isCoVar tcv) $+             lintL (anyFreeVarsOfType (== tcv) body_ty) $+             text "Covar does not occur in the body:" <+> (ppr tcv $$ ppr body_ty)++           ; go (tcv' : tcvs) body_ty }++    go tcvs body_ty+      = do { lintType body_ty+           ; lintForAllBody tcvs body_ty }++lintType (CastTy ty co)+  = do { lintType ty+       ; ty_kind <- substTyM (typeKind ty)+       ; co_lk <- lintStarCoercion co+       ; ensureEqTys ty_kind co_lk (mkCastTyErr ty co ty_kind co_lk) }++lintType (LitTy l)       = lintTyLit l+lintType (CoercionTy co) = lintCoercion co++-----------------+lintForAllBody :: [OutTyCoVar] -> InType -> LintM ()+-- Do the checks for the body of a forall-type+lintForAllBody tcvs body_ty+  = do { -- For type variables, check for skolem escape+         -- See Note [Phantom type variables in kinds] in GHC.Core.Type+         -- The kind of (forall cv. th) is liftedTypeKind, so no+         -- need to check for skolem-escape in the CoVar case+         body_kind <- substTyM (typeKind body_ty)+       ; case occCheckExpand tcvs body_kind of+           Just {} -> return ()+           Nothing -> failWithL $+                      hang (text "Variable escape in forall:")+                         2 (vcat [ text "tycovars (reversed):" <+> ppr tcvs+                                 , text "type:" <+> ppr body_ty+                                 , text "kind:" <+> ppr body_kind ])+       ; checkValueType body_kind (text "the body of forall:" <+> ppr body_ty) }++-----------------+lintTySynFamApp :: Bool -> InType -> TyCon -> [InType] -> LintM ()+-- The TyCon is a type synonym or a type family (not a data family)+-- See Note [Linting type synonym applications]+-- c.f. GHC.Tc.Validity.check_syn_tc_app+lintTySynFamApp report_unsat ty tc tys+  | report_unsat   -- Report unsaturated only if report_unsat is on+  , tys `lengthLessThan` tyConArity tc+  = failWithL (hang (text "Un-saturated type application") 2 (ppr ty))++  -- Deal with type synonyms+  | ExpandsSyn tenv rhs tys' <- expandSynTyCon_maybe tc tys+  , let expanded_ty = mkAppTys (substTy (mkTvSubstPrs tenv) rhs) tys'+  = do { when report_unsat $ do { _ <- lintType expanded_ty+                                ; return () }++       ; -- Kind-check the argument types, but without reporting+         -- un-saturated type families/synonyms+       ; setReportUnsat False $+         lint_ty_app ty (tyConKind tc) tys }++  -- Otherwise this must be a type family+  | otherwise+  = lint_ty_app ty (tyConKind tc) tys++-----------------+-- Confirms that a kind is really TYPE r or Constraint+checkValueType :: OutKind -> SDoc -> LintM ()+checkValueType kind doc+  = lintL (isTYPEorCONSTRAINT kind)+          (text "Non-Type-like kind when Type-like expected:" <+> ppr kind $$+           text "when checking" <+> doc)++-----------------+lintArrow :: SDoc -> FunTyFlag -> InType -> InType -> InType -> LintM ()+-- If you edit this function, you may need to update the GHC formalism+-- See Note [GHC Formalism]+lintArrow what af t1 t2 tw  -- Eg lintArrow "type or kind `blah'" k1 k2 kw+                            -- or lintArrow "coercion `blah'" k1 k2 kw+  = do { k1 <- substTyM (typeKind t1)+       ; k2 <- substTyM (typeKind t2)+       ; kw <- substTyM (typeKind tw)+       ; unless (isTYPEorCONSTRAINT k1) (report (text "argument")     t1 k1)+       ; unless (isTYPEorCONSTRAINT k2) (report (text "result")       t2 k2)+       ; unless (isMultiplicityTy kw)   (report (text "multiplicity") tw kw)++       ; let real_af = chooseFunTyFlag t1 t2+       ; unless (real_af == af) $ addErrL $+         hang (text "Bad FunTyFlag")+            2 (vcat [ text "FunTyFlag =" <+> ppr af+                    , text "Computed FunTyFlag =" <+> ppr real_af+                    , text "in" <+> what ]) }+  where+    report ar t k = addErrL (hang (text "Ill-kinded" <+> ar)+                                2 (vcat [ ppr t <+> dcolon <+> ppr k+                                        , text "in" <+> what ]))++-----------------+lintTyLit :: TyLit -> LintM ()+lintTyLit (NumTyLit n)+  | n >= 0    = return ()+  | otherwise = failWithL msg+    where msg = text "Negative type literal:" <+> integer n+lintTyLit (StrTyLit _) = return ()+lintTyLit (CharTyLit _) = return ()++-----------------+lint_ty_app :: InType -> OutKind -> [InType] -> LintM ()+lint_ty_app ty = lint_tyco_app (text "type" <+> quotes (ppr ty))++lint_co_app :: HasDebugCallStack => Coercion -> OutKind -> [InType] -> LintM ()+lint_co_app co = lint_tyco_app (text "coercion" <+> quotes (ppr co))++lint_tyco_app :: SDoc -> OutKind -> [InType] -> LintM ()+lint_tyco_app msg fun_kind arg_tys+    -- See Note [Avoiding compiler perf traps when constructing error messages.]+  = do { _ <- lintApp msg (\ty     -> do { lintType ty; substTyM ty })+                            (\ty _ _ -> do { lintType ty; ki <- substTyM (typeKind ty); return (ki,()) })+                            fun_kind arg_tys ()+       ; return () }++----------------+lintApp :: forall in_a acc. Outputable in_a =>+             SDoc+          -> (in_a -> LintM OutType)                        -- Lint the thing and return its value+          -> (in_a -> Mult -> acc -> LintM (OutKind, acc))  -- Lint the thing and return its type+          -> OutType+          -> [in_a]                               -- The arguments, always "In" things+          -> acc                                  -- Used (only) for UsageEnv in /term/ applications+          -> LintM (OutType,acc)+-- lintApp is a performance-critical function, which deals with multiple+-- applications such as  (/\a./\b./\c. expr) @ta @tb @tc+-- When returning the type of this expression we want to avoid substituting a:=ta,+-- and /then/ substituting b:=tb, etc.  That's quadratic, and can be a huge+-- perf hole.  So we gather all the arguments [in_a], and then gather the+-- substitution incrementally in the `go` loop.+--+-- lintApp is used:+--    * for term applications (lintCoreArgs)+--    * for type applications (lint_ty_app)+--    * for coercion application (lint_co_app)+-- To deal with these cases `lintApp` has two higher order arguments;+-- but we specialise it for each call site (by inlining)+{-# INLINE lintApp #-}    -- INLINE: very few call sites;+                          -- not recursive; specialised at its call sites++lintApp msg lint_forall_arg lint_arrow_arg !orig_fun_ty all_args acc+    = do { !in_scope <- getInScope+         -- We need the in_scope set to satisfy the invariant in+         -- Note [The substitution invariant] in GHC.Core.TyCo.Subst+         -- Forcing the in scope set eagerly here reduces allocations by up to 4%.++         ; let init_subst = mkEmptySubst in_scope++               go :: Subst -> OutType -> acc -> [in_a] -> LintM (OutType, acc)+                     -- The Subst applies (only) to the fun_ty+                     -- c.f. GHC.Core.Type.piResultTys, which has a similar loop++               go subst fun_ty acc []+                 = return (substTy subst fun_ty, acc)++               go subst (ForAllTy (Bndr tv _vis) body_ty) acc (arg:args)+                 = do { arg' <- lint_forall_arg arg+                      ; let tv_kind = substTy subst (varType tv)+                            karg'   = typeKind arg'+                            subst'  = extendTCvSubst subst tv arg'+                      ; ensureEqTys karg' tv_kind $+                        lint_app_fail_msg msg orig_fun_ty all_args+                            (hang (text "Forall:" <+> (ppr tv $$ ppr tv_kind))+                                2 (ppr arg' <+> dcolon <+> ppr karg'))+                      ; go subst' body_ty acc args }++               go subst fun_ty@(FunTy _ mult exp_arg_ty res_ty) acc (arg:args)+                 = do { (arg_ty, acc') <- lint_arrow_arg arg (substTy subst mult) acc+                      ; ensureEqTys (substTy subst exp_arg_ty) arg_ty $+                        lint_app_fail_msg msg orig_fun_ty all_args+                            (hang (text "Fun:" <+> ppr fun_ty)+                                2 (vcat [ text "exp_arg_ty:" <+> ppr exp_arg_ty+                                        , text "arg:" <+> ppr arg <+> dcolon <+> ppr arg_ty ]))+                      ; go subst res_ty acc' args }++               go subst fun_ty acc args+                 | Just fun_ty' <- coreView fun_ty+                 = go subst fun_ty' acc args++                 | not (isEmptyTCvSubst subst)  -- See Note [Care with kind instantiation]+                 = go init_subst (substTy subst fun_ty) acc args++                 | otherwise+                 = failWithL (lint_app_fail_msg msg orig_fun_ty all_args+                                  (text "Not a fun:" <+> (ppr fun_ty $$ ppr args)))++         ; go init_subst orig_fun_ty acc all_args }++-- This is a top level definition to ensure we pass all variables of the error message+-- explicitly and don't capture them as free variables. Otherwise this binder might+-- become a thunk that get's allocated in the hot code path.+-- See Note [Avoiding compiler perf traps when constructing error messages.]+lint_app_fail_msg :: (Outputable a2) => SDoc -> OutType -> a2 -> SDoc -> SDoc+lint_app_fail_msg msg kfn arg_tys extra+  = vcat [ hang (text "Application error in") 2 msg+         , nest 2 (text "Function type =" <+> ppr kfn)+         , nest 2 (text "Args =" <+> ppr arg_tys)+         , extra ]++{- *********************************************************************+*                                                                      *+        Linting rules+*                                                                      *+********************************************************************* -}++lintCoreRule :: OutVar -> OutType -> CoreRule -> LintM ()+lintCoreRule _ _ (BuiltinRule {})+  = return ()  -- Don't bother++lintCoreRule fun fun_ty rule@(Rule { ru_name = name, ru_bndrs = bndrs+                                   , ru_args = args, ru_rhs = rhs })+  = lintBinders LambdaBind bndrs $ \ _ ->+    do { (lhs_ty, _) <- lintCoreArgs (fun_ty, zeroUE) args+       ; (rhs_ty, _) <- case idJoinPointHood fun of+                     JoinPoint join_arity+                       -> do { checkL (args `lengthIs` join_arity) $+                                mkBadJoinPointRuleMsg fun join_arity rule+                               -- See Note [Rules for join points]+                             ; lintCoreExpr rhs }+                     _ -> markAllJoinsBad $ lintCoreExpr rhs+       ; ensureEqTys lhs_ty rhs_ty $+         (rule_doc <+> vcat [ text "lhs type:" <+> ppr lhs_ty+                            , text "rhs type:" <+> ppr rhs_ty+                            , text "fun_ty:" <+> ppr fun_ty ])+       ; let bad_bndrs = filter is_bad_bndr bndrs++       ; checkL (null bad_bndrs)+                (rule_doc <+> text "unbound" <+> ppr bad_bndrs)+            -- See Note [Linting rules]+    }+  where+    rule_doc = text "Rule" <+> doubleQuotes (ftext name) <> colon++    lhs_fvs = exprsFreeVars args+    rhs_fvs = exprFreeVars rhs++    is_bad_bndr :: Var -> Bool+    -- See Note [Unbound RULE binders] in GHC.Core.Rules+    is_bad_bndr bndr = not (bndr `elemVarSet` lhs_fvs)+                    && bndr `elemVarSet` rhs_fvs+                    && isNothing (isReflCoVar_maybe bndr)+++{- Note [Linting rules]+~~~~~~~~~~~~~~~~~~~~~~~+It's very bad if simplifying a rule means that one of the template+variables (ru_bndrs) that /is/ mentioned on the RHS becomes+not-mentioned in the LHS (ru_args).  How can that happen?  Well, in #10602,+SpecConstr stupidly constructed a rule like++  forall x,c1,c2.+     f (x |> c1 |> c2) = ....++But simplExpr collapses those coercions into one.  (Indeed in #10602,+it collapsed to the identity and was removed altogether.)++We don't have a great story for what to do here, but at least+this check will nail it.++NB (#11643): it's possible that a variable listed in the+binders becomes not-mentioned on both LHS and RHS.  Here's a silly+example:+   RULE forall x y. f (g x y) = g (x+1) (y-1)+And suppose worker/wrapper decides that 'x' is Absent.  Then+we'll end up with+   RULE forall x y. f ($gw y) = $gw (x+1)+This seems sufficiently obscure that there isn't enough payoff to+try to trim the forall'd binder list.++Note [Rules for join points]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A join point cannot be partially applied. However, the left-hand side of a rule+for a join point is effectively a *pattern*, not a piece of code, so there's an+argument to be made for allowing a situation like this:++  join $sj :: Int -> Int -> String+       $sj n m = ...+       j :: forall a. Eq a => a -> a -> String+       {-# RULES "SPEC j" jump j @ Int $dEq = jump $sj #-}+       j @a $dEq x y = ...++Applying this rule can't turn a well-typed program into an ill-typed one, so+conceivably we could allow it. But we can always eta-expand such an+"undersaturated" rule (see 'GHC.Core.Opt.Arity.etaExpandToJoinPointRule'), and in fact+the simplifier would have to in order to deal with the RHS. So we take a+conservative view and don't allow undersaturated rules for join points. See+Note [Join points and unfoldings/rules] in "GHC.Core.Opt.OccurAnal" for further discussion.+-}++{-+************************************************************************+*                                                                      *+         Linting coercions+*                                                                      *+************************************************************************+-}++{- Note [Asymptotic efficiency]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When linting coercions (and types actually) we return a linted+(substituted) coercion.  Then we often have to take the coercionKind of+that returned coercion. If we get long chains, that can be asymptotically+inefficient, notably in+* TransCo+* InstCo+* SelCo (cf #9233)+* LRCo++But the code is simple.  And this is only Lint.  Let's wait to see if+the bad perf bites us in practice.++A solution would be to return the kind and role of the coercion,+as well as the linted coercion.  Or perhaps even *only* the kind and role,+which is what used to happen.   But that proved tricky and error prone+(#17923), so now we return the coercion.+-}+++-- lintStarCoercion lints a coercion, confirming that its lh kind and+-- its rh kind are both *; also ensures that the role is Nominal+-- Returns the lh kind+lintStarCoercion :: InCoercion -> LintM OutType+lintStarCoercion g+  = do { lintCoercion g+       ; Pair t1 t2 <- substCoKindM g+       ; checkValueType (typeKind t1) (text "the kind of the left type in" <+> ppr g)+       ; checkValueType (typeKind t2) (text "the kind of the right type in" <+> ppr g)+       ; lintRole g Nominal (coercionRole g)+       ; return t1 }++substCoKindM :: InCoercion -> LintM (Pair OutType)+substCoKindM co+  = do { let !(Pair lk rk) = coercionKind co+       ; lk' <- substTyM lk+       ; rk' <- substTyM rk+       ; return (Pair lk' rk') }++lintCoercion :: HasDebugCallStack => InCoercion -> LintM ()+-- See Note [Linting types and coercions]+--+-- If you edit this function, you may need to update the GHC formalism+-- See Note [GHC Formalism]++lintCoercion (CoVarCo cv)+  | not (isCoVar cv)+  = failWithL (hang (text "Bad CoVarCo:" <+> ppr cv)+                  2 (text "With offending type:" <+> ppr (varType cv)))++  | otherwise  -- C.f. lintType (TyVarTy tv), which has better docs+  = do { _ <- lintVarOcc cv; return () }++lintCoercion (Refl ty)          = lintType ty+lintCoercion (GRefl _r ty MRefl) = lintType ty++lintCoercion (GRefl _r ty (MCo co))+  = do { lintType ty+       ; lintCoercion co+       ; tk <- substTyM (typeKind ty)+       ; tl <- substTyM (coercionLKind co)+       ; ensureEqTys tk tl $+         hang (text "GRefl coercion kind mis-match:" <+> ppr co)+            2 (vcat [ppr ty, ppr tk, ppr tl])+       ; lintRole co Nominal (coercionRole co) }++lintCoercion co@(TyConAppCo r tc cos)+  | Just {} <- tyConAppFunCo_maybe r tc cos+  = failWithL (hang (text "Saturated application of" <+> quotes (ppr tc))+                  2 (ppr co))+    -- All saturated TyConAppCos should be FunCos++  | Just {} <- synTyConDefn_maybe tc+  = failWithL (text "Synonym in TyConAppCo:" <+> ppr co)++  | otherwise+  = do { checkTyCon tc+       ; mapM_ lintCoercion cos+       ; let tc_kind = tyConKind tc+       ; lint_co_app co tc_kind (map coercionLKind cos)+       ; lint_co_app co tc_kind (map coercionRKind cos)+       ; zipWithM_ (lintRole co) (tyConRoleListX r tc) (map coercionRole cos) }+++lintCoercion co@(AppCo co1 co2)+  | TyConAppCo {} <- co1+  = failWithL (text "TyConAppCo to the left of AppCo:" <+> ppr co)+  | Just (TyConApp {}, _) <- isReflCo_maybe co1+  = failWithL (text "Refl (TyConApp ...) to the left of AppCo:" <+> ppr co)+  | otherwise+  = do { lintCoercion co1+       ; lintCoercion co2+       ; let !(Pair lt1 rt1) = coercionKind co1+       ; lk1 <- substTyM (typeKind lt1)+       ; rk1 <- substTyM (typeKind rt1)+       ; lint_co_app co lk1 [coercionLKind co2]+       ; lint_co_app co rk1 [coercionRKind co2]++       ; let r2 = coercionRole co2+       ; if coercionRole co1 == Phantom+         then lintL (r2 == Phantom || r2 == Nominal)+                     (text "Second argument in AppCo cannot be R:" $$+                      ppr co)+         else lintRole co Nominal r2 }++----------+lintCoercion co@(ForAllCo {})+-- See Note [ForAllCo] in GHC.Core.TyCo.Rep for the typing rule for ForAllCo+  = do { _ <- go [] co; return () }+  where+    go :: [OutTyCoVar]   -- Binders in reverse order+       -> InCoercion -> LintM Role+    go tcvs co@(ForAllCo { fco_tcv = tcv, fco_visL = visL, fco_visR = visR+                         , fco_kind = kind_co, fco_body = body_co })+      | not (isTyCoVar tcv)+      = failWithL (text "Non tyco binder in ForAllCo:" <+> ppr co)++      | otherwise+      = do { lk <- lintStarCoercion kind_co+           ; lintTyCoBndr tcv $ \tcv' ->+        do { ensureEqTys (varType tcv') lk $+             text "Kind mis-match in ForallCo" <+> ppr co++           -- I'm not very sure about this part, because it traverses body_co+           -- but at least it's on a cold path (a ForallCo for a CoVar)+           -- Also it works on InTyCoVar and InCoercion, which is suspect+           ; when (isCoVar tcv) $+             do { lintL (visL == coreTyLamForAllTyFlag && visR == coreTyLamForAllTyFlag) $+                  text "Invalid visibility flags in CoVar ForAllCo" <+> ppr co+                  -- See (FC7) in Note [ForAllCo] in GHC.Core.TyCo.Rep+                ; lintL (almostDevoidCoVarOfCo tcv body_co) $+                  text "Covar can only appear in Refl and GRefl: " <+> ppr co }+                  -- See (FC6) in Note [ForAllCo] in GHC.Core.TyCo.Rep++           ; role <- go (tcv':tcvs) body_co++           ; when (role == Nominal) $+             lintL (visL `eqForAllVis` visR) $+             text "Nominal ForAllCo has mismatched visibilities: " <+> ppr co++           ; return role } }++    go tcvs body_co+      = do { lintCoercion body_co++           -- Need to check that+           --    (forall (tcv:k1). lty) and+           --    (forall (tcv:k2). rty[(tcv:k2) |> sym kind_co/tcv])+           -- are both well formed, including the skolem escape check.+           -- Easiest way is to call lintForAllBody for each+           ; let Pair lty rty = coercionKind body_co+           ; lintForAllBody tcvs lty+           ; lintForAllBody tcvs rty++           ; return (coercionRole body_co) }+++lintCoercion (FunCo { fco_role = r, fco_afl = afl, fco_afr = afr+                    , fco_mult = cow, fco_arg = co1, fco_res = co2 })+  = do { lintCoercion co1+       ; lintCoercion co2+       ; lintCoercion cow+       ; let Pair lt1 rt1 = coercionKind co1+             Pair lt2 rt2 = coercionKind co2+             Pair ltw rtw = coercionKind cow+       ; lintArrow (bad_co_msg "arrowl") afl lt1 lt2 ltw+       ; lintArrow (bad_co_msg "arrowr") afr rt1 rt2 rtw+       ; lintRole co1 r (coercionRole co1)+       ; lintRole co2 r (coercionRole co2)+       ; let expected_mult_role = case r of+                                    Phantom -> Phantom+                                    _ -> Nominal+       ; lintRole cow expected_mult_role (coercionRole cow) }+  where+    bad_co_msg s = hang (text "Bad coercion" <+> parens (text s))+                      2 (vcat [ text "afl:" <+> ppr afl+                              , text "afr:" <+> ppr afr+                              , text "arg_co:" <+> ppr co1+                              , text "res_co:" <+> ppr co2 ])++-- See Note [Bad unsafe coercion]+lintCoercion co@(UnivCo { uco_role = r, uco_prov = prov+                        , uco_lty = ty1, uco_rty = ty2, uco_deps = deps })+  = do { -- Check the role.  PhantomProv must have Phantom role, otherwise any role is fine+         case prov of+            PhantomProv -> lintRole co Phantom r+            _           -> return ()++       -- Check the to and from types+       ; lintType ty1+       ; lintType ty2+       ; tk1 <- substTyM (typeKind ty1)+       ; tk2 <- substTyM (typeKind ty2)++       ; when (r /= Phantom && isTYPEorCONSTRAINT tk1 && isTYPEorCONSTRAINT tk2)+              (checkTypes ty1 ty2)++       -- Check the coercions on which this UnivCo depends+       ; mapM_ lintCoercion deps }+   where+     report s = hang (text $ "Unsafe coercion: " ++ s)+                     2 (vcat [ text "From:" <+> ppr ty1+                             , text "  To:" <+> ppr ty2])+     isUnBoxed :: PrimRep -> Bool+     isUnBoxed = not . isGcPtrRep++       -- see #9122 for discussion of these checks+     checkTypes t1 t2+       = do { checkWarnL fixed_rep_1+                         (report "left-hand type does not have a fixed runtime representation")+            ; checkWarnL fixed_rep_2+                         (report "right-hand type does not have a fixed runtime representation")+            ; when (fixed_rep_1 && fixed_rep_2) $+              do { checkWarnL (reps1 `equalLength` reps2)+                              (report "between values with different # of reps")+                 ; zipWithM_ validateCoercion reps1 reps2 }}+       where+         fixed_rep_1 = typeHasFixedRuntimeRep t1+         fixed_rep_2 = typeHasFixedRuntimeRep t2++         -- don't look at these unless lev_poly1/2 are False+         -- Otherwise, we get #13458+         reps1 = typePrimRep t1+         reps2 = typePrimRep t2++     validateCoercion :: PrimRep -> PrimRep -> LintM ()+     validateCoercion rep1 rep2+       = do { platform <- getPlatform+            ; checkWarnL (isUnBoxed rep1 == isUnBoxed rep2)+                         (report "between unboxed and boxed value")+            ; checkWarnL (TyCon.primRepSizeB platform rep1+                           == TyCon.primRepSizeB platform rep2)+                         (report "between unboxed values of different size")+            ; let fl = liftM2 (==) (TyCon.primRepIsFloat rep1)+                                   (TyCon.primRepIsFloat rep2)+            ; case fl of+                Nothing    -> addWarnL (report "between vector types")+                Just False -> addWarnL (report "between float and integral values")+                _          -> return ()+            }++lintCoercion (SymCo co) = lintCoercion co++lintCoercion co@(TransCo co1 co2)+  = do { lintCoercion co1+       ; lintCoercion co2+       ; rk1 <- substTyM (coercionRKind co1)+       ; lk2 <- substTyM (coercionLKind co2)+       ; ensureEqTys rk1 lk2+               (hang (text "Trans coercion mis-match:" <+> ppr co)+                   2 (vcat [ppr (coercionKind co1), ppr (coercionKind co2)]))+       ; lintRole co (coercionRole co1) (coercionRole co2) }++lintCoercion the_co@(SelCo cs co)+  = do { lintCoercion co+       ; Pair s t <- substCoKindM co++       ; if -- forall (both TyVar and CoVar)+            | Just _ <- splitForAllTyCoVar_maybe s+            , Just _ <- splitForAllTyCoVar_maybe t+            , SelForAll <- cs+            ,   (isForAllTy_ty s && isForAllTy_ty t)+             || (isForAllTy_co s && isForAllTy_co t)+            -> return ()++            -- function+            | isFunTy s+            , isFunTy t+            , SelFun {} <- cs+            -> return ()++            -- TyCon+            | Just (tc_s, tys_s) <- splitTyConApp_maybe s+            , Just (tc_t, tys_t) <- splitTyConApp_maybe t+            , tc_s == tc_t+            , SelTyCon n r0 <- cs+            , let co_role = coercionRole co+            , isInjectiveTyCon tc_s co_role+                -- see Note [SelCo and newtypes] in GHC.Core.TyCo.Rep+            , tys_s `equalLength` tys_t+            , tys_s `lengthExceeds` n+            -> do { lintRole the_co (tyConRole co_role tc_s n) r0+                  ; return () }++            | otherwise+            -> failWithL (hang (text "Bad SelCo:")+                             2 (ppr the_co $$ ppr s $$ ppr t)) }++lintCoercion the_co@(LRCo _lr co)+  = do { lintCoercion co+       ; Pair s t <- substCoKindM co+       ; lintRole co Nominal (coercionRole co)+       ; case (splitAppTy_maybe s, splitAppTy_maybe t) of+           (Just {}, Just {}) -> return ()+           _ -> failWithL (hang (text "Bad LRCo:")+                              2 (ppr the_co $$ ppr s $$ ppr t)) }+++lintCoercion orig_co@(InstCo co arg)+  = go co [arg]+  where+    go (InstCo co arg) args = do { lintCoercion arg; go co (arg:args) }+    go co              args = do { lintCoercion co+                                 ; let Pair lty rty = coercionKind co+                                 ; lty' <- substTyM lty+                                 ; rty' <- substTyM rty+                                 ; in_scope <- getInScope+                                 ; let subst = mkEmptySubst in_scope+                                 ; go_args (subst, lty') (subst,rty') args }++    -------------+    go_args :: (Subst, OutType) -> (Subst,OutType) -> [InCoercion]+           -> LintM ()+    go_args _ _ []+      = return ()+    go_args lty rty (arg:args)+      = do { (lty1, rty1)  <- go_arg lty rty arg+           ; go_args lty1 rty1 args }++    -------------+    go_arg :: (Subst, OutType) -> (Subst,OutType) -> InCoercion+           -> LintM ((Subst,OutType), (Subst,OutType))+    go_arg (lsubst,lty) (rsubst,rty) arg+      = do { lintRole arg Nominal (coercionRole arg)+           ; Pair arg_lty arg_rty <- substCoKindM arg++           ; case (splitForAllTyCoVar_maybe lty, splitForAllTyCoVar_maybe rty) of+              -- forall over tvar+                (Just (ltv,lty1), Just (rtv,rty1))+                  | typeKind arg_lty `eqType` substTy lsubst (tyVarKind ltv)+                  , typeKind arg_rty `eqType` substTy rsubst (tyVarKind rtv)+                  -> return ( (extendTCvSubst lsubst ltv arg_lty, lty1)+                            , (extendTCvSubst rsubst rtv arg_rty, rty1) )+                  | otherwise+                  -> failWithL (hang (text "Kind mis-match in inst coercion")+                                   2 (vcat [ text "arg"  <+> ppr arg+                                           , text "lty"  <+> ppr lty <+> dcolon <+> ppr (typeKind lty)+                                           , text "rty"  <+> ppr rty <+> dcolon <+> ppr (typeKind rty)+                                           , text "arg_lty" <+> ppr arg_lty <+> dcolon <+> ppr (typeKind arg_lty)+                                           , text "arg_rty" <+> ppr arg_rty <+> dcolon <+> ppr (typeKind arg_rty)+                                           , text "ltv" <+> ppr ltv <+> dcolon <+> ppr (tyVarKind ltv)+                                           , text "rtv" <+> ppr rtv <+> dcolon <+> ppr (tyVarKind rtv) ]))++                _ -> failWithL (text "Bad argument of inst" <+> ppr orig_co) }++lintCoercion this_co@(AxiomCo ax cos)+  = do { mapM_ lintCoercion cos+       ; lint_roles 0 (coAxiomRuleArgRoles ax) cos+       ; prs <- mapM substCoKindM cos+       ; lint_ax ax prs }++  where+    lint_ax :: CoAxiomRule -> [Pair OutType] -> LintM ()+    lint_ax (BuiltInFamRew  bif) prs+      = checkL (isJust (bifrw_proves bif prs))  bad_bif+    lint_ax (BuiltInFamInj bif) prs+      = checkL (case prs of+                  [pr] -> isJust (bifinj_proves bif pr)+                  _    -> False)+               bad_bif+    lint_ax (UnbranchedAxiom ax) prs+      = lintBranch this_co (coAxiomTyCon ax) (coAxiomSingleBranch ax) prs+    lint_ax (BranchedAxiom ax ind) prs+      = do { checkL (0 <= ind && ind < numBranches (coAxiomBranches ax))+                    (bad_ax this_co (text "index out of range"))+           ; lintBranch this_co (coAxiomTyCon ax) (coAxiomNthBranch ax ind) prs }++    bad_bif = bad_ax this_co (text "Proves returns Nothing")++    err :: forall a. String -> [SDoc] -> LintM a+    err m xs  = failWithL $+                hang (text m) 2 $ vcat (text "Rule:" <+> ppr ax : xs)++    lint_roles n (e : es) (co:cos)+      | e == coercionRole co+      = lint_roles (n+1) es cos+      | otherwise = err "Argument roles mismatch"+                        [ text "In argument:" <+> int (n+1)+                        , text "Expected:" <+> ppr e+                        , text "Found:" <+> ppr (coercionRole co) ]+    lint_roles _ [] []  = return ()+    lint_roles n [] rs  = err "Too many coercion arguments"+                            [ text "Expected:" <+> int n+                            , text "Provided:" <+> int (n + length rs) ]++    lint_roles n es []  = err "Not enough coercion arguments"+                            [ text "Expected:" <+> int (n + length es)+                            , text "Provided:" <+> int n ]++lintCoercion (KindCo co) = lintCoercion co++lintCoercion (SubCo co)+  = do { lintCoercion co+       ; lintRole co Nominal (coercionRole co) }++lintCoercion (HoleCo h)+  = failWithL (text "Unfilled coercion hole:" <+> ppr h)++{-+Note [Conflict checking for axiom applications]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider the following type family and axiom:++type family Equal (a :: k) (b :: k) :: Bool+type instance where+  Equal a a = True+  Equal a b = False+--+Equal :: forall k::*. k -> k -> Bool+axEqual :: { forall k::*. forall a::k. Equal k a a ~ True+           ; forall k::*. forall a::k. forall b::k. Equal k a b ~ False }++The coercion (axEqual[1] <*> <Int> <Int) is ill-typed, and Lint should reject it.+(Recall that the index is 0-based, so this is the second branch of the axiom.)+The problem is that, on the surface, it seems that++  (axEqual[1] <*> <Int> <Int>) :: (Equal * Int Int ~ False)++and that all is OK. But, all is not OK: we want to use the first branch of the+axiom in this case, not the second. The problem is that the parameters of the+first branch can unify with the supplied coercions, thus meaning that the first+branch should be taken. See also Note [Apartness] in "GHC.Core.FamInstEnv".++For more details, see the section "Branched axiom conflict checking" in+docs/core-spec, which defines the corresponding no_conflict function used by the+Co_AxiomInstCo rule in the section "Coercion typing".+-}++-- | Check to make sure that an axiom application is internally consistent.+-- Returns the conflicting branch, if it exists+-- Note [Conflict checking for axiom applications]+lintBranch :: Coercion -> TyCon-> CoAxBranch -> [Pair Type] -> LintM ()+-- defined here to avoid dependencies in GHC.Core.Coercion+-- If you edit this function, you may need to update the GHC formalism+-- See Note [GHC Formalism] in GHC.Core.Lint+lintBranch this_co fam_tc branch arg_kinds+  | CoAxBranch { cab_tvs = ktvs, cab_cvs = cvs } <- branch+  = do { checkL (arg_kinds `equalLength` (ktvs ++ cvs)) $+                (bad_ax this_co (text "lengths"))++       ; subst <- getSubst+       ; let empty_subst = zapSubst subst+       ; _ <- foldlM check_ki (empty_subst, empty_subst)+                              (zip (ktvs ++ cvs) arg_kinds)++       ; case check_no_conflict target incomps of+            Nothing -> return ()+            Just bad_branch -> failWithL $ bad_ax this_co $+                               text "inconsistent with" <+>+                                 pprCoAxBranch fam_tc bad_branch }+  where+    check_ki (subst_l, subst_r) (ktv, Pair s' t')+      = do { let sk' = typeKind s'+                 tk' = typeKind t'+           ; let ktv_kind_l = substTy subst_l (tyVarKind ktv)+                 ktv_kind_r = substTy subst_r (tyVarKind ktv)+           ; checkL (sk' `eqType` ktv_kind_l)+                    (bad_ax this_co (text "check_ki1" <+> vcat [ ppr this_co, ppr sk', ppr ktv, ppr ktv_kind_l ] ))+           ; checkL (tk' `eqType` ktv_kind_r)+                    (bad_ax this_co (text "check_ki2" <+> vcat [ ppr this_co, ppr tk', ppr ktv, ppr ktv_kind_r ] ))+           ; return (extendTCvSubst subst_l ktv s',+                     extendTCvSubst subst_r ktv t') }++    tvs          = coAxBranchTyVars branch+    cvs          = coAxBranchCoVars branch+    incomps      = coAxBranchIncomps branch+    (tys, cotys) = splitAtList tvs (map pFst arg_kinds)+    co_args      = map stripCoercionTy cotys+    subst        = zipTvSubst tvs tys `composeTCvSubst`+                   zipCvSubst cvs co_args+    target   = Type.substTys subst (coAxBranchLHS branch)++    check_no_conflict :: [Type] -> [CoAxBranch] -> Maybe CoAxBranch+    check_no_conflict _    [] = Nothing+    check_no_conflict flat (b@CoAxBranch { cab_lhs = lhs_incomp } : rest)+         -- See Note [Apartness] in GHC.Core.FamInstEnv+      | SurelyApart <- tcUnifyTysFG alwaysBindFam alwaysBindTv flat lhs_incomp+      = check_no_conflict flat rest+      | otherwise+      = Just b++bad_ax :: Coercion -> SDoc -> SDoc+bad_ax this_co what+    = hang (text "Bad axiom application" <+> parens what) 2 (ppr this_co)+++{-+************************************************************************+*                                                                      *+              Axioms+*                                                                      *+************************************************************************+-}++lintAxioms :: Logger+           -> LintConfig+           -> SDoc -- ^ The source of the linted axioms+           -> [CoAxiom Branched]+           -> IO ()+lintAxioms logger cfg what axioms =+  displayLintResults logger True what (vcat $ map pprCoAxiom axioms) $+  initL cfg $+  do { mapM_ lint_axiom axioms+     ; let axiom_groups = groupWith coAxiomTyCon axioms+     ; mapM_ lint_axiom_group axiom_groups }++lint_axiom :: CoAxiom Branched -> LintM ()+lint_axiom ax@(CoAxiom { co_ax_tc = tc, co_ax_branches = branches+                       , co_ax_role = ax_role })+  = addLoc (InAxiom ax) $+    do { mapM_ (lint_branch tc) branch_list+       ; extra_checks }+  where+    branch_list = fromBranches branches++    extra_checks+      | isNewTyCon tc+      = do { CoAxBranch { cab_tvs     = ax_tvs+                        , cab_eta_tvs = eta_tvs+                        , cab_cvs     = cvs+                        , cab_roles   = roles+                        , cab_lhs     = lhs_tys }+              <- case branch_list of+               [branch] -> return branch+               _        -> failWithL (text "multi-branch axiom with newtype")++           -- The LHS of the axiom is (N lhs_tys)+           -- We expect it to be      (N ax_tvs)+           ; lintL (mkTyVarTys ax_tvs `eqTypes` lhs_tys)+                   (text "Newtype axiom LHS does not match newtype definition")+           ; lintL (null cvs)+                   (text "Newtype axiom binds coercion variables")+           ; lintL (null eta_tvs)  -- See Note [Eta reduction for data families]+                                   -- which is not about newtype axioms+                   (text "Newtype axiom has eta-tvs")+           ; lintL (ax_role == Representational)+                   (text "Newtype axiom role not representational")+           ; lintL (roles `equalLength` ax_tvs)+                   (text "Newtype axiom roles list is the wrong length." $$+                    text "roles:" <+> sep (map ppr roles))+           ; lintL (roles == takeList roles (tyConRoles tc))+                   (vcat [ text "Newtype axiom roles do not match newtype tycon's."+                         , text "axiom roles:" <+> sep (map ppr roles)+                         , text "tycon roles:" <+> sep (map ppr (tyConRoles tc)) ])+           }++      | isFamilyTyCon tc+      = do { if | isTypeFamilyTyCon tc+                  -> lintL (ax_role == Nominal)+                           (text "type family axiom is not nominal")++                | isDataFamilyTyCon tc+                  -> lintL (ax_role == Representational)+                           (text "data family axiom is not representational")++                | otherwise+                  -> addErrL (text "A family TyCon is neither a type family nor a data family:" <+> ppr tc)++           ; mapM_ (lint_family_branch tc) branch_list }++      | otherwise+      = addErrL (text "Axiom tycon is neither a newtype nor a family.")++lint_branch :: TyCon -> CoAxBranch -> LintM ()+lint_branch ax_tc (CoAxBranch { cab_tvs = tvs, cab_cvs = cvs+                              , cab_lhs = lhs_args, cab_rhs = rhs })+  = lintBinders LambdaBind (tvs ++ cvs) $ \_ ->+    do { let lhs = mkTyConApp ax_tc lhs_args+       ; lintType lhs+       ; lintType rhs+       ; lhs_kind <- substTyM (typeKind lhs)+       ; rhs_kind <- substTyM (typeKind rhs)+       ; lintL (not (lhs_kind `typesAreApart` rhs_kind)) $+         hang (text "Inhomogeneous axiom")+            2 (text "lhs:" <+> ppr lhs <+> dcolon <+> ppr lhs_kind $$+               text "rhs:" <+> ppr rhs <+> dcolon <+> ppr rhs_kind) }+         -- Type and Constraint are not Apart, so this test allows+         -- the newtype axiom for a single-method class.  Indeed the+         -- whole reason Type and Constraint are not Apart is to allow+         -- such axioms!++-- these checks do not apply to newtype axioms+lint_family_branch :: TyCon -> CoAxBranch -> LintM ()+lint_family_branch fam_tc br@(CoAxBranch { cab_tvs     = tvs+                                         , cab_eta_tvs = eta_tvs+                                         , cab_cvs     = cvs+                                         , cab_roles   = roles+                                         , cab_lhs     = lhs+                                         , cab_incomps = incomps })+  = do { lintL (isDataFamilyTyCon fam_tc || null eta_tvs)+               (text "Type family axiom has eta-tvs")+       ; lintL (all (`elemVarSet` tyCoVarsOfTypes lhs) tvs)+               (text "Quantified variable in family axiom unused in LHS")+       ; lintL (all isTyFamFree lhs)+               (text "Type family application on LHS of family axiom")+       ; lintL (all (== Nominal) roles)+               (text "Non-nominal role in family axiom" $$+                text "roles:" <+> sep (map ppr roles))+       ; lintL (null cvs)+               (text "Coercion variables bound in family axiom")+       ; forM_ incomps $ \ br' ->+           lintL (not (compatibleBranches br br')) $+           hang (text "Incorrect incompatible branches:")+              2 (vcat [text "Branch:"       <+> ppr br,+                       text "Bogus incomp:" <+> ppr br']) }++lint_axiom_group :: NonEmpty (CoAxiom Branched) -> LintM ()+lint_axiom_group (_  :| []) = return ()+lint_axiom_group (ax :| axs)+  = do { lintL (isOpenFamilyTyCon tc)+               (text "Non-open-family with multiple axioms")+       ; let all_pairs = [ (ax1, ax2) | ax1 <- all_axs+                                      , ax2 <- all_axs ]+       ; mapM_ (lint_axiom_pair tc) all_pairs }+  where+    all_axs = ax : axs+    tc      = coAxiomTyCon ax++lint_axiom_pair :: TyCon -> (CoAxiom Branched, CoAxiom Branched) -> LintM ()+lint_axiom_pair tc (ax1, ax2)+  | Just br1@(CoAxBranch { cab_tvs = tvs1+                         , cab_lhs = lhs1+                         , cab_rhs = rhs1 }) <- coAxiomSingleBranch_maybe ax1+  , Just br2@(CoAxBranch { cab_tvs = tvs2+                         , cab_lhs = lhs2+                         , cab_rhs = rhs2 }) <- coAxiomSingleBranch_maybe ax2+  = lintL (compatibleBranches br1 br2) $+    vcat [ hsep [ text "Axioms", ppr ax1, text "and", ppr ax2+                , text "are incompatible" ]+         , text "tvs1 =" <+> pprTyVars tvs1+         , text "lhs1 =" <+> ppr (mkTyConApp tc lhs1)+         , text "rhs1 =" <+> ppr rhs1+         , text "tvs2 =" <+> pprTyVars tvs2+         , text "lhs2 =" <+> ppr (mkTyConApp tc lhs2)+         , text "rhs2 =" <+> ppr rhs2 ]++  | otherwise+  = addErrL (text "Open type family axiom has more than one branch: either" <+>+             ppr ax1 <+> text "or" <+> ppr ax2)++{-+************************************************************************+*                                                                      *+\subsection[lint-monad]{The Lint monad}+*                                                                      *+************************************************************************+-}++-- If you edit this type, you may need to update the GHC formalism+-- See Note [GHC Formalism]+data LintEnv+  = LE { le_flags :: LintFlags       -- Linting the result of this pass+       , le_loc   :: [LintLocInfo]   -- Locations++       , le_subst :: Subst+                  -- Current substitution, for TyCoVars only.+                  -- Non-CoVar Ids don't appear in here, not even in the InScopeSet+                  -- Used for (a) cloning to avoid shadowing of TyCoVars,+                  --              so that eqType works ok+                  --          (b) substituting for let-bound tyvars, when we have+                  --              (let @a = Int -> Int in ...)++       , le_in_vars :: VarEnv (InVar, OutType)+                    -- Maps an InVar (i.e. its unique) to its binding InVar+                    --    and to its OutType+                    -- /All/ in-scope variables are here (term variables,+                    --    type variables, and coercion variables)+                    -- Used at an occurrence of the InVar++       , le_joins :: IdSet     -- Join points in scope that are valid+                               -- A subset of the InScopeSet in le_subst+                               -- See Note [Join points]++       , le_ue_aliases :: NameEnv UsageEnv+             -- See Note [Linting linearity]+             -- Assigns usage environments to the alias-like binders,+             -- as found in non-recursive lets.+             -- Domain is OutIds++       , le_platform   :: Platform         -- ^ Target platform+       , le_diagOpts   :: DiagOpts         -- ^ Target platform+       }++data LintFlags+  = LF { lf_check_global_ids           :: Bool -- See Note [Checking for global Ids]+       , lf_check_inline_loop_breakers :: Bool -- See Note [Checking for INLINE loop breakers]+       , lf_check_static_ptrs :: StaticPtrCheck -- ^ See Note [Checking StaticPtrs]+       , lf_report_unsat_syns :: Bool -- ^ See Note [Linting type synonym applications]+       , lf_check_linearity :: Bool -- ^ See Note [Linting linearity]+       , lf_check_fixed_rep :: Bool -- See Note [Checking for representation polymorphism]+    }++-- See Note [Checking StaticPtrs]+data StaticPtrCheck+    = AllowAnywhere+        -- ^ Allow 'makeStatic' to occur anywhere.+    | AllowAtTopLevel+        -- ^ Allow 'makeStatic' calls at the top-level only.+    | RejectEverywhere+        -- ^ Reject any 'makeStatic' occurrence.+  deriving Eq++newtype LintM a =+   LintM' { unLintM ::+            LintEnv ->+            WarnsAndErrs ->           -- Warning and error messages so far+            LResult a } -- Result and messages (if any)+++pattern LintM :: (LintEnv -> WarnsAndErrs -> LResult a) -> LintM a+-- See Note [The one-shot state monad trick] in GHC.Utils.Monad+pattern LintM m <- LintM' m+  where+    LintM m = LintM' (oneShot $ \env -> oneShot $ \we -> m env we)+    -- LintM m = LintM' (oneShot $ oneShot m)+{-# COMPLETE LintM #-}++instance Functor (LintM) where+  fmap f (LintM m) = LintM $ \e w -> mapLResult f (m e w)++type WarnsAndErrs = (Bag SDoc, Bag SDoc)++-- Using a unboxed tuple here reduced allocations for a lint heavy+-- file by ~6%. Using MaybeUB reduced them further by another ~12%.+--+-- Warning: if you don't inline the matcher for JustUB etc, Lint becomes+-- /tremendously/ inefficient, and compiling GHC.Tc.Errors.Types (which+-- contains gigantic types) is very very slow indeed. Conclusion: make+-- sure unfoldings are expose in GHC.Data.Unboxed, and that you compile+-- Lint.hs with optimistation on.+type LResult a = (# MaybeUB a, WarnsAndErrs #)++pattern LResult :: MaybeUB a -> WarnsAndErrs -> LResult a+pattern LResult m w = (# m, w #)+{-# COMPLETE LResult #-}++mapLResult :: (a1 -> a2) -> LResult a1 -> LResult a2+mapLResult f (LResult r w) = LResult (fmapMaybeUB f r) w++-- Just for testing.+fromBoxedLResult :: (Maybe a, WarnsAndErrs) -> LResult a+fromBoxedLResult (Just x, errs) = LResult (JustUB x) errs+fromBoxedLResult (Nothing,errs) = LResult NothingUB errs++{- Note [Checking for global Ids]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Before CoreTidy, all locally-bound Ids must be LocalIds, even+top-level ones. See Note [Exported LocalIds] and #9857.++Note [Checking StaticPtrs]+~~~~~~~~~~~~~~~~~~~~~~~~~~+See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable for an overview.++Every occurrence of the function 'makeStatic' should be moved to the+top level by the FloatOut pass.  It's vital that we don't have nested+'makeStatic' occurrences after CorePrep, because we populate the Static+Pointer Table from the top-level bindings. See SimplCore Note [Grand+plan for static forms].++The linter checks that no occurrence is left behind, nested within an+expression. The check is enabled only after the FloatOut, CorePrep,+and CoreTidy passes and only if the module uses the StaticPointers+language extension. Checking more often doesn't help since the condition+doesn't hold until after the first FloatOut pass.++Note [Type substitution]+~~~~~~~~~~~~~~~~~~~~~~~~+Why do we need a type substitution?  Consider+        /\(a:*). \(x:a). /\(a:*). id a x+This is ill typed, because (renaming variables) it is really+        /\(a:*). \(x:a). /\(b:*). id b x+Hence, when checking an application, we can't naively compare x's type+(at its binding site) with its expected type (at a use site).  So we+rename type binders as we go, maintaining a substitution.++The same substitution also supports let-type, current expressed as+        (/\(a:*). body) ty+Here we substitute 'ty' for 'a' in 'body', on the fly.++Note [Linting type synonym applications]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When linting a type-synonym, or type-family, application+  S ty1 .. tyn+we behave as follows (#15057, #T15664):++* If lf_report_unsat_syns = True, and S has arity < n,+  complain about an unsaturated type synonym or type family++* Switch off lf_report_unsat_syns, and lint ty1 .. tyn.++  Reason: catch out of scope variables or other ill-kinded gubbins,+  even if S discards that argument entirely. E.g. (#15012):+     type FakeOut a = Int+     type family TF a+     type instance TF Int = FakeOut a+  Here 'a' is out of scope; but if we expand FakeOut, we conceal+  that out-of-scope error.++  Reason for switching off lf_report_unsat_syns: with+  LiberalTypeSynonyms, GHC allows unsaturated synonyms provided they+  are saturated when the type is expanded. Example+     type T f = f Int+     type S a = a -> a+     type Z = T S+  In Z's RHS, S appears unsaturated, but it is saturated when T is expanded.++* If lf_report_unsat_syns is on, expand the synonym application and+  lint the result.  Reason: want to check that synonyms are saturated+  when the type is expanded.++Note [Linting linearity]+~~~~~~~~~~~~~~~~~~~~~~~~+Lint ignores linearity unless `-dlinear-core-lint` is set.  For why, see below.++* When do we /check linearity/ in Lint?  That is, when is `-dlinear-core-lint`+  lint set?  Answer: we check linearity in the output of the desugarer, shortly+  after type checking.++* When so we /not/ check linearity in Lint?  On all passes after desugaring.  Why?+  Because optimisation passes are not (yet) guaranteed to maintain linearity.+  They should do so semantically (GHC is careful not to duplicate computation)+  but it is much harder to ensure that the statically-checkable constraints of+  Linear Core are maintained. See examples below.++The current Linear Core is described in the wiki at:+https://gitlab.haskell.org/ghc/ghc/-/wikis/linear-types/implementation.++Concretely, "ignore linearity in Lint" specifically means two things:+* In `ensureEqTypes`, use `eqTypeIgnoringMultiplicity`+* In `ensureSubMult`, do nothing++Here are some examples of how the optimiser can break linearity checking.  Other+examples are documented in the linear-type implementation wiki page+[https://gitlab.haskell.org/ghc/ghc/-/wikis/linear-types/implementation#core-to-core-passes]++* EXAMPLE 1: the binder swap transformation+    Consider++      data T = MkT {-# UNPACK #-} !Int++    The wrapper for MkT is++      $wMkT :: Int %1 -> T+      $wMkT n = case %1 n of+        I# n' -> MkT n'++    This introduces, in particular, a `case %1` (this is not actual Haskell or+    Core syntax), where the `%1` means that the `case` expression consumes its+    scrutinee linearly.++    Now, `case %1` interacts with the binder swap optimisation in a non-trivial+    way. Take a slightly modified version of the code for $wMkT:++      case %1 x of z {+        I# n' -> (x, n')+      }++    Binder-swap changes this to++      case %1 x of z {+        I# n' -> let x = z in (x, n')+      }++    This is rejected by `-dlinear-core-lint` because 1/ n' must be used linearly+    2/ `-dlinear-core-lint` recognises a use of `z` as a use of `n'`. So it sees+    two uses of n' where there should be a single one.++* EXAMPLE 2: letrec+    Some optimisations can create a letrec which uses a variable+    linearly, e.g.++      letrec f True = f False+             f False = x+      in f True++    uses 'x' linearly, but this is not seen by the linter, which considers,+    conservatively, that a letrec always has multiplicity Many (in particular+    that every captured free variable must have multiplicity Many). This issue+    is discussed in ticket #18694.++* EXAMPLE 3: rewrite rules+    Ignoring linearity means in particular that `a -> b` and `a %1 -> b` must be+    treated the same by rewrite rules (see also Note [Rewrite rules ignore+    multiplicities in FunTy] in GHC.Core.Unify). Consider++      m :: Bool -> A+      m' :: (Bool -> Bool) -> A+      {- RULES "ex" forall f. m (f True) = m' f -}++      f :: Bool %1 -> A+      x = m (f True)++    The rule "ex" must match . So the linter must accept `m' f`.++* EXAMPLE 4: eta-reduction+   Eta-expansion can change linear functions into unrestricted functions++     f :: A %1 -> B++     g :: A %Many -> B+     g = \x -> f x++   Eta-reduction undoes this and produces:++     g :: A %Many -> B+     g = f++Historical note: In the original linear-types implementation, we had tried to+make every optimisation pass produce code that passes `-dlinear-core-lint`. It+had proved very difficult. We kept finding corner case after corner+case. Furthermore, to attempt to achieve that goal we ended up restricting+transformations when `-dlinear-core-lint` couldn't typecheck the result.++In the future, we may be able to lint the linearity of the output of+Core-to-Core passes (#19165). But this shouldn't be done at the expense of+producing efficient code. Therefore we lay the following principle.++PRINCIPLE: The type system bends to the optimisation, not the other way around.++There is a useful discussion at https://gitlab.haskell.org/ghc/ghc/-/issues/22123++Note [Linting representation-polymorphic builtins]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+As described in Note [Representation-polymorphism checking built-ins], on+top of the two main representation-polymorphism invariants described in the+Note [Representation polymorphism invariants], we must perform additional+representation-polymorphism checks on builtin functions which don't have a+binding, for example to ensure that we don't run afoul of the+representation-polymorphism invariants when eta-expanding.++There are two situations:++  1. Builtins which have skolem type variables which must be instantiated to+     concrete types, such as the RuntimeRep type argument r to the catch# primop.++  2. Representation-polymorphic unlifted newtypes, which must always be instantiated+     at a fixed runtime representation.++For 1, consider for example 'coerce':++  coerce :: forall {r} (a :: TYPE r) (b :: TYPE r). Coercible a b => a -> b++We store in the IdDetails of the coerce Id that the first binder, r, must always+be instantiated to a concrete type. We thus check this in Core Lint: whenever we+see an application of the form++  coerce @{rep1} ...++we ensure that 'rep1' is concrete. This is done in the function "checkRepPolyBuiltinApp".+Moreover, not instantiating these type variables at all is also an error, as+we would again not be able to perform eta-expansion. (This is a bit more theoretical,+as in user programs the typechecker will insert these type applications when+instantiating, but it can still arise when constructing Core expressions).++For 2, whenever we have an unlifted newtype such as++  type RR :: Type -> RuntimeRep+  type family RR a++  type F :: forall (a :: Type) -> TYPE (RR a)+  type family F a++  type N :: forall (a :: Type) -> TYPE (RR a)+  newtype N a = MkN (F a)++and an unsaturated occurrence++  MkN @ty -- NB: no value argument!++we check that the (instantiated) argument type has a fixed runtime representation.+This is done in the function "checkRepPolyNewtypeApp".+-}++instance Applicative LintM where+      pure x = LintM $ \ _ errs -> LResult (JustUB x) errs+                                   --(Just x, errs)+      (<*>) = ap++instance Monad LintM where+  m >>= k  = LintM (\ env errs ->+                       let res = unLintM m env errs in+                         case res of+                           LResult (JustUB r) errs' -> unLintM (k r) env errs'+                           LResult NothingUB errs' -> LResult NothingUB errs'+                    )+                          --  LError errs'-> LError errs')+                      --  let (res, errs') = unLintM m env errs in+                          --  Just r -> unLintM (k r) env errs'+                          --  Nothing -> (Nothing, errs'))++instance MonadFail LintM where+    fail err = failWithL (text err)++getPlatform :: LintM Platform+getPlatform = LintM (\ e errs -> (LResult (JustUB $ le_platform e) errs))++data LintLocInfo+  = RhsOf Id            -- The variable bound+  | OccOf Id            -- Occurrence of id+  | LambdaBodyOf Id     -- The lambda-binder+  | RuleOf Id           -- Rules attached to a binder+  | UnfoldingOf Id      -- Unfolding of a binder+  | BodyOfLet Id        -- The let-bound variable+  | BodyOfLetRec [Id]   -- The binders of the let+  | CaseAlt CoreAlt     -- Case alternative+  | CasePat CoreAlt     -- The *pattern* of the case alternative+  | CaseTy CoreExpr     -- The type field of a case expression+                        -- with this scrutinee+  | IdTy Id             -- The type field of an Id binder+  | AnExpr CoreExpr     -- Some expression+  | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which)+  | TopLevelBindings+  | InType Type         -- Inside a type+  | InCo   Coercion     -- Inside a coercion+  | InAxiom (CoAxiom Branched)   -- Inside a CoAxiom++data LintConfig = LintConfig+  { l_diagOpts   :: !DiagOpts         -- ^ Diagnostics opts+  , l_platform   :: !Platform         -- ^ Target platform+  , l_flags      :: !LintFlags        -- ^ Linting the result of this pass+  , l_vars       :: ![Var]            -- ^ 'Id's that should be treated as being in scope+  }++initL :: LintConfig+      -> LintM a            -- ^ Action to run+      -> WarnsAndErrs+initL cfg m+  = case unLintM m env (emptyBag, emptyBag) of+      LResult (JustUB _) errs -> errs+      LResult NothingUB errs@(_, e) | not (isEmptyBag e) -> errs+                                    | otherwise -> pprPanic ("Bug in Lint: a failure occurred " +++                                                      "without reporting an error message") empty+  where+    vars = l_vars cfg+    env = LE { le_flags   = l_flags cfg+             , le_subst   = mkEmptySubst (mkInScopeSetList vars)+             , le_in_vars = mkVarEnv [ (v,(v, varType v)) | v <- vars ]+             , le_joins   = emptyVarSet+             , le_loc     = []+             , le_ue_aliases = emptyNameEnv+             , le_platform = l_platform cfg+             , le_diagOpts = l_diagOpts cfg+             }++setReportUnsat :: Bool -> LintM a -> LintM a+-- Switch off lf_report_unsat_syns+setReportUnsat ru thing_inside+  = LintM $ \ env errs ->+    let env' = env { le_flags = (le_flags env) { lf_report_unsat_syns = ru } }+    in unLintM thing_inside env' errs++-- See Note [Checking for representation polymorphism]+noFixedRuntimeRepChecks :: LintM a -> LintM a+noFixedRuntimeRepChecks thing_inside+  = LintM $ \env errs ->+    let env' = env { le_flags = (le_flags env) { lf_check_fixed_rep = False } }+    in unLintM thing_inside env' errs++getLintFlags :: LintM LintFlags+getLintFlags = LintM $ \ env errs -> fromBoxedLResult (Just (le_flags env), errs)++checkL :: Bool -> SDoc -> LintM ()+checkL True  _   = return ()+checkL False msg = failWithL msg++-- like checkL, but relevant to type checking+lintL :: Bool -> SDoc -> LintM ()+lintL = checkL++checkWarnL :: Bool -> SDoc -> LintM ()+checkWarnL True   _  = return ()+checkWarnL False msg = addWarnL msg++failWithL :: SDoc -> LintM a+failWithL msg = LintM $ \ env (warns,errs) ->+                fromBoxedLResult (Nothing, (warns, addMsg True env errs msg))++addErrL :: SDoc -> LintM ()+addErrL msg = LintM $ \ env (warns,errs) ->+              fromBoxedLResult (Just (), (warns, addMsg True env errs msg))++addWarnL :: SDoc -> LintM ()+addWarnL msg = LintM $ \ env (warns,errs) ->+              fromBoxedLResult (Just (), (addMsg True env warns msg, errs))++addMsg :: Bool -> LintEnv ->  Bag SDoc -> SDoc -> Bag SDoc+addMsg show_context env msgs msg+  = assertPpr (notNull loc_msgs) msg $+    msgs `snocBag` mk_msg msg+  where+   loc_msgs :: [(SrcLoc, SDoc)]  -- Innermost first+   loc_msgs = map dumpLoc (le_loc env)++   cxt_doc = vcat [ vcat $ reverse $ map snd loc_msgs+                  , text "Substitution:" <+> ppr (le_subst env) ]++   context | show_context  = cxt_doc+           | otherwise     = whenPprDebug cxt_doc+     -- Print voluminous info for Lint errors+     -- but not for warnings++   msg_span = case [ span | (loc,_) <- loc_msgs+                          , let span = srcLocSpan loc+                          , isGoodSrcSpan span ] of+               []    -> noSrcSpan+               (s:_) -> s+   !diag_opts = le_diagOpts env+   mk_msg msg = mkLocMessage (mkMCDiagnostic diag_opts WarningWithoutFlag Nothing) msg_span+                             (msg $$ context)++addLoc :: LintLocInfo -> LintM a -> LintM a+addLoc extra_loc m+  = LintM $ \ env errs ->+    unLintM m (env { le_loc = extra_loc : le_loc env }) errs++inCasePat :: LintM Bool         -- A slight hack; see the unique call site+inCasePat = LintM $ \ env errs -> fromBoxedLResult (Just (is_case_pat env), errs)+  where+    is_case_pat (LE { le_loc = CasePat {} : _ }) = True+    is_case_pat _other                           = False++addInScopeId :: InId -> OutType -> (OutId -> LintM a) -> LintM a+-- Unlike addInScopeTyCoVar, this function does no cloning; Ids never get cloned+addInScopeId in_id out_ty thing_inside+  = LintM $ \ env errs ->+    let !(out_id, env') = add env+    in unLintM (thing_inside out_id) env' errs++  where+    add env@(LE { le_in_vars = id_vars, le_joins = join_set+                , le_ue_aliases = aliases, le_subst = subst })+      = (out_id, env1)+      where+        env1 = env { le_in_vars = in_vars', le_joins = join_set', le_ue_aliases = aliases' }++        in_vars' = extendVarEnv id_vars in_id (in_id, out_ty)+        aliases' = delFromNameEnv aliases (idName in_id)+           -- aliases': when shadowing an alias, we need to make sure the+           -- Id is no longer classified as such. E.g.+           --   let x = <e1> in case x of x { _DEFAULT -> <e2> }+           -- Occurrences of 'x' in e2 shouldn't count as occurrences of e1.++        -- A very tiny optimisation, not sure if it's really worth it+        -- Short-cut when the substitution is a no-op+        out_id | isEmptyTCvSubst subst = in_id+               | otherwise             = setIdType in_id out_ty++        join_set'+          | isJoinId out_id = extendVarSet join_set in_id -- Overwrite with new arity+          | otherwise       = delVarSet    join_set in_id -- Remove any existing binding++addInScopeTyCoVar :: InTyCoVar -> OutType -> (OutTyCoVar -> LintM a) -> LintM a+-- This function clones to avoid shadowing of TyCoVars+addInScopeTyCoVar tcv tcv_type thing_inside+  = LintM $ \ env@(LE { le_in_vars = in_vars, le_subst = subst }) errs ->+    let (tcv', subst') = subst_bndr subst+        env' = env { le_in_vars = extendVarEnv in_vars tcv (tcv, tcv_type)+                   , le_subst = subst' }+    in unLintM (thing_inside tcv') env' errs+  where+    subst_bndr subst+      | isEmptyTCvSubst subst                -- No change in kind+      , not (tcv `elemInScopeSet` in_scope)  -- Not already in scope+      = -- Do not extend the substitution, just the in-scope set+        (if (varType tcv `eqType` tcv_type) then (\x->x) else+          pprTrace "addInScopeTyCoVar" (+            vcat [ text "tcv" <+> ppr tcv <+> dcolon <+> ppr (varType tcv)+                 , text "tcv_type" <+> ppr tcv_type ])) $+        (tcv, subst `extendSubstInScope` tcv)++      -- Clone, and extend the substitution+      | let tcv' = uniqAway in_scope (setVarType tcv tcv_type)+      = (tcv', extendTCvSubstWithClone subst tcv tcv')+      where+        in_scope = substInScopeSet subst++getInVarEnv :: LintM (VarEnv (InId, OutType))+getInVarEnv = LintM (\env errs -> fromBoxedLResult (Just (le_in_vars env), errs))++extendTvSubstL :: TyVar -> Type -> LintM a -> LintM a+extendTvSubstL tv ty m+  = LintM $ \ env errs ->+    unLintM m (env { le_subst = Type.extendTvSubst (le_subst env) tv ty }) errs++markAllJoinsBad :: LintM a -> LintM a+markAllJoinsBad m+  = LintM $ \ env errs -> unLintM m (env { le_joins = emptyVarSet }) errs++markAllJoinsBadIf :: Bool -> LintM a -> LintM a+markAllJoinsBadIf True  m = markAllJoinsBad m+markAllJoinsBadIf False m = m++getValidJoins :: LintM IdSet+getValidJoins = LintM (\ env errs -> fromBoxedLResult (Just (le_joins env), errs))++getSubst :: LintM Subst+getSubst = LintM (\ env errs -> fromBoxedLResult (Just (le_subst env), errs))++substTyM :: InType -> LintM OutType+-- Apply the substitution to the type+-- The substitution is often empty, in which case it is a no-op+substTyM ty+  = do { subst <- getSubst+       ; return (substTy subst ty) }++getUEAliases :: LintM (NameEnv UsageEnv)+getUEAliases = LintM (\ env errs -> fromBoxedLResult (Just (le_ue_aliases env), errs))++getInScope :: LintM InScopeSet+getInScope = LintM (\ env errs -> fromBoxedLResult (Just (substInScopeSet $ le_subst env), errs))++lintVarOcc :: InVar -> LintM OutType+-- Used at an occurrence of a variable: term variables, type variables, and coercion variables+-- Checks two things:+-- a) that it is in scope+-- b) that the InType at the ocurrences matches the InType at the binding site+lintVarOcc v_occ+  = do { in_var_env <- getInVarEnv+       ; case lookupVarEnv in_var_env v_occ of+           Nothing | isGlobalId v_occ -> return (idType v_occ)+                   | otherwise        -> failWithL (text pp_what <+> quotes (ppr v_occ)+                                                    <+> text "is out of scope")+           Just (v_bndr, out_ty) -> do { check_bad_global v_bndr+                                       ; ensureEqTys occ_ty bndr_ty $  -- Compares InTypes+                                         mkBndrOccTypeMismatchMsg v_occ bndr_ty occ_ty+                                       ; return out_ty }+             where+               occ_ty  = varType v_occ+               bndr_ty = varType v_bndr }+  where+    pp_what | isTyVar v_occ = "The type variable"+            | isCoVar v_occ = "The coercion variable"+            | otherwise     = "The value variable"++       -- 'check_bad_global' checks for the case where an /occurrence/ is+       -- a GlobalId, but there is an enclosing binding fora a LocalId.+       -- NB: the in-scope variables are mostly LocalIds, checked by lintIdBndr,+       --     but GHCi adds GlobalIds from the interactive context.  These+       --     are fine; hence the test (isLocalId id == isLocalId v)+       -- NB: when compiling Control.Exception.Base, things like absentError+       --     are defined locally, but appear in expressions as (global)+       --     wired-in Ids after worker/wrapper+       --     So we simply disable the test in this case+    check_bad_global v_bndr+      | isGlobalId v_occ+      , isLocalId v_bndr+      , not (isWiredIn v_occ)+      = failWithL $ hang (text "Occurrence is GlobalId, but binding is LocalId")+                       2 (vcat [ hang (text "occurrence:") 2 $ pprBndr LetBind v_occ+                               , hang (text "binder    :") 2 $ pprBndr LetBind v_bndr ])+      | otherwise+      = return ()++lookupJoinId :: Id -> LintM JoinPointHood+-- Look up an Id which should be a join point, valid here+-- If so, return its arity, if not return Nothing+lookupJoinId id+  = do { join_set <- getValidJoins+       ; case lookupVarSet join_set id of+            Just id' -> return (idJoinPointHood id')+            Nothing  -> return NotJoinPoint }++addAliasUE :: OutId -> UsageEnv -> LintM a -> LintM a+addAliasUE id ue thing_inside = LintM $ \ env errs ->+  let new_ue_aliases =+        extendNameEnv (le_ue_aliases env) (getName id) ue+  in+    unLintM thing_inside (env { le_ue_aliases = new_ue_aliases }) errs++varCallSiteUsage :: OutId -> LintM UsageEnv+varCallSiteUsage id =+  do m <- getUEAliases+     return $ case lookupNameEnv m (getName id) of+         Nothing    -> singleUsageUE id+         Just id_ue -> id_ue++ensureEqTys :: OutType -> OutType -> SDoc -> LintM ()+-- check ty2 is subtype of ty1 (ie, has same structure but usage+-- annotations need only be consistent, not equal)+-- Assumes ty1,ty2 are have already had the substitution applied+{-# INLINE ensureEqTys #-} -- See Note [INLINE ensureEqTys]+ensureEqTys ty1 ty2 msg+  = do { flags <- getLintFlags+       ; lintL (eq_type flags ty1 ty2) msg }++eq_type :: LintFlags -> Type -> Type -> Bool+-- When `-dlinear-core-lint` is off, then consider `a -> b` and `a %1 -> b` to+-- be equal. See Note [Linting linearity].+eq_type flags ty1 ty2 | lf_check_linearity flags = eqType                     ty1 ty2+                      | otherwise                = eqTypeIgnoringMultiplicity ty1 ty2++{- Note [INLINE ensureEqTys]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+To make Lint fast, we want to avoid allocating a thunk for <msg> in+      ensureEqTypes ty1 ty2 <msg>+because the test almost always succeeds, and <msg> isn't needed.+So we INLINE `ensureEqTys`.  This actually make a difference of+1-2% when compiling programs with -dcore-lint.+-}++ensureSubUsage :: Usage -> Mult -> SDoc -> LintM ()+ensureSubUsage Bottom     _              _ = return ()+ensureSubUsage Zero       described_mult err_msg = ensureSubMult ManyTy described_mult err_msg+ensureSubUsage (MUsage m) described_mult err_msg = ensureSubMult m described_mult err_msg++ensureSubMult :: Mult -> Mult -> SDoc -> LintM ()+ensureSubMult actual_mult described_mult err_msg = do+    flags <- getLintFlags+    when (lf_check_linearity flags) $+      unless (deepSubMult actual_mult described_mult) $+        addErrL err_msg+  where+    -- Check for submultiplicity using the following rules:+    -- 1. x*y <= z when x <= z and y <= z.+    --    This rule follows from the fact that x*y = sup{x,y} for any+    --    multiplicities x,y.+    -- 2. x <= y*z when x <= y or x <= z.+    --    This rule is not complete: when x = y*z, we cannot+    --    change y*z <= y*z to y*z <= y or y*z <= z.+    --    However, we eliminate products on the LHS in step 1.+    -- 3. One <= x and x <= Many for any x, as checked by 'submult'.+    -- 4. x <= x.+    -- Otherwise, we fail.+    deepSubMult :: Mult -> Mult -> Bool+    deepSubMult m n+      | Just (m1, m2) <- isMultMul m = deepSubMult m1 n  && deepSubMult m2 n+      | Just (n1, n2) <- isMultMul n = deepSubMult m  n1 || deepSubMult m  n2+      | Submult <- m `submult` n = True+      | otherwise = m `eqType` n++lintRole :: Outputable thing+          => thing     -- where the role appeared+          -> Role      -- expected+          -> Role      -- actual+          -> LintM ()+lintRole co r1 r2+  = lintL (r1 == r2)+          (text "Role incompatibility: expected" <+> ppr r1 <> comma <+>+           text "got" <+> ppr r2 $$+           text "in" <+> ppr co)++{-+************************************************************************+*                                                                      *+\subsection{Error messages}+*                                                                      *+************************************************************************+-}++dumpLoc :: LintLocInfo -> (SrcLoc, SDoc)++dumpLoc (RhsOf v)+  = (getSrcLoc v, text "In the RHS of" <+> pp_binders [v])++dumpLoc (OccOf v)+  = (getSrcLoc v, text "In an occurrence of" <+> pp_binder v)++dumpLoc (LambdaBodyOf b)+  = (getSrcLoc b, text "In the body of lambda with binder" <+> pp_binder b)++dumpLoc (RuleOf b)+  = (getSrcLoc b, text "In a rule attached to" <+> pp_binder b)++dumpLoc (UnfoldingOf b)+  = (getSrcLoc b, text "In the unfolding of" <+> pp_binder b)++dumpLoc (BodyOfLet b)+  = (noSrcLoc, text "In the body of a let with binder" <+> pp_binder b)++dumpLoc (BodyOfLetRec [])+  = (noSrcLoc, text "In body of a letrec with no binders")++dumpLoc (BodyOfLetRec bs@(b:_))+  = ( getSrcLoc b, text "In the body of a letrec with binders" <+> pp_binders bs)++dumpLoc (AnExpr e)+  = (noSrcLoc, text "In the expression:" <+> ppr e)++dumpLoc (CaseAlt (Alt con args _))+  = (noSrcLoc, text "In a case alternative:" <+> parens (ppr con <+> pp_binders args))++dumpLoc (CasePat (Alt con args _))+  = (noSrcLoc, text "In the pattern of a case alternative:" <+> parens (ppr con <+> pp_binders args))++dumpLoc (CaseTy scrut)+  = (noSrcLoc, hang (text "In the result-type of a case with scrutinee:")+                  2 (ppr scrut))++dumpLoc (IdTy b)+  = (getSrcLoc b, text "In the type of a binder:" <+> ppr b)++dumpLoc (ImportedUnfolding locn)+  = (locn, text "In an imported unfolding")+dumpLoc TopLevelBindings+  = (noSrcLoc, Outputable.empty)+dumpLoc (InType ty)+  = (noSrcLoc, text "In the type" <+> quotes (ppr ty))+dumpLoc (InCo co)+  = (noSrcLoc, text "In the coercion" <+> quotes (ppr co))+dumpLoc (InAxiom ax)+  = (getSrcLoc ax, hang (text "In the coercion axiom")+                      2 (pprCoAxiom ax))++pp_binders :: [Var] -> SDoc+pp_binders bs = sep (punctuate comma (map pp_binder bs))++pp_binder :: Var -> SDoc+pp_binder b | isId b    = hsep [ppr b, dcolon, ppr (idType b)]+            | otherwise = hsep [ppr b, dcolon, ppr (tyVarKind b)]++------------------------------------------------------+--      Messages for case expressions++mkDefaultArgsMsg :: [Var] -> SDoc+mkDefaultArgsMsg args+  = hang (text "DEFAULT case with binders")+         4 (ppr args)++mkCaseAltMsg :: CoreExpr -> Type -> Type -> SDoc+mkCaseAltMsg e ty1 ty2+  = hang (text "Type of case alternatives not the same as the annotation on case:")+         4 (vcat [ text "Actual type:" <+> ppr ty1,+                   text "Annotation on case:" <+> ppr ty2,+                   text "Alt Rhs:" <+> ppr e ])++mkScrutMsg :: Id -> Type -> Type -> SDoc+mkScrutMsg var var_ty scrut_ty+  = vcat [text "Result binder in case doesn't match scrutinee:" <+> ppr var,+          text "Result binder type:" <+> ppr var_ty,--(idType var),+          text "Scrutinee type:" <+> ppr scrut_ty]++mkNonDefltMsg, mkNonIncreasingAltsMsg :: CoreExpr -> SDoc+mkNonDefltMsg e+  = hang (text "Case expression with DEFAULT not at the beginning") 4 (ppr e)+mkNonIncreasingAltsMsg e+  = hang (text "Case expression with badly-ordered alternatives") 4 (ppr e)++nonExhaustiveAltsMsg :: CoreExpr -> SDoc+nonExhaustiveAltsMsg e+  = hang (text "Case expression with non-exhaustive alternatives") 4 (ppr e)++mkBadConMsg :: TyCon -> DataCon -> SDoc+mkBadConMsg tycon datacon+  = vcat [+        text "In a case alternative, data constructor isn't in scrutinee type:",+        text "Scrutinee type constructor:" <+> ppr tycon,+        text "Data con:" <+> ppr datacon+    ]++mkBadPatMsg :: Type -> Type -> SDoc+mkBadPatMsg con_result_ty scrut_ty+  = vcat [+        text "In a case alternative, pattern result type doesn't match scrutinee type:",+        text "Pattern result type:" <+> ppr con_result_ty,+        text "Scrutinee type:" <+> ppr scrut_ty+    ]++integerScrutinisedMsg :: SDoc+integerScrutinisedMsg+  = text "In a LitAlt, the literal is lifted (probably Integer)"++mkBadAltMsg :: Type -> CoreAlt -> SDoc+mkBadAltMsg scrut_ty alt+  = vcat [ text "Data alternative when scrutinee is not a tycon application",+           text "Scrutinee type:" <+> ppr scrut_ty,+           text "Alternative:" <+> pprCoreAlt alt ]++mkNewTyDataConAltMsg :: Type -> CoreAlt -> SDoc+mkNewTyDataConAltMsg scrut_ty alt+  = vcat [ text "Data alternative for newtype datacon",+           text "Scrutinee type:" <+> ppr scrut_ty,+           text "Alternative:" <+> pprCoreAlt alt ]+++------------------------------------------------------+--      Other error messages++mkAppMsg :: Type -> Type -> CoreExpr -> SDoc+mkAppMsg expected_arg_ty actual_arg_ty arg+  = vcat [text "Argument value doesn't match argument type:",+              hang (text "Expected arg type:") 4 (ppr expected_arg_ty),+              hang (text "Actual arg type:") 4 (ppr actual_arg_ty),+              hang (text "Arg:") 4 (ppr arg)]++mkNonFunAppMsg :: Type -> Type -> CoreExpr -> SDoc+mkNonFunAppMsg fun_ty arg_ty arg+  = vcat [text "Non-function type in function position",+              hang (text "Fun type:") 4 (ppr fun_ty),+              hang (text "Arg type:") 4 (ppr arg_ty),+              hang (text "Arg:") 4 (ppr arg)]++mkLetErr :: TyVar -> CoreExpr -> SDoc+mkLetErr bndr rhs+  = vcat [text "Bad `let' binding:",+          hang (text "Variable:")+                 4 (ppr bndr <+> dcolon <+> ppr (varType bndr)),+          hang (text "Rhs:")+                 4 (ppr rhs)]++mkTyAppMsg :: OutType -> Type -> SDoc+mkTyAppMsg ty arg_ty+  = vcat [text "Illegal type application:",+              hang (text "Function type:")+                 4 (ppr ty <+> dcolon <+> ppr (typeKind ty)),+              hang (text "Type argument:")+                 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]++emptyRec :: CoreExpr -> SDoc+emptyRec e = hang (text "Empty Rec binding:") 2 (ppr e)++mkRhsMsg :: Id -> SDoc -> Type -> SDoc+mkRhsMsg binder what ty+  = vcat+    [hsep [text "The type of this binder doesn't match the type of its" <+> what <> colon,+            ppr binder],+     hsep [text "Binder's type:", ppr (idType binder)],+     hsep [text "Rhs type:", ppr ty]]++badBndrTyMsg :: Id -> SDoc -> SDoc+badBndrTyMsg binder what+  = vcat [ text "The type of this binder is" <+> what <> colon <+> ppr binder+         , text "Binder's type:" <+> ppr (idType binder) ]++mkNonTopExportedMsg :: Id -> SDoc+mkNonTopExportedMsg binder+  = hsep [text "Non-top-level binder is marked as exported:", ppr binder]++mkNonTopExternalNameMsg :: Id -> SDoc+mkNonTopExternalNameMsg binder+  = hsep [text "Non-top-level binder has an external name:", ppr binder]++mkTopNonLitStrMsg :: Id -> SDoc+mkTopNonLitStrMsg binder+  = hsep [text "Top-level Addr# binder has a non-literal rhs:", ppr binder]++mkKindErrMsg :: TyVar -> Type -> SDoc+mkKindErrMsg tyvar arg_ty+  = vcat [text "Kinds don't match in type application:",+          hang (text "Type variable:")+                 4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)),+          hang (text "Arg type:")+                 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]++mkCastErr :: CoreExpr -> Coercion -> Type -> Type -> SDoc+mkCastErr expr = mk_cast_err "expression" "type" (ppr expr)++mkCastTyErr :: Type -> Coercion -> Kind -> Kind -> SDoc+mkCastTyErr ty = mk_cast_err "type" "kind" (ppr ty)++mk_cast_err :: String -- ^ What sort of casted thing this is+                      --   (\"expression\" or \"type\").+            -> String -- ^ What sort of coercion is being used+                      --   (\"type\" or \"kind\").+            -> SDoc   -- ^ The thing being casted.+            -> Coercion -> Type -> Type -> SDoc+mk_cast_err thing_str co_str pp_thing co from_ty thing_ty+  = vcat [from_msg <+> text "of Cast differs from" <+> co_msg+            <+> text "of" <+> enclosed_msg,+          from_msg <> colon <+> ppr from_ty,+          text (capitalise co_str) <+> text "of" <+> enclosed_msg <> colon+            <+> ppr thing_ty,+          text "Actual" <+> enclosed_msg <> colon <+> pp_thing,+          text "Coercion used in cast:" <+> ppr co+         ]+  where+    co_msg, from_msg, enclosed_msg :: SDoc+    co_msg       = text co_str+    from_msg     = text "From-" <> co_msg+    enclosed_msg = text "enclosed" <+> text thing_str++mkBadTyVarMsg :: Var -> SDoc+mkBadTyVarMsg tv+  = text "Non-tyvar used in TyVarTy:"+      <+> ppr tv <+> dcolon <+> ppr (varType tv)++mkBadJoinBindMsg :: Var -> SDoc+mkBadJoinBindMsg var+  = vcat [ text "Bad join point binding:" <+> ppr var+         , text "Join points can be bound only by a non-top-level let" ]++mkInvalidJoinPointMsg :: Var -> Type -> SDoc+mkInvalidJoinPointMsg var ty+  = hang (text "Join point has invalid type:")+        2 (ppr var <+> dcolon <+> ppr ty)++mkBadJoinArityMsg :: Var -> Int -> Int -> CoreExpr -> SDoc+mkBadJoinArityMsg var ar n rhs+  = vcat [ text "Join point has too few lambdas",+           text "Join var:" <+> ppr var,+           text "Join arity:" <+> ppr ar,+           text "Number of lambdas:" <+> ppr (ar - n),+           text "Rhs = " <+> ppr rhs+           ]++invalidJoinOcc :: Var -> SDoc+invalidJoinOcc var+  = vcat [ text "Invalid occurrence of a join variable:" <+> ppr var+         , text "The binder is either not a join point, or not valid here" ]++mkBadJumpMsg :: Var -> Int -> Int -> SDoc+mkBadJumpMsg var ar nargs+  = vcat [ text "Join point invoked with wrong number of arguments",+           text "Join var:" <+> ppr var,+           text "Join arity:" <+> ppr ar,+           text "Number of arguments:" <+> int nargs ]++mkInconsistentRecMsg :: [Var] -> SDoc+mkInconsistentRecMsg bndrs+  = vcat [ text "Recursive let binders mix values and join points",+           text "Binders:" <+> hsep (map ppr_with_details bndrs) ]+  where+    ppr_with_details bndr = ppr bndr <> ppr (idDetails bndr)++mkJoinBndrOccMismatchMsg :: Var -> JoinArity -> JoinArity -> SDoc+mkJoinBndrOccMismatchMsg bndr join_arity_bndr join_arity_occ+  = vcat [ text "Mismatch in join point arity between binder and occurrence"+         , text "Var:" <+> ppr bndr+         , text "Arity at binding site:" <+> ppr join_arity_bndr+         , text "Arity at occurrence:  " <+> ppr join_arity_occ ]++mkBndrOccTypeMismatchMsg :: InVar -> InType -> InType -> SDoc+mkBndrOccTypeMismatchMsg var bndr_ty occ_ty+  = vcat [ text "Mismatch in type between binder and occurrence"+         , text "Binder:    " <+> ppr var <+> dcolon <+> ppr bndr_ty+         , text "Occurrence:" <+> ppr var <+> dcolon <+> ppr occ_ty ]++mkBadJoinPointRuleMsg :: JoinId -> JoinArity -> CoreRule -> SDoc+mkBadJoinPointRuleMsg bndr join_arity rule+  = vcat [ text "Join point has rule with wrong number of arguments"+         , text "Var:" <+> ppr bndr+         , text "Join arity:" <+> ppr join_arity+         , text "Rule:" <+> ppr rule ]++dupVars :: [NonEmpty Var] -> SDoc+dupVars vars+  = hang (text "Duplicate variables brought into scope")+       2 (ppr (map toList vars))++dupExtVars :: [NonEmpty Name] -> SDoc+dupExtVars vars+  = hang (text "Duplicate top-level variables with the same qualified name")+       2 (ppr (map toList vars))++{-+************************************************************************+*                                                                      *+\subsection{Annotation Linting}+*                                                                      *+************************************************************************+-}++-- | This checks whether a pass correctly looks through debug+-- annotations (@SourceNote@). This works a bit different from other+-- consistency checks: We check this by running the given task twice,+-- noting all differences between the results.+lintAnnots :: SDoc -> (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts+lintAnnots pname pass guts = {-# SCC "lintAnnots" #-} do+  -- Run the pass as we normally would+  dflags <- getDynFlags+  logger <- getLogger+  when (gopt Opt_DoAnnotationLinting dflags) $+    liftIO $ Err.showPass logger "Annotation linting - first run"+  -- If appropriate re-run it without debug annotations to make sure+  -- that they made no difference.+  if gopt Opt_DoAnnotationLinting dflags+    then do+      nguts <- pass guts+      liftIO $ Err.showPass logger "Annotation linting - second run"+      nguts' <- withoutAnnots pass guts+      -- Finally compare the resulting bindings+      liftIO $ Err.showPass logger "Annotation linting - comparison"+      let binds = flattenBinds $ mg_binds nguts+          binds' = flattenBinds $ mg_binds nguts'+          (diffs,_) = diffBinds True (mkRnEnv2 emptyInScopeSet) binds binds'+      when (not (null diffs)) $ GHC.Core.Opt.Monad.putMsg $ vcat+        [ lint_banner "warning" pname+        , text "Core changes with annotations:"+        , withPprStyle defaultDumpStyle $ nest 2 $ vcat diffs+        ]+      return nguts+    else+      pass guts++-- | Run the given pass without annotations. This means that we both+-- set the debugLevel setting to 0 in the environment as well as all+-- annotations from incoming modules.+withoutAnnots :: (ModGuts -> CoreM ModGuts) -> ModGuts -> CoreM ModGuts+withoutAnnots pass guts = do+  -- Remove debug flag from environment.+  -- TODO: supply tag here as well ?+  let withoutFlag = mapDynFlagsCoreM $ \(!dflags) -> dflags { debugLevel = 0 }+  -- Nuke existing ticks in module.+  -- TODO: Ticks in unfoldings. Maybe change unfolding so it removes+  -- them in absence of debugLevel > 0.+  let nukeTicks = stripTicksE (not . tickishIsCode)+      nukeAnnotsBind :: CoreBind -> CoreBind+      nukeAnnotsBind bind = case bind of+        Rec bs     -> Rec $ map (\(b,e) -> (b, nukeTicks e)) bs+        NonRec b e -> NonRec b $ nukeTicks e+      nukeAnnotsMod mg@ModGuts{mg_binds=binds}+        = mg{mg_binds = map nukeAnnotsBind binds}+  -- Perform pass with all changes applied. Drop the simple count so it doesn't+  -- effect the total also+  dropSimplCount $ withoutFlag $ pass (nukeAnnotsMod guts)
+ GHC/Core/Lint/Interactive.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE ScopedTypeVariables #-}++{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1993-1998+++A ``lint'' pass to check for Core correctness.+See Note [Core Lint guarantee].+-}++module GHC.Core.Lint.Interactive (+    interactiveInScope,+ ) where++import GHC.Prelude++import GHC.Runtime.Context++import GHC.Core.Coercion+import GHC.Core.TyCo.FVs+import GHC.Core.InstEnv      ( instanceDFunId, instEnvElts )++import GHC.Types.Id+import GHC.Types.TypeEnv+++interactiveInScope :: InteractiveContext -> [Var]+-- In GHCi we may lint expressions, or bindings arising from 'deriving'+-- clauses, that mention variables bound in the interactive context.+-- These are Local things (see Note [Interactively-bound Ids in GHCi] in GHC.Runtime.Context).+-- So we have to tell Lint about them, lest it reports them as out of scope.+--+-- We do this by find local-named things that may appear free in interactive+-- context.  This function is pretty revolting and quite possibly not quite right.+-- When we are not in GHCi, the interactive context (hsc_IC hsc_env) is empty+-- so this is a (cheap) no-op.+--+-- See #8215 for an example+interactiveInScope ictxt+  = tyvars ++ ids+  where+    -- C.f. GHC.Tc.Module.setInteractiveContext, Desugar.deSugarExpr+    (cls_insts, _fam_insts) = ic_instances ictxt+    te1    = mkTypeEnvWithImplicits (ic_tythings ictxt)+    te     = extendTypeEnvWithIds te1 (map instanceDFunId $ instEnvElts cls_insts)+    ids    = typeEnvIds te+    tyvars = tyCoVarsOfTypesList $ map idType ids+              -- Why the type variables?  How can the top level envt have free tyvars?+              -- I think it's because of the GHCi debugger, which can bind variables+              --   f :: [t] -> [t]+              -- where t is a RuntimeUnk (see TcType)
GHC/Core/Make.hs view
@@ -1,14 +1,11 @@---{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}- -- | Handy functions for creating much Core syntax module GHC.Core.Make (         -- * Constructing normal syntax         mkCoreLet, mkCoreLets,-        mkCoreApp, mkCoreApps, mkCoreConApps,-        mkCoreLams, mkWildCase, mkIfThenElse,-        mkWildValBinder, mkWildEvBinder,+        mkCoreApp, mkCoreApps, mkCoreConApps, mkCoreConWrapApps,+        mkCoreLams, mkCoreTyLams,+        mkWildCase, mkIfThenElse,+        mkWildValBinder,         mkSingleAltCase,         sortQuantVars, castBottomExpr, @@ -25,35 +22,30 @@         FloatBind(..), wrapFloat, wrapFloats, floatBindings,          -- * Constructing small tuples-        mkCoreVarTupTy, mkCoreTup, mkCoreUbxTup, mkCoreUbxSum,+        mkCoreVarTupTy, mkCoreTup, mkCoreUnboxedTuple, mkCoreUnboxedSum,         mkCoreTupBoxity, unitExpr,          -- * Constructing big tuples-        mkBigCoreVarTup, mkBigCoreVarTup1,+        mkChunkified, chunkify,+        mkBigCoreVarTup, mkBigCoreVarTupSolo,         mkBigCoreVarTupTy, mkBigCoreTupTy,         mkBigCoreTup, -        -- * Deconstructing small tuples-        mkSmallTupleSelector, mkSmallTupleCase,--        -- * Deconstructing big tuples-        mkTupleSelector, mkTupleSelector1, mkTupleCase,+          -- * Deconstructing big tuples+        mkBigTupleSelector, mkBigTupleSelectorSolo, mkBigTupleCase,          -- * Constructing list expressions         mkNilExpr, mkConsExpr, mkListExpr,         mkFoldrExpr, mkBuildExpr, -        -- * Constructing non empty lists-        mkNonEmptyListExpr,-         -- * Constructing Maybe expressions         mkNothingExpr, mkJustExpr,          -- * Error Ids         mkRuntimeErrorApp, mkImpossibleExpr, mkAbsentErrorApp, errorIds,-        rEC_CON_ERROR_ID, rUNTIME_ERROR_ID,+        rEC_CON_ERROR_ID,         nON_EXHAUSTIVE_GUARDS_ERROR_ID, nO_METHOD_BINDING_ERROR_ID,-        pAT_ERROR_ID, rEC_SEL_ERROR_ID, aBSENT_ERROR_ID,+        pAT_ERROR_ID, rEC_SEL_ERROR_ID,         tYPE_ERROR_ID, aBSENT_SUM_FIELD_ERROR_ID     ) where @@ -61,24 +53,25 @@ import GHC.Platform  import GHC.Types.Id-import GHC.Types.Var  ( EvVar, setTyVarUnique )+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, needsCaseBinding, mkSingleAltCase, bindNonRec )+import GHC.Core.Utils ( exprType, mkSingleAltCase, bindNonRec, mkCast ) import GHC.Core.Type-import GHC.Core.Coercion ( isCoVar )-import GHC.Core.DataCon  ( DataCon, dataConWorkId )+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.Hs.Utils      ( mkChunkified, chunkify )- import GHC.Builtin.Types import GHC.Builtin.Names import GHC.Builtin.Types.Prim@@ -86,11 +79,13 @@ import GHC.Utils.Outputable import GHC.Utils.Misc import GHC.Utils.Panic-import GHC.Utils.Panic.Plain +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`@@ -105,7 +100,7 @@ -- | 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+-- 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]@@ -115,9 +110,9 @@     sorted_tcvs = scopedSort tcvs  -- | Bind a binding group over an expression, using a @let@ or @case@ as--- appropriate (see "GHC.Core#let_app_invariant")+-- appropriate (see "GHC.Core#let_can_float_invariant") mkCoreLet :: CoreBind -> CoreExpr -> CoreExpr-mkCoreLet (NonRec bndr rhs) body        -- See Note [Core let/app invariant]+mkCoreLet (NonRec bndr rhs) body        -- See Note [Core let-can-float invariant]   = bindNonRec bndr rhs body mkCoreLet bind body   = Let bind body@@ -128,6 +123,14 @@ 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@@ -139,11 +142,15 @@ 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------ Respects the let/app invariant by building a case expression where necessary---   See Note [Core let/app invariant] in "GHC.Core" mkCoreApps :: CoreExpr -- ^ function            -> [CoreExpr] -- ^ arguments            -> CoreExpr@@ -156,9 +163,6 @@  -- | Construct an expression which represents the application of one expression -- to the other------ Respects the let/app invariant by building a case expression where necessary---   See Note [Core let/app invariant] in "GHC.Core" mkCoreApp :: SDoc           -> CoreExpr -- ^ function           -> CoreExpr -- ^ argument@@ -170,9 +174,6 @@ -- paired with its type to an argument. The result is paired with its type. This -- function is not exported and used in the definition of 'mkCoreApp' and -- 'mkCoreApps'.------ Respects the let/app invariant by building a case expression where necessary---   See Note [Core let/app invariant] in "GHC.Core" mkCoreAppTyped :: SDoc -> (CoreExpr, Type) -> CoreExpr -> (CoreExpr, Type) mkCoreAppTyped _ (fun, fun_ty) (Type ty)   = (App fun (Type ty), piResultTy fun_ty ty)@@ -180,20 +181,7 @@   = (App fun (Coercion co), funResultTy fun_ty) mkCoreAppTyped d (fun, fun_ty) arg   = assertPpr (isFunTy fun_ty) (ppr fun $$ ppr arg $$ d)-    (mkValApp fun arg (Scaled mult arg_ty) res_ty, res_ty)-  where-    (mult, arg_ty, res_ty) = splitFunTy fun_ty---- | Build an application (e1 e2),--- or a strict binding  (case e2 of x -> e1 x)--- using the latter when necessary to respect the let/app invariant---   See Note [Core let/app invariant] in GHC.Core-mkValApp :: CoreExpr -> CoreExpr -> Scaled Type -> Type -> CoreExpr-mkValApp fun arg (Scaled w arg_ty) res_ty-  | not (needsCaseBinding arg_ty arg)-  = App fun arg                -- The vastly common case-  | otherwise-  = mkStrictApp fun arg (Scaled w arg_ty) res_ty+    (App fun arg, funResultTy fun_ty)  {- ********************************************************************* *                                                                      *@@ -201,9 +189,6 @@ *                                                                      * ********************************************************************* -} -mkWildEvBinder :: PredType -> EvVar-mkWildEvBinder pred = mkWildValBinder Many 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@@ -225,25 +210,6 @@ mkWildCase scrut (Scaled w scrut_ty) res_ty alts   = Case scrut (mkWildValBinder w scrut_ty) res_ty alts --- | Build a strict application (case e2 of x -> e1 x)-mkStrictApp :: CoreExpr -> CoreExpr -> Scaled Type -> Type -> CoreExpr-mkStrictApp fun arg (Scaled w arg_ty) res_ty-  = Case arg arg_id res_ty [Alt DEFAULT [] (App fun (Var arg_id))]-       -- mkDefaultCase looks attractive here, and would be sound.-       -- But it uses (exprType alt_rhs) to compute the result type,-       -- whereas here we already know that the result type is res_ty-  where-    arg_id = mkWildValBinder w arg_ty-        -- Lots of shadowing, but it doesn't matter,-        -- because 'fun' and 'res_ty' should not have a free wild-id-        ---        -- This is Dangerous.  But this is the only place we play this-        -- game, mkStrictApp returns an expression that does not have-        -- a free wild-id.  So the only way 'fun' could get a free wild-id-        -- would be if you take apart this case expression (or some other-        -- expression that uses mkWildValBinder, of which there are not-        -- many), and pass a fragment of it as the fun part of a 'mkStrictApp'.- mkIfThenElse :: CoreExpr -- ^ guard              -> CoreExpr -- ^ then              -> CoreExpr -- ^ else@@ -260,7 +226,7 @@ -- See Note [Empty case alternatives] in GHC.Core castBottomExpr e res_ty   | e_ty `eqType` res_ty = e-  | otherwise            = Case e (mkWildValBinder One e_ty) res_ty []+  | otherwise            = Case e (mkWildValBinder OneTy e_ty) res_ty []   where     e_ty = exprType e @@ -274,12 +240,12 @@ mkLitRubbish ty   | not (noFreeVarsOfType rep)   = Nothing   -- Satisfy INVARIANT 1-  | isCoVarType ty+  | isEqPred ty   = Nothing   -- Satisfy INVARIANT 2   | otherwise-  = Just (Lit (LitRubbish rep) `mkTyApps` [ty])+  = Just (Lit (LitRubbish torc rep) `mkTyApps` [ty])   where-    rep  = getRuntimeRep ty+    (torc, rep) = expectJust $ sORTKind_maybe (typeKind ty)  {- ************************************************************************@@ -302,7 +268,7 @@ mkIntExprInt :: Platform -> Int -> CoreExpr         -- Result = I# i :: Int mkIntExprInt platform i = mkCoreConApps intDataCon  [mkIntLit platform (fromIntegral i)] --- | Create a 'CoreExpr' which will evaluate to the a @Word@ with the given value+-- | 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] @@ -374,22 +340,12 @@ {- ************************************************************************ *                                                                      *-\subsection{Tuple constructors}+     Creating tuples and their types for Core expressions *                                                                      * ************************************************************************ -} -{--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]+{- Note [Flattening one-tuples] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ This family of functions creates a tuple of variables/expressions/types.   mkCoreTup [e1,e2,e3] = (e1,e2,e3)@@ -400,8 +356,8 @@     mkCoreTup [e1] = e1  * Build a one-tuple (see Note [One-tuples] in GHC.Builtin.Types)-    mkCoreTup1 [e1] = Solo e1-  We use a suffix "1" to indicate this.+    mkCoreTupSolo [e1] = Solo e1+  We use a suffix "Solo" to indicate this.  Usually we want the former, but occasionally the latter. @@ -419,47 +375,52 @@ 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 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  = mkCoreTup1 cs   -- non-1-tuples are uniform---- | 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]-mkCoreTup1 :: [CoreExpr] -> CoreExpr-mkCoreTup1 cs = mkCoreConApps (tupleDataCon Boxed (length cs))-                              (map (Type . exprType) cs ++ cs)+-- 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,--- with the given types. The types must be the types of the expressions.++-- | 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]-mkCoreUbxTup :: [Type] -> [CoreExpr] -> CoreExpr-mkCoreUbxTup tys exps-  = assert (tys `equalLength` exps) $-    mkCoreConApps (tupleDataCon Unboxed (length tys))-             (map (Type . getRuntimeRep) tys ++ map Type tys ++ exps)+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 = mkCoreTup1 exps-mkCoreTupBoxity Unboxed exps = mkCoreUbxTup (map exprType exps) exps+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.-mkCoreUbxSum :: Int -> Int -> [Type] -> CoreExpr -> CoreExpr-mkCoreUbxSum arity alt tys exp+mkCoreUnboxedSum :: Int -> Int -> [Type] -> CoreExpr -> CoreExpr+mkCoreUnboxedSum arity alt tys exp   = assert (length tys == arity) $     assert (alt <= arity) $     mkCoreConApps (sumDataCon alt arity)@@ -467,37 +428,154 @@                    ++ 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) -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 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 :: [Id] -> Type+mkBigCoreVarTupTy :: HasDebugCallStack => [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+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++ {- ************************************************************************ *                                                                      *@@ -506,7 +584,7 @@ ************************************************************************ -} --- | Builds a selector which scrutises the given+-- | 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@@ -518,16 +596,16 @@ -- If necessary, we pattern match on a \"big\" tuple. -- -- A tuple selector is not linear in its argument. Consequently, the case--- expression built by `mkTupleSelector` must consume its scrutinee 'Many'+-- expression built by `mkBigTupleSelector` must consume its scrutinee 'Many' -- times. And all the argument variables must have multiplicity 'Many'.-mkTupleSelector, mkTupleSelector1+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 --- mkTupleSelector [a,b,c,d] b v e+-- mkBigTupleSelector [a,b,c,d] b v e --          = case e of v { --                (p,q) -> case p of p { --                           (a,b) -> b }}@@ -538,7 +616,7 @@ --        case (case e of v --                (p,q) -> p) of p --          (a,b) -> b-mkTupleSelector vars the_var scrut_var scrut+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@@ -547,18 +625,23 @@         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'+          (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])-mkTupleSelector1 vars the_var scrut_var scrut+mkBigTupleSelectorSolo vars the_var scrut_var scrut   | [_] <- vars   = mkSmallTupleSelector1 vars the_var scrut_var scrut   | otherwise-  = mkTupleSelector vars the_var scrut_var scrut+  = mkBigTupleSelector vars the_var scrut_var scrut --- | Like 'mkTupleSelector' but for tuples that are guaranteed--- never to be \"big\".+-- | `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 } |]@@ -581,45 +664,71 @@     Case scrut scrut_var (idType the_var)          [Alt (DataAlt (tupleDataCon Boxed (length vars))) vars (Var the_var)] --- | A generalization of 'mkTupleSelector', allowing the body+-- | 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.-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+-- 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. -----         mkTupleCase uniqs [a,b,c,d] body v e+--         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 }}}-mkTupleCase uniqs vars body scrut_var scrut-  = mk_tuple_case uniqs (chunkify vars) 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 _ [vars] body+    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 make nest tuples at least once+    -- This is the case where we must 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'+      = 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)-      = let (uniq, us') = takeUniqFromSupply us-            scrut_var = mkSysLocal (fsLit "ds") uniq Many-              (mkBoxedTupleTy (map idType chunk_vars))-            body' = mkSmallTupleCase chunk_vars body scrut_var (Var scrut_var)-        in (us', scrut_var: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) --- | As 'mkTupleCase', but for a tuple that is small enough to be guaranteed+    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@@ -631,7 +740,6 @@ 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)          [Alt (DataAlt (tupleDataCon Boxed (length vars))) vars body] @@ -694,9 +802,6 @@ mkListExpr :: Type -> [CoreExpr] -> CoreExpr mkListExpr ty xs = foldr (mkConsExpr ty) (mkNilExpr ty) xs -mkNonEmptyListExpr :: Type -> CoreExpr -> [CoreExpr] -> CoreExpr-mkNonEmptyListExpr ty x xs = mkCoreConApps nonEmptyDataCon [Type ty, x, mkListExpr ty xs]- -- | Make a fully applied 'foldr' expression mkFoldrExpr :: MonadThings m             => Type             -- ^ Element type of the list@@ -724,7 +829,7 @@     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") Many c_ty, mkSysLocalM (fsLit "n") Many 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) @@ -762,7 +867,9 @@ -}  mkRuntimeErrorApp-        :: Id           -- Should be of type (forall a. Addr# -> a)+        :: 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@@ -774,10 +881,6 @@   where     err_string = Lit (mkLitString err_msg) -mkImpossibleExpr :: Type -> CoreExpr-mkImpossibleExpr res_ty-  = mkRuntimeErrorApp rUNTIME_ERROR_ID res_ty "Impossible case alternative"- {- ************************************************************************ *                                                                      *@@ -799,29 +902,23 @@  errorIds :: [Id] errorIds-  = [ rUNTIME_ERROR_ID,-      nON_EXHAUSTIVE_GUARDS_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,+      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-      rAISE_OVERFLOW_ID,-      rAISE_UNDERFLOW_ID,-      rAISE_DIVZERO_ID+      tYPE_ERROR_ID   -- Used with Opt_DeferTypeErrors, see #10284       ] -recSelErrorName, runtimeErrorName, absentErrorName :: Name-recConErrorName, patErrorName :: Name+recSelErrorName, recConErrorName, patErrorName :: Name nonExhaustiveGuardsErrorName, noMethodBindingErrorName :: Name typeErrorName :: Name absentSumFieldErrorName :: Name-raiseOverflowName, raiseUnderflowName, raiseDivZeroName :: Name  recSelErrorName     = err_nm "recSelError"     recSelErrorIdKey     rEC_SEL_ERROR_ID-runtimeErrorName    = err_nm "runtimeError"    runtimeErrorIdKey    rUNTIME_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@@ -832,19 +929,17 @@                                   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+err_nm str uniq id = mkWiredInIdName gHC_INTERNAL_CONTROL_EXCEPTION_BASE (fsLit str) uniq id -rEC_SEL_ERROR_ID, rUNTIME_ERROR_ID, rEC_CON_ERROR_ID :: 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_ERROR_ID, aBSENT_SUM_FIELD_ERROR_ID :: Id-rAISE_OVERFLOW_ID, rAISE_UNDERFLOW_ID, rAISE_DIVZERO_ID :: Id-rEC_SEL_ERROR_ID                = mkRuntimeErrorId recSelErrorName-rUNTIME_ERROR_ID                = mkRuntimeErrorId runtimeErrorName-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+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] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -945,38 +1040,7 @@       absentSumFieldErrorIdKey       aBSENT_SUM_FIELD_ERROR_ID -absentErrorName-   = mkWiredInIdName-      gHC_PRIM_PANIC-      (fsLit "absentError")-      absentErrorIdKey-      aBSENT_ERROR_ID--raiseOverflowName-   = mkWiredInIdName-      gHC_PRIM_EXCEPTION-      (fsLit "raiseOverflow")-      raiseOverflowIdKey-      rAISE_OVERFLOW_ID--raiseUnderflowName-   = mkWiredInIdName-      gHC_PRIM_EXCEPTION-      (fsLit "raiseUnderflow")-      raiseUnderflowIdKey-      rAISE_UNDERFLOW_ID--raiseDivZeroName-   = mkWiredInIdName-      gHC_PRIM_EXCEPTION-      (fsLit "raiseDivZero")-      raiseDivZeroIdKey-      rAISE_DIVZERO_ID- aBSENT_SUM_FIELD_ERROR_ID = mkExceptionId absentSumFieldErrorName-rAISE_OVERFLOW_ID         = mkExceptionId raiseOverflowName-rAISE_UNDERFLOW_ID        = mkExceptionId raiseUnderflowName-rAISE_DIVZERO_ID          = mkExceptionId raiseDivZeroName  -- | Exception with type \"forall a. a\" --@@ -989,31 +1053,7 @@       (divergingIdInfo [] `setCafInfo` NoCafRefs)          -- See Note [Wired-in exceptions are not CAFfy] -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 (divergingIdInfo [evalDmd])-     -- Do *not* mark them as NoCafRefs, because they can indeed have-     -- CAF refs.  For example, pAT_ERROR_ID calls GHC.Err.untangle,-     -- which has some CAFs-     -- In due course we may arrange that these error-y things are-     -- regarded by the GC as permanently live, in which case we-     -- can give them NoCaf info.  As it is, any function that calls-     -- any pc_bottoming_Id will itself have CafRefs, which bloats-     -- SRTs.--runtimeErrorTy :: Type--- forall (rr :: RuntimeRep) (a :: rr). Addr# -> a---   See Note [Error and friends have an "open-tyvar" forall]-runtimeErrorTy = mkSpecForAllTys [runtimeRep1TyVar, openAlphaTyVar]-                                 (mkVisFunTyMany addrPrimTy openAlphaTy)---- | An 'IdInfo' for an Id, such as 'aBSENT_ERROR_ID' or 'raiseOverflow', that+-- | 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. --@@ -1042,6 +1082,57 @@  ************************************************************************ *                                                                      *+                     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 *                                                                      * ************************************************************************@@ -1122,19 +1213,93 @@ be relying on anything from it. -} -aBSENT_ERROR_ID -- See Note [aBSENT_ERROR_ID]- = mkVanillaGlobalWithInfo absentErrorName absent_ty id_info- where-   absent_ty = mkSpecForAllTys [alphaTyVar] (mkVisFunTyMany addrPrimTy alphaTy)-   -- Not runtime-rep polymorphic. aBSENT_ERROR_ID is only used for-   -- lifted-type things; see Note [Absent fillers] in GHC.Core.Opt.WorkWrap.Utils-   id_info = divergingIdInfo [evalDmd] -- NB: CAFFY!+-- 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 aBSENT_ERROR_ID) [ Type res_ty, err_string ]+  = mkApps (Var err_id) [ Type res_ty, err_string ]   where+    err_id = case typeTypeOrConstraint res_ty of+               TypeLike       -> aBSENT_ERROR_ID+               ConstraintLike -> aBSENT_CONSTRAINT_ERROR_ID     err_string = Lit (mkLitString err_msg)++absentErrorName, absentConstraintErrorName :: Name+absentErrorName+   = mkWiredInIdName gHC_PRIM_PANIC (fsLit "absentError")+      absentErrorIdKey aBSENT_ERROR_ID++absentConstraintErrorName   -- See Note [Type vs Constraint for error ids]+   = mkWiredInIdName gHC_PRIM_PANIC (fsLit "absentConstraintError")+      absentConstraintErrorIdKey aBSENT_CONSTRAINT_ERROR_ID++aBSENT_ERROR_ID, aBSENT_CONSTRAINT_ERROR_ID :: Id++aBSENT_ERROR_ID -- See Note [aBSENT_ERROR_ID]+ = mk_runtime_error_id absentErrorName absent_ty+ where+   -- absentError :: forall (a :: Type). Addr# -> a+   absent_ty = mkSpecForAllTys [alphaTyVar] $+               mkVisFunTyMany addrPrimTy (mkTyVarTy alphaTyVar)+   -- Not runtime-rep polymorphic. aBSENT_ERROR_ID is only used for+   -- lifted-type things; see Note [Absent fillers] in GHC.Core.Opt.WorkWrap.Utils++aBSENT_CONSTRAINT_ERROR_ID -- See Note [aBSENT_ERROR_ID]+ = mk_runtime_error_id absentConstraintErrorName absent_ty+   -- See Note [Type vs Constraint for error ids]+ where+   -- absentConstraintError :: forall (a :: Constraint). Addr# -> a+   absent_ty = mkSpecForAllTys [alphaConstraintTyVar] $+               mkFunTy visArgConstraintLike ManyTy+                       addrPrimTy (mkTyVarTy alphaConstraintTyVar)+++{-+************************************************************************+*                                                                      *+                     mkRuntimeErrorId+*                                                                      *+************************************************************************+-}++mkRuntimeErrorId :: TypeOrConstraint -> Name -> Id+-- Error function+--   with type:  forall (r::RuntimeRep) (a::TYPE r). Addr# -> a+--   with arity: 1+-- which diverges after being given one argument+-- The Addr# is expected to be the address of+--   a UTF8-encoded error string+mkRuntimeErrorId torc name = mk_runtime_error_id name (mkRuntimeErrorTy torc)+++mk_runtime_error_id :: Name -> Type -> Id+mk_runtime_error_id name ty+ = mkVanillaGlobalWithInfo name ty (divergingIdInfo [evalDmd])+     -- Do *not* mark them as NoCafRefs, because they can indeed have+     -- CAF refs.  For example, pAT_ERROR_ID calls GHC.Err.untangle,+     -- which has some CAFs+     -- In due course we may arrange that these error-y things are+     -- regarded by the GC as permanently live, in which case we+     -- can give them NoCaf info.  As it is, any function that calls+     -- any pc_bottoming_Id will itself have CafRefs, which bloats+     -- SRTs.++mkRuntimeErrorTy :: TypeOrConstraint -> Type+-- forall (rr :: RuntimeRep) (a :: rr). Addr# -> a+--   See Note [Error and friends have an "open-tyvar" forall]+mkRuntimeErrorTy torc = mkSpecForAllTys [runtimeRep1TyVar, tyvar] $+                        mkFunctionType ManyTy addrPrimTy (mkTyVarTy tyvar)+  where+    tyvar:|_ = expectNonEmpty $ mkTemplateTyVars [kind]+    kind = case torc of+              TypeLike       -> mkTYPEapp       runtimeRep1Ty+              ConstraintLike -> mkCONSTRAINTapp runtimeRep1Ty+
GHC/Core/Map/Expr.hs view
@@ -40,6 +40,7 @@ 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@@ -109,14 +110,19 @@ -- 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-    mapTM f (CoreMap m) = CoreMap (mapTM f 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,@@ -124,6 +130,8 @@ -- 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@@ -146,9 +154,8 @@  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 (Var v1) (Var v2)             = eqDeBruijnVar (D env1 v1) (D env2 v2)     go (Lit lit1)    (Lit lit2)      = lit1 == lit2-    -- See Note [Using tcView inside eqDeBruijnType] in GHC.Core.Map.Type     go (Type t1)    (Type t2)        = eqDeBruijnType (D env1 t1) (D env2 t2)     -- See Note [Alpha-equality for Coercion arguments]     go (Coercion {}) (Coercion {}) = True@@ -159,7 +166,6 @@       && go e1 e2      go (Lam b1 e1)  (Lam b2 e2)-          -- See Note [Using tcView inside eqDeBruijnType] in GHC.Core.Map.Type       =  eqDeBruijnType (D env1 (varType b1)) (D env2 (varType b2))       && D env1 (varMultMaybe b1) == D env2 (varMultMaybe b2)       && eqDeBruijnExpr (D (extendCME env1 b1) e1) (D (extendCME env2 b2) e2)@@ -171,9 +177,7 @@     go (Let (Rec ps1) e1) (Let (Rec ps2) e2)       = equalLength ps1 ps2       -- See Note [Alpha-equality for let-bindings]-      && all2 (\b1 b2 -> -- See Note [Using tcView inside eqDeBruijnType] in-                         -- GHC.Core.Map.Type-                         eqDeBruijnType (D env1 (varType b1))+      && all2 (\b1 b2 -> eqDeBruijnType (D env1 (varType b1))                                         (D env2 (varType b2)))               bs1 bs2       && D env1' rs1 == D env2' rs2@@ -248,30 +252,28 @@             , 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-   mapTM    = mapE    filterTM = ftE+   mapMaybeTM = mpE  ---------------------------mapE :: (a->b) -> CoreMapX a -> CoreMapX b-mapE f (CM { cm_var = cvar, cm_lit = clit-           , cm_co = cco, cm_type = ctype-           , cm_cast = ccast , cm_app = capp-           , cm_lam = clam, cm_letn = cletn-           , cm_letr = cletr, cm_case = ccase-           , cm_ecase = cecase, cm_tick = ctick })-  = CM { cm_var = mapTM f cvar, cm_lit = mapTM f clit-       , cm_co = mapTM f cco, cm_type = mapTM f ctype-       , cm_cast = mapTM (mapTM f) ccast, cm_app = mapTM (mapTM f) capp-       , cm_lam = mapTM (mapTM f) clam, cm_letn = mapTM (mapTM (mapTM f)) cletn-       , cm_letr = mapTM (mapTM (mapTM f)) cletr, cm_case = mapTM (mapTM f) ccase-       , cm_ecase = mapTM (mapTM f) cecase, cm_tick = mapTM (mapTM f) ctick }- ftE :: (a->Bool) -> CoreMapX a -> CoreMapX a ftE f (CM { cm_var = cvar, cm_lit = clit           , cm_co = cco, cm_type = ctype@@ -281,11 +283,25 @@           , cm_ecase = cecase, cm_tick = ctick })   = CM { cm_var = filterTM f cvar, cm_lit = filterTM f clit        , cm_co = filterTM f cco, cm_type = filterTM f ctype-       , cm_cast = mapTM (filterTM f) ccast, cm_app = mapTM (filterTM f) capp-       , cm_lam = mapTM (filterTM f) clam, cm_letn = mapTM (mapTM (filterTM f)) cletn-       , cm_letr = mapTM (mapTM (filterTM f)) cletr, cm_case = mapTM (filterTM f) ccase-       , cm_ecase = mapTM (filterTM f) cecase, cm_tick = mapTM (filterTM f) ctick }+       , 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@@ -394,6 +410,11 @@        , 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@@ -402,8 +423,8 @@    lookupTM = lkA emptyCME    alterTM  = xtA emptyCME    foldTM   = fdA-   mapTM    = mapA    filterTM = ftA+   mapMaybeTM = mpA  instance Eq (DeBruijn CoreAlt) where   D env1 a1 == D env2 a2 = go a1 a2 where@@ -416,17 +437,11 @@           D (extendCMEs env1 bs1) rhs1 == D (extendCMEs env2 bs2) rhs2     go _ _ = False -mapA :: (a->b) -> AltMap a -> AltMap b-mapA f (AM { am_deflt = adeflt, am_data = adata, am_lit = alit })-  = AM { am_deflt = mapTM f adeflt-       , am_data = mapTM (mapTM f) adata-       , am_lit = mapTM (mapTM f) alit }- ftA :: (a->Bool) -> AltMap a -> AltMap a ftA f (AM { am_deflt = adeflt, am_data = adata, am_lit = alit })   = AM { am_deflt = filterTM f adeflt-       , am_data = mapTM (filterTM f) adata-       , am_lit = mapTM (filterTM f) alit }+       , 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)@@ -447,3 +462,9 @@ fdA k m = foldTM k (am_deflt m)         . foldTM (foldTM k) (am_data m)         . foldTM (foldTM k) (am_lit m)++mpA :: (a -> Maybe b) -> AltMap a -> AltMap b+mpA f (AM { am_deflt = adeflt, am_data = adata, am_lit = alit })+  = AM { am_deflt = mapMaybeTM f adeflt+       , am_data = fmap (mapMaybeTM f) adata+       , am_lit = fmap (mapMaybeTM f) alit }
GHC/Core/Map/Type.hs view
@@ -38,6 +38,8 @@ 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@@ -54,7 +56,6 @@ import qualified Data.IntMap as IntMap  import Control.Monad ( (>=>) )-import GHC.Data.Maybe  -- 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)@@ -83,26 +84,36 @@ -- 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-   mapTM f     (CoercionMap m) = CoercionMap (mapTM f 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-  mapTM f (CoercionMapX core_tm)  = CoercionMapX (mapTM 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@@ -141,13 +152,6 @@   = TM { tm_var    :: VarMap a        , tm_app    :: TypeMapG (TypeMapG a)  -- Note [Equality on AppTys] in GHC.Core.Type        , tm_tycon  :: DNameEnv a--         -- only InvisArg arrows here-       , tm_funty  :: TypeMapG (TypeMapG (TypeMapG a))-                       -- keyed on the argument, result rep, and result-                       -- constraints are never linear-restricted and are always lifted-                       -- See also Note [Equality on FunTys] in GHC.Core.TyCo.Rep-        , tm_forall :: TypeMapG (BndrMap a) -- See Note [Binders] in GHC.Core.Map.Expr        , tm_tylit  :: TyLitMap a        , tm_coerce :: Maybe a@@ -157,54 +161,41 @@ -- | Squeeze out any synonyms, and change TyConApps to nested AppTys. Why the -- last one? See Note [Equality on AppTys] in GHC.Core.Type ----- Note, however, that we keep Constraint and Type apart here, despite the fact--- that they are both synonyms of TYPE 'LiftedRep (see #11715).--- -- 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.-  | Just (tc, tys@(_:_)) <- tcSplitTyConApp_maybe ty+  -- 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' <- tcView ty = Just ty'+  | 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-   mapTM    = mapT    filterTM = filterT+   mapMaybeTM = mpT  instance Eq (DeBruijn Type) where   (==) = eqDeBruijnType -{- Note [Using tcView inside eqDeBruijnType]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-`eqDeBruijnType` uses `tcView` and thus treats Type and Constraint as-distinct -- see Note [coreView vs tcView] in GHC.Core.Type. We do that because-`eqDeBruijnType` is used in TrieMaps, which are used for instance for instance-selection in the type checker. [Or at least will be soon.]--However, the odds that we have two expressions that are identical save for the-'Type'/'Constraint' distinction are low. (Not impossible to do. But doubtful-anyone has ever done so in the history of Haskell.)--And it's actually all OK: 'eqExpr' is conservative: if `eqExpr e1 e2` returns-'True', thne it must be that `e1` behaves identically to `e2` in all contexts.-But if `eqExpr e1 e2` returns 'False', then we learn nothing. The use of-'tcView' where we expect 'coreView' means 'eqExpr' returns 'False' bit more-often that it should. This might, say, stop a `RULE` from firing or CSE from-optimizing an expression. Stopping `RULE` firing is good actually: `RULES` are-written in Haskell, where `Type /= Constraint`. Stopping CSE is unfortunate,-but tolerable.--}- -- | An equality relation between two 'Type's (known below as @t1 :: k2@ -- and @t2 :: k2@) data TypeEquality = TNEQ -- ^ @t1 /= t2@@@ -241,14 +232,14 @@     andEq TEQX e = hasCast e     andEq TEQ  e = e -    -- See Note [Comparing nullary type synonyms] in GHC.Core.Type-    go (D _ (TyConApp tc1 [])) (D _ (TyConApp tc2 []))-      | tc1 == tc2-      = TEQ+    -- 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')-      -- See Note [Using tcView inside eqDeBruijnType]-      | Just new_t  <- tcView t  = go (D env new_t) env_t'-      | Just new_t' <- tcView t' = go env_t (D env' new_t')+      | 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@@ -258,9 +249,9 @@           (TyVarTy v, TyVarTy v')               -> liftEquality $ eqDeBruijnVar (D env v) (D env' v')           -- See Note [Equality on AppTys] in GHC.Core.Type-          (AppTy t1 t2, s) | Just (t1', t2') <- repSplitAppTy_maybe s+          (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) <- repSplitAppTy_maybe s+          (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') @@ -276,16 +267,19 @@           (LitTy l, LitTy l')               -> liftEquality (l == l')           (ForAllTy (Bndr tv vis) ty, ForAllTy (Bndr tv' vis') ty')-              -> -- See Note [ForAllTy and typechecker equality] in-                 -- GHC.Tc.Solver.Canonical for why we use `sameVis` here-                 liftEquality (vis `sameVis` vis') `andEq`+              -> -- 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 -    gos _  _  []         []         = TEQ+    -- 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@@ -308,23 +302,10 @@ emptyT = TM { tm_var  = emptyTM             , tm_app  = emptyTM             , tm_tycon  = emptyDNameEnv-            , tm_funty  = emptyTM             , tm_forall = emptyTM             , 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_funty = tfunty, 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_funty  = mapTM (mapTM (mapTM f)) tfunty-       , 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@@ -334,19 +315,17 @@     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 (Bndr tv _) ty)   = tm_forall >.> lkG (D (extendCME env tv) ty)                                                >=> lkBndr env tv-    go (FunTy InvisArg _ arg res)-      | Just res_rep <- getRuntimeRep_maybe res-                                   = tm_funty >.> lkG (D env arg)-                                              >=> lkG (D env res_rep)-                                              >=> lkG (D env res)-    go ty@(FunTy {})               = pprPanic "lkT FunTy" (ppr ty)     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@@ -355,16 +334,15 @@ 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 env (FunTy InvisArg _ t1 t2)) f m = m { tm_funty = tm_funty m |> xtG (D env t1)-                                                                    |>> xtG (D env t2_rep)-                                                                    |>> xtG (D env t2) f }-  where t2_rep = expectJust "xtT FunTy InvisArg" (getRuntimeRep_maybe t2) 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) @@ -372,20 +350,18 @@ fdT k m = foldTM k (tm_var m)         . foldTM (foldTM k) (tm_app m)         . foldTM k (tm_tycon m)-        . foldTM (foldTM (foldTM k)) (tm_funty 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_funty = tfunty, tm_forall = tforall, tm_tylit = tlit+              , tm_forall = tforall, tm_tylit = tlit               , tm_coerce = tcoerce })   = TM { tm_var    = filterTM f tvar-       , tm_app    = mapTM (filterTM f) tapp+       , tm_app    = fmap (filterTM f) tapp        , tm_tycon  = filterTM f ttycon-       , tm_funty  = mapTM (mapTM (filterTM f)) tfunty-       , tm_forall = mapTM (filterTM f) tforall+       , tm_forall = fmap (filterTM f) tforall        , tm_tylit  = filterTM f tlit        , tm_coerce = filterMaybe f tcoerce } @@ -395,22 +371,23 @@                       , 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-   mapTM    = mapTyLit    filterTM = filterTyLit+   mapMaybeTM = mpTyLit  emptyTyLitMap :: TyLitMap a emptyTyLitMap = TLM { tlm_number = Map.empty, tlm_string = emptyUFM, tlm_char = Map.empty } -mapTyLit :: (a->b) -> TyLitMap a -> TyLitMap b-mapTyLit 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 }- lkTyLit :: TyLit -> TyLitMap a -> Maybe a lkTyLit l =   case l of@@ -426,7 +403,7 @@     CharTyLit n -> m { tlm_char = Map.alter f n (tlm_char m) }  foldTyLit :: (a -> b -> b) -> TyLitMap a -> b -> b-foldTyLit l m = flip (foldUFM l) (tlm_string m)+foldTyLit l m = flip (nonDetFoldUFM l) (tlm_string m)               . flip (Map.foldr l) (tlm_number m)               . flip (Map.foldr l) (tlm_char m) @@ -434,11 +411,20 @@ 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)@@ -456,8 +442,8 @@     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)-    filterTM f (TypeMap m) = TypeMap (mapTM (filterTM f) 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@@ -488,17 +474,21 @@  -- | 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)+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-  mapTM f (LooseTypeMap m) = LooseTypeMap (mapTM f m)   filterTM f (LooseTypeMap m) = LooseTypeMap (filterTM f m)+  mapMaybeTM f (LooseTypeMap m) = LooseTypeMap (mapMaybeTM f m)  {- ************************************************************************@@ -566,21 +556,25 @@ -- 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-   mapTM    = mapBndrMap    filterTM = ftBndrMap--mapBndrMap :: (a -> b) -> BndrMap a -> BndrMap b-mapBndrMap f (BndrMap tm) = BndrMap (mapTM (mapTM f) tm)+   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.@@ -596,24 +590,24 @@   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 (mapTM (filterTM f) tm)+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-   mapTM    = mapVar    filterTM = ftVar--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 }+   mapMaybeTM = mpVar  lkVar :: CmEnv -> Var -> VarMap a -> Maybe a lkVar env v@@ -639,9 +633,24 @@ ftVar f (VM { vm_bvar = bv, vm_fvar = fv })   = VM { vm_bvar = filterTM f bv, vm_fvar = filterTM f fv } +mpVar :: (a -> Maybe b) -> VarMap a -> VarMap b+mpVar f (VM { vm_bvar = bv, vm_fvar = fv })+  = VM { vm_bvar = mapMaybeTM f bv, vm_fvar = mapMaybeTM f fv }+ ------------------------------------------------- lkDNamed :: NamedThing n => n -> DNameEnv a -> Maybe a lkDNamed n env = lookupDNameEnv env (getName n)  xtDNamed :: NamedThing n => n -> XT a -> DNameEnv a -> DNameEnv a xtDNamed tc f m = alterDNameEnv f m (getName tc)++mpT :: (a -> Maybe b) -> TypeMapX a -> TypeMapX b+mpT f (TM { tm_var  = tvar, tm_app = tapp, tm_tycon = ttycon+          , tm_forall = tforall, tm_tylit = tlit+          , tm_coerce = tcoerce })+  = TM { tm_var    = mapMaybeTM f tvar+       , tm_app    = fmap (mapMaybeTM f) tapp+       , tm_tycon  = mapMaybeTM f ttycon+       , tm_forall = fmap (mapMaybeTM f) tforall+       , tm_tylit  = mapMaybeTM f tlit+       , tm_coerce = tcoerce >>= f }
GHC/Core/Multiplicity.hs view
@@ -11,8 +11,8 @@ -} module GHC.Core.Multiplicity   ( Mult-  , pattern One-  , pattern Many+  , pattern OneTy+  , pattern ManyTy   , isMultMul   , mkMultAdd   , mkMultMul@@ -29,14 +29,18 @@   , scaleScaled   , IsSubmult(..)   , submult-  , mapScaledType) where+  , 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.Core.Type import GHC.Builtin.Names (multMulTyConKey) import GHC.Types.Unique (hasKey) @@ -49,22 +53,30 @@ [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/pull/111] which+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)-    - Because, as a type constructor, the type of function now has an extra-      argument, the notation (->) is no longer suitable. We named the function-      type constructor `FUN`.-    - (->) retains its backward compatible meaning: `(->) a b = a -> b`. To-      achieve this, `(->)` is defined as a type synonym to `FUN Many` (see+    - 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).-- Multiplicities can be reified in Haskell as types of kind-  `GHC.Types.Multiplicity`-- Ground multiplicity (that is, without a variable) can be `One` or `Many`+- 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”@@ -73,19 +85,9 @@   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-  infra) has a more precise definition of “consuming exactly once”.-- Data types can have unrestricted fields (the canonical example being the-  `Unrestricted` data type), then these don't need to be consumed for a value to-  be consumed exactly once. So consuming a value of type `Unrestricted` exactly-  once means forcing it at least once.-- Why “at least once”? Because if `case u of { C x y -> f (C x y) }` is linear-  (provided `f` is a linear function). So 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 a 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.+  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@@ -100,6 +102,8 @@   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:@@ -132,7 +136,7 @@ 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 environements f_ue from the typechecking of f, and u_ue from the+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.@@ -206,8 +210,8 @@  Note [Data constructors are linear by default] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Data constructors defined without -XLinearTypes (as well as data constructors-defined with the Haskell 98 in all circumstances) have all their fields linear.+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 @@ -217,10 +221,52 @@      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@@ -295,13 +341,13 @@ -- With only two multiplicities One and Many, we can always replace -- p + q by Many. See Note [Overapproximating multiplicities]. mkMultAdd :: Mult -> Mult -> Mult-mkMultAdd _ _ = Many+mkMultAdd _ _ = ManyTy  mkMultMul :: Mult -> Mult -> Mult-mkMultMul One p = p-mkMultMul p One = p-mkMultMul Many _ = Many-mkMultMul _ Many = Many+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@@ -329,8 +375,30 @@ -- value of multiplicity @w2@ is expected. This is a partial order.  submult :: Mult -> Mult -> IsSubmult-submult _     Many = Submult-submult One   One  = Submult+submult _     ManyTy = Submult+submult OneTy OneTy  = Submult -- The 1 <= p rule-submult One   _    = Submult+submult OneTy _    = Submult submult _     _    = Unknown++pprArrowWithMultiplicity :: FunTyFlag -> Either Bool SDoc -> SDoc+-- Pretty-print a multiplicity arrow.  The multiplicity itself+-- is described by the (Either Bool SDoc)+--    Left False   -- Many+--    Left True    -- One+--    Right doc    -- Something else+-- In the Right case, the doc is in parens if not atomic+pprArrowWithMultiplicity af pp_mult+  | isFUNArg af+  = case pp_mult of+      Left False -> arrow+      Left True  -> lollipop+      Right doc  -> text "%" <> doc <+> arrow+  | otherwise+  = ppr (funTyFlagTyCon af)++-- | In Core, without `-dlinear-core-lint`, some function must ignore+-- multiplicities. See Note [Linting linearity] in GHC.Core.Lint.+data MultiplicityFlag+  = RespectMultiplicities+  | IgnoreMultiplicities
GHC/Core/Opt/Arity.hs view
@@ -7,1985 +7,3256 @@ -}  {-# LANGUAGE CPP #-}-{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}---- | Arity and eta expansion-module GHC.Core.Opt.Arity-   ( manifestArity, joinRhsArity, exprArity, typeArity-   , exprEtaExpandArity, findRhsArity-   , etaExpand, etaExpandAT-   , exprBotStrictness_maybe--   -- ** ArityType-   , ArityType(..), mkBotArityType, mkTopArityType, expandableArityType-   , arityTypeArity, maxWithArity, idArityType--   -- ** Join points-   , etaExpandToJoinPoint, etaExpandToJoinPointRule--   -- ** Coercions and casts-   , pushCoArg, pushCoArgs, pushCoValArg, pushCoTyArg-   , pushCoercionIntoLambda, pushCoDataCon, collectBindersPushingCo-   )-where--import GHC.Prelude--import GHC.Driver.Session ( DynFlags, GeneralFlag(..), gopt )--import GHC.Core-import GHC.Core.FVs-import GHC.Core.Utils-import GHC.Core.DataCon-import GHC.Core.TyCon     ( tyConArity )-import GHC.Core.TyCon.RecWalk     ( initRecTc, checkRecTc )-import GHC.Core.Predicate ( isDictTy, isCallStackPredTy )-import GHC.Core.Multiplicity---- We have two sorts of substitution:---   GHC.Core.Subst.Subst, and GHC.Core.TyCo.TCvSubst--- 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.Types.Demand-import GHC.Types.Var-import GHC.Types.Var.Env-import GHC.Types.Id-import GHC.Types.Var.Set-import GHC.Types.Basic-import GHC.Types.Tickish--import GHC.Builtin.Uniques-import GHC.Data.FastString-import GHC.Data.Pair--import GHC.Utils.Constants (debugIsOn)-import GHC.Utils.Outputable-import GHC.Utils.Panic-import GHC.Utils.Panic.Plain-import GHC.Utils.Trace-import GHC.Utils.Misc--{--************************************************************************-*                                                                      *-              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) (coercionRKind co)-                                        -- See Note [exprArity invariant]-    go (App e (Type _))            = go e-    go (App f a) | exprIsTrivial a = (go f - 1) `max` 0-        -- See Note [exprArity for applications]-        -- 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')  <- splitForAllTyCoVar_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 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-      = []------------------exprBotStrictness_maybe :: CoreExpr -> Maybe (Arity, DmdSig)--- A cheap and cheerful function that identifies bottoming functions--- and gives them a suitable strictness signatures.  It's used during--- float-out-exprBotStrictness_maybe e-  = case getBotArity (arityType botStrictnessArityEnv e) of-        Nothing -> Nothing-        Just ar -> Just (ar, sig ar)-  where-    sig ar = mkClosedDmdSig (replicate ar topDmd) botDiv--{--Note [exprArity invariant]-~~~~~~~~~~~~~~~~~~~~~~~~~~-exprArity has the following invariants:--  (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 GHC.Iface.Tidy 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 GHC.Iface.Tidy, 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 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 --------------Note [exprArity for applications]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When we come to an application we check that the arg is trivial.-   eg  f (fac x) does not have arity 2,-                 even if f has arity 3!--* We require that is trivial rather merely cheap.  Suppose f has arity 2.-  Then    f (Just y)-  has arity 0, because if we gave it arity 1 and then inlined f we'd get-          let v = Just y in \w. <f-body>-  which has arity 0.  And we try to maintain the invariant that we don't-  have arity decreases.--*  The `max 0` is important!  (\x y -> f x) has arity 2, even if f is-   unknown, hence arity 0---************************************************************************-*                                                                      *-           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]-~~~~~~~~~~~~~~~~~~~~~~~~~~-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-#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 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.--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-  decompose Int to a function type.   Hence the final case in eta_expand.--Note [The state-transformer hack]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose we have-        f = e-where e has arity n.  Then, if we know from the context that f has-a usage type like-        t1 -> ... -> tn -1-> t(n+1) -1-> ... -1-> tm -> ...-then we can expand the arity to m.  This usage type says that-any application (x e1 .. en) will be applied to uniquely to (m-n) more args-Consider f = \x. let y = <expensive>-                 in case x of-                      True  -> foo-                      False -> \(s:RealWorld) -> e-where foo has arity 1.  Then we want the state hack to-apply to foo too, so we can eta expand the case.--Then we expect that if f is applied to one arg, it'll be applied to two-(that's the hack -- we don't really know, and sometimes it's false)-See also Id.isOneShotBndr.--Note [State hack and bottoming functions]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-It's a terrible idea to use the state hack on a bottoming function.-Here's what happens (#2861):--  f :: String -> IO T-  f = \p. error "..."--Eta-expand, using the state hack:--  f = \p. (\s. ((error "...") |> g1) s) |> g2-  g1 :: IO T ~ (S -> (S,T))-  g2 :: (S -> (S,T)) ~ IO T--Extrude the g2--  f' = \p. \s. ((error "...") |> g1) s-  f = f' |> (String -> g2)--Discard args for 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 #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).--We use the following notation:-  at  ::= \o1..on.div-  div ::= T | x | ⊥-  o   ::= ? | 1-And omit the \. if n = 0. Examples:-  \?11.T stands for @AT [NoOneShotInfo,OneShotLam,OneShotLam] topDiv@-  ⊥      stands for @AT [] botDiv@-See the 'Outputable' instance for more information. It's pretty simple.--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.--   We allow ourselves to eta-expand bottoming functions, even-   if doing so may lose some `seq` sharing,-       let x = <expensive> in \y. error (g x y)-       ==> \y. let x = <expensive> in error (g x y)-- * If @at = AT [o1,..,on] topDiv@ (notation: \o1..on.T), then expanding 'f'-   to @\x1..xn. f x1..xn@ loses no sharing, assuming the calls of f respect-   the one-shot-ness o1..on of its definition.--   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#--Example:-      f = \x\y. let v = <expensive> in-          \s(one-shot) \t(one-shot). blah-      'f' has arity type \??11.T-      The one-shot-ness means we can, in effect, push that-      'let' inside the \st.---Suppose f = \xy. x+y-Then  f             :: \??.T-      f v           :: \?.T-      f <expensive> :: T--}----- | 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].------ We rely on this lattice structure for fixed-point iteration in--- 'findRhsArity'. For the semantics of 'ArityType', see Note [ArityType].-data ArityType-  = AT ![OneShotInfo] !Divergence-  -- ^ @AT oss div@ means this value can safely be eta-expanded @length oss@-  -- times, provided use sites respect the 'OneShotInfo's in @oss@.-  -- A 'OneShotLam' annotation can come from two sources:-  --     * The user annotated a lambda as one-shot with 'GHC.Exts.oneShot'-  --     * It's from a lambda binder of a type affected by `-fstate-hack`.-  --       See 'idStateHackOneShotInfo'.-  -- In both cases, 'OneShotLam' should win over 'NoOneShotInfo', see-  -- Note [Combining case branches].-  ---  -- If @div@ is dead-ending ('isDeadEndDiv'), then application to-  -- @length os@ arguments will surely diverge, similar to the situation-  -- with 'DmdType'.-  deriving Eq---- | 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 OneShotLam    = char '1'-      pp_os NoOneShotInfo = char '?'--mkBotArityType :: [OneShotInfo] -> ArityType-mkBotArityType oss = AT oss botDiv--botArityType :: ArityType-botArityType = mkBotArityType []--mkTopArityType :: [OneShotInfo] -> ArityType-mkTopArityType oss = AT oss topDiv--topArityType :: ArityType-topArityType = mkTopArityType []---- | The number of value args for the arity type-arityTypeArity :: ArityType -> Arity-arityTypeArity (AT oss _) = length oss---- | True <=> eta-expansion will add at least one lambda-expandableArityType :: ArityType -> Bool-expandableArityType at = arityTypeArity at > 0---- | See Note [Dead ends] in "GHC.Types.Demand".--- Bottom implies a dead end.-isDeadEndArityType :: ArityType -> Bool-isDeadEndArityType (AT _ div) = isDeadEndDiv div---- | Expand a non-bottoming arity type so that it has at least the given arity.-maxWithArity :: ArityType -> Arity -> ArityType-maxWithArity at@(AT oss div) !ar-  | isDeadEndArityType at    = at-  | oss `lengthAtLeast` ar   = at-  | otherwise                = AT (take ar $ oss ++ repeat NoOneShotInfo) div---- | 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'.-minWithArity :: ArityType -> Arity -> ArityType-minWithArity at@(AT oss _) ar-  | oss `lengthAtMost` ar = at-  | otherwise             = AT (take ar oss) topDiv--takeWhileOneShot :: ArityType -> ArityType-takeWhileOneShot (AT oss div)-  | isDeadEndDiv div = AT (takeWhile isOneShotInfo oss) topDiv-  | otherwise        = AT (takeWhile isOneShotInfo oss) div---- | The Arity returned is the number of value args the--- expression can be applied to without doing much work-exprEtaExpandArity :: DynFlags -> CoreExpr -> ArityType--- exprEtaExpandArity is used when eta expanding---      e  ==>  \xy -> e x y-exprEtaExpandArity dflags e = arityType (etaExpandArityEnv dflags) e--getBotArity :: ArityType -> Maybe Arity--- Arity of a divergent function-getBotArity (AT oss div)-  | isDeadEndDiv div = Just $ length oss-  | otherwise        = Nothing-------------------------findRhsArity :: DynFlags -> Id -> CoreExpr -> Arity -> ArityType--- This implements the fixpoint loop for arity analysis--- See Note [Arity analysis]--- If findRhsArity e = (n, is_bot) then---  (a) any application of e to <n arguments will not do much work,---      so it is safe to expand e  ==>  (\x1..xn. e x1 .. xn)---  (b) if is_bot=True, then e applied to n args is guaranteed bottom-findRhsArity dflags bndr rhs old_arity-  = go 0 botArityType-      -- 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-  where-    go :: Int -> ArityType -> ArityType-    go !n cur_at@(AT oss div)-      | not (isDeadEndDiv div)           -- the "stop right away" case-      , length oss <= 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 cur_at--    step :: ArityType -> ArityType-    step at = -- pprTrace "step" (ppr bndr <+> ppr at <+> ppr (arityType env rhs)) $-              arityType env rhs-      where-        env = extendSigEnv (findRhsArityEnv dflags) bndr at---{--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 [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.--}--arityLam :: Id -> ArityType -> ArityType-arityLam id (AT oss div) = AT (idStateHackOneShotInfo id : oss) div--floatIn :: Bool -> ArityType -> ArityType--- We have something like (let x = E in b),--- where b has the given arity type.-floatIn cheap at-  | isDeadEndArityType at || cheap = at-  -- If E is not cheap, keep arity only for one-shots-  | otherwise                      = takeWhileOneShot at--arityApp :: ArityType -> Bool -> ArityType--- Processing (fun arg) where at is the ArityType of fun,--- Knock off an argument and behave like 'let'-arityApp (AT (_:oss) div) cheap = floatIn cheap (AT oss div)-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 :: ArityType -> ArityType -> ArityType-andArityType (AT (os1:oss1) div1) (AT (os2:oss2) div2)-  | AT oss' div' <- andArityType (AT oss1 div1) (AT oss2 div2)-  = AT ((os1 `bestOneShot` os2) : oss') div' -- See Note [Combining case branches]-andArityType at1@(AT []         div1) at2-  | isDeadEndDiv div1 = at2                  -- Note [ABot branches: max arity wins]-  | otherwise         = at1                  -- See Note [Combining case branches]-andArityType at1                  at2@(AT []         div2)-  | isDeadEndDiv div2 = at1                  -- Note [ABot branches: max arity wins]-  | otherwise         = at2                  -- See Note [Combining case branches]--{- Note [ABot branches: max arity wins]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-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.--Note [Combining case branches]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--Unless we can conclude that **all** branches are safe to eta-expand then we-must pessimisticaly conclude that we can't eta-expand. See #21694 for where this-went wrong.-We can do better in the long run, but for the 9.4/9.2 branches we choose to simply-ignore oneshot annotations for the time being.---Note [Arity trimming]-~~~~~~~~~~~~~~~~~~~~~-Consider ((\x y. blah) |> co), where co :: (Int->Int->Int) ~ (Int -> F a) , and-F is some type family.--Because of Note [exprArity invariant], item (2), we must return with arity at-most 1, because typeArity (Int -> F a) = 1.  So we have to trim the result of-calling arityType on (\x y. blah).  Failing to do so, and hence breaking the-exprArity invariant, 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 [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.--}--------------------------------- | Each of the entry-points of the analyser ('arityType') has different--- requirements. The entry-points are------   1. 'exprBotStrictness_maybe'---   2. 'exprEtaExpandArity'---   3. 'findRhsArity'------ For each of the entry-points, there is a separate mode that governs------   1. How pedantic we are wrt. ⊥, in 'pedanticBottoms'.---   2. Whether we store arity signatures for non-recursive let-bindings,---      accessed in 'extendSigEnv'/'lookupSigEnv'.---      See Note [Arity analysis] why that's important.---   3. Which expressions we consider cheap to float inside a lambda,---      in 'myExprIsCheap'.-data AnalysisMode-  = BotStrictness-  -- ^ Used during 'exprBotStrictness_maybe'.-  | EtaExpandArity { am_ped_bot :: !Bool-                   , am_dicts_cheap :: !Bool }-  -- ^ Used for finding an expression's eta-expanding arity quickly, without-  -- fixed-point iteration ('exprEtaExpandArity').-  | FindRhsArity { am_ped_bot :: !Bool-                 , am_dicts_cheap :: !Bool-                 , am_sigs :: !(IdEnv ArityType) }-  -- ^ Used for regular, fixed-point arity analysis ('findRhsArity').-  --   See Note [Arity analysis] for details about fixed-point iteration.-  --   INVARIANT: Disjoint with 'ae_joins'.--data ArityEnv-  = AE-  { ae_mode   :: !AnalysisMode-  -- ^ The analysis mode. See 'AnalysisMode'.-  , ae_joins  :: !IdSet-  -- ^ In-scope join points. See Note [Eta-expansion and join points]-  --   INVARIANT: Disjoint with the domain of 'am_sigs' (if present).-  }---- | The @ArityEnv@ used by 'exprBotStrictness_maybe'. Pedantic about bottoms--- and no application is ever considered cheap.-botStrictnessArityEnv :: ArityEnv-botStrictnessArityEnv = AE { ae_mode = BotStrictness, ae_joins = emptyVarSet }---- | The @ArityEnv@ used by 'exprEtaExpandArity'.-etaExpandArityEnv :: DynFlags -> ArityEnv-etaExpandArityEnv dflags-  = AE { ae_mode  = EtaExpandArity { am_ped_bot = gopt Opt_PedanticBottoms dflags-                                   , am_dicts_cheap = gopt Opt_DictsCheap dflags }-       , ae_joins = emptyVarSet }---- | The @ArityEnv@ used by 'findRhsArity'.-findRhsArityEnv :: DynFlags -> ArityEnv-findRhsArityEnv dflags-  = AE { ae_mode  = FindRhsArity { am_ped_bot = gopt Opt_PedanticBottoms dflags-                                 , am_dicts_cheap = gopt Opt_DictsCheap dflags-                                 , am_sigs = emptyVarEnv }-       , ae_joins = emptyVarSet }---- First some internal functions in snake_case for deleting in certain VarEnvs--- of the ArityType. Don't call these; call delInScope* instead!--modifySigEnv :: (IdEnv ArityType -> IdEnv ArityType) -> ArityEnv -> ArityEnv-modifySigEnv f env@AE { ae_mode = am@FindRhsArity{am_sigs = sigs} } =-  env { ae_mode = am { am_sigs = f sigs } }-modifySigEnv _ env = env-{-# 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 #-}--del_join_env :: JoinId -> ArityEnv -> ArityEnv -- internal!-del_join_env id env@(AE { ae_joins = joins })-  = env { ae_joins = delVarSet joins id }-{-# INLINE del_join_env #-}--del_join_env_list :: [JoinId] -> ArityEnv -> ArityEnv -- internal!-del_join_env_list ids env@(AE { ae_joins = joins })-  = env { ae_joins = delVarSetList joins ids }-{-# INLINE del_join_env_list #-}---- end of internal deletion functions--extendJoinEnv :: ArityEnv -> [JoinId] -> ArityEnv-extendJoinEnv env@(AE { ae_joins = joins }) join_ids-  = del_sig_env_list join_ids-  $ env { ae_joins = joins `extendVarSetList` join_ids }--extendSigEnv :: ArityEnv -> Id -> ArityType -> ArityEnv-extendSigEnv env id ar_ty-  = del_join_env id (modifySigEnv (\sigs -> extendVarEnv sigs id ar_ty) env)--delInScope :: ArityEnv -> Id -> ArityEnv-delInScope env id = del_join_env id $ del_sig_env id env--delInScopeList :: ArityEnv -> [Id] -> ArityEnv-delInScopeList env ids = del_join_env_list ids $ del_sig_env_list ids env--lookupSigEnv :: ArityEnv -> Id -> Maybe ArityType-lookupSigEnv AE{ ae_mode = mode } id = case mode of-  BotStrictness                  -> Nothing-  EtaExpandArity{}               -> Nothing-  FindRhsArity{ am_sigs = sigs } -> lookupVarEnv sigs id---- | Whether the analysis should be pedantic about bottoms.--- 'exprBotStrictness_maybe' always is.-pedanticBottoms :: ArityEnv -> Bool-pedanticBottoms AE{ ae_mode = mode } = case mode of-  BotStrictness                          -> True-  EtaExpandArity{ am_ped_bot = ped_bot } -> ped_bot-  FindRhsArity{ am_ped_bot = ped_bot }   -> ped_bot---- | 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{ae_mode = mode} e mb_ty = case mode of-  BotStrictness -> False-  _             -> cheap_dict || cheap_fun e-    where-      cheap_dict = case mb_ty of-                     Nothing -> False-                     Just ty -> (am_dicts_cheap mode && isDictTy ty)-                                || isCallStackPredTy ty-        -- See Note [Eta expanding through dictionaries]-        -- See Note [Eta expanding through CallStacks]--      cheap_fun e = case mode of-#if __GLASGOW_HASKELL__ <= 900-        BotStrictness                -> panic "impossible"-#endif-        EtaExpandArity{}             -> exprIsCheap e-        FindRhsArity{am_sigs = sigs} -> exprIsCheapX (myIsCheapApp sigs) 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 ArityType -> 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 ArityType.-  -- Roughly approximate what 'isCheapApp' is doing.-  Just (AT oss div)-    | isDeadEndDiv div -> True -- See Note [isCheapApp: bottoming functions] in GHC.Core.Utils-    | n_val_args < length oss -> True -- Essentially isWorkFreeApp-    | otherwise -> False-------------------arityType :: ArityEnv -> CoreExpr -> ArityType--arityType env (Cast e co)-  = minWithArity (arityType env e) co_arity -- See Note [Arity trimming]-  where-    co_arity = length (typeArity (coercionRKind 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-    -- #5441 is a nice demo--arityType env (Var v)-  | v `elemVarSet` ae_joins env-  = botArityType  -- See Note [Eta-expansion and join points]-  | Just at <- lookupSigEnv env v -- Local binding-  = at-  | otherwise-  = idArityType v--        -- 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 (arityType env fun) (myExprIsCheap 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 _ alts)-  | exprIsDeadEnd scrut || null alts-  = botArityType    -- Do not eta expand. See (1) in Note [Dealing with bottom]-  | not (pedanticBottoms env)  -- See (2) in Note [Dealing with bottom]-  , myExprIsCheap env scrut (Just (idType bndr))-  = alts_type-  | exprOkForSpeculation scrut-  = alts_type--  | otherwise                  -- In the remaining cases we may not push-  = takeWhileOneShot alts_type -- evaluation of the scrutinee in-  where-    env' = delInScope env bndr-    arity_type_alt (Alt _con bndrs rhs) = arityType (delInScopeList env' bndrs) rhs-    alts_type = foldr1 andArityType (map arity_type_alt alts)--arityType env (Let (NonRec j rhs) body)-  | Just join_arity <- isJoinId_maybe j-  , (_, rhs_body)   <- collectNBinders join_arity rhs-  = -- See Note [Eta-expansion and join points]-    andArityType (arityType env rhs_body)-                 (arityType env' body)-  where-     env' = extendJoinEnv env [j]--arityType env (Let (Rec pairs) body)-  | ((j,_):_) <- pairs-  , isJoinId j-  = -- See Note [Eta-expansion and join points]-    foldr (andArityType . do_one) (arityType env' body) pairs-  where-    env' = extendJoinEnv env (map fst pairs)-    do_one (j,rhs)-      | Just arity <- isJoinId_maybe j-      = arityType env' $ snd $ collectNBinders arity rhs-      | otherwise-      = pprPanic "arityType:joinrec" (ppr pairs)--arityType env (Let (NonRec b r) e)-  = floatIn cheap_rhs (arityType env' e)-  where-    cheap_rhs = myExprIsCheap env r (Just (idType b))-    env'      = extendSigEnv env b (arityType env r)--arityType env (Let (Rec prs) e)-  = floatIn (all is_cheap prs) (arityType env' e)-  where-    env'           = delInScopeList env (map fst prs)-    is_cheap (b,e) = myExprIsCheap env' e (Just (idType b))--arityType env (Tick t e)-  | not (tickishIsCode t)     = arityType env e--arityType _ _ = topArityType--{- Note [Eta-expansion and 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.  But currently the join point totally messes all that up,-because (thought of as a vanilla let-binding) the arity pinned on 'j'-is just 1.--Why don't we eta-expand j?  Because of-Note [Do not eta-expand join points] in GHC.Core.Opt.Simplify.Utils--Even if we don't eta-expand j, why is its arity only 1?-See invariant 2b in Note [Invariants on join points] in GHC.Core.--So we do this:--* Treat the RHS of a join-point binding, /after/ stripping off-  join-arity lambda-binders, as very like the body of the let.-  More precisely, do andArityType with the arityType from the-  body of the let.--* Dually, when we come to a /call/ of a join point, just no-op-  by returning ABot, the bottom element of ArityType,-  which so that: bot `andArityType` x = x--* This works if the join point is bound in the expression we are-  taking the arityType of.  But if it's bound further out, it makes-  no sense to say that (say) the arityType of (j False) is ABot.-  Bad things happen.  So we keep track of the in-scope join-point Ids-  in ae_join.--This will make f, above, have arity 2. Then, we'll eta-expand it thus:--  f x eta = (join j y = ... in case x of ...) eta--and the Simplify will automatically push that application of eta into-the join points.--An alternative (roughly equivalent) idea would be to carry an-environment mapping let-bound Ids to their ArityType.--}--idArityType :: Id -> ArityType-idArityType v-  | strict_sig <- idDmdSig v-  , not $ isTopSig strict_sig-  , (ds, div) <- splitDmdSig strict_sig-  , let arity = length ds-  -- Every strictness signature admits an arity signature!-  = AT (take arity one_shots) div-  | otherwise-  = AT (take (idArity v) one_shots) topDiv-  where-    one_shots :: [OneShotInfo]  -- One-shot-ness derived from the type-    one_shots = typeArity (idType v)--{--%************************************************************************-%*                                                                      *-              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 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. I think-that for the use in CorePrep it really doesn't matter; and if-it does, then CoreToStg.myCollectArgs will fall over.--(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 -> ArityType -> CoreExpr -> CoreExpr--- See Note [Eta expansion with ArityType]------ We pass in the InScopeSet from the simplifier to avoid recomputing--- it here, which can be jolly expensive if the casts are big--- In #18223 it took 10% of compile time just to do the exprFreeVars!-etaExpandAT in_scope (AT oss _) orig_expr-  = eta_expand in_scope oss orig_expr---- etaExpand arity e = res--- Then 'res' has at least 'arity' lambdas at the top---    possibly with a cast wrapped around the outside--- 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)-  = Cast (eta_expand in_scope one_shots expr) co--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 applictions--   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--Note [Check for reflexive casts in eta expansion]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-It turns out that the casts created by teh above mechanism are often Refl.-When casts are very deeply nested (as happens in #18223), the repetition-of types can make the overall term very large.  So there is a big-payoff in cancelling out casts aggressively wherever possible.-(See also Note [No crap in eta-expanded code].)--This matters particularly in etaInfoApp, where we-* Do beta-reduction on the fly-* Use getArg_maybe to get a cast out of the way,-  so that we can do beta reduction-Together this makes a big difference.  Consider when e is-   case x of-      True  -> (\x -> e1) |> c1-      False -> (\p -> e2) |> c2--When we eta-expand this to arity 1, say, etaInfoAbs will wrap-a (\eta) around the outside and use etaInfoApp to apply each-alternative to 'eta'.  We want to beta-reduce all that junk-away.--#18223 was a dramatic example in which the intermediate term was-grotesquely huge, even though the next Simplifier iteration squashed-it.  Better to kill it at birth.--The crucial spots in etaInfoApp are:-* `checkReflexiveMCo` in the (Cast e co) case of `go`-* `checkReflexiveMCo` in `pushCoArg`-* Less important: checkReflexiveMCo in the final case of `go`-Collectively these make a factor-of-5 difference to the total-allocation of T18223, so take care if you change this stuff!--Example:-   newtype N = MkN (Y->Z)-   f :: X -> N-   f = \(x::X). ((\(y::Y). blah) |> fco)--where fco :: (Y->Z) ~ N--mkEtaWW makes an EtaInfo of (EI [(eta1:X), (eta2:Y)] eta_co-  where-    eta_co :: (X->N) ~ (X->Y->Z)-    eta_co =  (<X> -> nco)-    nco :: N ~ (Y->Z)  -- Comes from topNormaliseNewType_maybe--Now, when we push that eta_co inward in etaInfoApp:-* In the (Cast e co) case, the 'fco' and 'nco' will meet, and-  should cancel.-* When we meet the (\y.e) we want no cast on the y.---}-----------------data EtaInfo = EI [Var] MCoercionR---- (EI bs co) describes a particular eta-expansion, as follows:---  Abstraction:  (\b1 b2 .. bn. []) |> sym co---  Application:  ([] |> co) b1 b2 .. bn------    e :: T    co :: T ~ (t1 -> t2 -> .. -> tn -> tr)---    e = (\b1 b2 ... bn. (e |> co) b1 b2 .. bn) |> sym co--instance Outputable EtaInfo where-  ppr (EI vs mco) = text "EI" <+> ppr vs <+> parens (ppr mco)---etaInfoApp :: InScopeSet -> CoreExpr -> EtaInfo -> CoreExpr--- (etaInfoApp s e (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 (Core.substTy 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 (text "etaInfoAppTy") 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 = mkEmptyTCvSubst in_scope--    go :: Int                -- For fresh names-       -> [OneShotInfo]      -- Number of value args to expand to-       -> TCvSubst -> 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 _       -- See Note [exprArity invariant]-       ----------- Done!  No more expansion needed-       = (getTCvInScope subst, EI [] MRefl)--    go n oss@(one_shot:oss1) subst ty       -- See Note [exprArity invariant]-       ----------- Forall types  (forall a. ty)-       | Just (tcv,ty') <- splitForAllTyCoVar_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) (mkHomoForAllMCo tcv' mco))--       ----------- Function types  (t1 -> t2)-       | Just (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 (idScaledType 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)-         (getTCvInScope 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---{- *********************************************************************-*                                                                      *-              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 ~ tyR-       -- tyL = forall (a1 :: k1). ty1-       -- tyR = forall (a2 :: k2). ty2--    co1 = mkSymCo (mkNthCo Nominal 0 co)-       -- co1 :: k2 ~N k1-       -- Note that NthCo can extract a Nominal equality between the-       -- kinds of the types related by a coercion between forall-types.-       -- See the NthCo case in GHC.Core.Lint.--    co2 = mkInstCo co (mkGReflLeftCo Nominal ty co1)-        -- co2 :: ty1[ (ty|>co1)/a1 ] ~ ty2[ ty/a2 ]-        -- Arg of mkInstCo is always nominal, hence mkNomReflCo--pushCoValArg :: CoercionR -> Maybe (MCoercionR, MCoercionR)--- We have (fun |> co) arg--- Push the coercion through to return---         (fun (arg |> co_arg)) |> co_res--- 'co' is always Representational--- If the second returned Coercion is actually Nothing, then no cast is necessary;--- the returned coercion would have been reflexive.-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-  , (co_mult, co1, co2) <- decomposeFunCo Representational co-  , isReflexiveCo co_mult-    -- We can't push the coercion in the case where co_mult isn't reflexivity:-    -- it could be an unsafe axiom, and losing this information could yield-    -- ill-typed terms. For instance (fun x ::(1) Int -> (fun _ -> () |> co) x)-    -- with co :: (Int -> ()) ~ (Int %1 -> ()), would reduce to (fun x ::(1) Int-    -- -> (fun _ ::(Many) Int -> ()) x) which is ill-typed--              -- If   co  :: (tyL1 -> tyL2) ~ (tyR1 -> tyR2)-              -- then co1 :: tyL1 ~ tyR1-              --      co2 :: tyL2 ~ tyR2-  = assertPpr (isFunTy tyR) (ppr co $$ ppr arg) $-    Just (coToMCo (mkSymCo co1), coToMCo co2)-    -- Critically, coToMCo to checks for ReflCo; the whole coercion may not-    -- be reflexive, but either of its components might be-    -- 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-    arg = funArgTy tyR-    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 (_, _s1,_s2) <- splitFunTy_maybe s1s2-    , Just (w1, t1,_t2) <- splitFunTy_maybe t1t2-    , (co_mult, co1, co2) <- decomposeFunCo Representational co-    , isReflexiveCo co_mult-      -- We can't push the coercion in the case where co_mult isn't-      -- reflexivity. See pushCoValArg for more details.-    = 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-      -- See #21555 / #21577 for a case where this trace fired but the cause was benign-    = -- 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's nothing wrong with it--  = let-        tc_arity       = tyConArity to_tc-        dc_univ_tyvars = dataConUnivTyVars dc-        dc_ex_tcvars   = dataConExTyCoVars dc-        arg_tys        = dataConRepArgTys dc--        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 (tyConRolesRepresentational to_tc)-        (psi_subst, to_ex_arg_tys)-          = liftCoSubstWithEx Representational-                              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) ]-    in-    assertPpr (eqType from_ty (mkTyConApp to_tc (map exprToType $ takeList dc_univ_tyvars dc_args))) dump_doc $-    assertPpr (equalLength val_args arg_tys) dump_doc $-    Just (dc, to_tc_arg_tys, to_ex_args ++ new_val_args)--  | otherwise-  = 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 :: <Int> -> 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 -> 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 (mkNthCo Nominal 0 co)  -- See Note [collectBindersPushingCo]-      = go_c (b:bs) e (mkInstCo co (mkNomReflCo (mkTyVarTy b)))--      | isCoVar b-      , let Pair tyL tyR = coercionKind co-      , assert (isForAllTy_co tyL) $-        isForAllTy_co tyR-      , isReflCo (mkNthCo Nominal 0 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 Representational co-      , isReflCo co_mult -- See Note [collectBindersPushingCo]-      , isReflCo co_arg  -- See Note [collectBindersPushingCo]-      = go_c (b:bs) e co_res--      | otherwise = (reverse bs, mkCast (Lam b e) co)--{---Note [collectBindersPushingCo]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We just look for coercions of form-   <type> % w -> blah-(and similarly for foralls) to keep this function simple.  We could do-more elaborate stuff, but it'd involve substitution etc.---}--{- *********************************************************************-*                                                                      *-                Join points-*                                                                      *-********************************************************************* -}------------------------ | Split an expression into the given number of binders and a body,--- eta-expanding if necessary. Counts value *and* type binders.-etaExpandToJoinPoint :: JoinArity -> CoreExpr -> ([CoreBndr], CoreExpr)-etaExpandToJoinPoint join_arity expr-  = go join_arity [] expr-  where-    go 0 rev_bs e         = (reverse rev_bs, e)-    go n rev_bs (Lam b e) = go (n-1) (b : rev_bs) e-    go n rev_bs e         = case etaBodyForJoinPoint n e of-                              (bs, e') -> (reverse rev_bs ++ bs, e')--etaExpandToJoinPointRule :: JoinArity -> CoreRule -> CoreRule-etaExpandToJoinPointRule _ rule@(BuiltinRule {})-  = warnPprTrace True "Can't eta-expand built-in rule:" (ppr rule)-      -- How did a local binding get a built-in rule anyway? Probably a plugin.-    rule-etaExpandToJoinPointRule join_arity rule@(Rule { ru_bndrs = bndrs, ru_rhs = rhs-                                               , ru_args  = args })-  | need_args == 0-  = rule-  | need_args < 0-  = pprPanic "etaExpandToJoinPointRule" (ppr join_arity $$ ppr rule)-  | otherwise-  = rule { ru_bndrs = bndrs ++ new_bndrs, ru_args = args ++ new_args-         , ru_rhs = new_rhs }-  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) <- splitForAllTyCoVar_maybe ty-      , let (subst', tv') = substVarBndr subst tv-      = go (n-1) res_ty subst' (tv' : rev_bs) (e `App` varToCoreExpr tv')-      | Just (mult, arg_ty, res_ty) <- splitFunTy_maybe ty-      , let (subst', b) = freshEtaId n subst (Scaled mult 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 -> Scaled 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-        Scaled mult' ty' = Type.substScaledTyUnchecked subst ty-        eta_id' = uniqAway (getTCvInScope subst) $-                  mkSysLocalOrCoVar (fsLit "eta") (mkBuiltinUnique n) mult' ty'-                  -- "OrCoVar" since this can be used to eta-expand-                  -- coercion abstractions-        subst'  = extendTCvInScope subst eta_id'+{-# LANGUAGE MultiWayIf #-}++-- | Arity and eta expansion+module GHC.Core.Opt.Arity+   ( -- Finding arity+     manifestArity, joinRhsArity, exprArity+   , findRhsArity, cheapArityType+   , ArityOpts(..)++   -- ** Eta expansion+   , exprEtaExpandArity, etaExpand, etaExpandAT++   -- ** Eta reduction+   , tryEtaReduce++   -- ** ArityType+   , ArityType, mkBotArityType+   , arityTypeArity, idArityType++   -- ** Bottoming things+   , exprIsDeadEnd, exprBotStrictness_maybe, arityTypeBotSigs_maybe++   -- ** typeArity and the state hack+   , typeArity, typeOneShots, typeOneShot+   , isOneShotBndr+   , isStateHackType++   -- * Lambdas+   , zapLamBndrs+++   -- ** Join points+   , etaExpandToJoinPoint, etaExpandToJoinPointRule++   -- ** Coercions and casts+   , pushCoArg, pushCoArgs, pushCoValArg, pushCoTyArg+   , pushCoercionIntoLambda, pushCoDataCon, collectBindersPushingCo+   )+where++import GHC.Prelude++import GHC.Core+import GHC.Core.FVs+import GHC.Core.Utils+import GHC.Core.DataCon+import GHC.Core.TyCon     ( TyCon, tyConArity, isInjectiveTyCon )+import GHC.Core.TyCon.RecWalk     ( initRecTc, checkRecTc )+import GHC.Core.Predicate ( isDictTy, isEvId, isCallStackPredTy, isCallStackTy )+import GHC.Core.Multiplicity++-- We have two sorts of substitution:+--   GHC.Core.Subst.Subst, and GHC.Core.TyCo.Subst+-- Both have substTy, substCo  Hence need for qualification+import GHC.Core.Subst    as Core+import GHC.Core.Type     as Type+import GHC.Core.Coercion as Type+import GHC.Core.TyCo.Compare( eqType )++import GHC.Types.Demand+import GHC.Types.Cpr( CprSig, mkCprSig, botCpr )+import GHC.Types.Id+import GHC.Types.Var+import GHC.Types.Var.Env+import GHC.Types.Var.Set+import GHC.Types.Basic+import GHC.Types.Tickish++import GHC.Builtin.Types.Prim+import GHC.Builtin.Uniques++import GHC.Data.FastString+import GHC.Data.Graph.UnVar+import GHC.Data.Pair++import GHC.Utils.GlobalVars( unsafeHasNoStateHack )+import GHC.Utils.Constants (debugIsOn)+import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Utils.Misc++import Data.List.NonEmpty ( nonEmpty )+import qualified Data.List.NonEmpty as NE+import Data.Maybe( isJust )++{-+************************************************************************+*                                                                      *+              manifestArity and exprArity+*                                                                      *+************************************************************************++exprArity is a cheap-and-cheerful version of exprEtaExpandArity.+It tells how many things the expression can be applied to before doing+any work.  It doesn't look inside cases, lets, etc.  The idea is that+exprEtaExpandArity will do the hard work, leaving something that's easy+for exprArity to grapple with.  In particular, Simplify uses exprArity to+compute the ArityInfo for the Id.++Originally I thought that it was enough just to look for top-level lambdas, but+it isn't.  I've seen this++        foo = PrelBase.timesInt++We want foo to get arity 2 even though the eta-expander will leave it+unchanged, in the expectation that it'll be inlined.  But occasionally it+isn't, because foo is blacklisted (used in a rule).++Similarly, see the ok_note check in exprEtaExpandArity.  So+        f = __inline_me (\x -> e)+won't be eta-expanded.++And in any case it seems more robust to have exprArity be a bit more intelligent.+But note that   (\x y z -> f x y z)+should have arity 3, regardless of f's arity.+-}++manifestArity :: CoreExpr -> Arity+-- ^ manifestArity sees how many leading value lambdas there are,+--   after looking through casts+manifestArity (Lam v e) | isId v        = 1 + manifestArity e+                        | otherwise     = manifestArity e+manifestArity (Tick t e) | not (tickishIsCode t) =  manifestArity e+manifestArity (Cast e _)                = manifestArity e+manifestArity _                         = 0++joinRhsArity :: CoreExpr -> JoinArity+-- Join points are supposed to have manifestly-visible+-- lambdas at the top: no ticks, no casts, nothing+-- Moreover, type lambdas count in JoinArity+-- NB: For non-recursive bindings, the join arity of the binding may actually be+-- less that the number of manifestly-visible lambdas.+-- See Note [Join arity prediction based on joinRhsArity] in GHC.Core.Opt.OccurAnal+joinRhsArity (Lam _ e) = 1 + joinRhsArity e+joinRhsArity _         = 0+++---------------+exprBotStrictness_maybe :: CoreExpr -> Maybe (Arity, DmdSig, CprSig)+-- A cheap and cheerful function that identifies bottoming functions+-- and gives them a suitable strictness and CPR signatures.+-- It's used during float-out+exprBotStrictness_maybe e = arityTypeBotSigs_maybe (cheapArityType e)++arityTypeBotSigs_maybe :: ArityType ->  Maybe (Arity, DmdSig, CprSig)+-- Arity of a divergent function+arityTypeBotSigs_maybe (AT lams div)+  | isDeadEndDiv div = Just ( arity+                            , mkVanillaDmdSig arity botDiv+                            , mkCprSig arity botCpr)+  | otherwise        = Nothing+  where+    arity = length lams+++{- Note [exprArity for applications]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we come to an application we check that the arg is trivial.+   eg  f (fac x) does not have arity 2,+                 even if f has arity 3!++* We require that is trivial rather merely cheap.  Suppose f has arity 2.+  Then    f (Just y)+  has arity 0, because if we gave it arity 1 and then inlined f we'd get+          let v = Just y in \w. <f-body>+  which has arity 0.  And we try to maintain the invariant that we don't+  have arity decreases.++*  The `max 0` is important!  (\x y -> f x) has arity 2, even if f is+   unknown, hence arity 0+++************************************************************************+*                                                                      *+              typeArity and the "state hack"+*                                                                      *+********************************************************************* -}+++typeArity :: Type -> Arity+-- ^ (typeArity ty) says how many arrows GHC can expose in 'ty', after+-- looking through newtypes.  More generally, (typeOneShots ty) returns+-- ty's [OneShotInfo], based only on the type itself, using typeOneShot+-- on the argument type to access the "state hack".+typeArity = length . typeOneShots++typeOneShots :: Type -> [OneShotInfo]+-- How many value arrows are visible in the type?+-- We look through foralls, and newtypes+-- See Note [Arity invariants for bindings]+typeOneShots ty+  = go initRecTc ty+  where+    go rec_nts ty+      | Just (tcv, ty')  <- splitForAllTyCoVar_maybe ty+      = if isCoVar tcv+        then idOneShotInfo tcv : go rec_nts ty'+        else go rec_nts ty'++      | Just (_,_,arg,res) <- splitFunTy_maybe ty+      = typeOneShot arg : go rec_nts res++      | Just (tc,tys) <- splitTyConApp_maybe ty+      , Just (ty', _) <- instNewTyCon_maybe tc tys+      , Just rec_nts' <- checkRecTc rec_nts tc  -- See Note [Expanding newtypes and products]+                                                -- in GHC.Core.TyCon+--   , not (isClassTyCon tc)    -- Do not eta-expand through newtype classes+--                              -- See Note [Newtype classes and eta expansion]+--                              (no longer required)+      = go rec_nts' ty'+        -- Important to look through non-recursive newtypes, so that, eg+        --      (f x)   where f has arity 2, f :: Int -> IO ()+        -- Here we want to get arity 1 for the result!+        --+        -- AND through a layer of recursive newtypes+        -- e.g. newtype Stream m a b = Stream (m (Either b (a, Stream m a b)))++      | otherwise+      = []++typeOneShot :: Type -> OneShotInfo+typeOneShot ty+   | isStateHackType ty = OneShotLam+   | otherwise          = NoOneShotInfo++-- | Like 'idOneShotInfo', but taking the Horrible State Hack in to account+-- See Note [The state-transformer hack] in "GHC.Core.Opt.Arity"+idStateHackOneShotInfo :: Id -> OneShotInfo+idStateHackOneShotInfo id+    | isStateHackType (idType id) = OneShotLam+    | otherwise                   = idOneShotInfo id++-- | Returns whether the lambda associated with the 'Id' is+--   certainly applied at most once+-- This one is the "business end", called externally.+-- It works on type variables as well as Ids, returning True+-- Its main purpose is to encapsulate the Horrible State Hack+-- See Note [The state-transformer hack] in "GHC.Core.Opt.Arity"+isOneShotBndr :: Var -> Bool+isOneShotBndr var+  | isTyVar var                              = True+  | OneShotLam <- idStateHackOneShotInfo var = True+  | otherwise                                = False++isStateHackType :: Type -> Bool+isStateHackType ty+  | unsafeHasNoStateHack   -- Switch off with -fno-state-hack+  = False+  | otherwise+  = case tyConAppTyCon_maybe ty of+        Just tycon -> tycon == statePrimTyCon+        _          -> False+        -- This is a gross hack.  It claims that+        -- every function over realWorldStatePrimTy is a one-shot+        -- function.  This is pretty true in practice, and makes a big+        -- difference.  For example, consider+        --      a `thenST` \ r -> ...E...+        -- The early full laziness pass, if it doesn't know that r is one-shot+        -- will pull out E (let's say it doesn't mention r) to give+        --      let lvl = E in a `thenST` \ r -> ...lvl...+        -- When `thenST` gets inlined, we end up with+        --      let lvl = E in \s -> case a s of (r, s') -> ...lvl...+        -- and we don't re-inline E.+        --+        -- It would be better to spot that r was one-shot to start with, but+        -- I don't want to rely on that.+        --+        -- Another good example is in fill_in in PrelPack.hs.  We should be able to+        -- spot that fill_in has arity 2 (and when Keith is done, we will) but we can't yet.+++{- Note [Arity invariants for bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We have the following invariants for let-bindings++  (1) In any binding f = e,+         idArity f <= typeArity (idType f)+      We enforce this with trimArityType, called in findRhsArity;+      see Note [Arity trimming].++      Note that we enforce this only for /bindings/.  We do /not/ insist that+         arityTypeArity (arityType e) <= typeArity (exprType e)+      because that is quite a bit more expensive to guaranteed; it would+      mean checking at every Cast in the recursive arityType, for example.++  (2) If typeArity (exprType e) = n,+      then manifestArity (etaExpand e n) = n++      That is, etaExpand can always expand as much as typeArity says+      (or less, of course). So the case analysis in etaExpand and in+      typeArity must match.++      Consequence: because of (1), if we eta-expand to (idArity f), we will+      end up with n manifest lambdas.++   (3) In any binding f = e,+         idArity f <= arityTypeArity (safeArityType (arityType e))+       That is, we call safeArityType before attributing e's arityType to f.+       See Note [SafeArityType].++       So we call safeArityType in findRhsArity.++Suppose we have+   f :: Int -> Int -> Int+   f x y = x+y    -- Arity 2++   g :: F Int+   g = case <cond> of { True  -> f |> co1+                      ; False -> g |> co2 }++where F is a type family.  Now, we can't eta-expand g to have arity 2,+because etaExpand, which works off the /type/ of the expression+(albeit looking through newtypes), doesn't know how to make an+eta-expanded binding+   g = (\a b. case x of ...) |> co+because it can't make up `co` or the types of `a` and `b`.++So invariant (1) ensures that every binding has an arity that is no greater+than the typeArity of the RHS; and invariant (2) ensures that etaExpand+and handle what typeArity says.++Why is this important?  Because++  - In GHC.Iface.Tidy we use exprArity/manifestArity to fix the *final+    arity* of each top-level Id, and in++  - In CorePrep we use etaExpand on each rhs, so that the visible+    lambdas actually match that arity, which in turn means that the+    StgRhs has a number of lambdas that precisely matches the arity.++Note [Arity trimming]+~~~~~~~~~~~~~~~~~~~~~+Invariant (1) of Note [Arity invariants for bindings] is upheld by findRhsArity,+which calls trimArityType to trim the ArityType to match the Arity of the+binding.  Failing to do so, and hence breaking invariant (1) led to #5441.++How to trim?  If we end in topDiv, it's easy.  But we must take great care with+dead ends (i.e. botDiv). Suppose the expression was (\x y. error "urk"),+we'll get \??.⊥.  We absolutely must not trim that to \?.⊥, because that+claims that ((\x y. error "urk") |> co) diverges when given one argument,+which it absolutely does not. And Bad Things happen if we think something+returns bottom when it doesn't (#16066).++So, if we need to trim a dead-ending arity type, switch (conservatively) to+topDiv.++Historical note: long ago, we unconditionally switched to topDiv when we+encountered a cast, but that is far too conservative: see #5475++Note [Newtype classes and eta expansion]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+    NB: this nasty special case is no longer required, because+    for newtype classes we don't use the class-op rule mechanism+    at all.  See Note [Single-method classes] in GHC.Tc.TyCl.Instance. SLPJ May 2013++-------- Old out of date comments, just for interest -----------+We have to be careful when eta-expanding through newtypes.  In general+it's a good idea, but annoyingly it interacts badly with the class-op+rule mechanism.  Consider++   class C a where { op :: a -> a }+   instance C b => C [b] where+     op x = ...++These translate to++   co :: forall a. (a->a) ~ C a++   $copList :: C b -> [b] -> [b]+   $copList d x = ...++   $dfList :: C b -> C [b]+   {-# DFunUnfolding = [$copList] #-}+   $dfList d = $copList d |> co@[b]++Now suppose we have:++   dCInt :: C Int++   blah :: [Int] -> [Int]+   blah = op ($dfList dCInt)++Now we want the built-in op/$dfList rule will fire to give+   blah = $copList dCInt++But with eta-expansion 'blah' might (and in #3772, which is+slightly more complicated, does) turn into++   blah = op (\eta. ($dfList dCInt |> sym co) eta)++and now it is *much* harder for the op/$dfList rule to fire, because+exprIsConApp_maybe won't hold of the argument to op.  I considered+trying to *make* it hold, but it's tricky and I gave up.++The test simplCore/should_compile/T3722 is an excellent example.+-------- End of old out of date comments, just for interest -----------+-}++{- ********************************************************************+*                                                                      *+                  Zapping lambda binders+*                                                                      *+********************************************************************* -}++zapLamBndrs :: FullArgCount -> [Var] -> [Var]+-- If (\xyz. t) appears under-applied to only two arguments,+-- we must zap the occ-info on x,y, because they appear (in 't') under the \z.+-- See Note [Occurrence analysis for lambda binders] in GHc.Core.Opt.OccurAnal+--+-- NB: both `arg_count` and `bndrs` include both type and value args/bndrs+zapLamBndrs arg_count bndrs+  | no_need_to_zap = bndrs+  | otherwise      = zap_em arg_count bndrs+  where+    no_need_to_zap = all isOneShotBndr (drop arg_count bndrs)++    zap_em :: FullArgCount -> [Var] -> [Var]+    zap_em 0 bs = bs+    zap_em _ [] = []+    zap_em n (b:bs) | isTyVar b = b              : zap_em (n-1) bs+                    | otherwise = zapLamIdInfo b : zap_em (n-1) bs+++{- *********************************************************************+*                                                                      *+           Computing the "arity" of an expression+*                                                                      *+************************************************************************++Note [Definition of arity]+~~~~~~~~~~~~~~~~~~~~~~~~~~+The "arity" of an expression 'e' is n if+   applying 'e' to *fewer* than n *value* arguments+   converges rapidly++Or, to put it another way++   there is no work lost in duplicating the partial+   application (e x1 .. x(n-1))++In the divergent case, no work is lost by duplicating because if the thing+is evaluated once, that's the end of the program.++Or, to put it another way, in any context C++   C[ (\x1 .. xn. e x1 .. xn) ]+         is as efficient as+   C[ e ]++It's all a bit more subtle than it looks:++Note [One-shot lambdas]+~~~~~~~~~~~~~~~~~~~~~~~+Consider one-shot lambdas+                let x = expensive in \y z -> E+We want this to have arity 1 if the \y-abstraction is a 1-shot lambda.++Note [Dealing with bottom]+~~~~~~~~~~~~~~~~~~~~~~~~~~+GHC does some transformations that are technically unsound wrt+bottom, because doing so improves arities... a lot!  We describe+them in this Note.++The flag -fpedantic-bottoms (off by default) restore technically+correct behaviour at the cots of efficiency.++It's mostly to do with eta-expansion.  Consider++   f = \x -> case x of+               True  -> \s -> e1+               False -> \s -> e2++This happens all the time when f :: Bool -> IO ()+In this case we do eta-expand, in order to get that \s to the+top, and give f arity 2.++This isn't really right in the presence of seq.  Consider+        (f bot) `seq` 1++This should diverge!  But if we eta-expand, it won't.  We ignore this+"problem" (unless -fpedantic-bottoms is on), because being scrupulous+would lose an important transformation for many programs. (See+#5587 for an example.)++Consider also+        f = \x -> error "foo"+Here, arity 1 is fine.  But if it looks like this (see #22068)+        f = \x -> case x of+                        True  -> error "foo"+                        False -> \y -> x+y+then we want to get arity 2.  Technically, this isn't quite right, because+        (f True) `seq` 1+should diverge, but it'll converge if we eta-expand f.  Nevertheless, we+do so; it improves some programs significantly, and increasing convergence+isn't a bad thing.  Hence the ABot/ATop in ArityType.++So these two transformations aren't always the Right Thing, and we+have several tickets reporting unexpected behaviour resulting from+this transformation.  So we try to limit it as much as possible:++ (1) Do NOT move a lambda outside a known-bottom case expression+       case undefined of { (a,b) -> \y -> e }+     This showed up in #5557++ (2) Do NOT move a lambda outside a case unless+     (a) The scrutinee is ok-for-speculation, or+     (b) more liberally: the scrutinee is cheap (e.g. a variable), and+         -fpedantic-bottoms is not enforced (see #2915 for an example)++Of course both (1) and (2) are readily defeated by disguising the bottoms.++There also is an interaction with Note [Combining arity type with demand info],+outlined in Wrinkle (CAD1).++Note [Newtype arity]+~~~~~~~~~~~~~~~~~~~~+Non-recursive newtypes are transparent, and should not get in the way.+We do (currently) eta-expand recursive newtypes too.  So if we have, say++        newtype T = MkT ([T] -> Int)++Suppose we have+        e = coerce T f+where f has arity 1.  Then: etaExpandArity e = 1;+that is, etaExpandArity looks through the coerce.++When we eta-expand e to arity 1: eta_expand 1 e T+we want to get:                  coerce T (\x::[T] -> (coerce ([T]->Int) e) x)++  HOWEVER, note that if you use coerce bogusly you can ge+        coerce Int negate+  And since negate has arity 2, you might try to eta expand.  But you can't+  decompose Int to a function type.   Hence the final case in eta_expand.++Note [The state-transformer hack]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have+        f = e+where e has arity n.  Then, if we know from the context that f has+a usage type like+        t1 -> ... -> tn -1-> t(n+1) -1-> ... -1-> tm -> ...+then we can expand the arity to m.  This usage type says that+any application (x e1 .. en) will be applied to uniquely to (m-n) more args+Consider f = \x. let y = <expensive>+                 in case x of+                      True  -> foo+                      False -> \(s:RealWorld) -> e+where foo has arity 1.  Then we want the state hack to+apply to foo too, so we can eta expand the case.++Then we expect that if f is applied to one arg, it'll be applied to two+(that's the hack -- we don't really know, and sometimes it's false)+See also Id.isOneShotBndr.++Note [State hack and bottoming functions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It's a terrible idea to use the state hack on a bottoming function.+Here's what happens (#2861):++  f :: String -> IO T+  f = \p. error "..."++Eta-expand, using the state hack:++  f = \p. (\s. ((error "...") |> g1) s) |> g2+  g1 :: IO T ~ (S -> (S,T))+  g2 :: (S -> (S,T)) ~ IO T++Extrude the g2++  f' = \p. \s. ((error "...") |> g1) s+  f = f' |> (String -> g2)++Discard args for bottoming function++  f' = \p. \s. ((error "...") |> g1 |> g3+  g3 :: (S -> (S,T)) ~ (S,T)++Extrude g1.g3++  f'' = \p. \s. (error "...")+  f' = f'' |> (String -> S -> g1.g3)++And now we can repeat the whole loop.  Aargh!  The bug is in applying the+state hack to a function which then swallows the argument.++This arose in another guise in #3959.  Here we had++     catch# (throw exn >> return ())++Note that (throw :: forall a e. Exn e => e -> a) is called with [a = IO ()].+After inlining (>>) we get++     catch# (\_. throw {IO ()} exn)++We must *not* eta-expand to++     catch# (\_ _. throw {...} exn)++because 'catch#' expects to get a (# _,_ #) after applying its argument to+a State#, not another function!++In short, we use the state hack to allow us to push let inside a lambda,+but not to introduce a new lambda.+++Note [ArityType]+~~~~~~~~~~~~~~~~+ArityType can be thought of as an abstraction of an expression.+The ArityType+   AT [ (IsCheap,     NoOneShotInfo)+      , (IsExpensive, OneShotLam)+      , (IsCheap,     OneShotLam) ] Dunno)++abstracts an expression like+   \x. let <expensive> in+       \y{os}.+       \z{os}. blah++In general we have (AT lams div).  Then+* In lams :: [(Cost,OneShotInfo)]+  * The Cost flag describes the part of the expression down+    to the first (value) lambda.+  * The OneShotInfo flag gives the one-shot info on that lambda.++* If 'div' is dead-ending ('isDeadEndDiv'), then application to+  'length lams' arguments will surely diverge, similar to the situation+  with 'DmdType'.++ArityType is the result of a compositional analysis on expressions,+from which we can decide the real arity of the expression (extracted+with function exprEtaExpandArity).++We use the following notation:+  at  ::= \p1..pn.div+  div ::= T | x | ⊥+  p   ::= (c o)+  c   ::= X | C    -- Expensive or Cheap+  o   ::= ? | 1    -- NotOneShot or OneShotLam+We may omit the \. if n = 0.+And ⊥ stands for `AT [] botDiv`++Here is an example demonstrating the notation:+  \(C?)(X1)(C1).T+stands for+   AT [ (IsCheap,NoOneShotInfo)+      , (IsExpensive,OneShotLam)+      , (IsCheap,OneShotLam) ]+      topDiv++See the 'Outputable' instance for more information. It's pretty simple.++How can we use ArityType?  Example:+      f = \x\y. let v = <expensive> in+          \s(one-shot) \t(one-shot). blah+      'f' has arity type \(C?)(C?)(X1)(C1).T+      The one-shot-ness means we can, in effect, push that+      'let' inside the \st, and expand to arity 4++Suppose f = \xy. x+y+Then  f             :: \(C?)(C?).T+      f v           :: \(C?).T+      f <expensive> :: \(X?).T++Here is what the fields mean. If an arbitrary expression 'f' has+ArityType 'at', then++ * If @at = AT [o1,..,on] botDiv@ (notation: \o1..on.⊥), then @f x1..xn@+   definitely diverges. Partial applications to fewer than n args may *or+   may not* diverge.  Ditto exnDiv.++ * If `f` has ArityType `at` we can eta-expand `f` to have (aritTypeOneShots at)+   arguments without losing sharing. This function checks that the either+   there are no expensive expressions, or the lambdas are one-shots.++   NB 'f' is an arbitrary expression, eg @f = g e1 e2@.  This 'f' can have+   arity type @AT oss _@, with @length oss > 0@, only if e1 e2 are themselves+   cheap.++ * In both cases, @f@, @f x1@, ... @f x1 ... x(n-1)@ are definitely+   really functions, or bottom, but *not* casts from a data type, in+   at least one case branch.  (If it's a function in one case branch but+   an unsafe cast from a data type in another, the program is bogus.)+   So eta expansion is dynamically ok; see Note [State hack and+   bottoming functions], the part about catch#++Wrinkles++* Wrinkle [Bottoming functions]: see function 'arityLam'.+  We treat bottoming functions as one-shot, because there is no point+  in floating work outside the lambda, and it's fine to float it inside.++  For example, this is fine (see test stranal/sigs/BottomFromInnerLambda)+       let x = <expensive> in \y. error (g x y)+       ==> \y. let x = <expensive> in error (g x y)++  Idea: perhaps we could enforce this invariant with+     data Arity Type = TopAT [(Cost, OneShotInfo)] | DivAT [Cost]+++Note [SafeArityType]+~~~~~~~~~~~~~~~~~~~~+The function safeArityType trims an ArityType to return a "safe" ArityType,+for which we use a type synonym SafeArityType.  It is "safe" in the sense+that (arityTypeArity at) really reflects the arity of the expression, whereas+a regular ArityType might have more lambdas in its [ATLamInfo] that the+(cost-free) arity of the expression.++For example+   \x.\y.let v = expensive in \z. blah+has+   arityType = AT [C?, C?, X?, C?] Top+But the expression actually has arity 2, not 4, because of the X.+So safeArityType will trim it to (AT [C?, C?] Top), whose [ATLamInfo]+now reflects the (cost-free) arity of the expression++Why do we ever need an "unsafe" ArityType, such as the example above?+Because its (cost-free) arity may increased by combineWithCallCards+in findRhsArity. See Note [Combining arity type with demand info].++Thus the function `arityType` returns a regular "unsafe" ArityType, that+goes deeply into the lambdas (including under IsExpensive). But that is+very local; most ArityTypes are indeed "safe".  We use the type synonym+SafeArityType to indicate where we believe the ArityType is safe.+-}++-- | The analysis lattice of arity analysis. It is isomorphic to+--+-- @+--    data ArityType'+--      = AEnd Divergence+--      | ALam OneShotInfo ArityType'+-- @+--+-- Which is easier to display the Hasse diagram for:+--+-- @+--  ALam OneShotLam at+--          |+--      AEnd topDiv+--          |+--  ALam NoOneShotInfo at+--          |+--      AEnd exnDiv+--          |+--      AEnd botDiv+-- @+--+-- where the @at@ fields of @ALam@ are inductively subject to the same order.+-- That is, @ALam os at1 < ALam os at2@ iff @at1 < at2@.+--+-- Why the strange Top element?+--   See Note [Combining case branches: optimistic one-shot-ness]+--+-- We rely on this lattice structure for fixed-point iteration in+-- 'findRhsArity'. For the semantics of 'ArityType', see Note [ArityType].+data ArityType  -- See Note [ArityType]+  = AT ![ATLamInfo] !Divergence+    -- ^ `AT oss div` is an abstraction of the expression, which describes+    -- its lambdas, and how much work appears where.+    -- See Note [ArityType] for more information+    --+    -- If `div` is dead-ending ('isDeadEndDiv'), then application to+    -- `length os` arguments will surely diverge, similar to the situation+    -- with 'DmdType'.+  deriving Eq++type ATLamInfo = (Cost,OneShotInfo)+     -- ^ Info about one lambda in an ArityType+     -- See Note [ArityType]++type SafeArityType = ArityType -- See Note [SafeArityType]++data Cost = IsCheap | IsExpensive+          deriving( Eq )++allCosts :: (a -> Cost) -> [a] -> Cost+allCosts f xs = foldr (addCost . f) IsCheap xs++addCost :: Cost -> Cost -> Cost+addCost IsCheap IsCheap = IsCheap+addCost _       _       = IsExpensive++-- | This is the BNF of the generated output:+--+-- @+-- @+--+-- We format+-- @AT [o1,..,on] topDiv@ as @\o1..on.T@ and+-- @AT [o1,..,on] botDiv@ as @\o1..on.⊥@, respectively.+-- More concretely, @AT [NOI,OS,OS] topDiv@ is formatted as @\?11.T@.+-- If the one-shot info is empty, we omit the leading @\.@.+instance Outputable ArityType where+  ppr (AT oss div)+    | null oss  = pp_div div+    | otherwise = char '\\' <> hcat (map pp_os oss) <> dot <> pp_div div+    where+      pp_div Diverges = char '⊥'+      pp_div ExnOrDiv = char 'x'+      pp_div Dunno    = char 'T'+      pp_os (IsCheap,     OneShotLam)    = text "(C1)"+      pp_os (IsExpensive, OneShotLam)    = text "(X1)"+      pp_os (IsCheap,     NoOneShotInfo) = text "(C?)"+      pp_os (IsExpensive, NoOneShotInfo) = text "(X?)"++mkBotArityType :: [OneShotInfo] -> ArityType+mkBotArityType oss = AT [(IsCheap,os) | os <- oss] botDiv++botArityType :: ArityType+botArityType = mkBotArityType []++topArityType :: ArityType+topArityType = AT [] topDiv++-- | The number of value args for the arity type+arityTypeArity :: SafeArityType -> Arity+arityTypeArity (AT lams _) = length lams++arityTypeOneShots :: SafeArityType -> [OneShotInfo]+-- Returns a list only as long as the arity should be+arityTypeOneShots (AT lams _) = map snd lams++safeArityType :: ArityType -> SafeArityType+-- ^ Assuming this ArityType is all we know, find the arity of+-- the function, and trim the argument info (and Divergence)+-- to match that arity. See Note [SafeArityType]+safeArityType at@(AT lams _)+  = case go 0 IsCheap lams of+      Nothing -> at  -- No trimming needed+      Just ar -> AT (take ar lams) topDiv+ where+   go :: Arity -> Cost -> [(Cost,OneShotInfo)] -> Maybe Arity+   go _ _ [] = Nothing+   go ar ch1 ((ch2,os):lams)+      = case (ch1 `addCost` ch2, os) of+          (IsExpensive, NoOneShotInfo) -> Just ar+          (ch,          _)             -> go (ar+1) ch lams++infixl 2 `trimArityType`++trimArityType :: Arity -> ArityType -> ArityType+-- ^ Trim an arity type so that it has at most the given arity.+-- Any excess 'OneShotInfo's are truncated to 'topDiv', even if+-- they end in 'ABot'.  See Note [Arity trimming]+trimArityType max_arity at@(AT lams _)+  | lams `lengthAtMost` max_arity = at+  | otherwise                     = AT (take max_arity lams) topDiv++data ArityOpts = ArityOpts+  { ao_ped_bot :: !Bool -- See Note [Dealing with bottom]+  , ao_dicts_cheap :: !Bool -- See Note [Eta expanding through dictionaries]+  }++-- | The Arity returned is the number of value args the+-- expression can be applied to without doing much work+exprEtaExpandArity :: HasDebugCallStack => ArityOpts -> CoreExpr -> Maybe SafeArityType+-- exprEtaExpandArity is used when eta expanding+--      e  ==>  \xy -> e x y+-- Nothing if the expression has arity 0+exprEtaExpandArity opts e+  | AT [] _ <- arity_type+  = Nothing+  | otherwise+  = Just arity_type+  where+    arity_type = safeArityType (arityType (findRhsArityEnv opts False) e)+++{- *********************************************************************+*                                                                      *+                   findRhsArity+*                                                                      *+********************************************************************* -}++findRhsArity :: ArityOpts -> RecFlag -> Id -> CoreExpr+             -> (Bool, SafeArityType)+-- This implements the fixpoint loop for arity analysis+-- See Note [Arity analysis]+--+-- The Bool is True if the returned arity is greater than (exprArity rhs)+--     so the caller should do eta-expansion+-- That Bool is never True for join points, which are never eta-expanded+--+-- Returns an SafeArityType that is guaranteed trimmed to typeArity of 'bndr'+--         See Note [Arity trimming]++findRhsArity opts is_rec bndr rhs+  | isJoinId bndr+  = (False, join_arity_type)+    -- False: see Note [Do not eta-expand join points]+    -- But do return the correct arity and bottom-ness, because+    -- these are used to set the bndr's IdInfo (#15517)+    -- Note [Invariants on join points] invariant 2b, in GHC.Core++  | otherwise+  = (arity_increased, non_join_arity_type)+    -- arity_increased: eta-expand if we'll get more lambdas+    -- to the top of the RHS+  where+    old_arity = exprArity rhs++    init_env :: ArityEnv+    init_env = findRhsArityEnv opts (isJoinId bndr)++    -- Non-join-points only+    non_join_arity_type = case is_rec of+                             Recursive    -> go 0 botArityType+                             NonRecursive -> step init_env+    arity_increased = arityTypeArity non_join_arity_type > old_arity++    -- Join-points only+    -- See Note [Arity for non-recursive join bindings]+    -- and Note [Arity for recursive join bindings]+    join_arity_type = case is_rec of+                         Recursive    -> go 0 botArityType+                         NonRecursive -> trimArityType ty_arity (cheapArityType rhs)++    ty_arity     = typeArity (idType bndr)+    use_call_cards = useSiteCallCards bndr++    step :: ArityEnv -> SafeArityType+    step env = trimArityType ty_arity $+               safeArityType $ -- See Note [Arity invariants for bindings], item (3)+               combineWithCallCards env (arityType env rhs) use_call_cards+       -- trimArityType: see Note [Trim arity inside the loop]+       -- combineWithCallCards: take account of the demand on the+       -- binder.  Perhaps it is always called with 2 args+       --   let f = \x. blah in (f 3 4, f 1 9)+       -- f's demand-info says how many args it is called with++    -- The fixpoint iteration (go), done for recursive bindings. We+    -- always do one step, but usually that produces a result equal+    -- to old_arity, and then we stop right away, because old_arity+    -- is assumed to be sound. In other words, arities should never+    -- decrease.  Result: the common case is that there is just one+    -- iteration+    go :: Int -> SafeArityType -> SafeArityType+    go !n cur_at@(AT lams div)+      | not (isDeadEndDiv div)           -- the "stop right away" case+      , length lams <= old_arity = cur_at -- from above+      | next_at == cur_at        = cur_at+      | otherwise+         -- Warn if more than 2 iterations. Why 2? See Note [Exciting arity]+      = warnPprTrace (debugIsOn && n > 2)+            "Exciting arity"+            (nest 2 (ppr bndr <+> ppr cur_at <+> ppr next_at $$ ppr rhs)) $+        go (n+1) next_at+      where+        next_at = step (extendSigEnv init_env bndr cur_at)++combineWithCallCards :: ArityEnv -> ArityType -> [Card] -> ArityType+-- See Note [Combining arity type with demand info]+combineWithCallCards env at@(AT lams div) cards+  | null lams = at+  | otherwise = AT (zip_lams lams oss) div+  where+    oss = map card_to_oneshot cards+    card_to_oneshot n+      | isAtMostOnce n, not (pedanticBottoms env)+         -- Take care for -fpedantic-bottoms;+         -- see Note [Combining arity type with demand info], Wrinkle (CAD1)+      = OneShotLam+      | n == C_11+         -- Safe to eta-expand even in the presence of -fpedantic-bottoms+         -- see Note [Combining arity type with demand info], Wrinkle (CAD1)+      = OneShotLam+      | otherwise+      = NoOneShotInfo+    zip_lams :: [ATLamInfo] -> [OneShotInfo] -> [ATLamInfo]+    zip_lams lams []  = lams+    zip_lams []   oss | isDeadEndDiv div = []+                      | otherwise        = [ (IsExpensive,OneShotLam)+                                           | _ <- takeWhile isOneShotInfo oss]+    zip_lams ((ch,os1):lams) (os2:oss)+      = (ch, os1 `bestOneShot` os2) : zip_lams lams oss++useSiteCallCards :: Id -> [Card]+useSiteCallCards bndr+  = call_arity_one_shots `zip_cards` dmd_one_shots+  where+    call_arity_one_shots :: [Card]+    call_arity_one_shots+      | call_arity == 0 = []+      | otherwise       = C_0N : replicate (call_arity-1) C_01+    -- Call Arity analysis says /however often the function is called/, it is+    -- always applied to this many arguments.+    -- The first C_0N is because of the "however often it is called" part.+    -- Thus if Call Arity says "always applied to 3 args" then the one-shot info+    -- we get is [C_0N, C_01, C_01]+    call_arity = idCallArity bndr++    dmd_one_shots :: [Card]+    -- If the demand info is C(x,C(1,C(1,.))) then we know that an+    -- application to one arg is also an application to three+    dmd_one_shots = case idDemandInfo bndr of+      AbsDmd  -> [] -- There is no use in eta expanding+      BotDmd  -> [] -- when the binding could be dropped instead+      _ :* sd -> callCards sd++    -- Take the *longer* list+    zip_cards (n1:ns1) (n2:ns2) = (n1 `glbCard` n2) : zip_cards ns1 ns2+    zip_cards []       ns2      = ns2+    zip_cards ns1      []       = ns1++{- Note [Arity analysis]+~~~~~~~~~~~~~~~~~~~~~~~~+The motivating example for arity analysis is this:++  f = \x. let g = f (x+1)+          in \y. ...g...++What arity does f have?  Really it should have arity 2, but a naive+look at the RHS won't see that.  You need a fixpoint analysis which+says it has arity "infinity" the first time round.++This example happens a lot; it first showed up in Andy Gill's thesis,+fifteen years ago!  It also shows up in the code for 'rnf' on lists+in #4138.++We do the necessary, quite simple fixed-point iteration in 'findRhsArity',+which assumes for a single binding 'ABot' on the first run and iterates+until it finds a stable arity type. Two wrinkles++* We often have to ask (see the Case or Let case of 'arityType') whether some+  expression is cheap. In the case of an application, that depends on the arity+  of the application head! That's why we have our own version of 'exprIsCheap',+  'myExprIsCheap', that will integrate the optimistic arity types we have on+  f and g into the cheapness check.++* Consider this (#18793)++    go = \ds. case ds of+           []     -> id+           (x:ys) -> let acc = go ys in+                     case blah of+                       True  -> acc+                       False -> \ x1 -> acc (negate x1)++  We must propagate go's optimistically large arity to @acc@, so that the+  tail call to @acc@ in the True branch has sufficient arity.  This is done+  by the 'am_sigs' field in 'FindRhsArity', and 'lookupSigEnv' in the Var case+  of 'arityType'.++Note [Exciting arity]+~~~~~~~~~~~~~~~~~~~~~+The fixed-point iteration in 'findRhsArity' stabilises very quickly in almost+all cases. To get notified of cases where we need an usual number of iterations,+we emit a warning in debug mode, so that we can investigate and make sure that+we really can't do better. It's a gross hack, but catches real bugs (#18870).++Now, which number is "unusual"? We pick n > 2. Here's a pretty common and+expected example that takes two iterations and would ruin the specificity+of the warning (from T18937):++  f :: [Int] -> Int -> Int+  f []     = id+  f (x:xs) = let y = sum [0..x]+             in \z -> f xs (y + z)++Fixed-point iteration starts with arity type ⊥ for f. After the first+iteration, we get arity type \??.T, e.g. arity 2, because we unconditionally+'floatIn' the let-binding (see its bottom case).  After the second iteration,+we get arity type \?.T, e.g. arity 1, because now we are no longer allowed+to floatIn the non-cheap let-binding.  Which is all perfectly benign, but+means we do two iterations (well, actually 3 'step's to detect we are stable)+and don't want to emit the warning.++Note [Trim arity inside the loop]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Here's an example (from gadt/nbe.hs) which caused trouble.+  data Exp g t where+     Lam :: Ty a -> Exp (g,a) b -> Exp g (a->b)++  eval :: Exp g t -> g -> t+  eval (Lam _ e) g = \a -> eval e (g,a)++The danger is that we get arity 3 from analysing this; and the+next time arity 4, and so on for ever.  Solution: use trimArityType+on each iteration.++Note [Combining arity type with demand info]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+   let f = \x. let y = <expensive> in \p \q{os}. blah+   in ...(f a b)...(f c d)...++* From the RHS we get an ArityType like+    AT [ (IsCheap,?), (IsExpensive,?), (IsCheap,OneShotLam) ] Dunno+  where "?" means NoOneShotInfo++* From the body, the demand analyser (or Call Arity) will tell us+  that the function is always applied to at least two arguments.++Combining these two pieces of info, we can get the final ArityType+    AT [ (IsCheap,?), (IsExpensive,OneShotLam), (IsCheap,OneShotLam) ] Dunno+result: arity=3, which is better than we could do from either+source alone.++The "combining" part is done by combineWithCallCards.  It+uses info from both Call Arity and demand analysis.++We may have /more/ call demands from the calls than we have lambdas+in the binding.  E.g.+    let f1 = \x. g x x in ...(f1 p q r)...+    -- Demand on f1 is C(x,C(1,C(1,L)))++    let f2 = \y. error y in ...(f2 p q r)...+    -- Demand on f2 is C(x,C(1,C(1,L)))++In both these cases we can eta expand f1 and f2 to arity 3.+But /only/ for called-once demands.  Suppose we had+    let f1 = \y. g x x in ...let h = f1 p q in ...(h r1)...(h r2)...++Now we don't want to eta-expand f1 to have 3 args; only two.+Nor, in the case of f2, do we want to push that error call under+a lambda.  Hence the takeWhile in combineWithDemandDoneShots.++Wrinkles:++(CAD1) #24296 exposed a subtle interaction with -fpedantic-bottoms+  (See Note [Dealing with bottom]). Consider++    let f = \x y. error "blah" in+    f 2 1 `seq` Just (f 3 2 1)+      -- Demand on f is C(x,C(1,C(M,L)))++  Usually, it is OK to consider a lambda that is called *at most* once (so call+  cardinality C_01, abbreviated M) a one-shot lambda and eta-expand over it.+  But with -fpedantic-bottoms that is no longer true: If we were to eta-expand+  f to arity 3, we'd discard the error raised when evaluating `f 2 1`.+  Hence in the presence of -fpedantic-bottoms, we must have C_11 for+  eta-expansion.++Note [Do not eta-expand join points]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Similarly to CPR (see Note [Don't w/w join points for CPR] in+GHC.Core.Opt.WorkWrap), a join point stands well to gain from its outer binding's+eta-expansion, and eta-expanding a join point is fraught with issues like how to+deal with a cast:++    let join $j1 :: IO ()+             $j1 = ...+             $j2 :: Int -> IO ()+             $j2 n = if n > 0 then $j1+                              else ...++    =>++    let join $j1 :: IO ()+             $j1 = (\eta -> ...)+                     `cast` N:IO :: State# RealWorld -> (# State# RealWorld, ())+                                 ~  IO ()+             $j2 :: Int -> IO ()+             $j2 n = (\eta -> if n > 0 then $j1+                                       else ...)+                     `cast` N:IO :: State# RealWorld -> (# State# RealWorld, ())+                                 ~  IO ()++The cast here can't be pushed inside the lambda (since it's not casting to a+function type), so the lambda has to stay, but it can't because it contains a+reference to a join point. In fact, $j2 can't be eta-expanded at all. Rather+than try and detect this situation (and whatever other situations crop up!), we+don't bother; again, any surrounding eta-expansion will improve these join+points anyway, since an outer cast can *always* be pushed inside. By the time+CorePrep comes around, the code is very likely to look more like this:++    let join $j1 :: State# RealWorld -> (# State# RealWorld, ())+             $j1 = (...) eta+             $j2 :: Int -> State# RealWorld -> (# State# RealWorld, ())+             $j2 = if n > 0 then $j1+                            else (...) eta++Note [Arity for recursive join bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+  f x = joinrec j 0 = \ a b c -> (a,x,b)+                j n = j (n-1)+        in j 20++Obviously `f` should get arity 4.  But it's a bit tricky:++1. Remember, we don't eta-expand join points; see+   Note [Do not eta-expand join points].++2. But even though we aren't going to eta-expand it, we still want `j` to get+   idArity=4, via the findRhsArity fixpoint.  Then when we are doing findRhsArity+   for `f`, we'll call arityType on f's RHS:+    - At the letrec-binding for `j` we'll whiz up an arity-4 ArityType+      for `j` (See Note [arityType for non-recursive let-bindings]+      in GHC.Core.Opt.Arity)b+    - At the occurrence (j 20) that arity-4 ArityType will leave an arity-3+      result.++3. All this, even though j's /join-arity/ (stored in the JoinId) is 1.+   This is is the Main Reason that we want the idArity to sometimes be+   larger than the join-arity c.f. Note [Invariants on join points] item 2b+   in GHC.Core.++4. Be very careful of things like this (#21755):+     g x = let j 0 = \y -> (x,y)+               j n = expensive n `seq` j (n-1)+           in j x+   Here we do /not/ want eta-expand `g`, lest we duplicate all those+   (expensive n) calls.++   But it's fine: the findRhsArity fixpoint calculation will compute arity-1+   for `j` (not arity 2); and that's just what we want. But we do need that+   fixpoint.++   Historical note: an earlier version of GHC did a hack in which we gave+   join points an ArityType of ABot, but that did not work with this #21755+   case.++5. arityType does not usually expect to encounter free join points;+   see GHC.Core.Opt.Arity Note [No free join points in arityType].+   But consider+          f x = join    j1 y = .... in+                joinrec j2 z = ...j1 y... in+                j2 v++   When doing findRhsArity on `j2` we'll encounter the free `j1`.+   But that is fine, because we aren't going to eta-expand `j2`;+   we just want to know its arity.  So we have a flag am_no_eta,+   switched on when doing findRhsArity on a join point RHS. If+   the flag is on, we allow free join points, but not otherwise.+++Note [Arity for non-recursive join bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Note [Arity for recursive join bindings] deals with recursive join+bindings. But what about /non-recursive/ones?  If we just call+findRhsArity, it will call arityType.  And that can be expensive when+we have deeply nested join points:+  join j1 x1 = join j2 x2 = join j3 x3 = blah3+                            in blah2+               in blah1+(e.g. test T18698b).++So we call cheapArityType instead.  It's good enough for practical+purposes.++(Side note: maybe we should use cheapArity for the RHS of let bindings+in the main arityType function.)+-}+++{- *********************************************************************+*                                                                      *+                   arityType+*                                                                      *+********************************************************************* -}++arityLam :: Id -> ArityType -> ArityType+arityLam id (AT oss div)+  = AT ((IsCheap, one_shot) : oss) div+  where+    one_shot | isDeadEndDiv div = OneShotLam+             | otherwise        = idStateHackOneShotInfo id+    -- If the body diverges, treat it as one-shot: no point+    -- in floating out, and no penalty for floating in+    -- See Wrinkle [Bottoming functions] in Note [ArityType]++floatIn :: Cost -> ArityType -> ArityType+-- We have something like (let x = E in b),+-- where b has the given arity type.+-- NB: be as lazy as possible in the Cost-of-E argument;+--     we can often get away without ever looking at it+--     See Note [Care with nested expressions]+floatIn ch at@(AT lams div)+  = case lams of+      []                 -> at+      (IsExpensive,_):_  -> at+      (_,os):lams        -> AT ((ch,os):lams) div++addWork :: ArityType -> ArityType+-- Add work to the outermost level of the arity type+addWork at@(AT lams div)+  = case lams of+      []      -> at+      lam:lams' -> AT (add_work lam : lams') div++add_work :: ATLamInfo -> ATLamInfo+add_work (_,os) = (IsExpensive,os)++arityApp :: ArityType -> Cost -> ArityType+-- Processing (fun arg) where at is the ArityType of fun,+-- Knock off an argument and behave like 'let'+arityApp (AT ((ch1,_):oss) div) ch2 = floatIn (ch1 `addCost` ch2) (AT oss div)+arityApp at                     _   = at++-- | Least upper bound in the 'ArityType' lattice.+-- See the haddocks on 'ArityType' for the lattice.+--+-- Used for branches of a @case@.+andArityType :: ArityEnv -> ArityType -> ArityType -> ArityType+andArityType env (AT (lam1:lams1) div1) (AT (lam2:lams2) div2)+  | AT lams' div' <- andArityType env (AT lams1 div1) (AT lams2 div2)+  = AT ((lam1 `and_lam` lam2) : lams') div'+  where+    (ch1,os1) `and_lam` (ch2,os2)+      = ( ch1 `addCost` ch2, os1 `bestOneShot` os2)+        -- bestOneShot: see Note [Combining case branches: optimistic one-shot-ness]++andArityType env (AT [] div1) at2 = andWithTail env div1 at2+andArityType env at1 (AT [] div2) = andWithTail env div2 at1++andWithTail :: ArityEnv -> Divergence -> ArityType -> ArityType+andWithTail env div1 at2@(AT lams2 _)+  | isDeadEndDiv div1    -- case x of { T -> error; F -> \y.e }+  = at2                  -- See Note+  | pedanticBottoms env  --    [Combining case branches: andWithTail]+  = AT [] topDiv++  | otherwise  -- case x of { T -> plusInt <expensive>; F -> \y.e }+  = AT (map add_work lams2) topDiv    -- We know div1 = topDiv+    -- See Note [Combining case branches: andWithTail]++{- Note [Combining case branches: optimistic one-shot-ness]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When combining the ArityTypes for two case branches (with+andArityType) and both ArityTypes have ATLamInfo, then we just combine+their expensive-ness and one-shot info.  The tricky point is when we+have++     case x of True -> \x{one-shot). blah1+               Fale -> \y.           blah2++Since one-shot-ness is about the /consumer/ not the /producer/, we+optimistically assume that if either branch is one-shot, we combine+the best of the two branches, on the (slightly dodgy) basis that if we+know one branch is one-shot, then they all must be.  Surprisingly,+this means that the one-shot arity type is effectively the top element+of the lattice.++Hence the call to `bestOneShot` in `andArityType`.++Here's an example:+  go = \x. let z = go e0+               go2 = \x. case x of+                           True  -> z+                           False -> \s(one-shot). e1+           in go2 x++We *really* want to respect the one-shot annotation provided by the+user and eta-expand go and go2.  In the first fixpoint iteration of+'go' we'll bind 'go' to botArityType (written \.⊥, see Note+[ArityType]).  So 'z' will get arityType \.⊥; so we end up combining+the True and False branches:++      \.⊥ `andArityType` \1.T++That gives \1.T (see Note [Combining case branches: andWithTail],+first bullet).  So 'go2' gets an arityType of \(C?)(C1).T, which is+what we want.++Note [Care with nested expressions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+    arityType (Just <big-expressions>)+We will take+    arityType Just = AT [(IsCheap,os)] topDiv+and then do+    arityApp (AT [(IsCheap os)] topDiv) (exprCost <big-expression>)+The result will be AT [] topDiv.  It doesn't matter what <big-expresison>+is!  The same is true of+    arityType (let x = <rhs> in <body>)+where the cost of <rhs> doesn't matter unless <body> has a useful+arityType.++TL;DR in `floatIn`, do not to look at the Cost argument until you have to.++I found this when looking at #24471, although I don't think it was really+the main culprit.++Note [Combining case branches: andWithTail]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When combining the ArityTypes for two case branches (with andArityType)+and one side or the other has run out of ATLamInfo; then we get+into `andWithTail`.++* If one branch is guaranteed bottom (isDeadEndDiv), we just take+  the other. Consider   case x of+             True  -> \x.  error "urk"+             False -> \xy. error "urk2"++  Remember: \o1..on.⊥ means "if you apply to n args, it'll definitely+  diverge".  So we need \??.⊥ for the whole thing, the /max/ of both+  arities.++* Otherwise, if pedantic-bottoms is on, we just have to return+  AT [] topDiv.  E.g. if we have+    f x z = case x of True  -> \y. blah+                      False -> z+  then we can't eta-expand, because that would change the behaviour+  of (f False bottom().++* But if pedantic-bottoms is not on, we allow ourselves to push+  `z` under a lambda (much as we allow ourselves to put the `case x`+  under a lambda).  However we know nothing about the expensiveness+  or one-shot-ness of `z`, so we'd better assume it looks like+  (Expensive, NoOneShotInfo) all the way. Remembering+  Note [Combining case branches: optimistic one-shot-ness],+  we just add work to ever ATLamInfo, keeping the one-shot-ness.++Note [Eta expanding through CallStacks]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Just as it's good to eta-expand through dictionaries, so it is good to+do so through CallStacks.  #20103 is a case in point, where we got+  foo :: HasCallStack => Int -> Int+  foo = \(d::CallStack). let d2 = pushCallStack blah d in+        \(x:Int). blah++We really want to eta-expand this!  #20103 is quite convincing!+We do this regardless of -fdicts-cheap; it's not really a dictionary.++We also want to check both for (IP blah CallStack) and for CallStack itself.+We might have either+   d :: IP blah CallStack    -- Or HasCallStack+   d = (cs-expr :: CallStack) |> (nt-ax :: CallStack ~ IP blah CallStack)+or just+   cs :: CallStack+   cs = cs-expr++Test T20103 is an example of the latter.++Note [Eta expanding through dictionaries]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If the experimental -fdicts-cheap flag is on, we eta-expand through+dictionary bindings.  This improves arities. Thereby, it also+means that full laziness is less prone to floating out the+application of a function to its dictionary arguments, which+can thereby lose opportunities for fusion.  Example:+        foo :: Ord a => a -> ...+     foo = /\a \(d:Ord a). let d' = ...d... in \(x:a). ....+        -- So foo has arity 1++     f = \x. foo dInt $ bar x++The (foo DInt) is floated out, and makes ineffective a RULE+     foo (bar x) = ...++One could go further and make exprIsCheap reply True to any+dictionary-typed expression, but that's more work.+-}++---------------------------++data ArityEnv+  = AE { am_opts :: !ArityOpts++       , am_sigs :: !(IdEnv SafeArityType)+         -- NB `SafeArityType` so we can use this in myIsCheapApp+         -- See Note [Arity analysis] for details about fixed-point iteration.++       , am_free_joins :: !Bool  -- True <=> free join points allowed+         -- Used /only/ to support assertion checks+       }++instance Outputable ArityEnv where+  ppr (AE { am_sigs = sigs, am_free_joins = free_joins })+    = text "AE" <+> braces (sep [ text "free joins:" <+> ppr free_joins+                                , text "sigs:" <+> ppr sigs ])++-- | The @ArityEnv@ used by 'findRhsArity'.+findRhsArityEnv :: ArityOpts -> Bool -> ArityEnv+findRhsArityEnv opts free_joins+  = AE { am_opts       = opts+       , am_free_joins = free_joins+       , am_sigs       = emptyVarEnv }++freeJoinsOK :: ArityEnv -> Bool+freeJoinsOK (AE { am_free_joins = free_joins }) = free_joins++-- First some internal functions in snake_case for deleting in certain VarEnvs+-- of the ArityType. Don't call these; call delInScope* instead!++modifySigEnv :: (IdEnv ArityType -> IdEnv ArityType) -> ArityEnv -> ArityEnv+modifySigEnv f env@(AE { am_sigs = sigs }) = env { am_sigs = f sigs }+{-# INLINE modifySigEnv #-}++del_sig_env :: Id -> ArityEnv -> ArityEnv -- internal!+del_sig_env id = modifySigEnv (\sigs -> delVarEnv sigs id)+{-# INLINE del_sig_env #-}++del_sig_env_list :: [Id] -> ArityEnv -> ArityEnv -- internal!+del_sig_env_list ids = modifySigEnv (\sigs -> delVarEnvList sigs ids)+{-# INLINE del_sig_env_list #-}++-- end of internal deletion functions++extendSigEnv :: ArityEnv -> Id -> SafeArityType -> ArityEnv+extendSigEnv env id ar_ty+  = modifySigEnv (\sigs -> extendVarEnv sigs id ar_ty) $+    env++delInScope :: ArityEnv -> Id -> ArityEnv+delInScope env id = del_sig_env id env++delInScopeList :: ArityEnv -> [Id] -> ArityEnv+delInScopeList env ids = del_sig_env_list ids env++lookupSigEnv :: ArityEnv -> Id -> Maybe SafeArityType+lookupSigEnv (AE { am_sigs = sigs }) id = lookupVarEnv sigs id++-- | Whether the analysis should be pedantic about bottoms.+-- 'exprBotStrictness_maybe' always is.+pedanticBottoms :: ArityEnv -> Bool+pedanticBottoms (AE { am_opts = ArityOpts{ ao_ped_bot = ped_bot }}) = ped_bot++exprCost :: ArityEnv -> CoreExpr -> Maybe Type -> Cost+exprCost env e mb_ty+  | myExprIsCheap env e mb_ty = IsCheap+  | otherwise                 = IsExpensive++-- | A version of 'exprIsCheap' that considers results from arity analysis+-- and optionally the expression's type.+-- Under 'exprBotStrictness_maybe', no expressions are cheap.+myExprIsCheap :: ArityEnv -> CoreExpr -> Maybe Type -> Bool+myExprIsCheap (AE { am_opts = opts, am_sigs = sigs }) e mb_ty+  = cheap_dict || cheap_fun e+  where+    cheap_dict = case mb_ty of+                     Nothing -> False+                     Just ty -> (ao_dicts_cheap opts && isDictTy ty)+                                || isCallStackPredTy ty || isCallStackTy ty+        -- See Note [Eta expanding through dictionaries]+        -- See Note [Eta expanding through CallStacks]++    cheap_fun e = exprIsCheapX (myIsCheapApp sigs) False e++-- | A version of 'isCheapApp' that considers results from arity analysis.+-- See Note [Arity analysis] for what's in the signature environment and why+-- it's important.+myIsCheapApp :: IdEnv SafeArityType -> CheapAppFun+myIsCheapApp sigs fn n_val_args = case lookupVarEnv sigs fn of++  -- Nothing means not a local function, fall back to regular+  -- 'GHC.Core.Utils.isCheapApp'+  Nothing -> isCheapApp fn n_val_args++  -- `Just at` means local function with `at` as current SafeArityType.+  -- NB the SafeArityType bit: that means we can ignore the cost flags+  --    in 'lams', and just consider the length+  -- Roughly approximate what 'isCheapApp' is doing.+  Just (AT lams div)+    | isDeadEndDiv div -> True -- See Note [isCheapApp: bottoming functions] in GHC.Core.Utils+    | n_val_args == 0          -> True -- Essentially+    | n_val_args < length lams -> True -- isWorkFreeApp+    | otherwise                -> False++----------------+arityType :: HasDebugCallStack => ArityEnv -> CoreExpr -> ArityType+-- Precondition: all the free join points of the expression+--               are bound by the ArityEnv+-- See Note [No free join points in arityType]+--+-- Returns ArityType, not SafeArityType.  The caller must do+-- trimArityType if necessary.+arityType env (Var v)+  | Just at <- lookupSigEnv env v -- Local binding+  = at+  | otherwise+  = assertPpr (freeJoinsOK env || not (isJoinId v)) (ppr v) $+    -- All join-point should be in the ae_sigs+    -- See Note [No free join points in arityType]+    idArityType v++arityType env (Cast e _)+  = arityType env e++        -- Lambdas; increase arity+arityType env (Lam x e)+  | isId x    = arityLam x (arityType env' e)+  | otherwise = arityType env' e+  where+    env' = delInScope env x++        -- Applications; decrease arity, except for types+arityType env (App fun (Type _))+   = arityType env fun+arityType env (App fun arg )+   = arityApp fun_at arg_cost+   where+     fun_at   = arityType env fun+     arg_cost = exprCost env arg Nothing++        -- Case/Let; keep arity if either the expression is cheap+        -- or it's a 1-shot lambda+        -- The former is not really right for Haskell+        --      f x = case x of { (a,b) -> \y. e }+        --  ===>+        --      f x y = case x of { (a,b) -> e }+        -- The difference is observable using 'seq'+        --+arityType env (Case scrut bndr _ altList)+  | not $ exprIsDeadEnd scrut, Just alts <- nonEmpty altList+  = let env' = delInScope env bndr+        arity_type_alt (Alt _con bndrs rhs) = arityType (delInScopeList env' bndrs) rhs+        alts_type = foldr1 (andArityType env) (NE.map arity_type_alt alts)+    in if+      | not (pedanticBottoms env)  -- See (2) in Note [Dealing with bottom]+      , myExprIsCheap env scrut (Just (idType bndr))+       -> alts_type++      | exprOkForSpeculation scrut+       -> alts_type++      | otherwise            -- In the remaining cases we may not push+       -> addWork alts_type -- evaluation of the scrutinee in+  | otherwise = botArityType    -- Do not eta expand. See (1) in Note [Dealing with bottom]++arityType env (Let (NonRec b rhs) e)+  = -- See Note [arityType for non-recursive let-bindings]+    floatIn rhs_cost (arityType env' e)+  where+    rhs_cost = exprCost env rhs (Just (idType b))+    env'     = extendSigEnv env b (safeArityType (arityType env rhs))++arityType env (Let (Rec prs) e)+  = -- See Note [arityType for recursive let-bindings]+    floatIn (allCosts bind_cost prs) (arityType env' e)+  where+    bind_cost (b,e) = exprCost env' e (Just (idType b))+    env'            = foldl extend_rec env prs+    extend_rec :: ArityEnv -> (Id,CoreExpr) -> ArityEnv+    extend_rec env (b,_) = extendSigEnv env b  $+                           idArityType b+      -- See Note [arityType for recursive let-bindings]++arityType env (Tick t e)+  | not (tickishIsCode t)     = arityType env e++arityType _ _ = topArityType++--------------------+idArityType :: Id -> ArityType+idArityType v+  | strict_sig <- idDmdSig v+  , (ds, div) <- splitDmdSig strict_sig+  , isDeadEndDiv div+  = AT (takeList ds one_shots) div++  | isEmptyTy id_ty+  = botArityType++  | otherwise+  = AT (take (idArity v) one_shots) topDiv+  where+    id_ty = idType v++    one_shots :: [(Cost,OneShotInfo)]  -- One-shot-ness derived from the type+    one_shots = repeat IsCheap `zip` typeOneShots id_ty++--------------------+cheapArityType :: HasDebugCallStack => CoreExpr -> ArityType+-- A fast and cheap version of arityType.+-- Returns an ArityType with IsCheap everywhere+-- c.f. GHC.Core.Utils.exprIsDeadEnd+--+-- /Can/ encounter a free join-point Id; e.g. via the call+--   in exprBotStrictness_maybe, which is called in lots+--   of places+--+-- Returns ArityType, not SafeArityType.  The caller must do+-- trimArityType if necessary.+cheapArityType e = go e+  where+    go (Var v)                  = idArityType v+    go (Cast e _)               = go e+    go (Lam x e)  | isId x      = arityLam x (go e)+                  | otherwise   = go e+    go (App e a)  | isTypeArg a = go e+                  | otherwise   = arity_app a (go e)++    go (Tick t e) | not (tickishIsCode t) = go e++    -- Null alts: see Note [Empty case alternatives] in GHC.Core+    go (Case _ _ _ alts) | null alts = botArityType++    -- Give up on let, case.  In particular, unlike arityType,+    -- we make no attempt to look inside let's.+    go _ = topArityType++    -- Specialised version of arityApp; all costs in ArityType are IsCheap+    -- See Note [exprArity for applications]+    -- NB: (1) coercions count as a value argument+    --     (2) we use the super-cheap exprIsTrivial rather than the+    --         more complicated and expensive exprIsCheap+    arity_app _ at@(AT [] _) = at+    arity_app arg at@(AT ((cost,_):lams) div)+       | assertPpr (cost == IsCheap) (ppr at $$ ppr arg) $+         isDeadEndDiv div  = AT lams div+       | exprIsTrivial arg = AT lams topDiv+       | otherwise         = topArityType++---------------+exprArity :: CoreExpr -> Arity+-- ^ An approximate, even faster, version of 'cheapArityType'+-- Roughly   exprArity e = arityTypeArity (cheapArityType e)+-- But it's a bit less clever about bottoms+--+-- We do /not/ guarantee that exprArity e <= typeArity e+-- You may need to do arity trimming after calling exprArity+-- See Note [Arity trimming]+-- Reason: if we do arity trimming here we have take exprType+--         and that can be expensive if there is a large cast+exprArity e = go e+  where+    go (Var v)                     = idArity v+    go (Lam x e) | isId x          = go e + 1+                 | otherwise       = go e+    go (Tick t e) | not (tickishIsCode t) = go e+    go (Cast e _)                  = go e+    go (App e (Type _))            = go e+    go (App f a) | exprIsTrivial a = (go f - 1) `max` 0+        -- See Note [exprArity for applications]+        -- NB: coercions count as a value argument++    go _                           = 0++---------------+exprIsDeadEnd :: CoreExpr -> Bool+-- See Note [Bottoming expressions]+-- This function is, in effect, just a specialised (and hence cheap)+--    version of cheapArityType:+--    exprIsDeadEnd e = case cheapArityType e of+--                         AT lams div -> null lams && isDeadEndDiv div+-- See also exprBotStrictness_maybe, which uses cheapArityType+exprIsDeadEnd e+  = go 0 e+  where+    go :: Arity -> CoreExpr -> Bool+    -- (go n e) = True <=> expr applied to n value args is bottom+    go _ (Lit {})                = False+    go _ (Type {})               = False+    go _ (Coercion {})           = False+    go n (App e a) | isTypeArg a = go n e+                   | otherwise   = go (n+1) e+    go n (Tick _ e)              = go n e+    go n (Cast e _)              = go n e+    go n (Let _ e)               = go n e+    go n (Lam v e) | isTyVar v   = go n e+                   | otherwise   = False++    go _ (Case _ _ _ alts)       = null alts+       -- See Note [Empty case alternatives] in GHC.Core++    go n (Var v) | isDeadEndAppSig (idDmdSig v) n = True+                 | isEmptyTy (idType v)           = True+                 | otherwise                      = False++{- Note [Bottoming expressions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A bottoming expression is guaranteed to diverge, or raise an+exception.  We can test for it in two different ways, and exprIsDeadEnd+checks for both of these situations:++* Visibly-bottom computations.  For example+      (error Int "Hello")+  is visibly bottom.  The strictness analyser also finds out if+  a function diverges or raises an exception, and puts that info+  in its strictness signature.++* Empty types.  If a type is empty, its only inhabitant is bottom.+  For example:+      data T+      f :: T -> Bool+      f = \(x:t). case x of Bool {}+  Since T has no data constructors, the case alternatives are of course+  empty.  However note that 'x' is not bound to a visibly-bottom value;+  it's the *type* that tells us it's going to diverge.++A GADT may also be empty even though it has constructors:+        data T a where+          T1 :: a -> T Bool+          T2 :: T Int+        ...(case (x::T Char) of {})...+Here (T Char) is uninhabited.  A more realistic case is (Int ~ Bool),+which is likewise uninhabited.++Note [No free join points in arityType]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we call arityType on this expression (EX1)+   \x . case x of True  -> \y. e+                  False -> $j 3+where $j is a join point.  It really makes no sense to talk of the arity+of this expression, because it has a free join point.  In particular, we+can't eta-expand the expression because we'd have do the same thing to the+binding of $j, and we can't see that binding.++If we had (EX2)+   \x. join $j y = blah+       case x of True  -> \y. e+                 False -> $j 3+then it would make perfect sense: we can determine $j's ArityType, and+propagate it to the usage site as usual.++But how can we get (EX1)?  It doesn't make much sense, because $j can't+be a join point under the \x anyway.  So we make it a precondition of+arityType that the argument has no free join-point Ids.  (This is checked+with an assert in the Var case of arityType.)++Wrinkles++* We /do/ allow free join point when doing findRhsArity for join-point+  right-hand sides. See Note [Arity for recursive join bindings]+  point (5) in GHC.Core.Opt.Simplify.Utils.++* The invariant (no free join point in arityType) risks being+  invalidated by one very narrow special case: runRW#++   join $j y = blah+   runRW# (\s. case x of True  -> \y. e+                         False -> $j x)++  We have special magic in OccurAnal, and Simplify to allow continuations to+  move into the body of a runRW# call.++  So we are careful never to attempt to eta-expand the (\s.blah) in the+  argument to runRW#, at least not when there is a literal lambda there,+  so that OccurAnal has seen it and allowed join points bound outside.+  See Note [No eta-expansion in runRW#] in GHC.Core.Opt.Simplify.Iteration.++Note [arityType for non-recursive let-bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For non-recursive let-bindings, we just get the arityType of the RHS,+and extend the environment.  That works nicely for things like this+(#18793):+  go = \ ds. case ds_a2CF of {+               []     -> id+               : y ys -> case y of { GHC.Types.I# x ->+                         let acc = go ys in+                         case x ># 42# of {+                            __DEFAULT -> acc+                            1# -> \x1. acc (negate x2)++Here we want to get a good arity for `acc`, based on the ArityType+of `go`.++All this is particularly important for join points. Consider this (#18328)++  f x = join j y = case y of+                      True -> \a. blah+                      False -> \b. blah+        in case x of+              A -> j True+              B -> \c. blah+              C -> j False++and suppose the join point is too big to inline.  Now, what is the+arity of f?  If we inlined the join point, we'd definitely say "arity+2" because we are prepared to push case-scrutinisation inside a+lambda. It's important that we extend the envt with j's ArityType, so+that we can use that information in the A/C branch of the case.++Note [arityType for recursive let-bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For /recursive/ bindings it's more difficult, to call arityType+(as we do in Note [arityType for non-recursive let-bindings])+because we don't have an ArityType to put in the envt for the+recursively bound Ids.  So for we satisfy ourselves with whizzing up+up an ArityType from the idArity of the function, via idArityType.++That is nearly equivalent to deleting the binder from the envt, at+which point we'll call idArityType at the occurrences.  But doing it+here means++  (a) we only call idArityType once, no matter how many+      occurrences, and++  (b) we can check (in the arityType (Var v) case) that+      we don't mention free join-point Ids. See+      Note [No free join points in arityType].++But see Note [Arity for recursive join bindings] in+GHC.Core.Opt.Simplify.Utils for dark corners.+-}++{-+%************************************************************************+%*                                                                      *+              The main eta-expander+%*                                                                      *+%************************************************************************++We go for:+   f = \x1..xn -> N  ==>   f = \x1..xn y1..ym -> N y1..ym+                                 (n >= 0)++where (in both cases)++        * The xi can include type variables++        * The yi are all value variables++        * N is a NORMAL FORM (i.e. no redexes anywhere)+          wanting a suitable number of extra args.++The biggest reason for doing this is for cases like++        f = \x -> case x of+                    True  -> \y -> e1+                    False -> \y -> e2++Here we want to get the lambdas together.  A good example is the nofib+program fibheaps, which gets 25% more allocation if you don't do this+eta-expansion.++We may have to sandwich some coerces between the lambdas+to make the types work.   exprEtaExpandArity looks through coerces+when computing arity; and etaExpand adds the coerces as necessary when+actually computing the expansion.++Note [No crap in eta-expanded code]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The eta expander is careful not to introduce "crap".  In particular,+given a CoreExpr satisfying the 'CpeRhs' invariant (in CorePrep), it+returns a CoreExpr satisfying the same invariant. See Note [Eta+expansion and the CorePrep invariants] in CorePrep.++This means the eta-expander has to do a bit of on-the-fly+simplification but it's not too hard.  The alternative, of relying on+a subsequent clean-up phase of the Simplifier to de-crapify the result,+means you can't really use it in CorePrep, which is painful.++Note [Eta expansion for join points]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The no-crap rule is very tiresome to guarantee when+we have join points. Consider eta-expanding+   let j :: Int -> Int -> Bool+       j x = e+   in b++The simple way is+  \(y::Int). (let j x = e in b) y++The no-crap way is+  \(y::Int). let j' :: Int -> Bool+                 j' x = e y+             in b[j'/j] y+where I have written b[j'/j] to stress that j's type has+changed.  Note that (of course!) we have to push the application+inside the RHS of the join as well as into the body.  AND if j+has an unfolding we have to push it into there too.  AND j might+be recursive...++So for now I'm abandoning the no-crap rule in this case, conscious that this+causes the ugly Wrinkle (EA1) of Note [Eta expansion of arguments in CorePrep].++(Moreover, I think that casts can make the no-crap rule fail too.)++Note [Eta expansion and SCCs]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Note that SCCs are not treated specially by etaExpand.  If we have+        etaExpand 2 (\x -> scc "foo" e)+        = (\xy -> (scc "foo" e) y)+So the costs of evaluating 'e' (not 'e y') are attributed to "foo"++Note [Eta expansion and source notes]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+CorePrep puts floatable ticks outside of value applications, but not+type applications. As a result we might be trying to eta-expand an+expression like++  (src<...> v) @a++which we want to lead to code like++  \x -> src<...> v @a x++This means that we need to look through type applications and be ready+to re-add floats on the top.++Note [Eta expansion with ArityType]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The etaExpandAT function takes an ArityType (not just an Arity) to+guide eta-expansion.  Why? Because we want to preserve one-shot info.+Consider+  foo = \x. case x of+              True  -> (\s{os}. blah) |> co+              False -> wubble+We'll get an ArityType for foo of \?1.T.++Then we want to eta-expand to+  foo = (\x. \eta{os}. (case x of ...as before...) eta) |> some_co++That 'eta' binder is fresh, and we really want it to have the+one-shot flag from the inner \s{os}.  By expanding with the+ArityType gotten from analysing the RHS, we achieve this neatly.++This makes a big difference to the one-shot monad trick;+see Note [The one-shot state monad trick] in GHC.Utils.Monad.+-}++-- | @etaExpand n e@ returns an expression with+-- the same meaning as @e@, but with arity @n@.+--+-- Given:+--+-- > e' = etaExpand n e+--+-- We should have that:+--+-- > ty = exprType e = exprType e'++etaExpand :: Arity -> CoreExpr -> CoreExpr+etaExpand n orig_expr+  = eta_expand in_scope (replicate n NoOneShotInfo) orig_expr+  where+    in_scope = {-#SCC "eta_expand:in-scopeX" #-}+               mkInScopeSet (exprFreeVars orig_expr)++etaExpandAT :: InScopeSet -> SafeArityType -> CoreExpr -> CoreExpr+-- See Note [Eta expansion with ArityType]+--+-- We pass in the InScopeSet from the simplifier to avoid recomputing+-- it here, which can be jolly expensive if the casts are big+-- In #18223 it took 10% of compile time just to do the exprFreeVars!+etaExpandAT in_scope at orig_expr+  = eta_expand in_scope (arityTypeOneShots at) orig_expr++-- etaExpand arity e = res+-- Then 'res' has at least 'arity' lambdas at the top+--    possibly with a cast wrapped around the outside+-- See Note [Eta expansion with ArityType]+--+-- etaExpand deals with for-alls. For example:+--              etaExpand 1 E+-- where  E :: forall a. a -> a+-- would return+--      (/\b. \y::a -> E b y)++eta_expand :: InScopeSet -> [OneShotInfo] -> CoreExpr -> CoreExpr+eta_expand in_scope one_shots (Cast expr co)+  = mkCast (eta_expand in_scope one_shots expr) co+    -- This mkCast is important, because eta_expand might return an+    -- expression with a cast at the outside; and tryCastWorkerWrapper+    -- asssumes that we don't have nested casts. Makes a difference+    -- in compile-time for T18223++eta_expand in_scope one_shots orig_expr+  = go in_scope one_shots [] orig_expr+  where+      -- Strip off existing lambdas and casts before handing off to mkEtaWW+      -- This is mainly to avoid spending time cloning binders and substituting+      -- when there is actually nothing to do.  It's slightly awkward to deal+      -- with casts here, apart from the topmost one, and they are rare, so+      -- if we find one we just hand off to mkEtaWW anyway+      -- Note [Eta expansion and SCCs]+    go _ [] _ _ = orig_expr  -- Already has the specified arity; no-op++    go in_scope oss@(_:oss1) vs (Lam v body)+      | isTyVar v = go (in_scope `extendInScopeSet` v) oss  (v:vs) body+      | otherwise = go (in_scope `extendInScopeSet` v) oss1 (v:vs) body++    go in_scope oss rev_vs expr+      = -- pprTrace "ee" (vcat [ppr in_scope', ppr top_bndrs, ppr eis]) $+        retick $+        etaInfoAbs top_eis $+        etaInfoApp in_scope' sexpr eis+      where+          (in_scope', eis@(EI eta_bndrs mco))+                    = mkEtaWW oss (ppr orig_expr) in_scope (exprType expr)+          top_bndrs = reverse rev_vs+          top_eis   = EI (top_bndrs ++ eta_bndrs) (mkPiMCos top_bndrs mco)++          -- Find ticks behind type apps.+          -- See Note [Eta expansion and source notes]+          -- I don't really understand this code SLPJ May 21+          (expr', args) = collectArgs expr+          (ticks, expr'') = stripTicksTop tickishFloatable expr'+          sexpr = mkApps expr'' args+          retick expr = foldr mkTick expr ticks++{- *********************************************************************+*                                                                      *+              The EtaInfo mechanism+          mkEtaWW, etaInfoAbs, etaInfoApp+*                                                                      *+********************************************************************* -}++{- Note [The EtaInfo mechanism]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have (e :: ty) and we want to eta-expand it to arity N.+This what eta_expand does.  We do it in two steps:++1.  mkEtaWW: from 'ty' and 'N' build a EtaInfo which describes+    the shape of the expansion necessary to expand to arity N.++2.  Build the term+       \ v1..vn.  e v1 .. vn+    where those abstractions and applications are described by+    the same EtaInfo.  Specifically we build the term++       etaInfoAbs etas (etaInfoApp in_scope e etas)++   where etas :: EtaInfo+         etaInfoAbs builds the lambdas+         etaInfoApp builds the applications++   Note that the /same/ EtaInfo drives both etaInfoAbs and etaInfoApp++To a first approximation EtaInfo is just [Var].  But casts complicate+the question.  If we have+   newtype N a = MkN (S -> a)+     axN :: N a  ~  S -> a+and+   e :: N (N Int)+then the eta-expansion should look like+   (\(x::S) (y::S) -> (e |> co) x y) |> sym co+where+  co :: N (N Int) ~ S -> S -> Int+  co = axN @(N Int) ; (S -> axN @Int)++We want to get one cast, at the top, to account for all those+nested newtypes. This is expressed by the EtaInfo type:++   data EtaInfo = EI [Var] MCoercionR++Precisely, here is the (EtaInfo Invariant):++  EI bs co :: EtaInfo++describes a particular eta-expansion, thus:++  Abstraction:  (\b1 b2 .. bn. []) |> sym co+  Application:  ([] |> co) b1 b2 .. bn++  e  :: T+  co :: T ~R (t1 -> t2 -> .. -> tn -> tr)+  e = (\b1 b2 ... bn. (e |> co) b1 b2 .. bn) |> sym co+++Note [Check for reflexive casts in eta expansion]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It turns out that the casts created by the above mechanism are often Refl.+When casts are very deeply nested (as happens in #18223), the repetition+of types can make the overall term very large.  So there is a big+payoff in cancelling out casts aggressively wherever possible.+(See also Note [No crap in eta-expanded code].)++This matters particularly in etaInfoApp, where we+* Do beta-reduction on the fly+* Use getArg_maybe to get a cast out of the way,+  so that we can do beta reduction+Together this makes a big difference.  Consider when e is+   case x of+      True  -> (\x -> e1) |> c1+      False -> (\p -> e2) |> c2++When we eta-expand this to arity 1, say, etaInfoAbs will wrap+a (\eta) around the outside and use etaInfoApp to apply each+alternative to 'eta'.  We want to beta-reduce all that junk+away.++#18223 was a dramatic example in which the intermediate term was+grotesquely huge, even though the next Simplifier iteration squashed+it.  Better to kill it at birth.++The crucial spots in etaInfoApp are:+* `checkReflexiveMCo` in the (Cast e co) case of `go`+* `checkReflexiveMCo` in `pushCoArg`+* Less important: checkReflexiveMCo in the final case of `go`+Collectively these make a factor-of-5 difference to the total+allocation of T18223, so take care if you change this stuff!++Example:+   newtype N = MkN (Y->Z)+   f :: X -> N+   f = \(x::X). ((\(y::Y). blah) |> fco)++where fco :: (Y->Z) ~ N++mkEtaWW makes an EtaInfo of (EI [(eta1:X), (eta2:Y)] eta_co+  where+    eta_co :: (X->N) ~ (X->Y->Z)+    eta_co =  (<X> -> nco)+    nco :: N ~ (Y->Z)  -- Comes from topNormaliseNewType_maybe++Now, when we push that eta_co inward in etaInfoApp:+* In the (Cast e co) case, the 'fco' and 'nco' will meet, and+  should cancel.+* When we meet the (\y.e) we want no cast on the y.++-}++--------------+data EtaInfo = EI [Var] MCoercionR+     -- See Note [The EtaInfo mechanism]++instance Outputable EtaInfo where+  ppr (EI vs mco) = text "EI" <+> ppr vs <+> parens (ppr mco)+++etaInfoApp :: InScopeSet -> CoreExpr -> EtaInfo -> CoreExpr+-- (etaInfoApp s e (EI bs mco) returns something equivalent to+--             ((substExpr s e) |> mco b1 .. bn)+-- See Note [The EtaInfo mechanism]+--+-- NB: With very deeply nested casts, this function can be expensive+--     In T18223, this function alone costs 15% of allocation, all+--     spent in the calls to substExprSC and substBindSC++etaInfoApp in_scope expr eis+  = go (mkEmptySubst in_scope) expr eis+  where+    go :: Subst -> CoreExpr -> EtaInfo -> CoreExpr+    -- 'go' pushed down the eta-infos into the branch of a case+    -- and the body of a let; and does beta-reduction if possible+    --   go subst fun co [b1,..,bn]  returns  (subst(fun) |> co) b1 .. bn+    go subst (Tick t e) eis+      = Tick (substTickish subst t) (go subst e eis)++    go subst (Cast e co) (EI bs mco)+      = go subst e (EI bs mco')+      where+        mco' = checkReflexiveMCo (Core.substCo subst co `mkTransMCoR` mco)+               -- See Note [Check for reflexive casts in eta expansion]++    go subst (Case e b ty alts) eis+      = Case (Core.substExprSC subst e) b1 ty' alts'+      where+        (subst1, b1) = Core.substBndr subst b+        alts' = map subst_alt alts+        ty'   = etaInfoAppTy (substTyUnchecked subst ty) eis+        subst_alt (Alt con bs rhs) = Alt con bs' (go subst2 rhs eis)+                 where+                  (subst2,bs') = Core.substBndrs subst1 bs++    go subst (Let b e) eis+      | not (isJoinBind b) -- See Note [Eta expansion for join points]+      = Let b' (go subst' e eis)+      where+        (subst', b') = Core.substBindSC subst b++    -- Beta-reduction if possible, pushing any intervening casts past+    -- the argument. See Note [The EtaInfo mechanism]+    go subst (Lam v e) (EI (b:bs) mco)+      | Just (arg,mco') <- pushMCoArg mco (varToCoreExpr b)+      = go (Core.extendSubst subst v arg) e (EI bs mco')++    -- Stop pushing down; just wrap the expression up+    -- See Note [Check for reflexive casts in eta expansion]+    go subst e (EI bs mco) = Core.substExprSC subst e+                             `mkCastMCo` checkReflexiveMCo mco+                             `mkVarApps` bs++--------------+etaInfoAppTy :: Type -> EtaInfo -> Type+-- If                    e :: ty+-- then   etaInfoApp e eis :: etaInfoApp ty eis+etaInfoAppTy ty (EI bs mco)+  = applyTypeToArgs ty1 (map varToCoreExpr bs)+  where+    ty1 = case mco of+             MRefl  -> ty+             MCo co -> coercionRKind co++--------------+etaInfoAbs :: EtaInfo -> CoreExpr -> CoreExpr+-- See Note [The EtaInfo mechanism]+etaInfoAbs (EI bs mco) expr = (mkLams bs expr) `mkCastMCo` mkSymMCo mco++--------------+-- | @mkEtaWW n _ fvs ty@ will compute the 'EtaInfo' necessary for eta-expanding+-- an expression @e :: ty@ to take @n@ value arguments, where @fvs@ are the+-- free variables of @e@.+--+-- Note that this function is entirely unconcerned about cost centres and other+-- semantically-irrelevant source annotations, so call sites must take care to+-- preserve that info. See Note [Eta expansion and SCCs].+mkEtaWW+  :: [OneShotInfo]+  -- ^ How many value arguments to eta-expand+  -> SDoc+  -- ^ The pretty-printed original expression, for warnings.+  -> InScopeSet+  -- ^ A super-set of the free vars of the expression to eta-expand.+  -> Type+  -> (InScopeSet, EtaInfo)+  -- ^ The variables in 'EtaInfo' are fresh wrt. to the incoming 'InScopeSet'.+  -- The outgoing 'InScopeSet' extends the incoming 'InScopeSet' with the+  -- fresh variables in 'EtaInfo'.++mkEtaWW orig_oss ppr_orig_expr in_scope orig_ty+  = go 0 orig_oss empty_subst orig_ty+  where+    empty_subst = mkEmptySubst in_scope++    go :: Int                -- For fresh names+       -> [OneShotInfo]      -- Number of value args to expand to+       -> Subst -> Type   -- We are really looking at subst(ty)+       -> (InScopeSet, EtaInfo)+    -- (go [o1,..,on] subst ty) = (in_scope, EI [b1,..,bn] co)+    --    co :: subst(ty) ~ b1_ty -> ... -> bn_ty -> tr++    go _ [] subst _+       ----------- Done!  No more expansion needed+       = (substInScopeSet subst, EI [] MRefl)++    go n oss@(one_shot:oss1) subst ty+       ----------- Forall types  (forall a. ty)+       | Just (Bndr tcv vis, ty') <- splitForAllForAllTyBinder_maybe ty+       , (subst', tcv') <- Type.substVarBndr subst tcv+       , let oss' | isTyVar tcv = oss+                  | otherwise   = oss1+         -- A forall can bind a CoVar, in which case+         -- we consume one of the [OneShotInfo]+       , (in_scope, EI bs mco) <- go n oss' subst' ty'+       = (in_scope, EI (tcv' : bs) (mkEtaForAllMCo (Bndr tcv' vis) ty' mco))++       ----------- Function types  (t1 -> t2)+       | Just (_af, mult, arg_ty, res_ty) <- splitFunTy_maybe ty+       , typeHasFixedRuntimeRep arg_ty+          -- See Note [Representation polymorphism invariants] in GHC.Core+          -- See also test case typecheck/should_run/EtaExpandLevPoly++       , (subst', eta_id) <- freshEtaId n subst (Scaled mult arg_ty)+          -- Avoid free vars of the original expression++       , let eta_id' = eta_id `setIdOneShotInfo` one_shot+       , (in_scope, EI bs mco) <- go (n+1) oss1 subst' res_ty+       = (in_scope, EI (eta_id' : bs) (mkFunResMCo eta_id' mco))++       ----------- Newtypes+       -- Given this:+       --      newtype T = MkT ([T] -> Int)+       -- Consider eta-expanding this+       --      eta_expand 1 e T+       -- We want to get+       --      coerce T (\x::[T] -> (coerce ([T]->Int) e) x)+       | Just (co, ty') <- topNormaliseNewType_maybe ty+       , -- co :: ty ~ ty'+         let co' = Type.substCo subst co+             -- Remember to apply the substitution to co (#16979)+             -- (or we could have applied to ty, but then+             --  we'd have had to zap it for the recursive call)+       , (in_scope, EI bs mco) <- go n oss subst ty'+         -- mco :: subst(ty') ~ b1_ty -> ... -> bn_ty -> tr+       = (in_scope, EI bs (mkTransMCoR co' mco))++       | otherwise       -- We have an expression of arity > 0,+                         -- but its type isn't a function, or a binder+                         -- does not have a fixed runtime representation+       = warnPprTrace True "mkEtaWW" ((ppr orig_oss <+> ppr orig_ty) $$ ppr_orig_expr)+         (substInScopeSet subst, EI [] MRefl)+        -- This *can* legitimately happen:+        -- e.g.  coerce Int (\x. x) Essentially the programmer is+        -- playing fast and loose with types (Happy does this a lot).+        -- So we simply decline to eta-expand.  Otherwise we'd end up+        -- with an explicit lambda having a non-function type++mkEtaForAllMCo :: ForAllTyBinder -> Type -> MCoercion -> MCoercion+mkEtaForAllMCo (Bndr tcv vis) ty mco+  = case mco of+      MRefl | vis == coreTyLamForAllTyFlag -> MRefl+            | otherwise                    -> mk_fco (mkRepReflCo ty)+      MCo co                               -> mk_fco co+  where+    mk_fco co = MCo (mkForAllCo tcv vis coreTyLamForAllTyFlag+                                (mkNomReflCo (varType tcv)) co)+    -- coreTyLamForAllTyFlag: See Note [The EtaInfo mechanism], particularly+    -- the (EtaInfo Invariant).  (sym co) wraps a lambda that always has+    -- a ForAllTyFlag of coreTyLamForAllTyFlag; see Note [Required foralls in Core]+    -- in GHC.Core.TyCo.Rep++{-+************************************************************************+*                                                                      *+                Eta reduction+*                                                                      *+************************************************************************++Note [Eta reduction makes sense]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+GHC's eta reduction transforms+   \x y. <fun> x y  --->  <fun>+We discuss when this is /sound/ in Note [Eta reduction soundness].+But even assuming it is sound, when is it /desirable/.  That+is what we discuss here.++This test is made by `ok_fun` in tryEtaReduce.++1. We want to eta-reduce only if we get all the way to a trivial+   expression; we don't want to remove extra lambdas unless we are+   going to avoid allocating this thing altogether.++   Trivial means *including* casts and type lambdas:+     * `\x. f x |> co  -->  f |> (ty(x) -> co)` (provided `co` doesn't mention `x`)+     * `/\a. \x. f @(Maybe a) x -->  /\a. f @(Maybe a)`+   See Note [Do not eta reduce PAPs] for why we insist on a trivial head.++Of course, eta reduction is not always sound. See Note [Eta reduction soundness]+for when it is.++When there are multiple arguments, we might get multiple eta-redexes. Example:+   \x y. e x y+   ==> { reduce \y. (e x) y in context \x._ }+   \x. e x+   ==> { reduce \x. e x in context _ }+   e+And (1) implies that we never want to stop with `\x. e x`, because that is not a+trivial expression. So in practice, the implementation works by considering a+whole group of leading lambdas to reduce.++These delicacies are why we don't simply use 'exprIsTrivial' and 'exprIsHNF'+in 'tryEtaReduce'. Alas.++Note [Eta reduction soundness]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+GHC's eta reduction transforms+   \x y. <fun> x y  --->  <fun>+For soundness, we obviously require that `x` and `y`+to not occur free. But what /other/ restrictions are there for+eta reduction to be sound?++We discuss separately what it means for eta reduction to be+/desirable/, in Note [Eta reduction makes sense].++Eta reduction is *not* a sound transformation in general, because it+may change termination behavior if *value* lambdas are involved:+  `bot`  /=  `\x. bot x`   (as can be observed by a simple `seq`)+The past has shown that oversight of this fact can not only lead to endless+loops or exceptions, but also straight out *segfaults*.++Nevertheless, we can give the following criteria for when it is sound to+perform eta reduction on an expression with n leading lambdas `\xs. e xs`+(checked in 'is_eta_reduction_sound' in 'tryEtaReduce', which focuses on the+case where `e` is trivial):++(A) It is sound to eta-reduce n arguments as long as n does not exceed the+    `exprArity` of `e`. (Needs Arity analysis.)+    This criterion exploits information about how `e` is *defined*.++    Example: If `e = \x. bot` then we know it won't diverge until it is called+    with one argument. Hence it is safe to eta-reduce `\x. e x` to `e`.+    By contrast, it would be *unsound* to eta-reduce 2 args, `\x y. e x y` to `e`:+    `e 42` diverges when `(\x y. e x y) 42` does not.++(S) It is sound to eta-reduce n arguments in an evaluation context in which all+    calls happen with at least n arguments. (Needs Strictness analysis.)+    NB: This treats evaluations like a call with 0 args.+    NB: This criterion exploits information about how `e` is *used*.++    Example: Given a function `g` like+      `g c = Just (c 1 2 + c 2 3)`+    it is safe to eta-reduce the arg in `g (\x y. e x y)` to `g e` without+    knowing *anything* about `e` (perhaps it's a parameter occ itself), simply+    because `g` always calls its parameter with 2 arguments.+    It is also safe to eta-reduce just one arg, e.g., `g (\x. e x)` to `g e`.+    By contrast, it would *unsound* to eta-reduce 3 args in a call site+    like `g (\x y z. e x y z)` to `g e`, because that diverges when+    `e = \x y. bot`.++    Could we relax to "*At least one call in the same trace* is with n args"?+    No. Consider what happens for+      ``g2 c = c True `seq` c False 42``+    Here, `g2` will call `c` with 2 arguments (if there is a call at all).+    But it is unsound to eta-reduce the arg in `g2 (\x y. e x y)` to `g2 e`+    when `e = \x. if x then bot else id`, because the latter will diverge when+    the former would not. Fortunately, the strictness analyser will report+    "Not always called with two arguments" for `g2` and we won't eta-expand.++    See Note [Eta reduction based on evaluation context] for the implementation+    details. This criterion is tested extensively in T21261.++(R) Note [Eta reduction in recursive RHSs] tells us that we should not+    eta-reduce `f` in its own RHS and describes our fix.+    There we have `f = \x. f x` and we should not eta-reduce to `f=f`. Which+    might change a terminating program (think @f `seq` e@) to a non-terminating+    one.++(E) (See fun_arity in tryEtaReduce.) As a perhaps special case on the+    boundary of (A) and (S), when we know that a fun binder `f` is in+    WHNF, we simply assume it has arity 1 and apply (A).  Example:+       g f = f `seq` \x. f x+    Here it's sound eta-reduce `\x. f x` to `f`, because `f` can't be bottom+    after the `seq`. This turned up in #7542.++ T. If the binders are all type arguments, it's always safe to eta-reduce,+    regardless of the arity of f.+       /\a b. f @a @b  --> f++2. Type and dictionary abstraction. Regardless of whether 'f' is a value, it+   is always sound to reduce /type lambdas/, thus:+        (/\a -> f a)  -->   f+   Moreover, we always want to, because it makes RULEs apply more often:+      This RULE:    `forall g. foldr (build (/\a -> g a))`+      should match  `foldr (build (/\b -> ...something complex...))`+   and the simplest way to do so is eta-reduce `/\a -> g a` in the RULE to `g`.++   More debatably, we extend this to dictionary arguments too, because the type+   checker can insert these eta-expanded versions, with both type and dictionary+   lambdas; hence the slightly ad-hoc (all ok_lam bndrs).  That is, we eta-reduce+        \(d::Num a). f d   -->   f+   regardless of f's arity. Its not clear whether or not this is important, and+   it is not in general sound.  But that's the way it is right now.++And here are a few more technical criteria for when it is *not* sound to+eta-reduce that are specific to Core and GHC:++(J) We may not undersaturate join points.+    See Note [Invariants on join points] in GHC.Core, and #20599.++(B) We may not undersaturate functions with no binding.+    See Note [Eta expanding primops].++(W) We may not undersaturate StrictWorkerIds.+    See Note [CBV Function Ids] in GHC.Types.Id.Info.++Here is a list of historic accidents surrounding unsound eta-reduction:++* Consider+        f = \x.f x+        h y = case (case y of { True -> f `seq` True; False -> False }) of+                True -> ...; False -> ...+  If we (unsoundly) eta-reduce f to get f=f, the strictness analyser+  says f=bottom, and replaces the (f `seq` True) with just+  (f `cast` unsafe-co).+  [SG in 2022: I don't think worker/wrapper would do this today.]+  BUT, as things stand, 'f' got arity 1, and it *keeps* arity 1 (perhaps also+  wrongly). So CorePrep eta-expands the definition again, so that it does not+  terminate after all.+  Result: seg-fault because the boolean case actually gets a function value.+  See #1947.++* Never *reduce* arity. For example+      f = \xy. g x y+  Then if h has arity 1 we don't want to eta-reduce because then+  f's arity would decrease, and that is bad+  [SG in 2022: I don't understand this point. There is no `h`, perhaps that+   should have been `g`. Even then, this proposed eta-reduction is invalid by+   criterion (A), which might actually be the point this anecdote is trying to+   make. Perhaps the "no arity decrease" idea is also related to+   Note [Arity robustness]?]++Note [Do not eta reduce PAPs]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+I considered eta-reducing if the result is a PAP:+   \x. f e1 e2 x  ==>   f e1 e2++This reduces clutter, sometimes a lot. See Note [Do not eta-expand PAPs]+in GHC.Core.Opt.Simplify.Utils, where we are careful not to eta-expand+a PAP.  If eta-expanding is bad, then eta-reducing is good!++Also the code generator likes eta-reduced PAPs; see GHC.CoreToStg.Prep+Note [No eta reduction needed in rhsToBody].++But note that we don't want to eta-reduce+     \x y.  f <expensive> x y+to+     f <expensive>+The former has arity 2, and repeats <expensive> for every call of the+function; the latter has arity 0, and shares <expensive>.  We don't want+to change behaviour.  Hence the call to exprIsCheap in ok_fun.++I noticed this when examining #18993 and, although it is delicate,+eta-reducing to a PAP happens to fix the regression in #18993.++HOWEVER, if we transform+   \x. f y x   ==>   f y+that might mean that f isn't saturated any more, and does not inline.+This led to some other regressions.++TL;DR currently we do /not/ eta reduce if the result is a PAP.++Note [Eta reduction with casted arguments]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+    (\(x:t3). f (x |> g)) :: t3 -> t2+  where+    f :: t1 -> t2+    g :: t3 ~ t1+This should be eta-reduced to++    f |> (sym g -> t2)++So we need to accumulate a coercion, pushing it inward (past+variable arguments only) thus:+   f (x |> co_arg) |> co  -->  (f |> (sym co_arg -> co)) x+   f (x:t)         |> co  -->  (f |> (t -> co)) x+   f @ a           |> co  -->  (f |> (forall a.co)) @ a+   f @ (g:t1~t2)   |> co  -->  (f |> (t1~t2 => co)) @ (g:t1~t2)+These are the equations for ok_arg.++Note [Eta reduction with casted function]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Since we are pushing a coercion inwards, it is easy to accommodate+    (\xy. (f x |> g) y)+    (\xy. (f x y) |> g)++See the `(Cast e co)` equation for `go` in `tryEtaReduce`.  The+eta-expander pushes those casts outwards, so you might think we won't+ever see a cast here, but if we have+  \xy. (f x y |> g)+we will call tryEtaReduce [x,y] (f x y |> g), and we'd like that to+work.  This happens in GHC.Core.Opt.Simplify.Utils.mkLam, where+eta-expansion may be turned off (by sm_eta_expand).++Note [Eta reduction based on evaluation context]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Note [Eta reduction soundness], criterion (S) allows us to eta-reduce+`g (\x y. e x y)` to `g e` when we know that `g` always calls its parameter with+at least 2 arguments. So how do we read that off `g`'s demand signature?++Let's take the simple example of #21261, where `g` (actually, `f`) is defined as+  g c = c 1 2 + c 3 4+Then this is how the pieces are put together:++  * Demand analysis infers `<SC(S,C(1,L))>` for `g`'s demand signature++  * When the Simplifier next simplifies the argument in `g (\x y. e x y)`, it+    looks up the *evaluation context* of the argument in the form of the+    sub-demand `C(S,C(1,L))` and stores it in the 'SimplCont'.+    (Why does it drop the outer evaluation cardinality of the demand, `S`?+    Because it's irrelevant! When we simplify an expression, we do so under the+    assumption that it is currently under evaluation.)+    This sub-demand literally says "Whenever this expression is evaluated, it+    is called with at least two arguments, potentially multiple times".++  * Then the simplifier takes apart the lambda and simplifies the lambda group+    and then calls 'tryEtaReduce' when rebuilding the lambda, passing the+    evaluation context `C(S,C(1,L))` along. Then we simply peel off 2 call+    sub-demands `Cn` and see whether all of the n's (here: `S=C_1N` and+    `1=C_11`) were strict. And strict they are! Thus, it will eta-reduce+    `\x y. e x y` to `e`.++Note [Eta reduction in recursive RHSs]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider the following recursive function:+  f = \x. ....g (\y. f y)....+The recursive call of f in its own RHS seems like a fine opportunity for+eta-reduction because f has arity 1. And often it is!++Alas, that is unsound in general if the eta-reduction happens in a tail context.+Making the arity visible in the RHS allows us to eta-reduce+  f = \x -> f x+to+  f = f+which means we optimise terminating programs like (f `seq` ()) into+non-terminating ones. Nor is this problem just for tail calls.  Consider+  f = id (\x -> f x)+where we have (for some reason) not yet inlined `id`.  We must not eta-reduce to+  f = id f+because that will then simplify to `f = f` as before.++An immediate idea might be to look at whether the called function is a local+loopbreaker and refrain from eta-expanding. But that doesn't work for mutually+recursive function like in #21652:+  f = g+  g* x = f x+Here, g* is the loopbreaker but f isn't.++What can we do?++Fix 1: Zap `idArity` when analysing recursive RHSs and re-attach the info when+    entering the let body.+    Has the disadvantage that other transformations which make use of arity+    (such as dropping of `seq`s when arity > 0) will no longer work in the RHS.+    Plus it requires non-trivial refactorings to both the simple optimiser (in+    the way `subst_opt_bndr` is used) as well as the Simplifier (in the way+    `simplRecBndrs` and `simplRecJoinBndrs` is used), modifying the SimplEnv's+    substitution twice in the process. A very complicated stop-gap.++Fix 2: Pass the set of enclosing recursive binders to `tryEtaReduce`; these are+    the ones we should not eta-reduce. All call-site must maintain this set.+    Example:+      rec { f1 = ....rec { g = ... (\x. g x)...(\y. f2 y)... }...+          ; f2 = ...f1... }+    when eta-reducing those inner lambdas, we need to know that we are in the+    rec group for {f1, f2, g}.+    This is very much like the solution in Note [Speculative evaluation] in+    GHC.CoreToStg.Prep.+    It is a bit tiresome to maintain this info, because it means another field+    in SimplEnv and SimpleOptEnv.++We implement Fix (2) because of it isn't as complicated to maintain as (1).+Plus, it is the correct fix to begin with. After all, the arity is correct,+but doing the transformation isn't. The moving parts are:+  * A field `scRecIds` in `SimplEnv` tracks the enclosing recursive binders+  * We extend the `scRecIds` set in `GHC.Core.Opt.Simplify.simplRecBind`+  * We consult the set in `is_eta_reduction_sound` in `tryEtaReduce`+The situation is very similar to Note [Speculative evaluation] which has the+same fix.+-}++-- | `tryEtaReduce [x,y,z] e sd` returns `Just e'` if `\x y z -> e` is evaluated+-- according to `sd` and can soundly and gainfully be eta-reduced to `e'`.+-- See Note [Eta reduction soundness]+-- and Note [Eta reduction makes sense] when that is the case.+tryEtaReduce :: UnVarSet -> [Var] -> CoreExpr -> SubDemand -> Maybe CoreExpr+-- Return an expression equal to (\bndrs. body)+tryEtaReduce rec_ids bndrs body eval_sd+  = go (reverse bndrs) body (mkRepReflCo (exprType body))+  where+    incoming_arity = count isId bndrs -- See Note [Eta reduction makes sense], point (2)++    go :: [Var]            -- Binders, innermost first, types [a3,a2,a1]+       -> CoreExpr         -- Of type tr+       -> Coercion         -- Of type tr ~ ts+       -> Maybe CoreExpr   -- Of type a1 -> a2 -> a3 -> ts+    -- See Note [Eta reduction with casted arguments]+    -- for why we have an accumulating coercion+    --+    -- Invariant: (go bs body co) returns an expression+    --            equivalent to (\(reverse bs). (body |> co))++    -- See Note [Eta reduction with casted function]+    go bs (Cast e co1) co2+      = go bs e (co1 `mkTransCo` co2)++    go bs (Tick t e) co+      | tickishFloatable t+      = fmap (Tick t) $ go bs e co+      -- Float app ticks: \x -> Tick t (e x) ==> Tick t e++    go (b : bs) (App fun arg) co+      | Just (co', ticks) <- ok_arg b arg co (exprType fun)+      = fmap (flip (foldr mkTick) ticks) $ go bs fun co'+            -- Float arg ticks: \x -> e (Tick t x) ==> Tick t e++    go remaining_bndrs fun co+      | all isTyVar remaining_bndrs+            -- If all the remaining_bnrs are tyvars, then the etad_exp+            --    will be trivial, which is what we want.+            -- e.g. We might have  /\a \b. f [a] b, and we want to+            --      eta-reduce to  /\a. f [a]+            -- We don't want to give up on this one: see #20040+            -- See Note [Eta reduction makes sense], point (1)+      , remaining_bndrs `ltLength` bndrs+            -- Only reply Just if /something/ has happened+      , ok_fun fun+      , let used_vars     = exprFreeVars fun `unionVarSet` tyCoVarsOfCo co+            reduced_bndrs = mkVarSet (dropList remaining_bndrs bndrs)+            -- reduced_bndrs are the ones we are eta-reducing away+      , used_vars `disjointVarSet` reduced_bndrs+          -- Check for any of the reduced_bndrs (about to be dropped)+          -- free in the result, including the accumulated coercion.+          -- See Note [Eta reduction makes sense], intro and point (1)+          -- NB: don't compute used_vars from exprFreeVars (mkCast fun co)+          --     because the latter may be ill formed if the guard fails (#21801)+      = Just (mkLams (reverse remaining_bndrs) (mkCast fun co))++    go _remaining_bndrs _fun  _  = -- pprTrace "tER fail" (ppr _fun $$ ppr _remaining_bndrs) $+                                   Nothing++    ---------------+    -- See Note [Eta reduction makes sense], point (1)+    ok_fun (App fun (Type {})) = ok_fun fun+    ok_fun (Cast fun _)        = ok_fun fun+    ok_fun (Tick _ expr)       = ok_fun expr+    ok_fun (Var fun_id)        = is_eta_reduction_sound fun_id+    ok_fun _fun                = False++    ---------------+    -- See Note [Eta reduction soundness], this is THE place to check soundness!+    is_eta_reduction_sound fun+      | fun `elemUnVarSet` rec_ids          -- Criterion (R)+      = False -- Don't eta-reduce in fun in its own recursive RHSs++      | cantEtaReduceFun fun                -- Criteria (J), (W), (B)+      = False -- Function can't be eta reduced to arity 0+              -- without violating invariants of Core and GHC++      | otherwise+      = -- Check that eta-reduction won't make the program stricter...+        fun_arity fun >= incoming_arity          -- Criterion (A) and (E)+        || all_calls_with_arity incoming_arity   -- Criterion (S)+        || all ok_lam bndrs                      -- Criterion (T)++    all_calls_with_arity n = isStrict (fst $ peelManyCalls n eval_sd)+       -- See Note [Eta reduction based on evaluation context]++    ---------------+    fun_arity fun+       | arity > 0                           = arity+       | isEvaldUnfolding (idUnfolding fun)  = 1+           -- See Note [Eta reduction soundness], criterion (E)+       | otherwise                           = 0+       where+         arity = idArity fun++    ---------------+    ok_lam v = isTyVar v || isEvId v+    -- See Note [Eta reduction makes sense], point (2)++    ---------------+    ok_arg :: Var              -- Of type bndr_t+           -> CoreExpr         -- Of type arg_t+           -> Coercion         -- Of kind (t1~t2)+           -> Type             -- Type (arg_t -> t1) of the function+                               --      to which the argument is supplied+           -> Maybe (Coercion  -- Of type (arg_t -> t1 ~  bndr_t -> t2)+                               --   (and similarly for tyvars, coercion args)+                    , [CoreTickish])+    -- See Note [Eta reduction with casted arguments]+    ok_arg bndr (Type arg_ty) co fun_ty+       | Just tv <- getTyVar_maybe arg_ty+       , bndr == tv  = case splitForAllForAllTyBinder_maybe fun_ty of+           Just (Bndr _ vis, _) -> Just (fco, [])+             where !fco = mkForAllCo tv vis coreTyLamForAllTyFlag kco co+                   -- The lambda we are eta-reducing always has visibility+                   -- 'coreTyLamForAllTyFlag' which may or may not match+                   -- the visibility on the inner function (#24014)+                   kco = mkNomReflCo (tyVarKind tv)+           Nothing -> pprPanic "tryEtaReduce: type arg to non-forall type"+                               (text "fun:" <+> ppr bndr+                                $$ text "arg:" <+> ppr arg_ty+                                $$ text "fun_ty:" <+> ppr fun_ty)+    ok_arg bndr (Var v) co fun_ty+       | bndr == v+       , let mult = idMult bndr+       , Just (_af, fun_mult, _, _) <- splitFunTy_maybe fun_ty+       , mult `eqType` fun_mult -- There is no change in multiplicity, otherwise we must abort+       = Just (mkFunResCo Representational bndr co, [])+    ok_arg bndr (Cast e co_arg) co fun_ty+       | (ticks, Var v) <- stripTicksTop tickishFloatable e+       , Just (_, fun_mult, _, _) <- splitFunTy_maybe fun_ty+       , bndr == v+       , fun_mult `eqType` idMult bndr+       = Just (mkFunCoNoFTF Representational (multToCo fun_mult) (mkSymCo co_arg) co, ticks)+       -- The simplifier combines multiple casts into one,+       -- so we can have a simple-minded pattern match here+    ok_arg bndr (Tick t arg) co fun_ty+       | tickishFloatable t, Just (co', ticks) <- ok_arg bndr arg co fun_ty+       = Just (co', t:ticks)++    ok_arg _ _ _ _ = Nothing++-- | Can we eta-reduce the given function+-- See Note [Eta reduction soundness], criteria (B), (J), and (W).+cantEtaReduceFun :: Id -> Bool+cantEtaReduceFun fun+  =    hasNoBinding fun -- (B)+       -- Don't undersaturate functions with no binding.++    ||  isJoinId fun    -- (J)+       -- Don't undersaturate join points.+       -- See Note [Invariants on join points] in GHC.Core, and #20599++    || (isJust (idCbvMarks_maybe fun)) -- (W)+       -- Don't undersaturate StrictWorkerIds.+       -- See Note [CBV Function Ids] in GHC.Types.Id.Info.+++{- *********************************************************************+*                                                                      *+              The "push rules"+*                                                                      *+************************************************************************++Here we implement the "push rules" from FC papers:++* The push-argument rules, where we can move a coercion past an argument.+  We have+      (fun |> co) arg+  and we want to transform it to+    (fun arg') |> co'+  for some suitable co' and transformed arg'.++* The PushK rule for data constructors.  We have+       (K e1 .. en) |> co+  and we want to transform to+       (K e1' .. en')+  by pushing the coercion into the arguments+-}++pushCoArgs :: CoercionR -> [CoreArg] -> Maybe ([CoreArg], MCoercion)+pushCoArgs co []         = return ([], MCo co)+pushCoArgs co (arg:args) = do { (arg',  m_co1) <- pushCoArg  co  arg+                              ; case m_co1 of+                                  MCo co1 -> do { (args', m_co2) <- pushCoArgs co1 args+                                                 ; return (arg':args', m_co2) }+                                  MRefl  -> return (arg':args, MRefl) }++pushMCoArg :: MCoercionR -> CoreArg -> Maybe (CoreArg, MCoercion)+pushMCoArg MRefl    arg = Just (arg, MRefl)+pushMCoArg (MCo co) arg = pushCoArg co arg++pushCoArg :: CoercionR -> CoreArg -> Maybe (CoreArg, MCoercion)+-- We have (fun |> co) arg, and we want to transform it to+--         (fun arg) |> co+-- This may fail, e.g. if (fun :: N) where N is a newtype+-- C.f. simplCast in GHC.Core.Opt.Simplify+-- 'co' is always Representational+pushCoArg co arg+  | Type ty <- arg+  = do { (ty', m_co') <- pushCoTyArg co ty+       ; return (Type ty', m_co') }+  | otherwise+  = do { (arg_mco, m_co') <- pushCoValArg co+       ; let arg_mco' = checkReflexiveMCo arg_mco+             -- checkReflexiveMCo: see Note [Check for reflexive casts in eta expansion]+             -- The coercion is very often (arg_co -> res_co), but without+             -- the argument coercion actually being ReflCo+       ; return (arg `mkCastMCo` arg_mco', m_co') }++pushCoTyArg :: CoercionR -> Type -> Maybe (Type, MCoercionR)+-- We have (fun |> co) @ty+-- Push the coercion through to return+--         (fun @ty') |> co'+-- 'co' is always Representational+-- If the returned coercion is Nothing, then it would have been reflexive;+-- it's faster not to compute it, though.+pushCoTyArg co ty+  -- The following is inefficient - don't do `eqType` here, the coercion+  -- optimizer will take care of it. See #14737.+  -- -- | tyL `eqType` tyR+  -- -- = Just (ty, Nothing)++  | isReflCo co+  = Just (ty, MRefl)++  | isForAllTy_ty tyL+  = assertPpr (isForAllTy_ty tyR) (ppr co $$ ppr ty) $+    Just (ty `mkCastTy` co1, MCo co2)++  | otherwise+  = Nothing+  where+    Pair tyL tyR = coercionKind co+       -- co :: tyL ~R tyR+       -- tyL = forall (a1 :: k1). ty1+       -- tyR = forall (a2 :: k2). ty2++    co1 = mkSymCo (mkSelCo SelForAll co)+       -- co1 :: k2 ~N k1+       -- Note that SelCo extracts a Nominal equality between the+       -- kinds of the types related by a coercion between forall-types.+       -- See the SelCo case in GHC.Core.Lint.++    co2 = mkInstCo co (mkGReflLeftCo Nominal ty co1)+        -- co2 :: ty1[ (ty|>co1)/a1 ] ~R ty2[ ty/a2 ]+        -- Arg of mkInstCo is always nominal, hence Nominal++-- | If @pushCoValArg co = Just (co_arg, co_res)@, then+--+-- > (\x.body) |> co  =  (\y. let { x = y |> co_arg } in body) |> co_res)+--+-- or, equivalently+--+-- > (fun |> co) arg  =  (fun (arg |> co_arg)) |> co_res+--+-- If the LHS is well-typed, then so is the RHS. In particular, the argument+-- @arg |> co_arg@ is guaranteed to have a fixed 'RuntimeRep', in the sense of+-- Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete.+pushCoValArg :: CoercionR -> Maybe (MCoercionR, MCoercionR)+pushCoValArg co+  -- The following is inefficient - don't do `eqType` here, the coercion+  -- optimizer will take care of it. See #14737.+  -- -- | tyL `eqType` tyR+  -- -- = Just (mkRepReflCo arg, Nothing)++  | isReflCo co+  = Just (MRefl, MRefl)++  | isFunTy tyL+  , (_, co1, co2) <- decomposeFunCo co+      -- If   co  :: (tyL1 -> tyL2) ~ (tyR1 -> tyR2)+      -- then co1 :: tyL1 ~ tyR1+      --      co2 :: tyL2 ~ tyR2++  , typeHasFixedRuntimeRep new_arg_ty+    -- We can't push the coercion inside if it would give rise to+    -- a representation-polymorphic argument.++  = assertPpr (isFunTy tyL && isFunTy tyR)+     (vcat [ text "co:" <+> ppr co+           , text "old_arg_ty:" <+> ppr old_arg_ty+           , text "new_arg_ty:" <+> ppr new_arg_ty ]) $+    Just (coToMCo (mkSymCo co1), coToMCo co2)+    -- Critically, coToMCo to checks for ReflCo; the whole coercion may not+    -- be reflexive, but either of its components might be+    -- We could use isReflexiveCo, but it's not clear if the benefit+    -- is worth the cost, and it makes no difference in #18223++  | otherwise+  = Nothing+  where+    old_arg_ty = funArgTy tyR+    new_arg_ty = funArgTy tyL+    Pair tyL tyR = coercionKind co++pushCoercionIntoLambda+    :: HasDebugCallStack => InScopeSet -> Var -> CoreExpr -> CoercionR -> Maybe (Var, CoreExpr)+-- This implements the Push rule from the paper on coercions+--    (\x. e) |> co+-- ===>+--    (\x'. e |> co')+pushCoercionIntoLambda in_scope x e co+    | assert (not (isTyVar x) && not (isCoVar x)) True+    , Pair s1s2 t1t2 <- coercionKind co+    , Just {}              <- splitFunTy_maybe s1s2+    , Just (_, w1, t1,_t2) <- splitFunTy_maybe t1t2+    , (_, co1, co2)  <- decomposeFunCo co+    , typeHasFixedRuntimeRep t1+      -- We can't push the coercion into the lambda if it would create+      -- a representation-polymorphic binder.+    = let+          -- Should we optimize the coercions here?+          -- Otherwise they might not match too well+          x' = x `setIdType` t1 `setIdMult` w1+          in_scope' = in_scope `extendInScopeSet` x'+          subst = extendIdSubst (mkEmptySubst in_scope')+                                x+                                (mkCast (Var x') (mkSymCo co1))+            -- We substitute x' for x, except we need to preserve types.+            -- The types are as follows:+            --   x :: s1,  x' :: t1,  co1 :: s1 ~# t1,+            -- so we extend the substitution with x |-> (x' |> sym co1).+      in Just (x', substExpr subst e `mkCast` co2)+    | otherwise+    = Nothing++pushCoDataCon :: DataCon -> [CoreExpr] -> MCoercionR+              -> Maybe (DataCon+                       , [Type]      -- Universal type args+                       , [CoreExpr]) -- All other args incl existentials+-- Implement the KPush reduction rule as described in "Down with kinds"+-- The transformation applies iff we have+--      (C e1 ... en) `cast` co+-- where co :: (T t1 .. tn) ~ (T s1 .. sn)+-- The left-hand one must be a T, because exprIsConApp returned True+-- but the right-hand one might not be.  (Though it usually will.)+pushCoDataCon dc dc_args MRefl    = Just $! (push_dc_refl dc dc_args)+pushCoDataCon dc dc_args (MCo co) = push_dc_gen  dc dc_args co (coercionKind co)++push_dc_refl :: DataCon -> [CoreExpr] -> (DataCon, [Type], [CoreExpr])+push_dc_refl dc dc_args+  = (dc, map exprToType univ_ty_args, rest_args)+  where+    !(univ_ty_args, rest_args) = splitAtList (dataConUnivTyVars dc) dc_args++push_dc_gen :: DataCon -> [CoreExpr] -> CoercionR -> Pair Type+            -> Maybe (DataCon, [Type], [CoreExpr])+push_dc_gen dc dc_args co (Pair from_ty to_ty)+  | from_ty `eqType` to_ty  -- try cheap test first+  = Just $! (push_dc_refl dc dc_args)++  | Just (to_tc, to_tc_arg_tys) <- splitTyConApp_maybe to_ty+  , to_tc == dataConTyCon dc+        -- These two tests can fail; we might see+        --      (C x y) `cast` (g :: T a ~ S [a]),+        -- where S is a type function.  In fact, exprIsConApp+        -- will probably not be called in such circumstances,+        -- but there's nothing wrong with it+  = Just (push_data_con to_tc to_tc_arg_tys dc dc_args co Representational)++  | otherwise+  = Nothing+++push_data_con :: TyCon -> [Type] -> DataCon -> [CoreExpr]+              -> CoercionR -> Role                  -- Coercion and its role+              -> (DataCon, [Type], [CoreExpr])+push_data_con to_tc to_tc_arg_tys dc dc_args co role+  = assertPpr (eqType from_ty dc_app_ty)     dump_doc $+    assertPpr (equalLength val_args arg_tys) dump_doc $+    assertPpr (role == coercionRole co)      dump_doc $+    assertPpr (isInjectiveTyCon to_tc role)  dump_doc $+    -- isInjectiveTyCon: see (UCM9) in Note [Unary class magic]+    --                   in GHC.Core.TyCon+    (dc, to_tc_arg_tys, to_ex_args ++ new_val_args)+  where+    Pair from_ty to_ty = coercionKind co+    tc_arity       = tyConArity to_tc+    dc_univ_tyvars = dataConUnivTyVars dc+    dc_ex_tcvars   = dataConExTyCoVars dc+    arg_tys        = dataConRepArgTys dc++    dc_app_ty = mkTyConApp to_tc (map exprToType $ takeList dc_univ_tyvars dc_args)++    non_univ_args  = dropList dc_univ_tyvars dc_args+    (ex_args, val_args) = splitAtList dc_ex_tcvars non_univ_args++    -- Make the "Psi" from the paper+    omegas = decomposeCo tc_arity co (tyConRolesX role to_tc)+    (psi_subst, to_ex_arg_tys)+      = liftCoSubstWithEx dc_univ_tyvars+                          omegas+                          dc_ex_tcvars+                          (map exprToType ex_args)++      -- Cast the value arguments (which include dictionaries)+    new_val_args = zipWith cast_arg (map scaledThing arg_tys) val_args+    cast_arg arg_ty arg = mkCast arg (psi_subst arg_ty)++    to_ex_args = map Type to_ex_arg_tys++    dump_doc = vcat [ppr dc, ppr dc_univ_tyvars, ppr dc_ex_tcvars+                    , ppr arg_tys, ppr dc_args+                    , ppr ex_args, ppr val_args, ppr co, ppr from_ty, ppr to_ty, ppr to_tc+                    , ppr $ mkTyConApp to_tc (map exprToType $ takeList dc_univ_tyvars dc_args) ]++collectBindersPushingCo :: CoreExpr -> ([Var], CoreExpr)+-- Collect lambda binders, pushing coercions inside if possible+-- E.g.   (\x.e) |> g         g :: <Int> -> blah+--        = (\x. e |> SelCo (SelFun SelRes) g)+--+-- That is,+--+-- collectBindersPushingCo ((\x.e) |> g) === ([x], e |> SelCo (SelFun SelRes) g)+collectBindersPushingCo e+  = go [] e+  where+    -- Peel off lambdas until we hit a cast.+    go :: [Var] -> CoreExpr -> ([Var], CoreExpr)+    -- The accumulator is in reverse order+    go bs (Lam b e)   = go (b:bs) e+    go bs (Cast e co) = go_c bs e co+    go bs e           = (reverse bs, e)++    -- We are in a cast; peel off casts until we hit a lambda.+    go_c :: [Var] -> CoreExpr -> CoercionR -> ([Var], CoreExpr)+    -- (go_c bs e c) is same as (go bs e (e |> c))+    go_c bs (Cast e co1) co2 = go_c bs e (co1 `mkTransCo` co2)+    go_c bs (Lam b e)    co  = go_lam bs b e co+    go_c bs e            co  = (reverse bs, mkCast e co)++    -- We are in a lambda under a cast; peel off lambdas and build a+    -- new coercion for the body.+    go_lam :: [Var] -> Var -> CoreExpr -> CoercionR -> ([Var], CoreExpr)+    -- (go_lam bs b e c) is same as (go_c bs (\b.e) c)+    go_lam bs b e co+      | isTyVar b+      , let Pair tyL tyR = coercionKind co+      , assert (isForAllTy_ty tyL) $+        isForAllTy_ty tyR+      , isReflCo (mkSelCo SelForAll co)  -- See Note [collectBindersPushingCo]+      = go_c (b:bs) e (mkInstCo co (mkNomReflCo (mkTyVarTy b)))++      | isCoVar b+      , let Pair tyL tyR = coercionKind co+      , assert (isForAllTy_co tyL) $+        isForAllTy_co tyR+      , isReflCo (mkSelCo SelForAll co)  -- See Note [collectBindersPushingCo]+      , let cov = mkCoVarCo b+      = go_c (b:bs) e (mkInstCo co (mkNomReflCo (mkCoercionTy cov)))++      | isId b+      , let Pair tyL tyR = coercionKind co+      , assert (isFunTy tyL) $ isFunTy tyR+      , (co_mult, co_arg, co_res) <- decomposeFunCo co+      , isReflCo co_mult -- See Note [collectBindersPushingCo]+      , isReflCo co_arg  -- See Note [collectBindersPushingCo]+      = go_c (b:bs) e co_res++      | otherwise = (reverse bs, mkCast (Lam b e) co)++{- Note [collectBindersPushingCo]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We just look for coercions of form+   <type> % w -> blah+(and similarly for foralls) to keep this function simple.  We could do+more elaborate stuff, but it'd involve substitution etc.+-}++{- *********************************************************************+*                                                                      *+                Join points+*                                                                      *+********************************************************************* -}++-------------------+-- | Split an expression into the given number of binders and a body,+-- eta-expanding if necessary. Counts value *and* type binders.+etaExpandToJoinPoint :: JoinArity -> CoreExpr -> ([CoreBndr], CoreExpr)+etaExpandToJoinPoint join_arity expr+  = go join_arity [] expr+  where+    go 0 rev_bs e         = (reverse rev_bs, e)+    go n rev_bs (Lam b e) = go (n-1) (b : rev_bs) e+    go n rev_bs e         = case etaBodyForJoinPoint n e of+                              (bs, e') -> (reverse rev_bs ++ bs, e')++etaExpandToJoinPointRule :: JoinArity -> CoreRule -> CoreRule+etaExpandToJoinPointRule _ rule@(BuiltinRule {})+  = warnPprTrace True "Can't eta-expand built-in rule:" (ppr rule)+      -- How did a local binding get a built-in rule anyway? Probably a plugin.+    rule+etaExpandToJoinPointRule join_arity rule@(Rule { ru_bndrs = bndrs, ru_rhs = rhs+                                               , ru_args  = args })+  | need_args == 0+  = rule+  | need_args < 0+  = pprPanic "etaExpandToJoinPointRule" (ppr join_arity $$ ppr rule)+  | otherwise+  = rule { ru_bndrs = bndrs ++ new_bndrs+         , ru_args  = args ++ new_args+         , ru_rhs   = new_rhs }+  -- new_rhs really ought to be occ-analysed (see GHC.Core Note+  -- [OccInfo in unfoldings and rules]), but it makes a module loop to+  -- do so; it doesn't happen often; and it doesn't really matter if+  -- the outer binders have bogus occurrence info; and new_rhs won't+  -- have dead code if rhs didn't.++  where+    need_args = join_arity - length args+    (new_bndrs, new_rhs) = etaBodyForJoinPoint need_args rhs+    new_args = varsToCoreExprs new_bndrs++-- Adds as many binders as asked for; assumes expr is not a lambda+etaBodyForJoinPoint :: Int -> CoreExpr -> ([CoreBndr], CoreExpr)+etaBodyForJoinPoint need_args body+  = go need_args body_ty (mkEmptySubst in_scope) [] body+  where+    go 0 _  _     rev_bs e+      = (reverse rev_bs, e)+    go n ty subst rev_bs e+      | Just (tv, res_ty) <- splitForAllTyCoVar_maybe ty+      , let (subst', tv') = substVarBndr subst tv+      = go (n-1) res_ty subst' (tv' : rev_bs) (e `App` varToCoreExpr tv')+        -- The varToCoreExpr is important: `tv` might be a coercion variable++      | Just (_, mult, arg_ty, res_ty) <- splitFunTy_maybe ty+      , let (subst', b) = freshEtaId n subst (Scaled mult arg_ty)+      = go (n-1) res_ty subst' (b : rev_bs) (e `App` varToCoreExpr b)+        -- The varToCoreExpr is important: `b` might be a coercion variable++      | otherwise+      = pprPanic "etaBodyForJoinPoint" $ int need_args $$+                                         ppr body $$ ppr (exprType body)++    body_ty = exprType body+    in_scope = mkInScopeSet (exprFreeVars body `unionVarSet` tyCoVarsOfType body_ty)+    -- in_scope is a bit tricky.+    -- - We are wrapping `body` in some value lambdas, so must not shadow+    --   any free vars of `body`+    -- - We are wrapping `body` in some type lambdas, so must not shadow any+    --   tyvars in body_ty.  Example: body is just a variable+    --            (g :: forall (a::k). T k a -> Int)+    --   We must not shadown that `k` when adding the /\a. So treat the free vars+    --   of body_ty as in-scope.  Showed up in #23026.++--------------+freshEtaId :: Int -> Subst -> Scaled Type -> (Subst, Id)+-- Make a fresh Id, with specified type (after applying substitution)+-- It should be "fresh" in the sense that it's not in the in-scope set+-- of the TvSubstEnv; and it should itself then be added to the in-scope+-- set of the TvSubstEnv+--+-- The Int is just a reasonable starting point for generating a unique;+-- it does not necessarily have to be unique itself.+freshEtaId n subst ty+      = (subst', eta_id')+      where+        Scaled mult' ty' = Type.substScaledTyUnchecked subst ty+        eta_id' = uniqAway (substInScopeSet subst) $+                  mkSysLocalOrCoVar (fsLit "eta") (mkBuiltinUnique n) mult' ty'+                  -- "OrCoVar" since this can be used to eta-expand+                  -- coercion abstractions+        subst'  = extendSubstInScope subst eta_id'
GHC/Core/Opt/CSE.hs view
@@ -4,22 +4,13 @@ \section{Common subexpression} -} ---{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}- module GHC.Core.Opt.CSE (cseProgram, cseOneExpr) where  import GHC.Prelude  import GHC.Core.Subst-import GHC.Types.Var    ( Var )-import GHC.Types.Var.Env ( mkInScopeSet )-import GHC.Types.Id     ( Id, idType, idHasRules, zapStableUnfolding-                        , idInlineActivation, setInlineActivation-                        , zapIdOccInfo, zapIdUsageInfo, idInlinePragma-                        , isJoinId, isJoinId_maybe )+import GHC.Types.Var.Env ( mkInScopeSet, mkInScopeSetList )+import GHC.Types.Id import GHC.Core.Utils   ( mkAltExpr                         , exprIsTickedString                         , stripTicksE, stripTicksT, mkTicks )@@ -32,6 +23,7 @@ import GHC.Core.Map.Expr import GHC.Utils.Misc   ( filterOut, equalLength ) import GHC.Utils.Panic+import Data.Functor.Identity ( Identity (..) ) import Data.List        ( mapAccumL )  {-@@ -47,7 +39,7 @@ 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+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@@ -57,8 +49,8 @@ reverse mapping.  -Note [Shadowing]-~~~~~~~~~~~~~~~~+Note [Shadowing in CSE]+~~~~~~~~~~~~~~~~~~~~~~~ We have to be careful about shadowing. For example, consider         f = \x -> let y = x+x in@@ -144,7 +136,7 @@ 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 propate effects to the RULES. Finally, it+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. @@ -228,7 +220,7 @@   might replace <rhs> by 'bar', and then later be unable to see that it   really was <rhs>. -An except to the rule is when the INLINE pragma is not from the user, e.g. from+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. @@ -262,28 +254,32 @@ 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.+Wrinkles -Now consider-   foo = <expr>-   bar {-# Unf = Stable ... #-}-      = <expr>+* 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. -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.+* Consider+     foo = <expr>+     bar {-# Unf = Stable ... #-}+        = <expr>+  where the unfolding was added by strictness analysis, say.  Then+  CSE goes ahead, so we get+     bar = foo+  and probably use SUBSTITUTE that will make 'bar' dead.  But just+  possibly not -- see Note [Dealing with ticks].  In that case we might+  be left with+     bar = tick t1 (tick t2 foo)+  in which case we would really like to get rid of the stable unfolding+  (generated by the strictness analyser, say). +  Hence the zapStableUnfolding in cse_bind.  Not a big deal, and only+  makes a difference when ticks get into the picture.+ Note [Corner case for case expressions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Here is another reason that we do not use SUBSTITUTE for@@ -291,8 +287,8 @@    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.+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@@ -356,7 +352,7 @@  Note [Separate envs for let rhs and body] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Substituting occurances of the binder in the rhs with the+Substituting occurrences of the binder in the rhs with the  renamed binder is wrong for non-recursive bindings. Why? Consider this core. @@ -383,14 +379,21 @@ -}  cseProgram :: CoreProgram -> CoreProgram-cseProgram binds = snd (mapAccumL (cseBind TopLevel) emptyCSEnv binds)+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)       = addBinder env b+    (env1, b1)       = addNonRecBinder toplevel env b     (env2, (b2, e2)) = cse_bind toplevel env env1 (b,e) b1  cseBind toplevel env (Rec [(in_id, rhs)])@@ -408,7 +411,7 @@   = (extendCSRecEnv env1 out_id rhs'' id_expr', Rec [(zapped_id, rhs')])    where-    (env1, [out_id]) = addRecBinders env [in_id]+    (env1, Identity out_id) = addRecBinders toplevel env (Identity in_id)     rhs'  = cseExpr env1 rhs     rhs'' = stripTicksE tickishFloatable rhs'     ticks = stripTicksT tickishFloatable rhs'@@ -418,7 +421,7 @@ cseBind toplevel env (Rec pairs)   = (env2, Rec pairs')   where-    (env1, bndrs1) = addRecBinders env (map fst pairs)+    (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@@ -436,7 +439,7 @@       -- See Note [Take care with literal strings]   = (env_body', (out_id', in_rhs)) -  | Just arity <- isJoinId_maybe out_id+  | 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@@ -508,14 +511,17 @@ -- | Given a binder `let x = e`, this function -- determines whether we should add `e -> x` to the cs_map noCSE :: InId -> Bool-noCSE id =  not (isAlwaysActive (idInlineActivation id)) &&-            not (noUserInlineSpec (inlinePragmaSpec (idInlinePragma 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?]-+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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -632,7 +638,10 @@   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@@ -693,10 +702,11 @@ -- as a convenient entry point for users of the GHC API. cseOneExpr :: InExpr -> OutExpr cseOneExpr e = cseExpr env e-  where env = emptyCSEnv {cs_subst = mkEmptySubst (mkInScopeSet (exprFreeVars e)) }+  where+    env = emptyCSEnv (mkInScopeSet (exprFreeVars e))  cseExpr :: CSEnv -> InExpr -> OutExpr-cseExpr env (Type t)              = Type (substTy (csEnvSubst env) t)+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@@ -714,7 +724,7 @@   = Case scrut1 bndr3 ty' $     combineAlts (map cse_alt alts)   where-    ty' = substTy (csEnvSubst env) ty+    ty' = substTyUnchecked (csEnvSubst env) ty     (cse_done, scrut1) = try_for_cse env scrut      bndr1 = zapIdOccInfo bndr@@ -751,7 +761,7 @@   , Alt _ bndrs1 rhs1 <- alt1   , let filtered_alts = filterOut (identical_alt rhs1) rest_alts   , not (equalLength rest_alts filtered_alts)-  = assertPpr (null bndrs1) (ppr alts) $+  = assertPpr (all isDeadBinder bndrs1) (ppr alts) $     Alt DEFAULT [] rhs1 : filtered_alts    | otherwise@@ -759,14 +769,13 @@   where      find_bndr_free_alt :: [CoreAlt] -> (Maybe CoreAlt, [CoreAlt])-       -- The (Just alt) is a binder-free alt-       -- See Note [Combine case alts: awkward corner]+       -- The (Just alt) is an alt where all fields are dead     find_bndr_free_alt []       = (Nothing, [])     find_bndr_free_alt (alt@(Alt _ bndrs _) : alts)-      | null bndrs = (Just alt, alts)-      | otherwise  = case find_bndr_free_alt alts of-                       (mb_bf, alts) -> (mb_bf, alt: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@@ -810,7 +819,7 @@    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 alternatives usually+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.@@ -820,9 +829,9 @@  Note [Combine case alts: awkward corner] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We would really like to check isDeadBinder on the binders in the-alternative.  But alas, the simplifer zaps occ-info on binders in case-alternatives; see Note [Case alternative occ info] in GHC.Core.Opt.Simplify.+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@@ -830,14 +839,12 @@  * Another would be for CSE to return free vars as it goes. -* But the current solution is to find a nullary alternative (including-  the DEFAULT alt, if any). This will not catch-      case x of-        A y   -> blah-        B z p -> blah-  where no alternative is nullary or DEFAULT.  But the current-  solution is at least cheap.-+* 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.  ************************************************************************ *                                                                      *@@ -862,9 +869,11 @@             -- See Note [CSE for recursive bindings]        } -emptyCSEnv :: CSEnv-emptyCSEnv = CS { cs_map = emptyCoreMap, cs_rec_map = emptyCoreMap-                , cs_subst = emptySubst }+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@@ -897,7 +906,7 @@ 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] for more details.  You should call this whenever+-- 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')@@ -909,7 +918,19 @@                 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+addNonRecBinder :: TopLevelFlag -> CSEnv -> Var -> (CSEnv, Var)+-- Don't clone at top level+addNonRecBinder top_lvl cse v+  | isTopLevel top_lvl = (cse,                      v)+  | otherwise          = (cse { cs_subst = sub' }, v')+  where+    (sub', v') = substBndr (cs_subst cse) v++addRecBinders :: Traversable f => TopLevelFlag -> CSEnv -> f Id -> (CSEnv, f Id)+-- Don't clone at top level+addRecBinders top_lvl cse vs+  | isTopLevel top_lvl  = (cse,                     vs)+  | otherwise           = (cse { cs_subst = sub' }, vs')+  where+    (sub', vs') = substRecBndrs (cs_subst cse) vs+{-# INLINE addRecBinders #-}
GHC/Core/Opt/CallArity.hs view
@@ -2,7 +2,6 @@ -- Copyright (c) 2014 Joachim Breitner -- -{-# LANGUAGE BangPatterns #-}  module GHC.Core.Opt.CallArity     ( callArityAnalProgram@@ -24,6 +23,7 @@ import GHC.Utils.Misc  import Control.Arrow ( first, second )+import Data.List.NonEmpty ( NonEmpty (..) )   {-@@ -150,7 +150,7 @@    any useful co-call information.    Return (fv e)²  * Case alternatives alt₁,alt₂,...:-   Only one can be execuded, so+   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.@@ -277,7 +277,7 @@ Note [Analysis type signature] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The work-hourse of the analysis is the function `callArityAnal`, with the+The workhorse of the analysis is the function `callArityAnal`, with the following type:      type CallArityRes = (UnVarGraph, VarEnv Arity)@@ -377,15 +377,14 @@ 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 GHC.Core.Opt.Arity).+    [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.@@ -544,7 +543,7 @@ -- Which bindings should we look at? -- See Note [Which variables are interesting] isInteresting :: Var -> Bool-isInteresting v = not $ null (typeArity (idType v))+isInteresting v = typeArity (idType v) > 0  interestingBinds :: CoreBind -> [Var] interestingBinds = filter isInteresting . bindersOf@@ -698,9 +697,9 @@  -- See Note [Trimming arity] trimArity :: Id -> Arity -> Arity-trimArity v a = minimum [a, max_arity_by_type, max_arity_by_strsig]+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_type = typeArity (idType v)     max_arity_by_strsig         | isDeadEndDiv result_info = length demands         | otherwise = a@@ -729,7 +728,7 @@ resDel v (!g, !ae) = (g `delNode` v, ae `delVarEnv` v)  domRes :: CallArityRes -> UnVarSet-domRes (_, ae) = varEnvDom ae+domRes (_, ae) = varEnvDomain ae  -- In the result, find out the minimum arity and whether the variable is called -- at most once.
GHC/Core/Opt/CallerCC.hs view
@@ -15,24 +15,19 @@     , parseCallerCcFilter     ) where -import Data.Word (Word8) import Data.Maybe  import Control.Applicative import GHC.Utils.Monad.State.Strict-import Data.Either import Control.Monad-import qualified Text.ParserCombinators.ReadP as P  import GHC.Prelude import GHC.Utils.Outputable as Outputable-import GHC.Driver.Session-import GHC.Driver.Ppr+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.Name import GHC.Unit.Module.ModGuts import GHC.Types.SrcLoc import GHC.Types.Var@@ -40,10 +35,9 @@ import GHC.Data.FastString import GHC.Core import GHC.Core.Opt.Monad-import GHC.Utils.Panic-import qualified GHC.Utils.Binary as B-import Data.Char+import GHC.Core.Opt.CallerCC.Types + addCallerCostCentres :: ModGuts -> CoreM ModGuts addCallerCostCentres guts = do   dflags <- getDynFlags@@ -52,7 +46,7 @@       env = Env         { thisModule = mg_module guts         , ccState = newCostCentreState-        , dflags = dflags+        , countEntries = gopt Opt_ProfCountEntries dflags         , revParents = []         , filters = filters         }@@ -78,13 +72,13 @@           hcat (punctuate dot (map ppr (parents env))) <> parens (text "calling:" <> ppr v)          ccName :: CcName-        ccName = mkFastString $ showSDoc (dflags env) nameDoc+        ccName = mkFastString $ renderWithContext defaultSDocContext nameDoc     ccIdx <- getCCIndex' ccName-    let count = gopt Opt_ProfCountEntries (dflags env)+    let count = countEntries env         span = case revParents env of           top:_ -> nameSrcSpan $ varName top           _     -> noSrcSpan-        cc = NormalCC (ExprCC ccIdx) ccName (thisModule env) span+        cc = NormalCC (mkExprCCFlavour ccIdx) ccName (thisModule env) span         tick :: CoreTickish         tick = ProfNote cc count True     pure $ Tick tick e@@ -109,7 +103,7 @@  data Env = Env   { thisModule  :: Module-  , dflags      :: DynFlags+  , countEntries :: !Bool   , ccState     :: CostCentreState   , revParents  :: [Id]   , filters     :: [CallerCcFilter]@@ -138,91 +132,4 @@             Nothing -> True         checkFunc =             occNameMatches (ccfFuncName ccf) (getOccName i)--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 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 = pattern-  where-    pattern = star P.<++ wildcard P.<++ char P.<++ end-    star = PChar '*' <$ P.string "\\*" <*> pattern-    wildcard = do-      void $ P.char '*'-      PWildcard <$> pattern-    char = PChar <$> P.get <*> pattern-    end = PEnd <$ P.eof--data CallerCcFilter-    = CallerCcFilter { ccfModuleName  :: Maybe ModuleName-                     , ccfFuncName    :: NamePattern-                     }--instance Outputable CallerCcFilter where-  ppr ccf =-    maybe (char '*') ppr (ccfModuleName ccf)-    <> char '.'-    <> ppr (ccfFuncName ccf)--instance B.Binary CallerCcFilter where-  get bh = CallerCcFilter <$> B.get bh <*> B.get bh-  put_ bh (CallerCcFilter x y) = B.put_ bh x >> B.put_ bh y--parseCallerCcFilter :: String -> Either String CallerCcFilter-parseCallerCcFilter inp =-    case P.readP_to_S parseCallerCcFilter' inp of-      ((result, ""):_) -> Right result-      _ -> Left $ "parse error on " ++ inp--parseCallerCcFilter' :: Parser CallerCcFilter-parseCallerCcFilter' =-  CallerCcFilter-    <$> moduleFilter-    <*  P.char '.'-    <*> parseNamePattern-  where-    moduleFilter :: Parser (Maybe ModuleName)-    moduleFilter =-      (Just . mkModuleName <$> moduleName)-      <|>-      (Nothing <$ P.char '*')--    moduleName :: Parser String-    moduleName = do-      c <- P.satisfy isUpper-      cs <- P.munch1 (\c -> isUpper c || isLower c || isDigit c || c == '_')-      rest <- optional $ P.char '.' >> fmap ('.':) moduleName-      return $ c : (cs ++ fromMaybe "" rest)
− GHC/Core/Opt/CallerCC.hs-boot 
@@ -1,8 +0,0 @@-module GHC.Core.Opt.CallerCC where--import GHC.Prelude---- Necessary due to import in GHC.Driver.Session.-data CallerCcFilter--parseCallerCcFilter :: String -> Either String CallerCcFilter
+ GHC/Core/Opt/CallerCC/Types.hs view
@@ -0,0 +1,122 @@+module GHC.Core.Opt.CallerCC.Types ( NamePattern(..)+                                   , CallerCcFilter(..)+                                   , occNameMatches+                                   , parseCallerCcFilter+                                   , parseNamePattern+                                   ) where++import Data.Word (Word8)+import Data.Maybe++import Control.Applicative+import Data.Either+import Control.Monad+import qualified Text.ParserCombinators.ReadP as P++import GHC.Prelude+import GHC.Utils.Outputable as Outputable+import GHC.Types.Name hiding (varName)+import GHC.Utils.Panic+import qualified GHC.Utils.Binary as B+import Data.Char+import Control.DeepSeq++import Language.Haskell.Syntax.Module.Name+++data NamePattern+    = PChar Char NamePattern+    | PWildcard NamePattern+    | PEnd++instance Outputable NamePattern where+  ppr (PChar c rest) = char c <> ppr rest+  ppr (PWildcard rest) = char '*' <> ppr rest+  ppr PEnd = Outputable.empty++instance NFData NamePattern where+  rnf (PChar c n) = rnf c `seq` rnf n+  rnf (PWildcard np) = rnf np+  rnf PEnd = ()++instance B.Binary NamePattern where+  get bh = do+    tag <- B.get bh+    case tag :: Word8 of+      0 -> PChar <$> B.get bh <*> B.get bh+      1 -> PWildcard <$> B.get bh+      2 -> pure PEnd+      _ -> panic "Binary(NamePattern): Invalid tag"+  put_ bh (PChar x y) = B.put_ bh (0 :: Word8) >> B.put_ bh x >> B.put_ bh y+  put_ bh (PWildcard x) = B.put_ bh (1 :: Word8) >> B.put_ bh x+  put_ bh PEnd = B.put_ bh (2 :: Word8)++occNameMatches :: NamePattern -> OccName -> Bool+occNameMatches pat = go pat . occNameString+  where+    go :: NamePattern -> String -> Bool+    go PEnd "" = True+    go (PChar c rest) (d:s)+      = d == c && go rest s+    go (PWildcard rest) s+      = go rest s || go (PWildcard rest) (tail s)+    go _ _  = False++++type Parser = P.ReadP++parseNamePattern :: Parser NamePattern+parseNamePattern = namePattern+  where+    namePattern = star P.<++ wildcard P.<++ char P.<++ end+    star = PChar '*' <$ P.string "\\*" <*> namePattern+    wildcard = do+      void $ P.char '*'+      PWildcard <$> namePattern+    char = PChar <$> P.get <*> namePattern+    end = PEnd <$ P.eof++data CallerCcFilter+    = CallerCcFilter { ccfModuleName  :: Maybe ModuleName+                     , ccfFuncName    :: NamePattern+                     }++instance NFData CallerCcFilter where+  rnf (CallerCcFilter mn n) = rnf mn `seq` rnf n++instance Outputable CallerCcFilter where+  ppr ccf =+    maybe (char '*') ppr (ccfModuleName ccf)+    <> char '.'+    <> ppr (ccfFuncName ccf)++instance B.Binary CallerCcFilter where+  get bh = CallerCcFilter <$> B.get bh <*> B.get bh+  put_ bh (CallerCcFilter x y) = B.put_ bh x >> B.put_ bh y++parseCallerCcFilter :: String -> Either String CallerCcFilter+parseCallerCcFilter inp =+    case P.readP_to_S parseCallerCcFilter' inp of+      ((result, ""):_) -> Right result+      _ -> Left $ "parse error on " ++ inp++parseCallerCcFilter' :: Parser CallerCcFilter+parseCallerCcFilter' =+  CallerCcFilter+    <$> moduleFilter+    <*  P.char '.'+    <*> parseNamePattern+  where+    moduleFilter :: Parser (Maybe ModuleName)+    moduleFilter =+      (Just . mkModuleName <$> moduleName)+      <|>+      (Nothing <$ P.char '*')++    moduleName :: Parser String+    moduleName = do+      c <- P.satisfy isUpper+      cs <- P.munch1 (\c -> isUpper c || isLower c || isDigit c || c == '_')+      rest <- optional $ P.char '.' >> fmap ('.':) moduleName+      return $ c : (cs ++ fromMaybe "" rest)
GHC/Core/Opt/ConstantFold.hs view
@@ -20,21 +20,23 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-} -{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE -Wno-incomplete-uni-patterns #-}+{-# 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 ( voidPrimId )+import GHC.Types.Id.Make ( unboxedUnitExpr ) import GHC.Types.Id import GHC.Types.Literal import GHC.Types.Name.Occurrence ( occNameFS )@@ -46,14 +48,15 @@ import GHC.Core.Make import GHC.Core.SimpleOpt (  exprIsConApp_maybe, exprIsLiteral_maybe ) import GHC.Core.DataCon ( DataCon,dataConTagZ, dataConTyCon, dataConWrapId, dataConWorkId )-import GHC.Core.Utils  ( cheapEqExpr, exprIsHNF, exprType+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-   ( tyConDataCons_maybe, isAlgTyCon, isEnumerationTyCon-   , isNewTyCon, tyConDataCons-   , tyConFamilySize )+   ( TyCon, tyConDataCons_maybe, tyConDataCons, tyConSingleDataCon, tyConFamilySize+   , isEnumerationTyCon, isValidDTT2TyCon, isNewTyCon ) import GHC.Core.Map.Expr ( eqCoreExpr )  import GHC.Builtin.PrimOps ( PrimOp(..), tagToEnumKey )@@ -62,14 +65,14 @@ 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.Data.Maybe      ( orElse )  import GHC.Utils.Outputable import GHC.Utils.Misc import GHC.Utils.Panic-import GHC.Utils.Panic.Plain-import GHC.Utils.Trace  import Control.Applicative ( Alternative(..) ) import Control.Monad@@ -99,7 +102,8 @@ primOpRules ::  Name -> PrimOp -> Maybe CoreRule primOpRules nm = \case    TagToEnumOp -> mkPrimOpRule nm 2 [ tagToEnumRule ]-   DataToTagOp -> mkPrimOpRule nm 2 [ dataToTagRule ]+   DataToTagSmallOp -> mkPrimOpRule nm 3 [ dataToTagRule ]+   DataToTagLargeOp -> mkPrimOpRule nm 3 [ dataToTagRule ]     -- Int8 operations    Int8AddOp   -> mkPrimOpRule nm 2 [ binaryLit (int8Op2 (+))@@ -119,7 +123,9 @@    Int8QuotOp  -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (int8Op2 quot)                                     , leftZero                                     , rightIdentity oneI8-                                    , equalArgs $> Lit oneI8 ]+                                    , equalArgs $> Lit oneI8+                                    , quotFoldingRules int8Ops+                                    ]    Int8RemOp   -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (int8Op2 rem)                                     , leftZero                                     , oneLit 1 $> Lit zeroI8@@ -148,7 +154,9 @@                                     , mulFoldingRules Word8MulOp word8Ops                                     ]    Word8QuotOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (word8Op2 quot)-                                    , rightIdentity oneW8 ]+                                    , rightIdentity oneW8+                                    , quotFoldingRules word8Ops+                                    ]    Word8RemOp  -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (word8Op2 rem)                                     , leftZero                                     , oneLit 1 $> Lit zeroW8@@ -193,7 +201,9 @@    Int16QuotOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (int16Op2 quot)                                     , leftZero                                     , rightIdentity oneI16-                                    , equalArgs $> Lit oneI16 ]+                                    , equalArgs $> Lit oneI16+                                    , quotFoldingRules int16Ops+                                    ]    Int16RemOp  -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (int16Op2 rem)                                     , leftZero                                     , oneLit 1 $> Lit zeroI16@@ -222,7 +232,9 @@                                     , mulFoldingRules Word16MulOp word16Ops                                     ]    Word16QuotOp-> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (word16Op2 quot)-                                    , rightIdentity oneW16 ]+                                    , rightIdentity oneW16+                                    , quotFoldingRules word16Ops+                                    ]    Word16RemOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (word16Op2 rem)                                     , leftZero                                     , oneLit 1 $> Lit zeroW16@@ -267,7 +279,9 @@    Int32QuotOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (int32Op2 quot)                                     , leftZero                                     , rightIdentity oneI32-                                    , equalArgs $> Lit oneI32 ]+                                    , equalArgs $> Lit oneI32+                                    , quotFoldingRules int32Ops+                                    ]    Int32RemOp  -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (int32Op2 rem)                                     , leftZero                                     , oneLit 1 $> Lit zeroI32@@ -296,7 +310,9 @@                                     , mulFoldingRules Word32MulOp word32Ops                                     ]    Word32QuotOp-> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (word32Op2 quot)-                                    , rightIdentity oneW32 ]+                                    , rightIdentity oneW32+                                    , quotFoldingRules word32Ops+                                    ]    Word32RemOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (word32Op2 rem)                                     , leftZero                                     , oneLit 1 $> Lit zeroW32@@ -340,7 +356,9 @@    Int64QuotOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (int64Op2 quot)                                     , leftZero                                     , rightIdentity oneI64-                                    , equalArgs $> Lit oneI64 ]+                                    , equalArgs $> Lit oneI64+                                    , quotFoldingRules int64Ops+                                    ]    Int64RemOp  -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (int64Op2 rem)                                     , leftZero                                     , oneLit 1 $> Lit zeroI64@@ -369,7 +387,9 @@                                     , mulFoldingRules Word64MulOp word64Ops                                     ]    Word64QuotOp-> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (word64Op2 quot)-                                    , rightIdentity oneW64 ]+                                    , rightIdentity oneW64+                                    , quotFoldingRules word64Ops+                                    ]    Word64RemOp -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (word64Op2 rem)                                     , leftZero                                     , oneLit 1 $> Lit zeroW64@@ -419,15 +439,14 @@                                         [Lit (LitNumber _ l1), Lit (LitNumber _ l2)] <- getArgs                                         platform <- getPlatform                                         let r = l1 * l2-                                        pure $ mkCoreUbxTup [intPrimTy,intPrimTy,intPrimTy]+                                        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 (mkCoreUbxTup [intPrimTy,intPrimTy,intPrimTy]-                                                           [z,z,z])+                                        pure (mkCoreUnboxedTuple [z,z,z])                                        -- timesInt2# 1# other                                       -- ~~~>@@ -436,7 +455,7 @@                                       -- repeated to fill a word.                                     , identityPlatform onei >>= \other -> do                                         platform <- getPlatform-                                        pure $ mkCoreUbxTup [intPrimTy,intPrimTy,intPrimTy]+                                        pure $ mkCoreUnboxedTuple                                           [ Lit (zeroi platform)                                           , mkCoreApps (Var (primOpId IntSubOp))                                               [ Lit (zeroi platform)@@ -451,7 +470,9 @@    IntQuotOp   -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (intOp2 quot)                                     , leftZero                                     , rightIdentityPlatform onei-                                    , equalArgs >> retLit onei ]+                                    , equalArgs >> retLit onei+                                    , quotFoldingRules intOps+                                    ]    IntRemOp    -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (intOp2 rem)                                     , leftZero                                     , oneLit 1 >> retLit zeroi@@ -503,7 +524,9 @@                                     , mulFoldingRules WordMulOp wordOps                                     ]    WordQuotOp  -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (wordOp2 quot)-                                    , rightIdentityPlatform onew ]+                                    , rightIdentityPlatform onew+                                    , quotFoldingRules wordOps+                                    ]    WordRemOp   -> mkPrimOpRule nm 2 [ nonZeroLit 1 >> binaryLit (wordOp2 rem)                                     , leftZero                                     , oneLit 1 >> retLit zerow@@ -634,6 +657,38 @@                                        , 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@@ -656,6 +711,11 @@    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 ]@@ -671,6 +731,10 @@    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 ]@@ -790,7 +854,6 @@     AddrAddOp  -> mkPrimOpRule nm 2 [ rightIdentityPlatform zeroi ] -   SeqOp      -> mkPrimOpRule nm 4 [ seqRule ]    SparkOp    -> mkPrimOpRule nm 4 [ sparkRule ]     _          -> Nothing@@ -999,8 +1062,7 @@ retLitNoC :: (Platform -> Literal) -> RuleM CoreExpr retLitNoC l = do platform <- getPlatform                  let lit = l platform-                 let ty = literalType lit-                 return $ mkCoreUbxTup [ty, ty] [Lit lit, Lit (zeroi platform)]+                 return $ mkCoreUnboxedTuple [Lit lit, Lit (zeroi platform)]  word8Op2   :: (Integral a, Integral b)@@ -1067,7 +1129,7 @@     _ | shift_len == 0 -> pure e1        -- See Note [Guarding against silly shifts]-    _ | shift_len < 0 || shift_len > bit_size+    _ | 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@@ -1095,9 +1157,8 @@ -------------------------- floatDecodeOp :: RuleOpts -> Literal -> Maybe CoreExpr floatDecodeOp env (LitFloat ((decodeFloat . fromRational @Float) -> (m, e)))-  = Just $ mkCoreUbxTup [intPrimTy, intPrimTy]-                        [ mkIntVal (roPlatform env) (toInteger m)-                        , mkIntVal (roPlatform env) (toInteger e) ]+  = Just $ mkCoreUnboxedTuple [ mkIntVal (roPlatform env) (toInteger m)+                              , mkIntVal (roPlatform env) (toInteger e) ] floatDecodeOp _   _   = Nothing @@ -1112,20 +1173,158 @@ -------------------------- doubleDecodeOp :: RuleOpts -> Literal -> Maybe CoreExpr doubleDecodeOp env (LitDouble ((decodeFloat . fromRational @Double) -> (m, e)))-  = Just $ mkCoreUbxTup [iNT64Ty, intPrimTy]-                        [ Lit (mkLitINT64 (toInteger m))-                        , mkIntVal platform (toInteger e) ]+  = Just $ mkCoreUnboxedTuple [ Lit (mkLitInt64Wrap (toInteger m))+                              , mkIntVal platform (toInteger e) ]   where     platform = roPlatform env-    (iNT64Ty, mkLitINT64)-      | platformWordSizeInBits platform < 64-      = (int64PrimTy, mkLitInt64Wrap)-      | otherwise-      = (intPrimTy  , mkLitIntWrap platform) 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@@ -1226,9 +1425,8 @@ -- Integer is in the target Int range and the corresponding overflow flag -- (@0#@/@1#@) if it wasn't. intCResult :: Platform -> Integer -> Maybe CoreExpr-intCResult platform result = Just (mkPair [Lit lit, Lit c])+intCResult platform result = Just (mkCoreUnboxedTuple [Lit lit, Lit c])   where-    mkPair = mkCoreUbxTup [intPrimTy, intPrimTy]     (lit, b) = mkLitIntWrapC platform result     c = if b then onei platform else zeroi platform @@ -1268,9 +1466,8 @@ -- Integer is in the target Word range and the corresponding carry flag -- (@0#@/@1#@) if it wasn't. wordCResult :: Platform -> Integer -> Maybe CoreExpr-wordCResult platform result = Just (mkPair [Lit lit, Lit c])+wordCResult platform result = Just (mkCoreUnboxedTuple [Lit lit, Lit c])   where-    mkPair = mkCoreUbxTup [wordPrimTy, intPrimTy]     (lit, b) = mkLitWordWrapC platform result     c = if b then onei platform else zeroi platform @@ -1287,7 +1484,7 @@ word64Result' result = Lit (mkLitWord64Wrap result)  --- | 'ambiant (primop x) = x', but not nececesarily 'primop (ambient x) = x'.+-- | 'ambient (primop x) = x', but not necessarily 'primop (ambient x) = x'. semiInversePrimOp :: PrimOp -> RuleM CoreExpr semiInversePrimOp primop = do   [Var primop_id `App` e] <- getArgs@@ -1414,15 +1611,15 @@     let x = I# (error "invalid shift")     in ... -This was originally done in the fix to #16449 but this breaks the let/app-invariant (see Note [Core let/app invariant] in GHC.Core) as noted in #16742.-For the reasons discussed in Note [Checking versus non-checking primops] (in-the PrimOp module) there is no safe way rewrite the argument of I# such that-it bottoms.+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 large shifts are-undefined behavior (see associated documentation in primops.txt.pp) and-transform the invalid shift into an "obviously incorrect" value.+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: @@ -1624,7 +1821,7 @@   [Lit l1, e2] <- getArgs   guard $ l1 == id_lit platform   let no_c = Lit (zeroi platform)-  return (mkCoreUbxTup [exprType e2, intPrimTy] [e2, no_c])+  return (mkCoreUnboxedTuple [e2, no_c])  rightIdentityPlatform :: (Platform -> Literal) -> RuleM CoreExpr rightIdentityPlatform id_lit = do@@ -1641,7 +1838,7 @@   [e1, Lit l2] <- getArgs   guard $ l2 == id_lit platform   let no_c = Lit (zeroi platform)-  return (mkCoreUbxTup [exprType e1, intPrimTy] [e1, no_c])+  return (mkCoreUnboxedTuple [e1, no_c])  identityPlatform :: (Platform -> Literal) -> RuleM CoreExpr identityPlatform lit =@@ -1799,6 +1996,14 @@ 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@@ -1810,22 +2015,28 @@     Just (tycon, tc_args) | isEnumerationTyCon tycon -> do       let tag = fromInteger i           correct_tag dc = (dataConTagZ dc) == tag-      (dc:rest) <- return $ filter correct_tag (tyConDataCons_maybe tycon `orElse` [])-      massert (null rest)-      return $ mkTyApps (Var (dataConWorkId dc)) tc_args+      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 $ mkRuntimeErrorApp rUNTIME_ERROR_ID ty "tagToEnum# on non-enumeration type"+         return $ mkImpossibleExpr ty "tagToEnum# on non-enumeration type"  ------------------------------ dataToTagRule :: RuleM CoreExpr--- See Note [dataToTag# magic].+-- 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 ty1, Var tag_to_enum `App` Type ty2 `App` tag] <- getArgs+      [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@@ -1835,43 +2046,14 @@     --   dataToTag x     -- where x's unfolding is a constructor application     b = do-      dflags <- getPlatform-      [_, val_arg] <- getArgs+      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 dflags (toInteger (dataConTagZ dc)))+      return $ wrapFloats floats (mkIntVal platform (toInteger (dataConTagZ dc))) -{- Note [dataToTag# magic]-~~~~~~~~~~~~~~~~~~~~~~~~~~-The primop dataToTag# is unusual because it evaluates its argument.-Only `SeqOp` shares that property.  (Other primops do not do anything-as fancy as argument evaluation.)  The special handling for dataToTag#-is: -* GHC.Core.Utils.exprOkForSpeculation has a special case for DataToTagOp,-  (actually in app_ok).  Most primops with lifted arguments do not-  evaluate those arguments, but DataToTagOp and SeqOp are two-  exceptions.  We say that they are /never/ ok-for-speculation,-  regardless of the evaluated-ness of their argument.-  See GHC.Core.Utils Note [exprOkForSpeculation and SeqOp/DataToTagOp]--* There is a special case for DataToTagOp in GHC.StgToCmm.Expr.cgExpr,-  that evaluates its argument and then extracts the tag from-  the returned value.--* An application like (dataToTag# (Just x)) is optimised by-  dataToTagRule in GHC.Core.Opt.ConstantFold.--* A case expression like-     case (dataToTag# e) of <alts>-  gets transformed t-     case e of <transformed alts>-  by GHC.Core.Opt.ConstantFold.caseRules; see Note [caseRules for dataToTag]--See #15696 for a long saga.--}- {- ********************************************************************* *                                                                      *              unsafeEqualityProof@@ -1888,7 +2070,7 @@        ; fn <- getFunction        ; let (_, ue) = splitForAllTyCoVars (idType fn)              tc      = tyConAppTyCon ue  -- tycon:    UnsafeEquality-             (dc:_)  = tyConDataCons tc  -- data con: UnsafeRefl+             dc      = tyConSingleDataCon tc  -- data con: UnsafeRefl              -- UnsafeRefl :: forall (r :: RuntimeRep) (a :: TYPE r).              --               UnsafeEquality r a a        ; return (mkTyApps (Var (dataConWrapId dc)) [rep, t1]) }@@ -1896,75 +2078,18 @@  {- ********************************************************************* *                                                                      *-             Rules for seq# and spark#+             Rules for spark# *                                                                      * ********************************************************************* -} -{- Note [seq# magic]-~~~~~~~~~~~~~~~~~~~~-The primop-   seq# :: forall a s . a -> State# s -> (# State# s, a #)--is /not/ the same as the Prelude function seq :: a -> b -> b-as you can see from its type.  In fact, seq# is the implementation-mechanism for 'evaluate'--   evaluate :: a -> IO a-   evaluate a = IO $ \s -> seq# a s--The semantics of seq# is-  * evaluate its first argument-  * and return it--Things to note--* Why do we need a primop at all?  That is, instead of-      case seq# x s of (# x, s #) -> blah-  why not instead say this?-      case x of { DEFAULT -> blah)--  Reason (see #5129): if we saw-    catch# (\s -> case x of { DEFAULT -> raiseIO# exn s }) handler--  then we'd drop the 'case x' because the body of the case is bottom-  anyway. But we don't want to do that; the whole /point/ of-  seq#/evaluate is to evaluate 'x' first in the IO monad.--  In short, we /always/ evaluate the first argument and never-  just discard it.--* Why return the value?  So that we can control sharing of seq'd-  values: in-     let x = e in x `seq` ... x ...-  We don't want to inline x, so better to represent it as-       let x = e in case seq# x RW of (# _, x' #) -> ... x' ...-  also it matches the type of rseq in the Eval monad.--Implementing seq#.  The compiler has magic for SeqOp in--- GHC.Core.Opt.ConstantFold.seqRule: eliminate (seq# <whnf> s)--- GHC.StgToCmm.Expr.cgExpr, and cgCase: special case for seq#--- GHC.Core.Utils.exprOkForSpeculation;-  see Note [exprOkForSpeculation and SeqOp/DataToTagOp] in GHC.Core.Utils--- Simplify.addEvals records evaluated-ness for the result; see-  Note [Adding evaluatedness info to pattern-bound variables]-  in GHC.Core.Opt.Simplify--}--seqRule :: RuleM CoreExpr-seqRule = do-  [Type ty_a, Type _ty_s, a, s] <- getArgs-  guard $ exprIsHNF a-  return $ mkCoreUbxTup [exprType s, ty_a] [s, a]- -- spark# :: forall a s . a -> State# s -> (# State# s, a #) sparkRule :: RuleM CoreExpr-sparkRule = seqRule -- reduce on HNF, just the same-  -- XXX perhaps we shouldn't do this, because a spark eliminated by-  -- this rule won't be counted as a dud at runtime?+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?  {- ************************************************************************@@ -2103,10 +2228,10 @@         x <- isNaturalLiteral a0         y <- isNaturalLiteral a1         -- return an unboxed sum: (# (# #) | Natural #)-        let ret n v = pure $ mkCoreUbxSum 2 n [unboxedUnitTy,naturalTy] v+        let ret n v = pure $ mkCoreUnboxedSum 2 n [unboxedUnitTy,naturalTy] v         platform <- getPlatform         if x < y-            then ret 1 $ Var voidPrimId+            then ret 1 unboxedUnitExpr             else ret 2 $ mkNaturalExpr platform (x - y)      -- unary operations@@ -2136,12 +2261,12 @@   , divop_one  "integerRem"     integerRemName     rem     mkIntegerExpr   , divop_one  "integerDiv"     integerDivName     div     mkIntegerExpr   , divop_one  "integerMod"     integerModName     mod     mkIntegerExpr-  , divop_both "integerDivMod"  integerDivModName  divMod  mkIntegerExpr integerTy-  , divop_both "integerQuotRem" integerQuotRemName quotRem mkIntegerExpr integerTy+  , divop_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 naturalTy+  , divop_both "naturalQuotRem" naturalQuotRemName quotRem mkNaturalExpr      -- conversions from Rational for Float/Double literals   , rational_to "rationalToFloat"  rationalToFloatName  mkFloatExpr@@ -2243,7 +2368,7 @@       -- 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))+      guard (platformWordSizeInBits platform <= finiteBitSize (0 :: Word))       [a0] <- getArgs       x <- isBignumLiteral a0       pure $ Lit (mk_lit platform (fromIntegral (popCount x)))@@ -2291,14 +2416,14 @@       platform <- getPlatform       pure $ mk_lit platform (n `divop` d) -    divop_both str name divop mk_lit ty = mkRule str name 2 $ do+    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 $ mkCoreUbxTup [ty,ty] [mk_lit platform r, mk_lit platform s]+      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@@ -2408,7 +2533,7 @@ -- Also, look into variable's unfolding just in case the expression we look for -- is in a top-level thunk. stripStrTopTicks :: InScopeEnv -> CoreExpr -> ([CoreTickish], CoreExpr)-stripStrTopTicks (_,id_unf) e = case e of+stripStrTopTicks (ISE _ id_unf) e = case e of   Var v     | Just rhs <- expandUnfolding_maybe (id_unf v)     -> stripTicksTop tickishFloatable rhs@@ -2488,6 +2613,10 @@      inline f_ty (f a b c) = <f's unfolding> a b c   (if f has an unfolding, EVEN if it's a loop breaker) +  Additionally the rule looks through ticks/casts as well (#24808):+      inline f_ty (f a b c |> co) = <f's unfolding> a b c |> co+      inline f_ty <tick> ( f a b c ) = <tick> <f's unfolding> a b c+   It's important to allow the argument to 'inline' to have args itself   (a) because its more forgiving to allow the programmer to write       either  inline f a b c@@ -2500,18 +2629,31 @@ -}  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 (Type _ : e : _) = go e+  -- Maybe Monad ahead:+  where+    go (Var f)      = -- Ignore the IdUnfoldingFun here!+                      (maybeUnfoldingTemplate (realIdUnfolding f))+    go (App f a)    = do { f' <- go f; pure $ App f' a }+    -- inline (f |> co)+    go (Cast e co)  = do { app <- go e; pure (Cast app co) }+    -- inline (<tick> f)+    go (Tick t e)   = do { app <- go e; pure (Tick t app) }+    go _            = Nothing  match_inline _ = Nothing  -------------------------------------------------------- -- Note [Constant folding through nested expressions] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- GHC has some support for constant folding through nested expressions (i.e.+-- when constants are not only arguments of the considered App node but to one+-- of its own argument (an App node too), see examples below). --+-- For performance reason, this optimization is only enabled with -O1 and above.+-- As with all optimizations, it can also be independently enabled with its own+-- command-line flag too: -fnum-constant-folding (grep Opt_NumConstantFolding).+-- -- We use rewrites rules to perform constant folding. It means that we don't -- have a global view of the expression we are trying to optimise. As a -- consequence we only perform local (small-step) transformations that either:@@ -2662,6 +2804,14 @@       (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 @@ -2908,7 +3058,7 @@  andFoldingRules' :: Platform -> CoreExpr -> CoreExpr -> NumOps -> Maybe CoreExpr andFoldingRules' platform arg1 arg2 num_ops = case (arg1, arg2) of-    -- R2) * `or` `and` simplications+    -- 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)@@ -2924,6 +3074,11 @@     -- (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@@ -2931,7 +3086,7 @@  orFoldingRules' :: Platform -> CoreExpr -> CoreExpr -> NumOps -> Maybe CoreExpr orFoldingRules' platform arg1 arg2 num_ops = case (arg1, arg2) of-    -- R2) *  `or` `and` simplications+    -- 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)@@ -2947,11 +3102,39 @@     -- (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)@@ -2962,16 +3145,36 @@  App (OpVal op') x | op == op' -> Just x  _                             -> Nothing -is_add, is_sub, is_mul, is_and, is_or :: NumOps -> CoreExpr -> Maybe (Arg CoreBndr, Arg CoreBndr)+is_add, 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@@ -3016,6 +3219,7 @@    { 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@@ -3026,15 +3230,20 @@ 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-   , numLitType = LitNumInt8+   , numDiv     = Just Int8QuotOp    , numAnd     = Nothing    , numOr      = Nothing    , numNeg     = Just Int8NegOp+   , numLitType = LitNumInt8    }  word8Ops :: NumOps@@ -3042,6 +3251,7 @@    { numAdd     = Word8AddOp    , numSub     = Word8SubOp    , numMul     = Word8MulOp+   , numDiv     = Just Word8QuotOp    , numAnd     = Just Word8AndOp    , numOr      = Just Word8OrOp    , numNeg     = Nothing@@ -3053,10 +3263,11 @@    { numAdd     = Int16AddOp    , numSub     = Int16SubOp    , numMul     = Int16MulOp-   , numLitType = LitNumInt16+   , numDiv     = Just Int16QuotOp    , numAnd     = Nothing    , numOr      = Nothing    , numNeg     = Just Int16NegOp+   , numLitType = LitNumInt16    }  word16Ops :: NumOps@@ -3064,6 +3275,7 @@    { numAdd     = Word16AddOp    , numSub     = Word16SubOp    , numMul     = Word16MulOp+   , numDiv     = Just Word16QuotOp    , numAnd     = Just Word16AndOp    , numOr      = Just Word16OrOp    , numNeg     = Nothing@@ -3075,10 +3287,11 @@    { numAdd     = Int32AddOp    , numSub     = Int32SubOp    , numMul     = Int32MulOp-   , numLitType = LitNumInt32+   , numDiv     = Just Int32QuotOp    , numAnd     = Nothing    , numOr      = Nothing    , numNeg     = Just Int32NegOp+   , numLitType = LitNumInt32    }  word32Ops :: NumOps@@ -3086,6 +3299,7 @@    { numAdd     = Word32AddOp    , numSub     = Word32SubOp    , numMul     = Word32MulOp+   , numDiv     = Just Word32QuotOp    , numAnd     = Just Word32AndOp    , numOr      = Just Word32OrOp    , numNeg     = Nothing@@ -3097,10 +3311,11 @@    { numAdd     = Int64AddOp    , numSub     = Int64SubOp    , numMul     = Int64MulOp-   , numLitType = LitNumInt64+   , numDiv     = Just Int64QuotOp    , numAnd     = Nothing    , numOr      = Nothing    , numNeg     = Just Int64NegOp+   , numLitType = LitNumInt64    }  word64Ops :: NumOps@@ -3108,6 +3323,7 @@    { numAdd     = Word64AddOp    , numSub     = Word64SubOp    , numMul     = Word64MulOp+   , numDiv     = Just Word64QuotOp    , numAnd     = Just Word64AndOp    , numOr      = Just Word64OrOp    , numNeg     = Nothing@@ -3119,6 +3335,7 @@    { numAdd     = IntAddOp    , numSub     = IntSubOp    , numMul     = IntMulOp+   , numDiv     = Just IntQuotOp    , numAnd     = Just IntAndOp    , numOr      = Just IntOrOp    , numNeg     = Just IntNegOp@@ -3130,6 +3347,7 @@    { numAdd     = WordAddOp    , numSub     = WordSubOp    , numMul     = WordMulOp+   , numDiv     = Just WordQuotOp    , numAnd     = Just WordAndOp    , numOr      = Just WordOrOp    , numNeg     = Nothing@@ -3190,16 +3408,81 @@            , \v -> (App (App (Var f) type_arg) (Var v)))  -- See Note [caseRules for dataToTag]-caseRules _ (App (App (Var f) (Type ty)) v)       -- dataToTag x-  | Just DataToTagOp <- isPrimOpId_maybe f-  , Just (tc, _) <- tcSplitTyConApp_maybe ty-  , isAlgTyCon tc-  = Just (v, tx_con_dtt ty-           , \v -> App (App (Var f) (Type ty)) (Var v))+caseRules _ (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)@@ -3248,9 +3531,9 @@ tx_con_tte platform (DataAlt dc)  -- See Note [caseRules for tagToEnum]   = Just $ LitAlt $ mkLitInt platform $ toInteger $ dataConTagZ dc -tx_con_dtt :: Type -> AltCon -> Maybe AltCon+tx_con_dtt :: TyCon -> AltCon -> Maybe AltCon tx_con_dtt _  DEFAULT = Just DEFAULT-tx_con_dtt ty (LitAlt (LitNumber LitNumInt i))+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 (!!)@@ -3258,17 +3541,16 @@    = Nothing    where      tag         = fromInteger i :: ConTagZ-     tc          = tyConAppTyCon ty      n_data_cons = tyConFamilySize tc      data_cons   = tyConDataCons tc -tx_con_dtt _ alt = pprPanic "caseRules" (ppr alt)+tx_con_dtt _ alt = pprPanic "caseRules/dataToTag: bad alt" (ppr alt)   {- Note [caseRules for tagToEnum] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We want to transform-   case tagToEnum x of+   case tagToEnum# x of      False -> e1      True  -> e2 into@@ -3276,13 +3558,13 @@      0# -> e1      1# -> e2 -This rule eliminates a lot of boilerplate. For+See #8317.   This rule eliminates a lot of boilerplate. For   if (x>y) then e2 else e1 we generate-  case tagToEnum (x ># y) of+  case tagToEnum# (x ># y) of     False -> e1     True  -> e2-and it is nice to then get rid of the tagToEnum.+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@@ -3300,15 +3582,16 @@       DEFAULT -> e1       DEFAULT -> e2 -Instead, we deal with turning one branch into DEFAULT in GHC.Core.Opt.Simplify.Utils-(add_default in mkCase3).+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# magic].+See also Note [DataToTag overview] in GHC.Tc.Instance.Class.  We want to transform-  case dataToTag x of+  case dataToTagSmall# x of     DEFAULT -> e1     1# -> e2 into@@ -3316,14 +3599,23 @@     DEFAULT -> e1     (:) _ _ -> e2 -Note the need for some wildcard binders in-the 'cons' case.+(Note the need for some wildcard binders in the 'cons' case.) -For the time, we only apply this transformation when the type of `x` is a type-headed by a normal tycon. In particular, we do not apply this in the case of a-data family tycon, since that would require carefully applying coercion(s)-between the data family and the data family instance's representation type,-which caseRules isn't currently engineered to handle (#14680).+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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
GHC/Core/Opt/CprAnal.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE MultiWayIf #-}  -- | Constructed Product Result analysis. Identifies functions that surely -- return heap-allocated records on every code path, so that we can eliminate@@ -10,7 +11,7 @@  import GHC.Prelude -import GHC.Driver.Session+import GHC.Driver.Flags ( DumpFlag (..) )  import GHC.Builtin.Names ( runRWKey ) @@ -22,12 +23,15 @@ 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+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@@ -35,7 +39,6 @@ import GHC.Utils.Outputable import GHC.Utils.Misc import GHC.Utils.Panic-import GHC.Utils.Panic.Plain import GHC.Utils.Logger  ( Logger, putDumpFileMaybe, DumpFormat (..) )  import Data.List ( mapAccumL )@@ -210,16 +213,20 @@   -> (CprType, CoreExpr) -- ^ the updated expression and its 'CprType'  cprAnal env e = -- pprTraceWith "cprAnal" (\res -> ppr (fst (res)) $$ ppr e) $-                  cprAnal' env 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)+  = (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')@@ -271,20 +278,20 @@ cprAnalAlt env scrut_ty (Alt con bndrs rhs)   = (rhs_ty, Alt con bndrs rhs')   where+    ids = filter isId bndrs     env_alt       | DataAlt dc <- con-      , let ids = filter isId bndrs       , CprType arity cpr <- scrut_ty-      , assert (arity == 0 ) True+      , 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 "cprAnalAlt" ids sigs)+            -> extendSigEnvList env (zipEqual ids sigs)       | otherwise-      = env+      = extendSigEnvAllSame env ids topCprSig     (rhs_ty, rhs') = cprAnal env_alt rhs  --@@ -297,9 +304,16 @@  -- See Note [Nested CPR] exprTerminates :: CoreExpr -> TermFlag+-- ^ A /very/ simple termination analysis. exprTerminates e-  | exprIsHNF e = Terminates -- A /very/ simple termination analysis.-  | otherwise   = MightDiverge+  | 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]@@ -340,7 +354,7 @@   | isLocalId id   = assertPpr (isDataStructure id) (ppr id) topCprType   -- See Note [CPR for DataCon wrappers]-  | isDataConWrapId id, let rhs = uf_tmpl (realIdUnfolding id)+  | Just rhs <- dataConWrapUnfolding_maybe id   = fst $ cprAnalApp env rhs args   -- DataCon worker   | Just con <- isDataConWorkId_maybe id@@ -362,14 +376,16 @@ -- | Get a (possibly nested) 'CprType' for an application of a 'DataCon' worker, -- given a saturated number of 'CprType's for its field expressions. -- Implements the Nested part of Note [Nested CPR].-cprTransformDataConWork :: AnalEnv -> DataCon -> [(CprType, CoreArg)] -> CprType+cprTransformDataConWork :: 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]-  -- , pprTrace "cprTransformDataConWork" (ppr con <+> ppr wkr_arity <+> ppr args) True-  = CprType 0 (ConCpr (dataConTag con) (strictZipWith extract_nested_cpr args wkr_str_marks))+  = -- 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@@ -385,6 +401,19 @@ 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 --@@ -398,20 +427,28 @@   where     init_sig id       -- See Note [CPR for data structures]-      | isDataStructure id = topCprSig-      | otherwise          = mkCprSig 0 botCpr+      -- 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@@ -429,6 +466,43 @@             (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:@@ -464,24 +538,25 @@   | 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-  = (id,  rhs,  env) -- Data structure => no code => no need to analyse rhs+  | isDataStructure id -- Data structure => no code => no need to analyse rhs+  = (id,  rhs,  env)   | otherwise-  = (id', rhs', env')+  = -- 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]-      | stays_thunk = trimCprTy rhs_ty-      | otherwise   = rhs_ty+      | 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-    id'  = setIdCprSig id sig'     env' = extendSigEnv env id sig'      -- See Note [CPR for thunks]@@ -552,13 +627,16 @@      *workers*, because their transformers need to adapt to CPR for their      arguments in 'cprTransformDataConWork' to enable Note [Nested CPR].      Better keep it all in this module! The alternative would be that-     'GHC.Types.Id.Make' depends on DmdAnal.+     '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:@@ -591,7 +669,7 @@   , ae_fam_envs :: FamInstEnvs   -- ^ Needed when expanding type families and synonyms of product types.   , ae_rec_dc :: DataCon -> IsRecDataConResult-  -- ^ Memoised result of 'GHC.Core.Opt.WorkWrap.Utils.isRecDataCon'+  -- ^ Memoised result of 'GHC.Core.Opt.WorkWrap.Utils.isRecDataType   }  instance Outputable AnalEnv where@@ -740,7 +818,7 @@  Note that -  * Whether or not something unboxes is decided by 'wantToUnboxArg', else we may+  * 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@@ -994,10 +1072,11 @@  What can we do about it? - A. Don't CPR functions that return a *recursive data type* (the list in this-    case). This is the solution we adopt. Rationale: the benefit of CPR on-    recursive data structures is slight, because it only affects the outer layer-    of a potentially massive data structure.+ 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@@ -1007,11 +1086,16 @@     `c` in the second eqn of `replicateC`). But we'd need to know which paths     were hot. We want such static branch frequency estimates in #20378. -We adopt solution (A) It is ad-hoc, but appears to work reasonably well.-Deciding what a "recursive data constructor" is is quite tricky and ad-hoc, too:-See Note [Detecting recursive data constructors]. We don't have to be perfect-and can simply keep on unboxing if unsure.+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@@ -1027,12 +1111,15 @@     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 or coercion types because there's nothing to unbox.+  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@@ -1104,6 +1191,22 @@ 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] ~~~~~~~~~~~~~~~~~~~
GHC/Core/Opt/DmdAnal.hs view
@@ -16,2145 +16,2702 @@  import GHC.Prelude -import GHC.Core.Opt.WorkWrap.Utils-import GHC.Types.Demand   -- All of it-import GHC.Core-import GHC.Core.Multiplicity ( scaledThing )-import GHC.Utils.Outputable-import GHC.Types.Var.Env-import GHC.Types.Var.Set-import GHC.Types.Basic-import Data.List        ( mapAccumL )-import GHC.Core.DataCon-import GHC.Types.ForeignCall ( isSafeForeignCall )-import GHC.Types.Id-import GHC.Core.Utils-import GHC.Core.TyCon-import GHC.Core.Type-import GHC.Core.Predicate ( isClassPred )-import GHC.Core.FVs      ( rulesRhsFreeIds, bndrRuleAndUnfoldingIds )-import GHC.Core.Coercion ( Coercion )-import GHC.Core.TyCo.FVs ( coVarsOfCos )-import GHC.Core.FamInstEnv-import GHC.Core.Opt.Arity ( typeArity )-import GHC.Utils.Misc-import GHC.Utils.Panic-import GHC.Utils.Panic.Plain-import GHC.Data.Maybe-import GHC.Builtin.PrimOps-import GHC.Builtin.Types.Prim ( realWorldStatePrimTy )-import GHC.Types.Unique.Set-import GHC.Types.Unique.MemoFun--import GHC.Utils.Trace-_ = pprTrace -- Tired of commenting out the import all the time--{--************************************************************************-*                                                                      *-\subsection{Top level stuff}-*                                                                      *-************************************************************************--}---- | Options for the demand analysis-data DmdAnalOpts = DmdAnalOpts-   { dmd_strict_dicts    :: !Bool -- ^ Use strict dictionaries-   , dmd_unbox_width     :: !Int  -- ^ Use strict dictionaries-   , dmd_max_worker_args :: !Int-   }---- This is a strict alternative to (,)--- 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 lazyness (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 (add_exported_uses env' body_ty (bindersOf b)) bs'--    cons_up :: WithDmdType (DmdResult b [b]) -> WithDmdType [b]-    cons_up (WithDmdType dmd_ty (R b' bs')) = WithDmdType dmd_ty (b' : bs')--    add_exported_uses :: AnalEnv -> DmdType -> [Id] -> DmdType-    add_exported_uses env = foldl' (add_exported_use env)--    -- If @e@ is denoted by @dmd_ty@, then @add_exported_use _ dmd_ty id@-    -- corresponds to the demand type of @(id, e)@, but is a lot more direct.-    -- See Note [Analysing top-level bindings].-    add_exported_use :: AnalEnv -> DmdType -> Id -> DmdType-    add_exported_use env dmd_ty id-      | isExportedId id || elemVarSet id rule_fvs-      -- See Note [Absence analysis for stable unfoldings and RULES]-      = dmd_ty `plusDmdType` fst (dmdAnalStar env topDmd (Var id))-      | otherwise-      = dmd_ty--    rule_fvs :: IdSet-    rule_fvs = rulesRhsFreeIds rules---- | 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) `lengthExceeds` 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 [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 @LCL(CM(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     id rhs anal_body-  _ -> dmdAnalBindLetDown top_lvl env dmd bind   anal_body---- | 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---- | 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 env-    WithDmdType body_ty' id_dmd = findBndrDmd env body_ty id-    -- See Note [Finalising boxity for demand signatures]--    id_dmd'            = finaliseLetBoxity (ae_fam_envs env) (idType id) id_dmd-    !id'               = setBindIdDemandInfo top_lvl id id_dmd'-    (rhs_ty, rhs')     = dmdAnalStar env (dmdTransformThunkDmd rhs id_dmd') rhs--    -- See Note [Absence analysis for stable unfoldings and RULES]-    rule_fvs           = bndrRuleAndUnfoldingIds id-    final_ty           = body_ty' `plusDmdType` rhs_ty `keepAliveDmdType` rule_fvs---- | 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', lazy_fv, id1, rhs1) <--        dmdAnalRhsSig top_lvl NonRecursive env dmd id rhs-    -> do_rest env' lazy_fv [(id1, rhs1)] (uncurry NonRec . only)-  Rec pairs-    | (env', lazy_fv, pairs') <- dmdFix top_lvl env dmd pairs-    -> do_rest env' lazy_fv pairs' Rec-  where-    do_rest env' lazy_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                          = addLazyFVs body_ty lazy_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.---- 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 -- Should obey the let/app invariant-            -> (PlusDmdArg, CoreExpr)-dmdAnalStar env (n :* sd) e-  -- NB: (:*) expands AbsDmd and BotDmd as needed-  -- See Note [Analysing with absent demand]-  | WithDmdType dmd_ty e' <- dmdAnal env sd e-  = assertPpr (mightBeLiftedType (exprType e) || exprOkForSpeculation e) (ppr e)-    -- The argument 'e' should satisfy the let/app invariant-    (toPlusDmdArg $ multDmdType n dmd_ty, e')---- Main Demand Analsysis 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 (unitDmdType (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` mkPlusDmdArg (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 (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) ])-    WithDmdType (res_ty `plusDmdType` arg_ty) (App fun' arg')--dmdAnal' env dmd (Lam var body)-  | isTyVar var-  = let-        WithDmdType body_ty body' = dmdAnal env dmd body-    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 env body_dmd body-        WithDmdType lam_ty var'   = annotateLamIdBndr env body_ty var-        new_dmd_type = multDmdType n lam_ty-    in-    WithDmdType new_dmd_type (Lam var' body')--dmdAnal' env dmd (Case scrut case_bndr ty [Alt alt bndrs rhs])-  -- Only one alternative.-  -- If it's a DataAlt, it should be the only constructor of the type and we-  -- can consider its field demands when analysing the scrutinee.-  | want_precise_field_dmds alt-  = let-        WithDmdType rhs_ty rhs'           = dmdAnal env dmd rhs-        WithDmdType alt_ty1 fld_dmds      = findBndrsDmds env rhs_ty bndrs-        WithDmdType alt_ty2 case_bndr_dmd = findBndrDmd env alt_ty1 case_bndr-        !case_bndr'                       = setIdDemandInfo case_bndr case_bndr_dmd-        -- Evaluation cardinality on the case binder is irrelevant and a no-op.-        -- What matters is its nested sub-demand!-        -- NB: If case_bndr_dmd is absDmd, boxity will say Unboxed, which is-        -- what we want, because then `seq` will put a `seqDmd` on its scrut.-        (_ :* case_bndr_sd) = case_bndr_dmd-        -- Compute demand on the scrutinee-        -- FORCE the result, otherwise thunks will end up retaining the-        -- whole DmdEnv-        !(!bndrs', !scrut_sd)-          | DataAlt _ <- alt-          -- See Note [Demand on the scrutinee of a product case]-          -- See Note [Demand on case-alternative binders]-          , (!scrut_sd, fld_dmds') <- addCaseBndrDmd case_bndr_sd fld_dmds-          , let !bndrs' = setBndrsDemandInfo bndrs fld_dmds'-          = (bndrs', scrut_sd)-          | otherwise-          -- __DEFAULT and literal alts. Simply add demands and discard the-          -- evaluation cardinality, as we evaluate the scrutinee exactly once.-          = assert (null bndrs) (bndrs, case_bndr_sd)-        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` toPlusDmdArg 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 bndrs' rhs'])-    where-      want_precise_field_dmds alt = case alt of-        (DataAlt dc)-          | Nothing <- tyConSingleAlgDataCon_maybe $ dataConTyCon dc -> False-          | DefinitelyRecursive <- ae_rec_dc env dc                  -> False-              -- See Note [Demand analysis for recursive data constructors]-        _                                                            -> True-----dmdAnal' env dmd (Case scrut case_bndr ty alts)-  = let      -- Case expression with multiple alternatives-        WithDmdType alt_ty alts'     = combineAltDmds alts--        combineAltDmds [] = WithDmdType botDmdType []-        combineAltDmds (a:as) =-          let-            WithDmdType cur_ty a' = dmdAnalSumAlt env dmd case_bndr a-            WithDmdType rest_ty as' = combineAltDmds as-          in WithDmdType (lubDmdType cur_ty rest_ty) (a':as')--        WithDmdType alt_ty1 case_bndr_dmd = findBndrDmd env alt_ty case_bndr-        !case_bndr'                       = setIdDemandInfo case_bndr case_bndr_dmd-        WithDmdType scrut_ty scrut'       = dmdAnal env topSubDmd scrut-                               -- NB: Base case is botDmdType, for empty case alternatives-                               --     This is a unit for lubDmdType, and the right result-                               --     when there really are no alternatives-        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               = alt_ty2 `plusDmdType` toPlusDmdArg 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_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, _) <- collectArgs e-  , Just op    <- isPrimOpId_maybe f-  , op /= RaiseIOOp-  = False -- 2. in the Note-  | (Var f, _) <- collectArgs e-  , Just fcall <- isFCallId_maybe f-  , not (isSafeForeignCall fcall)-  = False -- 3. in the Note-  | otherwise-  = True  -- _. in the Note---- | 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--dmdAnalSumAlt :: AnalEnv -> SubDemand -> Id -> Alt Var -> WithDmdType (Alt Var)-dmdAnalSumAlt env dmd case_bndr (Alt con bndrs rhs)-  | WithDmdType rhs_ty rhs' <- dmdAnal env dmd rhs-  , WithDmdType alt_ty dmds <- findBndrsDmds env rhs_ty bndrs-  , let (_ :* case_bndr_sd) = findIdDemand alt_ty case_bndr-        -- See Note [Demand on case-alternative binders]-        -- we can't use the scrut_sd, because it says 'Prod' and we'll use-        -- topSubDmd anyway for scrutinees of sum types.-        (!_scrut_sd, dmds') = addCaseBndrDmd case_bndr_sd dmds-        -- Do not put a thunk into the Alt-        !new_ids            = setBndrsDemandInfo bndrs dmds'-  = WithDmdType alt_ty (Alt con new_ids rhs')---- Precondition: The SubDemand is not a Call--- See Note [Demand on the scrutinee of a product case]--- and Note [Demand on case-alternative binders]-addCaseBndrDmd :: SubDemand -- On the case binder-               -> [Demand]  -- On the fields of the constructor-               -> (SubDemand, [Demand])-                            -- SubDemand on the case binder incl. field demands-                            -- and final demands for the components of the constructor-addCaseBndrDmd case_sd fld_dmds-  | Just (_, ds) <- viewProd (length fld_dmds) scrut_sd-  = (scrut_sd, ds)-  | otherwise-  = pprPanic "was a call demand" (ppr case_sd $$ ppr fld_dmds) -- See the Precondition-  where-    scrut_sd = case_sd `plusSubDmd` mkProd Unboxed fld_dmds--{--Note [Analysing with absent demand]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose we analyse an expression with demand A.  The "A" means-"absent", so this expression will never be needed. What should happen?-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.--* Nevertheless, which sub-demand should we pick for analysis?-  Since the demand was absent, any would do. Worker/wrapper will replace-  absent bindings with an absent filler anyway, so annotations in the RHS-  of an absent binding don't matter much.-  Picking 'botSubDmd' would be the most useful, but would also look a bit-  misleading in the Core output of DmdAnal, because all nested annotations would-  be bottoming. Better pick 'seqSubDmd', so that we annotate many of those-  nested bindings with A themselves.--* In a previous incarnation of GHC we needed to be extra careful in the-  case of an *unlifted type*, because unlifted values are evaluated-  even if they are not used.  Example (see #9254):-     f :: (() -> (# Int#, () #)) -> ()-          -- Strictness signature is-          --    <CS(S(A,SU))>-          -- 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.--  However, the argument of toSubDmd always satisfies the let/app-  invariant; so if it is unlifted it is also okForSpeculation, and so-  can be evaluated in a short finite time -- and that rules out nasty-  cases like the one above.  (I'm not quite sure why this was a-  problem in an earlier version of GHC, but it isn't now.)--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 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. 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. 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.--Note [Demand analysis for recursive data constructors]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-T11545 features a single-product, recursive data type-  data A = A A A ... A-    deriving Eq-Naturally, `(==)` is deeply strict in `A` and in fact will never terminate. That-leads to very large (exponential in the depth) demand signatures and fruitless-churn in boxity analysis, demand analysis and worker/wrapper.-So we detect `A` as a recursive data constructor-(see Note [Detecting recursive data constructors]) analysing `case x of A ...`-and simply assume L for the demand on field binders, which is the same code-path as we take for sum types.-Combined with the B demand on the case binder, we get the very small demand-signature <1S><1S>b on `(==)`. This improves ghc/alloc performance on T11545-tenfold! See also Note [CPR for recursive data constructors] which describes the-sibling mechanism in CPR analysis.--Note [Demand on the scrutinee of a product case]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When figuring out the demand on the scrutinee of a product case,-we use the demands of the case alternative, i.e. id_dmds.-But note that these include the demand on the case binder;-see Note [Demand on case-alternative binders].-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 [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 [What are demand signatures?] in "GHC.Types.Demand"-dmdTransform env var sd-  -- Data constructors-  | isDataConWorkId var-  = dmdTransformDataConSig (idArity var) sd-  -- Dictionary component selectors-  -- Used to be controlled by a flag.-  -- See #18429 for some perf measurements.-  | Just _ <- isClassOpId_maybe var-  = -- pprTrace "dmdTransform:DictSel" (ppr var $$ ppr (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 multDmd below: It means we don't-        -- have to track whether @var@ is used strictly or at most-        -- once, because ultimately it never will.-        -> addVarDmd fn_ty var (C_0N `multDmd` (C_11 :* sd)) -- discard strictness-        | 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]) $-    unitDmdType (unitVarEnv var (C_11 :* sd))--{- *********************************************************************-*                                                                      *-                      Binding right-hand sides-*                                                                      *-********************************************************************* -}---- | @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, 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.--- See Note [NOINLINE and strictness]-dmdAnalRhsSig top_lvl rec_flag env let_dmd id rhs-  = -- pprTrace "dmdAnalRhsSig" (ppr id $$ ppr let_dmd $$ ppr rhs_dmds $$ ppr sig $$ ppr lazy_fv) $-    (final_env, lazy_fv, final_id, final_rhs)-  where-    rhs_arity = idArity id-    -- See Note [Demand signatures are computed for a threshold demand based on idArity]--    rhs_dmd = mkCalledOnceDmds rhs_arity body_dmd--    body_dmd-      | isJoinId id-      -- See Note [Demand analysis for join points]-      -- See Note [Invariants on join points] invariant 2b, in GHC.Core-      --     rhs_arity matches the join arity of the join point-      -- See Note [Unboxed demand on function bodies returning small products]-      = unboxedWhenSmall env rec_flag (resultType_maybe id) let_dmd-      | otherwise-      -- See Note [Unboxed demand on function bodies returning small products]-      = unboxedWhenSmall env rec_flag (resultType_maybe id) topSubDmd--    WithDmdType rhs_dmd_ty rhs' = dmdAnal env rhs_dmd rhs-    DmdType rhs_fv rhs_dmds rhs_div = rhs_dmd_ty-    -- See Note [Do not unbox class dictionaries]-    -- See Note [Boxity for bottoming functions]-    (final_rhs_dmds, final_rhs) = finaliseArgBoxities env id rhs_arity rhs' rhs_div-                                  `orElse` (rhs_dmds, rhs')--    sig = mkDmdSigForArity rhs_arity (DmdType sig_fv final_rhs_dmds rhs_div)--    final_id   = id `setIdDmdSig` sig-    !final_env = extendAnalEnv top_lvl env final_id sig--    -- See Note [Aggregated demand for cardinality]-    -- FIXME: That Note doesn't explain the following lines at all. The reason-    --        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_fv1 = case rec_flag of-                Recursive    -> reuseEnv rhs_fv-                NonRecursive -> rhs_fv--    -- See Note [Absence analysis for stable unfoldings and RULES]-    rhs_fv2 = rhs_fv1 `keepAliveDmdEnv` bndrRuleAndUnfoldingIds id--    -- See Note [Lazy and unleashable free variables]-    !(!lazy_fv, !sig_fv) = partitionVarEnv isWeakDmd rhs_fv2---- | The result type after applying 'idArity' many arguments. Returns 'Nothing'--- when the type doesn't have exactly 'idArity' many arrows.-resultType_maybe :: Id -> Maybe Type-resultType_maybe id-  | (pis,ret_ty) <- splitPiTys (idType id)-  , count (not . isNamedBinder) pis == idArity id-  = Just $! ret_ty-  | otherwise-  = Nothing--unboxedWhenSmall :: AnalEnv -> RecFlag -> Maybe Type -> SubDemand -> SubDemand--- See Note [Unboxed demand on function bodies returning small products]-unboxedWhenSmall _   _        Nothing       sd = sd-unboxedWhenSmall env rec_flag (Just ret_ty) sd = go 1 ret_ty sd-  where-    -- Magic constant, bounding the depth of optimistic 'Unboxed' flags. We-    -- might want to minmax in the future.-    max_depth | isRec rec_flag = 3 -- So we get at most something as deep as !P(L!P(L!L))-              | otherwise      = 1 -- Otherwise be unbox too deep in T18109, T18174 and others and get a bunch of stack overflows-    go :: Int -> Type -> SubDemand -> SubDemand-    go depth ty sd-      | depth <= max_depth-      , Just (tc, tc_args, _co) <- normSplitTyConApp_maybe (ae_fam_envs env) ty-      , Just dc <- tyConSingleAlgDataCon_maybe tc-      , null (dataConExTyCoVars dc) -- Can't unbox results with existentials-      , dataConRepArity dc <= dmd_unbox_width (ae_opts env)-      , Just (_, ds) <- viewProd (dataConRepArity dc) sd-      , arg_tys <- map scaledThing $ dataConInstArgTys dc tc_args-      , equalLength ds arg_tys-      = mkProd Unboxed $! strictZipWith (go_dmd (depth+1)) arg_tys ds-      | otherwise-      = sd--    go_dmd :: Int -> Type -> Demand -> Demand-    go_dmd depth ty dmd = case dmd of-      AbsDmd  -> AbsDmd-      BotDmd  -> BotDmd-      n :* sd -> n :* go depth ty sd---- | If given the (local, non-recursive) let-bound 'Id', 'useLetUp' determines--- whether we should process the binding up (body before rhs) or down (rhs--- before body).------ 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.  When analysing a join point, we can-analyse its body with the demand from the entire join-binding (written-let_dmd here).--Another win for join points!  #13543.--However, note that the strictness signature for a join point can-look a little puzzling.  E.g.--    (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 C1(L) context, so j's strictness signature-will be    [A]b-meaning one absent argument, returns bottom.  That seems odd because-there's a \y inside.  But it's right because when consumed in a C1(L)-context the RHS of the join point is indeed bottom.--Note [Demand signatures are computed for a threshold demand based on idArity]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We compute demand signatures assuming idArity incoming arguments to approximate-behavior for when we have a call site with at least that many arguments. 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]).--Because idArity of a function varies independently of its cardinality-properties (cf. Note [idArity varies independently of dmdTypeDepth]), we-implicitly encode the arity for when a demand signature is sound to unleash-in its 'dmdTypeDepth' (cf. Note [Understanding DmdType and DmdSig] in-GHC.Types.Demand). It is unsound to unleash a demand signature when the-incoming number of arguments is less than that.-See Note [What are demand signatures?] in GHC.Types.Demand for more details-on soundness.--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.--There might 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 C1(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 C1(C1(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 [idArity varies independently of dmdTypeDepth]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We used to check in GHC.Core.Lint that dmdTypeDepth <= idArity for a let-bound-identifier. But that means we would have to zap demand signatures every time we-reset or decrease arity. That's an unnecessary dependency, because--  * The demand signature captures a semantic property that is independent of-    what the binding's current arity is-  * idArity is analysis information itself, thus volatile-  * We already *have* dmdTypeDepth, wo why not just use it to encode the-    threshold for when to unleash the signature-    (cf. Note [Understanding DmdType and DmdSig] in GHC.Types.Demand)--Consider the following expression, for example:--    (let go x y = `x` seq ... in go) |> co--`go` might have a strictness signature of `<1L><L>`. The simplifier will identify-`go` as a nullary join point through `joinPointBinding_maybe` and float the-coercion into the binding, leading to an arity decrease:--    join go = (\x y -> `x` seq ...) |> co in go--With the CoreLint check, we would have to zap `go`'s perfectly viable strictness-signature.--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]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Ticket #18638 shows that it's really important to do absence analysis-for stable unfoldings. 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, adjust its DmdEnv (the demands-on its free variables) so that no variable mentioned in its unfolding-is Absent.  This is done by the function Demand.keepAliveDmdEnv.--ALSO: do the same for Ids free in the RHS of any RULES for f.--PS: 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.--Note [Boxity for bottoming functions]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-```hs-indexError :: Show a => (a, a) -> a -> String -> b--- Str=<..><1!P(S,S)><1S><S>b-indexError rng i s = error (show rng ++ show i ++ show s)--get :: (Int, Int) -> Int -> [a] -> a-get p@(l,u) i xs-  | l <= i, i < u = xs !! (i-u)-  | otherwise     = indexError p i "get"-```-The hot path of `get` certainly wants to unbox `p` as well as `l` and `u`, but-the unimportant, diverging error path needs `l` and `u` boxed (although the-wrapper for `indexError` *will* unbox `p`). This pattern often occurs in-performance sensitive code that does bounds-checking.--It would be a shame to let `Boxed` win for the fields! So here's what we do:-While to summarising `indexError`'s boxity signature in `finaliseArgBoxities`,-we `unboxDeeplyDmd` all its argument demands and are careful not to discard-excess boxity in the `StopUnboxing` case, to get the signature-`<1!P(!S,!S)><1!S><S!S>b`.--Then worker/wrapper will not only unbox the pair passed to `indexError` (as it-would do anyway), demand analysis will also pretend that `indexError` needs `l`-and `u` unboxed (and the two other args). Which is a lie, because `indexError`'s-type abstracts over their types and could never unbox them.--The important change is at the *call sites* of `$windexError`: Boxity analysis-will conclude to unbox `l` and `u`, which *will* incur reboxing of crud that-should better float to the call site of `$windexError`. There we don't care-much, because it's in the slow, diverging code path! And that floating often-happens, but not always. See Note [Reboxed crud for bottoming calls].--Note [Reboxed crud for bottoming calls]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-For functions like `get` in Note [Boxity for bottoming functions], it's clear-that the reboxed crud will be floated inside to the call site of `$windexError`.-But here's an example where that is not the case:-```hs-import GHC.Ix--theresCrud :: Int -> Int -> Int-theresCrud x y = go x-  where-    go 0 = index (0,y) 0-    go 1 = index (x,y) 1-    go n = go (n-1)-    {-# NOINLINE theresCrud #-}-```-If you look at the Core, you'll see that `y` will be reboxed and used in the-two exit join points for the `$windexError` calls, while `x` is only reboxed in the-exit join point for `index (x,y) 1` (happens in lvl below):-```-$wtheresCrud = \ ww ww1 ->-      let { y = I# ww1 } in-      join { lvl2 = ... case lvl1 ww y of wild { }; ... } in-      join { lvl3 = ... case lvl y of wild { }; ... } in-      ...-```-This is currently a bug that we willingly accept and it's documented in #21128.--}--{- *********************************************************************-*                                                                      *-             Finalising boxity-*                                                                      *-********************************************************************* -}--{- Note [Finalising boxity for demand signatures]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The worker/wrapper pass must strictly adhere to the boxity decisions-encoded in the demand signature, because that is the information that-demand analysis propagates throughout the program. Failing to-implement the strategy laid out in the signature can result in-reboxing in unexpected places. Hence, we must completely anticipate-unboxing decisions during demand analysis and reflect these decicions-in demand annotations. That is the job of 'finaliseArgBoxities',-which is defined here and called from demand analysis.--Here is a list of different Notes it has to take care of:--  * Note [No lazy, Unboxed demands in demand signature] such as `L!P(L)` in-    general, but still allow Note [Unboxing evaluated arguments]-  * Note [No nested Unboxed inside Boxed in demand signature] such as `1P(1!L)`-  * Implement fixes for corner cases Note [Do not unbox class dictionaries]-    and Note [mkWWstr and unsafeCoerce]--Then, in worker/wrapper blindly trusts the boxity info in the demand signature-and will not look at strictness info *at all*, in 'wantToUnboxArg'.--Note [Finalising boxity for let-bound Ids]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-  let x = e in body-where the demand on 'x' is 1!P(blah).  We want to unbox x according to-Note [Thunk splitting] in GHC.Core.Opt.WorkWrap.  We must do this becuase-worker/wrapper ignores stricness and looks only at boxity flags; so if-x's demand is L!P(blah) we might still split it (wrongly).  We want to-switch to Boxed on any lazy demand.--That is what finaliseLetBoxity does.  It has no worker-arg budget, so it-is much simpler than finaliseArgBoxities.--Note [No nested Unboxed inside Boxed in demand signature]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-```-f p@(x,y)-  | even (x+y) = []-  | otherwise  = [p]-```-Demand analysis will infer that the function body puts a demand of `1P(1!L,1!L)`-on 'p', e.g., Boxed on the outside but Unboxed on the inside. But worker/wrapper-can't unbox the pair components without unboxing the pair! So we better say-`1P(1L,1L)` in the demand signature in order not to spread wrong Boxity info.-That happens via the call to trimBoxity in 'finaliseArgBoxities'/'finaliseLetBoxity'.--Note [No lazy, Unboxed demands in demand signature]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-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 'wantToUnboxArg' for its unboxing decision. It will-  /not/ look at the strictness bits of the demand, only at Boxity flags. As such,-  it will happily unbox 'a' despite the lazy demand on it.--The net effect is that boxity analysis and the w/w transformation are more-aggressive about unboxing the strict arguments of a data constructor than when-looking at strictness info exclusively. It is very much like (Nested) CPR, which-needs its nested fields to be evaluated in order for it to unbox nestedly.--There is the usual danger of reboxing, which as usual we ignore. But-if X is monomorphic, and has an UNPACK pragma, then this optimisation-is even more important.  We don't want the wrapper to rebox an unboxed-argument, and pass an Int to $wfoo!--This works in nested situations like T10482--    data family Bar a-    data instance Bar (a, b) = BarPair !(Bar a) !(Bar b)-    newtype instance Bar Int = Bar Int--    foo :: Bar ((Int, Int), Int) -> Int -> Int-    foo f k = case f of BarPair x y ->-              case burble of-                 True -> case x of-                           BarPair p q -> ...-                 False -> ...--The extra eagerness lets us produce a worker of type:-     $wfoo :: Int# -> Int# -> Int# -> Int -> Int-     $wfoo p# q# y# = ...--even though the `case x` is only lazily evaluated.----------- Historical note -------------We used to add data-con strictness demands when demand analysing case-expression. However, it was noticed in #15696 that this misses some cases. For-instance, consider the program (from T10482)--    data family Bar a-    data instance Bar (a, b) = BarPair !(Bar a) !(Bar b)-    newtype instance Bar Int = Bar Int--    foo :: Bar ((Int, Int), Int) -> Int -> Int-    foo f k =-      case f of-        BarPair x y -> case burble of-                          True -> case x of-                                    BarPair p q -> ...-                          False -> ...--We really should be able to assume that `p` is already evaluated since it came-from a strict field of BarPair. This strictness would allow us to produce a-worker of type:--    $wfoo :: Int# -> Int# -> Int# -> Int -> Int-    $wfoo p# q# y# = ...--even though the `case x` is only lazily evaluated--Indeed before we fixed #15696 this would happen since we would float the inner-`case x` through the `case burble` to get:--    foo f k =-      case f of-        BarPair x y -> case x of-                          BarPair p q -> case burble of-                                          True -> ...-                                          False -> ...--However, after fixing #15696 this could no longer happen (for the reasons-discussed in ticket:15696#comment:76). This means that the demand placed on `f`-would then be significantly weaker (since the False branch of the case on-`burble` is not strict in `p` or `q`).--Consequently, we now instead account for data-con strictness in mkWWstr_one,-applying the strictness demands to the final result of DmdAnal. The result is-that we get the strict demand signature we wanted even if we can't float-the case on `x` up through the case on `burble`.--Note [Do not unbox class dictionaries]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If we have-   f :: Ord a => [a] -> Int -> a-   {-# INLINABLE f #-}-and we worker/wrapper f, we'll get a worker with an INLINABLE pragma-(see Note [Worker/wrapper for INLINABLE functions] in GHC.Core.Opt.WorkWrap),-which can still be specialised by the type-class specialiser, something like-   fw :: Ord a => [a] -> Int# -> a--BUT if f is strict in the Ord dictionary, we might unpack it, to get-   fw :: (a->a->Bool) -> [a] -> Int# -> a-and the type-class specialiser can't specialise that. An example is #6056.--But in any other situation, a dictionary is just an ordinary value,-and can be unpacked.  So we track the INLINABLE pragma, and discard the boxity-flag in finaliseArgBoxities (see the isClassPred test).--Historical note: #14955 describes how I got this fix wrong the first time.--Note that the simplicity of this fix implies that INLINE functions (such as-wrapper functions after the WW run) will never say that they unbox class-dictionaries. That's not ideal, but not worth losing sleep over, as INLINE-functions will have been inlined by the time we run demand analysis so we'll-see the unboxing around the worker in client modules. I got aware of the issue-in T5075 by the change in boxity of loop between demand analysis runs.--Note [Worker argument budget]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In 'finaliseArgBoxities' we don't want to generate workers with zillions of-argument when, say given a strict record with zillions of fields.  So we-limit the maximum number of worker args to the maximum of-  - -fmax-worker-args=N-  - The number of args in the original function; if it already has has-    zillions of arguments we don't want to seek /fewer/ args in the worker.-(Maybe we should /add/ them instead of maxing?)--We pursue a "layered" strategy for unboxing: we unbox the top level of the-argument(s), subject to budget; if there are any arguments left we unbox the-next layer, using that depleted budget.--To achieve this, we use the classic almost-circular programming technique in-which we we write one pass that takes a lazy list of the Budgets for every-layer.--Note [The OPAQUE pragma and avoiding the reboxing of arguments]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In https://gitlab.haskell.org/ghc/ghc/-/issues/13143 it was identified that when-a function 'f' with a NOINLINE pragma is W/W transformed, then the worker for-'f' should get the NOINLINE annotation, while the wrapper /should/ be inlined.--That's because if the wrapper for 'f' had stayed NOINLINE, then any worker of a-W/W-transformed /caller of/ 'f' would immediately rebox any unboxed arguments-that is applied to the wrapper of 'f'. When the wrapper is inlined, that kind of-reboxing does not happen.--But now we have functions with OPAQUE pragmas, which by definition (See Note-[OPAQUE pragma]) do not get W/W-transformed. So in order to avoid reboxing-workers of any W/W-transformed /callers of/ 'f' we need to strip all boxity-information from 'f' in the demand analysis. This will inform the-W/W-transformation code that boxed arguments of 'f' must definitely be passed-along in boxed form and as such dissuade the creation of reboxing workers.--}--data Budgets = MkB Arity Budgets   -- An infinite list of arity budgets--incTopBudget :: Budgets -> Budgets-incTopBudget (MkB n bg) = MkB (n+1) bg--positiveTopBudget :: Budgets -> Bool-positiveTopBudget (MkB n _) = n >= 0--finaliseArgBoxities :: AnalEnv -> Id -> Arity -> CoreExpr -> Divergence-                    -> Maybe ([Demand], CoreExpr)-finaliseArgBoxities env fn arity rhs div-  | arity > count isId bndrs  -- Can't find enough binders-  = Nothing  -- This happens if we have   f = g-             -- Then there are no binders; we don't worker/wrapper; and we-             -- simply want to give f the same demand signature as g--  | otherwise-  = Just (arg_dmds', add_demands arg_dmds' rhs)-    -- add_demands: we must attach the final boxities to the lambda-binders-    -- of the function, both because that's kosher, and because CPR analysis-    -- uses the info on the binders directly.-  where-    opts            = ae_opts env-    fam_envs        = ae_fam_envs env-    is_inlinable_fn = isStableUnfolding (realIdUnfolding fn)-    (bndrs, _body)  = collectBinders rhs-    max_wkr_args    = dmd_max_worker_args opts `max` arity-                      -- See Note [Worker argument budget]--    -- This is the key line, which uses almost-circular programming-    -- The remaining budget from one layer becomes the initial-    -- budget for the next layer down.  See Note [Worker argument budget]-    (remaining_budget, arg_dmds') = go_args (MkB max_wkr_args remaining_budget) arg_triples--    arg_triples :: [(Type, StrictnessMark, Demand)]-    arg_triples = take arity $-                  map mk_triple $-                  filter isRuntimeVar bndrs--    mk_triple :: Id -> (Type,StrictnessMark,Demand)-    mk_triple bndr | is_cls_arg ty = (ty, NotMarkedStrict, trimBoxity dmd)-                   | is_bot_fn     = (ty, NotMarkedStrict, unboxDeeplyDmd dmd)-                   -- See Note [OPAQUE pragma]-                   -- See Note [The OPAQUE pragma and avoiding the reboxing of arguments]-                   | is_opaque     = (ty, NotMarkedStrict, trimBoxity dmd)-                   | otherwise     = (ty, NotMarkedStrict, dmd)-                   where-                     ty        = idType bndr-                     dmd       = idDemandInfo bndr-                     is_opaque = isOpaquePragma (idInlinePragma fn)--    -- is_cls_arg: see Note [Do not unbox class dictionaries]-    is_cls_arg arg_ty = is_inlinable_fn && isClassPred arg_ty-    -- is_bot_fn:  see Note [Boxity for bottoming functions]-    is_bot_fn         = div == botDiv--    go_args :: Budgets -> [(Type,StrictnessMark,Demand)] -> (Budgets, [Demand])-    go_args bg triples = mapAccumL go_arg bg triples--    go_arg :: Budgets -> (Type,StrictnessMark,Demand) -> (Budgets, Demand)-    go_arg bg@(MkB bg_top bg_inner) (ty, str_mark, dmd@(n :* _))-      = case wantToUnboxArg False fam_envs ty dmd of-          StopUnboxing-            | not is_bot_fn-                -- If bot: Keep deep boxity even though WW won't unbox-                -- See Note [Boxity for bottoming functions]-            -> (MkB (bg_top-1) bg_inner, trimBoxity dmd)--          Unbox DataConPatContext{dcpc_dc=dc, dcpc_tc_args=tc_args} dmds-            -> (MkB (bg_top-1) final_bg_inner, final_dmd)-            where-              dc_arity = dataConRepArity dc-              arg_tys  = dubiousDataConInstArgTys dc tc_args-              (bg_inner', dmds') = go_args (incTopBudget bg_inner) $-                                   zip3 arg_tys (dataConRepStrictness dc) dmds-              dmd' = n :* (mkProd Unboxed $! dmds')-              (final_bg_inner, final_dmd)-                  | dmds `lengthIs` dc_arity-                  , isStrict n || isMarkedStrict str_mark-                     -- isStrict: see Note [No lazy, Unboxed demands in demand signature]-                     -- isMarkedStrict: see Note [Unboxing evaluated arguments]-                  , positiveTopBudget bg_inner'-                  , NonRecursiveOrUnsure <- ae_rec_dc env dc-                     -- See Note [Which types are unboxed?]-                     -- and Note [Demand analysis for recursive data constructors]-                  = (bg_inner', dmd')-                  | otherwise-                  = (bg_inner, trimBoxity dmd)-          _ -> (bg, dmd)--    add_demands :: [Demand] -> CoreExpr -> CoreExpr-    -- Attach the demands to the outer lambdas of this expression-    add_demands [] e = e-    add_demands (dmd:dmds) (Lam v e)-      | isTyVar v = Lam v (add_demands (dmd:dmds) e)-      | otherwise = Lam (v `setIdDemandInfo` dmd) (add_demands dmds e)-    add_demands dmds e = pprPanic "add_demands" (ppr dmds $$ ppr e)--finaliseLetBoxity-  :: FamInstEnvs-  -> Type                   -- ^ Type of the let-bound Id-  -> Demand                 -- ^ How the Id is used-  -> Demand--- See Note [Finalising boxity for let-bound Ids]--- This function is like finaliseArgBoxities, but much simpler because--- it has no "budget".  It simply unboxes strict demands, and stops--- when it reaches a lazy one.-finaliseLetBoxity env ty dmd-  = go ty NotMarkedStrict dmd-  where-    go ty mark dmd@(n :* _) =-      case wantToUnboxArg False env ty dmd of-        DropAbsent   -> dmd-        StopUnboxing -> trimBoxity dmd-        Unbox DataConPatContext{dcpc_dc=dc, dcpc_tc_args=tc_args} dmds-          | isStrict n || isMarkedStrict mark-          , dmds `lengthIs` dataConRepArity dc-          , let arg_tys = dubiousDataConInstArgTys dc tc_args-                dmds'   = strictZipWith3 go arg_tys (dataConRepStrictness dc) dmds-          -> n :* (mkProd Unboxed $! dmds')-          | otherwise-          -> trimBoxity dmd-        Unlift -> panic "No unlifting in DmdAnal"---{- *********************************************************************-*                                                                      *-                      Fixpoints-*                                                                      *-********************************************************************* -}---- Recursive bindings-dmdFix :: TopLevelFlag-       -> AnalEnv                            -- Does not include bindings for this binding-       -> SubDemand-       -> [(Id,CoreExpr)]-       -> (AnalEnv, DmdEnv, [(Id,CoreExpr)]) -- Binders annotated with strictness info--dmdFix top_lvl env let_dmd orig_pairs-  = loop 1 initial_pairs-  where-    -- See Note [Initialising strictness]-    initial_pairs | ae_virgin env = [(setIdDmdSig id botSig, rhs) | (id, rhs) <- orig_pairs ]-                  | otherwise     = orig_pairs--    -- If fixed-point iteration does not yield a result we use this instead-    -- See Note [Safe abortion in the fixed-point iteration]-    abort :: (AnalEnv, DmdEnv, [(Id,CoreExpr)])-    abort = (env, lazy_fv', zapped_pairs)-      where (lazy_fv, pairs') = step True (zapIdDmdSig orig_pairs)-            -- Note [Lazy and unleashable free variables]-            non_lazy_fvs = plusVarEnvList $ map (dmdSigDmdEnv . idDmdSig . fst) pairs'-            lazy_fv'     = lazy_fv `plusVarEnv` mapVarEnv (const topDmd) non_lazy_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, DmdEnv, [(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, lazy_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-        (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), emptyVarEnv)--        !((_,!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)-          = -- pprTrace "my_downRhs" (ppr id $$ ppr (idDmdSig id) $$ ppr sig) $-            ((env', lazy_fv'), (id', rhs'))-          where-            !(!env', !lazy_fv1, !id', !rhs') = dmdAnalRhsSig top_lvl Recursive env let_dmd id rhs-            !lazy_fv'                    = plusVarEnv_C plusDmd lazy_fv lazy_fv1--    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 botttom 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 recrusive.-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-*                                                                      *-********************************************************************* -}--unitDmdType :: DmdEnv -> DmdType-unitDmdType dmd_env = DmdType dmd_env [] topDiv--coercionDmdEnv :: Coercion -> DmdEnv-coercionDmdEnv co = coercionsDmdEnv [co]--coercionsDmdEnv :: [Coercion] -> DmdEnv-coercionsDmdEnv cos = mapVarEnv (const topDmd) (getUniqSet $ coVarsOfCos cos)-                      -- The VarSet from coVarsOfCos is really a VarEnv Var--addVarDmd :: DmdType -> Var -> Demand -> DmdType-addVarDmd (DmdType fv ds res) var dmd-  = DmdType (extendVarEnv_C plusDmd fv var dmd) ds res--addLazyFVs :: DmdType -> DmdEnv -> DmdType-addLazyFVs dmd_ty lazy_fvs-  = dmd_ty `plusDmdType` mkPlusDmdArg lazy_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 lazy_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.--{--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 :: HasCallStack => [Var] -> [Demand] -> [Var]-setBndrsDemandInfo (b:bs) ds-  | isTyVar b = b : setBndrsDemandInfo bs ds-setBndrsDemandInfo (b:bs) (d:ds) =-    let !new_info = setIdDemandInfo b d-        !vars = setBndrsDemandInfo bs ds-    in new_info : vars-setBndrsDemandInfo [] ds = assert (null ds) []-setBndrsDemandInfo 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 "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".---************************************************************************-*                                                                      *-\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)-         }--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, (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--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 dictionaries strict]-      | dmd_strict_dicts (ae_opts env)-             -- We never want to strictify a recursive let. At the moment-             -- findBndrDmd is never called for recursive lets; if that-             -- changes, we need a RecFlag parameter and another guard here.-      = strictifyDictDmd id_ty dmd-      | otherwise-      = dmd--    fam_envs = ae_fam_envs env--{- Note [Making dictionaries strict]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The Opt_DictsStrict flag makes GHC use call-by-value for dictionaries.  Why?--* Generally CBV is more efficient.--* Dictionaries are always non-bottom; and never take much work to-  compute.  E.g. a dfun from an instance decl always returns a dicionary-  record immediately.  See DFunUnfolding in CoreSyn.-  See also Note [Recursive superclasses] in TcInstDcls.--* The strictness analyser will then unbox dictionaries and pass the-  methods individually, rather than in a bundle.  If there are a lot of-  methods that might be bad; but worker/wrapper already does throttling.--* A newtype dictionary is *not* always non-bottom.  E.g.-      class C a where op :: a -> a-      instance C Int where op = error "urk"-  Now a value of type (C Int) is just a newtype wrapper (a cast) around-  the error thunk.  Don't strictify these!--See #17758 for more background and perf numbers.--The implementation is extremly simple: just make the strictness-analyser strictify the demand on a dictionary binder in-'findBndrDmd'.--However there is one case where this can make performance worse.-For the principle consider some function at the core level:-    myEq :: Eq a => a -> a -> Bool-    myEq eqDict x y = ((==) eqDict) x y-If we make the dictionary strict then WW can fire turning this into:-    $wmyEq :: (a -> a -> Bool) -> a -> a -> Bool-    $wmyEq eq x y = eq x y-Which *usually* performs better. However if the dictionary is known we-are far more likely to inline a function applied to the dictionary than-to inline one applied to a function. Sometimes this makes just enough-of a difference to stop a function from inlining. This is documented in #18421.--It's somewhat similar to Note [Do not unbox class dictionaries] although-here our problem is with the inliner, not the specializer.--Note [Initialising strictness]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-See section 9.2 (Finding fixpoints) of the paper.--Our basic plan is to initialise the strictness of each Id in a-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 (CM(..)) /can/ be+import GHC.Types.Demand   -- All of it++import GHC.Core+import GHC.Core.DataCon+import GHC.Core.Utils+import GHC.Core.TyCon+import GHC.Core.Type+import GHC.Core.FVs      ( rulesRhsFreeIds, bndrRuleAndUnfoldingIds )+import GHC.Core.Coercion ( Coercion )+import GHC.Core.TyCo.FVs     ( coVarsOfCos )+import GHC.Core.TyCo.Compare ( eqType )+import GHC.Core.Multiplicity ( scaledThing )+import GHC.Core.FamInstEnv+import GHC.Core.Opt.Arity ( typeArity )+import GHC.Core.Opt.WorkWrap.Utils++import GHC.Builtin.Names+import GHC.Builtin.PrimOps+import GHC.Builtin.Types.Prim ( realWorldStatePrimTy )++import GHC.Types.Unique.Set+import GHC.Types.Unique.MemoFun+import GHC.Types.RepType+import GHC.Types.ForeignCall ( isSafeForeignCall )+import GHC.Types.Id+import GHC.Types.Var.Env+import GHC.Types.Var.Set+import GHC.Types.Basic++import GHC.Utils.Misc+import GHC.Utils.Panic+import GHC.Utils.Outputable++import Data.List        ( mapAccumL )++{-+************************************************************************+*                                                                      *+\subsection{Top level stuff}+*                                                                      *+************************************************************************+-}++-- | Options for the demand analysis+data DmdAnalOpts = DmdAnalOpts+   { dmd_strict_dicts    :: !Bool+   -- ^ Value of `-fdicts-strict` (on by default).+   -- When set, all functons are implicitly strict in dictionary args.+   , dmd_do_boxity       :: !Bool+   -- ^ Governs whether the analysis should update boxity signatures.+   -- See Note [Don't change boxity without worker/wrapper].+   , dmd_unbox_width     :: !Int+   -- ^ Value of `-fdmd-unbox-width`.+   -- See Note [Unboxed demand on function bodies returning small products]+   , dmd_max_worker_args :: !Int+   -- ^ Value of `-fmax-worker-args`.+   -- Don't unbox anything if we end up with more than this many args.+   }++-- This is a strict alternative to (,)+-- See Note [Space Leaks in Demand Analysis]+data WithDmdType a = WithDmdType !DmdType !a++getAnnotated :: WithDmdType a -> a+getAnnotated (WithDmdType _ a) = a++data DmdResult a b = R !a !b++-- | Outputs a new copy of the Core program in which binders have been annotated+-- with demand and strictness information.+--+-- Note: use `seqBinds` on the result to avoid leaks due to laziness (cf Note+-- [Stamp out space leaks in demand analysis])+dmdAnalProgram :: DmdAnalOpts -> FamInstEnvs -> [CoreRule] -> CoreProgram -> CoreProgram+dmdAnalProgram opts fam_envs rules binds+  = getAnnotated $ go (emptyAnalEnv opts fam_envs) binds+  where+    -- See Note [Analysing top-level bindings]+    -- and Note [Why care for top-level demand annotations?]+    go _   []     = WithDmdType nopDmdType []+    go env (b:bs) = cons_up $ dmdAnalBind TopLevel env topSubDmd b anal_body+      where+        anal_body env'+          | WithDmdType body_ty bs' <- go env' bs+          = WithDmdType (body_ty `plusDmdType` keep_alive_roots env' (bindersOf b)) bs'++    cons_up :: WithDmdType (DmdResult b [b]) -> WithDmdType [b]+    cons_up (WithDmdType dmd_ty (R b' bs')) = WithDmdType dmd_ty (b' : bs')++    keep_alive_roots :: AnalEnv -> [Id] -> DmdEnv+    -- See Note [Absence analysis for stable unfoldings and RULES]+    -- Here we keep alive "roots", e.g., exported ids and stuff mentioned in+    -- orphan RULES+    keep_alive_roots env ids = plusDmdEnvs (map (demandRoot env) (filter is_root ids))++    is_root :: Id -> Bool+    is_root id = isExportedId id || elemVarSet id rule_fvs++    rule_fvs :: IdSet+    rule_fvs = rulesRhsFreeIds rules++demandRoot :: AnalEnv -> Id -> DmdEnv+-- See Note [Absence analysis for stable unfoldings and RULES]+demandRoot env id = fst (dmdAnalStar env topDmd (Var id))++demandRoots :: AnalEnv -> [Id] -> DmdEnv+-- See Note [Absence analysis for stable unfoldings and RULES]+demandRoots env roots = plusDmdEnvs (map (demandRoot env) roots)++demandRootSet :: AnalEnv -> IdSet -> DmdEnv+demandRootSet env ids = demandRoots env (nonDetEltsUniqSet ids)+  -- It's OK to use nonDetEltsUniqSet here because plusDmdType is commutative++-- | We attach useful (e.g. not 'topDmd') 'idDemandInfo' to top-level bindings+-- that satisfy this function.+--+-- Basically, we want to know how top-level *functions* are *used*+-- (e.g. called). The information will always be lazy.+-- Any other top-level bindings are boring.+--+-- See also Note [Why care for top-level demand annotations?].+isInterestingTopLevelFn :: Id -> Bool+-- SG tried to set this to True and got a +2% ghc/alloc regression in T5642+-- (which is dominated by the Simplifier) at no gain in analysis precision.+-- If there was a gain, that regression might be acceptable.+-- Plus, we could use LetUp for thunks and share some code with local let+-- bindings.+isInterestingTopLevelFn id = typeArity (idType id) > 0++{- Note [Stamp out space leaks in demand analysis]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The demand analysis pass outputs a new copy of the Core program in+which binders have been annotated with demand and strictness+information. It's tiresome to ensure that this information is fully+evaluated everywhere that we produce it, so we just run a single+seqBinds over the output before returning it, to ensure that there are+no references holding on to the input Core program.++This makes a ~30% reduction in peak memory usage when compiling+DynFlags (cf #9675 and #13426).++This is particularly important when we are doing late demand analysis,+since we don't do a seqBinds at any point thereafter. Hence code+generation would hold on to an extra copy of the Core program, via+unforced thunks in demand or strictness information; and it is the+most memory-intensive part of the compilation process, so this added+seqBinds makes a big difference in peak memory usage.++Note [Don't change boxity without worker/wrapper]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider (T21754)+  f n = n+1+  {-# NOINLINE f #-}+With `-fno-worker-wrapper`, we should not give `f` a boxity signature that says+that it unboxes its argument! Client modules would never be able to cancel away+the box for n. Likewise we shouldn't give `f` the CPR property.++Similarly, in the last run of DmdAnal before codegen (which does not have a+worker/wrapper phase) we should not change boxity in any way. Remember: an+earlier result of the demand analyser, complete with worker/wrapper, has aleady+given a demand signature (with boxity info) to the function.+(The "last run" is mainly there to attach demanded-once info to let-bindings.)++In general, we should not run Note [Boxity analysis] unless worker/wrapper+follows to exploit the boxity and make sure that calling modules can observe the+reported boxity.++Hence DmdAnal is configured by a flag `dmd_do_boxity` that is True only+if worker/wrapper follows after DmdAnal. If it is not set, and the signature+is not subject to Note [Boxity for bottoming functions], DmdAnal tries+to transfer over the previous boxity to the new demand signature, in+`setIdDmdAndBoxSig`.++Why isn't CprAnal configured with a similar flag? Because if we aren't going to+do worker/wrapper we don't run CPR analysis at all. (see GHC.Core.Opt.Pipeline)++It might be surprising that we only try to preserve *arg* boxity, not boxity on+FVs. But FV demands won't make it into interface files anyway, so it's a waste+of energy.+Besides, W/W zaps the `DmdEnv` portion of a signature, so we don't know the old+boxity to begin with; see Note [Zapping DmdEnv after Demand Analyzer].++Note [Analysing top-level bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider a CoreProgram like+  e1 = ...+  n1 = ...+  e2 = \a b -> ... fst (n1 a b) ...+  n2 = \c d -> ... snd (e2 c d) ...+  ...+where e* are exported, but n* are not.+Intuitively, we can see that @n1@ is only ever called with two arguments+and in every call site, the first component of the result of the call+is evaluated. Thus, we'd like it to have idDemandInfo @LC(L,C(M,P(1L,A))@.+NB: We may *not* give e2 a similar annotation, because it is exported and+external callers might use it in arbitrary ways, expressed by 'topDmd'.+This can then be exploited by Nested CPR and eta-expansion,+see Note [Why care for top-level demand annotations?].++How do we get this result? Answer: By analysing the program as if it was a let+expression of this form:+  let e1 = ... in+  let n1 = ... in+  let e2 = ... in+  let n2 = ... in+  (e1,e2, ...)+E.g. putting all bindings in nested lets and returning all exported binders in a tuple.+Of course, we will not actually build that CoreExpr! Instead we faithfully+simulate analysis of said expression by adding the free variable 'DmdEnv'+of @e*@'s strictness signatures to the 'DmdType' we get from analysing the+nested bindings.++And even then the above form blows up analysis performance in T10370:+If @e1@ uses many free variables, we'll unnecessarily carry their demands around+with us from the moment we analyse the pair to the moment we bubble back up to+the binding for @e1@. So instead we analyse as if we had+  let e1 = ... in+  (e1, let n1 = ... in+  (    let e2 = ... in+  (e2, let n2 = ... in+  (    ...))))+That is, a series of right-nested pairs, where the @fst@ are the exported+binders of the last enclosing let binding and @snd@ continues the nested+lets.++Variables occurring free in RULE RHSs are to be handled the same as exported Ids.+See also Note [Absence analysis for stable unfoldings and RULES].++Note [Why care for top-level demand annotations?]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Reading Note [Analysing top-level bindings], you might think that we go through+quite some trouble to get useful demands for top-level bindings. They can never+be strict, for example, so why bother?++First, we get to eta-expand top-level bindings that we weren't able to+eta-expand before without Call Arity. From T18894b:+  module T18894b (f) where+  eta :: Int -> Int -> Int+  eta x = if fst (expensive x) == 13 then \y -> ... else \y -> ...+  f m = ... eta m 2 ... eta 2 m ...+Since only @f@ is exported, we see all call sites of @eta@ and can eta-expand to+arity 2.++The call demands we get for some top-level bindings will also allow Nested CPR+to unbox deeper. From T18894:+  module T18894 (h) where+  g m n = (2 * m, 2 `div` n)+  {-# NOINLINE g #-}+  h :: Int -> Int+  h m = ... snd (g m 2) ... uncurry (+) (g 2 m) ...+Only @h@ is exported, hence we see that @g@ is always called in contexts were we+also force the division in the second component of the pair returned by @g@.+This allows Nested CPR to evaluate the division eagerly and return an I# in its+position.+-}++{-+************************************************************************+*                                                                      *+\subsection{The analyser itself}+*                                                                      *+************************************************************************+-}++-- | Analyse a binding group and its \"body\", e.g. where it is in scope.+--+-- It calls a function that knows how to analyse this \"body\" given+-- an 'AnalEnv' with updated demand signatures for the binding group+-- (reflecting their 'idDmdSigInfo') and expects to receive a+-- 'DmdType' in return, which it uses to annotate the binding group with their+-- 'idDemandInfo'.+dmdAnalBind+  :: TopLevelFlag+  -> AnalEnv+  -> SubDemand                 -- ^ Demand put on the "body"+                               --   (important for join points)+  -> CoreBind+  -> (AnalEnv -> WithDmdType a) -- ^ How to analyse the "body", e.g.+                               --   where the binding is in scope+  -> WithDmdType (DmdResult CoreBind a)+dmdAnalBind top_lvl env dmd bind anal_body = case bind of+  NonRec id rhs+    | useLetUp top_lvl id+    -> dmdAnalBindLetUp   top_lvl env_rhs     id rhs anal_body+  _ -> dmdAnalBindLetDown top_lvl env_rhs dmd bind   anal_body+  where+    env_rhs = enterDFun bind env++-- | Annotates uninteresting top level functions ('isInterestingTopLevelFn')+-- with 'topDmd', the rest with the given demand.+setBindIdDemandInfo :: TopLevelFlag -> Id -> Demand -> Id+setBindIdDemandInfo top_lvl id dmd = setIdDemandInfo id $ case top_lvl of+  TopLevel | not (isInterestingTopLevelFn id) -> topDmd+  _                                           -> dmd++-- | Update the demand signature, but be careful not to change boxity info if+-- `dmd_do_boxity` is True or if the signature is bottom.+-- See Note [Don't change boxity without worker/wrapper]+-- and Note [Boxity for bottoming functions].+setIdDmdAndBoxSig :: DmdAnalOpts -> Id -> DmdSig -> Id+setIdDmdAndBoxSig opts id sig = setIdDmdSig id $+  if dmd_do_boxity opts || isBottomingSig sig+    then sig+    else transferArgBoxityDmdSig (idDmdSig id) sig++-- | Let bindings can be processed in two ways:+-- Down (RHS before body) or Up (body before RHS).+-- This function handles the up variant.+--+-- It is very simple. For  let x = rhs in body+--   * Demand-analyse 'body' in the current environment+--   * Find the demand, 'rhs_dmd' placed on 'x' by 'body'+--   * Demand-analyse 'rhs' in 'rhs_dmd'+--+-- This is used for a non-recursive local let without manifest lambdas (see+-- 'useLetUp').+--+-- This is the LetUp rule in the paper “Higher-Order Cardinality Analysis”.+dmdAnalBindLetUp :: TopLevelFlag+                 -> AnalEnv+                 -> Id+                 -> CoreExpr+                 -> (AnalEnv -> WithDmdType a)+                 -> WithDmdType (DmdResult CoreBind a)+dmdAnalBindLetUp top_lvl env id rhs anal_body = WithDmdType final_ty (R (NonRec id' rhs') (body'))+  where+    WithDmdType body_ty body'   = anal_body (addInScopeAnalEnv env id)+    -- See Note [Bringing a new variable into scope]+    WithDmdType body_ty' id_dmd = findBndrDmd env body_ty id+    -- See Note [Finalising boxity for demand signatures]++    id_dmd'            = finaliseLetBoxity env (idType id) id_dmd+    !id'               = setBindIdDemandInfo top_lvl id id_dmd'+    (rhs_ty, rhs')     = dmdAnalStar env id_dmd' rhs++    -- See Note [Absence analysis for stable unfoldings and RULES]+    rule_fvs           = bndrRuleAndUnfoldingIds id+    final_ty           = body_ty' `plusDmdType` rhs_ty `plusDmdType` demandRootSet env rule_fvs++-- | Let bindings can be processed in two ways:+-- Down (RHS before body) or Up (body before RHS).+-- This function handles the down variant.+--+-- It computes a demand signature (by means of 'dmdAnalRhsSig') and uses+-- that at call sites in the body.+--+-- It is used for toplevel definitions, recursive definitions and local+-- non-recursive definitions that have manifest lambdas (cf. 'useLetUp').+-- Local non-recursive definitions without a lambda are handled with LetUp.+--+-- This is the LetDown rule in the paper “Higher-Order Cardinality Analysis”.+dmdAnalBindLetDown :: TopLevelFlag -> AnalEnv -> SubDemand -> CoreBind -> (AnalEnv -> WithDmdType a) -> WithDmdType (DmdResult CoreBind a)+dmdAnalBindLetDown top_lvl env dmd bind anal_body = case bind of+  NonRec id rhs+    | (env', weak_fv, id1, rhs1) <-+        dmdAnalRhsSig top_lvl NonRecursive env dmd id rhs+    -> do_rest env' weak_fv [(id1, rhs1)] (uncurry NonRec . only)+  Rec pairs+    | (env', weak_fv, pairs') <- dmdFix top_lvl env dmd pairs+    -> do_rest env' weak_fv pairs' Rec+  where+    do_rest env' weak_fv pairs1 build_bind = WithDmdType final_ty (R (build_bind pairs2) body')+      where+        WithDmdType body_ty body'        = anal_body env'+        -- see Note [Lazy and unleashable free variables]+        dmd_ty                          = addWeakFVs body_ty weak_fv+        WithDmdType final_ty id_dmds    = findBndrsDmds env' dmd_ty (strictMap fst pairs1)+        -- Important to force this as build_bind might not force it.+        !pairs2                         = strictZipWith do_one pairs1 id_dmds+        do_one (id', rhs') dmd          = ((,) $! setBindIdDemandInfo top_lvl id' dmd) $! rhs'+        -- If the actual demand is better than the vanilla call+        -- demand, you might think that we might do better to re-analyse+        -- the RHS with the stronger demand.+        -- But (a) That seldom happens, because it means that *every* path in+        --         the body of the let has to use that stronger demand+        -- (b) It often happens temporarily in when fixpointing, because+        --     the recursive function at first seems to place a massive demand.+        --     But we don't want to go to extra work when the function will+        --     probably iterate to something less demanding.+        -- In practice, all the times the actual demand on id2 is more than+        -- the vanilla call demand seem to be due to (b).  So we don't+        -- bother to re-analyse the RHS.++-- | Mimic the effect of 'GHC.Core.Prep.mkFloat', turning non-trivial argument+-- expressions/RHSs into a proper let-bound thunk (lifted) or a case (with+-- unlifted scrutinee).+anticipateANF :: CoreExpr -> Card -> Card+anticipateANF e n+  | exprIsTrivial e                               = n -- trivial expr won't have a binding+  | definitelyUnliftedType (exprType e)+  , not (isAbs n && exprOkForSpeculation e)       = case_bind n+  | otherwise                                     = let_bind  n+  where+    case_bind _ = C_11       -- evaluated exactly once+    let_bind    = oneifyCard -- evaluated at most once++-- Do not process absent demands+-- Otherwise act like in a normal demand analysis+-- See ↦* relation in the Cardinality Analysis paper+dmdAnalStar :: AnalEnv+            -> Demand   -- This one takes a *Demand*+            -> CoreExpr+            -> (DmdEnv, CoreExpr)+dmdAnalStar env (n :* sd) e+  -- NB: (:*) expands AbsDmd and BotDmd as needed+  | WithDmdType dmd_ty e' <- dmdAnal env sd e+  , n' <- anticipateANF e n+      -- See Note [Anticipating ANF in demand analysis]+      -- and Note [Analysing with absent demand]+  = (multDmdEnv n' (discardArgDmds dmd_ty), e')++-- Main Demand Analysis machinery+dmdAnal, dmdAnal' :: AnalEnv+        -> SubDemand         -- The main one takes a *SubDemand*+        -> CoreExpr -> WithDmdType CoreExpr++dmdAnal env d e = -- pprTrace "dmdAnal" (ppr d <+> ppr e) $+                  dmdAnal' env d e++dmdAnal' _ _ (Lit lit)     = WithDmdType nopDmdType (Lit lit)+dmdAnal' _ _ (Type ty)     = WithDmdType nopDmdType (Type ty) -- Doesn't happen, in fact+dmdAnal' _ _ (Coercion co)+  = WithDmdType (noArgsDmdType (coercionDmdEnv co)) (Coercion co)++dmdAnal' env dmd (Var var)+  = WithDmdType (dmdTransform env var dmd) (Var var)++dmdAnal' env dmd (Cast e co)+  = WithDmdType (dmd_ty `plusDmdType` coercionDmdEnv co) (Cast e' co)+  where+    WithDmdType dmd_ty e' = dmdAnal env dmd e++dmdAnal' env dmd (Tick t e)+  = WithDmdType dmd_ty (Tick t e')+  where+    WithDmdType dmd_ty e' = dmdAnal env dmd e++dmdAnal' env dmd (App fun (Type ty))+  = WithDmdType fun_ty (App fun' (Type ty))+  where+    WithDmdType fun_ty fun' = dmdAnal env dmd fun++-- Lots of the other code is there to make this+-- beautiful, compositional, application rule :-)+dmdAnal' env dmd (App fun arg)+  = -- This case handles value arguments (type args handled above)+    -- Crucially, coercions /are/ handled here, because they are+    -- value arguments (#10288)+    let+        call_dmd          = mkCalledOnceDmd dmd+        WithDmdType fun_ty fun' = dmdAnal env call_dmd fun+        (arg_dmd, res_ty) = splitDmdTy fun_ty+        (arg_ty, arg')    = dmdAnalStar env arg_dmd arg+    in+--    pprTrace "dmdAnal:app" (vcat+--         [ text "dmd =" <+> ppr dmd+--         , text "expr =" <+> ppr (App fun arg)+--         , text "fun dmd_ty =" <+> ppr fun_ty+--         , text "arg dmd =" <+> ppr arg_dmd+--         , text "arg dmd_ty =" <+> ppr arg_ty+--         , text "res dmd_ty =" <+> ppr res_ty+--         , text "overall res dmd_ty =" <+> ppr (res_ty `plusDmdType` arg_ty) ])+    WithDmdType (res_ty `plusDmdType` arg_ty) (App fun' arg')++dmdAnal' env dmd (Lam var body)+  | isTyVar var+  = let+        WithDmdType body_ty body' = dmdAnal (addInScopeAnalEnv env var) dmd body+        -- See Note [Bringing a new variable into scope]+    in+    WithDmdType body_ty (Lam var body')++  | otherwise+  = let (n, body_dmd)    = peelCallDmd dmd+          -- body_dmd: a demand to analyze the body++        WithDmdType body_ty body' = dmdAnal (addInScopeAnalEnv env var) body_dmd body+        -- See Note [Bringing a new variable into scope]+        WithDmdType lam_ty var'   = annotateLamIdBndr env body_ty var+        new_dmd_type = multDmdType n lam_ty+    in+    WithDmdType new_dmd_type (Lam var' body')++dmdAnal' env dmd (Case scrut case_bndr ty [Alt alt_con bndrs rhs])+  -- Only one alternative.+  -- If it's a DataAlt, it should be the only constructor of the type and we+  -- can consider its field demands when analysing the scrutinee.+  | want_precise_field_dmds alt_con+  = let+        rhs_env = addInScopeAnalEnvs env (case_bndr:bndrs)+        -- See Note [Bringing a new variable into scope]+        WithDmdType rhs_ty rhs'           = dmdAnal rhs_env dmd rhs+        WithDmdType alt_ty1 fld_dmds      = findBndrsDmds env rhs_ty bndrs+        WithDmdType alt_ty2 case_bndr_dmd = findBndrDmd env alt_ty1 case_bndr+        !case_bndr'                       = setIdDemandInfo case_bndr case_bndr_dmd++        -- Evaluation cardinality on the case binder is irrelevant and a no-op.+        -- What matters is its nested sub-demand!+        -- NB: If case_bndr_dmd is absDmd, boxity will say Unboxed, which is+        -- what we want, because then `seq` will put a `seqDmd` on its scrut.+        (_ :* case_bndr_sd) = strictifyDmd case_bndr_dmd++        -- Compute demand on the scrutinee+        -- FORCE the result, otherwise thunks will end up retaining the+        -- whole DmdEnv+        !(!bndrs', !scrut_sd)+          | DataAlt _ <- alt_con+          -- See Note [Demand on the scrutinee of a product case]+          , let !scrut_sd = scrutSubDmd case_bndr_sd fld_dmds+          -- See Note [Demand on case-alternative binders]+          , let !fld_dmds' = fieldBndrDmds scrut_sd (length fld_dmds)+          , let !bndrs' = setBndrsDemandInfo bndrs fld_dmds'+          = (bndrs', scrut_sd)+          | otherwise+          -- DEFAULT alts. Simply add demands and discard the evaluation+          -- cardinality, as we evaluate the scrutinee exactly once.+          = assert (null bndrs) (bndrs, case_bndr_sd)++        alt_ty3+          -- See Note [Precise exceptions and strictness analysis] in "GHC.Types.Demand"+          | exprMayThrowPreciseException (ae_fam_envs env) scrut+          = deferAfterPreciseException alt_ty2+          | otherwise+          = alt_ty2++        WithDmdType scrut_ty scrut' = dmdAnal env scrut_sd scrut+        res_ty             = alt_ty3 `plusDmdType` discardArgDmds scrut_ty+    in+--    pprTrace "dmdAnal:Case1" (vcat [ text "scrut" <+> ppr scrut+--                                   , text "dmd" <+> ppr dmd+--                                   , text "case_bndr_dmd" <+> ppr (idDemandInfo case_bndr')+--                                   , text "scrut_sd" <+> ppr scrut_sd+--                                   , text "scrut_ty" <+> ppr scrut_ty+--                                   , text "alt_ty" <+> ppr alt_ty2+--                                   , text "res_ty" <+> ppr res_ty ]) $+    WithDmdType res_ty (Case scrut' case_bndr' ty [Alt alt_con bndrs' rhs'])+    where+      want_precise_field_dmds (DataAlt dc)+        | let tc = dataConTyCon dc+        , assertPpr (not (isNewTyCon tc)) (ppr dc) True  -- DataAlt is never newtype+        , Nothing <- tyConSingleDataCon_maybe $ dataConTyCon dc+        = False    -- Not a product type, even though this is the+                   -- only remaining possible data constructor+        | DefinitelyRecursive <- ae_rec_dc env dc+        = False     -- See Note [Demand analysis for recursive data constructors]+        | otherwise+        = True+      want_precise_field_dmds (LitAlt {}) = False  -- Like the non-product datacon above+      want_precise_field_dmds DEFAULT     = True++dmdAnal' env dmd (Case scrut case_bndr ty alts)+  = let      -- Case expression with multiple alternatives+        WithDmdType scrut_ty scrut' = dmdAnal env topSubDmd scrut++        WithDmdType alt_ty1 case_bndr_dmd = findBndrDmd env alt_ty case_bndr+        !case_bndr'                       = setIdDemandInfo case_bndr case_bndr_dmd+        WithDmdType alt_ty alts'          = dmdAnalSumAlts env dmd case_bndr alts++        fam_envs             = ae_fam_envs env+        alt_ty2+          -- See Note [Precise exceptions and strictness analysis] in "GHC.Types.Demand"+          | exprMayThrowPreciseException fam_envs scrut+          = deferAfterPreciseException alt_ty1+          | otherwise+          = alt_ty1+        res_ty               = scrut_ty `plusDmdType` discardArgDmds alt_ty2++    in+--    pprTrace "dmdAnal:Case2" (vcat [ text "scrut" <+> ppr scrut+--                                   , text "scrut_ty" <+> ppr scrut_ty+--                                   , text "alt_ty1" <+> ppr alt_ty1+--                                   , text "alt_ty2" <+> ppr alt_ty2+--                                   , text "res_ty" <+> ppr res_ty ]) $+    WithDmdType res_ty (Case scrut' case_bndr' ty alts')++dmdAnal' env dmd (Let bind body)+  = WithDmdType final_ty (Let bind' body')+  where+    !(WithDmdType final_ty (R bind' body')) = dmdAnalBind NotTopLevel env dmd bind go'+    go' !env'                 = dmdAnal env' dmd body++-- | A simple, syntactic analysis of whether an expression MAY throw a precise+-- exception when evaluated. It's always sound to return 'True'.+-- See Note [Which scrutinees may throw precise exceptions].+exprMayThrowPreciseException :: FamInstEnvs -> CoreExpr -> Bool+exprMayThrowPreciseException envs e+  | not (forcesRealWorld envs (exprType e))+  = False -- 1. in the Note+  | Var f <- fn+  , Just op    <- isPrimOpId_maybe f+  , op /= RaiseIOOp+  = False -- 2. in the Note+  | Var f <- fn+  , f `hasKey` seqHashKey+  = False -- 3. in the Note+  | Var f <- fn+  , Just fcall <- isFCallId_maybe f+  , not (isSafeForeignCall fcall)+  = False -- 4. in the Note+  | otherwise+  = True  -- _. in the Note+  where+    (fn, _) = collectArgs e++-- | Recognises types that are+--    * @State# RealWorld@+--    * Unboxed tuples with a @State# RealWorld@ field+-- modulo coercions. This will detect 'IO' actions (even post Nested CPR! See+-- T13380e) and user-written variants thereof by their type.+forcesRealWorld :: FamInstEnvs -> Type -> Bool+forcesRealWorld fam_envs ty+  | ty `eqType` realWorldStatePrimTy+  = True+  | Just (tc, tc_args, _co)  <- normSplitTyConApp_maybe fam_envs ty+  , isUnboxedTupleTyCon tc+  , let field_tys = dataConInstArgTys (tyConSingleDataCon tc) tc_args+  = any (eqType realWorldStatePrimTy . scaledThing) field_tys+  | otherwise+  = False++dmdAnalSumAlts :: AnalEnv -> SubDemand -> Id -> [CoreAlt] -> WithDmdType [CoreAlt]+dmdAnalSumAlts _ _ _ [] = WithDmdType botDmdType []+  -- Base case is botDmdType, for empty case alternatives+  -- This is a unit for lubDmdType, and the right result+  -- when there really are no alternatives+dmdAnalSumAlts env dmd case_bndr (alt:alts)+  = let+      WithDmdType cur_ty  alt'  = dmdAnalSumAlt env dmd case_bndr alt+      WithDmdType rest_ty alts' = dmdAnalSumAlts env dmd case_bndr alts+    in WithDmdType (lubDmdType cur_ty rest_ty) (alt':alts')+++dmdAnalSumAlt :: AnalEnv -> SubDemand -> Id -> CoreAlt -> WithDmdType CoreAlt+dmdAnalSumAlt env dmd case_bndr (Alt con bndrs rhs)+  | let rhs_env = addInScopeAnalEnvs env (case_bndr:bndrs)+    -- See Note [Bringing a new variable into scope]+  , WithDmdType rhs_ty rhs' <- dmdAnal rhs_env dmd rhs+  , WithDmdType alt_ty dmds <- findBndrsDmds env rhs_ty bndrs+  , let (_ :* case_bndr_sd) = findIdDemand alt_ty case_bndr+        -- See Note [Demand on case-alternative binders]+        -- we can't use the scrut_sd, because it says 'Prod' and we'll use+        -- topSubDmd anyway for scrutinees of sum types.+        scrut_sd = scrutSubDmd case_bndr_sd dmds+        dmds' = fieldBndrDmds scrut_sd (length dmds)+        -- Do not put a thunk into the Alt+        !new_ids            = setBndrsDemandInfo bndrs dmds'+  = -- pprTrace "dmdAnalSumAlt" (ppr con $$ ppr case_bndr $$ ppr dmd $$ ppr alt_ty) $+    WithDmdType alt_ty (Alt con new_ids rhs')++-- See Note [Demand on the scrutinee of a product case]+scrutSubDmd :: SubDemand -> [Demand] -> SubDemand+scrutSubDmd case_sd fld_dmds =+  -- pprTraceWith "scrutSubDmd" (\scrut_sd -> ppr case_sd $$ ppr fld_dmds $$ ppr scrut_sd) $+  case_sd `plusSubDmd` mkProd Unboxed fld_dmds++-- See Note [Demand on case-alternative binders]+fieldBndrDmds :: SubDemand -- on the scrutinee+              -> Arity+              -> [Demand]  -- Final demands for the components of the DataCon+fieldBndrDmds scrut_sd n_flds =+  case viewProd n_flds scrut_sd of+    Just (_, ds) -> ds+    Nothing      -> replicate n_flds topDmd+                      -- Either an arity mismatch or scrut_sd was a call demand.+                      -- See Note [Untyped demand on case-alternative binders]++{-+Note [Anticipating ANF in demand analysis]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When analysing non-complex (e.g., trivial) thunks and complex function+arguments, we have to pretend that the expression is really in administrative+normal form (ANF), the conversion to which is done by CorePrep.++Consider+```+f x = let y = x |> co in y `seq` y `seq` ()+```+E.g., 'y' is a let-binding with a trivial RHS. That may occur if 'y' can't be+inlined, for example. Now, is 'x' used once? It may appear as if that is the+case, since its only occurrence is in 'y's memoised RHS. But actually, CorePrep+will *not* allocate a thunk for 'y', because it is trivial and could just+re-use the memoisation mechanism of 'x'! By saying that 'x' is used once it+becomes a single-entry thunk and a call to 'f' will evaluate it twice.+The same applies to trivial arguments, e.g., `f z` really evaluates `z` twice.++So, somewhat counter-intuitively, trivial arguments and let RHSs will *not* be+memoised. On the other hand, evaluation of non-trivial arguments and let RHSs+*will* be memoised. In fact, consider the effect of conversion to ANF on complex+function arguments (as done by 'GHC.Core.Prep.mkFloat'):+```+f2 (g2 x) ===> let y = g2 x in f2 y                   (if `y` is lifted)+f3 (g3 x) ===> case g3 x of y { __DEFAULT -> f3 y }   (if `y` is not lifted)+```+So if a lifted argument like `g2 x` is complex enough, it will be memoised.+Regardless how many times 'f2' evaluates its parameter, the argument will be+evaluated at most once to WHNF.+Similarly, when an unlifted argument like `g3 x` is complex enough, we will+evaluate it *exactly* once to WHNF, no matter how 'f3' evaluates its parameter.++Note that any evaluation beyond WHNF is not affected by memoisation. So this+Note affects the outer 'Card' of a 'Demand', but not its nested 'SubDemand'.+'anticipateANF' predicts the effect of case-binding and let-binding complex+arguments, as well as the lack of memoisation for trivial let RHSs.+In particular, this takes care of the gripes in+Note [Analysing with absent demand] relating to unlifted types.++Note [Analysing with absent demand]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we analyse an expression with demand A.  The "A" means+"absent", so this expression will never be needed. What should happen?+There are several wrinkles:++* We *do* want to analyse the expression regardless.+  Reason: Note [Always analyse in virgin pass]++  But we can post-process the results to ignore all the usage+  demands coming back. This is done by 'multDmdType' with the appropriate+  (absent) evaluation cardinality A or B.++* Nevertheless, which sub-demand should we pick for analysis?+  Since the demand was absent, any would do. Worker/wrapper will replace+  absent bindings with an absent filler anyway, so annotations in the RHS+  of an absent binding don't matter much.+  Picking 'botSubDmd' would be the most useful, but would also look a bit+  misleading in the Core output of DmdAnal, because all nested annotations would+  be bottoming. Better pick 'seqSubDmd', so that we annotate many of those+  nested bindings with A themselves.++* Since we allow unlifted arguments that are not ok-for-speculation,+  we need to be extra careful in the following situation, because unlifted+  values are evaluated even if they are not used. Example from #9254:+     f :: (() -> (# Int#, () #)) -> ()+          -- Strictness signature is+          --    <1C(1,P(A,1L))>+          -- I.e. calls k, but discards first component of result+     f k = case k () of (# _, r #) -> r++     g :: Int -> ()+     g y = f (\n -> (# case y of I# y2 -> y2, n #))++  Here, f's strictness signature says (correctly) that it calls its argument+  function and ignores the first component of its result.++  But in function g, we *will* evaluate the 'case y of ...', because it has type+  Int#. So in the program as written, 'y' will be evaluated. Hence we must+  record this usage of 'y', else 'g' will say 'y' is absent, and will w/w so+  that 'y' is bound to an absent filler (see Note [Absent fillers]), leading+  to a crash when 'y' is evaluated.++  Now, worker/wrapper could be smarter and replace `case y of I# y2 -> y2`+  with a suitable absent filler such as `RUBBISH[IntRep] @Int#`.+  But as long as worker/wrapper isn't equipped to do so, we must be cautious,+  and follow Note [Anticipating ANF in demand analysis]. That is, in+  'dmdAnalStar', we will set the evaluation cardinality to C_11, anticipating+  the case binding of the complex argument `case y of I# y2 -> y2`. This+  cardinlities' only effect is in the call to 'multDmdType', where it makes sure+  that the demand on the arg's free variable 'y' is not absent and strict, so+  that it is ultimately passed unboxed to 'g'.++Note [Always analyse in virgin pass]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Tricky point: make sure that we analyse in the 'virgin' pass. Consider+   rec { f acc x True  = f (...rec { g y = ...g... }...)+         f acc x False = acc }+In the virgin pass for 'f' we'll give 'f' a very strict (bottom) type.+That might mean that we analyse the sub-expression containing the+E = "...rec g..." stuff in a bottom demand.  Suppose we *didn't analyse*+E, but just returned botType.++Then in the *next* (non-virgin) iteration for 'f', we might analyse E+in a weaker demand, and that will trigger doing a fixpoint iteration+for g.  But *because it's not the virgin pass* we won't start g's+iteration at bottom.  Disaster.  (This happened in $sfibToList' of+nofib/spectral/fibheaps.)++So in the virgin pass we make sure that we do analyse the expression+at least once, to initialise its signatures.++Note [Which scrutinees may throw precise exceptions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+This is the specification of 'exprMayThrowPreciseExceptions',+which is important for Scenario 2 of+Note [Precise exceptions and strictness analysis] in GHC.Types.Demand.++For an expression @f a1 ... an :: ty@ we determine that+  1. False  If ty is *not* @State# RealWorld@ or an unboxed tuple thereof.+            This check is done by 'forcesRealWorld'.+            (Why not simply unboxed pairs as above? This is motivated by+            T13380{d,e}.)+  2. False  If f is a PrimOp, and it is *not* raiseIO#+  3. False  If f is the PrimOp-like `seq#`, cf. Note [seq# magic].+  4. False  If f is an unsafe FFI call ('PlayRisky')+  _. True   Otherwise "give up".++It is sound to return False in those cases, because+  1. We don't give any guarantees for unsafePerformIO, so no precise exceptions+     from pure code.+  2. raiseIO# is the only primop that may throw a precise exception.+  3. `seq#` used to be a primop that did not throw a precise exception.+     We keep it that way for back-compat.+     See the implementation bits of Note [seq# magic] in GHC.Types.Id.Make.+  4. Unsafe FFI calls may not interact with the RTS (to throw, for example).+     See haddock on GHC.Types.ForeignCall.PlayRisky.++We *need* to return False in those cases, because+  1. We would lose too much strictness in pure code, all over the place.+  2. We would lose strictness for primops like getMaskingState#, which+     introduces a substantial regression in+     GHC.IO.Handle.Internals.wantReadableHandle.+  3. `seq#` used to be a PrimOp and we want to stay backwards compatible.+  4. We would lose strictness for code like GHC.Fingerprint.fingerprintData,+     where an intermittent FFI call to c_MD5Init would otherwise lose+     strictness on the arguments len and buf, leading to regressions in T9203+     (2%) and i386's haddock.base (5%). Tested by T13380f.++In !3014 we tried a more sophisticated analysis by introducing ConOrDiv (nic)+to the Divergence lattice, but in practice it turned out to be hard to untaint+from 'topDiv' to 'conDiv', leading to bugs, performance regressions and+complexity that didn't justify the single fixed testcase T13380c.++You might think that we should check for side-effects rather than just for+precise exceptions. Right you are! See Note [Side-effects and strictness]+for why we unfortunately do not.++Note [Demand analysis for recursive data constructors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+T11545 features a single-product, recursive data type+  data A = A A A ... A+    deriving Eq+Naturally, `(==)` is deeply strict in `A` and in fact will never terminate. That+leads to very large (exponential in the depth) demand signatures and fruitless+churn in boxity analysis, demand analysis and worker/wrapper.++So we detect `A` as a recursive data constructor (see+Note [Detecting recursive data constructors]) analysing `case x of A ...`+and simply assume L for the demand on field binders, which is the same code+path as we take for sum types. This code happens in want_precise_field_dmds+in the Case equation for dmdAnal.++Combined with the B demand on the case binder, we get the very small demand+signature <1S><1S>b on `(==)`. This improves ghc/alloc performance on T11545+tenfold! See also Note [CPR for recursive data constructors] which describes the+sibling mechanism in CPR analysis.++Note [Demand on the scrutinee of a product case]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When figuring out the demand on the scrutinee of a product case,+we use the demands of the case alternative, i.e. id_dmds.+But note that these include the demand on the case binder;+see Note [Demand on case-alternative binders].+This is crucial. Example:+   f x = case x of y { (a,b) -> k y a }+If we just take scrut_demand = 1P(L,A), then we won't pass x to the+worker, so the worker will rebuild+     x = (a, absent-error)+and that'll crash.++Note [Demand on case-alternative binders]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The demand on a binder in a case alternative comes+  (a) From the demand on the binder itself+  (b) From the demand on the case binder+Forgetting (b) led directly to #10148.++Example. Source code:+  f x@(p,_) = if p then foo x else True++  foo (p,True) = True+  foo (p,q)    = foo (q,p)++After strictness analysis, forgetting (b):+  f = \ (x_an1 [Dmd=1P(1L,ML)] :: (Bool, Bool)) ->+      case x_an1+      of wild_X7 [Dmd=MP(ML,ML)]+      { (p_an2 [Dmd=1L], ds_dnz [Dmd=A]) ->+      case p_an2 of _ {+        False -> GHC.Types.True;+        True -> foo wild_X7 }++Note that ds_dnz is syntactically dead, but the expression bound to it is+reachable through the case binder wild_X7. Now watch what happens if we inline+foo's wrapper:+  f = \ (x_an1 [Dmd=1P(1L,ML)] :: (Bool, Bool)) ->+      case x_an1+      of _ [Dmd=MP(ML,ML)]+      { (p_an2 [Dmd=1L], ds_dnz [Dmd=A]) ->+      case p_an2 of _ {+        False -> GHC.Types.True;+        True -> $wfoo_soq GHC.Types.True ds_dnz }++Look at that! ds_dnz has come back to life in the call to $wfoo_soq! A second+run of demand analysis would no longer infer ds_dnz to be absent.+But unlike occurrence analysis, which infers properties of the *syntactic*+shape of the program, the results of demand analysis describe expressions+*semantically* and are supposed to be mostly stable across Simplification.+That's why we should better account for (b).+In #10148, we ended up emitting a single-entry thunk instead of an updateable+thunk for a let binder that was an an absent case-alt binder during DmdAnal.++This is needed even for non-product types, in case the case-binder+is used but the components of the case alternative are not.++Note [Untyped demand on case-alternative binders]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+With unsafeCoerce, #8037 and #22039 taught us that the demand on the case binder+may be a call demand or have a different number of fields than the constructor+of the case alternative it is used in. From T22039:++  blarg :: (Int, Int) -> Int+  blarg (x,y) = x+y+  -- blarg :: <1!P(1L,1L)>++  f :: Either Int Int -> Int+  f Left{} = 0+  f e = blarg (unsafeCoerce e)+  ==> { desugars to }+  f = \ (ds_d1nV :: Either Int Int) ->+      case ds_d1nV of wild_X1 {+        Left ds_d1oV -> lvl_s1Q6;+        Right ipv_s1Pl ->+          blarg+            (case unsafeEqualityProof @(*) @(Either Int Int) @(Int, Int) of+             { UnsafeRefl co_a1oT ->+             wild_X1 `cast` (Sub (Sym co_a1oT) :: Either Int Int ~R# (Int, Int))+             })+      }++The case binder `e`/`wild_X1` has demand 1!P(1L,1L), with two fields, from the call+to `blarg`, but `Right` only has one field. Although the code will crash when+executed, we must be able to analyse it in 'fieldBndrDmds' and conservatively+approximate with Top instead of panicking because of the mismatch.+In #22039, this kind of code was guarded behind a safe `cast` and thus dead+code, but nevertheless led to a panic of the compiler.++You might wonder why the same problem doesn't come up when scrutinising a+product type instead of a sum type. It appears that for products, `wild_X1`+will be inlined before DmdAnal.++See also Note [mkWWstr and unsafeCoerce] for a related issue.++Note [Aggregated demand for cardinality]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+FIXME: This Note should be named [LetUp vs. LetDown] and probably predates+said separation. SG++We use different strategies for strictness and usage/cardinality to+"unleash" demands captured on free variables by bindings. Let us+consider the example:++f1 y = let {-# NOINLINE h #-}+           h = y+       in  (h, h)++We are interested in obtaining cardinality demand U1 on |y|, as it is+used only in a thunk, and, therefore, is not going to be updated any+more. Therefore, the demand on |y|, captured and unleashed by usage of+|h| is U1. However, if we unleash this demand every time |h| is used,+and then sum up the effects, the ultimate demand on |y| will be U1 ++U1 = U. In order to avoid it, we *first* collect the aggregate demand+on |h| in the body of let-expression, and only then apply the demand+transformer:++transf[x](U) = {y |-> U1}++so the resulting demand on |y| is U1.++The situation is, however, different for strictness, where this+aggregating approach exhibits worse results because of the nature of+|both| operation for strictness. Consider the example:++f y c =+  let h x = y |seq| x+   in case of+        True  -> h True+        False -> y++It is clear that |f| is strict in |y|, however, the suggested analysis+will infer from the body of |let| that |h| is used lazily (as it is+used in one branch only), therefore lazy demand will be put on its+free variable |y|. Conversely, if the demand on |h| is unleashed right+on the spot, we will get the desired result, namely, that |f| is+strict in |y|.+++************************************************************************+*                                                                      *+                    Demand transformer+*                                                                      *+************************************************************************+-}++dmdTransform :: AnalEnv   -- ^ The analysis environment+             -> Id        -- ^ The variable+             -> SubDemand -- ^ The evaluation context of the var+             -> DmdType   -- ^ The demand type unleashed by the variable in this+                          -- context. The returned DmdEnv includes the demand on+                          -- this function plus demand on its free variables+-- See Note [DmdSig: demand signatures, and demand-sig arity] in "GHC.Types.Demand"+dmdTransform env var sd+  -- Data constructors+  | Just con <- isDataConWorkId_maybe var+  = -- pprTraceWith "dmdTransform:DataCon" (\ty -> ppr con $$ ppr sd $$ ppr ty) $+    dmdTransformDataConSig (dataConRepStrictness con) sd+  -- See Note [DmdAnal for DataCon wrappers]+  | Just rhs <- dataConWrapUnfolding_maybe var+  , WithDmdType dmd_ty _rhs' <- dmdAnal env sd rhs+  = dmd_ty+  -- Dictionary component selectors+  -- Used to be controlled by a flag.+  -- See #18429 for some perf measurements.+  | Just _ <- isClassOpId_maybe var+  = -- pprTrace "dmdTransform:DictSel" (ppr var $$ ppr (idDmdSig var) $$ ppr sd) $+    dmdTransformDictSelSig (idDmdSig var) sd+  -- Imported functions+  | isGlobalId var+  , let res = dmdTransformSig (idDmdSig var) sd+  = -- pprTrace "dmdTransform:import" (vcat [ppr var, ppr (idDmdSig var), ppr sd, ppr res])+    res+  -- Top-level or local let-bound thing for which we use LetDown ('useLetUp').+  -- In that case, we have a strictness signature to unleash in our AnalEnv.+  | Just (sig, top_lvl) <- lookupSigEnv env var+  , let fn_ty = dmdTransformSig sig sd+  = -- pprTrace "dmdTransform:LetDown" (vcat [ppr var, ppr sig, ppr sd, ppr fn_ty]) $+    case top_lvl of+      NotTopLevel -> addVarDmd fn_ty var (C_11 :* sd)+      TopLevel+        | isInterestingTopLevelFn var+        -- Top-level things will be used multiple times or not at+        -- all anyway, hence the `floatifyDmd`: it means we don't+        -- have to track whether @var@ is used strictly or at most+        -- once, because ultimately it never will+        -> addVarDmd fn_ty var (floatifyDmd (C_11 :* sd))+        | otherwise+        -> fn_ty -- don't bother tracking; just annotate with 'topDmd' later+  -- Everything else:+  --   * Local let binders for which we use LetUp (cf. 'useLetUp')+  --   * Lambda binders+  --   * Case and constructor field binders+  | otherwise+  = -- pprTrace "dmdTransform:other" (vcat [ppr var, ppr boxity, ppr sd]) $+    noArgsDmdType (addVarDmdEnv nopDmdEnv var (C_11 :* sd))++{- *********************************************************************+*                                                                      *+                      Binding right-hand sides+*                                                                      *+********************************************************************* -}++-- | An environment in which all demands are weak according to 'isWeakDmd'.+-- See Note [Lazy and unleashable free variables].+type WeakDmds = VarEnv Demand++-- | @dmdAnalRhsSig@ analyses the given RHS to compute a demand signature+-- for the LetDown rule. It works as follows:+--+--  * assuming the weakest possible body sub-demand, L+--  * looking at the definition+--  * determining a strictness signature+--+-- Since it assumed a body sub-demand of L, the resulting signature is+-- applicable at any call site.+dmdAnalRhsSig+  :: TopLevelFlag+  -> RecFlag+  -> AnalEnv -> SubDemand+  -> Id -> CoreExpr+  -> (AnalEnv, WeakDmds, Id, CoreExpr)+-- Process the RHS of the binding, add the strictness signature+-- to the Id, and augment the environment with the signature as well.+-- See Note [NOINLINE and strictness]+dmdAnalRhsSig top_lvl rec_flag env let_sd id rhs+  = -- pprTrace "dmdAnalRhsSig" (ppr id $$ ppr let_dmd $$ ppr rhs_dmds $$ ppr sig $$ ppr weak_fvs) $+    (final_env, weak_fvs, final_id, final_rhs)+  where+    ww_arity = workWrapArity id rhs+      -- See Note [Worker/wrapper arity and join points] point (1)++    body_sd | isJoinId id = let_sd+            | otherwise   = topSubDmd+      -- See Note [Demand analysis for join points]+      -- See Note [Invariants on join points] invariant 2b, in GHC.Core+      --     ww_arity matches the join arity of the join point++    adjusted_body_sd = unboxedWhenSmall env rec_flag (resultType_maybe id) body_sd+      -- See Note [Unboxed demand on function bodies returning small products]++    rhs_sd = mkCalledOnceDmds ww_arity adjusted_body_sd++    WithDmdType rhs_dmd_ty rhs' = dmdAnal env rhs_sd rhs+    DmdType rhs_env rhs_dmds = rhs_dmd_ty+    (final_rhs_dmds, final_rhs) = finaliseArgBoxities env id ww_arity+                                                      rhs_dmds (de_div rhs_env) rhs'++    dmd_sig_arity = ww_arity + strictCallArity body_sd+    sig = mkDmdSigForArity dmd_sig_arity (DmdType sig_env final_rhs_dmds)+          -- strictCallArity is > 0 only for join points+          -- See Note [mkDmdSigForArity]++    opts       = ae_opts env+    final_id   = setIdDmdAndBoxSig opts id sig+    !final_env = extendAnalEnv top_lvl env final_id sig++    -- See Note [Aggregated demand for cardinality]+    -- FIXME: That Note doesn't explain the following lines at all. The reason+    --        is really much different: When we have a recursive function, we'd+    --        have to also consider the free vars of the strictness signature+    --        when checking whether we found a fixed-point. That is expensive;+    --        we only want to check whether argument demands of the sig changed.+    --        reuseEnv makes it so that the FV results are stable as long as the+    --        last argument demands were. Strictness won't change. But used-once+    --        might turn into used-many even if the signature was stable and+    --        we'd have to do an additional iteration. reuseEnv makes sure that+    --        we never get used-once info for FVs of recursive functions.+    --        See #14816 where we try to get rid of reuseEnv.+    rhs_env1 = case rec_flag of+                Recursive    -> reuseEnv rhs_env+                NonRecursive -> rhs_env++    -- See Note [Absence analysis for stable unfoldings and RULES]+    rhs_env2 = rhs_env1 `plusDmdEnv` demandRootSet env (bndrRuleAndUnfoldingIds id)++    -- See Note [Lazy and unleashable free variables]+    !(!sig_env, !weak_fvs) = splitWeakDmds rhs_env2++splitWeakDmds :: DmdEnv -> (DmdEnv, WeakDmds)+splitWeakDmds (DE fvs div) = (DE sig_fvs div, weak_fvs)+  where (!weak_fvs, !sig_fvs) = partitionVarEnv isWeakDmd fvs++-- | The result type after applying 'idArity' many arguments. Returns 'Nothing'+-- when the type doesn't have exactly 'idArity' many arrows.+resultType_maybe :: Id -> Maybe Type+resultType_maybe id+  | (pis,ret_ty) <- splitPiTys (idType id)+  , count isAnonPiTyBinder pis == idArity id+  = Just $! ret_ty+  | otherwise+  = Nothing++unboxedWhenSmall :: AnalEnv -> RecFlag -> Maybe Type -> SubDemand -> SubDemand+-- See Note [Unboxed demand on function bodies returning small products]+unboxedWhenSmall _   _        Nothing       sd = sd+unboxedWhenSmall env rec_flag (Just ret_ty) sd = go 1 ret_ty sd+  where+    -- Magic constant, bounding the depth of optimistic 'Unboxed' flags. We+    -- might want to minmax in the future.+    max_depth | isRec rec_flag = 3 -- So we get at most something as deep as !P(L!P(L!L))+              | otherwise      = 1 -- Otherwise be unbox too deep in T18109, T18174 and others and get a bunch of stack overflows+    go :: Int -> Type -> SubDemand -> SubDemand+    go depth ty sd+      | depth <= max_depth+      , Just (tc, tc_args, _co) <- normSplitTyConApp_maybe (ae_fam_envs env) ty+      , Just [dc] <- canUnboxTyCon tc   -- tc is not a newtype+      , null (dataConExTyCoVars dc)     -- Can't unbox results with existentials+      , dataConRepArity dc <= dmd_unbox_width (ae_opts env)+      , Just (_, ds) <- viewProd (dataConRepArity dc) sd+      , arg_tys <- map scaledThing $ dataConInstArgTys dc tc_args+      , equalLength ds arg_tys+      = mkProd Unboxed $! strictZipWith (go_dmd (depth+1)) arg_tys ds+      | otherwise+      = sd++    go_dmd :: Int -> Type -> Demand -> Demand+    go_dmd depth ty dmd = case dmd of+      AbsDmd  -> AbsDmd+      BotDmd  -> BotDmd+      n :* sd -> n :* go depth ty sd++-- | If given the (local, non-recursive) let-bound 'Id', 'useLetUp' determines+-- whether we should process the binding up (body before rhs) or down (rhs+-- before body).+--+-- We use LetDown if there is a chance to get a useful strictness signature to+-- unleash at call sites. LetDown is generally more precise than LetUp if we can+-- correctly guess how it will be used in the body, that is, for which incoming+-- demand the strictness signature should be computed, which allows us to+-- unleash higher-order demands on arguments at call sites. This is mostly the+-- case when+--+--   * The binding takes any arguments before performing meaningful work (cf.+--     'idArity'), in which case we are interested to see how it uses them.+--   * The binding is a join point, hence acting like a function, not a value.+--     As a big plus, we know *precisely* how it will be used in the body; since+--     it's always tail-called, we can directly unleash the incoming demand of+--     the let binding on its RHS when computing a strictness signature. See+--     [Demand analysis for join points].+--+-- Thus, if the binding is not a join point and its arity is 0, we have a thunk+-- and use LetUp, implying that we have no usable demand signature available+-- when we analyse the let body.+--+-- Since thunk evaluation is memoised, we want to unleash its 'DmdEnv' of free+-- vars at most once, regardless of how many times it was forced in the body.+-- This makes a real difference wrt. usage demands. The other reason is being+-- able to unleash a more precise product demand on its RHS once we know how the+-- thunk was used in the let body.+--+-- Characteristic examples, always assuming a single evaluation:+--+--   * @let x = 2*y in x + x@ => LetUp. Compared to LetDown, we find out that+--     the expression uses @y@ at most once.+--   * @let x = (a,b) in fst x@ => LetUp. Compared to LetDown, we find out that+--     @b@ is absent.+--   * @let f x = x*2 in f y@ => LetDown. Compared to LetUp, we find out that+--     the expression uses @y@ strictly, because we have @f@'s demand signature+--     available at the call site.+--   * @join exit = 2*y in if a then exit else if b then exit else 3*y@ =>+--     LetDown. Compared to LetUp, we find out that the expression uses @y@+--     strictly, because we can unleash @exit@'s signature at each call site.+--   * For a more convincing example with join points, see Note [Demand analysis+--     for join points].+--+useLetUp :: TopLevelFlag -> Var -> Bool+useLetUp top_lvl f = isNotTopLevel top_lvl && idArity f == 0 && not (isJoinId f)++{- Note [Demand analysis for join points]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+   g :: (Int,Int) -> Int+   g (p,q) = p+q++   f :: T -> Int -> Int+   f x p = g (join j y = (p,y)+              in case x of+                   A -> j 3+                   B -> j 4+                   C -> (p,7))++If j was a vanilla function definition, we'd analyse its body with evalDmd, and+think that it was lazy in p.  But for join points we can do better!  We know+that j's body will (if called at all) be evaluated with the demand that consumes+the entire join-binding, in this case the argument demand from g.  Whizzo!  g+evaluates both components of its argument pair, so p will certainly be evaluated+if j is called.++For f to be strict in p, we need /all/ paths to evaluate p; in this case the C+branch does so too, so we are fine.  So, as usual, we need to transport demands+on free variables to the call site(s).  Compare Note [Lazy and unleashable free+variables].++The implementation is easy: see `body_sd` in`dmdAnalRhsSig`.  When analysing+a join point, we can analyse its body (after stripping off the join binders,+here just 'y') with the demand from the entire join-binding (written `let_sd`+here).++Another win for join points!  #13543.++BUT see Note [Worker/wrapper arity and join points].++Note we may analyse the rhs of a join point with a demand that is either+bigger than, or smaller than, the number of lambdas syntactically visible.+* More lambdas than call demands:+       join j x = \p q r -> blah in ...+  in a context with demand Top.++* More call demands than lambdas:+       (join j x = h in ..(j 2)..(j 3)) a b c++Note [Worker/wrapper arity and join points]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+    (join j x = \y. error "urk")+    (in case v of              )+    (     A -> j 3             )  x+    (     B -> j 4             )+    (     C -> \y. blah        )++The entire thing is in a C(1,L) context, so we will analyse j's body, namely+   \y. error "urk"+with demand C(C(1,L)).  See `rhs_sd` in `dmdAnalRhsSig`.  That will produce+a demand signature of <A><A>b: and indeed `j` diverges when given two arguments.++BUT we do /not/ want to worker/wrapper `j` with two arguments.  Suppose we have+     join j2 :: Int -> Int -> blah+          j2 x = rhs+     in ...(j2 3)...(j2 4)...++where j2's join-arity is 1, so calls to `j` will all have /one/ argument.+Suppose the entire expression is in a called context (like `j` above) and `j2`+gets the demand signature <1!P(L)><1!P(L)>, that is, strict in both arguments.++we worker/wrapper'd `j2` with two args we'd get+     join $wj2 x# y# = let x = I# x#; y = I# y# in rhs+          j2 x = \y. case x of I# x# -> case y of I# y# -> $wj2 x# y#+     in ...(j2 3)...(j2 4)...+But now `$wj2`is no longer a join point. Boo.++Instead if we w/w at all, we want to do so only with /one/ argument:+     join $wj2 x# = let x = I# x# in rhs+          j2 x = case x of I# x# -> $wj2 x#+     in ...(j2 3)...(j2 4)...+Now all is fine.  BUT in `finaliseArgBoxities` we should trim y's boxity,+to reflect the fact tta we aren't going to unbox `y` at all.++Conclusion:++(1) The "worker/wrapper arity" of an Id is+    * For non-join-points: idArity+    * The join points: the join arity (Id part only of course)+    This is the number of args we will use in worker/wrapper.+    See `ww_arity` in `dmdAnalRhsSig`, and the function `workWrapArity`.++(2) A join point's demand-signature arity may exceed the Id's worker/wrapper+    arity.  See the `arity_ok` assertion in `mkWwBodies`.++(3) In `finaliseArgBoxities`, do trimBoxity on any argument demands beyond+    the worker/wrapper arity.++(4) In WorkWrap.splitFun, make sure we split based on the worker/wrapper+    arity (re)-computed by workWrapArity.++Note [The demand for the RHS of a binding]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Given a binding { f = rhs }, in `dmdAnalRhsSig` we compute a `rhs_sd` in+which to analyse `rhs`.++The demand we use is:++* Ordinary bindings: a call-demand of depth (idArity f).+  Why idArity arguments? Because that's a conservative estimate of how many+  arguments we must feed a function before it does anything interesting with+  them.  Also it elegantly subsumes the trivial RHS and PAP case.  E.g. for+      f = g+  we want to use a threshold arity based on g, not 0!++  idArity is /at least/ the number of manifest lambdas, but might be higher for+  PAPs and trivial RHS (see Note [Demand analysis for trivial right-hand sides]).++* Join points: a call-demand of depth (value-binder subset of JoinArity),+  wrapped around the incoming demand for the entire expression; see+  Note [Demand analysis for join points]++Note that the idArity of a function varies independently of its cardinality+properties (cf. Note [idArity varies independently of dmdTypeDepth]), so we+implicitly encode the arity for when a demand signature is sound to unleash in+its 'dmdTypeDepth', not in its idArity (cf. Note [Understanding DmdType and+DmdSig] in GHC.Types.Demand). It is unsound to unleash a demand signature when+the incoming number of arguments is less than that. See GHC.Types.Demand+Note [DmdSig: demand signatures, and demand-sig arity].++Note that there might, in principle, be functions for which we might want to+analyse for more incoming arguments than idArity. Example:++  f x =+    if expensive+      then \y -> ... y ...+      else \y -> ... y ...++We'd analyse `f` under a unary call demand C(1,L), corresponding to idArity+being 1. That's enough to look under the manifest lambda and find out how a+unary call would use `x`, but not enough to look into the lambdas in the if+branches.++On the other hand, if we analysed for call demand C(1,C(1,L)), we'd get useful+strictness info for `y` (and more precise info on `x`) and possibly CPR+information, but++  * We would no longer be able to unleash the signature at unary call sites++  * Performing the worker/wrapper split based on this information would be+    implicitly eta-expanding `f`, playing fast and loose with divergence and+    even being unsound in the presence of newtypes, so we refrain from doing so.+    Also see Note [Don't eta expand in w/w] in GHC.Core.Opt.WorkWrap.++Since we only compute one signature, we do so for arity 1. Computing multiple+signatures for different arities (i.e., polyvariance) would be entirely+possible, if it weren't for the additional runtime and implementation+complexity.++Note [mkDmdSigForArity]+~~~~~~~~~~~~~~~~~~~~~~~+Consider+   f x = if expensive x+         then \y. blah1+         else \y. blah2+We will analyse the body with demand C(1L), reflecting the single visible+argument x.  But dmdAnal will return a DmdType looking like+    DmdType fvs [x-dmd, y-dmd]+because it has seen two lambdas, \x and \y. Since the length of the argument+demands in a DmdSig gives the "threshold" for applying the signature+(see Note [DmdSig: demand signatures, and demand-sig arity] in GHC.Types.Demand)+we must trim that DmdType to just+    DmdSig (DmdTypte fvs [x-dmd])+when making that DmdType into the DmdSig for f.  This trimming is the job of+`mkDmdSigForArity`.++Alternative.  An alternative would be be to ensure that if+    (dmd_ty, e') = dmdAnal env subdmd e+then the length dmds in dmd_ty is always less than (or maybe equal to?) the+call-depth of subdmd.  To do that we'd need to adjust the Lam case of dmdAnal.+Probably not hard, but a job for another day; see discussion on !12873, #23113,+and #21392.++Note [idArity varies independently of dmdTypeDepth]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In general, an Id `f` has two independently varying attributes:++* f's idArity, and+* the dmdTypeDepth of f's demand signature++For example, if f's demand signature is <L><L>, f's arity could be+greater than, or less than 2. Why?  Because both are conservative+approximations:++* Arity n means "does no expensive work until applied to at least n args"+  (e.g. (f x1..xm) is cheap to bring to HNF for m<n)++* Dmd sig with n args means "here is how to transform the incoming demand+  when applied to n args".  This is /semantic/ property, unrelated to+  arity. See GHC.Types.Demand Note [Understanding DmdType and DmdSig]++We used to check in GHC.Core.Lint that dmdTypeDepth <= idArity for a let-bound+identifier. But that means we would have to zap demand signatures every time we+reset or decrease arity.++For example, consider the following expression:++    (let go x y = `x` seq ... in go) |> co++`go` might have a strictness signature of `<1L><L>`. The simplifier will identify+`go` as a nullary join point through `joinPointBinding_maybe` and float the+coercion into the binding, leading to an arity decrease:++    join go = (\x y -> `x` seq ...) |> co in go++With the CoreLint check, we would have to zap `go`'s perfectly viable strictness+signature.++However, in the case of a /bottoming/ signature, f : <L><L>b, we /can/+say that f's arity is no greater than 2, because it'd be false to say+that f does no work when applied to 3 args.  Lint checks this constraint,+in `GHC.Core.Lint.lintLetBind`.++Note [Demand analysis for trivial right-hand sides]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+    foo = plusInt |> co+where plusInt is an arity-2 function with known strictness.  Clearly+we want plusInt's strictness to propagate to foo!  But because it has+no manifest lambdas, it won't do so automatically, and indeed 'co' might+have type (Int->Int->Int) ~ T.++Fortunately, GHC.Core.Opt.Arity gives 'foo' arity 2, which is enough for LetDown to+forward plusInt's demand signature, and all is well (see Note [Newtype arity] in+GHC.Core.Opt.Arity)! A small example is the test case NewtypeArity.++Note [Absence analysis for stable unfoldings and RULES]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Among others, tickets #18638 and #23208 show that it's really important to treat+stable unfoldings as demanded. Consider++   g = blah++   f = \x.  ...no use of g....+   {- f's stable unfolding is f = \x. ...g... -}++If f is ever inlined we use 'g'. But f's current RHS makes no use+of 'g', so if we don't look at the unfolding we'll mark g as Absent,+and transform to++   g = error "Entered absent value"+   f = \x. ...+   {- f's stable unfolding is f = \x. ...g... -}++Now if f is subsequently inlined, we'll use 'g' and ... disaster.++SOLUTION: if f has a stable unfolding, treat every free variable as a+/demand root/, that is: Analyse it as if it was a variable occurring in a+'topDmd' context. This is done in `demandRoot` (which we also use for exported+top-level ids). Do the same for Ids free in the RHS of any RULES for f.++Wrinkles:++  (W1) You may wonder how it can be that f's optimised RHS has somehow+    discarded 'g', but when f is inlined we /don't/ discard g in the same+    way. I think a simple example is+       g = (a,b)+       f = \x.  fst g+       {-# INLINE f #-}++    Now f's optimised RHS will be \x.a, but if we change g to (error "..")+    (since it is apparently Absent) and then inline (\x. fst g) we get+    disaster.  But regardless, #18638 was a more complicated version of+    this, that actually happened in practice.++  (W2) You might wonder why we don't simply take the free vars of the+    unfolding/RULE and map them to topDmd. The reason is that any of the free vars+    might have demand signatures themselves that in turn demand transitive free+    variables and that we hence need to unleash! This came up in #23208.+    Consider++       err :: Int -> b+       err = error "really important message"++       sg :: Int -> Int+       sg _ = case err of {}  -- Str=<1B>b {err:->S}++       g :: a -> a  -- g is exported+       g x = x+       {-# RULES "g" g @Int = sg #-}++    Here, `err` is only demanded by `sg`'s demand signature: It doesn't occur+    in the weak_fvs of `sg`'s RHS at all. Hence when we `demandRoots` `sg`+    because it occurs in the RULEs of `g` (which is exported), we better unleash+    the demand signature of `sg`, too! Before #23208 we simply added a 'topDmd'+    for `sg`, failing to unleash the signature and hence observed an absent+    error instead of the `really important message`.++Note [DmdAnal for DataCon wrappers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We give DataCon wrappers a (necessarily flat) demand signature in+`GHC.Types.Id.Make.mkDataConRep`, so that passes such as the Simplifier can+exploit it via the call to `GHC.Core.Opt.Simplify.Utils.isStrictArgInfo` in+`GHC.Core.Opt.Simplify.Iteration.rebuildCall`. But during DmdAnal, we *ignore*+the demand signature of a DataCon wrapper, and instead analyse its unfolding at+every call site.++The reason is that DataCon *worker*s have very precise demand transformers,+computed by `dmdTransformDataConSig`. It would be awkward if DataCon *wrappers*+would behave much less precisely during DmdAnal. Example:++   data T1 = MkT1 { get_x1 :: Int,  get_y1 :: Int }+   data T2 = MkT2 { get_x2 :: !Int, get_y2 :: Int }+   f1 x y = get_x1 (MkT1 x y)+   f2 x y = get_x2 (MkT2 x y)++Here `MkT1` has no wrapper. `get_x1` puts a demand `!P(1!L,A)` on its argument,+and `dmdTransformDataConSig` will transform that demand to an absent demand on+`y` in `f1` and an unboxing demand on `x`.+But `MkT2` has a wrapper (to evaluate the first field). If demand analysis deals+with `MkT2` only through its demand signature, demand signatures can't transform+an incoming demand `P(1!L,A)` in a useful way, so we won't get an absent demand+on `y` in `f2` or see that `x` can be unboxed. That's a serious loss.++The example above will not actually occur, because $WMkT2 would be inlined.+Nevertheless, we can get interesting sub-demands on DataCon wrapper+applications in boring contexts; see T22241.++You might worry about the efficiency cost of demand-analysing datacon wrappers+at every call site. But in fact they are inlined /anyway/ in the Final phase,+which happens before DmdAnal, so few wrappers remain. And analysing the+unfoldings for the remaining calls (which are those in a boring context) will be+exactly as (in)efficent as if we'd inlined those calls. It turns out to be not+measurable in practice.++See also Note [CPR for DataCon wrappers] in `GHC.Core.Opt.CprAnal`.++Note [Boxity for bottoming functions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider (A)+    indexError :: Show a => (a, a) -> a -> String -> b+    -- Str=<..><1!P(S,S)><1S><S>b+    indexError rng i s = error (show rng ++ show i ++ show s)++    get :: (Int, Int) -> Int -> [a] -> a+    get p@(l,u) i xs+      | l <= i, i < u = xs !! (i-u)+      | otherwise     = indexError p i "get"++The hot path of `get` certainly wants to unbox `p` as well as `l` and+`u`, but the unimportant, diverging error path needs `l::a` and `u::a`+boxed, since `indexError` can't unbox them because they are polymorphic.+This pattern often occurs in performance sensitive code that does+bounds-checking.++So we want to give `indexError` a signature like `<1!P(!S,!S)><1!S><S!S>b`+where the !S (meaning Poly Unboxed C1N) says that the polymorphic arguments+are unboxed (recursively).  The wrapper for `indexError` won't /actually/+unbox them (because their polymorphic type doesn't allow that) but when+demand-analysing /callers/, we'll behave as if that call needs the args+unboxed.++Then at call sites of `indexError`, we will end up doing some+reboxing, because `$windexError` still takes boxed arguments. This+reboxing should usually float into the slow, diverging code path; but+sometimes (sadly) it doesn't: see Note [Reboxed crud for bottoming calls].++Here is another important case (B):+    f x = Just x  -- Suppose f is not inlined for some reason+                  -- Main point: f takes its argument boxed++    wombat x = error (show (f x))++    g :: Bool -> Int -> a+    g True  x = x+1+    g False x = wombat x++Again we want `wombat` to pretend to take its Int-typed argument unboxed,+even though it has to pass it boxed to `f`, so that `g` can take its+argument unboxed (and rebox it before calling `wombat`).++So here's what we do: while summarising `indexError`'s boxity signature in+`finaliseArgBoxities`:++* To address (B), for bottoming functions, we start by using `unboxDeeplyDmd`+  to make all its argument demands unboxed, right to the leaves; regardless+  of what the analysis said.++* To address (A), for bottoming functions, in the DontUnbox case when the+  argument is a type variable, we /refrain/ from using trimBoxity.+  (Remember the previous bullet: we have already doen `unboxDeeplyDmd`.)++Wrinkle:++* Remember Note [No lazy, Unboxed demands in demand signature]. So+  unboxDeeplyDmd doesn't recurse into lazy demands.  It's extremely unusual+  to have lazy demands in the arguments of a bottoming function anyway.+  But it can happen, when the demand analyser gives up because it+  encounters a recursive data type; see Note [Demand analysis for recursive+  data constructors].++Note [Reboxed crud for bottoming calls]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For functions like `get` in Note [Boxity for bottoming functions], it's clear+that the reboxed crud will be floated inside to the call site of `$windexError`.+But here's an example where that is not the case:+```hs+import GHC.Ix++theresCrud :: Int -> Int -> Int+theresCrud x y = go x+  where+    go 0 = index (0,y) 0+    go 1 = index (x,y) 1+    go n = go (n-1)+    {-# NOINLINE theresCrud #-}+```+If you look at the Core, you'll see that `y` will be reboxed and used in the+two exit join points for the `$windexError` calls, while `x` is only reboxed in the+exit join point for `index (x,y) 1` (happens in lvl below):+```+$wtheresCrud = \ ww ww1 ->+      let { y = I# ww1 } in+      join { lvl2 = ... case lvl1 ww y of wild { }; ... } in+      join { lvl3 = ... case lvl y of wild { }; ... } in+      ...+```+This is currently a bug that we willingly accept and it's documented in #21128.++See also Note [indexError] in base:GHC.Ix, which describes how we use+SPECIALISE to mitigate this problem for indexError.+-}++{- *********************************************************************+*                                                                      *+             Finalising boxity+*                                                                      *+********************************************************************* -}++{- Note [Finalising boxity for demand signatures]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The worker/wrapper pass must strictly adhere to the boxity decisions+encoded in the demand signature, because that is the information that+demand analysis propagates throughout the program. Failing to+implement the strategy laid out in the signature can result in+reboxing in unexpected places. Hence, we must completely anticipate+unboxing decisions during demand analysis and reflect these decisions+in demand annotations. That is the job of 'finaliseArgBoxities',+which is defined here and called from demand analysis.++Here is a list of different Notes it has to take care of:++  * Note [No lazy, Unboxed demands in demand signature] such as `L!P(L)` in+    general, but still allow Note [Unboxing evaluated arguments]+  * Note [No nested Unboxed inside Boxed in demand signature] such as `1P(1!L)`+  * Note [mkWWstr and unsafeCoerce]++NB: Then, the worker/wrapper blindly trusts the boxity info in the+demand signature; that is why 'canUnboxArg' does not look at+strictness -- it is redundant to do so.++Note [Finalising boxity for let-bound Ids]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+  let x = e in body+where the demand on 'x' is 1!P(blah).  We want to unbox x according to+Note [Thunk splitting] in GHC.Core.Opt.WorkWrap.  We must do this because+worker/wrapper ignores strictness and looks only at boxity flags; so if+x's demand is L!P(blah) we might still split it (wrongly).  We want to+switch to Boxed on any lazy demand.++That is what finaliseLetBoxity does.  It has no worker-arg budget, so it+is much simpler than finaliseArgBoxities.++Note [No nested Unboxed inside Boxed in demand signature]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+```+f p@(x,y)+  | even (x+y) = []+  | otherwise  = [p]+```+Demand analysis will infer that the function body puts a demand of `1P(1!L,1!L)`+on 'p', e.g., Boxed on the outside but Unboxed on the inside. But worker/wrapper+can't unbox the pair components without unboxing the pair! So we better say+`1P(1L,1L)` in the demand signature in order not to spread wrong Boxity info.+That happens via the call to trimBoxity in 'finaliseArgBoxities'/'finaliseLetBoxity'.++Note [No lazy, Unboxed demands in demand signature]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider T19407:++  data Huge = Huge Bool () ... () -- think: DynFlags+  data T = T { h :: Huge, n :: Int }+  f t@(T h _) = g h t+  g (H b _ ... _) t = if b then 1 else n t++The body of `g` puts (approx.) demand `L!P(A,1)` on `t`. But we better+not put that demand in `g`'s demand signature, because worker/wrapper will not+in general unbox a lazy-and-unboxed demand like `L!P(..)`.+(The exception are known-to-be-evaluated arguments like strict fields,+see Note [Unboxing evaluated arguments].)++The program above is an example where spreading misinformed boxity through the+signature is particularly egregious. If we give `g` that signature, then `f`+puts demand `S!P(1!P(1L,A,..),ML)` on `t`. Now we will unbox `t` in `f` it and+we get++  f (T (H b _ ... _) n) = $wf b n+  $wf b n = $wg b (T (H b x ... x) n)+  $wg = ...++Massive reboxing in `$wf`! Solution: Trim boxity on lazy demands in+'trimBoxity', modulo Note [Unboxing evaluated arguments].++Note [Unboxing evaluated arguments]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this program (due to Roman):++    data X a = X !a++    foo :: X Int -> Int -> Int+    foo x@(X a) n = go 0+     where+       go i | i < n     = a + go (i+1)+            | otherwise = 0++We want the worker for 'foo' to look like this:++    $wfoo :: Int# -> Int# -> Int#++with the first argument unboxed, so that it is not eval'd each time around the+'go' loop (which would otherwise happen, since 'foo' is not strict in 'a'). It+is sound for the wrapper to pass an unboxed arg because X is strict+(see Note [Strictness and Unboxing] in "GHC.Core.Opt.DmdAnal"), so its argument+must be evaluated. And if we *don't* pass an unboxed argument, we can't even+repair it by adding a `seq` thus:++    foo (X a) n = a `seq` go 0++because the seq is discarded (very early) since X is strict!++So here's what we do++* Since this has nothing to do with how 'foo' uses 'a', we leave demand+  analysis alone, but account for the additional evaluatedness when+  annotating the binder 'finaliseArgBoxities', which will retain the Unboxed+  boxity on 'a' in the definition of 'foo' in the demand 'L!P(L)'; meaning+  it's used lazily but unboxed nonetheless. This seems to contradict Note+  [No lazy, Unboxed demands in demand signature], but we know that 'a' is+  evaluated and thus can be unboxed.++* When 'finaliseArgBoxities' decides to unbox a record, it will zip the field demands+  together with the respective 'StrictnessMark'. In case of 'x', it will pair+  up the lazy field demand 'L!P(L)' on 'a' with 'MarkedStrict' to account for+  the strict field.++* Said 'StrictnessMark' is passed to the recursive invocation of 'go_args' in+  'finaliseArgBoxities' when deciding whether to unbox 'a'. 'a' was used lazily, but+  since it also says 'MarkedStrict', we'll retain the 'Unboxed' boxity on 'a'.++* Worker/wrapper will consult 'canUnboxArg' for its unboxing decision. It will+  /not/ look at the strictness bits of the demand, only at Boxity flags. As such,+  it will happily unbox 'a' despite the lazy demand on it.++The net effect is that boxity analysis and the w/w transformation are more+aggressive about unboxing the strict arguments of a data constructor than when+looking at strictness info exclusively. It is very much like (Nested) CPR, which+needs its nested fields to be evaluated in order for it to unbox nestedly.++There is the usual danger of reboxing, which as usual we ignore. But+if X is monomorphic, and has an UNPACK pragma, then this optimisation+is even more important.  We don't want the wrapper to rebox an unboxed+argument, and pass an Int to $wfoo!++This works in nested situations like T10482++    data family Bar a+    data instance Bar (a, b) = BarPair !(Bar a) !(Bar b)+    newtype instance Bar Int = Bar Int++    foo :: Bar ((Int, Int), Int) -> Int -> Int+    foo f k = case f of BarPair x y ->+              case burble of+                 True -> case x of+                           BarPair p q -> ...+                 False -> ...++The extra eagerness lets us produce a worker of type:+     $wfoo :: Int# -> Int# -> Int# -> Int -> Int+     $wfoo p# q# y# = ...++even though the `case x` is only lazily evaluated.++--------- Historical note ------------+We used to add data-con strictness demands when demand analysing case+expression. However, it was noticed in #15696 that this misses some cases. For+instance, consider the program (from T10482)++    data family Bar a+    data instance Bar (a, b) = BarPair !(Bar a) !(Bar b)+    newtype instance Bar Int = Bar Int++    foo :: Bar ((Int, Int), Int) -> Int -> Int+    foo f k =+      case f of+        BarPair x y -> case burble of+                          True -> case x of+                                    BarPair p q -> ...+                          False -> ...++We really should be able to assume that `p` is already evaluated since it came+from a strict field of BarPair. This strictness would allow us to produce a+worker of type:++    $wfoo :: Int# -> Int# -> Int# -> Int -> Int+    $wfoo p# q# y# = ...++even though the `case x` is only lazily evaluated++Indeed before we fixed #15696 this would happen since we would float the inner+`case x` through the `case burble` to get:++    foo f k =+      case f of+        BarPair x y -> case x of+                          BarPair p q -> case burble of+                                          True -> ...+                                          False -> ...++However, after fixing #15696 this could no longer happen (for the reasons+discussed in ticket:15696#comment:76). This means that the demand placed on `f`+would then be significantly weaker (since the False branch of the case on+`burble` is not strict in `p` or `q`).++Consequently, we now instead account for data-con strictness in mkWWstr_one,+applying the strictness demands to the final result of DmdAnal. The result is+that we get the strict demand signature we wanted even if we can't float+the case on `x` up through the case on `burble`.++Note [Worker argument budget]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In 'finaliseArgBoxities' we don't want to generate workers with zillions of+argument when, say given a strict record with zillions of fields.  So we+limit the maximum number of worker args ('max_wkr_args') to the maximum of+  - -fmax-worker-args=N+  - The number of args in the original function; if it already has has+    zillions of arguments we don't want to seek /fewer/ args in the worker.+(Maybe we should /add/ them instead of maxing?)++We pursue a "layered" strategy for unboxing: we unbox the top level of the+argument(s), subject to budget; if there are any arguments left we unbox the+next layer, using that depleted budget.+Unboxing an argument *increases* the budget for the inner layer roughly+according to how many registers that argument takes (unboxed tuples take+multiple registers, see below), as determined by 'unariseArity'.+Budget is spent when we have to pass a non-absent field as a parameter.++To achieve this, we use the classic almost-circular programming technique in+which we we write one pass that takes a lazy list of the Budgets for every+layer. The effect is that of a breadth-first search (over argument type and+demand structure) to compute Budgets followed by a depth-first search to+construct the product demands, but laziness allows us to do it all in one+pass and without intermediate data structures.++Suppose we have -fmax-worker-args=4 for the remainder of this Note.+Then consider this example function:++  boxed :: (Int, Int) -> (Int, (Int, Int, Int)) -> Int+  boxed (a,b) (c, (d,e,f)) = a + b + c + d + e + f++With a budget of 4 args to spend (number of args is only 2), we'd be served well+to unbox both pairs, but not the triple. Indeed, that is what the algorithm+computes, and the following pictogram shows how the budget layers are computed.+Each layer is started with `n ~>`, where `n` is the budget at the start of the+layer. We write -n~> when we spend budget (and n is the remaining budget) and++n~> when we earn budget. We separate unboxed args with ][ and indicate+inner budget threads becoming negative in braces {{}}, so that we see which+unboxing decision we do *not* commit to. Without further ado:++  4 ~> ][     (a,b) -3~>               ][     (c, ...) -2~>+       ][      | |                     ][      |   |+       ][      | +-------------+       ][      |   +-----------------++       ][      |               |       ][      |                     |+       ][      v               v       ][      v                     v+  2 ~> ][ +3~> a  -2~> ][      b  -1~> ][ +2~> c  -1~> ][        (d, e, f) -0~>+       ][      |       ][      |       ][      |       ][ {{      |  |  |                          }}+       ][      |       ][      |       ][      |       ][ {{      |  |  +----------------+         }}+       ][      v       ][      v       ][      v       ][ {{      v  +------v            v         }}+  0 ~> ][ +1~> I# -0~> ][ +1~> I# -0~> ][ +1~> I# -0~> ][ {{ +1~> d -0~> ][ e -(-1)~> ][ f -(-2)~> }}++Unboxing increments the budget we have on the next layer (because we don't need+to retain the boxed arg), but in turn the inner layer must afford to retain all+non-absent fields, each decrementing the budget. Note how the budget becomes+negative when trying to unbox the triple and the unboxing decision is "rolled+back". This is done by the 'positiveTopBudget' guard.++There's a bit of complication as a result of handling unboxed tuples correctly;+specifically, handling nested unboxed tuples. Consider (#21737)++  unboxed :: (Int, Int) -> (# Int, (# Int, Int, Int #) #) -> Int+  unboxed (a,b) (# c, (# d, e, f #) #) = a + b + c + d + e + f++Recall that unboxed tuples will be flattened to individual arguments during+unarisation. Here, `unboxed` will have 5 arguments at runtime because of the+nested unboxed tuple, which will be flattened to 4 args. So it's best to leave+`(a,b)` boxed (because we already are above our arg threshold), but unbox `c`+through `f` because that doesn't increase the number of args post unarisation.++Note that the challenge is that syntactically, `(# d, e, f #)` occurs in a+deeper layer than `(a, b)`. Treating unboxed tuples as a regular data type, we'd+make the same unboxing decisions as for `boxed` above; although our starting+budget is 5 (Here, the number of args is greater than -fmax-worker-args), it's+not enough to unbox the triple (we'd finish with budget -1). So we'd unbox `a`+through `c`, but not `d` through `f`, which is silly, because then we'd end up+having 6 arguments at runtime, of which `d` through `f` weren't unboxed.++Hence we pretend that the fields of unboxed tuples appear in the same budget+layer as the tuple itself. For example at the top-level, `(# x,y #)` is to be+treated just like two arguments `x` and `y`.+Of course, for that to work, our budget calculations must initialise+'max_wkr_args' to 5, based on the 'unariseArity' of each Core arg: That would be+1 for the pair and 4 for the unboxed pair. Then when we decide whether to unbox+the unboxed pair, we *directly* recurse into the fields, spending our budget+on retaining `c` and (after recursing once more) `d` through `f` as arguments,+depleting our budget completely in the first layer. Pictorially:++  5 ~> ][         (a,b) -4~>             ][         (# c, ... #)+       ][ {{      | |                 }} ][      c  -3~> ][ (# d, e, f #)+       ][ {{      | +-------+         }} ][      |       ][      d  -2~> ][      e  -1~> ][      f  -0~>+       ][ {{      |         |         }} ][      |       ][      |       ][      |       ][      |+       ][ {{      v         v         }} ][      v       ][      v       ][      v       ][      v+  0 ~> ][ {{ +1~> a -0~> ][ b -(-1)~> }} ][ +1~> I# -0~> ][ +1~> I# -0~> ][ +1~> I# -0~> ][ +1~> I# -0~>++As you can see, we have no budget left to justify unboxing `(a,b)` on the second+layer, which is good, because it would increase the number of args. Also note+that we can still unbox `c` through `f` in this layer, because doing so has a+net zero effect on budget.++Note [The OPAQUE pragma and avoiding the reboxing of arguments]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In https://gitlab.haskell.org/ghc/ghc/-/issues/13143 it was identified that when+a function 'f' with a NOINLINE pragma is W/W transformed, then the worker for+'f' should get the NOINLINE annotation, while the wrapper /should/ be inlined.++That's because if the wrapper for 'f' had stayed NOINLINE, then any worker of a+W/W-transformed /caller of/ 'f' would immediately rebox any unboxed arguments+that is applied to the wrapper of 'f'. When the wrapper is inlined, that kind of+reboxing does not happen.++But now we have functions with OPAQUE pragmas, which by definition+(See Note [OPAQUE pragma]) do not get W/W-transformed. So in order to avoid+reboxing workers of any W/W-transformed /callers of/ 'f' we need to strip all+boxity information from 'f' in the demand analysis. This will inform the+W/W-transformation code that boxed arguments of 'f' must definitely be passed+along in boxed form and as such dissuade the creation of reboxing workers.+-}++-- | How many registers does this type take after unarisation?+unariseArity :: Type -> Arity+unariseArity ty = length (typePrimRep ty)++data Budgets = MkB !Arity Budgets   -- An infinite list of arity budgets++earnTopBudget :: Budgets -> Budgets+earnTopBudget (MkB n bg) = MkB (n+1) bg++spendTopBudget :: Arity -> Budgets -> Budgets+spendTopBudget m (MkB n bg) = MkB (n-m) bg++positiveTopBudget :: Budgets -> Bool+positiveTopBudget (MkB n _) = n >= 0++finaliseArgBoxities :: AnalEnv -> Id -> Arity+                    -> [Demand] -> Divergence+                    -> CoreExpr -> ([Demand], CoreExpr)+-- POSTCONDITION:+-- If:    (dmds', rhs') = finaliseArgBoxitities ... dmds .. rhs+-- Then:+--     dmds' is the same as dmds (including length), except for boxity info+--     rhs'  is the same as rhs, except for dmd info on lambda binders+-- NB: For join points, length dmds might be greater than ww_arity+finaliseArgBoxities env fn ww_arity arg_dmds div rhs++  -- Check for an OPAQUE function: see Note [OPAQUE pragma]+  -- In that case, trim off all boxity info from argument demands+  -- and demand info on lambda binders+  -- See Note [The OPAQUE pragma and avoiding the reboxing of arguments]+  | isOpaquePragma (idInlinePragma fn)+  , let trimmed_arg_dmds = map trimBoxity arg_dmds+  = (trimmed_arg_dmds, set_lam_dmds trimmed_arg_dmds rhs)++  -- Check that we have enough visible binders to match the+  -- ww arity; if not, we won't do worker/wrapper+  -- This happens if we have simply  {f = g} or a PAP {f = h 13}+  -- we simply want to give f the same demand signature as g+  -- How can such bindings arise?  Perhaps from {-# NOLINE[2] f #-},+  -- or if the call to `f` is currently not-applied (map f xs).+  -- It's a bit of a corner case.  Anyway for now we pass on the+  -- unadulterated demands from the RHS, without any boxity trimming.+  | ww_arity > count isId bndrs+  = (arg_dmds, rhs)++  -- The normal case+  | otherwise+  = -- pprTrace "finaliseArgBoxities" (+    -- vcat [text "function:" <+> ppr fn+    --        , text "max" <+> ppr max_wkr_args+    --        , text "dmds before:" <+> ppr (map idDemandInfo (filter isId bndrs))+    --        , text "dmds after: " <+>  ppr arg_dmds' ]) $+    (arg_dmds', set_lam_dmds arg_dmds' rhs)+    -- set_lam_dmds: we must attach the final boxities to the lambda-binders+    -- of the function, both because that's kosher, and because CPR analysis+    -- uses the info on the binders directly.+  where+    opts           = ae_opts env+    (bndrs, _body) = collectBinders rhs+       -- NB: in the interesting code path, count isId bndrs >= ww_arity++    arg_triples :: [(Type, StrictnessMark, Demand)]+    arg_triples = take ww_arity $+                  [ (idType bndr, NotMarkedStrict, get_dmd bndr)+                  | bndr <- bndrs, isRuntimeVar bndr ]++    arg_dmds' = ww_arg_dmds ++ map trimBoxity (drop ww_arity arg_dmds)+                -- If ww_arity < length arg_dmds, the leftover ones+                -- will not be w/w'd, so trimBoxity them+                -- See Note [Worker/wrapper arity and join points] point (3)++    -- This is the key line, which uses almost-circular programming+    -- The remaining budget from one layer becomes the initial+    -- budget for the next layer down.  See Note [Worker argument budget]+    (remaining_budget, ww_arg_dmds) = go_args (MkB max_wkr_args remaining_budget) arg_triples+    unarise_arity = sum [ unariseArity (idType b) | b <- bndrs, isId b ]+    max_wkr_args  = dmd_max_worker_args opts `max` unarise_arity+                    -- This is the budget initialisation step of+                    -- Note [Worker argument budget]++    get_dmd :: Id -> Demand+    get_dmd bndr+      | is_bot_fn = unboxDeeplyDmd dmd -- See Note [Boxity for bottoming functions],+      | otherwise = dmd                --     case (B)+      where+        dmd = idDemandInfo bndr++    -- is_bot_fn:  see Note [Boxity for bottoming functions]+    is_bot_fn = div == botDiv++    go_args :: Budgets -> [(Type,StrictnessMark,Demand)] -> (Budgets, [Demand])+    go_args bg triples = mapAccumL go_arg bg triples++    go_arg :: Budgets -> (Type,StrictnessMark,Demand) -> (Budgets, Demand)+    go_arg bg@(MkB bg_top bg_inner) (ty, str_mark, dmd@(n :* _))+      = case wantToUnboxArg env ty str_mark dmd of+          DropAbsent -> (bg, dmd)++          DontUnbox | is_bot_fn, isTyVarTy ty -> (retain_budget, dmd)+                    | otherwise               -> (retain_budget, trimBoxity dmd)+            -- If bot: Keep deep boxity even though WW won't unbox+            -- See Note [Boxity for bottoming functions] case (A)+            -- trimBoxity: see Note [No lazy, Unboxed demands in demand signature]+            where+              retain_budget = spendTopBudget (unariseArity ty) bg+                -- spendTopBudget: spend from our budget the cost of the+                -- retaining the arg+                -- The unboxed case does happen here, for example+                --   app g x = g x :: (# Int, Int #)+                -- here, `x` is used `L`azy and thus Boxed++          DoUnbox triples+            | isUnboxedTupleType ty+            , (bg', dmds') <- go_args bg triples+            -> (bg', n :* (mkProd Unboxed $! dmds'))+                     -- See Note [Worker argument budget]+                     -- unboxed tuples are always unboxed, deeply+                     -- NB: Recurse with bg, *not* bg_inner! The unboxed fields+                     -- are at the same budget layer.++            | isUnboxedSumType ty+            -> pprPanic "Unboxing through unboxed sum" (ppr fn <+> ppr ty)+                     -- We currently don't return DoUnbox for unboxed sums.+                     -- But hopefully we will at some point. When that happens,+                     -- it would still be impossible to predict the effect+                     -- of dropping absent fields and unboxing others on the+                     -- unariseArity of the sum without losing sanity.+                     -- We could overwrite bg_top with the one from+                     -- retain_budget while still unboxing inside the alts as in+                     -- the tuple case for a conservative solution, though.++            | otherwise+            -> (spendTopBudget 1 (MkB bg_top final_bg_inner), final_dmd)+            where+              (bg_inner', dmds') = go_args (earnTopBudget bg_inner) triples+                     -- earnTopBudget: give back the cost of retaining the+                     -- arg we are insted unboxing.+              dmd' = n :* (mkProd Unboxed $! dmds')+              ~(final_bg_inner, final_dmd) -- "~": This match *must* be lazy!+                 | positiveTopBudget bg_inner' = (bg_inner', dmd')+                 | otherwise                   = (bg_inner,  trimBoxity dmd)++    set_lam_dmds :: [Demand] -> CoreExpr -> CoreExpr+    -- Attach the demands to the outer lambdas of this expression+    set_lam_dmds (dmd:dmds) (Lam v e)+      | isTyVar v = Lam v (set_lam_dmds (dmd:dmds) e)+      | otherwise = Lam (v `setIdDemandInfo` dmd) (set_lam_dmds dmds e)+    set_lam_dmds dmds (Cast e co) = Cast (set_lam_dmds dmds e) co+       -- This case happens for an OPAQUE function, which may look like+       --     f = (\x y. blah) |> co+       -- We give it strictness but no boxity (#22502)+    set_lam_dmds _ e = e+       -- In the OPAQUE case, the list of demands at this point might be+       -- non-empty, e.g., when looking at a PAP. Hence don't panic (#22997).++finaliseLetBoxity+  :: AnalEnv+  -> Type                   -- ^ Type of the let-bound Id+  -> Demand                 -- ^ How the Id is used+  -> Demand+-- See Note [Finalising boxity for let-bound Ids]+-- This function is like finaliseArgBoxities, but much simpler because+-- it has no "budget".  It simply unboxes strict demands, and stops+-- when it reaches a lazy one.+finaliseLetBoxity env ty dmd+  = go (ty, NotMarkedStrict, dmd)+  where+    go :: (Type,StrictnessMark,Demand) -> Demand+    go (ty, str, dmd@(n :* _)) =+      case wantToUnboxArg env ty str dmd of+        DropAbsent      -> dmd+        DontUnbox       -> trimBoxity dmd+        DoUnbox triples -> n :* (mkProd Unboxed $! map go triples)++wantToUnboxArg :: AnalEnv -> Type -> StrictnessMark -> Demand+               -> UnboxingDecision [(Type, StrictnessMark, Demand)]+wantToUnboxArg env ty str_mark dmd@(n :* _)+  = case canUnboxArg (ae_fam_envs env) ty dmd of+      DropAbsent -> DropAbsent+      DontUnbox  -> DontUnbox++      DoUnbox (DataConPatContext{ dcpc_dc      = dc+                                , dcpc_tc_args = tc_args+                                , dcpc_args    = dmds })+       -- OK, so we /can/ unbox it; but do we /want/ to?+       | not (isStrict n || isMarkedStrict str_mark)   -- Don't unbox a lazy field+         -- isMarkedStrict: see Note [Unboxing evaluated arguments] in DmdAnal+       -> DontUnbox++       | DefinitelyRecursive <- ae_rec_dc env dc+         -- See Note [Which types are unboxed?]+         -- and Note [Demand analysis for recursive data constructors]+       -> DontUnbox++       | otherwise  -- Bad cases dealt with: we want to unbox!+       -> DoUnbox (zip3 (dubiousDataConInstArgTys dc tc_args)+                        (dataConRepStrictness dc)+                        dmds)++{- *********************************************************************+*                                                                      *+                      Fixpoints+*                                                                      *+********************************************************************* -}++-- Recursive bindings+dmdFix :: TopLevelFlag+       -> AnalEnv                            -- Does not include bindings for this binding+       -> SubDemand+       -> [(Id,CoreExpr)]+       -> (AnalEnv, WeakDmds, [(Id,CoreExpr)]) -- Binders annotated with strictness info+dmdFix top_lvl env let_dmd orig_pairs+  = loop 1 initial_pairs+  where+    opts = ae_opts env+    -- See Note [Initialising strictness]+    initial_pairs | ae_virgin env = [(setIdDmdAndBoxSig opts id botSig, rhs) | (id, rhs) <- orig_pairs ]+                  | otherwise     = orig_pairs++    -- If fixed-point iteration does not yield a result we use this instead+    -- See Note [Safe abortion in the fixed-point iteration]+    abort :: (AnalEnv, WeakDmds, [(Id,CoreExpr)])+    abort = (env, weak_fv', zapped_pairs)+      where (weak_fv, pairs') = step True (zapIdDmdSig orig_pairs)+            -- Note [Lazy and unleashable free variables]+            weak_fvs = plusVarEnvList $ map (de_fvs . dmdSigDmdEnv . idDmdSig . fst) pairs'+            weak_fv'     = plusVarEnv_C plusDmd weak_fv $ mapVarEnv (const topDmd) weak_fvs+            zapped_pairs = zapIdDmdSig pairs'++    -- The fixed-point varies the idDmdSig field of the binders, and terminates if that+    -- annotation does not change any more.+    loop :: Int -> [(Id,CoreExpr)] -> (AnalEnv, WeakDmds, [(Id,CoreExpr)])+    loop n pairs = -- pprTrace "dmdFix" (ppr n <+> vcat [ ppr id <+> ppr (idDmdSig id)+                   --                                   | (id,_) <- pairs]) $+                   loop' n pairs++    loop' n pairs+      | found_fixpoint = (final_anal_env, weak_fv, pairs')+      | n == 10        = abort+      | otherwise      = loop (n+1) pairs'+      where+        found_fixpoint    = map (idDmdSig . fst) pairs' == map (idDmdSig . fst) pairs+        first_round       = n == 1+        (weak_fv, pairs') = step first_round pairs+        final_anal_env    = extendAnalEnvs top_lvl env (map fst pairs')++    step :: Bool -> [(Id, CoreExpr)] -> (WeakDmds, [(Id, CoreExpr)])+    step first_round pairs = (weak_fv, pairs')+      where+        -- In all but the first iteration, delete the virgin flag+        start_env | first_round = env+                  | otherwise   = nonVirgin env++        start = (extendAnalEnvs top_lvl start_env (map fst pairs), emptyVarEnv)++        !((_,!weak_fv), !pairs') = mapAccumL my_downRhs start pairs+                -- mapAccumL: Use the new signature to do the next pair+                -- The occurrence analyser has arranged them in a good order+                -- so this can significantly reduce the number of iterations needed++        my_downRhs (env, weak_fv) (id,rhs)+          = -- pprTrace "my_downRhs" (ppr id $$ ppr (idDmdSig id) $$ ppr sig) $+            ((env', weak_fv'), (id', rhs'))+          where+            !(!env', !weak_fv1, !id', !rhs') = dmdAnalRhsSig top_lvl Recursive env let_dmd id rhs+            !weak_fv'                    = plusVarEnv_C plusDmd weak_fv weak_fv1++    zapIdDmdSig :: [(Id, CoreExpr)] -> [(Id, CoreExpr)]+    zapIdDmdSig pairs = [(setIdDmdSig id nopSig, rhs) | (id, rhs) <- pairs ]++{- Note [Safe abortion in the fixed-point iteration]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Fixed-point iteration may fail to terminate. But we cannot simply give up and+return the environment and code unchanged! We still need to do one additional+round, for two reasons:++ * To get information on used free variables (both lazy and strict!)+   (see Note [Lazy and unleashable free variables])+ * To ensure that all expressions have been traversed at least once, and any left-over+   strictness annotations have been updated.++This final iteration does not add the variables to the strictness signature+environment, which effectively assigns them 'nopSig' (see "getStrictness")++Note [Trimming a demand to a type]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There are two reasons we sometimes trim a demand to match a type.+  1. GADTs+  2. Recursive products and widening++More on both below.  But the bottom line is: we really don't want to+have a binder whose demand is more deeply-nested than its type+"allows". So in findBndrDmd we call trimToType and findTypeShape to+trim the demand on the binder to a form that matches the type++Now to the reasons. For (1) consider+  f :: a -> Bool+  f x = case ... of+          A g1 -> case (x |> g1) of (p,q) -> ...+          B    -> error "urk"++where A,B are the constructors of a GADT.  We'll get a 1P(L,L) demand+on x from the A branch, but that's a stupid demand for x itself, which+has type 'a'. Indeed we get ASSERTs going off (notably in+splitUseProdDmd, #8569).++For (2) consider+  data T = MkT Int T    -- A recursive product+  f :: Int -> T -> Int+  f 0 _         = 0+  f _ (MkT n t) = f n t++Here f is lazy in T, but its *usage* is infinite: P(L,P(L,P(L, ...))).+Notice that this happens because T is a product type, and is recursive.+If we are not careful, we'll fail to iterate to a fixpoint in dmdFix,+and bale out entirely, which is inefficient and over-conservative.++Worse, as we discovered in #18304, the size of the usages we compute+can grow /exponentially/, so even 10 iterations costs far too much.+Especially since we then discard the result.++To avoid this we use the same findTypeShape function as for (1), but+arrange that it trims the demand if it encounters the same type constructor+twice (or three times, etc).  We use our standard RecTcChecker mechanism+for this -- see GHC.Core.Opt.WorkWrap.Utils.findTypeShape.++This is usually call "widening".  We could do it just in dmdFix, but+since are doing this findTypeShape business /anyway/ because of (1),+and it has all the right information to hand, it's extremely+convenient to do it there.++-}++{- *********************************************************************+*                                                                      *+                 Strictness signatures and types+*                                                                      *+********************************************************************* -}++noArgsDmdType :: DmdEnv -> DmdType+noArgsDmdType dmd_env = DmdType dmd_env []++coercionDmdEnv :: Coercion -> DmdEnv+coercionDmdEnv co = coercionsDmdEnv [co]++coercionsDmdEnv :: [Coercion] -> DmdEnv+coercionsDmdEnv cos+  = mkTermDmdEnv $ mapVarEnv (const topDmd) $ getUniqSet $ coVarsOfCos cos+  -- The VarSet from coVarsOfCos is really a VarEnv Var++addVarDmd :: DmdType -> Var -> Demand -> DmdType+addVarDmd (DmdType fv ds) var dmd+  = DmdType (addVarDmdEnv fv var dmd) ds++addWeakFVs :: DmdType -> WeakDmds -> DmdType+addWeakFVs dmd_ty weak_fvs+  = dmd_ty `plusDmdType` mkTermDmdEnv weak_fvs+        -- Using plusDmdType (rather than just plus'ing the envs)+        -- is vital.  Consider+        --      let f = \x -> (x,y)+        --      in  error (f 3)+        -- Here, y is treated as a lazy-fv of f, but we must `plusDmd` that L+        -- demand with the bottom coming up from 'error'+        --+        -- I got a loop in the fixpointer without this, due to an interaction+        -- with the weak_fv filtering in dmdAnalRhsSig.  Roughly, it was+        --      letrec f n x+        --          = letrec g y = x `fatbar`+        --                         letrec h z = z + ...g...+        --                         in h (f (n-1) x)+        --      in ...+        -- In the initial iteration for f, f=Bot+        -- Suppose h is found to be strict in z, but the occurrence of g in its RHS+        -- is lazy.  Now consider the fixpoint iteration for g, esp the demands it+        -- places on its free variables.  Suppose it places none.  Then the+        --      x `fatbar` ...call to h...+        -- will give a x->V demand for x.  That turns into a L demand for x,+        -- which floats out of the defn for h.  Without the modifyEnv, that+        -- L demand doesn't get both'd with the Bot coming up from the inner+        -- call to f.  So we just get an L demand for x for g.++setBndrsDemandInfo :: HasDebugCallStack => [Var] -> [Demand] -> [Var]+setBndrsDemandInfo (b:bs) ds+  | isTyVar b = b : setBndrsDemandInfo bs ds+setBndrsDemandInfo (b:bs) (d:ds) =+    let !new_info = setIdDemandInfo b d+        !vars = setBndrsDemandInfo bs ds+    in new_info : vars+setBndrsDemandInfo [] ds = assert (null ds) []+setBndrsDemandInfo bs _  = pprPanic "setBndrsDemandInfo" (ppr bs)++annotateLamIdBndr :: AnalEnv+                  -> DmdType    -- Demand type of body+                  -> Id         -- Lambda binder+                  -> WithDmdType Id  -- Demand type of lambda+                                     -- and binder annotated with demand++annotateLamIdBndr env dmd_ty id+-- For lambdas we add the demand to the argument demands+-- Only called for Ids+  = assert (isId id) $+    -- pprTrace "annLamBndr" (vcat [ppr id, ppr dmd_ty, ppr final_ty]) $+    WithDmdType main_ty new_id+  where+    new_id  = setIdDemandInfo id dmd+    main_ty = addDemand dmd dmd_ty'+    WithDmdType dmd_ty' dmd = findBndrDmd env dmd_ty id++{- Note [NOINLINE and strictness]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+At one point we disabled strictness for NOINLINE functions, on the+grounds that they should be entirely opaque.  But that lost lots of+useful semantic strictness information, so now we analyse them like+any other function, and pin strictness information on them.++That in turn forces us to worker/wrapper them; see+Note [Worker/wrapper for NOINLINE functions] in GHC.Core.Opt.WorkWrap.+++Note [Lazy and unleashable free variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We put the strict and once-used FVs in the DmdType of the Id, so+that at its call sites we unleash demands on its strict fvs.+An example is 'roll' in imaginary/wheel-sieve2+Something like this:+        roll x = letrec+                     go y = if ... then roll (x-1) else x+1+                 in+                 go ms+We want to see that roll is strict in x, which is because+go is called.   So we put the DmdEnv for x in go's DmdType.++Another example:++        f :: Int -> Int -> Int+        f x y = let t = x+1+            h z = if z==0 then t else+                  if z==1 then x+1 else+                  x + h (z-1)+        in h y++Calling h does indeed evaluate x, but we can only see+that if we unleash a demand on x at the call site for t.++Incidentally, here's a place where lambda-lifting h would+lose the cigar --- we couldn't see the joint strictness in t/x++        ON THE OTHER HAND++We don't want to put *all* the fv's from the RHS into the+DmdType. Because++ * it makes the strictness signatures larger, and hence slows down fixpointing++and++ * it is useless information at the call site anyways:+   For lazy, used-many times fv's we will never get any better result than+   that, no matter how good the actual demand on the function at the call site+   is (unless it is always absent, but then the whole binder is useless).++Therefore we exclude lazy multiple-used fv's from the environment in the+DmdType.++But now the signature lies! (Missing variables are assumed to be absent.) To+make up for this, the code that analyses the binding keeps the demand on those+variable separate (usually called "weak_fv") and adds it to the demand of the+whole binding later.++What if we decide _not_ to store a strictness signature for a binding at all, as+we do when aborting a fixed-point iteration? The we risk losing the information+that the strict variables are being used. In that case, we take all free variables+mentioned in the (unsound) strictness signature, conservatively approximate the+demand put on them (topDmd), and add that to the "weak_fv" returned by "dmdFix".+++************************************************************************+*                                                                      *+\subsection{Strictness signatures}+*                                                                      *+************************************************************************+-}+++data AnalEnv = AE+  { ae_opts      :: !DmdAnalOpts+  -- ^ Analysis options+  , ae_sigs      :: !SigEnv+  , ae_virgin    :: !Bool+  -- ^ True on first iteration only. See Note [Initialising strictness]+  , ae_fam_envs  :: !FamInstEnvs+  , ae_rec_dc    :: DataCon -> IsRecDataConResult+  -- ^ Memoised result of 'GHC.Core.Opt.WorkWrap.Utils.isRecDataCon'+  }++        -- We use the se_env to tell us whether to+        -- record info about a variable in the DmdEnv+        -- We do so if it's a LocalId, but not top-level+        --+        -- The DmdEnv gives the demand on the free vars of the function+        -- when it is given enough args to satisfy the strictness signature++type SigEnv = VarEnv (DmdSig, TopLevelFlag)++instance Outputable AnalEnv where+  ppr env = text "AE" <+> braces (vcat+         [ text "ae_virgin =" <+> ppr (ae_virgin env)+         , text "ae_sigs =" <+> ppr (ae_sigs env)+         ])++emptyAnalEnv :: DmdAnalOpts -> FamInstEnvs -> AnalEnv+emptyAnalEnv opts fam_envs+    = AE { ae_opts         = opts+         , ae_sigs         = emptySigEnv+         , ae_virgin       = True+         , ae_fam_envs     = fam_envs+         , ae_rec_dc       = memoiseUniqueFun (isRecDataCon fam_envs 3)+         }++-- | Unset the 'dmd_strict_dicts' flag if any of the given bindings is a DFun+-- binding. Part of the mechanism that detects+-- Note [Do not strictify a DFun's parameter dictionaries].+enterDFun :: CoreBind -> AnalEnv -> AnalEnv+enterDFun bind env+  | any isDFunId (bindersOf bind)+  = env { ae_opts = (ae_opts env) { dmd_strict_dicts = False } }+  | otherwise+  = env++emptySigEnv :: SigEnv+emptySigEnv = emptyVarEnv++-- | Extend an environment with the strictness sigs attached to the Ids+extendAnalEnvs :: TopLevelFlag -> AnalEnv -> [Id] -> AnalEnv+extendAnalEnvs top_lvl env vars+  = env { ae_sigs = extendSigEnvs top_lvl (ae_sigs env) vars }++extendSigEnvs :: TopLevelFlag -> SigEnv -> [Id] -> SigEnv+extendSigEnvs top_lvl sigs vars+  = extendVarEnvList sigs [ (var, (idDmdSig var, top_lvl)) | var <- vars]++extendAnalEnv :: TopLevelFlag -> AnalEnv -> Id -> DmdSig -> AnalEnv+extendAnalEnv top_lvl env var sig+  = env { ae_sigs = extendSigEnv top_lvl (ae_sigs env) var sig }++extendSigEnv :: TopLevelFlag -> SigEnv -> Id -> DmdSig -> SigEnv+extendSigEnv top_lvl sigs var sig = extendVarEnv sigs var (sig, top_lvl)++lookupSigEnv :: AnalEnv -> Id -> Maybe (DmdSig, TopLevelFlag)+lookupSigEnv env id = lookupVarEnv (ae_sigs env) id++addInScopeAnalEnv :: AnalEnv -> Var -> AnalEnv+addInScopeAnalEnv env id = env { ae_sigs = delVarEnv (ae_sigs env) id }++addInScopeAnalEnvs :: AnalEnv -> [Var] -> AnalEnv+addInScopeAnalEnvs env ids = env { ae_sigs = delVarEnvList (ae_sigs env) ids }++nonVirgin :: AnalEnv -> AnalEnv+nonVirgin env = env { ae_virgin = False }++findBndrsDmds :: AnalEnv -> DmdType -> [Var] -> WithDmdType [Demand]+-- Return the demands on the Ids in the [Var]+findBndrsDmds env dmd_ty bndrs+  = go dmd_ty bndrs+  where+    go dmd_ty []  = WithDmdType dmd_ty []+    go dmd_ty (b:bs)+      | isId b    = let WithDmdType dmd_ty1 dmds = go dmd_ty bs+                        WithDmdType dmd_ty2 dmd  = findBndrDmd env dmd_ty1 b+                    in WithDmdType dmd_ty2  (dmd : dmds)+      | otherwise = go dmd_ty bs++findBndrDmd :: AnalEnv -> DmdType -> Id -> WithDmdType Demand+-- See Note [Trimming a demand to a type]+findBndrDmd env dmd_ty id+  = -- pprTrace "findBndrDmd" (ppr id $$ ppr dmd_ty $$ ppr starting_dmd $$ ppr dmd') $+    WithDmdType dmd_ty' dmd'+  where+    dmd' = strictify $+           trimToType starting_dmd (findTypeShape fam_envs id_ty)++    (dmd_ty', starting_dmd) = peelFV dmd_ty id++    id_ty = idType id++    strictify dmd+      -- See Note [Making dictionary parameters strict]+      -- and Note [Do not strictify a DFun's parameter dictionaries]+      | dmd_strict_dicts (ae_opts env)+      = strictifyDictDmd id_ty dmd+      | otherwise+      = dmd++    fam_envs = ae_fam_envs env++{- Note [Bringing a new variable into scope]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+   f x = blah+   g = ...(\f. ...f...)...++In the body of the '\f', any occurrence of `f` refers to the lambda-bound `f`,+not the top-level `f` (which will be in `ae_sigs`).  So it's very important+to delete `f` from `ae_sigs` when we pass a lambda/case/let-up binding of `f`.+Otherwise chaos results (#22718).++Note [Making dictionary parameters strict]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The Opt_DictsStrict flag makes GHC use call-by-value for dictionaries.  Why?++* Generally CBV is more efficient.++* A datatype dictionary is always non-bottom and never takes much work to+  compute.  E.g. a DFun from an instance decl always returns a dictionary+  record immediately.  See DFunUnfolding in CoreSyn.+  See also Note [Recursive superclasses] in TcInstDcls.++See #17758 for more background and perf numbers.++Wrinkles:++* A newtype dictionary is *not* always non-bottom.  E.g.+      class C a where op :: a -> a+      instance C Int where op = error "urk"+  Now a value of type (C Int) is just a newtype wrapper (a cast) around+  the error thunk.  Don't strictify these!++* Strictifying DFuns risks destroying the invariant that DFuns never take much+  work to compute, so we don't do it.+  See Note [Do not strictify a DFun's parameter dictionaries] for details.++* Although worker/wrapper *could* unbox strictly used dictionaries, we do not do+  so; see Note [Do not unbox class dictionaries].++The implementation is extremely simple: just make the strictness+analyser strictify the demand on a dictionary binder in+'findBndrDmd' if the binder does not belong to a DFun.++Note [Do not strictify a DFun's parameter dictionaries]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The typechecker can tie recursive knots involving (non-recursive) DFuns, so+we must not strictify a DFun's parameter dictionaries (#22549).+T22549 has an example involving undecidable instances that <<loop>>s when we+strictify the DFun of, e.g., `$fEqSeqT`:++  Main.$fEqSeqT+    = \@m @a ($dEq :: Eq (m (ViewT m a))) ($dMonad :: Monad m) ->+        GHC.Classes.C:Eq @(SeqT m a) ($c== @m @a $dEq $dMonad)+                                     ($c/= @m @a $dEq $dMonad)++  Rec {+    $dEq_a = Main.$fEqSeqT @Identity @Int $dEq_b Main.$fMonadIdentity+    $dEq_b = ... $dEq_a ... <another strict context due to DFun>+  }++If we make `$fEqSeqT` strict in `$dEq`, we'll collapse the Rec group into a+giant, <<loop>>ing thunk.++To prevent that, we never strictify dictionary params when inside a DFun.+That is implemented by unsetting 'dmd_strict_dicts' when entering a DFun.++See also Note [Speculative evaluation] in GHC.CoreToStg.Prep which has a rather+similar example in #20836. We may never speculate *arguments* of (recursive)+DFun calls, likewise we should not mark *formal parameters* of recursive DFuns+as strict.++Note [Initialising strictness]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+See section 9.2 (Finding fixpoints) of the paper.++Our basic plan is to initialise the strictness of each Id in a+recursive group to "bottom", and find a fixpoint from there.  However,+this group B might be inside an *enclosing* recursive group A, in+which case we'll do the entire fixpoint shebang on for each iteration+of A. This can be illustrated by the following example:++Example:++  f [] = []+  f (x:xs) = let g []     = f xs+                 g (y:ys) = y+1 : g ys+              in g (h x)++At each iteration of the fixpoint for f, the analyser has to find a+fixpoint for the enclosed function g. In the meantime, the demand+values for g at each iteration for f are *greater* than those we+encountered in the previous iteration for f. Therefore, we can begin+the fixpoint for g not with the bottom value but rather with the+result of the previous analysis. I.e., when beginning the fixpoint+process for g, we can start from the demand signature computed for g+previously and attached to the binding occurrence of g.++To speed things up, we initialise each iteration of A (the enclosing+one) from the result of the last one, which is neatly recorded in each+binder.  That way we make use of earlier iterations of the fixpoint+algorithm. (Cunning plan.)++But on the *first* iteration we want to *ignore* the current strictness+of the Id, and start from "bottom".  Nowadays the Id can have a current+strictness, because interface files record strictness for nested bindings.+To know when we are in the first iteration, we look at the ae_virgin+field of the AnalEnv.+++Note [Final Demand Analyser run]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Some of the information that the demand analyser determines is not always+preserved by the simplifier.  For example, the simplifier will happily rewrite+  \y [Demand=MU] let x = y in x + x+to+  \y [Demand=MU] y + y+which is quite a lie: Now y occurs more than just once.++The once-used information is (currently) only used by the code+generator, though.  So:++ * We zap the used-once info in the worker-wrapper;+   see Note [Zapping Used Once info in WorkWrap] in+   GHC.Core.Opt.WorkWrap.+   If it's not reliable, it's better not to have it at all.++ * Just before TidyCore, we add a pass of the demand analyser,+      but WITHOUT subsequent worker/wrapper and simplifier,+   right before TidyCore.  See SimplCore.getCoreToDo.++   This way, correct information finds its way into the module interface+   (strictness signatures!) and the code generator (single-entry thunks!)++Note that, in contrast, the single-call information (C(M,..)) /can/ be relied upon, as the simplifier tends to be very careful about not duplicating actual function calls.
GHC/Core/Opt/Exitify.hs view
@@ -36,20 +36,24 @@ -}  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.Core-import GHC.Core.Utils-import GHC.Utils.Monad.State.Strict-import GHC.Builtin.Uniques import GHC.Types.Var.Set import GHC.Types.Var.Env-import GHC.Core.FVs-import GHC.Data.FastString-import GHC.Core.Type+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 @@ -62,7 +66,7 @@     goTopLvl (Rec pairs) = Rec (map (second (go in_scope_toplvl)) pairs)       -- Top-level bindings are never join points -    in_scope_toplvl = emptyInScopeSet `extendInScopeSetList` bindersOfBinds binds+    in_scope_toplvl = emptyInScopeSet `extendInScopeSetBndrs` binds      go :: InScopeSet -> CoreExpr -> CoreExpr     go _    e@(Var{})       = e@@ -94,7 +98,7 @@       | otherwise   = Let (Rec pairs') body'       where         is_join_rec = any (isJoinId . fst) pairs-        in_scope'   = in_scope `extendInScopeSetList` bindersOf (Rec pairs)+        in_scope'   = in_scope `extendInScopeSetBind` (Rec pairs)         pairs'      = mapSnd (go in_scope') pairs         body'       = go in_scope' body @@ -160,7 +164,7 @@     go captured (_, AnnLet ann_bind body)         -- join point, RHS and body are in tail-call position         | AnnNonRec j rhs <- ann_bind-        , Just join_arity <- isJoinId_maybe j+        , 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'@@ -265,7 +269,7 @@                          `extendInScopeSet` exit_id_tmpl -- just cosmetics     return (uniqAway avoid exit_id_tmpl)   where-    exit_id_tmpl = mkSysLocal (fsLit "exit") initExitJoinUnique Many ty+    exit_id_tmpl = mkSysLocal (fsLit "exit") initExitJoinUnique ManyTy ty                     `asJoinId` join_arity  addExit :: InScopeSet -> JoinArity -> CoreExpr -> ExitifyM JoinId@@ -306,7 +310,7 @@   in …  where the floated expression `x+x` is a bit more complicated, but still not-intersting.+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:@@ -315,7 +319,7 @@    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 mentiones at least one free,+So we only hoist an exit expression out if it mentions at least one free, non-imported variable.  Note [Jumps can be interesting]@@ -430,7 +434,7 @@ To prevent this, we need to recognize exit join points, and then disable inlining. -Exit join points, recognizeable using `isExitJoinId` are join points with an+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`,
GHC/Core/Opt/FloatIn.hs view
@@ -22,21 +22,25 @@ 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, Levity(Unlifted) )-import GHC.Types.Id         ( isOneShotBndr, idType, isJoinId, isJoinId_maybe )+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 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.@@ -123,7 +127,7 @@ ************************************************************************ -} -type FreeVarSet  = DIdSet+type FreeVarSet  = DVarSet type BoundVarSet = DIdSet  data FloatInBind = FB BoundVarSet FreeVarSet FloatBind@@ -131,11 +135,17 @@         -- of recursive bindings, the set doesn't include the bound         -- variables. -type FloatInBinds = [FloatInBind]-        -- In reverse dependency order (innermost binder first)+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-       -> FloatInBinds      -- Binds we're trying to drop+       -> RevFloatInBinds   -- Binds we're trying to drop                             -- as far "inwards" as possible        -> CoreExprWithFVs   -- Input expr        -> CoreExpr          -- Result@@ -146,13 +156,12 @@ 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 ++ co_drop) $+  = wrapFloats drop_here $     Cast (fiExpr platform e_drop expr) co   where-    [drop_here, e_drop, co_drop]-      = sepBindsByDropPoint platform False-          [freeVarsOf expr, freeVarsOfAnn co_ann]-          to_drop+    (drop_here, [e_drop])+      = sepBindsByDropPoint platform False to_drop+          (freeVarsOfAnn co_ann) [freeVarsOf expr]  {- Applications: we do float inside applications, mainly because we@@ -161,29 +170,27 @@ -}  fiExpr platform to_drop ann_expr@(_,AnnApp {})-  = wrapFloats drop_here $ wrapFloats extra_drop $+  = wrapFloats drop_here $     mkTicks ticks $     mkApps (fiExpr platform fun_drop ann_fun)-           (zipWithEqual "fiExpr" (fiExpr platform) arg_drops ann_args)+           (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_ty  = exprType (deAnnotate ann_fun)     fun_fvs = freeVarsOf ann_fun-    arg_fvs = map freeVarsOf ann_args -    (drop_here : extra_drop : fun_drop : arg_drops)-       = sepBindsByDropPoint platform False-                             (extra_fvs : fun_fvs : arg_fvs)-                             to_drop+    (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 -    (_, extra_fvs) = foldl' add_arg (fun_ty, extra_fvs0) ann_args-    extra_fvs0 = case ann_fun of+    (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]@@ -191,17 +198,11 @@           -- join point, floating it in isn't especially harmful but it's           -- useless since the simplifier will immediately float it back out.) -    add_arg :: (Type,FreeVarSet) -> CoreExprWithFVs -> (Type,FreeVarSet)-    add_arg (fun_ty, extra_fvs) (_, AnnType ty)-      = (piResultTy fun_ty ty, extra_fvs)--    add_arg (fun_ty, extra_fvs) (arg_fvs, arg)-      | noFloatIntoArg arg arg_ty-      = (res_ty, extra_fvs `unionDVarSet` arg_fvs)-      | otherwise-      = (res_ty, extra_fvs)-      where-       (_, arg_ty, res_ty) = splitFunTy fun_ty+    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] ~~~~~~~~~~~~~~~~~~~~~~~@@ -212,15 +213,6 @@ But, while this may be unusual it is not actually wrong, and it did once happen (#15696). -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@@ -242,6 +234,29 @@ 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.@@ -283,7 +298,6 @@ 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@@ -303,6 +317,36 @@ 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 _ _)@@ -311,11 +355,18 @@   = wrapFloats to_drop (mkLams bndrs (fiExpr platform [] body))    | otherwise           -- Float inside-  = mkLams bndrs (fiExpr platform to_drop body)+  = 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@@ -395,6 +446,30 @@ 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@@ -403,12 +478,11 @@ But there are wrinkles  * Which unlifted cases do we float?-  See Note [PrimOp can_fail and has_side_effects] in GHC.Builtin.PrimOps which-  explains:-   - We can float in can_fail primops (which concerns imprecise exceptions),-     but we can't float them out.-   - But we can float a has_side_effects primop, but NOT inside a lambda,-     so for now we don't float them at all. Hence exprOkForSideEffects.+  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#'.@@ -420,7 +494,7 @@   ===>     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 (can_fail), the thunk will stay+  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@@ -449,63 +523,67 @@ fiExpr platform to_drop (_, AnnCase scrut case_bndr _ [AnnAlt con alt_bndrs rhs])   | isUnliftedType (idType case_bndr)      -- binders have a fixed RuntimeRep so it's OK to call isUnliftedType-  , exprOkForSideEffects (deAnnotate scrut)+  , exprOkToDiscard (deAnnotate scrut)       -- See Note [Floating primops]   = wrapFloats shared_binds $     fiExpr platform (case_float : rhs_binds) rhs   where-    case_float = FB (mkDVarSet (case_bndr : alt_bndrs)) scrut_fvs+    case_float = FB all_bndrs scrut_fvs                     (FloatCase scrut' case_bndr con alt_bndrs)     scrut'     = fiExpr platform scrut_binds scrut-    rhs_fvs    = freeVarsOf rhs `delDVarSetList` (case_bndr : alt_bndrs)-    scrut_fvs  = freeVarsOf 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-           [scrut_fvs, rhs_fvs]-           to_drop+    (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 "fiExpr" fi_alt alts_drops_s alts)+         (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-           [scrut_fvs, all_alts_fvs]-           to_drop+    (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)-      | [ _ ] <- alts = [] : [alts_drops]-      | otherwise     = sepBindsByDropPoint platform True alts_fvs alts_drops+    (drop_here2, alts_drops_s)+       = sepBindsByDropPoint platform True alts_drops emptyDVarSet alts_fvs -    scrut_fvs    = freeVarsOf scrut-    alts_fvs     = map alt_fvs alts-    all_alts_fvs = unionDVarSets alts_fvs-    alt_fvs (AnnAlt _con args rhs)-      = foldl' delDVarSet (freeVarsOf rhs) (case_bndr:args)-           -- Delete case_bndr and args from free vars of rhs-           -- to get free vars of alt+    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-       -> FloatInBinds      -- Binds we're trying to drop-                            -- as far "inwards" as possible-       -> CoreBindWithFVs   -- Input binding-       -> DVarSet           -- Free in scope of binding-       -> ( FloatInBinds    -- Land these before-          , FloatInBind     -- The binding itself-          , FloatInBinds)   -- Land these after+       -> 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-  = ( extra_binds ++ shared_binds          -- Land these before-                                           -- See Note [extra_fvs (1)] and Note [extra_fvs (2)]+  = ( 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@@ -523,10 +601,9 @@         -- 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 platform False-            [extra_fvs, rhs_fvs, body_fvs2]-            to_drop+    (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@@ -534,7 +611,7 @@                         -- Don't forget the rule_fvs; the binding mentions them!  fiBind platform to_drop (AnnRec bindings) body_fvs-  = ( extra_binds ++ shared_binds+  = ( shared_binds     , FB (mkDVarSet ids) rhs_fvs'          (FloatLet (Rec (fi_bind rhss_binds bindings)))     , body_binds )@@ -548,28 +625,27 @@                 unionDVarSets [ rhs_fvs | (bndr, (rhs_fvs, rhs)) <- bindings                               , noFloatIntoRhs Recursive bndr rhs ] -    (shared_binds:extra_binds:body_binds:rhss_binds)-        = sepBindsByDropPoint platform False-            (extra_fvs:body_fvs:rhss_fvs)-            to_drop+    (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 :: [FloatInBinds]       -- one per "drop pt" conjured w/ fvs_of_rhss+    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 "fi_bind" pairs to_drops ]+        | ((binder, rhs), to_drop) <- zipEqual pairs to_drops ]  -------------------fiRhs :: Platform -> FloatInBinds -> CoreBndr -> CoreExprWithFVs -> CoreExpr+fiRhs :: Platform -> RevFloatInBinds -> CoreBndr -> CoreExprWithFVs -> CoreExpr fiRhs platform to_drop bndr rhs-  | Just join_arity <- isJoinId_maybe bndr+  | JoinPoint join_arity <- idJoinPointHood bndr   , let (bndrs, body) = collectNAnnBndrs join_arity rhs   = mkLams bndrs (fiExpr platform to_drop body)   | otherwise@@ -588,14 +664,14 @@   | isJoinId bndr   = isRec is_rec -- Joins are one-shot iff non-recursive -  | otherwise-  = noFloatIntoArg rhs (idType bndr)+  | definitelyUnliftedType (idType bndr)+  = True  -- Preserve let-can-float invariant, see Note [noFloatInto considerations] -noFloatIntoArg :: CoreExprWithFVs' -> Type -> Bool-noFloatIntoArg expr expr_ty-  | Just Unlifted <- typeLevity_maybe expr_ty-  = True  -- See Note [Do not destroy the let/app invariant]+  | otherwise+  = noFloatIntoArg rhs +noFloatIntoArg :: CoreExprWithFVs' -> Bool+noFloatIntoArg expr    | AnnLam bndr e <- expr    , (bndrs, _) <- collectAnnBndrs e    =  noFloatIntoLam (bndr:bndrs)  -- Wrinkle 1 (a)@@ -610,11 +686,11 @@ {- Note [noFloatInto considerations] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When do we want to float bindings into-   - noFloatIntoRHs: the RHS of a let-binding+   - noFloatIntoRhs: the RHS of a let-binding    - noFloatIntoArg: the argument of a function application -Definitely don't float in if it has unlifted type; that-would destroy the let/app invariant.+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@@ -667,69 +743,85 @@ We have to maintain the order on these drop-point-related lists. -} --- pprFIB :: FloatInBinds -> SDoc+-- pprFIB :: RevFloatInBinds -> SDoc -- pprFIB fibs = text "FIB:" <+> ppr [b | FB _ _ b <- fibs]  sepBindsByDropPoint     :: Platform-    -> Bool                -- True <=> is case expression-    -> [FreeVarSet]        -- One set of FVs per drop point-                           -- Always at least two long!-    -> FloatInBinds        -- Candidate floaters-    -> [FloatInBinds]      -- FIRST one is bindings which must not be floated-                           -- inside any drop point; the rest correspond-                           -- one-to-one with the input list of FV sets+    -> 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) -sepBindsByDropPoint platform is_case drop_pts floaters+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-  = [] : [[] | _ <- drop_pts]+  = ([], [[] | _ <- fork_fvs])    | otherwise-  = assert (drop_pts `lengthAtLeast` 2) $-    go floaters (map (\fvs -> (fvs, [])) (emptyDVarSet : drop_pts))+  = go floaters (initDropBox here_fvs) (map initDropBox fork_fvs)   where-    n_alts = length drop_pts+    n_alts = length fork_fvs -    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 :: RevFloatInBinds -> DropBox -> [DropBox]+       -> (RevFloatInBinds, [RevFloatInBinds])+        -- The *first* one in the pair is the drop_here set -    go [] drop_boxes = map (reverse . snd) drop_boxes+    go [] here_box fork_boxes+        = (dropBoxFloats here_box, map dropBoxFloats fork_boxes) -    go (bind_w_fvs@(FB bndrs bind_fvs bind) : binds) drop_boxes@(here_box : fork_boxes)-        = go binds new_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 : used_in_flags) = [ fvs `intersectsDVarSet` bndrs-                                        | (fvs, _) <- drop_boxes]+          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_used_alts == n_alts   -- Used in all, don't push-                                                  -- Remember n_alts > 1+            | 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_boxes | drop_here = (insert here_box : fork_boxes)-                    | otherwise = (here_box : new_fork_boxes)--          new_fork_boxes = zipWithEqual "FloatIn.sepBinds" insert_maybe+          new_fork_boxes = zipWithEqual insert_maybe                                         fork_boxes used_in_flags            insert :: DropBox -> DropBox@@ -738,9 +830,7 @@           insert_maybe box True  = insert box           insert_maybe box False = box -    go _ _ = panic "sepBindsByDropPoint/go" - {- Note [Duplicating floats] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ For case expressions we duplicate the binding if it is reasonably@@ -756,14 +846,14 @@ so we don't duplicate then. -} -floatedBindsFVs :: FloatInBinds -> FreeVarSet+floatedBindsFVs :: RevFloatInBinds -> 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 :: RevFloatInBinds -> CoreExpr -> CoreExpr+-- Remember RevFloatInBinds is in *reverse* dependency order wrapFloats []               e = e wrapFloats (FB _ _ fl : bs) e = wrapFloats bs (wrapFloat fl e)
GHC/Core/Opt/FloatOut.hs view
@@ -15,13 +15,14 @@ import GHC.Core import GHC.Core.Utils import GHC.Core.Make-import GHC.Core.Opt.Arity ( exprArity, etaExpand )+-- import GHC.Core.Opt.Arity ( exprArity, etaExpand ) import GHC.Core.Opt.Monad ( FloatOutSwitches(..) ) -import GHC.Driver.Session+import GHC.Driver.Flags  ( DumpFlag (..) ) import GHC.Utils.Logger-import GHC.Types.Id      ( Id, idArity, idType, isDeadEndId,-                           isJoinId, isJoinId_maybe )+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 )@@ -108,53 +109,7 @@ @ 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 GHC.Core), 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 GHC.Core.Opt.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}@@ -218,14 +173,7 @@   -- 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 GHC.Core.Opt.SetLevels-    let rhs'' | isDeadEndId var-              , exprArity rhs' < idArity var = etaExpand (idArity var) rhs'-              | otherwise                    = rhs'--    in (fs, rhs_floats, [NonRec var rhs'']) }+      (fs, rhs_floats, [NonRec var rhs']) }  floatBind (Rec pairs)   = case floatList do_pair pairs of { (fs, rhs_floats, new_pairs) ->@@ -349,7 +297,7 @@ 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.+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.@@ -401,14 +349,14 @@ 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') ->+  = 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             = asJoinCeilLvl (floatSpecLevel lam_spec)+        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@@ -418,11 +366,11 @@  floatExpr (Tick tickish expr)   | tickish `tickishScopesLike` SoftScope -- not scoped, can just float-  = case (atJoinCeiling $ floatExpr expr)    of { (fs, floating_defns, expr') ->+  = case (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') ->+  = 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@@ -438,7 +386,7 @@   = pprPanic "floatExpr tick" (ppr tickish)  floatExpr (Cast expr co)-  = case (atJoinCeiling $ floatExpr expr) of { (fs, floating_defns, expr') ->+  = case (floatExpr expr) of { (fs, floating_defns, expr') ->     (fs, floating_defns, Cast expr' co) }  floatExpr (Let bind body)@@ -469,8 +417,8 @@   = case case_spec of       FloatMe dest_lvl  -- Case expression moves         | [Alt con@(DataAlt {}) bndrs rhs] <- alts-        -> case atJoinCeiling $ floatExpr scrut of { (fse, fde, scrut') ->-           case                 floatExpr rhs   of { (fsb, fdb, rhs') ->+        -> 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]@@ -480,7 +428,7 @@         -> pprPanic "Floating multi-case" (ppr alts)        StayPut bind_lvl  -- Case expression stays put-        -> case atJoinCeiling $ floatExpr scrut of { (fse, fde, scrut') ->+        -> 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')            }}@@ -493,7 +441,7 @@          -> LevelledExpr          -> (FloatStats, FloatBinds, CoreExpr) floatRhs bndr rhs-  | Just join_arity <- isJoinId_maybe bndr+  | JoinPoint join_arity <- idJoinPointHood bndr   , Just (bndrs, body) <- try_collect join_arity rhs []   = case bndrs of       []                -> floatExpr rhs@@ -502,7 +450,7 @@         case floatBody lvl body of { (fs, floats, body') ->         (fs, floats, mkLams [b | TB b _ <- bndrs] body') }   | otherwise-  = atJoinCeiling $ floatExpr rhs+  = 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)@@ -577,9 +525,9 @@   = FlS (a1 + a2) (b1 + b2) (c1 + c2)  add_to_stats :: FloatStats -> FloatBinds -> FloatStats-add_to_stats (FlS a b c) (FB tops ceils others)+add_to_stats (FlS a b c) (FB tops others)   = FlS (a + lengthBag tops)-        (b + lengthBag ceils + lengthBag (flattenMajor others))+        (b + lengthBag (flattenMajor others))         (c + 1)  {-@@ -614,21 +562,18 @@ 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)+  ppr (FB fbs 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)+flattenTopFloats (FB tops defs)   = assertPpr (isEmptyBag (flattenMajor defs)) (ppr defs) $-    assertPpr (isEmptyBag ceils) (ppr ceils)     tops  addTopFloatPairs :: Bag CoreBind -> [(Id,CoreExpr)] -> [(Id,CoreExpr)]@@ -645,29 +590,24 @@ flattenMinor = M.foldr unionBags emptyBag  emptyFloats :: FloatBinds-emptyFloats = FB emptyBag emptyBag M.empty+emptyFloats = FB 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))+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 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))+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 c1 l1) (FB t2 c2 l2)-  = FB (t1 `unionBags` t2) (c1 `unionBags` c2) (l1 `plusMajor` l2)+plusFloats (FB t1 l1) (FB t2 l2)+  = FB (t1 `unionBags` t2) (l1 `plusMajor` l2)  plusMajor :: MajorEnv -> MajorEnv -> MajorEnv plusMajor = M.unionWith plusMinor@@ -707,10 +647,9 @@                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+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@@ -719,27 +658,10 @@                                             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 :: CoreTickish -> FloatBinds -> FloatBinds-wrapTick t (FB tops ceils defns)-  = FB (mapBag wrap_bind tops) (wrap_defns ceils)+wrapTick t (FB tops defns)+  = FB (mapBag wrap_bind tops)        (M.map (M.map wrap_defns) defns)   where     wrap_defns = mapBag wrap_one
GHC/Core/Opt/LiberateCase.hs view
@@ -5,13 +5,16 @@ -}  -module GHC.Core.Opt.LiberateCase ( liberateCase ) where+module GHC.Core.Opt.LiberateCase+  ( LibCaseOpts(..)+  , liberateCase+  ) where  import GHC.Prelude -import GHC.Driver.Session 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@@ -101,19 +104,17 @@ ************************************************************************ -} -liberateCase :: DynFlags -> CoreProgram -> CoreProgram-liberateCase dflags binds = do_prog (initLiberateCaseEnv dflags) binds+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 :: DynFlags -> LibCaseEnv-initLiberateCaseEnv dflags = LibCaseEnv-   { lc_threshold = liberateCaseThreshold dflags-   , lc_uf_opts   = unfoldingOpts dflags+initLiberateCaseEnv :: LibCaseOpts -> LibCaseEnv+initLiberateCaseEnv opts = LibCaseEnv+   { lc_opts      = opts    , lc_lvl       = 0    , lc_lvl_env   = emptyVarEnv    , lc_rec_env   = emptyVarEnv@@ -173,7 +174,7 @@ {- Note [Not bottoming Ids] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ Do not specialise error-functions (this is unusual, but I once saw it,-(actually in Data.Typable.Internal)+(actually in Data.Typeable.Internal)  Note [Only functions!] ~~~~~~~~~~~~~~~~~~~~~~@@ -388,6 +389,22 @@ {- ************************************************************************ *                                                                      *+         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 *                                                                      * ************************************************************************@@ -398,14 +415,16 @@ 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_threshold :: Maybe Int,-                -- ^ Bomb-out size for deciding if potential liberatees are too-                -- big.--        lc_uf_opts :: UnfoldingOpts,-                -- ^ Unfolding options+        lc_opts :: !LibCaseOpts,+                -- ^ liberate case options          lc_lvl :: LibCaseLevel, -- ^ Current level                 -- The level is incremented when (and only when) going
GHC/Core/Opt/Monad.hs view
@@ -6,31 +6,22 @@  {-# LANGUAGE DeriveFunctor #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}- module GHC.Core.Opt.Monad (-    -- * Configuration of the core-to-core passes-    CoreToDo(..), runWhen, runMaybe,-    SimplMode(..),+    -- * Types used in core-to-core passes     FloatOutSwitches(..),-    pprPassDetails, -    -- * Plugins-    CorePluginPass, bindsOnlyPass,--    -- * Counting-    SimplCount, doSimplTick, doFreeSimplTick, simplCountN,-    pprSimplCount, plusSimplCount, zeroSimplCount,-    isZeroSimplCount, hasDetailedCounts, Tick(..),-     -- * The monad     CoreM, runCoreM, +    mapDynFlagsCoreM, dropSimplCount,+     -- ** Reading from the monad-    getHscEnv, getRuleBase, getModule,+    getHscEnv, getModule,+    initRuleEnv, getExternalRuleBase,     getDynFlags, getPackageFamInstEnv,-    getVisibleOrphanMods, getUniqMask,-    getPrintUnqualified, getSrcSpanM,+    getInteractiveContext,+    getUniqTag,+    getNamePprCtx, getSrcSpanM,      -- ** Writing to the monad     addSimplCount,@@ -42,22 +33,20 @@     getAnnotations, getFirstAnnotations,      -- ** Screen output-    putMsg, putMsgS, errorMsg, errorMsgS, msg,+    putMsg, putMsgS, errorMsg, msg,     fatalErrorMsg, fatalErrorMsgS,     debugTraceMsg, debugTraceMsgS,   ) where  import GHC.Prelude hiding ( read ) -import GHC.Driver.Session+import GHC.Driver.DynFlags import GHC.Driver.Env -import GHC.Core-import GHC.Core.Unfold+import GHC.Core.Rules     ( RuleBase, RuleEnv, mkRuleEnv )+import GHC.Core.Opt.Stats ( SimplCount, zeroSimplCount, plusSimplCount ) -import GHC.Types.Basic  ( CompilerPhase(..) ) import GHC.Types.Annotations-import GHC.Types.Var import GHC.Types.Unique.Supply import GHC.Types.Name.Env import GHC.Types.SrcLoc@@ -68,158 +57,43 @@ import GHC.Utils.Logger import GHC.Utils.Monad -import GHC.Data.FastString 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.List (intersperse, groupBy, sortBy)-import Data.Ord import Data.Dynamic-import Data.Map (Map)-import qualified Data.Map as Map-import qualified Data.Map.Strict as MapStrict+import Data.Maybe (listToMaybe) import Data.Word import Control.Monad import Control.Applicative ( Alternative(..) )-import GHC.Utils.Panic (throwGhcException, GhcException(..), panic) -{--************************************************************************-*                                                                      *-              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-        SimplMode-  | CoreDoPluginPass String CorePluginPass-  | CoreDoFloatInwards-  | CoreDoFloatOutwards FloatOutSwitches-  | CoreLiberateCase-  | CoreDoPrintCore-  | CoreDoStaticArgs-  | CoreDoCallArity-  | CoreDoExitify-  | CoreDoDemand-  | 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-  | 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 CoreDoExitify            = text "Exitification transformation"-  ppr CoreDoDemand             = 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 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 SimplMode             -- See comments in GHC.Core.Opt.Simplify.Monad-  = SimplMode-        { sm_names        :: [String]       -- ^ Name(s) of the phase-        , sm_phase        :: CompilerPhase-        , sm_uf_opts      :: !UnfoldingOpts -- ^ Unfolding options-        , 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-        , sm_cast_swizzle :: !Bool          -- ^ Do we swizzle casts past lambdas?-        , sm_pre_inline   :: !Bool          -- ^ Whether pre-inlining is enabled-        , sm_logger       :: !Logger-        , sm_dflags       :: DynFlags-            -- Just for convenient non-monadic access; we don't override these.-            ---            -- Used for:-            --    - target platform (for `exprIsDupable` and `mkDupableAlt`)-            --    - Opt_DictsCheap and Opt_PedanticBottoms general flags-            --    - rules options (initRuleOpts)-            --    - inlineCheck-        }+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 -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+  , floatOutConstants :: Bool       -- ^ True <=> float constants to top level,+                                    --            even if they do not escape a lambda -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+  , 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. -  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@@ -230,343 +104,12 @@      sep $ punctuate comma $      [ text "Lam ="    <+> ppr (floatOutLambdas sw)      , text "Consts =" <+> ppr (floatOutConstants sw)+     , text "JoinsToTop =" <+> ppr (floatJoinsToTop 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 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' }) }--{--************************************************************************-*                                                                      *-             Counting and logging-*                                                                      *-************************************************************************--}--getVerboseSimplStats :: (Bool -> SDoc) -> SDoc-getVerboseSimplStats = getPprDebug          -- 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 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.--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 :: [[(Tick,Int)]]    -- Each group shares a common tag-                                -- toList returns common tags adjacent-    groups = groupBy 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  -- 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 = 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 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 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 `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--{--************************************************************************-*                                                                      *              Monad and carried data structure definitions *                                                                      * ************************************************************************@@ -574,13 +117,12 @@  data CoreReader = CoreReader {         cr_hsc_env             :: HscEnv,-        cr_rule_base           :: RuleBase,+        cr_rule_base           :: RuleBase,  -- Home package table rules         cr_module              :: Module,-        cr_print_unqual        :: PrintUnqualified,+        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_visible_orphan_mods :: !ModuleSet,-        cr_uniq_mask           :: !Char      -- Mask for creating unique values+        cr_uniq_tag            :: !Char      -- Tag for creating unique values }  -- Note: CoreWriter used to be defined with data, rather than newtype.  If it@@ -590,9 +132,10 @@         cw_simpl_count :: SimplCount } -emptyWriter :: DynFlags -> CoreWriter-emptyWriter dflags = CoreWriter {-        cw_simpl_count = zeroSimplCount dflags+emptyWriter :: Bool -- ^ -ddump-simpl-stats+            -> CoreWriter+emptyWriter dump_simpl_stats = CoreWriter {+        cw_simpl_count = zeroSimplCount dump_simpl_stats     }  plusWriter :: CoreWriter -> CoreWriter -> CoreWriter@@ -629,33 +172,31 @@  instance MonadUnique CoreM where     getUniqueSupplyM = do-        mask <- read cr_uniq_mask-        liftIO $! mkSplitUniqSupply mask+        tag <- read cr_uniq_tag+        liftIO $! mkSplitUniqSupply tag      getUniqueM = do-        mask <- read cr_uniq_mask-        liftIO $! uniqFromMask mask+        tag <- read cr_uniq_tag+        liftIO $! uniqFromTag tag  runCoreM :: HscEnv          -> RuleBase          -> Char -- ^ Mask          -> Module-         -> ModuleSet-         -> PrintUnqualified+         -> NamePprCtx          -> SrcSpan          -> CoreM a          -> IO (a, SimplCount)-runCoreM hsc_env rule_base mask mod orph_imps print_unqual loc m+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_visible_orphan_mods = orph_imps,-            cr_print_unqual = print_unqual,+            cr_name_ppr_ctx = name_ppr_ctx,             cr_loc = loc,-            cr_uniq_mask = mask+            cr_uniq_tag = tag         }      extract :: (a, CoreWriter) -> (a, SimplCount)@@ -671,8 +212,8 @@  nop :: a -> CoreIOEnv (a, CoreWriter) nop x = do-    r <- getEnv-    return (x, emptyWriter $ (hsc_dflags . cr_hsc_env) r)+    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))@@ -704,26 +245,46 @@ getHscEnv :: CoreM HscEnv getHscEnv = read cr_hsc_env -getRuleBase :: CoreM RuleBase-getRuleBase = read cr_rule_base+getHomeRuleBase :: CoreM RuleBase+getHomeRuleBase = read cr_rule_base -getVisibleOrphanMods :: CoreM ModuleSet-getVisibleOrphanMods = read cr_visible_orphan_mods+initRuleEnv :: ModGuts -> CoreM RuleEnv+initRuleEnv guts+  = do { hpt_rules <- getHomeRuleBase+       ; eps_rules <- getExternalRuleBase+       ; return (mkRuleEnv guts eps_rules hpt_rules) } -getPrintUnqualified :: CoreM PrintUnqualified-getPrintUnqualified = read cr_print_unqual+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 }) -getUniqMask :: CoreM Char-getUniqMask = read cr_uniq_mask+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 @@ -733,11 +294,16 @@ instance HasModule CoreM where     getModule = read cr_module +getInteractiveContext :: CoreM InteractiveContext+getInteractiveContext = hsc_IC <$> getHscEnv+ getPackageFamInstEnv :: CoreM PackageFamInstEnv-getPackageFamInstEnv = do+getPackageFamInstEnv = eps_fam_inst_env <$> get_eps++get_eps :: CoreM ExternalPackageState+get_eps = do     hsc_env <- getHscEnv-    eps <- liftIO $ hscEPS hsc_env-    return $ eps_fam_inst_env eps+    liftIO $ hscEPS hsc_env  {- ************************************************************************@@ -766,8 +332,8 @@ getFirstAnnotations deserialize guts   = bimap mod name <$> getAnnotations deserialize guts   where-    mod = mapModuleEnv head . filterModuleEnv (const $ not . null)-    name = mapNameEnv head . filterNameEnv (not . null)+    mod = mapMaybeModuleEnv (const listToMaybe)+    name = mapMaybeNameEnv listToMaybe  {- Note [Annotations]@@ -799,14 +365,14 @@ msg msg_class doc = do     logger <- getLogger     loc    <- getSrcSpanM-    unqual <- getPrintUnqualified+    name_ppr_ctx <- getNamePprCtx     let sty = case msg_class of-                MCDiagnostic _ _ -> err_sty-                MCDump           -> dump_sty-                _                -> user_sty-        err_sty  = mkErrStyle unqual-        user_sty = mkUserStyle unqual AllTheWay-        dump_sty = mkDumpStyle unqual+                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@@ -816,10 +382,6 @@ -- | 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.-errorMsgS :: String -> CoreM ()-errorMsgS = errorMsg . text  -- | Output an error to the screen. Does not cause the compiler to die. errorMsg :: SDoc -> CoreM ()
− GHC/Core/Opt/Monad.hs-boot 
@@ -1,30 +0,0 @@--- Created this hs-boot file to remove circular dependencies from the use of--- Plugins. Plugins needs CoreToDo and CoreM types to define core-to-core--- transformations.--- However GHC.Core.Opt.Monad does much more than defining these, and because Plugins are--- activated in various modules, the imports become circular. To solve this I--- extracted CoreToDo and CoreM into this file.--- I needed to write the whole definition of these types, otherwise it created--- a data-newtype conflict.--module GHC.Core.Opt.Monad ( CoreToDo, CoreM ) where--import GHC.Prelude--import GHC.Data.IOEnv ( IOEnv )--type CoreIOEnv = IOEnv CoreReader--data CoreReader--newtype CoreWriter = CoreWriter {-        cw_simpl_count :: SimplCount-}--data SimplCount--newtype CoreM a = CoreM { unCoreM :: CoreIOEnv (a, CoreWriter) }--instance Monad CoreM--data CoreToDo
GHC/Core/Opt/OccurAnal.hs view
@@ -1,3341 +1,4073 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE ViewPatterns #-}--{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}--{--(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-  ) where--import GHC.Prelude--import GHC.Core-import GHC.Core.FVs-import GHC.Core.Utils   ( exprIsTrivial, isDefaultAlt, isExpandableApp,-                          stripTicksTopE, mkTicks )-import GHC.Core.Opt.Arity   ( joinRhsArity )-import GHC.Core.Coercion-import GHC.Core.Type-import GHC.Core.TyCo.FVs( tyCoVarsOfMCo )--import GHC.Data.Maybe( isJust, 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 )--import GHC.Utils.Outputable-import GHC.Utils.Panic-import GHC.Utils.Panic.Plain-import GHC.Utils.Misc-import GHC.Utils.Trace--import GHC.Builtin.Names( runRWKey )-import GHC.Unit.Module( Module )--import Data.List (mapAccumL, mapAccumR)--{--************************************************************************-*                                                                      *-    occurAnalysePgm, occurAnalyseExpr-*                                                                      *-************************************************************************--Here's the externally-callable interface:--}---- | Do occurrence analysis, and discard occurrence info returned-occurAnalyseExpr :: CoreExpr -> CoreExpr-occurAnalyseExpr expr = expr'-  where-    (WithUsageDetails _ 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 }--    (WithUsageDetails final_usage occ_anald_binds) = go init_env binds-    (WithUsageDetails _ occ_anald_glommed_binds) = occAnalRecBind init_env TopLevel-                                                    imp_rule_edges-                                                    (flattenBinds binds)-                                                    initial_uds-          -- 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 :: OccEnv -> [CoreBind] -> WithUsageDetails [CoreBind]-    go !_ []-        = WithUsageDetails initial_uds []-    go env (bind:binds)-        = WithUsageDetails final_usage (bind' ++ binds')-        where-           (WithUsageDetails bs_usage binds')   = go env binds-           (WithUsageDetails final_usage bind') = occAnalBind env TopLevel imp_rule_edges bind bs_usage--{- *********************************************************************-*                                                                      *-                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.--}--{--************************************************************************-*                                                                      *-                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 [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 [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 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 we must do the adjustRhsUsage thing-on j's RHS.  That's why we pass mb_join_arity to calcUnfolding.--Aame 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-cal info from the RHS of the rule to-propagate.--* Wrinkle for Rec case. In the recursive case we don't know the-  join-point arity in advance, when calling occAnalUnfolding and-  occAnalRules.  (See makeNode.)  We don't want to pass Nothing,-  because then a recursive joinrec might lose its join-poin-hood-  when SpecConstr adds a RULE.  So we just make do with the-  *current* join-poin-hood, stored in the Id.--  In the non-recursive case things are simple: see occAnalNonRecBind--* 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 [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.----------------------------------------------------------------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 'markAllInsideLam' *unless* the binding is for a thunk, a one-shot-     lambda, or a non-recursive join point; and-  b) call 'markAllNonTail' *unless* the binding is for a join point, and-     the RHS has the right arity; e.g.-        join j x y = case ... of-                       A -> j2 p-                       B -> j2 q-        in j a b-     Here we want the tail calls to j2 to be tail calls of the whole expression--Some examples, with how the free occurrences in e (assumed not to be a value-lambda) get marked:--                             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'.)--}---data WithUsageDetails a = WithUsageDetails !UsageDetails !a-----------------------------------------------------------------------                 occAnalBind---------------------------------------------------------------------occAnalBind :: OccEnv           -- The incoming OccEnv-            -> TopLevelFlag-            -> ImpRuleEdges-            -> CoreBind-            -> UsageDetails             -- Usage details of scope-            -> WithUsageDetails [CoreBind] -- Of the whole let(rec)--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 -> WithUsageDetails [CoreBind]-occAnalNonRecBind !env lvl imp_rule_edges bndr rhs body_usage-  | isTyVar bndr      -- A type let; we don't gather usage info-  = WithUsageDetails body_usage [NonRec bndr rhs]--  | not (bndr `usedIn` body_usage)    -- It's not mentioned-  = WithUsageDetails body_usage []--  | otherwise                   -- It's mentioned in the body-  = WithUsageDetails (body_usage' `andUDs` rhs_usage) [NonRec final_bndr rhs']-  where-    (body_usage', tagged_bndr) = tagNonRecBinder lvl body_usage bndr-    final_bndr = tagged_bndr `setIdUnfolding` unf'-                             `setIdSpecialisation` mkRuleInfo rules'-    rhs_usage = rhs_uds `andUDs` unf_uds `andUDs` rule_uds--    -- Get the join info from the *new* decision-    -- See Note [Join points and unfoldings/rules]-    mb_join_arity = willBeJoinId_maybe tagged_bndr-    is_join_point = isJust mb_join_arity--    --------- Right hand side ----------    env1 | is_join_point    = env  -- See Note [Join point RHSs]-         | certainly_inline = env  -- See Note [Cascading inlines]-         | otherwise        = rhsCtxt env--    -- See Note [Sources of one-shot information]-    rhs_env = env1 { occ_one_shots = argOneShots dmd }-    (WithUsageDetails rhs_uds rhs') = occAnalRhs rhs_env NonRecursive mb_join_arity rhs--    --------- Unfolding ----------    -- See Note [Unfoldings and join points]-    unf | isId bndr = idUnfolding bndr-        | otherwise = NoUnfolding-    (WithUsageDetails unf_uds unf') = occAnalUnfolding rhs_env NonRecursive mb_join_arity unf--    --------- Rules ----------    -- See Note [Rules are extra RHSs] and Note [Rule dependency info]-    rules_w_uds  = occAnalRules rhs_env mb_join_arity bndr-    rules'       = map fstOf3 rules_w_uds-    imp_rule_uds = impRulesScopeUsage (lookupImpRules imp_rule_edges bndr)-         -- imp_rule_uds: consider-         --     h = ...-         --     g = ...-         --     RULE map g = h-         -- Then we want to ensure that h is in scope everwhere-         -- that g is (since the RULE might turn g into h), so-         -- we make g mention h.--    rule_uds = foldr add_rule_uds imp_rule_uds rules_w_uds-    add_rule_uds (_, l, r) uds = l `andUDs` r `andUDs` uds--    -----------    occ = idOccInfo tagged_bndr-    certainly_inline -- See Note [Cascading inlines]-      = case occ of-          OneOcc { occ_in_lam = NotInsideLam, occ_n_br = 1 }-            -> active && not_stable-          _ -> False--    dmd        = idDemandInfo bndr-    active     = isAlwaysActive (idInlineActivation bndr)-    not_stable = not (isStableUnfolding (idUnfolding 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 !env lvl imp_rule_edges pairs body_usage-  = foldr (occAnalRec rhs_env lvl) (WithUsageDetails body_usage []) sccs-  where-    sccs :: [SCC Details]-    sccs = {-# SCC "occAnalBind.scc" #-}-           stronglyConnCompFromEdgedVerticesUniq nodes--    nodes :: [LetrecNode]-    nodes = {-# SCC "occAnalBind.assoc" #-}-            map (makeNode rhs_env imp_rule_edges bndr_set) pairs--    bndrs    = map fst pairs-    bndr_set = mkVarSet bndrs-    rhs_env  = env `addInScope` bndrs---------------------------------occAnalRec :: OccEnv -> TopLevelFlag-           -> SCC Details-           -> WithUsageDetails [CoreBind]-           -> WithUsageDetails [CoreBind]--        -- The NonRec case is just like a Let (NonRec ...) above-occAnalRec !_ lvl (AcyclicSCC (ND { nd_bndr = bndr, nd_rhs = rhs-                                  , nd_uds = rhs_uds }))-           (WithUsageDetails body_uds binds)-  | not (bndr `usedIn` body_uds)-  = WithUsageDetails body_uds binds -- See Note [Dead code]--  | otherwise                   -- It's mentioned in the body-  = WithUsageDetails (body_uds' `andUDs` rhs_uds')-                     (NonRec tagged_bndr rhs : binds)-  where-    (body_uds', tagged_bndr) = tagNonRecBinder lvl body_uds bndr-    rhs_uds'      = adjustRhsUsage mb_join_arity rhs rhs_uds-    mb_join_arity = willBeJoinId_maybe tagged_bndr--        -- The Rec case is the interesting one-        -- See Note [Recursive bindings: the grand plan]-        -- See Note [Loop breaking]-occAnalRec env lvl (CyclicSCC details_s) (WithUsageDetails body_uds binds)-  | not (any (`usedIn` body_uds) bndrs) -- NB: look at body_uds, not total_uds-  = WithUsageDetails body_uds binds     -- See Note [Dead code]--  | otherwise   -- At this point we always build a single Rec-  = -- pprTrace "occAnalRec" (ppr loop_breaker_nodes)-    WithUsageDetails final_uds (Rec pairs : binds)--  where-    bndrs      = map nd_bndr details_s-    all_simple = all nd_simple details_s--    -------------------------------    -- Make the nodes for the loop-breaker analysis-    -- See Note [Choosing loop breakers] for loop_breaker_nodes-    final_uds :: UsageDetails-    loop_breaker_nodes :: [LetrecNode]-    (WithUsageDetails 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 possiblity, we include edges from lvl2 to /both/ its-stable unfolding /and/ its RHS.  Hence the defn of inl_fvs in-makeNode.  Maybe we could be more clever, but it's very much a corner-case.--Note [Weak loop breakers]-~~~~~~~~~~~~~~~~~~~~~~~~~-There is a last nasty wrinkle.  Suppose we have--    Rec { f = f_rhs-          RULE f [] = g--          h = h_rhs-          g = h-          ...more... }--Remember that we simplify the RULES before any RHS (see Note-[Rules are visible in their own rec group] above).--So we must *not* postInlineUnconditionally 'g', even though-its RHS turns out to be trivial.  (I'm assuming that 'g' is-not chosen as a loop breaker.)  Why not?  Because then we-drop the binding for 'g', which leaves it out of scope in the-RULE!--Here's a somewhat different example of the same thing-    Rec { q = r-        ; r = ...p...-        ; p = p_rhs-          RULE p [] = q }-Here the RULE is "below" q, but we *still* can't postInlineUnconditionally-q, because the RULE for p is active throughout.  So the RHS of r-might rewrite to     r = ...q...-So q must remain in scope in the output program!--We "solve" this by:--    Make q a "weak" loop breaker (OccInfo = IAmLoopBreaker True)-    iff q is a mentioned in the RHS of any RULE (active on not)-    in the Rec group--Note the "active or not" comment; even if a RULE is inactive, we-want its RHS free vars to stay alive (#20820)!--A normal "strong" loop breaker has IAmLoopBreaker False.  So:--                                Inline  postInlineUnconditionally-strong   IAmLoopBreaker False    no      no-weak     IAmLoopBreaker True     yes     no-         other                   yes     yes--The **sole** reason for this kind of loop breaker is so that-postInlineUnconditionally does not fire.  Ugh.--Annoyingly, since we simplify the rules *first* we'll never inline-q into p's RULE.  That trivial binding for q will hang around until-we discard the rule.  Yuk.  But it's rare.--Note [Rules and loop breakers]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When we form the loop-breaker graph (Step 4 in Note [Recursive-bindings: the grand plan]), we must be careful about RULEs.--For a start, we want a loop breaker to cut every cycle, so inactive-rules play no part; we need only consider /active/ rules.-See Note [Finding rule RHS free vars]--The second point is more subtle.  A RULE is like an equation for-'f' that is *always* inlined if it is applicable.  We do *not* disable-rules for loop-breakers.  It's up to whoever makes the rules to make-sure that the rules themselves always terminate.  See Note [Rules for-recursive functions] in GHC.Core.Opt.Simplify--Hence, if-    f's RHS (or its stable unfolding if it has one) mentions g, and-    g has a RULE that mentions h, and-    h has a RULE that mentions f--then we *must* choose f to be a loop breaker.  Example: see Note-[Specialisation rules]. So our plan is this:--   Take the free variables of f's RHS, and augment it with all the-   variables reachable by a transitive sequence RULES from those-   starting points.--That is the whole reason for computing rule_fv_env in mkLoopBreakerNodes.-Wrinkles:--* We only consider /active/ rules. See Note [Finding rule RHS free vars]--* We need only consider free vars that are also binders in this Rec-  group.  See also Note [Finding rule RHS free vars]--* We only consider variables free in the *RHS* of the rule, in-  contrast to the way we build the Rec group in the first place (Note-  [Rule dependency info])--* Why "transitive sequence of rules"?  Because active rules apply-  unconditionally, without checking loop-breaker-ness.- See Note [Loop breaker dependencies].--Note [Finding rule RHS free vars]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider this real example from Data Parallel Haskell-     tagZero :: Array Int -> Array Tag-     {-# INLINE [1] tagZeroes #-}-     tagZero xs = pmap (\x -> fromBool (x==0)) xs--     {-# RULES "tagZero" [~1] forall xs n.-         pmap fromBool <blah blah> = tagZero xs #-}-So tagZero's RHS mentions pmap, and pmap's RULE mentions tagZero.-However, tagZero can only be inlined in phase 1 and later, while-the RULE is only active *before* phase 1.  So there's no problem.--To make this work, we look for the RHS free vars only for-*active* rules. That's the reason for the occ_rule_act field-of the OccEnv.--Note [loopBreakNodes]-~~~~~~~~~~~~~~~~~~~~~-loopBreakNodes is applied to the list of nodes for a cyclic strongly-connected component (there's guaranteed to be a cycle).  It returns-the same nodes, but-        a) in a better order,-        b) with some of the Ids having a IAmALoopBreaker pragma--The "loop-breaker" Ids are sufficient to break all cycles in the SCC.  This means-that the simplifier can guarantee not to loop provided it never records an inlining-for these no-inline guys.--Furthermore, the order of the binds is such that if we neglect dependencies-on the no-inline Ids then the binds are topologically sorted.  This means-that the simplifier will generally do a good job if it works from top bottom,-recording inlinings for any Ids which aren't marked as "no-inline" as it goes.--}--type Binding = (Id,CoreExpr)---- See Note [loopBreakNodes]-loopBreakNodes :: Int-               -> VarSet        -- Binders whose dependencies may be "missing"-                                -- See Note [Weak loop breakers]-               -> [LetrecNode]-               -> [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 -> [LetrecNode] -> [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-                                                 (nd_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) -> LetrecNode -> Binding-nodeBinding set_id_occ (node_payload -> ND { nd_bndr = bndr, nd_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-                  -> [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 (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 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 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-*                                                                      *-************************************************************************--}--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_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 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]--       , 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 "simple =" <+> ppr (nd_simple nd)-                  , text "active_rule_fvs =" <+> ppr (nd_active_rule_fvs nd)-                  , text "score =" <+> ppr (nd_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)-  = 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             = rhs'-                 , nd_uds             = scope_uds-                 , 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-                 , nd_score           = pprPanic "makeNodeDetails" (ppr bndr) }--    bndr' = bndr `setIdUnfolding`      unf'-                 `setIdSpecialisation` mkRuleInfo rules'--    inl_uds = rhs_uds `andUDs` unf_uds-    scope_uds = inl_uds `andUDs` rule_uds-                   -- Note [Rules are extra RHSs]-                   -- Note [Rule dependency info]-    scope_fvs = udFreeVars bndr_set 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 inl_uds-    -- inl_fvs: vars that would become free if the function was inlined.-    -- We conservatively approximate that by thefree vars from the RHS-    -- and the unfolding together.-    -- See Note [inl_fvs]--    mb_join_arity = isJoinId_maybe bndr-    -- Get join point info from the *current* decision-    -- We don't know what the new decision will be!-    -- Using the old decision at least allows us to-    -- preserve existing join point, even RULEs are added-    -- See Note [Join points and unfoldings/rules]--    --------- Right hand side ----------    -- Constructing the edges for the main Rec computation-    -- See Note [Forming Rec groups]-    -- Do not use occAnalRhs because we don't yet know the final-    -- answer for mb_join_arity; instead, do the occAnalLam call from-    -- occAnalRhs, and postpone adjustRhsUsage until occAnalRec-    rhs_env                         = rhsCtxt env-    (WithUsageDetails rhs_uds rhs') = occAnalLam rhs_env rhs--    --------- Unfolding ----------    -- See Note [Unfoldings and join points]-    unf = realIdUnfolding bndr -- realIdUnfolding: Ignore loop-breaker-ness-                               -- here because that is what we are setting!-    (WithUsageDetails unf_uds unf') = occAnalUnfolding rhs_env Recursive mb_join_arity unf--    --------- 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 ---------    rules_w_uds :: [(CoreRule, UsageDetails, UsageDetails)]-    rules_w_uds = occAnalRules rhs_env mb_join_arity bndr-    rules'      = map fstOf3 rules_w_uds--    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-                   -> [Details]-                   -> WithUsageDetails [LetrecNode] -- adjusted--- 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-  = WithUsageDetails final_uds (zipWithEqual "mkLoopBreakerNodes" mk_lb_node details_s bndrs')-  where-    (final_uds, bndrs') = tagRecBinders lvl body_uds details_s--    mk_lb_node nd@(ND { nd_bndr = old_bndr, nd_inl = inl_fvs }) new_bndr-      = DigraphNode { node_payload      = new_nd-                    , 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-        new_nd = nd { nd_bndr = new_bndr, nd_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-          -> Details-          -> NodeScore-nodeScore !env new_bndr lb_deps-          (ND { nd_bndr = old_bndr, nd_rhs = bind_rhs })--  | not (isId old_bndr)     -- A type or coercion variable is never a loop breaker-  = (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 occAnalLam.--* Simplifier.  The simplifier is careful when partially applying-  lambda-groups. See the call to zapLambdaBndrs in-     GHC.Core.Opt.Simplify.simplExprF1-     GHC.Core.SimpleOpt.simple_app--* Why do we take care to account for intervening casts? Answer:-  currently we don't do eta-expansion and cast-swizzling in a stable-  unfolding (see Note [Eta-expansion in stable unfoldings]).-  So we can get-    f = \x. ((\y. ...x...y...) |> co)-  Now, since the lambdas aren't together, the occurrence analyser will-  say that x is OnceInLam.  Now if we have a call-    (f e1 |> co) e2-  we'll end up with-    let x = e1 in ...x..e2...-  and it'll take an extra iteration of the Simplifier to substitute for x.--A thought: a lambda-group is pretty much what GHC.Core.Opt.Arity.manifestArity-recognises except that the latter looks through (some) ticks.  Maybe a lambda-group should also look through (some) ticks?--}--isOneShotFun :: CoreExpr -> Bool--- The top level lambdas, ignoring casts, of the expression--- are all one-shot.  If there aren't any lambdas at all, this is True-isOneShotFun (Lam b e)  = isOneShotBndr b && isOneShotFun e-isOneShotFun (Cast e _) = isOneShotFun e-isOneShotFun _          = True--zapLambdaBndrs :: CoreExpr -> FullArgCount -> CoreExpr--- If (\xyz. t) appears under-applied to only two arguments,--- we must zap the occ-info on x,y, because they appear under the \z--- See Note [Occurrence analysis for lambda binders] in GHc.Core.Opt.OccurAnal------ NB: `arg_count` includes both type and value args-zapLambdaBndrs fun arg_count-  = -- If the lambda is fully applied, leave it alone; if not-    -- zap the OccInfo on the lambdas that do have arguments,-    -- so they beta-reduce to use-many Lets rather than used-once ones.-    zap arg_count fun `orElse` fun-  where-    zap :: FullArgCount -> CoreExpr -> Maybe CoreExpr-    -- Nothing => No need to change the occ-info-    -- Just e  => Had to change-    zap 0 e | isOneShotFun e = Nothing  -- All remaining lambdas are one-shot-            | otherwise      = Just e   -- in which case no need to zap-    zap n (Cast e co) = do { e' <- zap n e; return (Cast e' co) }-    zap n (Lam b e)   = do { e' <- zap (n-1) e-                           ; return (Lam (zap_bndr b) e') }-    zap _ _           = Nothing  -- More arguments than lambdas--    zap_bndr b | isTyVar b = b-               | otherwise = zapLamIdInfo b--occAnalLam :: OccEnv -> CoreExpr -> (WithUsageDetails CoreExpr)--- See Note [Occurrence analysis for lambda binders]--- It does the following:---   * Sets one-shot info on the lambda binder from the OccEnv, and---     removes that one-shot info from the OccEnv---   * Sets the OccEnv to OccVanilla when going under a value lambda---   * Tags each lambda with its occurrence information---   * Walks through casts--- This function does /not/ do---   markAllInsideLam or---   markAllNonTail--- The caller does that, either in occAnal (Lam {}), or in adjustRhsUsage--- See Note [Adjusting right-hand sides]--occAnalLam env (Lam bndr expr)-  | isTyVar bndr-  = let (WithUsageDetails usage expr') = occAnalLam env expr-    in WithUsageDetails usage (Lam bndr expr')-       -- Important: Keep the 'env' unchanged so that with a RHS like-       --   \(@ x) -> K @x (f @x)-       -- we'll see that (K @x (f @x)) is in a OccRhs, and hence refrain-       -- from inlining f. See the beginning of Note [Cascading inlines].--  | otherwise  -- So 'bndr' is an Id-  = let (env_one_shots', bndr1)-           = case occ_one_shots env of-               []         -> ([],  bndr)-               (os : oss) -> (oss, updOneShotInfo bndr os)-               -- Use updOneShotInfo, not setOneShotInfo, as pre-existing-               -- one-shot info might be better than what we can infer, e.g.-               -- due to explicit use of the magic 'oneShot' function.-               -- See Note [The oneShot function]--        env1 = env { occ_encl = OccVanilla, occ_one_shots = env_one_shots' }-        env2 = addOneInScope env1 bndr-        (WithUsageDetails usage expr') = occAnalLam env2 expr-        (usage', bndr2) = tagLamBinder usage bndr1-    in WithUsageDetails usage' (Lam bndr2 expr')---- For casts, keep going in the same lambda-group--- See Note [Occurrence analysis for lambda binders]-occAnalLam env (Cast expr co)-  = let  (WithUsageDetails usage expr') = occAnalLam env expr-         -- usage1: see Note [Gather occurrences of coercion variables]-         usage1 = addManyOccs usage (coVarsOfCo co)--         -- usage2: see Note [Occ-anal and cast worker/wrapper]-         usage2 = case expr of-                    Var {} | isRhsEnv env -> markAllMany usage1-                    _ -> usage1--         -- usage3: you might think this was not necessary, because of-         -- the markAllNonTail in adjustRhsUsage; but not so!  For a-         -- join point, adjustRhsUsage doesn't do this; yet if there is-         -- a cast, we must!-         usage3 = markAllNonTail usage2--    in WithUsageDetails usage3 (Cast expr' co)--occAnalLam env expr = occAnal env expr--{- Note [Occ-anal and cast worker/wrapper]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider   y = e; x = y |> co-If we mark y as used-once, we'll inline y into x, and the the Cast-worker/wrapper transform will float it straight back out again.  See-Note [Cast worker/wrapper] in GHC.Core.Opt.Simplify.--So in this particular case we want to mark 'y' as Many.  It's very-ad-hoc, but it's also simple.  It's also what would happen if we gave-the binding for x a stable unfolding (as we usually do for wrappers, thus-      y = e-      {-# INLINE x #-}-      x = y |> co-Now y appears twice -- once in x's stable unfolding, and once in x's-RHS. So it'll get a Many occ-info.  (Maybe Cast w/w should create a stable-unfolding, which would obviate this Note; but that seems a bit of a-heavyweight solution.)--We only need to this in occAnalLam, not occAnal, because the top leve-of a right hand side is handled by occAnalLam.--}---{- *********************************************************************-*                                                                      *-                   Right hand sides-*                                                                      *-********************************************************************* -}--occAnalRhs :: OccEnv -> RecFlag -> Maybe JoinArity-           -> CoreExpr   -- RHS-           -> WithUsageDetails CoreExpr-occAnalRhs !env is_rec mb_join_arity rhs-  = let (WithUsageDetails usage rhs1) = occAnalLam env rhs-           -- We call occAnalLam here, not occAnalExpr, so that it doesn't-           -- do the markAllInsideLam and markNonTailCall stuff before-           -- we've had a chance to help with join points; that comes next-        rhs2      = markJoinOneShots is_rec mb_join_arity rhs1-        rhs_usage = adjustRhsUsage mb_join_arity rhs2 usage-    in WithUsageDetails rhs_usage rhs2----markJoinOneShots :: RecFlag -> Maybe JoinArity -> CoreExpr -> CoreExpr--- For a /non-recursive/ join point we can mark all--- its join-lambda as one-shot; and it's a good idea to do so-markJoinOneShots NonRecursive (Just join_arity) rhs-  = go join_arity rhs-  where-    go 0 rhs         = rhs-    go n (Lam b rhs) = Lam (if isId b then setOneShotLambda b else b)-                           (go (n-1) rhs)-    go _ rhs         = rhs  -- Not enough lambdas.  This can legitimately happen.-                            -- e.g.    let j = case ... in j True-                            -- This will become an arity-1 join point after the-                            -- simplifier has eta-expanded it; but it may not have-                            -- enough lambdas /yet/. (Lint checks that JoinIds do-                            -- have enough lambdas.)-markJoinOneShots _ _ rhs-  = rhs--occAnalUnfolding :: OccEnv-                 -> RecFlag-                 -> Maybe JoinArity   -- See Note [Join points and unfoldings/rules]-                 -> Unfolding-                 -> WithUsageDetails Unfolding--- Occurrence-analyse a stable unfolding;--- discard a non-stable one altogether.-occAnalUnfolding !env is_rec mb_join_arity unf-  = case unf of-      unf@(CoreUnfolding { uf_tmpl = rhs, uf_src = src })-        | isStableSource src ->-            let-              (WithUsageDetails usage rhs') = occAnalRhs env is_rec mb_join_arity rhs--              unf' | noBinderSwaps env = unf -- Note [Unfoldings and rules]-                   | otherwise         = unf { uf_tmpl = rhs' }-            in WithUsageDetails (markAllMany usage) unf'-              -- markAllMany: see Note [Occurrences in stable unfoldings]-        | otherwise          -> WithUsageDetails emptyDetails unf-              -- For non-Stable unfoldings we leave them undisturbed, but-              -- don't count their usage because the simplifier will discard them.-              -- We leave them undisturbed because nodeScore uses their size info-              -- to guide its decisions.  It's ok to leave un-substituted-              -- expressions in the tree because all the variables that were in-              -- scope remain in scope; there is no cloning etc.--      unf@(DFunUnfolding { df_bndrs = bndrs, df_args = args })-        -> WithUsageDetails final_usage (unf { df_args = args' })-        where-          env'            = env `addInScope` bndrs-          (WithUsageDetails usage args') = occAnalList env' args-          final_usage     = markAllManyNonTail (delDetailsList usage bndrs)-                            `addLamCoVarOccs` bndrs-                            `delDetailsList` bndrs-              -- delDetailsList; no need to use tagLamBinders because we-              -- never inline DFuns so the occ-info on binders doesn't matter--      unf -> WithUsageDetails emptyDetails unf--occAnalRules :: OccEnv-             -> Maybe JoinArity  -- See Note [Join points and unfoldings/rules]-             -> Id               -- Get rules from here-             -> [(CoreRule,      -- Each (non-built-in) rule-                  UsageDetails,  -- Usage details for LHS-                  UsageDetails)] -- Usage details for RHS-occAnalRules !env mb_join_arity bndr-  = map occ_anal_rule (idCoreRules bndr)-  where-    occ_anal_rule rule@(Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs })-      = (rule', lhs_uds', rhs_uds')-      where-        env' = env `addInScope` bndrs-        rule' | noBinderSwaps env = rule  -- Note [Unfoldings and rules]-              | otherwise         = rule { ru_args = args', ru_rhs = rhs' }--        (WithUsageDetails lhs_uds args') = occAnalList env' args-        lhs_uds'         = markAllManyNonTail (lhs_uds `delDetailsList` bndrs)-                           `addLamCoVarOccs` bndrs--        (WithUsageDetails rhs_uds rhs') = occAnal env' rhs-                            -- Note [Rules are extra RHSs]-                            -- Note [Rule dependency info]-        rhs_uds' = markAllNonTailIf (not exact_join) $-                   markAllMany                             $-                   rhs_uds `delDetailsList` bndrs--        exact_join = exactJoin mb_join_arity args-                     -- See Note [Join points and unfoldings/rules]--    occ_anal_rule other_rule = (other_rule, emptyDetails, emptyDetails)--{- Note [Join point RHSs]-~~~~~~~~~~~~~~~~~~~~~~~~~-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 RhsCtxt (#14137).  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.  See #14137.--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".--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.--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 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.---************************************************************************-*                                                                      *-                Expressions-*                                                                      *-************************************************************************--}--occAnalList :: OccEnv -> [CoreExpr] -> WithUsageDetails [CoreExpr]-occAnalList !_   []    = WithUsageDetails emptyDetails []-occAnalList env (e:es) = let-                          (WithUsageDetails uds1 e') = occAnal env e-                          (WithUsageDetails uds2 es') = occAnalList env es-                         in WithUsageDetails (uds1 `andUDs` uds2) (e' : es')--occAnal :: OccEnv-        -> CoreExpr-        -> WithUsageDetails CoreExpr       -- Gives info only about the "interesting" Ids--occAnal !_   expr@(Lit _)  = WithUsageDetails emptyDetails expr--occAnal env expr@(Var _) = occAnalApp env (expr, [], [])-    -- At one stage, I gathered the idRuleVars for the variable here too,-    -- which in a way is the right thing to do.-    -- But that went wrong right after specialisation, when-    -- 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)-  = WithUsageDetails (addManyOccs emptyDetails (coVarsOfType ty)) expr-occAnal _ expr@(Coercion co)-  = WithUsageDetails (addManyOccs emptyDetails (coVarsOfCo co)) expr-        -- See Note [Gather occurrences of coercion variables]--{- Note [Gather occurrences of coercion variables]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We need to gather info about what coercion variables appear, for two reasons:--1. So that we can sort them into the right place when doing dependency analysis.--2. So that we know when they are surely dead.--It is useful to know when they a coercion variable is surely dead,-when we want to discard a case-expression, in GHC.Core.Opt.Simplify.rebuildCase.-For example (#20143):--  case unsafeEqualityProof @blah of-     UnsafeRefl cv -> ...no use of cv...--Here we can discard the case, since unsafeEqualityProof always terminates.-But only if the coercion variable 'cv' is unused.--Another example from #15696: we had something like-  case eq_sel d of co -> ...(typeError @(...co...) "urk")...-Then 'd' was substituted by a dictionary, so the expression-simpified to-  case (Coercion <blah>) of cv -> ...(typeError @(...cv...) "urk")...--We can only  drop the case altogether if 'cv' is unused, which is not-the case here.--Conclusion: we need accurate dead-ness info for CoVars.-We gather CoVar occurrences from:--  * The (Type ty) and (Coercion co) cases of occAnal--  * The type 'ty' of a lambda-binder (\(x:ty). blah)-    See addLamCoVarOccs--But it is not necessary to gather CoVars from the types of other binders.--* For let-binders, if the type mentions a CoVar, so will the RHS (since-  it has the same type)--* For case-alt binders, if the type mentions a CoVar, so will the scrutinee-  (since it has the same type)--}--occAnal env (Tick tickish body)-  | SourceNote{} <- tickish-  = WithUsageDetails usage (Tick tickish body')-                  -- SourceNotes are best-effort; so we just proceed as usual.-                  -- If we drop a tick due to the issues described below it's-                  -- not the end of the world.--  | tickish `tickishScopesLike` SoftScope-  = WithUsageDetails (markAllNonTail usage) (Tick tickish body')--  | Breakpoint _ _ ids <- tickish-  = WithUsageDetails (usage_lam `andUDs` foldr addManyOcc emptyDetails ids) (Tick tickish body')-    -- never substitute for any of the Ids in a Breakpoint--  | otherwise-  = WithUsageDetails usage_lam (Tick tickish body')-  where-    (WithUsageDetails usage body') = occAnal env body-    -- for a non-soft tick scope, we can inline lambdas only-    usage_lam = markAllNonTail (markAllInsideLam usage)-                  -- TODO There may be ways to make ticks and join points play-                  -- nicer together, but right now there are problems:-                  --   let j x = ... in tick<t> (j 1)-                  -- Making j a join point may cause the simplifier to drop t-                  -- (if the tick is put into the continuation). So we don't-                  -- count j 1 as a tail call.-                  -- See #14242.--occAnal env (Cast expr co)-  = let  (WithUsageDetails usage expr') = occAnal env expr-         usage1 = addManyOccs usage (coVarsOfCo co)-             -- usage2: see Note [Gather occurrences of coercion variables]-         usage2 = markAllNonTail usage1-             -- usage3: calls inside expr aren't tail calls any more-    in WithUsageDetails usage2 (Cast expr' co)--occAnal env app@(App _ _)-  = occAnalApp env (collectArgsTicks tickishFloatable app)--occAnal env expr@(Lam {})-  = let (WithUsageDetails usage expr') = occAnalLam env expr-        final_usage = markAllInsideLamIf (not (isOneShotFun expr')) $-                      markAllNonTail usage-    in WithUsageDetails final_usage expr'--occAnal env (Case scrut bndr ty alts)-  = let-      (WithUsageDetails scrut_usage scrut') = occAnal (scrutCtxt env alts) scrut-      alt_env = addBndrSwap scrut' bndr $ env { occ_encl = OccVanilla } `addOneInScope` bndr-      (alts_usage_s, alts') = mapAndUnzip (do_alt alt_env) alts-      alts_usage  = foldr orUDs emptyDetails alts_usage_s-      (alts_usage1, tagged_bndr) = tagLamBinder alts_usage bndr-      total_usage = markAllNonTail scrut_usage `andUDs` alts_usage1-                    -- Alts can have tail calls, but the scrutinee can't-    in WithUsageDetails total_usage (Case scrut' tagged_bndr ty alts')-  where-    do_alt !env (Alt con bndrs rhs)-      = let-          (WithUsageDetails rhs_usage1 rhs1) = occAnal (env `addInScope` bndrs) rhs-          (alt_usg, tagged_bndrs) = tagLamBinders rhs_usage1 bndrs-        in                          -- See Note [Binders in case alternatives]-        (alt_usg, Alt con tagged_bndrs rhs1)--occAnal env (Let bind body)-  = let-      body_env = env { occ_encl = OccVanilla } `addInScope` bindersOf bind-      (WithUsageDetails body_usage  body')  = occAnal body_env body-      (WithUsageDetails final_usage binds') = occAnalBind env NotTopLevel-                                                    noImpRuleEdges bind body_usage-    in WithUsageDetails final_usage (mkLets binds' body')--occAnalArgs :: OccEnv -> CoreExpr -> [CoreExpr] -> [OneShots] -> WithUsageDetails CoreExpr--- The `fun` argument is just an accumulating parameter,--- the base for building the application we return-occAnalArgs !env fun args !one_shots-  = go emptyDetails fun args one_shots-  where-    go uds fun [] _ = WithUsageDetails uds fun-    go uds fun (arg:args) one_shots-      = go (uds `andUDs` arg_uds) (fun `App` arg') args one_shots'-      where-        !(WithUsageDetails arg_uds arg') = occAnal arg_env arg-        !(arg_env, one_shots')-            | isTypeArg arg = (env, one_shots)-            | otherwise     = valArgCtxt env one_shots--{--Applications are dealt with specially because we want-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], [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-  , let (WithUsageDetails usage arg') = occAnalRhs env NonRecursive (Just 1) arg-  = WithUsageDetails usage (mkTicks ticks $ mkApps (Var fun) [t1, t2, arg'])--occAnalApp env (Var fun_id, args, ticks)-  = WithUsageDetails 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-    !(WithUsageDetails args_uds app') = occAnalArgs env fun' args one_shots--    fun_uds = mkOneOcc fun_id' int_cxt n_args-       -- NB: fun_uds is computed for fun_id', not fun_id-       -- 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) $-                      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)-  = WithUsageDetails (markAllNonTail (fun_uds `andUDs` args_uds))-                     (mkTicks ticks app')-  where-    !(WithUsageDetails args_uds app') = occAnalArgs env fun' args []-    !(WithUsageDetails fun_uds fun')  = occAnal (addAppCtxt env args) fun-        -- The addAppCtxt is a bit cunning.  One iteration of the simplifier-        -- often leaves behind beta redexs like-        --      (\x y -> e) a1 a2-        -- Here we would like to mark x,y as one-shot, and treat the whole-        -- thing much like a let.  We do this by pushing some 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 :: 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 #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, 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 |> sym mco)-           -- Invariant of course: idType x = exprType (y |> sym mco)-           , occ_bs_env  :: !(VarEnv (OutId, MCoercion))-           , occ_bs_rng  :: !VarSet   -- Vars free in the range of occ_bs_env-                   -- Domain is Global and Local Ids-                   -- Range is just Local Ids-    }----------------------------------- 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 enough about the context to know what to do when--- we encounter a constructor application or PAP.------ OccScrut is used to set the "interesting context" field of OncOcc--data OccEncl-  = OccRhs         -- RHS of let(rec), albeit perhaps inside a type lambda-                   -- Don't inline into constructor args here--  | OccScrut       -- Scrutintee of a case-                   -- Can inline into constructor args--  | OccVanilla     -- Argument of function, body of lambda, etc-                   -- Do inline into constructor args here--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_bs_env = emptyVarEnv-           , occ_bs_rng = emptyVarSet }--noBinderSwaps :: OccEnv -> Bool-noBinderSwaps (OccEnv { occ_bs_env = bs_env }) = isEmptyVarEnv bs_env--scrutCtxt :: OccEnv -> [CoreAlt] -> OccEnv-scrutCtxt !env alts-  | interesting_alts =  env { occ_encl = OccScrut,   occ_one_shots = [] }-  | otherwise        =  env { occ_encl = OccVanilla, occ_one_shots = [] }-  where-    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"!--rhsCtxt :: OccEnv -> OccEnv-rhsCtxt !env = env { occ_encl = OccRhs, occ_one_shots = [] }--valArgCtxt :: OccEnv -> [OneShots] -> (OccEnv, [OneShots])-valArgCtxt !env []-  = (env { occ_encl = OccVanilla, occ_one_shots = [] }, [])-valArgCtxt 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 = cxt }) = case cxt of-                                          OccRhs -> True-                                          _      -> False--addOneInScope :: OccEnv -> CoreBndr -> OccEnv-addOneInScope env@(OccEnv { occ_bs_env = swap_env, occ_bs_rng = rng_vars }) bndr-  | bndr `elemVarSet` rng_vars = env { occ_bs_env = emptyVarEnv, occ_bs_rng = emptyVarSet }-  | otherwise                  = env { occ_bs_env = swap_env `delVarEnv` bndr }--addInScope :: OccEnv -> [Var] -> OccEnv--- See Note [The binder-swap substitution]--- It's only neccessary to call this on in-scope Ids,--- but harmless to include TyVars too-addInScope env@(OccEnv { occ_bs_env = swap_env, occ_bs_rng = rng_vars }) bndrs-  | any (`elemVarSet` rng_vars) bndrs = env { occ_bs_env = emptyVarEnv, occ_bs_rng = emptyVarSet }-  | otherwise                         = env { occ_bs_env = swap_env `delVarEnvList` bndrs }------------------------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, 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:-         - \x. blah-           Here we want to delete the x-binding from occ_bs_env--         - \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.--      The occurrence analyser itself does /not/ do cloning. It could, in-      principle, but it'd make it a bit more complicated and there is no-      great benefit. The simplifer uses cloning to get a no-shadowing-      situation, the care-when-shadowing behaviour above isn't needed for-      long.--(BS4) The domain of occ_bs_env can include GlobaIds.  Eg-         case M.foo of b { alts }-      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.--Historical note-----------------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.--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 [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.--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.--}--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 })-  | Just (scrut_var, mco) <- get_scrut_var (stripTicksTopE (const True) 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-    get_scrut_var :: OutExpr -> Maybe (OutVar, MCoercion)-    get_scrut_var (Var v)           = Just (v, MRefl)-    get_scrut_var (Cast (Var v) co) = Just (v, MCo co) -- See Note [Case of cast]-    get_scrut_var _                 = Nothing--    case_bndr' = zapIdOccInfo case_bndr-                 -- See Note [Zap case binders in proxy bindings]--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) -> (add_cast fun mco, fun_id) }--  where-    add_cast fun MRefl    = fun-    add_cast fun (MCo co) = Cast fun (mkSymCo co)-    -- We must switch that 'co' to 'sym co';-    -- see the comment with occ_bs_env-    -- No need to test for isReflCo, because 'co' came from-    -- a (Cast e co) and hence is unlikely to be Refl--{--************************************************************************-*                                                                      *-\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 'markNonTail' 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--andUDs, orUDs-        :: UsageDetails -> UsageDetails -> UsageDetails-andUDs = combineUsageDetailsWith addOccInfo-orUDs  = combineUsageDetailsWith orOccInfo--mkOneOcc :: Id -> InterestingCxt -> JoinArity -> UsageDetails-mkOneOcc id int_cxt arity-  | isLocalId id-  = emptyDetails { ud_env = unitVarEnv id occ_info }-  | otherwise-  = emptyDetails-  where-    occ_info = OneOcc { occ_in_lam  = NotInsideLam-                      , occ_n_br    = oneBranch-                      , occ_int_cxt = int_cxt-                      , occ_tail    = AlwaysTailCalled arity }--addManyOccId :: UsageDetails -> Id -> UsageDetails--- Add the non-committal (id :-> noOccInfo) to the usage details-addManyOccId ud id = ud { ud_env = extendVarEnv (ud_env ud) id noOccInfo }---- Add several occurrences, assumed not to be tail calls-addManyOcc :: Var -> UsageDetails -> UsageDetails-addManyOcc v u | isId v    = addManyOccId u v-               | 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.)--addManyOccs :: UsageDetails -> VarSet -> UsageDetails-addManyOccs usage id_set = nonDetStrictFoldUniqSet addManyOcc usage id_set-  -- It's OK to use nonDetStrictFoldUniqSet here because addManyOcc commutes--addLamCoVarOccs :: UsageDetails -> [Var] -> UsageDetails--- Add any CoVars free in the type of a lambda-binder--- See Note [Gather occurrences of coercion variables]-addLamCoVarOccs uds bndrs-  = uds `addManyOccs` coVarsOfTypes (map varType bndrs)--delDetails :: UsageDetails -> Id -> UsageDetails-delDetails ud bndr-  = ud `alterUsageDetails` (`delVarEnv` bndr)--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, markAllNonTail, markAllManyNonTail-  :: UsageDetails -> UsageDetails-markAllMany          ud = ud { ud_z_many    = ud_env ud }-markAllInsideLam     ud = ud { ud_z_in_lam  = ud_env ud }-markAllNonTail ud = ud { ud_z_no_tail = ud_env ud }--markAllInsideLamIf, markAllNonTailIf :: Bool -> UsageDetails -> UsageDetails--markAllInsideLamIf  True  ud = markAllInsideLam ud-markAllInsideLamIf  False ud = ud--markAllNonTailIf True  ud = markAllNonTail ud-markAllNonTailIf False ud = ud---markAllManyNonTail = markAllMany . markAllNonTail -- 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 = restrictFreeVars bndrs (ud_env ud)--restrictFreeVars :: VarSet -> OccInfoEnv -> VarSet-restrictFreeVars bndrs fvs = restrictUniqSetToUFM bndrs fvs------------------------ 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 { ud_z_many = many-                      , ud_z_in_lam = in_lam-                      , ud_z_no_tail = no_tail })-                  uniq occ-  = occ2-  where-    occ1 | uniq `elemVarEnvByKey` many    = markMany occ-         | uniq `elemVarEnvByKey` in_lam  = markInsideLam occ-         | otherwise                      = occ-    occ2 | uniq `elemVarEnvByKey` no_tail = markNonTail occ1-         | otherwise                      = occ1--alterUsageDetails :: UsageDetails -> (OccInfoEnv -> OccInfoEnv) -> UsageDetails-alterUsageDetails !ud f-  = UD { ud_env       = f (ud_env       ud)-       , ud_z_many    = f (ud_z_many    ud)-       , ud_z_in_lam  = f (ud_z_in_lam  ud)-       , ud_z_no_tail = f (ud_z_no_tail ud) }--flattenUsageDetails :: UsageDetails -> UsageDetails-flattenUsageDetails ud@(UD { ud_env = env })-  = UD { ud_env       = mapUFM_Directly (doZappingByUnique ud) env-       , ud_z_many    = emptyVarEnv-       , ud_z_in_lam  = emptyVarEnv-       , ud_z_no_tail = emptyVarEnv }------------------------ See Note [Adjusting right-hand sides]-adjustRhsUsage :: Maybe JoinArity-               -> CoreExpr       -- Rhs, AFTER occ anal-               -> UsageDetails   -- From body of lambda-               -> UsageDetails-adjustRhsUsage mb_join_arity rhs usage-  = -- c.f. occAnal (Lam {})-    markAllInsideLamIf (not one_shot) $-    markAllNonTailIf (not exact_join) $-    usage-  where-    one_shot   = isOneShotFun rhs-    exact_join = exactJoin mb_join_arity bndrs-    (bndrs,_)  = collectBinders rhs--exactJoin :: Maybe JoinArity -> [a] -> Bool-exactJoin Nothing           _    = False-exactJoin (Just join_arity) args = args `lengthIs` join_arity-  -- Remember join_arity includes type binders--type IdWithOccInfo = Id--tagLamBinders :: UsageDetails          -- Of scope-              -> [Id]                  -- Binders-              -> (UsageDetails,        -- Details with binders removed-                 [IdWithOccInfo])    -- Tagged binders-tagLamBinders usage binders-  = usage' `seq` (usage', bndrs')-  where-    (usage', bndrs') = mapAccumR tagLamBinder usage binders--tagLamBinder :: UsageDetails       -- Of scope-             -> Id                 -- Binder-             -> (UsageDetails,     -- Details with binder 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-tagLamBinder usage bndr-  = (usage2, bndr')-  where-        occ    = lookupDetails usage bndr-        bndr'  = setBinderOcc (markNonTail occ) bndr-                   -- Don't try to make an argument into a join point-        usage1 = usage `delDetails` bndr-        usage2 | isId bndr = addManyOccs 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 = -- must already be marked AlwaysTailCalled-                              assert (isAlwaysTailCalled occ) occ-             | otherwise    = markNonTail 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-              -> [Details]-              -> (UsageDetails,         -- Adjusted details for whole scope,-                                        -- with binders removed-                  [IdWithOccInfo])      -- Tagged binders--- Substantially more complicated than non-recursive case. Need to adjust RHS--- details *before* tagging binders (because the tags depend on the RHSes).-tagRecBinders lvl body_uds details_s- = let-     bndrs    = map nd_bndr details_s-     rhs_udss = map nd_uds  details_s--     -- 1. Determine join-point-hood of whole group, as determined by-     --    the *unadjusted* usage details-     unadj_uds     = foldr andUDs body_uds 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' = [ adjustRhsUsage (mb_join_arity bndr) rhs rhs_uds-                 | ND { nd_bndr = bndr, nd_uds = rhs_uds-                      , nd_rhs = rhs } <- details_s ]--     mb_join_arity :: Id -> Maybe JoinArity-     mb_join_arity bndr-         -- Can't use willBeJoinId_maybe here because we haven't tagged-         -- the binder yet (the tag depends on these adjustments!)-       | will_be_joins-       , let occ = lookupDetails unadj_uds bndr-       , AlwaysTailCalled arity <- tailCallInfo occ-       = Just arity-       | otherwise-       = assert (not will_be_joins) -- Should be AlwaysTailCalled if-         Nothing                   -- we are making join points!--     -- 3. Compute final usage details from adjusted RHS details-     adj_uds   = foldr andUDs body_uds rhs_udss'--     -- 4. Tag each binder with its adjusted details-     bndrs'    = [ setBinderOcc (lookupDetails adj_uds bndr) bndr-                 | bndr <- 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.------ 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".-decideJoinPointHood :: TopLevelFlag -> UsageDetails-                    -> [CoreBndr]-                    -> Bool-decideJoinPointHood TopLevel _ _-  = False-decideJoinPointHood NotTopLevel usage bndrs-  | isJoinId (head bndrs)-  = warnPprTrace (not all_ok)-                 "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 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--    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--willBeJoinId_maybe :: CoreBndr -> Maybe JoinArity-willBeJoinId_maybe bndr-  | isId bndr-  , AlwaysTailCalled arity <- tailCallInfo (idOccInfo bndr)-  = Just arity-  | otherwise-  = isJoinId_maybe bndr---{- 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}-*                                                                      *-************************************************************************--}--markMany, markInsideLam, markNonTail :: OccInfo -> OccInfo--markMany IAmDead = IAmDead-markMany occ     = ManyOccs { occ_tail = occ_tail occ }--markInsideLam occ@(OneOcc {}) = occ { occ_in_lam = IsInsideLam }-markInsideLam occ             = occ--markNonTail IAmDead = IAmDead-markNonTail 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_n_br    = nbr1-                  , occ_int_cxt = int_cxt1-                  , occ_tail    = tail1 })-          (OneOcc { occ_in_lam  = in_lam2-                  , occ_n_br    = nbr2-                  , occ_int_cxt = int_cxt2-                  , occ_tail    = tail2 })-  = OneOcc { occ_n_br    = nbr1 + nbr2-           , occ_in_lam  = in_lam1 `mappend` in_lam2-           , occ_int_cxt = int_cxt1 `mappend` int_cxt2-           , occ_tail    = tail1 `andTailCallInfo` tail2 }--orOccInfo a1 a2 = assert (not (isDeadOcc a1 || isDeadOcc a2)) $-                  ManyOccs { occ_tail = tailCallInfo a1 `andTailCallInfo`-                                        tailCallInfo a2 }+{-# LANGUAGE ViewPatterns #-}++{-# OPTIONS_GHC -cpp -Wno-incomplete-record-updates #-}++{-# OPTIONS_GHC -fmax-worker-args=12 #-}+-- The -fmax-worker-args=12 is there because the main functions+-- are strict in the OccEnv, and it turned out that with the default settting+-- some functions would unbox the OccEnv ad some would not, depending on how+-- many /other/ arguments the function has.  Inconsistent unboxing is very+-- bad for performance, so I increased the limit to allow it to unbox+-- consistently.++{-+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++************************************************************************+*                                                                      *+\section[OccurAnal]{Occurrence analysis pass}+*                                                                      *+************************************************************************++The occurrence analyser re-typechecks a core expression, returning a new+core expression with (hopefully) improved usage information.+-}++module GHC.Core.Opt.OccurAnal (+    occurAnalysePgm,+    occurAnalyseExpr,+    zapLambdaBndrs, BinderSwapDecision(..), scrutOkForBinderSwap+  ) where++import GHC.Prelude hiding ( head, init, last, tail )++import GHC.Core+import GHC.Core.FVs+import GHC.Core.Utils   ( exprIsTrivial, isDefaultAlt, isExpandableApp,+                          mkCastMCo, mkTicks )+import GHC.Core.Opt.Arity   ( joinRhsArity, isOneShotBndr )+import GHC.Core.Coercion+import GHC.Core.Type+import GHC.Core.TyCo.FVs    ( tyCoVarsOfMCo )++import GHC.Data.Maybe( orElse )+import GHC.Data.Graph.Directed ( SCC(..), Node(..)+                               , stronglyConnCompFromEdgedVerticesUniq+                               , stronglyConnCompFromEdgedVerticesUniqR )+import GHC.Types.Unique+import GHC.Types.Unique.FM+import GHC.Types.Unique.Set+import GHC.Types.Id+import GHC.Types.Id.Info+import GHC.Types.Basic+import GHC.Types.Tickish+import GHC.Types.Var.Set+import GHC.Types.Var.Env+import GHC.Types.Var+import GHC.Types.Demand ( argOneShots, argsOneShots, isDeadEndSig )++import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Utils.Misc++import GHC.Builtin.Names( runRWKey )+import GHC.Unit.Module( Module )++import Data.List (mapAccumL)+import Data.List.NonEmpty (NonEmpty (..))++{-+************************************************************************+*                                                                      *+    occurAnalysePgm, occurAnalyseExpr+*                                                                      *+************************************************************************++Here's the externally-callable interface:+-}++-- | Do occurrence analysis, and discard occurrence info returned+occurAnalyseExpr :: CoreExpr -> CoreExpr+occurAnalyseExpr expr = expr'+  where+    WUD _ expr' = occAnal initOccEnv expr++occurAnalysePgm :: Module         -- Used only in debug output+                -> (Id -> Bool)         -- Active unfoldings+                -> (Activation -> Bool) -- Active rules+                -> [CoreRule]           -- Local rules for imported Ids+                -> CoreProgram -> CoreProgram+occurAnalysePgm this_mod active_unf active_rule imp_rules binds+  | isEmptyDetails final_usage+  = occ_anald_binds++  | otherwise   -- See Note [Glomming]+  = warnPprTrace True "Glomming in" (hang (ppr this_mod <> colon) 2 (ppr final_usage))+    occ_anald_glommed_binds+  where+    init_env = initOccEnv { occ_rule_act = active_rule+                          , occ_unf_act  = active_unf }++    WUD final_usage occ_anald_binds = go binds init_env+    WUD _ occ_anald_glommed_binds = occAnalRecBind init_env TopLevel+                                                    imp_rule_edges+                                                    (flattenBinds binds)+                                                    initial_uds+          -- It's crucial to re-analyse the glommed-together bindings+          -- so that we establish the right loop breakers. Otherwise+          -- we can easily create an infinite loop (#9583 is an example)+          --+          -- Also crucial to re-analyse the /original/ bindings+          -- in case the first pass accidentally discarded as dead code+          -- a binding that was actually needed (albeit before its+          -- definition site).  #17724 threw this up.++    initial_uds = addManyOccs emptyDetails (rulesFreeVars imp_rules)+    -- The RULES declarations keep things alive!++    -- imp_rule_edges maps a top-level local binder 'f' to the+    -- RHS free vars of any IMP-RULE, a local RULE for an imported function,+    -- where 'f' appears on the LHS+    --   e.g.  RULE foldr f = blah+    --         imp_rule_edges contains f :-> fvs(blah)+    -- We treat such RULES as extra rules for 'f'+    -- See Note [Preventing loops due to imported functions rules]+    imp_rule_edges :: ImpRuleEdges+    imp_rule_edges = foldr (plusVarEnv_C (++)) emptyVarEnv+                           [ mapVarEnv (const [(act,rhs_fvs)]) $ getUniqSet $+                             exprsFreeIds args `delVarSetList` bndrs+                           | Rule { ru_act = act, ru_bndrs = bndrs+                                   , ru_args = args, ru_rhs = rhs } <- imp_rules+                                   -- Not BuiltinRules; see Note [Plugin rules]+                           , let rhs_fvs = exprFreeIds rhs `delVarSetList` bndrs ]++    go :: [CoreBind] -> OccEnv -> WithUsageDetails [CoreBind]+    go []           _   = WUD initial_uds []+    go (bind:binds) env = occAnalBind env TopLevel+                           imp_rule_edges bind (go binds) (++)++{- *********************************************************************+*                                                                      *+                IMP-RULES+         Local rules for imported functions+*                                                                      *+********************************************************************* -}++type ImpRuleEdges = IdEnv [(Activation, VarSet)]+    -- Mapping from a local Id 'f' to info about its IMP-RULES,+    -- i.e. /local/ rules for an imported Id that mention 'f' on the LHS+    -- We record (a) its Activation and (b) the RHS free vars+    -- See Note [IMP-RULES: local rules for imported functions]++noImpRuleEdges :: ImpRuleEdges+noImpRuleEdges = emptyVarEnv++lookupImpRules :: ImpRuleEdges -> Id -> [(Activation,VarSet)]+lookupImpRules imp_rule_edges bndr+  = case lookupVarEnv imp_rule_edges bndr of+      Nothing -> []+      Just vs -> vs++impRulesScopeUsage :: [(Activation,VarSet)] -> UsageDetails+-- Variable mentioned in RHS of an IMP-RULE for the bndr,+-- whether active or not+impRulesScopeUsage imp_rules_info+  = foldr add emptyDetails imp_rules_info+  where+    add (_,vs) usage = addManyOccs usage vs++impRulesActiveFvs :: (Activation -> Bool) -> VarSet+                  -> [(Activation,VarSet)] -> VarSet+impRulesActiveFvs is_active bndr_set vs+  = foldr add emptyVarSet vs `intersectVarSet` bndr_set+  where+    add (act,vs) acc | is_active act = vs `unionVarSet` acc+                     | otherwise     = acc++{- Note [IMP-RULES: local rules for imported functions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We quite often have+  * A /local/ rule+  * for an /imported/ function+like this:+  foo x = blah+  {-# RULE "map/foo" forall xs. map foo xs = xs #-}+We call them IMP-RULES.  They are important in practice, and occur a+lot in the libraries.++IMP-RULES are held in mg_rules of ModGuts, and passed in to+occurAnalysePgm.++Main Invariant:++* Throughout, we treat an IMP-RULE that mentions 'f' on its LHS+  just like a RULE for f.++Note [IMP-RULES: unavoidable loops]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this+   f = /\a. B.g a+   RULE B.g Int = 1 + f Int+Note that+  * The RULE is for an imported function.+  * f is non-recursive+Now we+can get+   f Int --> B.g Int      Inlining f+         --> 1 + f Int    Firing RULE+and so the simplifier goes into an infinite loop. This+would not happen if the RULE was for a local function,+because we keep track of dependencies through rules.  But+that is pretty much impossible to do for imported Ids.  Suppose+f's definition had been+   f = /\a. C.h a+where (by some long and devious process), C.h eventually inlines to+B.g.  We could only spot such loops by exhaustively following+unfoldings of C.h etc, in case we reach B.g, and hence (via the RULE)+f.++We regard this potential infinite loop as a *programmer* error.+It's up the programmer not to write silly rules like+     RULE f x = f x+and the example above is just a more complicated version.++Note [Specialising imported functions] (referred to from Specialise)+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For *automatically-generated* rules, the programmer can't be+responsible for the "programmer error" in Note [IMP-RULES: unavoidable+loops].  In particular, consider specialising a recursive function+defined in another module.  If we specialise a recursive function B.g,+we get+  g_spec = .....(B.g Int).....+  RULE B.g Int = g_spec+Here, g_spec doesn't look recursive, but when the rule fires, it+becomes so.  And if B.g was mutually recursive, the loop might not be+as obvious as it is here.++To avoid this,+ * When specialising a function that is a loop breaker,+   give a NOINLINE pragma to the specialised function++Note [Preventing loops due to imported functions rules]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider:+  import GHC.Base (foldr)++  {-# RULES "filterList" forall p. foldr (filterFB (:) p) [] = filter p #-}+  filter p xs = build (\c n -> foldr (filterFB c p) n xs)+  filterFB c p = ...++  f = filter p xs++Note that filter is not a loop-breaker, so what happens is:+  f =          filter p xs+    = {inline} build (\c n -> foldr (filterFB c p) n xs)+    = {inline} foldr (filterFB (:) p) [] xs+    = {RULE}   filter p xs++We are in an infinite loop.++A more elaborate example (that I actually saw in practice when I went to+mark GHC.List.filter as INLINABLE) is as follows. Say I have this module:+  {-# LANGUAGE RankNTypes #-}+  module GHCList where++  import Prelude hiding (filter)+  import GHC.Base (build)++  {-# INLINABLE filter #-}+  filter :: (a -> Bool) -> [a] -> [a]+  filter p [] = []+  filter p (x:xs) = if p x then x : filter p xs else filter p xs++  {-# NOINLINE [0] filterFB #-}+  filterFB :: (a -> b -> b) -> (a -> Bool) -> a -> b -> b+  filterFB c p x r | p x       = x `c` r+                   | otherwise = r++  {-# RULES+  "filter"     [~1] forall p xs.  filter p xs = build (\c n -> foldr+  (filterFB c p) n xs)+  "filterList" [1]  forall p.     foldr (filterFB (:) p) [] = filter p+   #-}++Then (because RULES are applied inside INLINABLE unfoldings, but inlinings+are not), the unfolding given to "filter" in the interface file will be:+  filter p []     = []+  filter p (x:xs) = if p x then x : build (\c n -> foldr (filterFB c p) n xs)+                           else     build (\c n -> foldr (filterFB c p) n xs++Note that because this unfolding does not mention "filter", filter is not+marked as a strong loop breaker. Therefore at a use site in another module:+  filter p xs+    = {inline}+      case xs of []     -> []+                 (x:xs) -> if p x then x : build (\c n -> foldr (filterFB c p) n xs)+                                  else     build (\c n -> foldr (filterFB c p) n xs)++  build (\c n -> foldr (filterFB c p) n xs)+    = {inline} foldr (filterFB (:) p) [] xs+    = {RULE}   filter p xs++And we are in an infinite loop again, except that this time the loop is producing an+infinitely large *term* (an unrolling of filter) and so the simplifier finally+dies with "ticks exhausted"++SOLUTION: we treat the rule "filterList" as an extra rule for 'filterFB'+because it mentions 'filterFB' on the LHS.  This is the Main Invariant+in Note [IMP-RULES: local rules for imported functions].++So, during loop-breaker analysis:++- for each active RULE for a local function 'f' we add an edge between+  'f' and the local FVs of the rule RHS++- for each active RULE for an *imported* function we add dependency+  edges between the *local* FVS of the rule LHS and the *local* FVS of+  the rule RHS.++Even with this extra hack we aren't always going to get things+right. For example, it might be that the rule LHS mentions an imported+Id, and another module has a RULE that can rewrite that imported Id to+one of our local Ids.++Note [Plugin rules]+~~~~~~~~~~~~~~~~~~~+Conal Elliott (#11651) built a GHC plugin that added some+BuiltinRules (for imported Ids) to the mg_rules field of ModGuts, to+do some domain-specific transformations that could not be expressed+with an ordinary pattern-matching CoreRule.  But then we can't extract+the dependencies (in imp_rule_edges) from ru_rhs etc, because a+BuiltinRule doesn't have any of that stuff.++So we simply assume that BuiltinRules have no dependencies, and filter+them out from the imp_rule_edges comprehension.++Note [Glomming]+~~~~~~~~~~~~~~~+RULES for imported Ids can make something at the top refer to+something at the bottom:++        foo = ...(B.f @Int)...+        $sf = blah+        RULE:  B.f @Int = $sf++Applying this rule makes foo refer to $sf, although foo doesn't appear to+depend on $sf.  (And, as in Note [IMP-RULES: local rules for imported functions], the+dependency might be more indirect. For example, foo might mention C.t+rather than B.f, where C.t eventually inlines to B.f.)++NOTICE that this cannot happen for rules whose head is a+locally-defined function, because we accurately track dependencies+through RULES.  It only happens for rules whose head is an imported+function (B.f in the example above).++Solution:+  - When simplifying, bring all top level identifiers into+    scope at the start, ignoring the Rec/NonRec structure, so+    that when 'h' pops up in f's rhs, we find it in the in-scope set+    (as the simplifier generally expects). This happens in simplTopBinds.++  - In the occurrence analyser, if there are any out-of-scope+    occurrences that pop out of the top, which will happen after+    firing the rule:      f = \x -> h x+                          h = \y -> 3+    then just glom all the bindings into a single Rec, so that+    the *next* iteration of the occurrence analyser will sort+    them all out.   This part happens in occurAnalysePgm.++This is a legitimate situation where the need for glomming doesn't+point to any problems. However, when GHC is compiled with -DDEBUG, we+produce a warning addressed to the GHC developers just in case we+require glomming due to an out-of-order reference that is caused by+some earlier transformation stage misbehaving.+-}++{-+************************************************************************+*                                                                      *+                Bindings+*                                                                      *+************************************************************************++Note [Recursive bindings: the grand plan]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Loop breaking is surprisingly subtle.  First read the section 4 of+"Secrets of the GHC inliner".  This describes our basic plan.  We+avoid infinite inlinings by choosing loop breakers, and ensuring that+a loop breaker cuts each loop.++See also Note [Inlining and hs-boot files] in GHC.Core.ToIface, which+deals with a closely related source of infinite loops.++When we come across a binding group+  Rec { x1 = r1; ...; xn = rn }+we treat it like this (occAnalRecBind):++1. Note [Forming Rec groups]+   Occurrence-analyse each right hand side, and build a+   "Details" for each binding to capture the results.+   Wrap the details in a LetrecNode, ready for SCC analysis.+   All this is done by makeNode.++   The edges of this graph are the "scope edges".++2. Do SCC-analysis on these Nodes:+   - Each CyclicSCC will become a new Rec+   - Each AcyclicSCC will become a new NonRec++   The key property is that every free variable of a binding is+   accounted for by the scope edges, so that when we are done+   everything is still in scope.++3. For each AcyclicSCC, just make a NonRec binding.++4. For each CyclicSCC of the scope-edge SCC-analysis in (2), we+   identify suitable loop-breakers to ensure that inlining terminates.+   This is done by occAnalRec.++   To do so, form the loop-breaker graph, do SCC analysis. For each+   CyclicSCC we choose a loop breaker, delete all edges to that node,+   re-analyse the SCC, and iterate. See Note [Choosing loop breakers]+   for the details+++Note [Dead code]+~~~~~~~~~~~~~~~~+Dropping dead code for a cyclic Strongly Connected Component is done+in a very simple way:++        the entire SCC is dropped if none of its binders are mentioned+        in the body; otherwise the whole thing is kept.++The key observation is that dead code elimination happens after+dependency analysis: so 'occAnalBind' processes SCCs instead of the+original term's binding groups.++Thus 'occAnalBind' does indeed drop 'f' in an example like++        letrec f = ...g...+               g = ...(...g...)...+        in+           ...g...++when 'g' no longer uses 'f' at all (eg 'f' does not occur in a RULE in+'g'). 'occAnalBind' first consumes 'CyclicSCC g' and then it consumes+'AcyclicSCC f', where 'body_usage' won't contain 'f'.++Note [Forming Rec groups]+~~~~~~~~~~~~~~~~~~~~~~~~~+The key point about the "Forming Rec groups" step is that it /preserves+scoping/.  If 'x' is mentioned, it had better be bound somewhere.  So if+we start with+  Rec { f = ...h...+      ; g = ...f...+      ; h = ...f... }+we can split into SCCs+  Rec { f = ...h...+      ; h = ..f... }+  NonRec { g = ...f... }++We put bindings {f = ef; g = eg } in a Rec group if "f uses g" and "g+uses f", no matter how indirectly.  We do a SCC analysis with an edge+f -> g if "f mentions g". That is, g is free in:+  a) the rhs 'ef'+  b) or the RHS of a rule for f, whether active or inactive+       Note [Rules are extra RHSs]+  c) or the LHS or a rule for f, whether active or inactive+       Note [Rule dependency info]+  d) the RHS of an /active/ local IMP-RULE+       Note [IMP-RULES: local rules for imported functions]++(b) and (c) apply regardless of the activation of the RULE, because even if+the rule is inactive its free variables must be bound.  But (d) doesn't need+to worry about this because IMP-RULES are always notionally at the bottom+of the file.++  * Note [Rules are extra RHSs]+    ~~~~~~~~~~~~~~~~~~~~~~~~~~~+    A RULE for 'f' is like an extra RHS for 'f'. That way the "parent"+    keeps the specialised "children" alive.  If the parent dies+    (because it isn't referenced any more), then the children will die+    too (unless they are already referenced directly).++    So in Example [eftInt], eftInt and eftIntFB will be put in the+    same Rec, even though their 'main' RHSs are both non-recursive.++    We must also include inactive rules, so that their free vars+    remain in scope.++  * Note [Rule dependency info]+    ~~~~~~~~~~~~~~~~~~~~~~~~~~~+    The VarSet in a RuleInfo is used for dependency analysis in the+    occurrence analyser.  We must track free vars in *both* lhs and rhs.+    Hence use of idRuleVars, rather than idRuleRhsVars in occAnalBind.+    Why both? Consider+        x = y+        RULE f x = v+4+    Then if we substitute y for x, we'd better do so in the+    rule's LHS too, so we'd better ensure the RULE appears to mention 'x'+    as well as 'v'++  * Note [Rules are visible in their own rec group]+    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+    We want the rules for 'f' to be visible in f's right-hand side.+    And we'd like them to be visible in other functions in f's Rec+    group.  E.g. in Note [Specialisation rules] we want f' rule+    to be visible in both f's RHS, and fs's RHS.++    This means that we must simplify the RULEs first, before looking+    at any of the definitions.  This is done by Simplify.simplRecBind,+    when it calls addLetIdInfo.++Note [TailUsageDetails when forming Rec groups]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The `TailUsageDetails` stored in the `nd_uds` field of a `NodeDetails` is+computed by `occAnalLamTail` applied to the RHS, not `occAnalExpr`.+That is because the binding might still become a *non-recursive join point* in+the AcyclicSCC case of dependency analysis!+Hence we do the delayed `adjustTailUsage` in `occAnalRec`/`tagRecBinders` to get+a regular, adjusted UsageDetails.+See Note [Join points and unfoldings/rules] for more details on the contract.++Note [Stable unfoldings]+~~~~~~~~~~~~~~~~~~~~~~~~+None of the above stuff about RULES applies to a stable unfolding+stored in a CoreUnfolding.  The unfolding, if any, is simplified+at the same time as the regular RHS of the function (ie *not* like+Note [Rules are visible in their own rec group]), so it should be+treated *exactly* like an extra RHS.++Or, rather, when computing loop-breaker edges,+  * If f has an INLINE pragma, and it is active, we treat the+    INLINE rhs as f's rhs+  * If it's inactive, we treat f as having no rhs+  * If it has no INLINE pragma, we look at f's actual rhs+++There is a danger that we'll be sub-optimal if we see this+     f = ...f...+     [INLINE f = ..no f...]+where f is recursive, but the INLINE is not. This can just about+happen with a sufficiently odd set of rules; eg++        foo :: Int -> Int+        {-# INLINE [1] foo #-}+        foo x = x+1++        bar :: Int -> Int+        {-# INLINE [1] bar #-}+        bar x = foo x + 1++        {-# RULES "foo" [~1] forall x. foo x = bar x #-}++Here the RULE makes bar recursive; but it's INLINE pragma remains+non-recursive. It's tempting to then say that 'bar' should not be+a loop breaker, but an attempt to do so goes wrong in two ways:+   a) We may get+         $df = ...$cfoo...+         $cfoo = ...$df....+         [INLINE $cfoo = ...no-$df...]+      But we want $cfoo to depend on $df explicitly so that we+      put the bindings in the right order to inline $df in $cfoo+      and perhaps break the loop altogether.  (Maybe this+   b)+++Example [eftInt]+~~~~~~~~~~~~~~~+Example (from GHC.Enum):++  eftInt :: Int# -> Int# -> [Int]+  eftInt x y = ...(non-recursive)...++  {-# INLINE [0] eftIntFB #-}+  eftIntFB :: (Int -> r -> r) -> r -> Int# -> Int# -> r+  eftIntFB c n x y = ...(non-recursive)...++  {-# RULES+  "eftInt"  [~1] forall x y. eftInt x y = build (\ c n -> eftIntFB c n x y)+  "eftIntList"  [1] eftIntFB  (:) [] = eftInt+   #-}++Note [Specialisation rules]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this group, which is typical of what SpecConstr builds:++   fs a = ....f (C a)....+   f  x = ....f (C a)....+   {-# RULE f (C a) = fs a #-}++So 'f' and 'fs' are in the same Rec group (since f refers to fs via its RULE).++But watch out!  If 'fs' is not chosen as a loop breaker, we may get an infinite loop:+  - the RULE is applied in f's RHS (see Note [Rules for recursive functions] in GHC.Core.Opt.Simplify+  - fs is inlined (say it's small)+  - now there's another opportunity to apply the RULE++This showed up when compiling Control.Concurrent.Chan.getChanContents.+Hence the transitive rule_fv_env stuff described in+Note [Rules and loop breakers].++Note [Occurrence analysis for join points]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider these two somewhat artificial programs (#22404)++  Program (P1)                      Program (P2)+  ------------------------------    -------------------------------------+  let v = <small thunk> in          let v = <small thunk> in+                                    join j = case v of (a,b) -> a+  in case x of                      in case x of+        A -> case v of (a,b) -> a         A -> j+        B -> case v of (a,b) -> a         B -> j+        C -> case v of (a,b) -> b         C -> case v of (a,b) -> b+        D -> []                           D -> []++In (P1), `v` gets allocated, as a thunk, every time this code is executed.  But+notice that `v` occurs at most once in any case branch; the occurrence analyser+spots this and returns a OneOcc{ occ_n_br = 3 } for `v`.  Then the code in+GHC.Core.Opt.Simplify.Utils.postInlineUnconditionally inlines `v` at its three+use sites, and discards the let-binding.  That way, we avoid allocating `v` in+the A,B,C branches (though we still compute it of course), and branch D+doesn't involve <small thunk> at all.  This sometimes makes a Really Big+Difference.++In (P2) we have shared the common RHS of A, B, in a join point `j`.  We would+like to inline `v` in just the same way as in (P1).  But the usual strategy+for let bindings is conservative and uses `andUDs` to combine usage from j's+RHS to its body; as if `j` was called on every code path (once, albeit).  In+the case of (P2), we'll get ManyOccs for `v`.  Important optimisation lost!++Solving this problem makes the Simplifier less fragile.  For example,+the Simplifier might inline `j`, and convert (P2) into (P1)... or it might+not, depending in a perhaps-fragile way on the size of the join point.+I was motivated to implement this feature of the occurrence analyser+when trying to make optimisation join points simpler and more robust+(see e.g. #23627).++The occurrence analyser therefore has clever code that behaves just as+if you inlined `j` at all its call sites.  Here is a tricky variant+to keep in mind:++  Program (P3)+  -------------------------------+    join j = case v of (a,b) -> a+    in case f v of+          A -> j+          B -> j+          C -> []++If you mentally inline `j` you'll see that `v` is used twice on the path+through A, so it should have ManyOcc.  Bear this case in mind!++* We treat /non-recursive/ join points specially. Recursive join points are+  treated like any other letrec, as before.  Moreover, we only give this special+  treatment to /pre-existing/ non-recursive join points, not the ones that we+  discover for the first time in this sweep of the occurrence analyser.++* In occ_env, the new (occ_join_points :: IdEnv OccInfoEnv) maps+  each in-scope non-recursive join point, such as `j` above, to+  a "zeroed form" of its RHS's usage details. The "zeroed form"+    * deletes ManyOccs+    * maps a OneOcc to OneOcc{ occ_n_br = 0 }+  In our example, occ_join_points will be extended with+      [j :-> [v :-> OneOcc{occ_n_br=0}]]+  See addJoinPoint.++* At an occurrence of a join point, we do everything as normal, but add in the+  UsageDetails from the occ_join_points.  See mkOneOcc.++* Crucially, at the NonRec binding of the join point, in `occAnalBind`, we use+  `orUDs`, not `andUDs` to combine the usage from the RHS with the usage from+  the body.++Here are the consequences++* Because of the perhaps-surprising OneOcc{occ_n_br=0} idea of the zeroed+  form, the occ_n_br field of a OneOcc binder still counts the number of+  /actual lexical occurrences/ of the variable.  In Program P2, for example,+  `v` will end up with OneOcc{occ_n_br=2}, not occ_n_br=3.+  There are two lexical occurrences of `v`!+  (NB: `orUDs` adds occ_n_br together, so occ_n_br=1 is impossible, too.)++* In the tricky (P3) we'll get an `andUDs` of+    * OneOcc{occ_n_br=0} from the occurrences of `j`)+    * OneOcc{occ_n_br=1} from the (f v)+  These are `andUDs` together in `addOccInfo`, and hence+  `v` gets ManyOccs, just as it should.  Clever!++There are a couple of tricky wrinkles++(W1) Consider this example which shadows `j`:+          join j = rhs in+          in case x of { K j -> ..j..; ... }+     Clearly when we come to the pattern `K j` we must drop the `j`+     entry in occ_join_points.++     This is done by `drop_shadowed_joins` in `addInScope`.++(W2) Consider this example which shadows `v`:+          join j = ...v...+          in case x of { K v -> ..j..; ... }++     We can't make j's occurrences in the K alternative give rise to an+     occurrence of `v` (via occ_join_points), because it'll just be deleted by+     the `K v` pattern.  Yikes.  This is rare because shadowing is rare, but+     it definitely can happen.  Solution: when bringing `v` into scope at+     the `K v` pattern, chuck out of occ_join_points any elements whose+     UsageDetails mentions `v`.  Instead, just `andUDs` all that usage in+     right here.++     This requires work in two places.+     * In `preprocess_env`, we detect if the newly-bound variables intersect+       the free vars of occ_join_points.  (These free vars are conveniently+       simply the domain of the OccInfoEnv for that join point.) If so,+       we zap the entire occ_join_points.+     * In `postprcess_uds`, we add the chucked-out join points to the+       returned UsageDetails, with `andUDs`.++(W3) Consider this example, which shadows `j`, but this time in an argument+              join j = rhs+              in f (case x of { K j -> ...; ... })+     We can zap the entire occ_join_points when looking at the argument,+     because `j` can't posibly occur -- it's a join point!  And the smaller+     occ_join_points is, the better.  Smaller to look up in mkOneOcc, and+     more important, less looking-up when checking (W2).++     This is done in setNonTailCtxt.  It's important /not/ to do this for+     join-point RHS's because of course `j` can occur there!++     NB: this is just about efficiency: it is always safe /not/ to zap the+     occ_join_points.++(W4) What if the join point binding has a stable unfolding, or RULES?+     They are just alternative right-hand sides, and at each call site we+     will use only one of them. So again, we can use `orUDs` to combine+     usage info from all these alternatives RHSs.++Wrinkles (W1) and (W2) are very similar to Note [Binder swap] (BS3).++Note [Finding join points]+~~~~~~~~~~~~~~~~~~~~~~~~~~+It's the occurrence analyser's job to find bindings that we can turn into join+points, but it doesn't perform that transformation right away. Rather, it marks+the eligible bindings as part of their occurrence data, leaving it to the+simplifier (or to simpleOptPgm) to actually change the binder's 'IdDetails'.+The simplifier then eta-expands the RHS if needed and then updates the+occurrence sites. Dividing the work this way means that the occurrence analyser+still only takes one pass, yet one can always tell the difference between a+function call and a jump by looking at the occurrence (because the same pass+changes the 'IdDetails' and propagates the binders to their occurrence sites).++To track potential join points, we use the 'occ_tail' field of OccInfo. A value+of `AlwaysTailCalled n` indicates that every occurrence of the variable is a+tail call with `n` arguments (counting both value and type arguments). Otherwise+'occ_tail' will be 'NoTailCallInfo'. The tail call info flows bottom-up with the+rest of 'OccInfo' until it goes on the binder.++Note [Join arity prediction based on joinRhsArity]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In general, the join arity from tail occurrences of a join point (O) may be+higher or lower than the manifest join arity of the join body (M). E.g.,++  -- M > O:+  let f x y = x + y              -- M = 2+  in if b then f 1 else f 2      -- O = 1+  ==> { Contify for join arity 1 }+  join f x = \y -> x + y+  in if b then jump f 1 else jump f 2++  -- M < O+  let f = id                     -- M = 0+  in if ... then f 12 else f 13  -- O = 1+  ==> { Contify for join arity 1, eta-expand f }+  join f x = id x+  in if b then jump f 12 else jump f 13++But for *recursive* let, it is crucial that both arities match up, consider++  letrec f x y = if ... then f x else True+  in f 42++Here, M=2 but O=1. If we settled for a joinrec arity of 1, the recursive jump+would not happen in a tail context! Contification is invalid here.+So indeed it is crucial to demand that M=O.++(Side note: Actually, we could be more specific: Let O1 be the join arity of+occurrences from the letrec RHS and O2 the join arity from the let body. Then+we need M=O1 and M<=O2 and could simply eta-expand the RHS to match O2 later.+M=O is the specific case where we don't want to eta-expand. Neither the join+points paper nor GHC does this at the moment.)++We can capitalise on this observation and conclude that *if* f could become a+joinrec (without eta-expansion), it will have join arity M.+Now, M is just the result of 'joinRhsArity', a rather simple, local analysis.+It is also the join arity inside the 'TailUsageDetails' returned by+'occAnalLamTail', so we can predict join arity without doing any fixed-point+iteration or really doing any deep traversal of let body or RHS at all.+We check for M in the 'adjustTailUsage' call inside 'tagRecBinders'.++All this is quite apparent if you look at the contification transformation in+Fig. 5 of "Compiling without Continuations" (which does not account for+eta-expansion at all, mind you). The letrec case looks like this++  letrec f = /\as.\xs. L[us] in L'[es]+    ... and a bunch of conditions establishing that f only occurs+        in app heads of join arity (len as + len xs) inside us and es ...++The syntactic form `/\as.\xs. L[us]` forces M=O iff `f` occurs in `us`. However,+for non-recursive functions, this is the definition of contification from the+paper:++  let f = /\as.\xs.u in L[es]     ... conditions ...++Note that u could be a lambda itself, as we have seen. No relationship between M+and O to exploit here.++Note [Join points and unfoldings/rules]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+   let j2 y = blah+   let j x = j2 (x+x)+       {-# INLINE [2] j #-}+   in case e of { A -> j 1; B -> ...; C -> j 2 }++Before j is inlined, we'll have occurrences of j2 in+both j's RHS and in its stable unfolding.  We want to discover+j2 as a join point. So 'occAnalUnfolding' returns an unadjusted+'TailUsageDetails', like 'occAnalLamTail'. We adjust the usage details of the+unfolding to the actual join arity using the same 'adjustTailArity' as for+the RHS, see Note [Adjusting right-hand sides].++Same with rules. Suppose we have:++  let j :: Int -> Int+      j y = 2 * y+  let k :: Int -> Int -> Int+      {-# RULES "SPEC k 0" k 0 y = j y #-}+      k x y = x + 2 * y+  in case e of { A -> k 1 2; B -> k 3 5; C -> blah }++We identify k as a join point, and we want j to be a join point too.+Without the RULE it would be, and we don't want the RULE to mess it+up.  So provided the join-point arity of k matches the args of the+rule we can allow the tail-call info from the RHS of the rule to+propagate.++* Note that the join arity of the RHS and that of the unfolding or RULE might+  mismatch:++    let j x y = j2 (x+x)+        {-# INLINE[2] j = \x. g #-}+        {-# RULE forall x y z. j x y z = h 17 #-}+    in j 1 2++  So it is crucial that we adjust each TailUsageDetails individually+  with the actual join arity 2 here before we combine with `andUDs`.+  Here, that means losing tail call info on `g` and `h`.++* Wrinkle for Rec case: We store one TailUsageDetails in the node Details for+  RHS, unfolding and RULE combined. Clearly, if they don't agree on their join+  arity, we have to do some adjusting. We choose to adjust to the join arity+  of the RHS, because that is likely the join arity that the join point will+  have; see Note [Join arity prediction based on joinRhsArity].++  If the guess is correct, then tail calls in the RHS are preserved; a necessary+  condition for the whole binding becoming a joinrec.+  The guess can only be incorrect in the 'AcyclicSCC' case when the binding+  becomes a non-recursive join point with a different join arity. But then the+  eventual call to 'adjustTailUsage' in 'tagRecBinders'/'occAnalRec' will+  be with a different join arity and destroy unsound tail call info with+  'markNonTail'.++* Wrinkle for RULES.  Suppose the example was a bit different:+      let j :: Int -> Int+          j y = 2 * y+          k :: Int -> Int -> Int+          {-# RULES "SPEC k 0" k 0 = j #-}+          k x y = x + 2 * y+      in ...+  If we eta-expanded the rule all would be well, but as it stands the+  one arg of the rule don't match the join-point arity of 2.++  Conceivably we could notice that a potential join point would have+  an "undersaturated" rule and account for it. This would mean we+  could make something that's been specialised a join point, for+  instance. But local bindings are rarely specialised, and being+  overly cautious about rules only costs us anything when, for some `j`:++  * Before specialisation, `j` has non-tail calls, so it can't be a join point.+  * During specialisation, `j` gets specialised and thus acquires rules.+  * Sometime afterward, the non-tail calls to `j` disappear (as dead code, say),+    and so now `j` *could* become a join point.++  This appears to be very rare in practice. TODO Perhaps we should gather+  statistics to be sure.++------------------------------------------------------------+Note [Adjusting right-hand sides]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There's a bit of a dance we need to do after analysing a lambda expression or+a right-hand side. In particular, we need to++  a) call 'markAllNonTail' *unless* the binding is for a join point, and+     the TailUsageDetails from the RHS has the right join arity; e.g.+        join j x y = case ... of+                       A -> j2 p+                       B -> j2 q+        in j a b+     Here we want the tail calls to j2 to be tail calls of the whole expression+  b) call 'markAllInsideLam' *unless* the binding is for a thunk, a one-shot+     lambda, or a non-recursive join point++Some examples, with how the free occurrences in e (assumed not to be a value+lambda) get marked:++                             inside lam    non-tail-called+  ------------------------------------------------------------+  let x = e                  No            Yes+  let f = \x -> e            Yes           Yes+  let f = \x{OneShot} -> e   No            Yes+  \x -> e                    Yes           Yes+  join j x = e               No            No+  joinrec j x = e            Yes           No++There are a few other caveats; most importantly, if we're marking a binding as+'AlwaysTailCalled', it's *going* to be a join point, so we treat it as one so+that the effect cascades properly. Consequently, at the time the RHS is+analysed, we won't know what adjustments to make; thus 'occAnalLamTail' must+return the unadjusted 'TailUsageDetails', to be adjusted by 'adjustTailUsage'+once join-point-hood has been decided and eventual one-shot annotations have+been added through 'markNonRecJoinOneShots'.++It is not so simple to see that 'occAnalNonRecBind' and 'occAnalRecBind' indeed+perform a similar sequence of steps. Thus, here is an interleaving of events+of both functions, serving as a specification:++  1. Call 'occAnalLamTail' to find usage information for the RHS.+     Recursive case:     'makeNode'+     Non-recursive case: 'occAnalNonRecBind'+  2. (Analyse the binding's scope. Done in 'occAnalBind'/`occAnal Let{}`.+      Same whether recursive or not.)+  3. Call 'tagNonRecBinder' or 'tagRecBinders', which decides whether to make+     the binding a join point.+     Cyclic  Recursive case:  'mkLoopBreakerNodes'+     Acyclic Recursive case:  `occAnalRec AcyclicSCC{}`+     Non-recursive case:      'occAnalNonRecBind'+  4. Non-recursive join point: Call 'markNonRecJoinOneShots' so that e.g.,+     FloatOut sees one-shot annotations on lambdas+     Acyclic Recursive case:  `occAnalRec AcyclicSCC{}`  calls 'adjustNonRecRhs'+     Non-recursive case:      'occAnalNonRecBind'        calls 'adjustNonRecRhs'+  5. Call 'adjustTailUsage' accordingly.+     Cyclic Recursive case:   'tagRecBinders'+     Acyclic Recursive case:  'adjustNonRecRhs'+     Non-recursive case:      'adjustNonRecRhs'+-}++------------------------------------------------------------------+--                 occAnalBind+------------------------------------------------------------------++occAnalBind+  :: OccEnv+  -> TopLevelFlag+  -> ImpRuleEdges+  -> CoreBind+  -> (OccEnv -> WithUsageDetails r)  -- Scope of the bind+  -> ([CoreBind] -> r -> r)          -- How to combine the scope with new binds+  -> WithUsageDetails r              -- Of the whole let(rec)++occAnalBind env lvl ire (Rec pairs) thing_inside combine+  = addInScopeList env (map fst pairs) $ \env ->+    let WUD body_uds body'  = thing_inside env+        WUD bind_uds binds' = occAnalRecBind env lvl ire pairs body_uds+    in WUD bind_uds (combine binds' body')++occAnalBind !env lvl ire (NonRec bndr rhs) thing_inside combine+  | isTyVar bndr      -- A type let; we don't gather usage info+  = let !(WUD body_uds res) = addInScopeOne env bndr thing_inside+    in WUD body_uds (combine [NonRec bndr rhs] res)++  -- /Existing/ non-recursive join points+  -- See Note [Occurrence analysis for join points]+  | mb_join@(JoinPoint {}) <- idJoinPointHood bndr+  = -- Analyse the RHS and /then/ the body+    let -- Analyse the rhs first, generating rhs_uds+        !(rhs_uds_s, bndr', rhs') = occAnalNonRecRhs env lvl ire mb_join bndr rhs+        rhs_uds = foldr1 orUDs rhs_uds_s   -- NB: orUDs.  See (W4) of+                                           -- Note [Occurrence analysis for join points]++        -- Now analyse the body, adding the join point+        -- into the environment with addJoinPoint+        !(WUD body_uds (occ, body)) = occAnalNonRecBody env bndr' $ \env ->+                                      thing_inside (addJoinPoint env bndr' rhs_uds)+    in+    if isDeadOcc occ     -- Drop dead code; see Note [Dead code]+    then WUD body_uds body+    else WUD (rhs_uds `orUDs` body_uds)    -- Note `orUDs`+             (combine [NonRec (fst (tagNonRecBinder lvl occ bndr')) rhs']+                      body)++  -- The normal case, including newly-discovered join points+  -- Analyse the body and /then/ the RHS+  | WUD body_uds (occ,body) <- occAnalNonRecBody env bndr thing_inside+  = if isDeadOcc occ   -- Drop dead code; see Note [Dead code]+    then WUD body_uds body+    else let+        -- Get the join info from the *new* decision; NB: bndr is not already a JoinId+        -- See Note [Join points and unfoldings/rules]+        -- => join arity O of Note [Join arity prediction based on joinRhsArity]+        (tagged_bndr, mb_join) = tagNonRecBinder lvl occ bndr++        !(rhs_uds_s, final_bndr, rhs') = occAnalNonRecRhs env lvl ire mb_join tagged_bndr rhs+    in WUD (foldr andUDs body_uds rhs_uds_s)      -- Note `andUDs`+           (combine [NonRec final_bndr rhs'] body)++-----------------+occAnalNonRecBody :: OccEnv -> Id+                  -> (OccEnv -> WithUsageDetails r)  -- Scope of the bind+                  -> (WithUsageDetails (OccInfo, r))+occAnalNonRecBody env bndr thing_inside+  = addInScopeOne env bndr $ \env ->+    let !(WUD inner_uds res) = thing_inside env+        !occ = lookupLetOccInfo inner_uds bndr+    in WUD inner_uds (occ, res)++-----------------+occAnalNonRecRhs :: OccEnv -> TopLevelFlag -> ImpRuleEdges+                -> JoinPointHood -> Id -> CoreExpr+                 -> (NonEmpty UsageDetails, Id, CoreExpr)+occAnalNonRecRhs !env lvl imp_rule_edges mb_join bndr rhs+  | null rules, null imp_rule_infos+  =  -- Fast path for common case of no rules. This is only worth+     -- 0.1% perf on average, but it's also only a line or two of code+    ( adj_rhs_uds :| adj_unf_uds : [], final_bndr_no_rules, final_rhs )+  | otherwise+  = ( adj_rhs_uds :| adj_unf_uds : adj_rule_uds, final_bndr_with_rules, final_rhs )+  where+    --------- Right hand side ---------+    -- For join points, set occ_encl to OccVanilla, via setTailCtxt.  If we have+    --    join j = Just (f x) in ...+    -- we do not want to float the (f x) to+    --    let y = f x in join j = Just y in ...+    -- That's that OccRhs would do; but there's no point because+    -- j will never be scrutinised.+    rhs_env  = mkRhsOccEnv env NonRecursive rhs_ctxt mb_join bndr rhs+    rhs_ctxt = mkNonRecRhsCtxt lvl bndr unf++    -- See Note [Join arity prediction based on joinRhsArity]+    -- Match join arity O from mb_join_arity with manifest join arity M as+    -- returned by of occAnalLamTail. It's totally OK for them to mismatch;+    -- hence adjust the UDs from the RHS+    WUD adj_rhs_uds final_rhs = adjustNonRecRhs mb_join $+                                occAnalLamTail rhs_env rhs+    final_bndr_with_rules+      | noBinderSwaps env = bndr -- See Note [Unfoldings and rules]+      | otherwise         = bndr `setIdSpecialisation` mkRuleInfo rules'+                                 `setIdUnfolding` unf1+    final_bndr_no_rules+      | noBinderSwaps env = bndr -- See Note [Unfoldings and rules]+      | otherwise         = bndr `setIdUnfolding` unf1++    --------- Unfolding ---------+    -- See Note [Join points and unfoldings/rules]+    unf = idUnfolding bndr+    WTUD unf_tuds unf1 = occAnalUnfolding rhs_env unf+    adj_unf_uds = adjustTailArity mb_join unf_tuds++    --------- Rules ---------+    -- See Note [Rules are extra RHSs] and Note [Rule dependency info]+    -- and Note [Join points and unfoldings/rules]+    rules        = idCoreRules bndr+    rules_w_uds  = map (occAnalRule rhs_env) rules+    rules'       = map fstOf3 rules_w_uds+    imp_rule_infos = lookupImpRules imp_rule_edges bndr+    imp_rule_uds   = [impRulesScopeUsage imp_rule_infos]+         -- imp_rule_uds: consider+         --     h = ...+         --     g = ...+         --     RULE map g = h+         -- Then we want to ensure that h is in scope everywhere+         -- that g is (since the RULE might turn g into h), so+         -- we make g mention h.++    adj_rule_uds :: [UsageDetails]+    adj_rule_uds = imp_rule_uds +++                   [ l `andUDs` adjustTailArity mb_join r+                   | (_,l,r) <- rules_w_uds ]++mkNonRecRhsCtxt :: TopLevelFlag -> Id -> Unfolding -> OccEncl+-- Precondition: Id is not a join point+mkNonRecRhsCtxt lvl bndr unf+  | certainly_inline = OccVanilla -- See Note [Cascading inlines]+  | otherwise        = OccRhs+  where+    certainly_inline -- See Note [Cascading inlines]+      = -- mkNonRecRhsCtxt is only used for non-join points, so occAnalBind+        -- has set the OccInfo for this binder before calling occAnalNonRecRhs+        case idOccInfo bndr of+          OneOcc { occ_in_lam = NotInsideLam, occ_n_br = 1 }+            -> active && not stable_unf && not top_bottoming+          _ -> False++    active     = isAlwaysActive (idInlineActivation bndr)+    stable_unf = isStableUnfolding unf+    top_bottoming = isTopLevel lvl && isDeadEndId bndr++-----------------+occAnalRecBind :: OccEnv -> TopLevelFlag -> ImpRuleEdges -> [(Var,CoreExpr)]+               -> UsageDetails -> WithUsageDetails [CoreBind]+-- For a recursive group, we+--      * occ-analyse all the RHSs+--      * compute strongly-connected components+--      * feed those components to occAnalRec+-- See Note [Recursive bindings: the grand plan]+occAnalRecBind !rhs_env lvl imp_rule_edges pairs body_usage+  = foldr (occAnalRec rhs_env lvl) (WUD body_usage []) sccs+  where+    sccs :: [SCC NodeDetails]+    sccs = stronglyConnCompFromEdgedVerticesUniq nodes++    nodes :: [LetrecNode]+    nodes = map (makeNode rhs_env imp_rule_edges bndr_set) pairs++    bndrs    = map fst pairs+    bndr_set = mkVarSet bndrs++-----------------------------+occAnalRec :: OccEnv -> TopLevelFlag+           -> SCC NodeDetails+           -> WithUsageDetails [CoreBind]+           -> WithUsageDetails [CoreBind]++-- The NonRec case is just like a Let (NonRec ...) above+occAnalRec !_ lvl+           (AcyclicSCC (ND { nd_bndr = bndr, nd_rhs = wtuds }))+           (WUD body_uds binds)+  | isDeadOcc occ  -- Check for dead code: see Note [Dead code]+  = WUD body_uds binds+  | otherwise+  = let (bndr', mb_join) = tagNonRecBinder lvl occ bndr+        !(WUD rhs_uds' rhs') = adjustNonRecRhs mb_join wtuds+    in WUD (body_uds `andUDs` rhs_uds')+           (NonRec bndr' rhs' : binds)+  where+    occ = lookupLetOccInfo body_uds bndr++-- The Rec case is the interesting one+-- See Note [Recursive bindings: the grand plan]+-- See Note [Loop breaking]+occAnalRec env lvl (CyclicSCC details_s) (WUD body_uds binds)+  | not (any needed details_s)+  = -- Check for dead code: see Note [Dead code]+    -- NB: Only look at body_uds, ignoring uses in the SCC+    WUD body_uds binds++  | otherwise+  = WUD final_uds (Rec pairs : binds)+  where+    all_simple = all nd_simple details_s++    needed :: NodeDetails -> Bool+    needed (ND { nd_bndr = bndr }) = isExportedId bndr || bndr `elemVarEnv` body_env+    body_env = ud_env body_uds++    ------------------------------+    -- Make the nodes for the loop-breaker analysis+    -- See Note [Choosing loop breakers] for loop_breaker_nodes+    final_uds :: UsageDetails+    loop_breaker_nodes :: [LoopBreakerNode]+    WUD final_uds loop_breaker_nodes = mkLoopBreakerNodes env lvl body_uds details_s++    ------------------------------+    weak_fvs :: VarSet+    weak_fvs = mapUnionVarSet nd_weak_fvs details_s++    ---------------------------+    -- Now reconstruct the cycle+    pairs :: [(Id,CoreExpr)]+    pairs | all_simple = reOrderNodes   0 weak_fvs loop_breaker_nodes []+          | otherwise  = loopBreakNodes 0 weak_fvs loop_breaker_nodes []+          -- In the common case when all are "simple" (no rules at all)+          -- the loop_breaker_nodes will include all the scope edges+          -- so a SCC computation would yield a single CyclicSCC result;+          -- and reOrderNodes deals with exactly that case.+          -- Saves a SCC analysis in a common case+++{- *********************************************************************+*                                                                      *+                Loop breaking+*                                                                      *+********************************************************************* -}++{- Note [Choosing loop breakers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In Step 4 in Note [Recursive bindings: the grand plan]), occAnalRec does+loop-breaking on each CyclicSCC of the original program:++* mkLoopBreakerNodes: Form the loop-breaker graph for that CyclicSCC++* loopBreakNodes: Do SCC analysis on it++* reOrderNodes: For each CyclicSCC, pick a loop breaker+    * Delete edges to that loop breaker+    * Do another SCC analysis on that reduced SCC+    * Repeat++To form the loop-breaker graph, we construct a new set of Nodes, the+"loop-breaker nodes", with the same details but different edges, the+"loop-breaker edges".  The loop-breaker nodes have both more and fewer+dependencies than the scope edges:++  More edges:+     If f calls g, and g has an active rule that mentions h then+     we add an edge from f -> h.  See Note [Rules and loop breakers].++  Fewer edges: we only include dependencies+     * only on /active/ rules,+     * on rule /RHSs/ (not LHSs)++The scope edges, by contrast, must be much more inclusive.++The nd_simple flag tracks the common case when a binding has no RULES+at all, in which case the loop-breaker edges will be identical to the+scope edges.++Note that in Example [eftInt], *neither* eftInt *nor* eftIntFB is+chosen as a loop breaker, because their RHSs don't mention each other.+And indeed both can be inlined safely.++Note [inl_fvs]+~~~~~~~~~~~~~~+Note that the loop-breaker graph includes edges for occurrences in+/both/ the RHS /and/ the stable unfolding.  Consider this, which actually+occurred when compiling BooleanFormula.hs in GHC:++  Rec { lvl1 = go+      ; lvl2[StableUnf = go] = lvl1+      ; go = ...go...lvl2... }++From the point of view of infinite inlining, we need only these edges:+   lvl1 :-> go+   lvl2 :-> go       -- The RHS lvl1 will never be used for inlining+   go   :-> go, lvl2++But the danger is that, lacking any edge to lvl1, we'll put it at the+end thus+  Rec { lvl2[ StableUnf = go] = lvl1+      ; go[LoopBreaker] = ...go...lvl2... }+      ; lvl1[Occ=Once]  = go }++And now the Simplifer will try to use PreInlineUnconditionally on lvl1+(which occurs just once), but because it is last we won't actually+substitute in lvl2.  Sigh.++To avoid this possibility, we include edges from lvl2 to /both/ its+stable unfolding /and/ its RHS.  Hence the defn of inl_fvs in+makeNode.  Maybe we could be more clever, but it's very much a corner+case.++Note [Weak loop breakers]+~~~~~~~~~~~~~~~~~~~~~~~~~+There is a last nasty wrinkle.  Suppose we have++    Rec { f = f_rhs+          RULE f [] = g++          h = h_rhs+          g = h+          ...more... }++Remember that we simplify the RULES before any RHS (see Note+[Rules are visible in their own rec group] above).++So we must *not* postInlineUnconditionally 'g', even though+its RHS turns out to be trivial.  (I'm assuming that 'g' is+not chosen as a loop breaker.)  Why not?  Because then we+drop the binding for 'g', which leaves it out of scope in the+RULE!++Here's a somewhat different example of the same thing+    Rec { q = r+        ; r = ...p...+        ; p = p_rhs+          RULE p [] = q }+Here the RULE is "below" q, but we *still* can't postInlineUnconditionally+q, because the RULE for p is active throughout.  So the RHS of r+might rewrite to     r = ...q...+So q must remain in scope in the output program!++We "solve" this by:++    Make q a "weak" loop breaker (OccInfo = IAmLoopBreaker True)+    iff q is a mentioned in the RHS of any RULE (active on not)+    in the Rec group++Note the "active or not" comment; even if a RULE is inactive, we+want its RHS free vars to stay alive (#20820)!++A normal "strong" loop breaker has IAmLoopBreaker False.  So:++                                Inline  postInlineUnconditionally+strong   IAmLoopBreaker False    no      no+weak     IAmLoopBreaker True     yes     no+         other                   yes     yes++The **sole** reason for this kind of loop breaker is so that+postInlineUnconditionally does not fire.  Ugh.++Annoyingly, since we simplify the rules *first* we'll never inline+q into p's RULE.  That trivial binding for q will hang around until+we discard the rule.  Yuk.  But it's rare.++Note [Rules and loop breakers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we form the loop-breaker graph (Step 4 in Note [Recursive+bindings: the grand plan]), we must be careful about RULEs.++For a start, we want a loop breaker to cut every cycle, so inactive+rules play no part; we need only consider /active/ rules.+See Note [Finding rule RHS free vars]++The second point is more subtle.  A RULE is like an equation for+'f' that is *always* inlined if it is applicable.  We do *not* disable+rules for loop-breakers.  It's up to whoever makes the rules to make+sure that the rules themselves always terminate.  See Note [Rules for+recursive functions] in GHC.Core.Opt.Simplify++Hence, if+    f's RHS (or its stable unfolding if it has one) mentions g, and+    g has a RULE that mentions h, and+    h has a RULE that mentions f++then we *must* choose f to be a loop breaker.  Example: see Note+[Specialisation rules]. So our plan is this:++   Take the free variables of f's RHS, and augment it with all the+   variables reachable by a transitive sequence RULES from those+   starting points.++That is the whole reason for computing rule_fv_env in mkLoopBreakerNodes.+Wrinkles:++* We only consider /active/ rules. See Note [Finding rule RHS free vars]++* We need only consider free vars that are also binders in this Rec+  group.  See also Note [Finding rule RHS free vars]++* We only consider variables free in the *RHS* of the rule, in+  contrast to the way we build the Rec group in the first place (Note+  [Rule dependency info])++* Why "transitive sequence of rules"?  Because active rules apply+  unconditionally, without checking loop-breaker-ness.+ See Note [Loop breaker dependencies].++Note [Finding rule RHS free vars]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this real example from Data Parallel Haskell+     tagZero :: Array Int -> Array Tag+     {-# INLINE [1] tagZeroes #-}+     tagZero xs = pmap (\x -> fromBool (x==0)) xs++     {-# RULES "tagZero" [~1] forall xs n.+         pmap fromBool <blah blah> = tagZero xs #-}+So tagZero's RHS mentions pmap, and pmap's RULE mentions tagZero.+However, tagZero can only be inlined in phase 1 and later, while+the RULE is only active *before* phase 1.  So there's no problem.++To make this work, we look for the RHS free vars only for+*active* rules. That's the reason for the occ_rule_act field+of the OccEnv.++Note [loopBreakNodes]+~~~~~~~~~~~~~~~~~~~~~+loopBreakNodes is applied to the list of nodes for a cyclic strongly+connected component (there's guaranteed to be a cycle).  It returns+the same nodes, but+        a) in a better order,+        b) with some of the Ids having a IAmALoopBreaker pragma++The "loop-breaker" Ids are sufficient to break all cycles in the SCC.  This means+that the simplifier can guarantee not to loop provided it never records an inlining+for these no-inline guys.++Furthermore, the order of the binds is such that if we neglect dependencies+on the no-inline Ids then the binds are topologically sorted.  This means+that the simplifier will generally do a good job if it works from top bottom,+recording inlinings for any Ids which aren't marked as "no-inline" as it goes.+-}++type Binding = (Id,CoreExpr)++-- See Note [loopBreakNodes]+loopBreakNodes :: Int+               -> VarSet        -- Binders whose dependencies may be "missing"+                                -- See Note [Weak loop breakers]+               -> [LoopBreakerNode]+               -> [Binding]             -- Append these to the end+               -> [Binding]++-- Return the bindings sorted into a plausible order, and marked with loop breakers.+-- See Note [loopBreakNodes]+loopBreakNodes depth weak_fvs nodes binds+  = -- pprTrace "loopBreakNodes" (ppr nodes) $+    go (stronglyConnCompFromEdgedVerticesUniqR nodes)+  where+    go []         = binds+    go (scc:sccs) = loop_break_scc scc (go sccs)++    loop_break_scc scc binds+      = case scc of+          AcyclicSCC node  -> nodeBinding (mk_non_loop_breaker weak_fvs) node : binds+          CyclicSCC nodes  -> reOrderNodes depth weak_fvs nodes binds++----------------------------------+reOrderNodes :: Int -> VarSet -> [LoopBreakerNode] -> [Binding] -> [Binding]+    -- Choose a loop breaker, mark it no-inline,+    -- and call loopBreakNodes on the rest+reOrderNodes _ _ []     _     = panic "reOrderNodes"+reOrderNodes _ _ [node] binds = nodeBinding mk_loop_breaker node : binds+reOrderNodes depth weak_fvs (node : nodes) binds+  = -- pprTrace "reOrderNodes" (vcat [ text "unchosen" <+> ppr unchosen+    --                               , text "chosen" <+> ppr chosen_nodes ]) $+    loopBreakNodes new_depth weak_fvs unchosen $+    (map (nodeBinding mk_loop_breaker) chosen_nodes ++ binds)+  where+    (chosen_nodes, unchosen) = chooseLoopBreaker approximate_lb+                                                 (snd_score (node_payload node))+                                                 [node] [] nodes++    approximate_lb = depth >= 2+    new_depth | approximate_lb = 0+              | otherwise      = depth+1+        -- After two iterations (d=0, d=1) give up+        -- and approximate, returning to d=0++nodeBinding :: (Id -> Id) -> LoopBreakerNode -> Binding+nodeBinding set_id_occ (node_payload -> SND { snd_bndr = bndr, snd_rhs = rhs})+  = (set_id_occ bndr, rhs)++mk_loop_breaker :: Id -> Id+mk_loop_breaker bndr+  = bndr `setIdOccInfo` occ'+  where+    occ'      = strongLoopBreaker { occ_tail = tail_info }+    tail_info = tailCallInfo (idOccInfo bndr)++mk_non_loop_breaker :: VarSet -> Id -> Id+-- See Note [Weak loop breakers]+mk_non_loop_breaker weak_fvs bndr+  | bndr `elemVarSet` weak_fvs = setIdOccInfo bndr occ'+  | otherwise                  = bndr+  where+    occ'      = weakLoopBreaker { occ_tail = tail_info }+    tail_info = tailCallInfo (idOccInfo bndr)++----------------------------------+chooseLoopBreaker :: Bool                -- True <=> Too many iterations,+                                         --          so approximate+                  -> NodeScore           -- Best score so far+                  -> [LoopBreakerNode]   -- Nodes with this score+                  -> [LoopBreakerNode]   -- Nodes with higher scores+                  -> [LoopBreakerNode]   -- Unprocessed nodes+                  -> ([LoopBreakerNode], [LoopBreakerNode])+    -- This loop looks for the bind with the lowest score+    -- to pick as the loop  breaker.  The rest accumulate in+chooseLoopBreaker _ _ loop_nodes acc []+  = (loop_nodes, acc)        -- Done++    -- If approximate_loop_breaker is True, we pick *all*+    -- nodes with lowest score, else just one+    -- See Note [Complexity of loop breaking]+chooseLoopBreaker approx_lb loop_sc loop_nodes acc (node : nodes)+  | approx_lb+  , rank sc == rank loop_sc+  = chooseLoopBreaker approx_lb loop_sc (node : loop_nodes) acc nodes++  | sc `betterLB` loop_sc  -- Better score so pick this new one+  = chooseLoopBreaker approx_lb sc [node] (loop_nodes ++ acc) nodes++  | otherwise              -- Worse score so don't pick it+  = chooseLoopBreaker approx_lb loop_sc loop_nodes (node : acc) nodes+  where+    sc = snd_score (node_payload node)++{-+Note [Complexity of loop breaking]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The loop-breaking algorithm knocks out one binder at a time, and+performs a new SCC analysis on the remaining binders.  That can+behave very badly in tightly-coupled groups of bindings; in the+worst case it can be (N**2)*log N, because it does a full SCC+on N, then N-1, then N-2 and so on.++To avoid this, we switch plans after 2 (or whatever) attempts:+  Plan A: pick one binder with the lowest score, make it+          a loop breaker, and try again+  Plan B: pick *all* binders with the lowest score, make them+          all loop breakers, and try again+Since there are only a small finite number of scores, this will+terminate in a constant number of iterations, rather than O(N)+iterations.++You might thing that it's very unlikely, but RULES make it much+more likely.  Here's a real example from #1969:+  Rec { $dm = \d.\x. op d+        {-# RULES forall d. $dm Int d  = $s$dm1+                  forall d. $dm Bool d = $s$dm2 #-}++        dInt = MkD .... opInt ...+        dInt = MkD .... opBool ...+        opInt  = $dm dInt+        opBool = $dm dBool++        $s$dm1 = \x. op dInt+        $s$dm2 = \x. op dBool }+The RULES stuff means that we can't choose $dm as a loop breaker+(Note [Choosing loop breakers]), so we must choose at least (say)+opInt *and* opBool, and so on.  The number of loop breakers is+linear in the number of instance declarations.++Note [Loop breakers and INLINE/INLINABLE pragmas]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Avoid choosing a function with an INLINE pramga as the loop breaker!+If such a function is mutually-recursive with a non-INLINE thing,+then the latter should be the loop-breaker.++It's vital to distinguish between INLINE and INLINABLE (the+Bool returned by hasStableCoreUnfolding_maybe).  If we start with+   Rec { {-# INLINABLE f #-}+         f x = ...f... }+and then worker/wrapper it through strictness analysis, we'll get+   Rec { {-# INLINABLE $wf #-}+         $wf p q = let x = (p,q) in ...f...++         {-# INLINE f #-}+         f x = case x of (p,q) -> $wf p q }++Now it is vital that we choose $wf as the loop breaker, so we can+inline 'f' in '$wf'.++Note [DFuns should not be loop breakers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It's particularly bad to make a DFun into a loop breaker.  See+Note [How instance declarations are translated] in GHC.Tc.TyCl.Instance++We give DFuns a higher score than ordinary CONLIKE things because+if there's a choice we want the DFun to be the non-loop breaker. Eg++rec { sc = /\ a \$dC. $fBWrap (T a) ($fCT @ a $dC)++      $fCT :: forall a_afE. (Roman.C a_afE) => Roman.C (Roman.T a_afE)+      {-# DFUN #-}+      $fCT = /\a \$dC. MkD (T a) ((sc @ a $dC) |> blah) ($ctoF @ a $dC)+    }++Here 'sc' (the superclass) looks CONLIKE, but we'll never get to it+if we can't unravel the DFun first.++Note [Constructor applications]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It's really really important to inline dictionaries.  Real+example (the Enum Ordering instance from GHC.Base):++     rec     f = \ x -> case d of (p,q,r) -> p x+             g = \ x -> case d of (p,q,r) -> q x+             d = (v, f, g)++Here, f and g occur just once; but we can't inline them into d.+On the other hand we *could* simplify those case expressions if+we didn't stupidly choose d as the loop breaker.+But we won't because constructor args are marked "Many".+Inlining dictionaries is really essential to unravelling+the loops in static numeric dictionaries, see GHC.Float.++Note [Closure conversion]+~~~~~~~~~~~~~~~~~~~~~~~~~+We treat (\x. C p q) as a high-score candidate in the letrec scoring algorithm.+The immediate motivation came from the result of a closure-conversion transformation+which generated code like this:++    data Clo a b = forall c. Clo (c -> a -> b) c++    ($:) :: Clo a b -> a -> b+    Clo f env $: x = f env x++    rec { plus = Clo plus1 ()++        ; plus1 _ n = Clo plus2 n++        ; plus2 Zero     n = n+        ; plus2 (Succ m) n = Succ (plus $: m $: n) }++If we inline 'plus' and 'plus1', everything unravels nicely.  But if+we choose 'plus1' as the loop breaker (which is entirely possible+otherwise), the loop does not unravel nicely.+++@occAnalUnfolding@ deals with the question of bindings where the Id is marked+by an INLINE pragma.  For these we record that anything which occurs+in its RHS occurs many times.  This pessimistically assumes that this+inlined binder also occurs many times in its scope, but if it doesn't+we'll catch it next time round.  At worst this costs an extra simplifier pass.+ToDo: try using the occurrence info for the inline'd binder.++[March 97] We do the same for atomic RHSs.  Reason: see notes with loopBreakSCC.+[June 98, SLPJ]  I've undone this change; I don't understand it.  See notes with loopBreakSCC.+++************************************************************************+*                                                                      *+                   Making nodes+*                                                                      *+************************************************************************+-}++-- | Digraph node as constructed by 'makeNode' and consumed by 'occAnalRec'.+-- The Unique key is gotten from the Id.+type LetrecNode = Node Unique NodeDetails++-- | Node details as consumed by 'occAnalRec'.+data NodeDetails+  = ND { nd_bndr :: Id          -- Binder++       , nd_rhs  :: !(WithTailUsageDetails CoreExpr)+         -- ^ RHS, already occ-analysed+         -- With TailUsageDetails from RHS, and RULES, and stable unfoldings,+         -- ignoring phase (ie assuming all are active).+         -- NB: Unadjusted TailUsageDetails, as if this Node becomes a+         -- non-recursive join point!+         -- See Note [TailUsageDetails when forming Rec groups]++       , nd_inl  :: IdSet       -- Free variables of the stable unfolding and the RHS+                                -- but excluding any RULES+                                -- This is the IdSet that may be used if the Id is inlined++       , nd_simple :: Bool      -- True iff this binding has no local RULES+                                -- If all nodes are simple we don't need a loop-breaker+                                -- dep-anal before reconstructing.++       , nd_weak_fvs :: IdSet    -- Variables bound in this Rec group that are free+                                 -- in the RHS of any rule (active or not) for this bndr+                                 -- See Note [Weak loop breakers]++       , nd_active_rule_fvs :: IdSet    -- Variables bound in this Rec group that are free+                                        -- in the RHS of an active rule for this bndr+                                        -- See Note [Rules and loop breakers]+  }++instance Outputable NodeDetails where+   ppr nd = text "ND" <> braces+             (sep [ text "bndr =" <+> ppr (nd_bndr nd)+                  , text "uds =" <+> ppr uds+                  , text "inl =" <+> ppr (nd_inl nd)+                  , text "simple =" <+> ppr (nd_simple nd)+                  , text "active_rule_fvs =" <+> ppr (nd_active_rule_fvs nd)+             ])+            where+               WTUD uds _ = nd_rhs nd++-- | Digraph with simplified and completely occurrence analysed+-- 'SimpleNodeDetails', retaining just the info we need for breaking loops.+type LoopBreakerNode = Node Unique SimpleNodeDetails++-- | Condensed variant of 'NodeDetails' needed during loop breaking.+data SimpleNodeDetails+  = SND { snd_bndr  :: IdWithOccInfo  -- OccInfo accurate+        , snd_rhs   :: CoreExpr       -- properly occur-analysed+        , snd_score :: NodeScore+        }++instance Outputable SimpleNodeDetails where+   ppr nd = text "SND" <> braces+             (sep [ text "bndr =" <+> ppr (snd_bndr nd)+                  , text "score =" <+> ppr (snd_score nd)+             ])++-- The NodeScore is compared lexicographically;+--      e.g. lower rank wins regardless of size+type NodeScore = ( Int     -- Rank: lower => more likely to be picked as loop breaker+                 , Int     -- Size of rhs: higher => more likely to be picked as LB+                           -- Maxes out at maxExprSize; we just use it to prioritise+                           -- small functions+                 , Bool )  -- Was it a loop breaker before?+                           -- True => more likely to be picked+                           -- Note [Loop breakers, node scoring, and stability]++rank :: NodeScore -> Int+rank (r, _, _) = r++makeNode :: OccEnv -> ImpRuleEdges -> VarSet+         -> (Var, CoreExpr) -> LetrecNode+-- See Note [Recursive bindings: the grand plan]+makeNode !env imp_rule_edges bndr_set (bndr, rhs)+  = -- pprTrace "makeNode" (ppr bndr <+> ppr (sizeVarSet bndr_set)) $+    DigraphNode { node_payload      = details+                , node_key          = varUnique bndr+                , node_dependencies = nonDetKeysUniqSet scope_fvs }+    -- It's OK to use nonDetKeysUniqSet here as stronglyConnCompFromEdgedVerticesR+    -- is still deterministic with edges in nondeterministic order as+    -- explained in Note [Deterministic SCC] in GHC.Data.Graph.Directed.+  where+    details = ND { nd_bndr            = bndr'+                 , nd_rhs             = WTUD (TUD rhs_ja unadj_scope_uds) rhs'+                 , nd_inl             = inl_fvs+                 , nd_simple          = null rules_w_uds && null imp_rule_info+                 , nd_weak_fvs        = weak_fvs+                 , nd_active_rule_fvs = active_rule_fvs }++    bndr' | noBinderSwaps env = bndr  -- See Note [Unfoldings and rules]+          | otherwise         = bndr `setIdUnfolding`      unf'+                                     `setIdSpecialisation` mkRuleInfo rules'++    -- NB: Both adj_unf_uds and adj_rule_uds have been adjusted to match the+    --     JoinArity rhs_ja of unadj_rhs_uds.+    unadj_inl_uds   = unadj_rhs_uds `andUDs` adj_unf_uds+    unadj_scope_uds = unadj_inl_uds `andUDs` adj_rule_uds+                   -- Note [Rules are extra RHSs]+                   -- Note [Rule dependency info]+    scope_fvs = udFreeVars bndr_set unadj_scope_uds+    -- scope_fvs: all occurrences from this binder: RHS, unfolding,+    --            and RULES, both LHS and RHS thereof, active or inactive++    inl_fvs  = udFreeVars bndr_set unadj_inl_uds+    -- inl_fvs: vars that would become free if the function was inlined.+    -- We conservatively approximate that by the free vars from the RHS+    -- and the unfolding together.+    -- See Note [inl_fvs]+++    --------- Right hand side ---------+    -- Constructing the edges for the main Rec computation+    -- See Note [Forming Rec groups]+    -- and Note [TailUsageDetails when forming Rec groups]+    -- Compared to occAnalNonRecBind, we can't yet adjust the RHS because+    --   (a) we don't yet know the final joinpointhood. It might not become a+    --       join point after all!+    --   (b) we don't even know whether it stays a recursive RHS after the SCC+    --       analysis we are about to seed! So we can't markAllInsideLam in+    --       advance, because if it ends up as a non-recursive join point we'll+    --       consider it as one-shot and don't need to markAllInsideLam.+    -- Instead, do the occAnalLamTail call here and postpone adjustTailUsage+    -- until occAnalRec. In effect, we pretend that the RHS becomes a+    -- non-recursive join point and fix up later with adjustTailUsage.+    rhs_env = mkRhsOccEnv env Recursive OccRhs (idJoinPointHood bndr) bndr rhs+            -- If bndr isn't an /existing/ join point (so idJoinPointHood = NotJoinPoint),+            -- it's safe to zap the occ_join_points, because they can't occur in RHS.+    WTUD (TUD rhs_ja unadj_rhs_uds) rhs' = occAnalLamTail rhs_env rhs+      -- The corresponding call to adjustTailUsage is in occAnalRec and tagRecBinders++    --------- Unfolding ---------+    -- See Note [Join points and unfoldings/rules]+    unf = realIdUnfolding bndr -- realIdUnfolding: Ignore loop-breaker-ness+                               -- here because that is what we are setting!+    WTUD unf_tuds unf' = occAnalUnfolding rhs_env unf+    adj_unf_uds = adjustTailArity (JoinPoint rhs_ja) unf_tuds+      -- `rhs_ja` is `joinRhsArity rhs` and is the prediction for source M+      -- of Note [Join arity prediction based on joinRhsArity]++    --------- IMP-RULES --------+    is_active     = occ_rule_act env :: Activation -> Bool+    imp_rule_info = lookupImpRules imp_rule_edges bndr+    imp_rule_uds  = impRulesScopeUsage imp_rule_info+    imp_rule_fvs  = impRulesActiveFvs is_active bndr_set imp_rule_info++    --------- All rules --------+    -- See Note [Join points and unfoldings/rules]+    -- `rhs_ja` is `joinRhsArity rhs'` and is the prediction for source M+    -- of Note [Join arity prediction based on joinRhsArity]+    rules_w_uds :: [(CoreRule, UsageDetails, UsageDetails)]+    rules_w_uds = [ (r,l,adjustTailArity (JoinPoint rhs_ja) rhs_wuds)+                  | rule <- idCoreRules bndr+                  , let (r,l,rhs_wuds) = occAnalRule rhs_env rule ]+    rules'      = map fstOf3 rules_w_uds++    adj_rule_uds = foldr add_rule_uds imp_rule_uds rules_w_uds+    add_rule_uds (_, l, r) uds = l `andUDs` r `andUDs` uds++    -------- active_rule_fvs ------------+    active_rule_fvs = foldr add_active_rule imp_rule_fvs rules_w_uds+    add_active_rule (rule, _, rhs_uds) fvs+      | is_active (ruleActivation rule)+      = udFreeVars bndr_set rhs_uds `unionVarSet` fvs+      | otherwise+      = fvs++    -------- weak_fvs ------------+    -- See Note [Weak loop breakers]+    weak_fvs = foldr add_rule emptyVarSet rules_w_uds+    add_rule (_, _, rhs_uds) fvs = udFreeVars bndr_set rhs_uds `unionVarSet` fvs++mkLoopBreakerNodes :: OccEnv -> TopLevelFlag+                   -> UsageDetails   -- for BODY of let+                   -> [NodeDetails]+                   -> WithUsageDetails [LoopBreakerNode] -- with OccInfo up-to-date+-- See Note [Choosing loop breakers]+-- This function primarily creates the Nodes for the+-- loop-breaker SCC analysis.  More specifically:+--   a) tag each binder with its occurrence info+--   b) add a NodeScore to each node+--   c) make a Node with the right dependency edges for+--      the loop-breaker SCC analysis+--   d) adjust each RHS's usage details according to+--      the binder's (new) shotness and join-point-hood+mkLoopBreakerNodes !env lvl body_uds details_s+  = WUD final_uds (zipWithEqual mk_lb_node details_s bndrs')+  where+    WUD final_uds bndrs' = tagRecBinders lvl body_uds details_s++    mk_lb_node nd@(ND { nd_bndr = old_bndr, nd_inl = inl_fvs+                      , nd_rhs = WTUD _ rhs }) new_bndr+      = DigraphNode { node_payload      = simple_nd+                    , node_key          = varUnique old_bndr+                    , node_dependencies = nonDetKeysUniqSet lb_deps }+              -- It's OK to use nonDetKeysUniqSet here as+              -- stronglyConnCompFromEdgedVerticesR is still deterministic with edges+              -- in nondeterministic order as explained in+              -- Note [Deterministic SCC] in GHC.Data.Graph.Directed.+      where+        simple_nd = SND { snd_bndr = new_bndr, snd_rhs = rhs, snd_score = score }+        score  = nodeScore env new_bndr lb_deps nd+        lb_deps = extendFvs_ rule_fv_env inl_fvs+        -- See Note [Loop breaker dependencies]++    rule_fv_env :: IdEnv IdSet+    -- Maps a variable f to the variables from this group+    --      reachable by a sequence of RULES starting with f+    -- Domain is *subset* of bound vars (others have no rule fvs)+    -- See Note [Finding rule RHS free vars]+    -- Why transClosureFV?  See Note [Loop breaker dependencies]+    rule_fv_env = transClosureFV $ mkVarEnv $+                  [ (b, rule_fvs)+                  | ND { nd_bndr = b, nd_active_rule_fvs = rule_fvs } <- details_s+                  , not (isEmptyVarSet rule_fvs) ]++{- Note [Loop breaker dependencies]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The loop breaker dependencies of x in a recursive+group { f1 = e1; ...; fn = en } are:++- The "inline free variables" of f: the fi free in+  f's stable unfolding and RHS; see Note [inl_fvs]++- Any fi reachable from those inline free variables by a sequence+  of RULE rewrites.  Remember, rule rewriting is not affected+  by fi being a loop breaker, so we have to take the transitive+  closure in case f is the only possible loop breaker in the loop.++  Hence rule_fv_env.  We need only account for /active/ rules.+-}++------------------------------------------+nodeScore :: OccEnv+          -> Id        -- Binder with new occ-info+          -> VarSet    -- Loop-breaker dependencies+          -> NodeDetails+          -> NodeScore+nodeScore !env new_bndr lb_deps+          (ND { nd_bndr = old_bndr, nd_rhs = WTUD _ bind_rhs })++  | not (isId old_bndr)     -- A type or coercion variable is never a loop breaker+  = (100, 0, False)++  | old_bndr `elemVarSet` lb_deps  -- Self-recursive things are great loop breakers+  = (0, 0, True)                   -- See Note [Self-recursion and loop breakers]++  | not (occ_unf_act env old_bndr) -- A binder whose inlining is inactive (e.g. has+  = (0, 0, True)                   -- a NOINLINE pragma) makes a great loop breaker++  | exprIsTrivial rhs+  = mk_score 10  -- Practically certain to be inlined+    -- Used to have also: && not (isExportedId bndr)+    -- But I found this sometimes cost an extra iteration when we have+    --      rec { d = (a,b); a = ...df...; b = ...df...; df = d }+    -- where df is the exported dictionary. Then df makes a really+    -- bad choice for loop breaker++  | DFunUnfolding { df_args = args } <- old_unf+    -- Never choose a DFun as a loop breaker+    -- Note [DFuns should not be loop breakers]+  = (9, length args, is_lb)++    -- Data structures are more important than INLINE pragmas+    -- so that dictionary/method recursion unravels++  | CoreUnfolding { uf_guidance = UnfWhen {} } <- old_unf+  = mk_score 6++  | is_con_app rhs   -- Data types help with cases:+  = mk_score 5       -- Note [Constructor applications]++  | isStableUnfolding old_unf+  , can_unfold+  = mk_score 3++  | isOneOcc (idOccInfo new_bndr)+  = mk_score 2  -- Likely to be inlined++  | can_unfold  -- The Id has some kind of unfolding+  = mk_score 1++  | otherwise+  = (0, 0, is_lb)++  where+    mk_score :: Int -> NodeScore+    mk_score rank = (rank, rhs_size, is_lb)++    -- is_lb: see Note [Loop breakers, node scoring, and stability]+    is_lb = isStrongLoopBreaker (idOccInfo old_bndr)++    old_unf = realIdUnfolding old_bndr+    can_unfold = canUnfold old_unf+    rhs        = case old_unf of+                   CoreUnfolding { uf_src = src, uf_tmpl = unf_rhs }+                     | isStableSource src+                     -> unf_rhs+                   _ -> bind_rhs+       -- 'bind_rhs' is irrelevant for inlining things with a stable unfolding+    rhs_size = case old_unf of+                 CoreUnfolding { uf_guidance = guidance }+                    | UnfIfGoodArgs { ug_size = size } <- guidance+                    -> size+                 _  -> cheapExprSize rhs+++        -- Checking for a constructor application+        -- Cheap and cheerful; the simplifier moves casts out of the way+        -- The lambda case is important to spot x = /\a. C (f a)+        -- which comes up when C is a dictionary constructor and+        -- f is a default method.+        -- Example: the instance for Show (ST s a) in GHC.ST+        --+        -- However we *also* treat (\x. C p q) as a con-app-like thing,+        --      Note [Closure conversion]+    is_con_app (Var v)    = isConLikeId v+    is_con_app (App f _)  = is_con_app f+    is_con_app (Lam _ e)  = is_con_app e+    is_con_app (Tick _ e) = is_con_app e+    is_con_app (Let _ e)  = is_con_app e  -- let x = let y = blah in (a,b)+    is_con_app _          = False         -- We will float the y out, so treat+                                          -- the x-binding as a con-app (#20941)++maxExprSize :: Int+maxExprSize = 20  -- Rather arbitrary++cheapExprSize :: CoreExpr -> Int+-- Maxes out at maxExprSize+cheapExprSize e+  = go 0 e+  where+    go n e | n >= maxExprSize = n+           | otherwise        = go1 n e++    go1 n (Var {})        = n+1+    go1 n (Lit {})        = n+1+    go1 n (Type {})       = n+    go1 n (Coercion {})   = n+    go1 n (Tick _ e)      = go1 n e+    go1 n (Cast e _)      = go1 n e+    go1 n (App f a)       = go (go1 n f) a+    go1 n (Lam b e)+      | isTyVar b         = go1 n e+      | otherwise         = go (n+1) e+    go1 n (Let b e)       = gos (go1 n e) (rhssOfBind b)+    go1 n (Case e _ _ as) = gos (go1 n e) (rhssOfAlts as)++    gos n [] = n+    gos n (e:es) | n >= maxExprSize = n+                 | otherwise        = gos (go1 n e) es++betterLB :: NodeScore -> NodeScore -> Bool+-- If  n1 `betterLB` n2  then choose n1 as the loop breaker+betterLB (rank1, size1, lb1) (rank2, size2, _)+  | rank1 < rank2 = True+  | rank1 > rank2 = False+  | size1 < size2 = False   -- Make the bigger n2 into the loop breaker+  | size1 > size2 = True+  | lb1           = True    -- Tie-break: if n1 was a loop breaker before, choose it+  | otherwise     = False   -- See Note [Loop breakers, node scoring, and stability]++{- Note [Self-recursion and loop breakers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we have+   rec { f = ...f...g...+       ; g = .....f...   }+then 'f' has to be a loop breaker anyway, so we may as well choose it+right away, so that g can inline freely.++This is really just a cheap hack. Consider+   rec { f = ...g...+       ; g = ..f..h...+      ;  h = ...f....}+Here f or g are better loop breakers than h; but we might accidentally+choose h.  Finding the minimal set of loop breakers is hard.++Note [Loop breakers, node scoring, and stability]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+To choose a loop breaker, we give a NodeScore to each node in the SCC,+and pick the one with the best score (according to 'betterLB').++We need to be jolly careful (#12425, #12234) about the stability+of this choice. Suppose we have++    let rec { f = ...g...g...+            ; g = ...f...f... }+    in+    case x of+      True  -> ...f..+      False -> ..f...++In each iteration of the simplifier the occurrence analyser OccAnal+chooses a loop breaker. Suppose in iteration 1 it choose g as the loop+breaker. That means it is free to inline f.++Suppose that GHC decides to inline f in the branches of the case, but+(for some reason; eg it is not saturated) in the rhs of g. So we get++    let rec { f = ...g...g...+            ; g = ...f...f... }+    in+    case x of+      True  -> ...g...g.....+      False -> ..g..g....++Now suppose that, for some reason, in the next iteration the occurrence+analyser chooses f as the loop breaker, so it can freely inline g. And+again for some reason the simplifier inlines g at its calls in the case+branches, but not in the RHS of f. Then we get++    let rec { f = ...g...g...+            ; g = ...f...f... }+    in+    case x of+      True  -> ...(...f...f...)...(...f..f..).....+      False -> ..(...f...f...)...(..f..f...)....++You can see where this is going! Each iteration of the simplifier+doubles the number of calls to f or g. No wonder GHC is slow!++(In the particular example in comment:3 of #12425, f and g are the two+mutually recursive fmap instances for CondT and Result. They are both+marked INLINE which, oddly, is why they don't inline in each other's+RHS, because the call there is not saturated.)++The root cause is that we flip-flop on our choice of loop breaker. I+always thought it didn't matter, and indeed for any single iteration+to terminate, it doesn't matter. But when we iterate, it matters a+lot!!++So The Plan is this:+   If there is a tie, choose the node that+   was a loop breaker last time round++Hence the is_lb field of NodeScore+-}++{- *********************************************************************+*                                                                      *+                  Lambda groups+*                                                                      *+********************************************************************* -}++{- Note [Occurrence analysis for lambda binders]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For value lambdas we do a special hack.  Consider+     (\x. \y. ...x...)+If we did nothing, x is used inside the \y, so would be marked+as dangerous to dup.  But in the common case where the abstraction+is applied to two arguments this is over-pessimistic, which delays+inlining x, which forces more simplifier iterations.++So the occurrence analyser collaborates with the simplifier to treat+a /lambda-group/ specially.   A lambda-group is a contiguous run of+lambda and casts, e.g.+    Lam x (Lam y (Cast (Lam z body) co))++* Occurrence analyser: we just mark each binder in the lambda-group+  (here: x,y,z) with its occurrence info in the *body* of the+  lambda-group.  See occAnalLamTail.++* Simplifier.  The simplifier is careful when partially applying+  lambda-groups. See the call to zapLambdaBndrs in+     GHC.Core.Opt.Simplify.simplExprF1+     GHC.Core.SimpleOpt.simple_app++* Why do we take care to account for intervening casts? Answer:+  currently we don't do eta-expansion and cast-swizzling in a stable+  unfolding (see Historical-note [Eta-expansion in stable unfoldings]).+  So we can get+    f = \x. ((\y. ...x...y...) |> co)+  Now, since the lambdas aren't together, the occurrence analyser will+  say that x is OnceInLam.  Now if we have a call+    (f e1 |> co) e2+  we'll end up with+    let x = e1 in ...x..e2...+  and it'll take an extra iteration of the Simplifier to substitute for x.++A thought: a lambda-group is pretty much what GHC.Core.Opt.Arity.manifestArity+recognises except that the latter looks through (some) ticks.  Maybe a lambda+group should also look through (some) ticks?+-}++isOneShotFun :: CoreExpr -> Bool+-- The top level lambdas, ignoring casts, of the expression+-- are all one-shot.  If there aren't any lambdas at all, this is True+isOneShotFun (Lam b e)  = isOneShotBndr b && isOneShotFun e+isOneShotFun (Cast e _) = isOneShotFun e+isOneShotFun _          = True++zapLambdaBndrs :: CoreExpr -> FullArgCount -> CoreExpr+-- If (\xyz. t) appears under-applied to only two arguments,+-- we must zap the occ-info on x,y, because they appear under the \z+-- See Note [Occurrence analysis for lambda binders] in GHc.Core.Opt.OccurAnal+--+-- NB: `arg_count` includes both type and value args+zapLambdaBndrs fun arg_count+  = -- If the lambda is fully applied, leave it alone; if not+    -- zap the OccInfo on the lambdas that do have arguments,+    -- so they beta-reduce to use-many Lets rather than used-once ones.+    zap arg_count fun `orElse` fun+  where+    zap :: FullArgCount -> CoreExpr -> Maybe CoreExpr+    -- Nothing => No need to change the occ-info+    -- Just e  => Had to change+    zap 0 e | isOneShotFun e = Nothing  -- All remaining lambdas are one-shot+            | otherwise      = Just e   -- in which case no need to zap+    zap n (Cast e co) = do { e' <- zap n e; return (Cast e' co) }+    zap n (Lam b e)   = do { e' <- zap (n-1) e+                           ; return (Lam (zap_bndr b) e') }+    zap _ _           = Nothing  -- More arguments than lambdas++    zap_bndr b | isTyVar b = b+               | otherwise = zapLamIdInfo b++occAnalLamTail :: OccEnv -> CoreExpr -> WithTailUsageDetails CoreExpr+-- ^ See Note [Occurrence analysis for lambda binders].+-- It does the following:+--   * Sets one-shot info on the lambda binder from the OccEnv, and+--     removes that one-shot info from the OccEnv+--   * Sets the OccEnv to OccVanilla when going under a value lambda+--   * Tags each lambda with its occurrence information+--   * Walks through casts+--   * Package up the analysed lambda with its manifest join arity+--+-- This function does /not/ do+--   markAllInsideLam or+--   markAllNonTail+-- The caller does that, via adjustTailUsage (mostly calls go through+-- adjustNonRecRhs). Every call to occAnalLamTail must ultimately call+-- adjustTailUsage to discharge the assumed join arity.+--+-- In effect, the analysis result is for a non-recursive join point with+-- manifest arity and adjustTailUsage does the fixup.+-- See Note [Adjusting right-hand sides]+occAnalLamTail env expr+  = let !(WUD usage expr') = occ_anal_lam_tail env expr+    in WTUD (TUD (joinRhsArity expr) usage) expr'++occ_anal_lam_tail :: OccEnv -> CoreExpr -> WithUsageDetails CoreExpr+-- Does not markInsideLam etc for the outmost batch of lambdas+occ_anal_lam_tail env expr@(Lam {})+  = go env [] expr+  where+    go :: OccEnv -> [Var] -> CoreExpr -> WithUsageDetails CoreExpr+    go env rev_bndrs (Lam bndr body)+      | isTyVar bndr+      = go env (bndr:rev_bndrs) body+              -- Important: Unlike a value binder, do not modify occ_encl+              -- to OccVanilla, so that with a RHS like+              --   \(@ x) -> K @x (f @x)+              -- we'll see that (K @x (f @x)) is in a OccRhs, and hence refrain+              -- from inlining f. See the beginning of Note [Cascading inlines].++      | otherwise+      = let (env_one_shots', bndr')+              = case occ_one_shots env of+                  []         -> ([],  bndr)+                  (os : oss) -> (oss, updOneShotInfo bndr os)+                  -- Use updOneShotInfo, not setOneShotInfo, as pre-existing+                  -- one-shot info might be better than what we can infer, e.g.+                  -- due to explicit use of the magic 'oneShot' function.+                  -- See Note [oneShot magic]+            env' = env { occ_encl = OccVanilla, occ_one_shots = env_one_shots' }+         in go env' (bndr':rev_bndrs) body++    go env rev_bndrs body+      = addInScope env rev_bndrs $ \env ->+        let !(WUD usage body') = occ_anal_lam_tail env body+            wrap_lam body bndr = Lam (tagLamBinder usage bndr) body+        in WUD (usage `addLamCoVarOccs` rev_bndrs)+               (foldl' wrap_lam body' rev_bndrs)++-- For casts, keep going in the same lambda-group+-- See Note [Occurrence analysis for lambda binders]+occ_anal_lam_tail env (Cast expr co)+  = let  WUD usage expr' = occ_anal_lam_tail env expr+         -- usage1: see Note [Gather occurrences of coercion variables]+         usage1 = addManyOccs usage (coVarsOfCo co)++         -- usage2: see Note [Occ-anal and cast worker/wrapper]+         usage2 = case expr of+                    Var {} | isRhsEnv env -> markAllMany usage1+                    _ -> usage1++         -- usage3: you might think this was not necessary, because of+         -- the markAllNonTail in adjustTailUsage; but not so!  For a+         -- join point, adjustTailUsage doesn't do this; yet if there is+         -- a cast, we must!  Also: why markAllNonTail?  See+         -- GHC.Core.Lint: Note Note [Join points and casts]+         usage3 = markAllNonTail usage2++    in WUD usage3 (Cast expr' co)++occ_anal_lam_tail env expr  -- Not Lam, not Cast+  = occAnal env expr++{- Note [Occ-anal and cast worker/wrapper]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider   y = e; x = y |> co+If we mark y as used-once, we'll inline y into x, and the Cast+worker/wrapper transform will float it straight back out again.  See+Note [Cast worker/wrapper] in GHC.Core.Opt.Simplify.++So in this particular case we want to mark 'y' as Many.  It's very+ad-hoc, but it's also simple.  It's also what would happen if we gave+the binding for x a stable unfolding (as we usually do for wrappers, thus+      y = e+      {-# INLINE x #-}+      x = y |> co+Now y appears twice -- once in x's stable unfolding, and once in x's+RHS. So it'll get a Many occ-info.  (Maybe Cast w/w should create a stable+unfolding, which would obviate this Note; but that seems a bit of a+heavyweight solution.)++We only need to this in occAnalLamTail, not occAnal, because the top leve+of a right hand side is handled by occAnalLamTail.+-}+++{- *********************************************************************+*                                                                      *+                   Right hand sides+*                                                                      *+********************************************************************* -}++occAnalUnfolding :: OccEnv+                 -> Unfolding+                 -> WithTailUsageDetails Unfolding+-- Occurrence-analyse a stable unfolding;+-- discard a non-stable one altogether and return empty usage details.+occAnalUnfolding !env unf+  = case unf of+      unf@(CoreUnfolding { uf_tmpl = rhs, uf_src = src })+        | isStableSource src ->+            let+              WTUD (TUD rhs_ja uds) rhs' = occAnalLamTail env rhs+              unf' = unf { uf_tmpl = rhs' }+            in WTUD (TUD rhs_ja (markAllMany uds)) unf'+              -- markAllMany: see Note [Occurrences in stable unfoldings]++        | otherwise -> WTUD (TUD 0 emptyDetails) unf+              -- For non-Stable unfoldings we leave them undisturbed, but+              -- don't count their usage because the simplifier will discard them.+              -- We leave them undisturbed because nodeScore uses their size info+              -- to guide its decisions.  It's ok to leave un-substituted+              -- expressions in the tree because all the variables that were in+              -- scope remain in scope; there is no cloning etc.++      unf@(DFunUnfolding { df_bndrs = bndrs, df_args = args })+        -> let WUD uds args' = addInScopeList env bndrs $ \ env ->+                               occAnalList env args+           in WTUD (TUD 0 uds) (unf { df_args = args' })+              -- No need to use tagLamBinders because we+              -- never inline DFuns so the occ-info on binders doesn't matter++      unf -> WTUD (TUD 0 emptyDetails) unf++occAnalRule :: OccEnv+             -> CoreRule+             -> (CoreRule,         -- Each (non-built-in) rule+                 UsageDetails,     -- Usage details for LHS+                 TailUsageDetails) -- Usage details for RHS+occAnalRule env rule@(Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs })+  = (rule', lhs_uds', TUD rhs_ja rhs_uds')+  where+    rule' = rule { ru_args = args', ru_rhs = rhs' }++    WUD lhs_uds args' = addInScopeList env bndrs $ \env ->+                        occAnalList env args++    lhs_uds' = markAllManyNonTail lhs_uds+    WUD rhs_uds rhs' = addInScopeList env bndrs $ \env ->+                       occAnal env rhs+                          -- Note [Rules are extra RHSs]+                          -- Note [Rule dependency info]+    rhs_uds' = markAllMany rhs_uds+    rhs_ja = length args -- See Note [Join points and unfoldings/rules]++occAnalRule _ other_rule = (other_rule, emptyDetails, TUD 0 emptyDetails)++{- Note [Occurrences in stable unfoldings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+    f p = BIG+    {-# INLINE g #-}+    g y = not (f y)+where this is the /only/ occurrence of 'f'.  So 'g' will get a stable+unfolding.  Now suppose that g's RHS gets optimised (perhaps by a rule+or inlining f) so that it doesn't mention 'f' any more.  Now the last+remaining call to f is in g's Stable unfolding. But, even though there+is only one syntactic occurrence of f, we do /not/ want to do+preinlineUnconditionally here!++The INLINE pragma says "inline exactly this RHS"; perhaps the+programmer wants to expose that 'not', say. If we inline f that will make+the Stable unfoldign big, and that wasn't what the programmer wanted.++Another way to think about it: if we inlined g as-is into multiple+call sites, now there's be multiple calls to f.++Bottom line: treat all occurrences in a stable unfolding as "Many".+We still leave tail call information intact, though, as to not spoil+potential join points.++Note [Unfoldings and rules]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Generally unfoldings and rules are already occurrence-analysed, so we+don't want to reconstruct their trees; we just want to analyse them to+find how they use their free variables.++EXCEPT if there is a binder-swap going on, in which case we do want to+produce a new tree.++So we have a fast-path that keeps the old tree if the occ_bs_env is+empty.   This just saves a bit of allocation and reconstruction; not+a big deal.++Two tricky corners:++* Dead bindings (#22761). Supose we have+    Unfolding = \x. let y = foo in x+1+  which includes a dead binding for `y`. In occAnalUnfolding we occ-anal+  the unfolding and produce /no/ occurrences of `foo` (since `y` is+  dead).  But if we discard the occ-analysed syntax tree (which we do on+  our fast path), and use the old one, we still /have/ an occurrence of+  `foo` -- and that can lead to out-of-scope variables (#22761).++  Solution: always keep occ-analysed trees in unfoldings and rules, so they+  have no dead code.  See Note [OccInfo in unfoldings and rules] in GHC.Core.++* One-shot binders. Consider+     {- f has Stable unfolding \p q -> blah+        Demand on f is LC(L,C(1,!P(L)); that is, one-shot in its second ar -}+     f = \x y. blah++   Now we `mkRhsOccEnv` will build an OccEnv for f's RHS that has+          occ_one_shots = [NoOneShortInfo, OneShotLam]+   This will put OneShotLam on the \y.  And it'll put it on the \q.  But the+   noBinderSwap check will mean that we discard this new occ-anal'd unfolding+   and keep the old one, with no OneShotInfo.++   This looks a little inconsistent, but the Stable unfolding is just used for+   inlinings; OneShotInfo isn't a lot of use here.++Note [Cascading inlines]+~~~~~~~~~~~~~~~~~~~~~~~~+By default we use an OccRhs for the RHS of a binding.  This tells the+occ anal n that it's looking at an RHS, which has an effect in+occAnalApp.  In particular, for constructor applications, it makes+the arguments appear to have NoOccInfo, so that we don't inline into+them. Thus    x = f y+              k = Just x+we do not want to inline x.++But there's a problem.  Consider+     x1 = a0 : []+     x2 = a1 : x1+     x3 = a2 : x2+     g  = f x3+First time round, it looks as if x1 and x2 occur as an arg of a+let-bound constructor ==> give them a many-occurrence.+But then x3 is inlined (unconditionally as it happens) and+next time round, x2 will be, and the next time round x1 will be+Result: multiple simplifier iterations.  Sigh.++So, when analysing the RHS of x3 we notice that x3 will itself+definitely inline the next time round, and so we analyse x3's rhs in+an OccVanilla context, not OccRhs.  Hence the "certainly_inline" stuff.++Annoyingly, we have to approximate GHC.Core.Opt.Simplify.Utils.preInlineUnconditionally.+If (a) the RHS is expandable (see isExpandableApp in occAnalApp), and+   (b) certainly_inline says "yes" when preInlineUnconditionally says "no"+then the simplifier iterates indefinitely:+        x = f y+        k = Just x   -- We decide that k is 'certainly_inline'+        v = ...k...  -- but preInlineUnconditionally doesn't inline it+inline ==>+        k = Just (f y)+        v = ...k...+float ==>+        x1 = f y+        k = Just x1+        v = ...k...++This is worse than the slow cascade, so we only want to say "certainly_inline"+if it really is certain.  Look at the note with preInlineUnconditionally+for the various clauses.  See #24582 for an example of the two getting out of sync.+++************************************************************************+*                                                                      *+                Expressions+*                                                                      *+************************************************************************+-}++occAnalList :: OccEnv -> [CoreExpr] -> WithUsageDetails [CoreExpr]+occAnalList !_   []    = WUD emptyDetails []+occAnalList env (e:es) = let+                          (WUD uds1 e') = occAnal env e+                          (WUD uds2 es') = occAnalList env es+                         in WUD (uds1 `andUDs` uds2) (e' : es')++occAnal :: OccEnv+        -> CoreExpr+        -> WithUsageDetails CoreExpr       -- Gives info only about the "interesting" Ids++occAnal !_   expr@(Lit _)  = WUD emptyDetails expr++occAnal env expr@(Var _) = occAnalApp env (expr, [], [])+    -- At one stage, I gathered the idRuleVars for the variable here too,+    -- which in a way is the right thing to do.+    -- But that went wrong right after specialisation, when+    -- the *occurrences* of the overloaded function didn't have any+    -- rules in them, so the *specialised* versions looked as if they+    -- weren't used at all.++occAnal _ expr@(Type ty)+  = WUD (addManyOccs emptyDetails (coVarsOfType ty)) expr+occAnal _ expr@(Coercion co)+  = WUD (addManyOccs emptyDetails (coVarsOfCo co)) expr+        -- See Note [Gather occurrences of coercion variables]++{- Note [Gather occurrences of coercion variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We need to gather info about what coercion variables appear, for two reasons:++1. So that we can sort them into the right place when doing dependency analysis.++2. So that we know when they are surely dead.++It is useful to know when they a coercion variable is surely dead,+when we want to discard a case-expression, in GHC.Core.Opt.Simplify.rebuildCase.+For example (#20143):++  case unsafeEqualityProof @blah of+     UnsafeRefl cv -> ...no use of cv...++Here we can discard the case, since unsafeEqualityProof always terminates.+But only if the coercion variable 'cv' is unused.++Another example from #15696: we had something like+  case eq_sel d of co -> ...(typeError @(...co...) "urk")...+Then 'd' was substituted by a dictionary, so the expression+simpified to+  case (Coercion <blah>) of cv -> ...(typeError @(...cv...) "urk")...++We can only  drop the case altogether if 'cv' is unused, which is not+the case here.++Conclusion: we need accurate dead-ness info for CoVars.+We gather CoVar occurrences from:++  * The (Type ty) and (Coercion co) cases of occAnal++  * The type 'ty' of a lambda-binder (\(x:ty). blah)+    See addCoVarOccs++But it is not necessary to gather CoVars from the types of other binders.++* For let-binders, if the type mentions a CoVar, so will the RHS (since+  it has the same type)++* For case-alt binders, if the type mentions a CoVar, so will the scrutinee+  (since it has the same type)+-}++occAnal env (Tick tickish body)+  = WUD usage' (Tick tickish body')+  where+    WUD usage body' = occAnal env body++    usage'+      | tickish `tickishScopesLike` SoftScope+      = usage  -- For soft-scoped ticks (including SourceNotes) we don't want+               -- to lose join-point-hood, so we don't mess with `usage` (#24078)++      -- For a non-soft tick scope, we can inline lambdas only, so we+      -- abandon tail calls, and do markAllInsideLam too: usage_lam++      | Breakpoint _ _ ids <- tickish+      = -- Never substitute for any of the Ids in a Breakpoint+        addManyOccs usage_lam (mkVarSet ids)++      | otherwise+      = usage_lam++    usage_lam = markAllNonTail (markAllInsideLam usage)++    -- TODO There may be ways to make ticks and join points play+    -- nicer together, but right now there are problems:+    --   let j x = ... in tick<t> (j 1)+    -- Making j a join point may cause the simplifier to drop t+    -- (if the tick is put into the continuation). So we don't+    -- count j 1 as a tail call.+    -- See #14242.++occAnal env (Cast expr co)+  = let  (WUD usage expr') = occAnal env expr+         usage1 = addManyOccs usage (coVarsOfCo co)+             -- usage2: see Note [Gather occurrences of coercion variables]+         usage2 = markAllNonTail usage1+             -- usage3: calls inside expr aren't tail calls any more+    in WUD usage2 (Cast expr' co)++occAnal env app@(App _ _)+  = occAnalApp env (collectArgsTicks tickishFloatable app)++occAnal env expr@(Lam {})+  = adjustNonRecRhs NotJoinPoint $ -- NotJoinPoint <=> markAllManyNonTail+    occAnalLamTail env expr++occAnal env (Case scrut bndr ty alts)+  = let+      WUD scrut_usage scrut' = occAnal (setScrutCtxt env alts) scrut++      WUD alts_usage (tagged_bndr, alts')+         = addInScopeOne env bndr $ \env ->+           let alt_env = addBndrSwap scrut' bndr $+                         setTailCtxt env  -- Kill off OccRhs+               WUD alts_usage alts' = do_alts alt_env alts+               tagged_bndr = tagLamBinder alts_usage bndr+           in WUD alts_usage (tagged_bndr, alts')++      total_usage = markAllNonTail scrut_usage `andUDs` alts_usage+                    -- Alts can have tail calls, but the scrutinee can't++    in WUD total_usage (Case scrut' tagged_bndr ty alts')+  where+    do_alts :: OccEnv -> [CoreAlt] -> WithUsageDetails [CoreAlt]+    do_alts _   []         = WUD emptyDetails []+    do_alts env (alt:alts) = WUD (uds1 `orUDs` uds2) (alt':alts')+      where+        WUD uds1 alt'  = do_alt  env alt+        WUD uds2 alts' = do_alts env alts++    do_alt !env (Alt con bndrs rhs)+      = addInScopeList env bndrs $ \ env ->+        let WUD rhs_usage rhs' = occAnal env rhs+            tagged_bndrs = tagLamBinders rhs_usage bndrs+        in                 -- See Note [Binders in case alternatives]+        WUD rhs_usage (Alt con tagged_bndrs rhs')++occAnal env (Let bind body)+  = occAnalBind env NotTopLevel noImpRuleEdges bind+                (\env -> occAnal env body) mkLets++occAnalArgs :: OccEnv -> CoreExpr -> [CoreExpr]+            -> [OneShots]  -- Very commonly empty, notably prior to dmd anal+            -> WithUsageDetails CoreExpr+-- The `fun` argument is just an accumulating parameter,+-- the base for building the application we return+occAnalArgs !env fun args !one_shots+  = go emptyDetails fun args one_shots+  where+    env_args = setNonTailCtxt encl env++    -- Make bottoming functions interesting+    -- See Note [Bottoming function calls]+    encl | Var f <- fun, isDeadEndSig (idDmdSig f) = OccScrut+         | otherwise                               = OccVanilla++    go uds fun [] _ = WUD uds fun+    go uds fun (arg:args) one_shots+      = go (uds `andUDs` arg_uds) (fun `App` arg') args one_shots'+      where+        !(WUD arg_uds arg') = occAnal arg_env arg+        !(arg_env, one_shots')+            | isTypeArg arg+            = (env_args, one_shots)+            | otherwise+            = case one_shots of+                []                -> (env_args, []) -- Fast path; one_shots is often empty+                (os : one_shots') -> (setOneShots os env_args, one_shots')++{-+Applications are dealt with specially because we want+the "build hack" to work.++Note [Bottoming function calls]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+   let x = (a,b) in+   case p of+      A -> ...(error x)..+      B -> ...(ertor x)...++postInlineUnconditionally may duplicate x's binding, but sometimes it+does so only if the use site IsInteresting.  Pushing allocation into error+branches is good, so we try to make bottoming calls look interesting, by+setting occ_encl = OccScrut for such calls.++The slightly-artificial test T21128 is a good example.  It's probably+not a huge deal.++Note [Arguments of let-bound constructors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+    f x = let y = expensive x in+          let z = (True,y) in+          (case z of {(p,q)->q}, case z of {(p,q)->q})+We feel free to duplicate the WHNF (True,y), but that means+that y may be duplicated thereby.++If we aren't careful we duplicate the (expensive x) call!+Constructors are rather like lambdas in this way.+-}++occAnalApp :: OccEnv+           -> (Expr CoreBndr, [Arg CoreBndr], [CoreTickish])+           -> WithUsageDetails (Expr CoreBndr)+-- Naked variables (not applied) end up here too+occAnalApp !env (Var fun, args, ticks)+  -- Account for join arity of runRW# continuation+  -- See Note [Simplification of runRW#]+  --+  -- NB: Do not be tempted to make the next (Var fun, args, tick)+  --     equation into an 'otherwise' clause for this equation+  --     The former has a bang-pattern to occ-anal the args, and+  --     we don't want to occ-anal them twice in the runRW# case!+  --     This caused #18296+  | fun `hasKey` runRWKey+  , [t1, t2, arg]  <- args+  , WUD usage arg' <- adjustNonRecRhs (JoinPoint 1) $ occAnalLamTail env arg+  = WUD usage (mkTicks ticks $ mkApps (Var fun) [t1, t2, arg'])++occAnalApp env (Var fun_id, args, ticks)+  = WUD all_uds (mkTicks ticks app')+  where+    -- Lots of banged bindings: this is a very heavily bit of code,+    -- so it pays not to make lots of thunks here, all of which+    -- will ultimately be forced.+    !(fun', fun_id')  = lookupBndrSwap env fun_id+    !(WUD args_uds app') = occAnalArgs env fun' args one_shots++    fun_uds = mkOneOcc env fun_id' int_cxt n_args+       -- NB: fun_uds is computed for fun_id', not fun_id+       -- See (BS1) in Note [The binder-swap substitution]++    all_uds = fun_uds `andUDs` final_args_uds++    !final_args_uds = markAllNonTail                              $+                      markAllInsideLamIf (isRhsEnv env && is_exp) $+                        -- isRhsEnv: see Note [OccEncl]+                      args_uds+       -- We mark the free vars of the argument of a constructor or PAP+       -- as "inside-lambda", if it is the RHS of a let(rec).+       -- This means that nothing gets inlined into a constructor or PAP+       -- argument position, which is what we want.  Typically those+       -- constructor arguments are just variables, or trivial expressions.+       -- We use inside-lam because it's like eta-expanding the PAP.+       --+       -- This is the *whole point* of the isRhsEnv predicate+       -- See Note [Arguments of let-bound constructors]++    !n_val_args = valArgCount args+    !n_args     = length args+    !int_cxt    = case occ_encl env of+                   OccScrut -> IsInteresting+                   _other   | n_val_args > 0 -> IsInteresting+                            | otherwise      -> NotInteresting++    !is_exp     = isExpandableApp fun_id n_val_args+        -- See Note [CONLIKE pragma] in GHC.Types.Basic+        -- The definition of is_exp should match that in GHC.Core.Opt.Simplify.prepareRhs++    one_shots  = argsOneShots (idDmdSig fun_id) guaranteed_val_args+    guaranteed_val_args = n_val_args + length (takeWhile isOneShotInfo+                                                         (occ_one_shots env))+        -- See Note [Sources of one-shot information], bullet point A']++occAnalApp env (fun, args, ticks)+  = WUD (markAllNonTail (fun_uds `andUDs` args_uds))+                     (mkTicks ticks app')+  where+    !(WUD args_uds app') = occAnalArgs env fun' args []+    !(WUD fun_uds fun')  = occAnal (addAppCtxt env args) fun+        -- The addAppCtxt is a bit cunning.  One iteration of the simplifier+        -- often leaves behind beta redexes like+        --      (\x y -> e) a1 a2+        -- Here we would like to mark x,y as one-shot, and treat the whole+        -- thing much like a let.  We do this by pushing some OneShotLam items+        -- onto the context stack.++addAppCtxt :: OccEnv -> [Arg CoreBndr] -> OccEnv+addAppCtxt env@(OccEnv { occ_one_shots = ctxt }) args+  | n_val_args > 0+  = env { occ_one_shots = replicate n_val_args OneShotLam ++ ctxt+        , occ_encl      = OccVanilla }+          -- OccVanilla: the function part of the application+          -- is no longer on OccRhs or OccScrut+  | otherwise+  = env+  where+    n_val_args = valArgCount args+++{-+Note [Sources of one-shot information]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The occurrence analyser obtains one-shot-lambda information from two sources:++A:  Saturated applications:  eg   f e1 .. en++    In general, given a call (f e1 .. en) we can propagate one-shot info from+    f's strictness signature into e1 .. en, but /only/ if n is enough to+    saturate the strictness signature. A strictness signature like++          f :: C(1,C(1,L))LS++    means that *if f is applied to three arguments* then it will guarantee to+    call its first argument at most once, and to call the result of that at+    most once. But if f has fewer than three arguments, all bets are off; e.g.++          map (f (\x y. expensive) e2) xs++    Here the \x y abstraction may be called many times (once for each element of+    xs) so we should not mark x and y as one-shot. But if it was++          map (f (\x y. expensive) 3 2) xs++    then the first argument of f will be called at most once.++    The one-shot info, derived from f's strictness signature, is+    computed by 'argsOneShots', called in occAnalApp.++A': Non-obviously saturated applications: eg    build (f (\x y -> expensive))+    where f is as above.++    In this case, f is only manifestly applied to one argument, so it does not+    look saturated. So by the previous point, we should not use its strictness+    signature to learn about the one-shotness of \x y. But in this case we can:+    build is fully applied, so we may use its strictness signature; and from+    that we learn that build calls its argument with two arguments *at most once*.++    So there is really only one call to f, and it will have three arguments. In+    that sense, f is saturated, and we may proceed as described above.++    Hence the computation of 'guaranteed_val_args' in occAnalApp, using+    '(occ_one_shots env)'.  See also #13227, comment:9++B:  Let-bindings:  eg   let f = \c. let ... in \n -> blah+                        in (build f, build f)++    Propagate one-shot info from the demand-info on 'f' to the+    lambdas in its RHS (which may not be syntactically at the top)++    This information must have come from a previous run of the demand+    analyser.++Previously, the demand analyser would *also* set the one-shot information, but+that code was buggy (see #11770), so doing it only in on place, namely here, is+saner.++Note [OneShots]+~~~~~~~~~~~~~~~+When analysing an expression, the occ_one_shots argument contains information+about how the function is being used. The length of the list indicates+how many arguments will eventually be passed to the analysed expression,+and the OneShotInfo indicates whether this application is once or multiple times.++Example:++ Context of f                occ_one_shots when analysing f++ f 1 2                       [OneShot, OneShot]+ map (f 1)                   [OneShot, NoOneShotInfo]+ build f                     [OneShot, OneShot]+ f 1 2 `seq` f 2 1           [NoOneShotInfo, OneShot]++Note [Binders in case alternatives]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+    case x of y { (a,b) -> f y }+We treat 'a', 'b' as dead, because they don't physically occur in the+case alternative.  (Indeed, a variable is dead iff it doesn't occur in+its scope in the output of OccAnal.)  It really helps to know when+binders are unused.  See esp the call to isDeadBinder in+Simplify.mkDupableAlt++In this example, though, the Simplifier will bring 'a' and 'b' back to+life, because it binds 'y' to (a,b) (imagine got inlined and+scrutinised y).+-}++{-+************************************************************************+*                                                                      *+                    OccEnv+*                                                                      *+************************************************************************+-}++data OccEnv+  = OccEnv { occ_encl       :: !OccEncl      -- Enclosing context information+           , occ_one_shots  :: !OneShots     -- See Note [OneShots]+           , occ_unf_act    :: Id -> Bool          -- Which Id unfoldings are active+           , occ_rule_act   :: Activation -> Bool  -- Which rules are active+             -- See Note [Finding rule RHS free vars]++           -- See Note [The binder-swap substitution]+           -- If  x :-> (y, co)  is in the env,+           -- then please replace x by (y |> mco)+           -- Invariant of course: idType x = exprType (y |> mco)+           , occ_bs_env  :: !(IdEnv (OutId, MCoercion))+              -- Domain is Global and Local Ids+              -- Range is just Local Ids+           , occ_bs_rng  :: !VarSet+               -- Vars (TyVars and Ids) free in the range of occ_bs_env++             -- Usage details of the RHS of in-scope non-recursive join points+             -- Invariant: no Id maps to an empty OccInfoEnv+             -- See Note [Occurrence analysis for join points]+           , occ_join_points :: !JoinPointInfo+    }++type JoinPointInfo = IdEnv OccInfoEnv++-----------------------------+{- Note [OccEncl]+~~~~~~~~~~~~~~~~~+OccEncl is used to control whether to inline into constructor arguments.++* OccRhs: consider+     let p = <blah> in+     let x = Just p+     in ...case p of ...++  Here `p` occurs syntactically once, but we want to mark it as InsideLam+  to stop `p` inlining.  We want to leave the x-binding as a constructor+  applied to variables, so that the Simplifier can simplify that inner `case`.++  The OccRhs just tells occAnalApp to mark occurrences in constructor args++* OccScrut: consider (case x of ...).  Here we want to give `x` OneOcc+  with "interesting context" field int_cxt = True.  The OccScrut tells+  occAnalApp (which deals with lone variables too) when to set this field+  to True.+-}++data OccEncl -- See Note [OccEncl]+  = OccRhs         -- RHS of let(rec), albeit perhaps inside a type lambda+  | OccScrut       -- Scrutintee of a case+  | OccVanilla     -- Everything else++instance Outputable OccEncl where+  ppr OccRhs     = text "occRhs"+  ppr OccScrut   = text "occScrut"+  ppr OccVanilla = text "occVanilla"++-- See Note [OneShots]+type OneShots = [OneShotInfo]++initOccEnv :: OccEnv+initOccEnv+  = OccEnv { occ_encl      = OccVanilla+           , occ_one_shots = []++                 -- To be conservative, we say that all+                 -- inlines and rules are active+           , occ_unf_act   = \_ -> True+           , occ_rule_act  = \_ -> True++           , occ_join_points = emptyVarEnv+           , occ_bs_env = emptyVarEnv+           , occ_bs_rng = emptyVarSet }++noBinderSwaps :: OccEnv -> Bool+noBinderSwaps (OccEnv { occ_bs_env = bs_env }) = isEmptyVarEnv bs_env++setScrutCtxt :: OccEnv -> [CoreAlt] -> OccEnv+setScrutCtxt !env alts+  = setNonTailCtxt encl env+  where+    encl | interesting_alts = OccScrut+         | otherwise        = OccVanilla++    interesting_alts = case alts of+                         []    -> False+                         [alt] -> not (isDefaultAlt alt)+                         _     -> True+     -- 'interesting_alts' is True if the case has at least one+     -- non-default alternative.  That in turn influences+     -- pre/postInlineUnconditionally.  Grep for "occ_int_cxt"!++{- Note [The OccEnv for a right hand side]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+How do we create the OccEnv for a RHS (in mkRhsOccEnv)?++For a non-join point binding, x = rhs++  * occ_encl: set to OccRhs; but see `mkNonRecRhsCtxt` for wrinkles++  * occ_join_points: zap them!++  * occ_one_shots: initialise from the idDemandInfo;+    see Note [Sources of one-shot information]++For a join point binding,  j x = rhs++  * occ_encl: Consider+       x = e+       join j = Just x+    We want to inline x into j right away, so we don't want to give the join point+    a OccRhs (#14137); we want OccVanilla.  It's not a huge deal, because the+    FloatIn pass knows to float into join point RHSs; and the simplifier does not+    float things out of join point RHSs.  But it's a simple, cheap thing to do.++  * occ_join_points: no need to zap.++  * occ_one_shots: we start with one-shot-info from the context, which indeed+    applies to the /body/ of the join point, after walking past the binders.+    So we add to the front a OneShotInfo for each value-binder of the join+    point: see `extendOneShotsForJoinPoint`. (Failing to account for the join-point+    binders caused #25096.)++    For the join point binders themselves, of a /non-recursive/ join point,+    we make the binder a OneShotLam.  Again see `extendOneShotsForJoinPoint`.++    These one-shot infos then get attached to the binder by `occAnalLamTail`.+-}++setNonTailCtxt :: OccEncl -> OccEnv -> OccEnv+setNonTailCtxt ctxt !env+  = env { occ_encl        = ctxt+        , occ_one_shots   = []+        , occ_join_points = zapJoinPointInfo (occ_join_points env) }++setTailCtxt :: OccEnv -> OccEnv+setTailCtxt !env = env { occ_encl = OccVanilla }+    -- Preserve occ_one_shots, occ_join points+    -- Do not use OccRhs for the RHS of a join point (which is a tail ctxt):++mkRhsOccEnv :: OccEnv -> RecFlag -> OccEncl -> JoinPointHood -> Id -> CoreExpr -> OccEnv+-- See Note [The OccEnv for a right hand side]+-- For a join point:+--   - Keep occ_one_shots, occ_joinPoints from the context+--   - But push enough OneShotInfo onto occ_one_shots to account+--     for the join-point value binders+--   - Set occ_encl to OccVanilla+-- For non-join points+--   - Zap occ_one_shots and occ_join_points+--   - Set occ_encl to specified OccEncl+mkRhsOccEnv env@(OccEnv { occ_one_shots = ctxt_one_shots, occ_join_points = ctxt_join_points })+            is_rec encl jp_hood bndr rhs+  | JoinPoint join_arity <- jp_hood+  = env { occ_encl        = OccVanilla+        , occ_one_shots   = extendOneShotsForJoinPoint is_rec join_arity rhs ctxt_one_shots+        , occ_join_points = ctxt_join_points }++  | otherwise+  = env { occ_encl        = encl+        , occ_one_shots   = argOneShots (idDemandInfo bndr)+                            -- argOneShots: see Note [Sources of one-shot information]+        , occ_join_points = zapJoinPointInfo ctxt_join_points }++zapJoinPointInfo :: JoinPointInfo -> JoinPointInfo+-- (zapJoinPointInfo jp_info) basically just returns emptyVarEnv (hence zapped).+-- See (W3) of Note [Occurrence analysis for join points]+--+-- Zapping improves efficiency, slightly, if you accidentally introduce a bug,+-- in which you zap [jx :-> uds] and then find an occurrence of jx anyway, you+-- might lose those uds, and that might mean we don't record all occurrencs, and+-- that means we duplicate a redex....  a very nasty bug (which I encountered!).+-- Hence this DEBUG code which doesn't remove jx from the envt; it just gives it+-- emptyDetails, which in turn causes a panic in mkOneOcc. That will catch this+-- bug before it does any damage.+#ifdef DEBUG+zapJoinPointInfo jp_info = mapVarEnv (\ _ -> emptyVarEnv) jp_info+#else+zapJoinPointInfo _       = emptyVarEnv+#endif++extendOneShotsForJoinPoint+  :: RecFlag -> JoinArity -> CoreExpr+  -> [OneShotInfo] -> [OneShotInfo]+-- Push enough OneShortInfos on the front of ctxt_one_shots+-- to account for the value lambdas of the join point+extendOneShotsForJoinPoint is_rec join_arity rhs ctxt_one_shots+  = go join_arity rhs+  where+    -- For a /non-recursive/ join point we can mark all+    -- its join-lambda as one-shot; and it's a good idea to do so+    -- But not so for recursive ones+    os = case is_rec of+           NonRecursive -> OneShotLam+           Recursive    -> NoOneShotInfo++    go 0 _        = ctxt_one_shots+    go n (Lam b rhs)+      | isId b    = os : go (n-1) rhs+      | otherwise =      go (n-1) rhs+    go _ _        = []  -- Not enough lambdas.  This can legitimately happen.+                        -- e.g.    let j = case ... in j True+                        -- This will become an arity-1 join point after the+                        -- simplifier has eta-expanded it; but it may not have+                        -- enough lambdas /yet/. (Lint checks that JoinIds do+                        -- have enough lambdas.)++setOneShots :: OneShots -> OccEnv -> OccEnv+setOneShots os !env+  | null os   = env  -- Fast path for common case+  | otherwise = env { occ_one_shots = os }++isRhsEnv :: OccEnv -> Bool+isRhsEnv (OccEnv { occ_encl = cxt }) = case cxt of+                                          OccRhs -> True+                                          _      -> False++addInScopeList :: OccEnv -> [Var]+               -> (OccEnv -> WithUsageDetails a) -> WithUsageDetails a+{-# INLINE addInScopeList #-}+addInScopeList env bndrs thing_inside+ | null bndrs = thing_inside env  -- E.g. nullary constructors in a `case`+ | otherwise  = addInScope env bndrs thing_inside++addInScopeOne :: OccEnv -> Id+               -> (OccEnv -> WithUsageDetails a) -> WithUsageDetails a+{-# INLINE addInScopeOne #-}+addInScopeOne env bndr = addInScope env [bndr]++addInScope :: OccEnv -> [Var]+           -> (OccEnv -> WithUsageDetails a) -> WithUsageDetails a+{-# INLINE addInScope #-}+-- This function is called a lot, so we want to inline the fast path+-- so we don't have to allocate thing_inside and call it+-- The bndrs must include TyVars as well as Ids, because of+--     (BS3) in Note [Binder swap]+-- We do not assume that the bndrs are in scope order; in fact the+-- call in occ_anal_lam_tail gives them to addInScope in /reverse/ order++-- Fast path when the is no environment-munging to do+-- This is rather common: notably at top level, but nested too+addInScope env bndrs thing_inside+  | isEmptyVarEnv (occ_bs_env env)+  , isEmptyVarEnv (occ_join_points env)+  , WUD uds res <- thing_inside env+  = WUD (delBndrsFromUDs bndrs uds) res++addInScope env bndrs thing_inside+  = WUD uds' res+  where+    bndr_set           = mkVarSet bndrs+    !(env', bad_joins) = preprocess_env env bndr_set+    !(WUD uds res)     = thing_inside env'+    uds'               = postprocess_uds bndrs bad_joins uds++preprocess_env :: OccEnv -> VarSet -> (OccEnv, JoinPointInfo)+preprocess_env env@(OccEnv { occ_join_points = join_points+                           , occ_bs_rng = bs_rng_vars })+               bndr_set+  | bad_joins = (drop_shadowed_swaps (drop_shadowed_joins env), join_points)+  | otherwise = (drop_shadowed_swaps env,                       emptyVarEnv)+  where+    drop_shadowed_swaps :: OccEnv -> OccEnv+    -- See Note [The binder-swap substitution] (BS3)+    drop_shadowed_swaps env@(OccEnv { occ_bs_env = swap_env })+      | isEmptyVarEnv swap_env+      = env+      | bs_rng_vars `intersectsVarSet` bndr_set+      = env { occ_bs_env = emptyVarEnv, occ_bs_rng = emptyVarSet }+      | otherwise+      = env { occ_bs_env = swap_env `minusUFM` bndr_fm }++    drop_shadowed_joins :: OccEnv -> OccEnv+    -- See Note [Occurrence analysis for join points] wrinkle2 (W1) and (W2)+    drop_shadowed_joins env = env { occ_join_points = emptyVarEnv }++    -- bad_joins is true if it would be wrong to push occ_join_points inwards+    --  (a) `bndrs` includes any of the occ_join_points+    --  (b) `bndrs` includes any variables free in the RHSs of occ_join_points+    bad_joins :: Bool+    bad_joins = nonDetStrictFoldVarEnv_Directly is_bad False join_points++    bndr_fm :: UniqFM Var Var+    bndr_fm = getUniqSet bndr_set++    is_bad :: Unique -> OccInfoEnv -> Bool -> Bool+    is_bad uniq join_uds rest+      = uniq `elemUniqSet_Directly` bndr_set ||+        not (bndr_fm `disjointUFM` join_uds) ||+        rest++postprocess_uds :: [Var] -> JoinPointInfo -> UsageDetails -> UsageDetails+postprocess_uds bndrs bad_joins uds+  = add_bad_joins (delBndrsFromUDs bndrs uds)+  where+    add_bad_joins :: UsageDetails -> UsageDetails+    -- Add usage info for occ_join_points that we cannot push inwards+    -- because of shadowing+    -- See Note [Occurrence analysis for join points] wrinkle (W2)+    add_bad_joins uds+       | isEmptyVarEnv bad_joins = uds+       | otherwise               = modifyUDEnv extend_with_bad_joins uds++    extend_with_bad_joins :: OccInfoEnv -> OccInfoEnv+    extend_with_bad_joins env+       = nonDetStrictFoldUFM_Directly add_bad_join env bad_joins++    add_bad_join :: Unique -> OccInfoEnv -> OccInfoEnv -> OccInfoEnv+    -- Behave like `andUDs` when adding in the bad_joins+    add_bad_join uniq join_env env+      | uniq `elemVarEnvByKey` env = plusVarEnv_C andLocalOcc env join_env+      | otherwise                  = env++addJoinPoint :: OccEnv -> Id -> UsageDetails -> OccEnv+addJoinPoint env bndr rhs_uds+  | isEmptyVarEnv zeroed_form+  = env+  | otherwise+  = env { occ_join_points = extendVarEnv (occ_join_points env) bndr zeroed_form }+  where+    zeroed_form = mkZeroedForm rhs_uds++mkZeroedForm :: UsageDetails -> OccInfoEnv+-- See Note [Occurrence analysis for join points] for "zeroed form"+mkZeroedForm (UD { ud_env = rhs_occs })+  = mapMaybeUFM do_one rhs_occs+  where+    do_one :: LocalOcc -> Maybe LocalOcc+    do_one (ManyOccL {})    = Nothing+    do_one occ@(OneOccL {}) = Just (occ { lo_n_br = 0 })++--------------------+transClosureFV :: VarEnv VarSet -> VarEnv VarSet+-- If (f,g), (g,h) are in the input, then (f,h) is in the output+--                                   as well as (f,g), (g,h)+transClosureFV env+  | no_change = env+  | otherwise = transClosureFV (listToUFM_Directly new_fv_list)+  where+    (no_change, new_fv_list) = mapAccumL bump True (nonDetUFMToList env)+      -- It's OK to use nonDetUFMToList here because we'll forget the+      -- ordering by creating a new set with listToUFM+    bump no_change (b,fvs)+      | no_change_here = (no_change, (b,fvs))+      | otherwise      = (False,     (b,new_fvs))+      where+        (new_fvs, no_change_here) = extendFvs env fvs++-------------+extendFvs_ :: VarEnv VarSet -> VarSet -> VarSet+extendFvs_ env s = fst (extendFvs env s)   -- Discard the Bool flag++extendFvs :: VarEnv VarSet -> VarSet -> (VarSet, Bool)+-- (extendFVs env s) returns+--     (s `union` env(s), env(s) `subset` s)+extendFvs env s+  | isNullUFM env+  = (s, True)+  | otherwise+  = (s `unionVarSet` extras, extras `subVarSet` s)+  where+    extras :: VarSet    -- env(s)+    extras = nonDetStrictFoldUFM unionVarSet emptyVarSet $+      -- It's OK to use nonDetStrictFoldUFM here because unionVarSet commutes+             intersectUFM_C (\x _ -> x) env (getUniqSet s)++{-+************************************************************************+*                                                                      *+                    Binder swap+*                                                                      *+************************************************************************++Note [Binder swap]+~~~~~~~~~~~~~~~~~~+The "binder swap" transformation swaps occurrence of the+scrutinee of a case for occurrences of the case-binder:++ (1)  case x of b { pi -> ri }+         ==>+      case x of b { pi -> ri[b/x] }++ (2)  case (x |> co) of b { pi -> ri }+        ==>+      case (x |> co) of b { pi -> ri[b |> sym co/x] }++The substitution ri[b/x] etc is done by the occurrence analyser.+See Note [The binder-swap substitution].++There are two reasons for making this swap:++(A) It reduces the number of occurrences of the scrutinee, x.+    That in turn might reduce its occurrences to one, so we+    can inline it and save an allocation.  E.g.+      let x = factorial y in case x of b { I# v -> ...x... }+    If we replace 'x' by 'b' in the alternative we get+      let x = factorial y in case x of b { I# v -> ...b... }+    and now we can inline 'x', thus+      case (factorial y) of b { I# v -> ...b... }++(B) The case-binder b has unfolding information; in the+    example above we know that b = I# v. That in turn allows+    nested cases to simplify.  Consider+       case x of b { I# v ->+       ...(case x of b2 { I# v2 -> rhs })...+    If we replace 'x' by 'b' in the alternative we get+       case x of b { I# v ->+       ...(case b of b2 { I# v2 -> rhs })...+    and now it is trivial to simplify the inner case:+       case x of b { I# v ->+       ...(let b2 = b in rhs)...++    The same can happen even if the scrutinee is a variable+    with a cast: see Note [Case of cast]++The reason for doing these transformations /here in the occurrence+analyser/ is because it allows us to adjust the OccInfo for 'x' and+'b' as we go.++  * Suppose the only occurrences of 'x' are the scrutinee and in the+    ri; then this transformation makes it occur just once, and hence+    get inlined right away.++  * If instead the Simplifier replaces occurrences of x with+    occurrences of b, that will mess up b's occurrence info. That in+    turn might have consequences.++There is a danger though.  Consider+      let v = x +# y+      in case (f v) of w -> ...v...v...+And suppose that (f v) expands to just v.  Then we'd like to+use 'w' instead of 'v' in the alternative.  But it may be too+late; we may have substituted the (cheap) x+#y for v in the+same simplifier pass that reduced (f v) to v.++I think this is just too bad.  CSE will recover some of it.++Note [The binder-swap substitution]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The binder-swap is implemented by the occ_bs_env field of OccEnv.+There are two main pieces:++* Given    case x |> co of b { alts }+  we add [x :-> (b, sym co)] to the occ_bs_env environment; this is+  done by addBndrSwap.++* Then, at an occurrence of a variable, we look up in the occ_bs_env+  to perform the swap. This is done by lookupBndrSwap.++Some tricky corners:++(BS1) We do the substitution before gathering occurrence info. So in+      the above example, an occurrence of x turns into an occurrence+      of b, and that's what we gather in the UsageDetails.  It's as+      if the binder-swap occurred before occurrence analysis. See+      the computation of fun_uds in occAnalApp.++(BS2) When doing a lookup in occ_bs_env, we may need to iterate,+      as you can see implemented in lookupBndrSwap.  Why?+      Consider   case x of a { 1# -> e1; DEFAULT ->+                 case x of b { 2# -> e2; DEFAULT ->+                 case x of c { 3# -> e3; DEFAULT -> ..x..a..b.. }}}+      At the first case addBndrSwap will extend occ_bs_env with+          [x :-> a]+      At the second case we occ-anal the scrutinee 'x', which looks up+        'x in occ_bs_env, returning 'a', as it should.+      Then addBndrSwap will add [a :-> b] to occ_bs_env, yielding+         occ_bs_env = [x :-> a, a :-> b]+      At the third case we'll again look up 'x' which returns 'a'.+      But we don't want to stop the lookup there, else we'll end up with+                 case x of a { 1# -> e1; DEFAULT ->+                 case a of b { 2# -> e2; DEFAULT ->+                 case a of c { 3# -> e3; DEFAULT -> ..a..b..c.. }}}+      Instead, we want iterate the lookup in addBndrSwap, to give+                 case x of a { 1# -> e1; DEFAULT ->+                 case a of b { 2# -> e2; DEFAULT ->+                 case b of c { 3# -> e3; DEFAULT -> ..c..c..c.. }}}+      This makes a particular difference for case-merge, which works+      only if the scrutinee is the case-binder of the immediately enclosing+      case (Note [Merge Nested Cases] in GHC.Core.Opt.Simplify.Utils+      See #19581 for the bug report that showed this up.++(BS3) We need care when shadowing.  Suppose [x :-> b] is in occ_bs_env,+      and we encounter:+         (i) \x. blah+             Here we want to delete the x-binding from occ_bs_env++         (ii) \b. blah+              This is harder: we really want to delete all bindings that+              have 'b' free in the range.  That is a bit tiresome to implement,+              so we compromise.  We keep occ_bs_rng, which is the set of+              free vars of rng(occc_bs_env).  If a binder shadows any of these+              variables, we discard all of occ_bs_env.  Safe, if a bit+              brutal.  NB, however: the simplifer de-shadows the code, so the+              next time around this won't happen.++      These checks are implemented in addInScope.+      (i) is needed only for Ids, but (ii) is needed for tyvars too (#22623)+      because if occ_bs_env has [x :-> ...a...] where `a` is a tyvar, we+      must not replace `x` by `...a...` under /\a. ...x..., or similarly+      under a case pattern match that binds `a`.++      An alternative would be for the occurrence analyser to do cloning as+      it goes.  In principle it could do so, but it'd make it a bit more+      complicated and there is no great benefit. The simplifer uses+      cloning to get a no-shadowing situation, the care-when-shadowing+      behaviour above isn't needed for long.++(BS4) The domain of occ_bs_env can include GlobaIds.  Eg+         case M.foo of b { alts }+      We extend occ_bs_env with [M.foo :-> b].  That's fine.++(BS5) We have to apply the occ_bs_env substitution uniformly,+      including to (local) rules and unfoldings.++(BS6) For interest (only),+      see Historical Note [Care with binder-swap on dictionaries]++Note [Case of cast]+~~~~~~~~~~~~~~~~~~~+Consider        case (x `cast` co) of b { I# ->+                ... (case (x `cast` co) of {...}) ...+We'd like to eliminate the inner case.  That is the motivation for+equation (2) in Note [Binder swap].  When we get to the inner case, we+inline x, cancel the casts, and away we go.++Historical Note [Care with binder-swap on dictionaries]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+This Note is now out-dated; it has been rendered irrelevant by+Note [Unary class magic] in GHC.Core.TyCon.  I'm leaving it here in+case we are every tempted to return to newtype classes.++This (historical) Note explains why we need isDictId in scrutOkForBinderSwap.+Consider this tricky example (#21229, #21470):++  class Sing (b :: Bool) where sing :: Bool+  instance Sing 'True  where sing = True+  instance Sing 'False where sing = False++  f :: forall a. Sing a => blah++  h = \ @(a :: Bool) ($dSing :: Sing a)+      let the_co =  Main.N:Sing[0] <a> :: Sing a ~R# Bool+      case ($dSing |> the_co) of wild+        True  -> f @'True (True |> sym the_co)+        False -> f @a     dSing++Now do a binder-swap on the case-expression:++  h = \ @(a :: Bool) ($dSing :: Sing a)+      let the_co =  Main.N:Sing[0] <a> :: Sing a ~R# Bool+      case ($dSing |> the_co) of wild+        True  -> f @'True (True |> sym the_co)+        False -> f @a     (wild |> sym the_co)++And now substitute `False` for `wild` (since wild=False in the False branch):++  h = \ @(a :: Bool) ($dSing :: Sing a)+      let the_co =  Main.N:Sing[0] <a> :: Sing a ~R# Bool+      case ($dSing |> the_co) of wild+        True  -> f @'True (True  |> sym the_co)+        False -> f @a     (False |> sym the_co)++And now we have a problem.  The specialiser will specialise (f @a d)a (for all+vtypes a and dictionaries d!!) with the dictionary (False |> sym the_co), using+Note [Specialising polymorphic dictionaries] in GHC.Core.Opt.Specialise.++The real problem is the binder-swap.  It swaps a dictionary variable $dSing+(of kind Constraint) for a term variable wild (of kind Type).  And that is+dangerous: a dictionary is a /singleton/ type whereas a general term variable is+not.  In this particular example, Bool is most certainly not a singleton type!++Conclusion:+  for a /dictionary variable/ do not perform+  the clever cast version of the binder-swap++Hence the subtle isDictId in scrutOkForBinderSwap.++Why this Note is now outdated.  Using Note [Unary class magic] in GHC.Core.TyCon+the program above becomes+  h = \ @(a :: Bool) ($dSing :: Sing a)+      case sing @a $dSing of (wild::Bool)+        True  -> f @'True $dSing+        False -> f @a     $dSing+so the issue of binder-swapping doesn't arise.++End of Historical Note.++Note [Zap case binders in proxy bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+From the original+     case x of cb(dead) { p -> ...x... }+we will get+     case x of cb(live) { p -> ...cb... }++Core Lint never expects to find an *occurrence* of an Id marked+as Dead, so we must zap the OccInfo on cb before making the+binding x = cb.  See #5028.++NB: the OccInfo on /occurrences/ really doesn't matter much; the simplifier+doesn't use it. So this is only to satisfy the perhaps-over-picky Lint.++-}++addBndrSwap :: OutExpr -> Id -> OccEnv -> OccEnv+-- See Note [The binder-swap substitution]+addBndrSwap scrut case_bndr+            env@(OccEnv { occ_bs_env = swap_env, occ_bs_rng = rng_vars })+  | DoBinderSwap scrut_var mco <- scrutOkForBinderSwap scrut+  , scrut_var /= case_bndr+      -- Consider: case x of x { ... }+      -- Do not add [x :-> x] to occ_bs_env, else lookupBndrSwap will loop+  = env { occ_bs_env = extendVarEnv swap_env scrut_var (case_bndr', mco)+        , occ_bs_rng = rng_vars `extendVarSet` case_bndr'+                       `unionVarSet` tyCoVarsOfMCo mco }++  | otherwise+  = env+  where+    case_bndr' = zapIdOccInfo case_bndr+                 -- See Note [Zap case binders in proxy bindings]++-- | See bBinderSwaOk.+data BinderSwapDecision+  = NoBinderSwap+  | DoBinderSwap OutVar MCoercion++scrutOkForBinderSwap :: OutExpr -> BinderSwapDecision+-- If (scrutOkForBinderSwap e = DoBinderSwap v mco, then+--    v = e |> mco+-- See Note [Case of cast]+-- See Historical Note [Care with binder-swap on dictionaries]+--+-- We use this same function in SpecConstr, and Simplify.Iteration,+-- when something binder-swap-like is happening+scrutOkForBinderSwap e+  = case e of+      Tick _ e        -> scrutOkForBinderSwap e  -- Drop ticks+      Var v           -> DoBinderSwap v MRefl+      Cast (Var v) co -> DoBinderSwap v (MCo (mkSymCo co))+                         -- Cast: see Note [Case of cast]+      _               -> NoBinderSwap++lookupBndrSwap :: OccEnv -> Id -> (CoreExpr, Id)+-- See Note [The binder-swap substitution]+-- Returns an expression of the same type as Id+lookupBndrSwap env@(OccEnv { occ_bs_env = bs_env })  bndr+  = case lookupVarEnv bs_env bndr of {+       Nothing           -> (Var bndr, bndr) ;+       Just (bndr1, mco) ->++    -- Why do we iterate here?+    -- See (BS2) in Note [The binder-swap substitution]+    case lookupBndrSwap env bndr1 of+      (fun, fun_id) -> (mkCastMCo fun mco, fun_id) }++{- Historical note [Proxy let-bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We used to do the binder-swap transformation by introducing+a proxy let-binding, thus;++   case x of b { pi -> ri }+      ==>+   case x of b { pi -> let x = b in ri }++But that had two problems:++1. If 'x' is an imported GlobalId, we'd end up with a GlobalId+   on the LHS of a let-binding which isn't allowed.  We worked+   around this for a while by "localising" x, but it turned+   out to be very painful #16296,++2. In CorePrep we use the occurrence analyser to do dead-code+   elimination (see Note [Dead code in CorePrep]).  But that+   occasionally led to an unlifted let-binding+       case x of b { DEFAULT -> let x::Int# = b in ... }+   which disobeys one of CorePrep's output invariants (no unlifted+   let-bindings) -- see #5433.++Doing a substitution (via occ_bs_env) is much better.++Historical Note [no-case-of-case]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We *used* to suppress the binder-swap in case expressions when+-fno-case-of-case is on.  Old remarks:+    "This happens in the first simplifier pass,+    and enhances full laziness.  Here's the bad case:+            f = \ y -> ...(case x of I# v -> ...(case x of ...) ... )+    If we eliminate the inner case, we trap it inside the I# v -> arm,+    which might prevent some full laziness happening.  I've seen this+    in action in spectral/cichelli/Prog.hs:+             [(m,n) | m <- [1..max], n <- [1..max]]+    Hence the check for NoCaseOfCase."+However, now the full-laziness pass itself reverses the binder-swap, so this+check is no longer necessary.++Historical Note [Suppressing the case binder-swap]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+This old note describes a problem that is also fixed by doing the+binder-swap in OccAnal:++    There is another situation when it might make sense to suppress the+    case-expression binde-swap. If we have++        case x of w1 { DEFAULT -> case x of w2 { A -> e1; B -> e2 }+                       ...other cases .... }++    We'll perform the binder-swap for the outer case, giving++        case x of w1 { DEFAULT -> case w1 of w2 { A -> e1; B -> e2 }+                       ...other cases .... }++    But there is no point in doing it for the inner case, because w1 can't+    be inlined anyway.  Furthermore, doing the case-swapping involves+    zapping w2's occurrence info (see paragraphs that follow), and that+    forces us to bind w2 when doing case merging.  So we get++        case x of w1 { A -> let w2 = w1 in e1+                       B -> let w2 = w1 in e2+                       ...other cases .... }++    This is plain silly in the common case where w2 is dead.++    Even so, I can't see a good way to implement this idea.  I tried+    not doing the binder-swap if the scrutinee was already evaluated+    but that failed big-time:++            data T = MkT !Int++            case v of w  { MkT x ->+            case x of x1 { I# y1 ->+            case x of x2 { I# y2 -> ...++    Notice that because MkT is strict, x is marked "evaluated".  But to+    eliminate the last case, we must either make sure that x (as well as+    x1) has unfolding MkT y1.  The straightforward thing to do is to do+    the binder-swap.  So this whole note is a no-op.++It's fixed by doing the binder-swap in OccAnal because we can do the+binder-swap unconditionally and still get occurrence analysis+information right.+++************************************************************************+*                                                                      *+\subsection[OccurAnal-types]{OccEnv}+*                                                                      *+************************************************************************++Note [UsageDetails and zapping]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+On many occasions, we must modify all gathered occurrence data at once. For+instance, all occurrences underneath a (non-one-shot) lambda set the+'occ_in_lam' flag to become 'True'. We could use 'mapVarEnv' to do this, but+that takes O(n) time and we will do this often---in particular, there are many+places where tail calls are not allowed, and each of these causes all variables+to get marked with 'NoTailCallInfo'.++Instead of relying on `mapVarEnv`, then, we carry three 'IdEnv's around along+with the 'OccInfoEnv'. Each of these extra environments is a "zapped set"+recording which variables have been zapped in some way. Zapping all occurrence+info then simply means setting the corresponding zapped set to the whole+'OccInfoEnv', a fast O(1) operation.++Note [LocalOcc]+~~~~~~~~~~~~~~~+LocalOcc is used purely internally, in the occurrence analyser.  It differs from+GHC.Types.Basic.OccInfo because it has only OneOcc and ManyOcc; it does not need+IAmDead or IAmALoopBreaker.++Note that `OneOccL` doesn't meant that it occurs /syntactially/ only once; it+means that it is /used/ only once. It might occur syntactically many times.+For example, in (case x of A -> y; B -> y; C -> True),+* `y` is used only once+* but it occurs syntactically twice++-}++type OccInfoEnv = IdEnv LocalOcc  -- A finite map from an expression's+                                  -- free variables to their usage++data LocalOcc  -- See Note [LocalOcc]+     = OneOccL { lo_n_br  :: {-# UNPACK #-} !BranchCount  -- Number of syntactic occurrences+               , lo_tail  :: !TailCallInfo+                   -- Combining (AlwaysTailCalled 2) and (AlwaysTailCalled 3)+                   -- gives NoTailCallInfo+              , lo_int_cxt :: !InterestingCxt }+    | ManyOccL !TailCallInfo++instance Outputable LocalOcc where+  ppr (OneOccL { lo_n_br = n, lo_tail = tci })+    = text "OneOccL" <> braces (ppr n <> comma <> ppr tci)+  ppr (ManyOccL tci) = text "ManyOccL" <> braces (ppr tci)++localTailCallInfo :: LocalOcc -> TailCallInfo+localTailCallInfo (OneOccL  { lo_tail = tci }) = tci+localTailCallInfo (ManyOccL tci)               = tci++type ZappedSet = OccInfoEnv -- Values are ignored++data UsageDetails+  = UD { ud_env       :: !OccInfoEnv+       , ud_z_many    :: !ZappedSet   -- apply 'markMany' to these+       , ud_z_in_lam  :: !ZappedSet   -- apply 'markInsideLam' to these+       , ud_z_tail    :: !ZappedSet   -- zap tail-call info for these+       }+  -- INVARIANT: All three zapped sets are subsets of ud_env++instance Outputable UsageDetails where+  ppr ud@(UD { ud_env = env, ud_z_tail = z_tail })+    = text "UD" <+> (braces $ fsep $ punctuate comma $+      [ ppr uq <+> text ":->" <+> ppr (lookupOccInfoByUnique ud uq)+      | (uq, _) <- nonDetStrictFoldVarEnv_Directly do_one [] env ])+      $$ nest 2 (text "ud_z_tail" <+> ppr z_tail)+    where+      do_one :: Unique -> LocalOcc -> [(Unique,LocalOcc)] -> [(Unique,LocalOcc)]+      do_one uniq occ occs = (uniq, occ) : occs++---------------------+-- | TailUsageDetails captures the result of applying 'occAnalLamTail'+--   to a function `\xyz.body`. The TailUsageDetails pairs together+--   * the number of lambdas (including type lambdas: a JoinArity)+--   * UsageDetails for the `body` of the lambda, unadjusted by `adjustTailUsage`.+-- If the binding turns out to be a join point with the indicated join+-- arity, this unadjusted usage details is just what we need; otherwise we+-- need to discard tail calls. That's what `adjustTailUsage` does.+data TailUsageDetails = TUD !JoinArity !UsageDetails++instance Outputable TailUsageDetails where+  ppr (TUD ja uds) = lambda <> ppr ja <> ppr uds++---------------------+data WithUsageDetails     a = WUD  !UsageDetails     !a+data WithTailUsageDetails a = WTUD !TailUsageDetails !a++-------------------+-- UsageDetails API++andUDs, orUDs+        :: UsageDetails -> UsageDetails -> UsageDetails+andUDs = combineUsageDetailsWith andLocalOcc+orUDs  = combineUsageDetailsWith orLocalOcc++mkOneOcc :: OccEnv -> Id -> InterestingCxt -> JoinArity -> UsageDetails+mkOneOcc !env id int_cxt arity+  | not (isLocalId id)+  = emptyDetails++  | Just join_uds <- lookupVarEnv (occ_join_points env) id+  = -- See Note [Occurrence analysis for join points]+    assertPpr (not (isEmptyVarEnv join_uds)) (ppr id) $+       -- We only put non-empty join-points into occ_join_points+    mkSimpleDetails (extendVarEnv join_uds id occ)++  | otherwise+  = mkSimpleDetails (unitVarEnv id occ)++  where+    occ = OneOccL { lo_n_br = 1, lo_int_cxt = int_cxt+                  , lo_tail = AlwaysTailCalled arity }++-- Add several occurrences, assumed not to be tail calls+add_many_occ :: Var -> OccInfoEnv -> OccInfoEnv+add_many_occ v env | isId v    = extendVarEnv env v (ManyOccL NoTailCallInfo)+                   | otherwise = env+        -- Give a non-committal binder info (i.e noOccInfo) because+        --   a) Many copies of the specialised thing can appear+        --   b) We don't want to substitute a BIG expression inside a RULE+        --      even if that's the only occurrence of the thing+        --      (Same goes for INLINE.)++addManyOccs :: UsageDetails -> VarSet -> UsageDetails+addManyOccs uds var_set+  | isEmptyVarSet var_set = uds+  | otherwise             = uds { ud_env = add_to (ud_env uds) }+  where+    add_to env = nonDetStrictFoldUniqSet add_many_occ env var_set+    -- It's OK to use nonDetStrictFoldUniqSet here because add_many_occ commutes++addLamCoVarOccs :: UsageDetails -> [Var] -> UsageDetails+-- Add any CoVars free in the type of a lambda-binder+-- See Note [Gather occurrences of coercion variables]+addLamCoVarOccs uds bndrs+  = foldr add uds bndrs+  where+    add bndr uds = uds `addManyOccs` coVarsOfType (varType bndr)++emptyDetails :: UsageDetails+emptyDetails = mkSimpleDetails emptyVarEnv++isEmptyDetails :: UsageDetails -> Bool+isEmptyDetails (UD { ud_env = env }) = isEmptyVarEnv env++mkSimpleDetails :: OccInfoEnv -> UsageDetails+mkSimpleDetails env = UD { ud_env       = env+                         , ud_z_many    = emptyVarEnv+                         , ud_z_in_lam  = emptyVarEnv+                         , ud_z_tail    = emptyVarEnv }++modifyUDEnv :: (OccInfoEnv -> OccInfoEnv) -> UsageDetails -> UsageDetails+modifyUDEnv f uds@(UD { ud_env = env }) = uds { ud_env = f env }++delBndrsFromUDs :: [Var] -> UsageDetails -> UsageDetails+-- Delete these binders from the UsageDetails+delBndrsFromUDs bndrs (UD { ud_env = env, ud_z_many = z_many+                          , ud_z_in_lam  = z_in_lam, ud_z_tail = z_tail })+  = UD { ud_env       = env      `delVarEnvList` bndrs+       , ud_z_many    = z_many   `delVarEnvList` bndrs+       , ud_z_in_lam  = z_in_lam `delVarEnvList` bndrs+       , ud_z_tail    = z_tail   `delVarEnvList` bndrs }++markAllMany, markAllInsideLam, markAllNonTail, markAllManyNonTail+  :: UsageDetails -> UsageDetails+markAllMany      ud@(UD { ud_env = env }) = ud { ud_z_many   = env }+markAllInsideLam ud@(UD { ud_env = env }) = ud { ud_z_in_lam = env }+markAllNonTail   ud@(UD { ud_env = env }) = ud { ud_z_tail   = env }+markAllManyNonTail = markAllMany . markAllNonTail -- effectively sets to noOccInfo++markAllInsideLamIf, markAllNonTailIf :: Bool -> UsageDetails -> UsageDetails++markAllInsideLamIf  True  ud = markAllInsideLam ud+markAllInsideLamIf  False ud = ud++markAllNonTailIf True  ud = markAllNonTail ud+markAllNonTailIf False ud = ud++lookupTailCallInfo :: UsageDetails -> Id -> TailCallInfo+lookupTailCallInfo uds id+  | UD { ud_z_tail = z_tail, ud_env = env } <- uds+  , not (id `elemVarEnv` z_tail)+  , Just occ <- lookupVarEnv env id+  = localTailCallInfo occ+  | otherwise+  = NoTailCallInfo++udFreeVars :: VarSet -> UsageDetails -> VarSet+-- Find the subset of bndrs that are mentioned in uds+udFreeVars bndrs (UD { ud_env = env }) = restrictFreeVars bndrs env++restrictFreeVars :: VarSet -> OccInfoEnv -> VarSet+restrictFreeVars bndrs fvs = restrictUniqSetToUFM bndrs fvs++-------------------+-- Auxiliary functions for UsageDetails implementation++combineUsageDetailsWith :: (LocalOcc -> LocalOcc -> LocalOcc)+                        -> UsageDetails -> UsageDetails -> UsageDetails+{-# INLINE combineUsageDetailsWith #-}+combineUsageDetailsWith plus_occ_info+    uds1@(UD { ud_env = env1, ud_z_many = z_many1, ud_z_in_lam = z_in_lam1, ud_z_tail = z_tail1 })+    uds2@(UD { ud_env = env2, ud_z_many = z_many2, ud_z_in_lam = z_in_lam2, ud_z_tail = z_tail2 })+  | isEmptyVarEnv env1 = uds2+  | isEmptyVarEnv env2 = uds1+  | otherwise+  = UD { ud_env       = plusVarEnv_C plus_occ_info env1 env2+       , ud_z_many    = plusVarEnv z_many1   z_many2+       , ud_z_in_lam  = plusVarEnv z_in_lam1 z_in_lam2+       , ud_z_tail    = plusVarEnv z_tail1   z_tail2 }++lookupLetOccInfo :: UsageDetails -> Id -> OccInfo+-- Don't use locally-generated occ_info for exported (visible-elsewhere)+-- things.  Instead just give noOccInfo.+-- NB: setBinderOcc will (rightly) erase any LoopBreaker info;+--     we are about to re-generate it and it shouldn't be "sticky"+lookupLetOccInfo ud id+ | isExportedId id = noOccInfo+ | otherwise       = lookupOccInfoByUnique ud (idUnique id)++lookupOccInfo :: UsageDetails -> Id -> OccInfo+lookupOccInfo ud id = lookupOccInfoByUnique ud (idUnique id)++lookupOccInfoByUnique :: UsageDetails -> Unique -> OccInfo+lookupOccInfoByUnique (UD { ud_env       = env+                          , ud_z_many    = z_many+                          , ud_z_in_lam  = z_in_lam+                          , ud_z_tail    = z_tail })+                  uniq+  = case lookupVarEnv_Directly env uniq of+      Nothing -> IAmDead+      Just (OneOccL { lo_n_br = n_br, lo_int_cxt = int_cxt+                    , lo_tail = tail_info })+          | uniq `elemVarEnvByKey`z_many+          -> ManyOccs { occ_tail = mk_tail_info tail_info }+          | otherwise+          -> OneOcc { occ_in_lam  = in_lam+                    , occ_n_br    = n_br+                    , occ_int_cxt = int_cxt+                    , occ_tail    = mk_tail_info tail_info }+         where+           in_lam | uniq `elemVarEnvByKey` z_in_lam = IsInsideLam+                  | otherwise                       = NotInsideLam++      Just (ManyOccL tail_info) -> ManyOccs { occ_tail = mk_tail_info tail_info }+  where+    mk_tail_info ti+        | uniq `elemVarEnvByKey` z_tail = NoTailCallInfo+        | otherwise                     = ti++++-------------------+-- See Note [Adjusting right-hand sides]++adjustNonRecRhs :: JoinPointHood+                -> WithTailUsageDetails CoreExpr+                -> WithUsageDetails CoreExpr+-- ^ This function concentrates shared logic between occAnalNonRecBind and the+-- AcyclicSCC case of occAnalRec.+-- It returns the adjusted rhs UsageDetails combined with the body usage+adjustNonRecRhs mb_join_arity rhs_wuds@(WTUD _ rhs)+  = WUD (adjustTailUsage mb_join_arity rhs_wuds) rhs+++adjustTailUsage :: JoinPointHood+                -> WithTailUsageDetails CoreExpr    -- Rhs usage, AFTER occAnalLamTail+                -> UsageDetails+adjustTailUsage mb_join_arity (WTUD (TUD rhs_ja uds) rhs)+  = -- c.f. occAnal (Lam {})+    markAllInsideLamIf (not one_shot) $+    markAllNonTailIf (not exact_join) $+    uds+  where+    one_shot   = isOneShotFun rhs+    exact_join = mb_join_arity == JoinPoint rhs_ja++adjustTailArity :: JoinPointHood -> TailUsageDetails -> UsageDetails+adjustTailArity mb_rhs_ja (TUD ja usage)+  = markAllNonTailIf (mb_rhs_ja /= JoinPoint ja) usage++type IdWithOccInfo = Id++tagLamBinders :: UsageDetails        -- Of scope+              -> [Id]                -- Binders+              -> [IdWithOccInfo]     -- Tagged binders+tagLamBinders usage binders+  = map (tagLamBinder usage) binders++tagLamBinder :: UsageDetails       -- Of scope+             -> Id                 -- Binder+             -> IdWithOccInfo      -- Tagged binders+-- Used for lambda and case binders+-- No-op on TyVars+-- A lambda binder never has an unfolding, so no need to look for that+tagLamBinder usage bndr+  = setBinderOcc (markNonTail occ) bndr+      -- markNonTail: don't try to make an argument into a join point+  where+    occ = lookupOccInfo usage bndr++tagNonRecBinder :: TopLevelFlag           -- At top level?+                -> OccInfo                -- Of scope+                -> CoreBndr               -- Binder+                -> (IdWithOccInfo, JoinPointHood)  -- Tagged binder+-- No-op on TyVars+-- Precondition: OccInfo is not IAmDead+tagNonRecBinder lvl occ bndr+  | okForJoinPoint lvl bndr tail_call_info+  , AlwaysTailCalled ar <- tail_call_info+  = (setBinderOcc occ bndr,        JoinPoint ar)+  | otherwise+  = (setBinderOcc zapped_occ bndr, NotJoinPoint)+ where+    tail_call_info = tailCallInfo occ+    zapped_occ     = markNonTail occ++tagRecBinders :: TopLevelFlag           -- At top level?+              -> UsageDetails           -- Of body of let ONLY+              -> [NodeDetails]+              -> WithUsageDetails       -- Adjusted details for whole scope,+                                        -- with binders removed+                  [IdWithOccInfo]       -- Tagged binders+-- Substantially more complicated than non-recursive case. Need to adjust RHS+-- details *before* tagging binders (because the tags depend on the RHSes).+tagRecBinders lvl body_uds details_s+ = let+     bndrs = map nd_bndr details_s++     -- 1. See Note [Join arity prediction based on joinRhsArity]+     --    Determine possible join-point-hood of whole group, by testing for+     --    manifest join arity M.+     --    This (re-)asserts that makeNode had made tuds for that same arity M!+     unadj_uds = foldr (andUDs . test_manifest_arity) body_uds details_s+     test_manifest_arity ND{nd_rhs = WTUD tuds rhs}+       = adjustTailArity (JoinPoint (joinRhsArity rhs)) tuds++     will_be_joins = decideRecJoinPointHood lvl unadj_uds bndrs++     mb_join_arity :: Id -> JoinPointHood+     -- mb_join_arity: See Note [Join arity prediction based on joinRhsArity]+     -- This is the source O+     mb_join_arity bndr+         -- Can't use willBeJoinId_maybe here because we haven't tagged+         -- the binder yet (the tag depends on these adjustments!)+       | will_be_joins+       , AlwaysTailCalled arity <- lookupTailCallInfo unadj_uds bndr+       = JoinPoint arity+       | otherwise+       = assert (not will_be_joins) -- Should be AlwaysTailCalled if+         NotJoinPoint               -- we are making join points!++     -- 2. Adjust usage details of each RHS, taking into account the+     --    join-point-hood decision+     rhs_udss' = [ adjustTailUsage (mb_join_arity bndr) rhs_wuds+                     -- Matching occAnalLamTail in makeNode+                 | ND { nd_bndr = bndr, nd_rhs = rhs_wuds } <- details_s ]++     -- 3. Compute final usage details from adjusted RHS details+     adj_uds = foldr andUDs body_uds rhs_udss'++     -- 4. Tag each binder with its adjusted details+     bndrs'    = [ setBinderOcc (lookupLetOccInfo adj_uds bndr) bndr+                 | bndr <- bndrs ]++   in+   WUD adj_uds bndrs'++setBinderOcc :: OccInfo -> CoreBndr -> CoreBndr+setBinderOcc occ_info bndr+  | isTyVar bndr               = bndr+  | occ_info == idOccInfo bndr = bndr+  | otherwise                  = setIdOccInfo bndr occ_info++-- | Decide whether some bindings should be made into join points or not, based+-- on its occurrences. This is+-- Returns `False` if they can't be join points. Note that it's an+-- all-or-nothing decision, as if multiple binders are given, they're+-- assumed to be mutually recursive.+--+-- It must, however, be a final decision. If we say `True` for 'f',+-- and then subsequently decide /not/ make 'f' into a join point, then+-- the decision about another binding 'g' might be invalidated if (say)+-- 'f' tail-calls 'g'.+--+-- See Note [Invariants on join points] in "GHC.Core".+decideRecJoinPointHood :: TopLevelFlag -> UsageDetails+                       -> [CoreBndr] -> Bool+decideRecJoinPointHood lvl usage bndrs+  = all ok bndrs  -- Invariant 3: Either all are join points or none are+  where+    ok bndr = okForJoinPoint lvl bndr (lookupTailCallInfo usage bndr)++okForJoinPoint :: TopLevelFlag -> Id -> TailCallInfo -> Bool+    -- See Note [Invariants on join points]; invariants cited by number below.+    -- Invariant 2 is always satisfiable by the simplifier by eta expansion.+okForJoinPoint lvl bndr tail_call_info+  | isJoinId bndr        -- A current join point should still be one!+  = warnPprTrace lost_join "Lost join point" lost_join_doc $+    True+  | valid_join+  = True+  | otherwise+  = False+  where+    valid_join | NotTopLevel <- lvl+               , AlwaysTailCalled arity <- tail_call_info++               , -- Invariant 1 as applied to LHSes of rules+                 all (ok_rule arity) (idCoreRules bndr)++                 -- Invariant 2a: stable unfoldings+                  -- See Note [Join points and INLINE pragmas]+               , ok_unfolding arity (realIdUnfolding bndr)++                 -- Invariant 4: Satisfies polymorphism rule+               , isValidJoinPointType arity (idType bndr)+               = True+               | otherwise+               = False++    lost_join | JoinPoint ja <- idJoinPointHood bndr+              = not valid_join ||+                (case tail_call_info of  -- Valid join but arity differs+                   AlwaysTailCalled ja' -> ja /= ja'+                   _                    -> False)+              | otherwise = False++    ok_rule _ BuiltinRule{} = False -- only possible with plugin shenanigans+    ok_rule join_arity (Rule { ru_args = args })+      = args `lengthIs` join_arity+        -- Invariant 1 as applied to LHSes of rules++    -- ok_unfolding returns False if we should /not/ convert a non-join-id+    -- into a join-id, even though it is AlwaysTailCalled+    ok_unfolding join_arity (CoreUnfolding { uf_src = src, uf_tmpl = rhs })+      = not (isStableSource src && join_arity > joinRhsArity rhs)+    ok_unfolding _ (DFunUnfolding {})+      = False+    ok_unfolding _ _+      = True++    lost_join_doc+      = vcat [ text "bndr:" <+> ppr bndr+             , text "tc:" <+> ppr tail_call_info+             , text "rules:" <+> ppr (idCoreRules bndr)+             , case tail_call_info of+                 AlwaysTailCalled arity ->+                    vcat [ text "ok_unf:" <+> ppr (ok_unfolding arity (realIdUnfolding bndr))+                         , text "ok_type:" <+> ppr (isValidJoinPointType arity (idType bndr)) ]+                 _ -> empty ]++{- Note [Join points and INLINE pragmas]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+   f x = let g = \x. not  -- Arity 1+             {-# INLINE g #-}+         in case x of+              A -> g True True+              B -> g True False+              C -> blah2++Here 'g' is always tail-called applied to 2 args, but the stable+unfolding captured by the INLINE pragma has arity 1.  If we try to+convert g to be a join point, its unfolding will still have arity 1+(since it is stable, and we don't meddle with stable unfoldings), and+Lint will complain (see Note [Invariants on join points], (2a), in+GHC.Core.  #13413.++Moreover, since g is going to be inlined anyway, there is no benefit+from making it a join point.++If it is recursive, and uselessly marked INLINE, this will stop us+making it a join point, which is annoying.  But occasionally+(notably in class methods; see Note [Instances and loop breakers] in+GHC.Tc.TyCl.Instance) we mark recursive things as INLINE but the recursion+unravels; so ignoring INLINE pragmas on recursive things isn't good+either.++See Invariant 2a of Note [Invariants on join points] in GHC.Core+++************************************************************************+*                                                                      *+\subsection{Operations over OccInfo}+*                                                                      *+************************************************************************+-}++markNonTail :: OccInfo -> OccInfo+markNonTail IAmDead = IAmDead+markNonTail occ     = occ { occ_tail = NoTailCallInfo }++andLocalOcc :: LocalOcc -> LocalOcc -> LocalOcc+andLocalOcc occ1 occ2 = ManyOccL (tci1 `andTailCallInfo` tci2)+  where+    !tci1 = localTailCallInfo occ1+    !tci2 = localTailCallInfo occ2++orLocalOcc :: LocalOcc -> LocalOcc -> LocalOcc+-- (orLocalOcc occ1 occ2) is used+-- when combining occurrence info from branches of a case+orLocalOcc (OneOccL { lo_n_br = nbr1, lo_int_cxt = int_cxt1, lo_tail = tci1 })+           (OneOccL { lo_n_br = nbr2, lo_int_cxt = int_cxt2, lo_tail = tci2 })+  = OneOccL { lo_n_br    = nbr1 + nbr2+            , lo_int_cxt = int_cxt1 `mappend` int_cxt2+            , lo_tail    = tci1 `andTailCallInfo` tci2 }+orLocalOcc occ1 occ2 = andLocalOcc occ1 occ2  andTailCallInfo :: TailCallInfo -> TailCallInfo -> TailCallInfo andTailCallInfo info@(AlwaysTailCalled arity1) (AlwaysTailCalled arity2)
GHC/Core/Opt/Pipeline.hs view
@@ -10,27 +10,27 @@  import GHC.Prelude -import GHC.Driver.Session+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   ( mkRuleBase,-                          extendRuleBaseList, ruleCheckProgram, addRuleInfo,-                          getRules, initRuleOpts )-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, dumpIdInfoOfProgram )-import GHC.Core.Lint    ( endPass, lintPassResult, dumpPassResult,-                          lintAnnots )-import GHC.Core.Opt.Simplify       ( simplTopBinds, simplExpr, simplImpRules )-import GHC.Core.Opt.Simplify.Utils ( simplEnvForGHCi, activeRule, activeUnfolding )-import GHC.Core.Opt.Simplify.Env+import GHC.Core.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 )@@ -43,7 +43,7 @@ import GHC.Core.Opt.Exitify      ( exitifyProgram ) import GHC.Core.Opt.WorkWrap     ( wwTopBinds ) import GHC.Core.Opt.CallerCC     ( addCallerCostCentres )-import GHC.Core.LateCC           (addLateCostCentresMG)+import GHC.Core.LateCC.TopLevelBinds (topLevelBindsCCMG) import GHC.Core.Seq (seqBinds) import GHC.Core.FamInstEnv @@ -51,29 +51,19 @@ import GHC.Utils.Logger as Logger import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Utils.Constants (debugIsOn)-import GHC.Utils.Trace -import GHC.Unit.External-import GHC.Unit.Module.Env import GHC.Unit.Module.ModGuts-import GHC.Unit.Module.Deps -import GHC.Runtime.Context--import GHC.Types.Id import GHC.Types.Id.Info import GHC.Types.Basic import GHC.Types.Demand ( zapDmdEnvSig )-import GHC.Types.Var.Set-import GHC.Types.Var.Env-import GHC.Types.Tickish-import GHC.Types.Unique.FM import GHC.Types.Name.Ppr+import GHC.Types.Var ( Var )  import Control.Monad import qualified GHC.LanguageExtensions as LangExt import GHC.Unit.Module+ {- ************************************************************************ *                                                                      *@@ -85,14 +75,13 @@ 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 { let builtin_passes = getCoreToDo logger dflags-             orph_mods = mkModuleSet (mod : dep_orphs deps)-             uniq_mask = 's'-       ;-       ; (guts2, stats) <- runCoreM hsc_env hpt_rule_base uniq_mask mod-                                    orph_mods print_unqual loc $+  = 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@@ -106,12 +95,14 @@         ; return guts2 }   where-    logger         = hsc_logger hsc_env     dflags         = hsc_dflags hsc_env-    home_pkg_rules = hptRules hsc_env (moduleUnitId mod) (GWIB { gwib_mod = moduleName mod-                                                               , gwib_isBoot = NotBoot })-    hpt_rule_base  = mkRuleBase home_pkg_rules-    print_unqual   = mkPrintUnqualified (hsc_unit_env hsc_env) rdr_env+    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@@ -126,8 +117,9 @@ ************************************************************************ -} -getCoreToDo :: Logger -> DynFlags -> [CoreToDo]-getCoreToDo logger dflags+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@@ -147,8 +139,6 @@     late_specialise = gopt Opt_LateSpecialise             dflags     static_args   = gopt Opt_StaticArgumentTransformation dflags     rules_on      = gopt Opt_EnableRewriteRules           dflags-    eta_expand_on = gopt Opt_DoLambdaEtaExpansion         dflags-    pre_inline_on = gopt Opt_SimplPreInlining             dflags     ww_on         = gopt Opt_WorkerWrapper                dflags     static_ptrs   = xopt LangExt.StaticPointers           dflags     profiling     = ways dflags `hasWay` WayProf@@ -159,30 +149,15 @@     maybe_rule_check phase = runMaybe rule_check (CoreDoRuleCheck phase)      maybe_strictness_before (Phase phase)-      | phase `elem` strictnessBefore dflags = CoreDoDemand+      | phase `elem` strictnessBefore dflags = CoreDoDemand False     maybe_strictness_before _       = CoreDoNothing -    base_mode = SimplMode { sm_phase        = panic "base_mode"-                          , sm_names        = []-                          , sm_dflags       = dflags-                          , sm_logger       = logger-                          , sm_uf_opts      = unfoldingOpts dflags-                          , sm_rules        = rules_on-                          , sm_eta_expand   = eta_expand_on-                          , sm_cast_swizzle = True-                          , sm_inline       = True-                          , sm_case_case    = True-                          , sm_pre_inline   = pre_inline_on-                          }-     simpl_phase phase name iter       = CoreDoPasses       $   [ maybe_strictness_before phase-          , CoreDoSimplify iter-                (base_mode { sm_phase = phase-                           , sm_names = [name] })-+          , 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.@@ -190,18 +165,13 @@     simplify name = simpl_phase FinalPhase name max_iter      -- 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 InitialPhase]-                                  , sm_inline = True-                                              -- See Note [Inline in InitialPhase]-                                  , sm_case_case = False })-                          -- Don't do case-of-case transformations.-                          -- This makes full laziness work better+    -- 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,CoreDoCpr,CoreDoWorkerWrapper]-                          else [CoreDoDemand,CoreDoCpr]+    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 (@@ -215,11 +185,12 @@       runWhen static_ptrs $ CoreDoPasses         [ simpl_gently -- Float Out can't handle type lets (sometimes created                        -- by simpleOptPgm via mkParallelBindings)-        , CoreDoFloatOutwards FloatOutSwitches+        , CoreDoFloatOutwards $ FloatOutSwitches           { floatOutLambdas   = Just 0           , floatOutConstants = True           , floatOutOverSatApps = False           , floatToTopLevelOnly = True+          , floatJoinsToTop = False           }         ] @@ -245,13 +216,13 @@         runWhen do_specialise CoreDoSpecialising,          if full_laziness then-           CoreDoFloatOutwards FloatOutSwitches {-                                 floatOutLambdas   = Just 0,-                                 floatOutConstants = True,-                                 floatOutOverSatApps = False,-                                 floatToTopLevelOnly = False }-                -- Was: gentleFloatOutSwitches-                --+           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.                 --@@ -273,7 +244,7 @@            -- GHC.Iface.Tidy.StaticPtrTable.            static_ptrs_float_outwards, -        -- Run the simplier phases 2,1,0 to allow rewrite rules to fire+        -- 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] ] ++@@ -307,17 +278,19 @@         runWhen exitification CoreDoExitify,             -- See Note [Placement of the exitification pass] -        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)+        -- 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,@@ -340,7 +313,7 @@            [ CoreLiberateCase, simplify "post-liberate-case" ],            -- Run the simplifier after LiberateCase to vastly            -- reduce the possibility of shadowing-           -- Reason: see Note [Shadowing] in GHC.Core.Opt.SpecConstr+           -- Reason: see Note [Shadowing in SpecConstr] in GHC.Core.Opt.SpecConstr          runWhen spec_constr $ CoreDoPasses            [ CoreDoSpecConstr, simplify "post-spec-constr"],@@ -369,7 +342,7 @@         -- 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,+        runWhen (strictness || late_dmd_anal) (CoreDoDemand False),          maybe_rule_check FinalPhase, @@ -384,6 +357,15 @@       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@@ -437,7 +419,7 @@ with -O2 -flate-specialise  1.  I found that running late-Specialise after SpecConstr, with no-    simplification in between meant that the carefullly constructed+    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....@@ -477,6 +459,7 @@ doCorePass :: CoreToDo -> ModGuts -> CoreM ModGuts doCorePass pass guts = do   logger    <- getLogger+  hsc_env   <- getHscEnv   dflags    <- getDynFlags   us        <- getUniqueSupplyM   p_fam_env <- getPackageFamInstEnv@@ -484,16 +467,26 @@   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 {}         -> {-# SCC "Simplify" #-}-                                 simplifyPgm pass guts+    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 dflags)+                                 updateBinds (liberateCase (initLiberateCaseOpts dflags))      CoreDoFloatInwards        -> {-# SCC "FloatInwards" #-}                                  updateBinds (floatInwards platform)@@ -510,14 +503,16 @@     CoreDoExitify             -> {-# SCC "Exitify" #-}                                  updateBinds exitifyProgram -    CoreDoDemand              -> {-# SCC "DmdAnal" #-}-                                 updateBindsM (liftIO . dmdAnal logger dflags fam_envs (mg_rules guts))+    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 (mg_module guts) dflags fam_envs us)+                                 updateBinds (wwTopBinds+                                               (initWorkWrapOpts (mg_module guts) dflags fam_envs)+                                               us)      CoreDoSpecialising        -> {-# SCC "Specialise" #-}                                  specProgram guts@@ -529,7 +524,7 @@                                  addCallerCostCentres guts      CoreAddLateCcs            -> {-# SCC "AddLateCcs" #-}-                                 addLateCostCentresMG guts+                                 topLevelBindsCCMG guts      CoreDoPrintCore           -> {-# SCC "PrintCore" #-}                                  liftIO $ printCore logger (mg_binds guts) >> return guts@@ -545,7 +540,6 @@     CoreDesugarOpt            -> pprPanic "doCorePass" (ppr pass)     CoreTidy                  -> pprPanic "doCorePass" (ppr pass)     CorePrep                  -> pprPanic "doCorePass" (ppr pass)-    CoreOccurAnal             -> pprPanic "doCorePass" (ppr pass)  {- ************************************************************************@@ -565,521 +559,24 @@     logger <- getLogger     withTiming logger (text "RuleCheck"<+>brackets (ppr $ mg_module guts))                 (const ()) $ do-        rb <- getRuleBase-        vis_orphs <- getVisibleOrphanMods-        let rule_fn fn = getRules (RuleEnv [rb] vis_orphs) fn-                          ++ (mg_rules guts)-        let ropts = initRuleOpts dflags+        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 -{--************************************************************************-*                                                                      *-        Gentle simplification-*                                                                      *-************************************************************************--}--simplifyExpr :: HscEnv -- 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-simplifyExpr hsc_env expr-  = withTiming logger (text "Simplify [expr]") (const ()) $-    do  { eps <- hscEPS hsc_env ;-        ; let fi_env    = ( eps_fam_inst_env eps-                          , extendFamInstEnvList emptyFamInstEnv $-                            snd $ ic_instances $ hsc_IC hsc_env )-              simpl_env = simplEnvForGHCi logger dflags--        ; let sz = exprSize expr--        ; (expr', counts) <- initSmpl logger dflags (eps_rule_base <$> hscEPS hsc_env) emptyRuleEnv fi_env 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'-        }-  where-    dflags = hsc_dflags hsc_env-    logger = hsc_logger hsc_env--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}-*                                                                      *-************************************************************************--}--simplifyPgm :: CoreToDo -> ModGuts -> CoreM ModGuts-simplifyPgm pass guts-  = do { hsc_env <- getHscEnv-       ; rb <- getRuleBase-       ; liftIOWithCount $-         simplifyPgmIO pass hsc_env rb guts }--simplifyPgmIO :: CoreToDo-              -> HscEnv-              -> RuleBase-              -> ModGuts-              -> IO (SimplCount, ModGuts)  -- New bindings--simplifyPgmIO pass@(CoreDoSimplify max_iterations mode)-              hsc_env 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 1 [] binds 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-    dflags       = hsc_dflags hsc_env-    logger       = hsc_logger hsc_env-    print_unqual = mkPrintUnqualified (hsc_unit_env hsc_env) rdr_env-    simpl_env    = mkSimplEnv mode-    active_rule  = activeRule mode-    active_unf   = activeUnfolding mode--    do_iteration :: Int --UniqSupply-                --  -> Int          -- Counts iterations-                 -> [SimplCount] -- Counts from earlier iterations, reversed-                 -> CoreProgram  -- Bindings in-                 -> [CoreRule]   -- and orphan rules-                 -> IO (String, Int, SimplCount, ModGuts)--    do_iteration 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-      = 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 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 { tagged_binds = {-# SCC "OccAnal" #-}-                     occurAnalysePgm this_mod active_unf active_rule 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 rules we read on the EPS-                -- value and then combine it when the existing rule base.-                -- See `GHC.Core.Opt.Simplify.Monad.getSimplRules`.-           eps <- hscEPS hsc_env ;-           let  { read_eps_rules = eps_rule_base <$> hscEPS hsc_env-                ; rule_base = extendRuleBaseList hpt_rule_base rules-                ; fam_envs = (eps_fam_inst_env eps, fam_inst_env)-                ; vis_orphs = this_mod : dep_orphs deps } ;--                -- Simplify the program-           ((binds1, rules1), counts1) <--             initSmpl logger dflags read_eps_rules (mkRuleEnv rule_base vis_orphs) fam_envs 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 rules--                  ; return (getTopFloatBinds floats, rules1) } ;--                -- Stop if nothing happened; don't dump output-                -- See Note [Which transformations are innocuous] in GHC.Core.Opt.Monad-           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-           let { dump_core_sizes = not (gopt Opt_SuppressCoreSizes dflags) } ;-           dump_end_iteration logger dump_core_sizes print_unqual iteration_no counts1 binds2 rules1 ;-           lintPassResult hsc_env pass binds2 ;--                -- Loop-           do_iteration (iteration_no + 1) (counts1:counts_so_far) binds2 rules1-           } }-#if __GLASGOW_HASKELL__ <= 810-      | otherwise = panic "do_iteration"-#endif-      where-        -- 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 :: Logger -> Bool -> PrintUnqualified -> Int-                   -> SimplCount -> CoreProgram -> [CoreRule] -> IO ()-dump_end_iteration logger dump_core_sizes print_unqual iteration_no counts binds rules-  = dumpPassResult logger dump_core_sizes print_unqual mb_flag hdr pp_counts binds rules-  where-    mb_flag | logHasDumpFlag logger Opt_D_dump_simpl_iterations = Just Opt_D_dump_simpl_iterations-            | otherwise                                         = Nothing-            -- Show details if Opt_D_dump_simpl_iterations is on--    hdr = "Simplifier iteration=" ++ show iteration_no-    pp_counts = vcat [ text "---- Simplifier counts for" <+> text hdr-                     , pprSimplCount counts-                     , text "---- End of simplifier counts for" <+> text hdr ]--{--************************************************************************-*                                                                      *-                Shorting out indirections-*                                                                      *-************************************************************************--If we have this:--        x_local = <expression>-        ...bindings...-        x_exported = x_local--where x_exported is exported, and x_local is not, then we replace it with this:--        x_exported = <expression>-        x_local = x_exported-        ...bindings...--Without this we never get rid of the x_exported = x_local thing.  This-save a gratuitous jump (from \tr{x_exported} to \tr{x_local}), and-makes strictness information propagate better.  This used to happen in-the final phase, but it's tidier to do it here.--Note [Messing up the exported Id's RULES]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We must be careful about discarding (obviously) or even merging the-RULES on the exported Id. The example that went bad on me at one stage-was this one:--    iterate :: (a -> a) -> a -> [a]-        [Exported]-    iterate = iterateList--    iterateFB c f x = x `c` iterateFB c f (f x)-    iterateList f x =  x : iterateList f (f x)-        [Not exported]--    {-# RULES-    "iterate"   forall f x.     iterate f x = build (\c _n -> iterateFB c f x)-    "iterateFB"                 iterateFB (:) = iterateList-     #-}--This got shorted out to:--    iterateList :: (a -> a) -> a -> [a]-    iterateList = iterate--    iterateFB c f x = x `c` iterateFB c f (f x)-    iterate f x =  x : iterate f (f x)--    {-# RULES-    "iterate"   forall f x.     iterate f x = build (\c _n -> iterateFB c f x)-    "iterateFB"                 iterateFB (:) = iterate-     #-}--And now we get an infinite loop in the rule system-        iterate f x -> build (\cn -> iterateFB c f x)-                    -> iterateFB (:) f x-                    -> iterate f x--Old "solution":-        use rule switching-off pragmas to get rid-        of iterateList in the first place--But in principle the user *might* want rules that only apply to the Id-they say.  And inline pragmas are similar-   {-# NOINLINE f #-}-   f = local-   local = <stuff>-Then we do not want to get rid of the NOINLINE.--Hence hasShortableIdinfo.---Note [Rules and indirection-zapping]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Problem: what if x_exported has a RULE that mentions something in ...bindings...?-Then the things mentioned can be out of scope!  Solution- a) Make sure that in this pass the usage-info from x_exported is-        available for ...bindings...- b) If there are any such RULES, rec-ify the entire top-level.-    It'll get sorted out next time round--Other remarks-~~~~~~~~~~~~~-If more than one exported thing is equal to a local thing (i.e., the-local thing really is shared), then we do one only:-\begin{verbatim}-        x_local = ....-        x_exported1 = x_local-        x_exported2 = x_local-==>-        x_exported1 = ....--        x_exported2 = x_exported1-\end{verbatim}--We rely on prior eta reduction to simplify things like-\begin{verbatim}-        x_exported = /\ tyvars -> x_local tyvars-==>-        x_exported = x_local-\end{verbatim}-Hence,there's a possibility of leaving unchanged something like this:-\begin{verbatim}-        x_local = ....-        x_exported1 = x_local Int-\end{verbatim}-By the time we've thrown away the types in STG land this-could be eliminated.  But I don't think it's very common-and it's dangerous to do this fiddling in STG land-because we might eliminate a binding that's mentioned in the-unfolding for something.--Note [Indirection zapping and ticks]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Unfortunately this is another place where we need a special case for-ticks. The following happens quite regularly:--        x_local = <expression>-        x_exported = tick<x> x_local--Which we want to become:--        x_exported =  tick<x> <expression>--As it makes no sense to keep the tick and the expression on separate-bindings. Note however that this might increase the ticks scoping-over the execution of x_local, so we can only do this for floatable-ticks. More often than not, other references will be unfoldings of-x_exported, and therefore carry the tick anyway.--}--type IndEnv = IdEnv (Id, [CoreTickish]) -- Maps local_id -> exported_id, ticks--shortOutIndirections :: CoreProgram -> CoreProgram-shortOutIndirections binds-  | isEmptyVarEnv ind_env = binds-  | no_need_to_flatten    = binds'                      -- See Note [Rules and indirection-zapping]-  | otherwise             = [Rec (flattenBinds binds')] -- for this no_need_to_flatten stuff-  where-    ind_env            = makeIndEnv binds-    -- These exported Ids are the subjects  of the indirection-elimination-    exp_ids            = map fst $ nonDetEltsUFM ind_env-      -- It's OK to use nonDetEltsUFM here because we forget the ordering-      -- by immediately converting to a set or check if all the elements-      -- satisfy a predicate.-    exp_id_set         = mkVarSet exp_ids-    no_need_to_flatten = all (null . ruleInfoRules . idSpecialisation) exp_ids-    binds'             = concatMap zap binds--    zap (NonRec bndr rhs) = [NonRec b r | (b,r) <- zapPair (bndr,rhs)]-    zap (Rec pairs)       = [Rec (concatMap zapPair pairs)]--    zapPair (bndr, rhs)-        | bndr `elemVarSet` exp_id_set-        = []   -- Kill the exported-id binding--        | Just (exp_id, ticks) <- lookupVarEnv ind_env bndr-        , (exp_id', lcl_id') <- transferIdInfo exp_id bndr-        =      -- Turn a local-id binding into two bindings-               --    exp_id = rhs; lcl_id = exp_id-          [ (exp_id', mkTicks ticks rhs),-            (lcl_id', Var exp_id') ]--        | otherwise-        = [(bndr,rhs)]--makeIndEnv :: [CoreBind] -> IndEnv-makeIndEnv binds-  = foldl' add_bind emptyVarEnv binds-  where-    add_bind :: IndEnv -> CoreBind -> IndEnv-    add_bind env (NonRec exported_id rhs) = add_pair env (exported_id, rhs)-    add_bind env (Rec pairs)              = foldl' add_pair env pairs--    add_pair :: IndEnv -> (Id,CoreExpr) -> IndEnv-    add_pair env (exported_id, exported)-        | (ticks, Var local_id) <- stripTicksTop tickishFloatable exported-        , shortMeOut env exported_id local_id-        = extendVarEnv env local_id (exported_id, ticks)-    add_pair env _ = env--------------------shortMeOut :: IndEnv -> Id -> Id -> Bool-shortMeOut ind_env exported_id local_id--- The if-then-else stuff is just so I can get a pprTrace to see--- how often I don't get shorting out because of IdInfo stuff-  = if isExportedId exported_id &&              -- Only if this is exported--       isLocalId local_id &&                    -- Only if this one is defined in this-                                                --      module, so that we *can* change its-                                                --      binding to be the exported thing!--       not (isExportedId local_id) &&           -- Only if this one is not itself exported,-                                                --      since the transformation will nuke it--       not (local_id `elemVarEnv` ind_env)      -- Only if not already substituted for-    then-        if hasShortableIdInfo exported_id-        then True       -- See Note [Messing up the exported Id's RULES]-        else warnPprTrace True "Not shorting out" (ppr exported_id) False-    else-        False--------------------hasShortableIdInfo :: Id -> Bool--- True if there is no user-attached IdInfo on exported_id,--- so we can safely discard it--- See Note [Messing up the exported Id's RULES]-hasShortableIdInfo id-  =  isEmptyRuleInfo (ruleInfo info)-  && isDefaultInlinePragma (inlinePragInfo info)-  && not (isStableUnfolding (realUnfoldingInfo info))-  where-     info = idInfo id--------------------{- Note [Transferring IdInfo]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If we have-     lcl_id = e; exp_id = lcl_id--and lcl_id has useful IdInfo, we don't want to discard it by going-     gbl_id = e; lcl_id = gbl_id--Instead, transfer IdInfo from lcl_id to exp_id, specifically-* (Stable) unfolding-* Strictness-* Rules-* Inline pragma--Overwriting, rather than merging, seems to work ok.--For the lcl_id we--* Zap the InlinePragma. It might originally have had a NOINLINE, which-  we have now transferred; and we really want the lcl_id to inline now-  that its RHS is trivial!--* Zap any Stable unfolding.  agian, we want lcl_id = gbl_id to inline,-  replacing lcl_id by gbl_id. That won't happen if lcl_id has its original-  great big Stable unfolding--}--transferIdInfo :: Id -> Id -> (Id, Id)--- See Note [Transferring IdInfo]-transferIdInfo exported_id local_id-  = ( modifyIdInfo transfer exported_id-    , modifyIdInfo zap_info local_id )-  where-    local_info = idInfo local_id-    transfer exp_info = exp_info `setDmdSigInfo`     dmdSigInfo local_info-                                 `setCprSigInfo`     cprSigInfo local_info-                                 `setUnfoldingInfo`  realUnfoldingInfo local_info-                                 `setInlinePragInfo` inlinePragInfo local_info-                                 `setRuleInfo`       addRuleInfo (ruleInfo exp_info) new_info-    new_info = setRuleInfoHead (idName exported_id)-                               (ruleInfo local_info)-        -- Remember to set the function-name field of the-        -- rules as we transfer them from one function to another--    zap_info lcl_info = lcl_info `setInlinePragInfo` defaultInlinePragma-                                 `setUnfoldingInfo`  noUnfolding---dmdAnal :: Logger -> DynFlags -> FamInstEnvs -> [CoreRule] -> CoreProgram -> IO CoreProgram-dmdAnal logger dflags fam_envs rules binds = do+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_str_signatures "Strictness signatures" FormatText $+  Logger.putDumpFileMaybe logger Opt_D_dump_dmd_signatures "Demand signatures" FormatText $     dumpIdInfoOfProgram (hasPprDebug dflags) (ppr . zapDmdEnvSig . dmdSigInfo) binds_plus_dmds   -- See Note [Stamp out space leaks in demand analysis] in GHC.Core.Opt.DmdAnal   seqBinds binds_plus_dmds `seq` return binds_plus_dmds
+ GHC/Core/Opt/Pipeline/Types.hs view
@@ -0,0 +1,103 @@+module GHC.Core.Opt.Pipeline.Types (+    -- * Configuration of the core-to-core passes+    CorePluginPass, CoreToDo(..),+    bindsOnlyPass, pprPassDetails,+  ) where++import GHC.Prelude++import GHC.Core ( CoreProgram )+import GHC.Core.Opt.Monad ( CoreM, FloatOutSwitches )+import GHC.Core.Opt.Simplify ( SimplifyOpts(..) )++import GHC.Types.Basic  ( CompilerPhase(..) )+import GHC.Unit.Module.ModGuts+import GHC.Utils.Outputable as Outputable++{-+************************************************************************+*                                                                      *+              The CoreToDo type and related types+          Abstraction of core-to-core passes to run.+*                                                                      *+************************************************************************+-}++-- | A description of the plugin pass itself+type CorePluginPass = ModGuts -> CoreM ModGuts++bindsOnlyPass :: (CoreProgram -> CoreM CoreProgram) -> ModGuts -> CoreM ModGuts+bindsOnlyPass pass guts+  = do { binds' <- pass (mg_binds guts)+       ; return (guts { mg_binds = binds' }) }++data CoreToDo           -- These are diff core-to-core passes,+                        -- which may be invoked in any order,+                        -- as many times as you like.++  = CoreDoSimplify !SimplifyOpts+  -- ^ The core-to-core simplifier.+  | CoreDoPluginPass String CorePluginPass+  | CoreDoFloatInwards+  | CoreDoFloatOutwards FloatOutSwitches+  | CoreLiberateCase+  | CoreDoPrintCore+  | CoreDoStaticArgs+  | CoreDoCallArity+  | CoreDoExitify+  | CoreDoDemand Bool  -- Bool: Do worker/wrapper afterwards?+                       -- See Note [Don't change boxity without worker/wrapper]+  | CoreDoCpr+  | CoreDoWorkerWrapper+  | CoreDoSpecialising+  | CoreDoSpecConstr+  | CoreCSE+  | CoreDoRuleCheck CompilerPhase String   -- Check for non-application of rules+                                           -- matching this string+  | CoreDoNothing                -- Useful when building up+  | CoreDoPasses [CoreToDo]      -- lists of these things++  | CoreDesugar    -- Right after desugaring, no simple optimisation yet!+  | CoreDesugarOpt -- CoreDesugarXXX: Not strictly a core-to-core pass, but produces+                       --                 Core output, and hence useful to pass to endPass++  | CoreTidy+  | CorePrep+  | CoreAddCallerCcs+  | CoreAddLateCcs++instance Outputable CoreToDo where+  ppr (CoreDoSimplify _)       = text "Simplifier"+  ppr (CoreDoPluginPass s _)   = text "Core plugin: " <+> text s+  ppr CoreDoFloatInwards       = text "Float inwards"+  ppr (CoreDoFloatOutwards f)  = text "Float out" <> parens (ppr f)+  ppr CoreLiberateCase         = text "Liberate case"+  ppr CoreDoStaticArgs         = text "Static argument"+  ppr CoreDoCallArity          = text "Called arity analysis"+  ppr CoreDoExitify            = text "Exitification transformation"+  ppr (CoreDoDemand True)      = text "Demand analysis (including Boxity)"+  ppr (CoreDoDemand False)     = text "Demand analysis"+  ppr CoreDoCpr                = text "Constructed Product Result analysis"+  ppr CoreDoWorkerWrapper      = text "Worker Wrapper binds"+  ppr CoreDoSpecialising       = text "Specialise"+  ppr CoreDoSpecConstr         = text "SpecConstr"+  ppr CoreCSE                  = text "Common sub-expression"+  ppr CoreDesugar              = text "Desugar (before optimization)"+  ppr CoreDesugarOpt           = text "Desugar (after optimization)"+  ppr CoreTidy                 = text "Tidy Core"+  ppr CoreAddCallerCcs         = text "Add caller cost-centres"+  ppr CoreAddLateCcs           = text "Add late core cost-centres"+  ppr CorePrep                 = text "CorePrep"+  ppr CoreDoPrintCore          = text "Print core"+  ppr (CoreDoRuleCheck {})     = text "Rule check"+  ppr CoreDoNothing            = text "CoreDoNothing"+  ppr (CoreDoPasses passes)    = text "CoreDoPasses" <+> ppr passes++pprPassDetails :: CoreToDo -> SDoc+pprPassDetails (CoreDoSimplify cfg) = vcat [ text "Max iterations =" <+> int n+                                           , ppr md ]+  where+    n = so_iterations cfg+    md = so_mode cfg++pprPassDetails _ = Outputable.empty
GHC/Core/Opt/SetLevels.hs view
@@ -1,4 +1,3 @@- {-# LANGUAGE PatternSynonyms #-}  {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}@@ -16,7 +15,7 @@    outwards (@FloatOut@).  2. We also let-ify many expressions (notably case scrutinees), so they-   will have a fighting chance of being floated sensible.+   will have a fighting chance of being floated sensibly.  3. Note [Need for cloning during float-out]    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -45,30 +44,39 @@         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.+   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. -  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.+   For example, consider: -  This can only work if @wild@ is an unrestricted binder. Indeed, even with the-  extended typing rule (in the linter) for case expressions, if-       case x of wild % 1 { p -> e}-  is well-typed, then-       case x of wild % 1 { p -> e[wild\x] }-  is only well-typed if @e[wild\x] = e@ (that is, if @wild@ is not used in @e@-  at all). In which case, it is, of course, pointless to do the substitution-  anyway. So for a linear binder (and really anything which isn't unrestricted),-  doing this substitution would either produce ill-typed terms or be the-  identity.+      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(..), LevelType(..), tOP_LEVEL, isJoinCeilLvl, asJoinCeilLvl,+        Level(..), tOP_LEVEL,         LevelledBind, LevelledExpr, LevelledBndr,         FloatSpec(..), floatSpecLevel, @@ -79,22 +87,16 @@  import GHC.Core import GHC.Core.Opt.Monad ( FloatOutSwitches(..) )-import GHC.Core.Utils   ( exprType, exprIsHNF-                        , exprOkForSpeculation-                        , exprIsTopLevelBindable-                        , collectMakeStaticArgs-                        , mkLamTypes-                        )-import GHC.Core.Opt.Arity   ( exprBotStrictness_maybe )+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, splitTyConApp_maybe, tyCoVarsOfType+import GHC.Core.Type    ( Type, tyCoVarsOfType                         , mightBeUnliftedType, closeOverKindsDSet                         , typeHasFixedRuntimeRep                         )-import GHC.Core.Multiplicity     ( pattern Many )-import GHC.Core.DataCon ( dataConOrigResTy )+import GHC.Core.Multiplicity     ( pattern ManyTy )  import GHC.Types.Id import GHC.Types.Id.Info@@ -104,10 +106,10 @@ import GHC.Types.Unique.DSet  ( getUniqDSet ) import GHC.Types.Var.Env import GHC.Types.Literal      ( litIsTrivial )-import GHC.Types.Demand       ( DmdSig, Demand, isStrUsedDmd, splitDmdSig, prependArgsDmdSig )-import GHC.Types.Cpr          ( mkCprSig, botCpr )+import GHC.Types.Demand       ( DmdSig, prependArgsDmdSig )+import GHC.Types.Cpr          ( CprSig, prependArgsCprSig ) import GHC.Types.Name         ( getOccName, mkSystemVarName )-import GHC.Types.Name.Occurrence ( occNameString )+import GHC.Types.Name.Occurrence ( occNameFS ) import GHC.Types.Unique       ( hasKey ) import GHC.Types.Tickish      ( tickishIsCode ) import GHC.Types.Unique.Supply@@ -120,12 +122,9 @@ import GHC.Data.FastString  import GHC.Utils.FV-import GHC.Utils.Monad  ( mapAccumLM ) import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Utils.Panic.Plain-import GHC.Utils.Trace  import Data.Maybe @@ -145,8 +144,6 @@                    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@@ -185,7 +182,6 @@ 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:@@ -212,25 +208,6 @@ 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@@ -238,44 +215,37 @@   ppr (StayPut l) = ppr l  tOP_LEVEL :: Level-tOP_LEVEL   = Level 0 0 BndrLvl+tOP_LEVEL   = Level 0 0  incMajorLvl :: Level -> Level-incMajorLvl (Level major _ _) = Level (major + 1) 0 BndrLvl+incMajorLvl (Level major _) = Level (major + 1) 0  incMinorLvl :: Level -> Level-incMinorLvl (Level major minor _) = Level major (minor+1) BndrLvl--asJoinCeilLvl :: Level -> Level-asJoinCeilLvl (Level major minor _) = Level major minor JoinCeilLvl+incMinorLvl (Level major minor) = Level major (minor+1)  maxLvl :: Level -> Level -> Level-maxLvl l1@(Level maj1 min1 _) l2@(Level maj2 min2 _)+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 _)+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+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+isTopLvl (Level 0 0) = True+isTopLvl _           = False  instance Outputable Level where-  ppr (Level maj min typ)-    = hcat [ char '<', int maj, char ',', int min, char '>'-           , ppWhen (typ == JoinCeilLvl) (char 'C') ]+  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+  (Level maj1 min1) == (Level maj2 min2) = maj1 == maj2 && min1 == min2  {- ************************************************************************@@ -317,7 +287,7 @@ --     there is no need call substAndLvlBndrs here lvl_top env is_rec bndr rhs   = do { rhs' <- lvlRhs env is_rec (isDeadEndId bndr)-                                   Nothing  -- Not a join point+                                   NotJoinPoint                                    (freeVars rhs)        ; return (stayPut tOP_LEVEL bndr, rhs') } @@ -364,7 +334,7 @@ If there were another lambda in @r@'s rhs, it would get level-2 as well. -} -lvlExpr env (_, AnnType ty)     = return (Type (GHC.Core.Subst.substTy (le_subst env) ty))+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)@@ -417,7 +387,7 @@                -> CoreExprWithFVs      -- Input expression                -> LvlM LevelledExpr    -- Result expression lvlNonTailExpr env expr-  = lvlExpr (placeJoinCeiling env) expr+  = lvlExpr env expr  ------------------------------------------- lvlApp :: LevelEnv@@ -440,21 +410,13 @@         ; return (foldl' App lapp' rargs') }    | otherwise-  = do { (_, args') <- mapAccumLM lvl_arg stricts args-            -- Take account of argument strictness; see-            -- Note [Floating to the top]+  = 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 -    stricts :: [Demand]   -- True for strict /value/ arguments-    stricts = case splitDmdSig (idDmdSig fn) of-                (arg_ds, _) | arg_ds `lengthExceeds` n_val_args-                            -> []-                            | otherwise-                            -> arg_ds-     -- 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.@@ -466,19 +428,6 @@        | otherwise               = left n     f (a:rargs)     left _ _ _                   = panic "GHC.Core.Opt.SetLevels.lvlExpr.left" -    is_val_arg :: CoreExprWithFVs -> Bool-    is_val_arg (_, AnnType {}) = False-    is_val_arg _               = True--    lvl_arg :: [Demand] -> CoreExprWithFVs -> LvlM ([Demand], LevelledExpr)-    lvl_arg strs arg | (str1 : strs') <- strs-                     , is_val_arg arg-                     = do { arg' <- lvlMFE env (isStrUsedDmd str1) arg-                          ; return (strs', arg') }-                     | otherwise-                     = do { arg' <- lvlMFE env False arg-                          ; return (strs, arg') }- lvlApp env _ (fun, args)   =  -- No PAPs that we can float: just carry on with the      -- arguments and the function.@@ -499,7 +448,7 @@   , 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-  , Many <- idMult case_bndr     -- See Note [Floating linear case]+  , 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)@@ -514,7 +463,7 @@        ; alts' <- mapM (lvl_alt alts_env) alts        ; return (Case scrut' case_bndr' ty' alts') }   where-    ty' = substTy (le_subst env) ty+    ty' = substTyUnchecked (le_subst env) ty      incd_lvl = incMinorLvl (le_ctxt_lvl env)     dest_lvl = maxFvLevel (const True) env scrut_fvs@@ -550,7 +499,7 @@   * The test we perform is exprIsHNF, and /not/ exprOkForSpeculation. -     - exrpIsHNF catches the key case of an evaluated variable+     - 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@@ -635,7 +584,7 @@               -> CoreExprWithFVs      -- input expression               -> LvlM LevelledExpr    -- Result expression lvlNonTailMFE env strict_ctxt ann_expr-  = lvlMFE (placeJoinCeiling 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]@@ -645,7 +594,7 @@ -- the expression, so that it can itself be floated.  lvlMFE env _ (_, AnnType ty)-  = return (Type (GHC.Core.Subst.substTy (le_subst env) 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@@ -665,7 +614,9 @@   = lvlExpr env e     -- See Note [Case MFEs]  lvlMFE env strict_ctxt ann_expr-  |  floatTopLvlOnly env && not (isTopLvl dest_lvl)+  |  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]@@ -673,20 +624,16 @@          -- We can't let-bind an expression if we don't know          -- how it will be represented at runtime.          -- See Note [Representation polymorphism invariants] in GHC.Core-  || notWorthFloating expr abs_vars-  || not float_me-  =     -- Don't float it out+  = -- 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+                              is_bot_lam NotJoinPoint ann_expr                   -- Treat the expr just like a right-hand side-       ; var <- newLvlVar expr1 join_arity_maybe is_mk_static+       ; 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)) }@@ -698,21 +645,20 @@   | 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]+  , 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) dc_res_ty-                             [Alt DEFAULT [] (mkConApp dc [Var ubx_bndr])]+                         Case expr1 (stayPut l1r ubx_bndr) box_ty+                             [Alt DEFAULT [] (App boxing_expr (Var ubx_bndr))] -       ; var <- newLvlVar float_rhs Nothing is_mk_static+       ; 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 dc) [stayPut l1u ubx_bndr] (Var ubx_bndr)]+                             [Alt (DataAlt box_dc) [stayPut l1u ubx_bndr] (Var ubx_bndr)]        ; return (Let (NonRec (TB var (FloatMe dest_lvl)) float_rhs)                      use_expr) } @@ -724,14 +670,16 @@     expr_ty      = exprType expr     fvs          = freeVarsOf ann_expr     fvs_ty       = tyCoVarsOfType expr_ty-    is_bot       = isBottomThunk mb_bot_str+    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-    dest_lvl     = destLevel env fvs fvs_ty is_function is_bot False-    abs_vars     = abstractVars dest_lvl env fvs+    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@@ -743,27 +691,28 @@      (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 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 -    -- 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-+    -- 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 [Escaping a value lambda] -    -- See Note [Floating to the top]+    -- See Note [Saving allocation] and Note [Floating to the top]     saves_alloc =  isTopLvl dest_lvl                 && floatConsts env-                && (not strict_ctxt || is_bot || exprIsHNF expr)+                && (   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.@@ -773,61 +722,147 @@ hasFreeJoin env fvs   = not (maxFvLevel isJoinId env fvs == tOP_LEVEL) -isBottomThunk :: Maybe (Arity, s) -> Bool--- See Note [Bottoming floats] (2)-isBottomThunk (Just (0, _)) = True   -- Zero arity-isBottomThunk _             = False+{- 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]. -{- 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:+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 -  * 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.+Wrinkles: -  * (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.+(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. -But do not so if:-     - the context is a strict, and-     - the expression is not a HNF, and-     - the expression is not bottoming+(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. -Exammples:+      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. -* Bottoming-      f x = case x of-              0 -> error <big thing>-              _ -> x+1-  Here we want to float (error <big thing>) to top level, abstracting-  over 'x', so as to make f's RHS smaller.+(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. -* 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.+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: -* Case scrutinee+* 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. -* Case alternative+* (a) Strict.  Case alternative       h = case y of              True  -> g True              False -> False   Don't float (g True) to the top level +* (b) HNF+      f = case y of+            True  -> p:q+            False -> blah+  We may as well float the (p:q) so it becomes a static data structure.++* (c) Bottoming expressions; see also Note [Bottoming floats]+      f x = case x of+              0 -> error <big thing>+              _ -> x+1+  Here we want to float (error <big thing>) to top level, abstracting+  over 'x', so as to make f's RHS smaller.++  But (#22494) if it's more like+       foo = case error <thing> of { ... }+  then there is no point in floating; we are never going to inline+  'foo' anyway.  So float bottoming things only if they escape+  a lambda.+ * Arguments      t = f (g True)-  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 idDmdSig in lvlApp).  It's not clear-  if this test is worth the bother: it's only about CAFs!+  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@@ -836,23 +871,76 @@  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 (#13286).+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.  So ok, let's do it.+of the resulting inlining of f. +Another reason for floating join points to the top. spectral/minimax has:+    prog input = join $j y = <expensive> in+                 case (input == "doesnt happen") of+                   True  -> $j (testBoard + testBoard)+                   False -> $j testBoard+Now, iff we float $j to the top, we can /also/ float ($j (tb+tb)) and ($j tb).+Result: asymptotic improvement in perf, if `prof` is called many times.++However there are also bad consequences of floating join points to the top:++* If a continuation consumes (let $j x = Just x in case y of {...})+  we may get much less duplication of the continuation if we don't+  float $j to the top, because the contination goes into $j's RHS++* See #21392 for an example of how demand analysis can get worse if you+  float a join point to the top level.++Compromise (determined experimentally):++* Always float /recursive/ join points to the top.++* For /non-recursive/ join points, float them to the top in the second+  invocation of FloatOut, near the end of the pipeline.  This is controlled by+  the FloatOutSwitch floatJoinsToTop.++Missed opportunity+------------------+There is another benfit of floating local join points.  Stream fusion+has been known to produce nested loops like this:++  joinrec j1 x1 =+    joinrec j2 x2 =+      joinrec j3 x3 = ... jump j1 (x3 + 1) ... jump j2 (x3 + 1) ...+      in jump j3 x2+    in jump j2 x1+  in jump j1 x++(Assume x1 and x2 do *not* occur free in j3.)++Here j1 and j2 are wholly superfluous---each of them merely forwards its+argument to j3. Since j3 only refers to x3, we can float j2 and j3 to make+everything one big mutual recursion:++  joinrec j1 x1 = jump j2 x1+          j2 x2 = jump j3 x2+          j3 x3 = ... jump j1 (x3 + 1) ... jump j2 (x3 + 1) ...+  in jump j1 x++Now the simplifier will happily inline the trivial j1 and j2, leaving only j3.+Without floating, we're stuck with three loops instead of one.++Currently we don't do this -- a missed opportunity.+ Note [Free join points] ~~~~~~~~~~~~~~~~~~~~~~~ We never float a MFE that has a free join-point variable.  You might think@@ -912,15 +1000,15 @@ 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)+     let x = 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+     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/app invariant is to use the same function!+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.@@ -947,7 +1035,7 @@ (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:+    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@@ -956,6 +1044,12 @@     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)...@@ -966,13 +1060,18 @@     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)+       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). @@ -997,16 +1096,6 @@     thing is based on the cheap-and-cheerful exprIsDeadEnd, 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 GHC.Core.Opt.SetLevels because it works over a decorated form of-CoreExpr.  So we do the eta expansion later, in GHC.Core.Opt.FloatOut.-But we should only eta-expand if the RHS doesn't already have the right-exprArity, otherwise we get unnecessary top-level bindings if the RHS was-trivial after the next run of the Simplifier.- Note [Case MFEs] ~~~~~~~~~~~~~~~~ We don't float a case expression as an MFE from a strict context.  Why not?@@ -1025,129 +1114,160 @@ 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) -> Id+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_str-  = case mb_str of-      Nothing           -> id-      Just (arity, sig) -> id `setIdArity`      (arity + n_extra)-                              `setIdDmdSig` (prependArgsDmdSig n_extra sig)-                              `setIdCprSig`    mkCprSig (arity + n_extra) botCpr+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--- 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)!-+--  See Note [notWorthFloating] notWorthFloating e abs_vars-  = go e (count isId abs_vars)+  = go e 0   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+    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-       -- See Note [Floating applications to coercions]-       | Type {} <- arg = go e n-       | n==0           = False-       | is_triv arg    = go e (n-1)-       | otherwise      = False-    go _ _              = False+       | 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 -    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   -- See Note [Floating applications to coercions]-    is_triv (Tick t e)            = not (tickishIsCode t) && is_triv e-    is_triv _                     = 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) -{--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.+    go _ _ = False  -- Let etc is worth floating -Ditto literal strings (LitString), which we'd like to float to top-level, which is now possible.+{- 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)! -Note [Floating applications to coercions]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-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 [Count coercion arguments in boring contexts] in-"GHC.Core.Unfold"), so we still want to float out variables applied only to-coercion arguments.+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) -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.+(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. -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.+  Ditto literal strings (LitString), which we'd like to float to top+  level, which is now possible. -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.+(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. -************************************************************************-*                                                                      *-\subsection{Bindings}-*                                                                      *-************************************************************************+(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. -The binding stuff works for top level too.+  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 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 && not (exprIsTopLevelBindable deann_rhs bndr_ty))-          -- 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-+  |  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 mb_join_arity rhs+    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') }@@ -1156,7 +1276,7 @@   | null abs_vars   = do {  -- No type abstraction; clone existing binder          rhs' <- lvlFloatRhs [] dest_lvl env NonRecursive-                             is_bot mb_join_arity rhs+                             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') }@@ -1164,7 +1284,7 @@   | 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+                             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') }@@ -1175,31 +1295,27 @@     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 is_join+    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     = isJust mb_bot_str-        -- NB: not isBottomThunk!  See Note [Bottoming floats] point (3)+    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) -    n_extra    = count isId abs_vars-    mb_join_arity = isJoinId_maybe bndr-    is_join       = isJust mb_join_arity+    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)-  |  floatTopLvlOnly env && not (isTopLvl dest_lvl)-         -- Only floating to the top level is allowed.-  || not (profitableFloat env dest_lvl)-  || (isTopLvl dest_lvl && 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)-       -- (Ultimately I think we should not use GHC.Core.Opt.SetLevels to-       -- float join bindings at all, but that's another story.)-  =    -- No float+  |  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 (isJoinId_maybe b) r+             lvl_rhs (b,r)  = lvlRhs env' Recursive is_bot (idJoinPointHood b) r        ; rhss' <- mapM lvl_rhs pairs        ; return (Rec (bndrs' `zip` rhss'), env') } @@ -1232,7 +1348,7 @@         (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+    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 $@@ -1258,13 +1374,9 @@                       -- 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+    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])@@ -1275,13 +1387,45 @@                 bndrs      ty_fvs   = foldr (unionVarSet . tyCoVarsOfType . idType) emptyVarSet bndrs-    dest_lvl = destLevel env bind_fvs ty_fvs is_fun is_bot is_join+    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                      -- Going all the way to top level+  || (isTopLvl dest_lvl && floatConsts env) -- Going all the way to top level   ----------------------------------------------------@@ -1290,7 +1434,7 @@ lvlRhs :: LevelEnv        -> RecFlag        -> Bool               -- Is this a bottoming function-       -> Maybe JoinArity+       -> JoinPointHood        -> CoreExprWithFVs        -> LvlM LevelledExpr lvlRhs env rec_flag is_bot mb_join_arity expr@@ -1299,7 +1443,7 @@  lvlFloatRhs :: [OutVar] -> Level -> LevelEnv -> RecFlag             -> Bool   -- Binding is for a bottoming function-            -> Maybe JoinArity+            -> JoinPointHood             -> CoreExprWithFVs             -> LvlM (Expr LevelledBndr) -- Ignores the le_ctxt_lvl in env; treats dest_lvl as the baseline@@ -1310,17 +1454,16 @@                   else lvlExpr body_env      body        ; return (mkLams bndrs' body') }   where-    (bndrs, body)     | Just join_arity <- mb_join_arity+    (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') | Just _ <- mb_join_arity+    (body_env, bndrs') | JoinPoint {} <- mb_join_arity                       = lvlJoinBndrs env1 dest_lvl rec all_bndrs                       | otherwise-                      = case lvlLamBndrs env1 dest_lvl all_bndrs of-                          (env2, bndrs') -> (placeJoinCeiling env2, bndrs')+                      = 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@@ -1403,9 +1546,11 @@     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"+    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]@@ -1429,7 +1574,6 @@ -- 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) @@ -1443,24 +1587,16 @@           -> TyCoVarSet -- Free in the /type/ of the term                         -- (a subset of the previous argument)           -> Bool   -- True <=> is function-          -> Bool   -- True <=> is bottom-          -> Bool   -- True <=> is a join point+          -> Bool   -- True <=> looks like \x1..xn.bottom (n>=0)           -> Level--- INVARIANT: if is_join=True then result >= join_ceiling-destLevel env fvs fvs_ty is_function is_bot is_join+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_join  -- Never float a join point past the join ceiling-             -- See Note [Join points] in GHC.Core.Opt.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   = as_far_as_poss      -- regardless; see Note [Bottoming floats]-                        -- Esp Bottoming floats (1)+                        -- Esp Bottoming floats (1) and (3)    | Just n_args <- floatLams env   , n_args > 0  -- n=0 case handled uniformly by the 'otherwise' case@@ -1471,7 +1607,6 @@    | otherwise = max_fv_id_level   where-    join_ceiling    = joinCeilingLevel env     max_fv_id_level = maxFvLevel isId env fvs -- Max over Ids only; the                                               -- tyvars will be abstracted @@ -1542,8 +1677,6 @@   = 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@@ -1588,12 +1721,11 @@ initialEnv float_lams binds   = LE { le_switches  = float_lams        , le_ctxt_lvl  = tOP_LEVEL-       , le_join_ceil = panic "initialEnv"        , le_lvl_env   = emptyVarEnv        , le_subst     = mkEmptySubst in_scope_toplvl        , le_env       = emptyVarEnv }   where-    in_scope_toplvl = emptyInScopeSet `extendInScopeSetList` bindersOfBinds binds+    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@@ -1629,18 +1761,13 @@                   -> LevelEnv extendCaseBndrEnv le@(LE { le_subst = subst, le_env = id_env })                   case_bndr (Var scrut_var)-    | Many <- varMult case_bndr+  -- 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 --- 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 env var_set   = nonDetStrictFoldDVarSet (maxIn max_me env) tOP_LEVEL var_set@@ -1669,11 +1796,6 @@                     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@@ -1733,24 +1855,24 @@      mk_poly_bndr bndr uniq = transferPolyIdInfo bndr abs_vars $ -- Note [transferPolyIdInfo] in GHC.Types.Id                              transfer_join_info bndr $-                             mkSysLocal (mkFastString str) uniq (idMult bndr) poly_ty+                             mkSysLocal str uniq (idMult bndr) poly_ty                            where-                             str     = "poly_" ++ occNameString (getOccName bndr)-                             poly_ty = mkLamTypes abs_vars (GHC.Core.Subst.substTy subst (idType bndr))+                             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-      | Just join_arity <- isJoinId_maybe 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-          -> Maybe JoinArity     -- Its join arity, if it is a join point+          -> 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@@ -1768,19 +1890,17 @@       = mkExportedVanillaId (mkSystemVarName uniq (mkFastString "static_ptr"))                             rhs_ty       | otherwise-      = mkSysLocal (mkFastString "lvl") uniq Many rhs_ty+      = 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 { us <- getUniqueSupplyM-       ; let (subst', vs') = cloneBndrs subst us 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 and-             -- le_join_ceil.  See Note [Setting levels when floating-             -- single-alternative cases].-             env' = env { le_lvl_env   = addLvls new_lvl lvl_env vs'+             -- 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') } @@ -1795,13 +1915,12 @@ 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+  = 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 }@@ -1809,9 +1928,12 @@        ; return (env', vs2) }   where     zap :: Var -> Var-    zap v | isId v    = zap_join (zapIdDemandInfo v)+    -- 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 @@ -1820,16 +1942,38 @@   | 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.+{- 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. -Similarly, if we're floating a join point, it won't be one anymore, so we zap-join point information as well.+Note [Floatifying demand info when floating]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When floating we must lazify the outer demand info on the Id+because it may be less demanded than at its original binding site.+For example:+     f :: Int -> Int+     f x = let v = 3*4 in v+x+Here v is strict and used at most once; but if we float v to top level,+that isn't true any more. Specifically, we lose track of v's cardinality info:+  * if `f` is called multiple times, then `v` is used more than once+  * if `f` is never called, then `v` is never evaluated.++But NOTE that we only need to adjust the /top-level/ cardinality info.+For example+     let x = (e1,e2)+     in ...(case x of (a,b) -> a+b)...+If we float x outwards, it may no longer be strict, but IF it is ever+evaluated THEN its components will be evaluated.  So we to lazify and+many-ify its demand-info, not discard it entirely.++Same if we have+     let f = \x y . blah+     in ...(f a b)...(f c d)...+Here `f` will get a demand like SC(S,C(1,L)). If we float it out, we can+keep that `1C` called-once inner demand. It's only the outer strictness+that we kill.++Conclusion: to floatify a demand, just do `multDmd C_0N` to reflect the+fact that `v` may be used any number of times, from zero upwards. -}
GHC/Core/Opt/Simplify.hs view
@@ -1,4284 +1,566 @@-{--(c) The AQUA Project, Glasgow University, 1993-1998--\section[Simplify]{The main module of the simplifier}--}---{-# LANGUAGE TypeFamilies #-}--{-# OPTIONS_GHC -Wno-incomplete-record-updates -Wno-incomplete-uni-patterns #-}-module GHC.Core.Opt.Simplify ( simplTopBinds, simplExpr, simplImpRules ) where--import GHC.Prelude--import GHC.Platform--import GHC.Driver.Session--import GHC.Core-import GHC.Core.Opt.Simplify.Monad-import GHC.Core.Type hiding ( substTy, substTyVar, extendTvSubst, extendCvSubst )-import GHC.Core.Opt.Simplify.Env-import GHC.Core.Opt.Simplify.Utils-import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr, zapLambdaBndrs )-import GHC.Core.Make       ( FloatBind, mkImpossibleExpr, castBottomExpr )-import qualified GHC.Core.Make-import GHC.Core.Coercion hiding ( substCo, substCoVar )-import GHC.Core.Reduction-import GHC.Core.Coercion.Opt    ( optCoercion )-import GHC.Core.FamInstEnv      ( FamInstEnv, topNormaliseType_maybe )-import GHC.Core.DataCon-   ( DataCon, dataConWorkId, dataConRepStrictness-   , dataConRepArgTys, isUnboxedTupleDataCon-   , StrictnessMark (..) )-import GHC.Core.Opt.Monad ( Tick(..), SimplMode(..) )-import GHC.Core.Ppr     ( pprCoreExpr )-import GHC.Core.Unfold-import GHC.Core.Unfold.Make-import GHC.Core.Utils-import GHC.Core.Opt.Arity ( ArityType(..)-                          , pushCoTyArg, pushCoValArg-                          , etaExpandAT )-import GHC.Core.SimpleOpt ( exprIsConApp_maybe, joinPointBinding_maybe, joinPointBindings_maybe )-import GHC.Core.FVs     ( mkRuleInfo )-import GHC.Core.Rules   ( lookupRule, getRules, initRuleOpts )-import GHC.Core.Multiplicity--import GHC.Types.Literal   ( litIsLifted ) --, mkLitInt ) -- temporarily commented out. See #8326-import GHC.Types.SourceText-import GHC.Types.Id-import GHC.Types.Id.Make   ( seqId )-import GHC.Types.Id.Info-import GHC.Types.Name   ( mkSystemVarName, isExternalName, getOccFS )-import GHC.Types.Demand-import GHC.Types.Cpr    ( mkCprSig, botCpr )-import GHC.Types.Unique ( hasKey )-import GHC.Types.Basic-import GHC.Types.Tickish-import GHC.Types.Var    ( isTyCoVar )-import GHC.Builtin.PrimOps ( PrimOp (SeqOp) )-import GHC.Builtin.Types.Prim( realWorldStatePrimTy )-import GHC.Builtin.Names( runRWKey )--import GHC.Data.Maybe   ( isNothing, orElse )-import GHC.Data.FastString-import GHC.Unit.Module ( moduleName, pprModuleName )-import GHC.Utils.Outputable-import GHC.Utils.Panic-import GHC.Utils.Panic.Plain-import GHC.Utils.Constants (debugIsOn)-import GHC.Utils.Trace-import GHC.Utils.Monad  ( mapAccumLM, liftIO )-import GHC.Utils.Logger--import Control.Monad--{--The guts of the simplifier is in this module, but the driver loop for-the simplifier is in GHC.Core.Opt.Pipeline--Note [The big picture]-~~~~~~~~~~~~~~~~~~~~~~-The general shape of the simplifier is this:--  simplExpr :: SimplEnv -> InExpr -> SimplCont -> SimplM (SimplFloats, OutExpr)-  simplBind :: SimplEnv -> InBind -> SimplM (SimplFloats, SimplEnv)-- * SimplEnv contains-     - Simplifier mode (which includes DynFlags for convenience)-     - Ambient substitution-     - InScopeSet-- * SimplFloats contains-     - Let-floats (which includes ok-for-spec case-floats)-     - Join floats-     - InScopeSet (including all the floats)-- * Expressions-      simplExpr :: SimplEnv -> InExpr -> SimplCont-                -> SimplM (SimplFloats, OutExpr)-   The result of simplifying an /expression/ is (floats, expr)-      - A bunch of floats (let bindings, join bindings)-      - A simplified expression.-   The overall result is effectively (let floats in expr)-- * Bindings-      simplBind :: SimplEnv -> InBind -> SimplM (SimplFloats, SimplEnv)-   The result of simplifying a binding is-     - A bunch of floats, the last of which is the simplified binding-       There may be auxiliary bindings too; see prepareRhs-     - An environment suitable for simplifying the scope of the binding--   The floats may also be empty, if the binding is inlined unconditionally;-   in that case the returned SimplEnv will have an augmented substitution.--   The returned floats and env both have an in-scope set, and they are-   guaranteed to be the same.---Note [Shadowing]-~~~~~~~~~~~~~~~~-The simplifier used to guarantee that the output had no shadowing, but-it does not do so any more.   (Actually, it never did!)  The reason is-documented with simplifyArgs.---Eta expansion-~~~~~~~~~~~~~~-For eta expansion, we want to catch things like--        case e of (a,b) -> \x -> case a of (p,q) -> \y -> r--If the \x was on the RHS of a let, we'd eta expand to bring the two-lambdas together.  And in general that's a good thing to do.  Perhaps-we should eta expand wherever we find a (value) lambda?  Then the eta-expansion at a let RHS can concentrate solely on the PAP case.--Note [In-scope set as a substitution]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-As per Note [Lookups in in-scope set], an in-scope set can act as-a substitution. Specifically, it acts as a substitution from variable to-variables /with the same unique/.--Why do we need this? Well, during the course of the simplifier, we may want to-adjust inessential properties of a variable. For instance, when performing a-beta-reduction, we change--    (\x. e) u ==> let x = u in e--We typically want to add an unfolding to `x` so that it inlines to (the-simplification of) `u`.--We do that by adding the unfolding to the binder `x`, which is added to the-in-scope set. When simplifying occurrences of `x` (every occurrence!), they are-replaced by their “updated” version from the in-scope set, hence inherit the-unfolding. This happens in `SimplEnv.substId`.--Another example. Consider--   case x of y { Node a b -> ...y...-               ; Leaf v   -> ...y... }--In the Node branch want y's unfolding to be (Node a b); in the Leaf branch we-want y's unfolding to be (Leaf v). We achieve this by adding the appropriate-unfolding to y, and re-adding it to the in-scope set. See the calls to-`addBinderUnfolding` in `Simplify.addAltUnfoldings` and elsewhere.--It's quite convenient. This way we don't need to manipulate the substitution all-the time: every update to a binder is automatically reflected to its bound-occurrences.--Note [Bangs in the Simplifier]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Both SimplFloats and SimplEnv do *not* generally benefit from making-their fields strict. I don't know if this is because of good use of-laziness or unintended side effects like closures capturing more variables-after WW has run.--But the end result is that we keep these lazy, but force them in some places-where we know it's beneficial to the compiler.--Similarly environments returned from functions aren't *always* beneficial to-force. In some places they would never be demanded so forcing them early-increases allocation. In other places they almost always get demanded so-it's worthwhile to force them early.--Would it be better to through every allocation of e.g. SimplEnv and decide-wether or not to make this one strict? Absolutely! Would be a good use of-someones time? Absolutely not! I made these strict that showed up during-a profiled build or which I noticed while looking at core for one reason-or another.--The result sadly is that we end up with "random" bangs in the simplifier-where we sometimes force e.g. the returned environment from a function and-sometimes we don't for the same function. Depending on the context around-the call. The treatment is also not very consistent. I only added bangs-where I saw it making a difference either in the core or benchmarks. Some-patterns where it would be beneficial aren't convered as a consequence as-I neither have the time to go through all of the core and some cases are-too small to show up in benchmarks.----************************************************************************-*                                                                      *-\subsection{Bindings}-*                                                                      *-************************************************************************--}--simplTopBinds :: SimplEnv -> [InBind] -> SimplM (SimplFloats, SimplEnv)--- See Note [The big picture]-simplTopBinds env0 binds0-  = do  {       -- Put all the top-level binders into scope at the start-                -- so that if a rewrite rule has unexpectedly brought-                -- anything into scope, then we don't get a complaint about that.-                -- It's rather as if the top-level binders were imported.-                -- See Note [Glomming] in "GHC.Core.Opt.OccurAnal".-        -- See Note [Bangs in the Simplifier]-        ; !env1 <- {-#SCC "simplTopBinds-simplRecBndrs" #-} simplRecBndrs env0 (bindersOfBinds binds0)-        ; (floats, env2) <- {-#SCC "simplTopBinds-simpl_binds" #-} simpl_binds env1 binds0-        ; freeTick SimplifierDone-        ; return (floats, env2) }-  where-        -- We need to track the zapped top-level binders, because-        -- they should have their fragile IdInfo zapped (notably occurrence info)-        -- That's why we run down binds and bndrs' simultaneously.-        ---    simpl_binds :: SimplEnv -> [InBind] -> SimplM (SimplFloats, SimplEnv)-    simpl_binds env []           = return (emptyFloats env, env)-    simpl_binds env (bind:binds) = do { (float,  env1) <- simpl_bind env bind-                                      ; (floats, env2) <- simpl_binds env1 binds-                                      -- See Note [Bangs in the Simplifier]-                                      ; let !floats1 = float `addFloats` floats-                                      ; return (floats1, env2) }--    simpl_bind env (Rec pairs)-      = simplRecBind env (BC_Let TopLevel Recursive) pairs-    simpl_bind env (NonRec b r)-      = do { let bind_cxt = BC_Let TopLevel NonRecursive-           ; (env', b') <- addBndrRules env b (lookupRecBndr env b) bind_cxt-           ; simplRecOrTopPair env' bind_cxt b b' r }--{--************************************************************************-*                                                                      *-        Lazy bindings-*                                                                      *-************************************************************************--simplRecBind is used for-        * recursive bindings only--}--simplRecBind :: SimplEnv -> BindContext-             -> [(InId, InExpr)]-             -> SimplM (SimplFloats, SimplEnv)-simplRecBind env0 bind_cxt pairs0-  = do  { (env_with_info, triples) <- mapAccumLM add_rules env0 pairs0-        ; (rec_floats, env1) <- go env_with_info triples-        ; return (mkRecFloats rec_floats, env1) }-  where-    add_rules :: SimplEnv -> (InBndr,InExpr) -> SimplM (SimplEnv, (InBndr, OutBndr, InExpr))-        -- Add the (substituted) rules to the binder-    add_rules env (bndr, rhs)-        = do { (env', bndr') <- addBndrRules env bndr (lookupRecBndr env bndr) bind_cxt-             ; return (env', (bndr, bndr', rhs)) }--    go env [] = return (emptyFloats env, env)--    go env ((old_bndr, new_bndr, rhs) : pairs)-        = do { (float, env1) <- simplRecOrTopPair env bind_cxt-                                                  old_bndr new_bndr rhs-             ; (floats, env2) <- go env1 pairs-             ; return (float `addFloats` floats, env2) }--{--simplOrTopPair is used for-        * recursive bindings (whether top level or not)-        * top-level non-recursive bindings--It assumes the binder has already been simplified, but not its IdInfo.--}--simplRecOrTopPair :: SimplEnv-                  -> BindContext-                  -> InId -> OutBndr -> InExpr  -- Binder and rhs-                  -> SimplM (SimplFloats, SimplEnv)--simplRecOrTopPair env bind_cxt old_bndr new_bndr rhs-  | Just env' <- preInlineUnconditionally env (bindContextLevel bind_cxt)-                                          old_bndr rhs env-  = {-#SCC "simplRecOrTopPair-pre-inline-uncond" #-}-    simplTrace env "SimplBindr:inline-uncond" (ppr old_bndr) $-    do { tick (PreInlineUnconditionally old_bndr)-       ; return ( emptyFloats env, env' ) }--  | otherwise-  = case bind_cxt of-      BC_Join cont  -> simplTrace env "SimplBind:join" (ppr old_bndr) $-                       simplJoinBind env cont old_bndr new_bndr rhs env--      BC_Let top_lvl is_rec -> simplTrace env "SimplBind:normal" (ppr old_bndr) $-                               simplLazyBind env top_lvl is_rec old_bndr new_bndr rhs env--simplTrace :: SimplEnv -> String -> SDoc -> a -> a-simplTrace env herald doc thing_inside-  | not (logHasDumpFlag logger Opt_D_verbose_core2core)-  = thing_inside-  | otherwise-  = logTraceMsg logger herald doc thing_inside-  where-    logger = seLogger env-----------------------------simplLazyBind :: SimplEnv-              -> TopLevelFlag -> RecFlag-              -> InId -> OutId          -- Binder, both pre-and post simpl-                                        -- Not a JoinId-                                        -- The OutId has IdInfo, except arity, unfolding-                                        -- Ids only, no TyVars-              -> InExpr -> SimplEnv     -- The RHS and its environment-              -> SimplM (SimplFloats, SimplEnv)--- Precondition: the OutId is already in the InScopeSet of the incoming 'env'--- Precondition: not a JoinId--- Precondition: rhs obeys the let/app invariant--- NOT used for JoinIds-simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se-  = assert (isId bndr )-    assertPpr (not (isJoinId bndr)) (ppr bndr) $-    -- pprTrace "simplLazyBind" ((ppr bndr <+> ppr bndr1) $$ ppr rhs $$ ppr (seIdSubst rhs_se)) $-    do  { let   !rhs_env     = rhs_se `setInScopeFromE` env -- See Note [Bangs in the Simplifier]-                (tvs, body) = case collectTyAndValBinders rhs of-                                (tvs, [], body)-                                  | surely_not_lam body -> (tvs, body)-                                _                       -> ([], rhs)--                surely_not_lam (Lam {})     = False-                surely_not_lam (Tick t e)-                  | not (tickishFloatable t) = surely_not_lam e-                   -- eta-reduction could float-                surely_not_lam _            = True-                        -- Do not do the "abstract tyvar" thing if there's-                        -- a lambda inside, because it defeats eta-reduction-                        --    f = /\a. \x. g a x-                        -- should eta-reduce.--        ; (body_env, tvs') <- {-#SCC "simplBinders" #-} simplBinders rhs_env tvs-                -- See Note [Floating and type abstraction] in GHC.Core.Opt.Simplify.Utils--        -- Simplify the RHS-        ; let rhs_cont = mkRhsStop (substTy body_env (exprType body))-        ; (body_floats0, body0) <- {-#SCC "simplExprF" #-} simplExprF body_env body rhs_cont--        -- ANF-ise a constructor or PAP rhs-        ; (body_floats2, body2) <- {-#SCC "prepareBinding" #-}-                                   prepareBinding env top_lvl is_rec-                                                  False  -- Not strict; this is simplLazyBind-                                                  bndr1 body_floats0 body0-          -- Subtle point: we do not need or want tvs' in the InScope set-          -- of body_floats2, so we pass in 'env' not 'body_env'.-          -- Don't want: if tvs' are in-scope in the scope of this let-binding, we may do-          -- more renaming than necessary => extra work (see !7777 and test T16577).-          -- Don't need: we wrap tvs' around the RHS anyway.--        ; (rhs_floats, body3)-            <-  if isEmptyFloats body_floats2 || null tvs then   -- Simple floating-                     {-#SCC "simplLazyBind-simple-floating" #-}-                     return (body_floats2, body2)--                else -- Non-empty floats, and non-empty tyvars: do type-abstraction first-                     {-#SCC "simplLazyBind-type-abstraction-first" #-}-                     do { (poly_binds, body3) <- abstractFloats (seUnfoldingOpts env) top_lvl-                                                                tvs' body_floats2 body2-                        ; let floats = foldl' extendFloats (emptyFloats env) poly_binds-                        ; return (floats, body3) }--        ; let env' = env `setInScopeFromF` rhs_floats-        ; rhs' <- mkLam env' tvs' body3 rhs_cont-        ; (bind_float, env2) <- completeBind env' (BC_Let top_lvl is_rec) bndr bndr1 rhs'-        ; return (rhs_floats `addFloats` bind_float, env2) }-----------------------------simplJoinBind :: SimplEnv-              -> SimplCont-              -> InId -> OutId          -- Binder, both pre-and post simpl-                                        -- The OutId has IdInfo, except arity,-                                        --   unfolding-              -> InExpr -> SimplEnv     -- The right hand side and its env-              -> SimplM (SimplFloats, SimplEnv)-simplJoinBind env cont old_bndr new_bndr rhs rhs_se-  = do  { let rhs_env = rhs_se `setInScopeFromE` env-        ; rhs' <- simplJoinRhs rhs_env old_bndr rhs cont-        ; completeBind env (BC_Join cont) old_bndr new_bndr rhs' }-----------------------------simplNonRecX :: SimplEnv-             -> InId            -- Old binder; not a JoinId-             -> OutExpr         -- Simplified RHS-             -> SimplM (SimplFloats, SimplEnv)--- A specialised variant of simplNonRec used when the RHS is already--- simplified, notably in knownCon.  It uses case-binding where necessary.------ Precondition: rhs satisfies the let/app invariant--simplNonRecX env bndr new_rhs-  | assertPpr (not (isJoinId bndr)) (ppr bndr) $-    isDeadBinder bndr   -- Not uncommon; e.g. case (a,b) of c { (p,q) -> p }-  = return (emptyFloats env, env)    --  Here c is dead, and we avoid-                                         --  creating the binding c = (a,b)--  | Coercion co <- new_rhs-  = return (emptyFloats env, extendCvSubst env bndr co)--  | exprIsTrivial new_rhs  -- Short-cut for let x = y in ...-    -- This case would ultimately land in postInlineUnconditionally-    -- but it seems not uncommon, and avoids a lot of faff to do it here-  = return (emptyFloats env-           , extendIdSubst env bndr (DoneEx new_rhs Nothing))--  | otherwise-  = do  { (env1, new_bndr)   <- simplBinder env bndr-        ; let is_strict = isStrictId new_bndr-              -- isStrictId: use new_bndr because the InId bndr might not have-              -- a fixed runtime representation, which isStrictId doesn't expect-              -- c.f. Note [Dark corner with representation polymorphism]--        ; (rhs_floats, rhs1) <- prepareBinding env NotTopLevel NonRecursive is_strict-                                               new_bndr (emptyFloats env) new_rhs-              -- NB: it makes a surprisingly big difference (5% in compiler allocation-              -- in T9630) to pass 'env' rather than 'env1'.  It's fine to pass 'env',-              -- because this is simplNonRecX, so bndr is not in scope in the RHS.--        ; (bind_float, env2) <- completeBind (env1 `setInScopeFromF` rhs_floats)-                                             (BC_Let NotTopLevel NonRecursive)-                                             bndr new_bndr rhs1-              -- Must pass env1 to completeBind in case simplBinder had to clone,-              -- and extended the substitution with [bndr :-> new_bndr]--        ; return (rhs_floats `addFloats` bind_float, env2) }---{- *********************************************************************-*                                                                      *-           Cast worker/wrapper-*                                                                      *-************************************************************************--Note [Cast worker/wrapper]-~~~~~~~~~~~~~~~~~~~~~~~~~~-When we have a binding-   x = e |> co-we want to do something very similar to worker/wrapper:-   $wx = e-   x = $wx |> co--We call this making a cast worker/wrapper in tryCastWorkerWrapper.--The main motivaiton is that x can be inlined freely.  There's a chance-that e will be a constructor application or function, or something-like that, so moving the coercion to the usage site may well cancel-the coercions and lead to further optimisation.  Example:--     data family T a :: *-     data instance T Int = T Int--     foo :: Int -> Int -> Int-     foo m n = ...-        where-          t = T m-          go 0 = 0-          go n = case t of { T m -> go (n-m) }-                -- This case should optimise--A second reason for doing cast worker/wrapper is that the worker/wrapper-pass after strictness analysis can't deal with RHSs like-     f = (\ a b c. blah) |> co-Instead, it relies on cast worker/wrapper to get rid of the cast,-leaving a simpler job for demand-analysis worker/wrapper.  See #19874.--Wrinkles--1. We must /not/ do cast w/w on-     f = g |> co-   otherwise it'll just keep repeating forever! You might think this-   is avoided because the call to tryCastWorkerWrapper is guarded by-   preInlineUnconditinally, but I'm worried that a loop-breaker or an-   exported Id might say False to preInlineUnonditionally.--2. We need to be careful with inline/noinline pragmas:-       rec { {-# NOINLINE f #-}-             f = (...g...) |> co-           ; g = ...f... }-   This is legitimate -- it tells GHC to use f as the loop breaker-   rather than g.  Now we do the cast thing, to get something like-       rec { $wf = ...g...-           ; f = $wf |> co-           ; g = ...f... }-   Where should the NOINLINE pragma go?  If we leave it on f we'll get-     rec { $wf = ...g...-         ; {-# NOINLINE f #-}-           f = $wf |> co-         ; g = ...f... }-   and that is bad: the whole point is that we want to inline that-   cast!  We want to transfer the pagma to $wf:-      rec { {-# NOINLINE $wf #-}-            $wf = ...g...-          ; f = $wf |> co-          ; g = ...f... }-   c.f. Note [Worker/wrapper for NOINLINE functions] in GHC.Core.Opt.WorkWrap.--3. We should still do cast w/w even if `f` is INLINEABLE.  E.g.-      {- f: Stable unfolding = <stable-big> -}-      f = (\xy. <big-body>) |> co-   Then we want to w/w to-      {- $wf: Stable unfolding = <stable-big> |> sym co -}-      $wf = \xy. <big-body>-      f = $wf |> co-   Notice that the stable unfolding moves to the worker!  Now demand analysis-   will work fine on $wf, whereas it has trouble with the original f.-   c.f. Note [Worker/wrapper for INLINABLE functions] in GHC.Core.Opt.WorkWrap.-   This point also applies to strong loopbreakers with INLINE pragmas, see-   wrinkle (4).--4. We should /not/ do cast w/w for non-loop-breaker INLINE functions (hence-   hasInlineUnfolding in tryCastWorkerWrapper, which responds False to-   loop-breakers) because they'll definitely be inlined anyway, cast and-   all. And if we do cast w/w for an INLINE function with arity zero, we get-   something really silly: we inline that "worker" right back into the wrapper!-   Worse than a no-op, because we have then lost the stable unfolding.--All these wrinkles are exactly like worker/wrapper for strictness analysis:-  f is the wrapper and must inline like crazy-  $wf is the worker and must carry f's original pragma-See Note [Worker/wrapper for INLINABLE functions]-and Note [Worker/wrapper for NOINLINE functions] in GHC.Core.Opt.WorkWrap.--See #17673, #18093, #18078, #19890.--Note [Preserve strictness in cast w/w]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In the Note [Cast worker/wrapper] transformation, keep the strictness info.-Eg-        f = e `cast` co    -- f has strictness SSL-When we transform to-        f' = e             -- f' also has strictness SSL-        f = f' `cast` co   -- f still has strictness SSL--Its not wrong to drop it on the floor, but better to keep it.--Note [Preserve RuntimeRep info in cast w/w]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We must not do cast w/w when the presence of the coercion is needed in order-to determine the runtime representation.--Example:--  Suppose we have a type family:--    type F :: RuntimeRep-    type family F where-      F = LiftedRep--  together with a type `ty :: TYPE F` and a top-level binding--    a :: ty |> TYPE F[0]--  The kind of `ty |> TYPE F[0]` is `LiftedRep`, so `a` is a top-level lazy binding.-  However, were we to apply cast w/w, we would get:--    b :: ty-    b = ...--    a :: ty |> TYPE F[0]-    a = b `cast` GRefl (TYPE F[0])--  Now we are in trouble because `ty :: TYPE F` does not have a known runtime-  representation, because we need to be able to reduce the nullary type family-  application `F` to find that out.--Conclusion: only do cast w/w when doing so would not lose the RuntimeRep-information. That is, when handling `Cast rhs co`, don't attempt cast w/w-unless the kind of the type of rhs is concrete, in the sense of-Note [Concrete types] in GHC.Tc.Utils.Concrete.--}--tryCastWorkerWrapper :: SimplEnv -> BindContext-                     -> InId -> OccInfo-                     -> OutId -> OutExpr-                     -> SimplM (SimplFloats, SimplEnv)--- See Note [Cast worker/wrapper]-tryCastWorkerWrapper env bind_cxt old_bndr occ_info bndr (Cast rhs co)-  | BC_Let top_lvl is_rec <- bind_cxt  -- Not join points-  , not (isDFunId bndr) -- nor DFuns; cast w/w is no help, and we can't transform-                        --            a DFunUnfolding in mk_worker_unfolding-  , not (exprIsTrivial rhs)        -- Not x = y |> co; Wrinkle 1-  , not (hasInlineUnfolding info)  -- Not INLINE things: Wrinkle 4-  , isConcrete (typeKind rhs_ty)   -- Don't peel off a cast if doing so would-                                   -- lose the underlying runtime representation.-                                   -- See Note [Preserve RuntimeRep info in cast w/w]-  , not (isOpaquePragma (idInlinePragma old_bndr)) -- Not for OPAQUE bindings-                                                   -- See Note [OPAQUE pragma]-  = do  { uniq <- getUniqueM-        ; let work_name = mkSystemVarName uniq occ_fs-              work_id   = mkLocalIdWithInfo work_name Many rhs_ty worker_info-              is_strict = isStrictId bndr--        ; (rhs_floats, work_rhs) <- prepareBinding env top_lvl is_rec is_strict-                                                   work_id (emptyFloats env) rhs--        ; work_unf <- mk_worker_unfolding top_lvl work_id work_rhs-        ; let  work_id_w_unf = work_id `setIdUnfolding` work_unf-               floats   = rhs_floats `addLetFloats`-                          unitLetFloat (NonRec work_id_w_unf work_rhs)--               triv_rhs = Cast (Var work_id_w_unf) co--        ; if postInlineUnconditionally env bind_cxt bndr occ_info triv_rhs-             -- Almost always True, because the RHS is trivial-             -- In that case we want to eliminate the binding fast-             -- We conservatively use postInlineUnconditionally so that we-             -- check all the right things-          then do { tick (PostInlineUnconditionally bndr)-                  ; return ( floats-                           , extendIdSubst (setInScopeFromF env floats) old_bndr $-                             DoneEx triv_rhs Nothing ) }--          else do { wrap_unf <- mkLetUnfolding (sm_uf_opts mode) top_lvl InlineRhs bndr triv_rhs-                  ; let bndr' = bndr `setInlinePragma` mkCastWrapperInlinePrag (idInlinePragma bndr)-                                `setIdUnfolding`  wrap_unf-                        floats' = floats `extendFloats` NonRec bndr' triv_rhs-                  ; return ( floats', setInScopeFromF env floats' ) } }-  where-    mode   = getMode env-    occ_fs = getOccFS bndr-    rhs_ty = coercionLKind co-    info   = idInfo bndr--    worker_info = vanillaIdInfo `setDmdSigInfo`     dmdSigInfo info-                                `setCprSigInfo`     cprSigInfo info-                                `setDemandInfo`     demandInfo info-                                `setInlinePragInfo` inlinePragInfo info-                                `setArityInfo`      arityInfo info-           -- We do /not/ want to transfer OccInfo, Rules-           -- Note [Preserve strictness in cast w/w]-           -- and Wrinkle 2 of Note [Cast worker/wrapper]--    ----------- Worker unfolding ------------    -- Stable case: if there is a stable unfolding we have to compose with (Sym co);-    --   the next round of simplification will do the job-    -- Non-stable case: use work_rhs-    -- Wrinkle 3 of Note [Cast worker/wrapper]-    mk_worker_unfolding top_lvl work_id work_rhs-      = case realUnfoldingInfo info of -- NB: the real one, even for loop-breakers-           unf@(CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src })-             | isStableSource src -> return (unf { uf_tmpl = mkCast unf_rhs (mkSymCo co) })-           _ -> mkLetUnfolding (sm_uf_opts mode) top_lvl InlineRhs work_id work_rhs--tryCastWorkerWrapper env _ _ _ bndr rhs  -- All other bindings-  = return (mkFloatBind env (NonRec bndr rhs))--mkCastWrapperInlinePrag :: InlinePragma -> InlinePragma--- See Note [Cast worker/wrapper]-mkCastWrapperInlinePrag (InlinePragma { inl_act = act, inl_rule = rule_info })-  = InlinePragma { inl_src    = SourceText "{-# INLINE"-                 , inl_inline = NoUserInlinePrag -- See Note [Wrapper NoUserInlinePrag]-                 , inl_sat    = Nothing      --     in GHC.Core.Opt.WorkWrap-                 , inl_act    = wrap_act     -- See Note [Wrapper activation]-                 , inl_rule   = rule_info }  --     in GHC.Core.Opt.WorkWrap-                                -- RuleMatchInfo is (and must be) unaffected-  where-    -- See Note [Wrapper activation] in GHC.Core.Opt.WorkWrap-    -- But simpler, because we don't need to disable during InitialPhase-    wrap_act | isNeverActive act = activateDuringFinal-             | otherwise         = act---{- *********************************************************************-*                                                                      *-           prepareBinding, prepareRhs, makeTrivial-*                                                                      *-********************************************************************* -}--prepareBinding :: SimplEnv -> TopLevelFlag -> RecFlag -> Bool-               -> Id   -- Used only for its OccName; can be InId or OutId-               -> SimplFloats -> OutExpr-               -> SimplM (SimplFloats, OutExpr)--- In (prepareBinding ... bndr floats rhs), the binding is really just---    bndr = let floats in rhs--- Maybe we can ANF-ise this binding and float out; e.g.---    bndr = let a = f x in K a a (g x)--- we could float out to give---    a    = f x---    tmp  = g x---    bndr = K a a tmp--- That's what prepareBinding does--- Precondition: binder is not a JoinId-prepareBinding env top_lvl is_rec strict_bind bndr rhs_floats rhs-  = do { -- Never float join-floats out of a non-join let-binding (which this is)-         -- So wrap the body in the join-floats right now-         -- Hence: rhs_floats1 consists only of let-floats-         let (rhs_floats1, rhs1) = wrapJoinFloatsX rhs_floats rhs--         -- rhs_env: add to in-scope set the binders from rhs_floats-         -- so that prepareRhs knows what is in scope in rhs-       ; let rhs_env = env `setInScopeFromF` rhs_floats1--       -- Now ANF-ise the remaining rhs-       ; (anf_floats, rhs2) <- prepareRhs rhs_env top_lvl (getOccFS bndr) rhs1--       -- Finally, decide whether or not to float-       ; let all_floats = rhs_floats1 `addLetFloats` anf_floats-       ; if doFloatFromRhs top_lvl is_rec strict_bind all_floats rhs2-         then -- Float!-              do { tick LetFloatFromLet-                 ; return (all_floats, rhs2) }--         else -- Abandon floating altogether; revert to original rhs-              -- Since we have already built rhs1, we just need to add-              -- rhs_floats1 to it-              return (emptyFloats env, wrapFloats rhs_floats1 rhs1) }--{- Note [prepareRhs]-~~~~~~~~~~~~~~~~~~~~-prepareRhs takes a putative RHS, checks whether it's a PAP or-constructor application and, if so, converts it to ANF, so that the-resulting thing can be inlined more easily.  Thus-        x = (f a, g b)-becomes-        t1 = f a-        t2 = g b-        x = (t1,t2)--We also want to deal well cases like this-        v = (f e1 `cast` co) e2-Here we want to make e1,e2 trivial and get-        x1 = e1; x2 = e2; v = (f x1 `cast` co) v2-That's what the 'go' loop in prepareRhs does--}--prepareRhs :: SimplEnv -> TopLevelFlag-           -> FastString    -- Base for any new variables-           -> OutExpr-           -> SimplM (LetFloats, OutExpr)--- Transforms a RHS into a better RHS by ANF'ing args--- for expandable RHSs: constructors and PAPs--- e.g        x = Just e--- becomes    a = e               -- 'a' is fresh---            x = Just a--- See Note [prepareRhs]-prepareRhs env top_lvl occ rhs0-  = do  { (_is_exp, floats, rhs1) <- go 0 rhs0-        ; return (floats, rhs1) }-  where-    go :: Int -> OutExpr -> SimplM (Bool, LetFloats, OutExpr)-    go n_val_args (Cast rhs co)-        = do { (is_exp, floats, rhs') <- go n_val_args rhs-             ; return (is_exp, floats, Cast rhs' co) }-    go n_val_args (App fun (Type ty))-        = do { (is_exp, floats, rhs') <- go n_val_args fun-             ; return (is_exp, floats, App rhs' (Type ty)) }-    go n_val_args (App fun arg)-        = do { (is_exp, floats1, fun') <- go (n_val_args+1) fun-             ; case is_exp of-                False -> return (False, emptyLetFloats, App fun arg)-                True  -> do { (floats2, arg') <- makeTrivial env top_lvl topDmd occ arg-                            ; return (True, floats1 `addLetFlts` floats2, App fun' arg') } }-    go n_val_args (Var fun)-        = return (is_exp, emptyLetFloats, Var fun)-        where-          is_exp = isExpandableApp fun n_val_args   -- The fun a constructor or PAP-                        -- See Note [CONLIKE pragma] in GHC.Types.Basic-                        -- The definition of is_exp should match that in-                        -- 'GHC.Core.Opt.OccurAnal.occAnalApp'--    go n_val_args (Tick t rhs)-        -- We want to be able to float bindings past this-        -- tick. Non-scoping ticks don't care.-        | tickishScoped t == NoScope-        = do { (is_exp, floats, rhs') <- go n_val_args rhs-             ; return (is_exp, floats, Tick t rhs') }--        -- On the other hand, for scoping ticks we need to be able to-        -- copy them on the floats, which in turn is only allowed if-        -- we can obtain non-counting ticks.-        | (not (tickishCounts t) || tickishCanSplit t)-        = do { (is_exp, floats, rhs') <- go n_val_args rhs-             ; let tickIt (id, expr) = (id, mkTick (mkNoCount t) expr)-                   floats' = mapLetFloats floats tickIt-             ; return (is_exp, floats', Tick t rhs') }--    go _ other-        = return (False, emptyLetFloats, other)--makeTrivialArg :: SimplEnv -> ArgSpec -> SimplM (LetFloats, ArgSpec)-makeTrivialArg env arg@(ValArg { as_arg = e, as_dmd = dmd })-  = do { (floats, e') <- makeTrivial env NotTopLevel dmd (fsLit "arg") e-       ; return (floats, arg { as_arg = e' }) }-makeTrivialArg _ arg-  = return (emptyLetFloats, arg)  -- CastBy, TyArg--makeTrivial :: SimplEnv -> TopLevelFlag -> Demand-            -> FastString  -- ^ A "friendly name" to build the new binder from-            -> OutExpr     -- ^ This expression satisfies the let/app invariant-            -> SimplM (LetFloats, OutExpr)--- Binds the expression to a variable, if it's not trivial, returning the variable--- For the Demand argument, see Note [Keeping demand info in StrictArg Plan A]-makeTrivial env top_lvl dmd occ_fs expr-  | exprIsTrivial expr                          -- Already trivial-  || not (bindingOk top_lvl expr expr_ty)       -- Cannot trivialise-                                                --   See Note [Cannot trivialise]-  = return (emptyLetFloats, expr)--  | Cast expr' co <- expr-  = do { (floats, triv_expr) <- makeTrivial env top_lvl dmd occ_fs expr'-       ; return (floats, Cast triv_expr co) }--  | otherwise-  = do { (floats, new_id) <- makeTrivialBinding env top_lvl occ_fs-                                                id_info expr expr_ty-       ; return (floats, Var new_id) }-  where-    id_info = vanillaIdInfo `setDemandInfo` dmd-    expr_ty = exprType expr--makeTrivialBinding :: SimplEnv -> TopLevelFlag-                   -> FastString  -- ^ a "friendly name" to build the new binder from-                   -> IdInfo-                   -> OutExpr     -- ^ This expression satisfies the let/app invariant-                   -> OutType     -- Type of the expression-                   -> SimplM (LetFloats, OutId)-makeTrivialBinding env top_lvl occ_fs info expr expr_ty-  = do  { (floats, expr1) <- prepareRhs env top_lvl occ_fs expr-        ; uniq <- getUniqueM-        ; let name = mkSystemVarName uniq occ_fs-              var  = mkLocalIdWithInfo name Many expr_ty info--        -- Now something very like completeBind,-        -- but without the postInlineUnconditionally part-        ; (arity_type, expr2) <- tryEtaExpandRhs env var expr1-          -- Technically we should extend the in-scope set in 'env' with-          -- the 'floats' from prepareRHS; but they are all fresh, so there is-          -- no danger of introducing name shadowig in eta expansion--        ; unf <- mkLetUnfolding (sm_uf_opts mode) top_lvl InlineRhs var expr2--        ; let final_id = addLetBndrInfo var arity_type unf-              bind     = NonRec final_id expr2--        ; return ( floats `addLetFlts` unitLetFloat bind, final_id ) }-  where-    mode = getMode env--bindingOk :: TopLevelFlag -> CoreExpr -> Type -> Bool--- True iff we can have a binding of this expression at this level--- Precondition: the type is the type of the expression-bindingOk top_lvl expr expr_ty-  | isTopLevel top_lvl = exprIsTopLevelBindable expr expr_ty-  | otherwise          = True--{- Note [Cannot trivialise]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider:-   f :: Int -> Addr#--   foo :: Bar-   foo = Bar (f 3)--Then we can't ANF-ise foo, even though we'd like to, because-we can't make a top-level binding for the Addr# (f 3). And if-so we don't want to turn it into-   foo = let x = f 3 in Bar x-because we'll just end up inlining x back, and that makes the-simplifier loop.  Better not to ANF-ise it at all.--Literal strings are an exception.--   foo = Ptr "blob"#--We want to turn this into:--   foo1 = "blob"#-   foo = Ptr foo1--See Note [Core top-level string literals] in GHC.Core.--************************************************************************-*                                                                      *-          Completing a lazy binding-*                                                                      *-************************************************************************--completeBind-  * deals only with Ids, not TyVars-  * takes an already-simplified binder and RHS-  * is used for both recursive and non-recursive bindings-  * is used for both top-level and non-top-level bindings--It does the following:-  - tries discarding a dead binding-  - tries PostInlineUnconditionally-  - add unfolding [this is the only place we add an unfolding]-  - add arity-  - extend the InScopeSet of the SimplEnv--It does *not* attempt to do let-to-case.  Why?  Because it is used for-  - top-level bindings (when let-to-case is impossible)-  - many situations where the "rhs" is known to be a WHNF-                (so let-to-case is inappropriate).--Nor does it do the atomic-argument thing--}--completeBind :: SimplEnv-             -> BindContext-             -> InId           -- Old binder-             -> OutId          -- New binder; can be a JoinId-             -> OutExpr        -- New RHS-             -> SimplM (SimplFloats, SimplEnv)--- completeBind may choose to do its work---      * by extending the substitution (e.g. let x = y in ...)---      * or by adding to the floats in the envt------ Binder /can/ be a JoinId--- Precondition: rhs obeys the let/app invariant-completeBind env bind_cxt old_bndr new_bndr new_rhs- | isCoVar old_bndr- = case new_rhs of-     Coercion co -> return (emptyFloats env, extendCvSubst env old_bndr co)-     _           -> return (mkFloatBind env (NonRec new_bndr new_rhs))-- | otherwise- = assert (isId new_bndr) $-   do { let old_info = idInfo old_bndr-            old_unf  = realUnfoldingInfo old_info-            occ_info = occInfo old_info--         -- Do eta-expansion on the RHS of the binding-         -- See Note [Eta-expanding at let bindings] in GHC.Core.Opt.Simplify.Utils-      ; (new_arity, eta_rhs) <- tryEtaExpandRhs env new_bndr new_rhs--        -- Simplify the unfolding-      ; new_unfolding <- simplLetUnfolding env bind_cxt old_bndr-                         eta_rhs (idType new_bndr) new_arity old_unf--      ; let new_bndr_w_info = addLetBndrInfo new_bndr new_arity new_unfolding-        -- See Note [In-scope set as a substitution]--      ; if postInlineUnconditionally env bind_cxt new_bndr_w_info occ_info eta_rhs--        then -- Inline and discard the binding-             do  { tick (PostInlineUnconditionally old_bndr)-                 ; let unf_rhs = maybeUnfoldingTemplate new_unfolding `orElse` eta_rhs-                          -- See Note [Use occ-anald RHS in postInlineUnconditionally]-                 ; simplTrace env "PostInlineUnconditionally" (ppr new_bndr <+> ppr unf_rhs) $-                   return ( emptyFloats env-                          , extendIdSubst env old_bndr $-                            DoneEx unf_rhs (isJoinId_maybe new_bndr)) }-                -- Use the substitution to make quite, quite sure that the-                -- substitution will happen, since we are going to discard the binding--        else -- Keep the binding; do cast worker/wrapper-             -- pprTrace "Binding" (ppr new_bndr <+> ppr new_unfolding) $-             tryCastWorkerWrapper env bind_cxt old_bndr occ_info new_bndr_w_info eta_rhs }--addLetBndrInfo :: OutId -> ArityType -> Unfolding -> OutId-addLetBndrInfo new_bndr new_arity_type new_unf-  = new_bndr `setIdInfo` info5-  where-    AT oss div = new_arity_type-    new_arity  = length oss--    info1 = idInfo new_bndr `setArityInfo` new_arity--    -- Unfolding info: Note [Setting the new unfolding]-    info2 = info1 `setUnfoldingInfo` new_unf--    -- Demand info: Note [Setting the demand info]-    info3 | isEvaldUnfolding new_unf-          = zapDemandInfo info2 `orElse` info2-          | otherwise-          = info2--    -- Bottoming bindings: see Note [Bottoming bindings]-    info4 | isDeadEndDiv div = info3 `setDmdSigInfo` bot_sig-                                     `setCprSigInfo`        bot_cpr-          | otherwise        = info3--    bot_sig = mkClosedDmdSig (replicate new_arity topDmd) div-    bot_cpr = mkCprSig new_arity botCpr--     -- Zap call arity info. We have used it by now (via-     -- `tryEtaExpandRhs`), and the simplifier can invalidate this-     -- information, leading to broken code later (e.g. #13479)-    info5 = zapCallArityInfo info4---{- Note [Bottoming bindings]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose we have-   let x = error "urk"-   in ...(case x of <alts>)...-or-   let f = \x. error (x ++ "urk")-   in ...(case f "foo" of <alts>)...--Then we'd like to drop the dead <alts> immediately.  So it's good to-propagate the info that x's RHS is bottom to x's IdInfo as rapidly as-possible.--We use tryEtaExpandRhs on every binding, and it turns out that the-arity computation it performs (via GHC.Core.Opt.Arity.findRhsArity) already-does a simple bottoming-expression analysis.  So all we need to do-is propagate that info to the binder's IdInfo.--This showed up in #12150; see comment:16.--Note [Setting the demand info]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If the unfolding is a value, the demand info may-go pear-shaped, so we nuke it.  Example:-     let x = (a,b) in-     case x of (p,q) -> h p q x-Here x is certainly demanded. But after we've nuked-the case, we'll get just-     let x = (a,b) in h a b x-and now x is not demanded (I'm assuming h is lazy)-This really happens.  Similarly-     let f = \x -> e in ...f..f...-After inlining f at some of its call sites the original binding may-(for example) be no longer strictly demanded.-The solution here is a bit ad hoc...--Note [Use occ-anald RHS in postInlineUnconditionally]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose we postInlineUnconditionally 'f in-  let f = \x -> x True in ...(f blah)...-then we'd like to inline the /occ-anald/ RHS for 'f'.  If we-use the non-occ-anald version, we'll end up with a-    ...(let x = blah in x True)...-and hence an extra Simplifier iteration.--We already /have/ the occ-anald version in the Unfolding for-the Id.  Well, maybe not /quite/ always.  If the binder is Dead,-postInlineUnconditionally will return True, but we may not have an-unfolding because it's too big. Hence the belt-and-braces `orElse`-in the defn of unf_rhs.  The Nothing case probably never happens.---************************************************************************-*                                                                      *-\subsection[Simplify-simplExpr]{The main function: simplExpr}-*                                                                      *-************************************************************************--The reason for this OutExprStuff stuff is that we want to float *after*-simplifying a RHS, not before.  If we do so naively we get quadratic-behaviour as things float out.--To see why it's important to do it after, consider this (real) example:--        let t = f x-        in fst t-==>-        let t = let a = e1-                    b = e2-                in (a,b)-        in fst t-==>-        let a = e1-            b = e2-            t = (a,b)-        in-        a       -- Can't inline a this round, cos it appears twice-==>-        e1--Each of the ==> steps is a round of simplification.  We'd save a-whole round if we float first.  This can cascade.  Consider--        let f = g d-        in \x -> ...f...-==>-        let f = let d1 = ..d.. in \y -> e-        in \x -> ...f...-==>-        let d1 = ..d..-        in \x -> ...(\y ->e)...--Only in this second round can the \y be applied, and it-might do the same again.--}--simplExpr :: SimplEnv -> CoreExpr -> SimplM CoreExpr-simplExpr !env (Type ty) -- See Note [Bangs in the Simplifier]-  = do { ty' <- simplType env ty  -- See Note [Avoiding space leaks in OutType]-       ; return (Type ty') }--simplExpr env expr-  = simplExprC env expr (mkBoringStop expr_out_ty)-  where-    expr_out_ty :: OutType-    expr_out_ty = substTy env (exprType expr)-    -- NB: Since 'expr' is term-valued, not (Type ty), this call-    --     to exprType will succeed.  exprType fails on (Type ty).--simplExprC :: SimplEnv-           -> InExpr     -- A term-valued expression, never (Type ty)-           -> SimplCont-           -> SimplM OutExpr-        -- Simplify an expression, given a continuation-simplExprC env expr cont-  = -- pprTrace "simplExprC" (ppr expr $$ ppr cont) $-    do  { (floats, expr') <- simplExprF env expr cont-        ; -- pprTrace "simplExprC ret" (ppr expr $$ ppr expr') $-          -- pprTrace "simplExprC ret3" (ppr (seInScope env')) $-          -- pprTrace "simplExprC ret4" (ppr (seLetFloats env')) $-          return (wrapFloats floats expr') }-----------------------------------------------------simplExprF :: SimplEnv-           -> InExpr     -- A term-valued expression, never (Type ty)-           -> SimplCont-           -> SimplM (SimplFloats, OutExpr)--simplExprF !env e !cont -- See Note [Bangs in the Simplifier]-  = {- pprTrace "simplExprF" (vcat-      [ ppr e-      , text "cont =" <+> ppr cont-      , text "inscope =" <+> ppr (seInScope env)-      , text "tvsubst =" <+> ppr (seTvSubst env)-      , text "idsubst =" <+> ppr (seIdSubst env)-      , text "cvsubst =" <+> ppr (seCvSubst env)-      ]) $ -}-    simplExprF1 env e cont--simplExprF1 :: SimplEnv -> InExpr -> SimplCont-            -> SimplM (SimplFloats, OutExpr)--simplExprF1 _ (Type ty) cont-  = pprPanic "simplExprF: type" (ppr ty <+> text"cont: " <+> ppr cont)-    -- simplExprF does only with term-valued expressions-    -- The (Type ty) case is handled separately by simplExpr-    -- and by the other callers of simplExprF--simplExprF1 env (Var v)        cont = {-#SCC "simplIdF" #-} simplIdF env v cont-simplExprF1 env (Lit lit)      cont = {-#SCC "rebuild" #-} rebuild env (Lit lit) cont-simplExprF1 env (Tick t expr)  cont = {-#SCC "simplTick" #-} simplTick env t expr cont-simplExprF1 env (Cast body co) cont = {-#SCC "simplCast" #-} simplCast env body co cont-simplExprF1 env (Coercion co)  cont = {-#SCC "simplCoercionF" #-} simplCoercionF env co cont--simplExprF1 env (App fun arg) cont-  = {-#SCC "simplExprF1-App" #-} case arg of-      Type ty -> do { -- The argument type will (almost) certainly be used-                      -- in the output program, so just force it now.-                      -- See Note [Avoiding space leaks in OutType]-                      arg' <- simplType env ty--                      -- But use substTy, not simplType, to avoid forcing-                      -- the hole type; it will likely not be needed.-                      -- See Note [The hole type in ApplyToTy]-                    ; let hole' = substTy env (exprType fun)--                    ; simplExprF env fun $-                      ApplyToTy { sc_arg_ty  = arg'-                                , sc_hole_ty = hole'-                                , sc_cont    = cont } }-      _       ->-          -- Crucially, sc_hole_ty is a /lazy/ binding.  It will-          -- be forced only if we need to run contHoleType.-          -- When these are forced, we might get quadratic behavior;-          -- this quadratic blowup could be avoided by drilling down-          -- to the function and getting its multiplicities all at once-          -- (instead of one-at-a-time). But in practice, we have not-          -- observed the quadratic behavior, so this extra entanglement-          -- seems not worthwhile.-        simplExprF env fun $-        ApplyToVal { sc_arg = arg, sc_env = env-                   , sc_hole_ty = substTy env (exprType fun)-                   , sc_dup = NoDup, sc_cont = cont }--simplExprF1 env expr@(Lam {}) cont-  = {-#SCC "simplExprF1-Lam" #-}-    simplLam env (zapLambdaBndrs expr n_args) cont-        -- zapLambdaBndrs: the issue here is under-saturated lambdas-        --   (\x1. \x2. e) arg1-        -- Here x1 might have "occurs-once" occ-info, because occ-info-        -- is computed assuming that a group of lambdas is applied-        -- all at once.  If there are too few args, we must zap the-        -- occ-info, UNLESS the remaining binders are one-shot-  where-    n_args = countArgs cont-        -- NB: countArgs counts all the args (incl type args)-        -- and likewise drop counts all binders (incl type lambdas)--simplExprF1 env (Case scrut bndr _ alts) cont-  = {-#SCC "simplExprF1-Case" #-}-    simplExprF env scrut (Select { sc_dup = NoDup, sc_bndr = bndr-                                 , sc_alts = alts-                                 , sc_env = env, sc_cont = cont })--simplExprF1 env (Let (Rec pairs) body) cont-  | Just pairs' <- joinPointBindings_maybe pairs-  = {-#SCC "simplRecJoinPoin" #-} simplRecJoinPoint env pairs' body cont--  | otherwise-  = {-#SCC "simplRecE" #-} simplRecE env pairs body cont--simplExprF1 env (Let (NonRec bndr rhs) body) cont-  | Type ty <- rhs    -- First deal with type lets (let a = Type ty in e)-  = {-#SCC "simplExprF1-NonRecLet-Type" #-}-    assert (isTyVar bndr) $-    do { ty' <- simplType env ty-       ; simplExprF (extendTvSubst env bndr ty') body cont }--  | Just (bndr', rhs') <- joinPointBinding_maybe bndr rhs-  = {-#SCC "simplNonRecJoinPoint" #-} simplNonRecJoinPoint env bndr' rhs' body cont--  | otherwise-  = {-#SCC "simplNonRecE" #-} simplNonRecE env bndr (rhs, env) body cont--{- Note [Avoiding space leaks in OutType]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Since the simplifier is run for multiple iterations, we need to ensure-that any thunks in the output of one simplifier iteration are forced-by the evaluation of the next simplifier iteration. Otherwise we may-retain multiple copies of the Core program and leak a terrible amount-of memory (as in #13426).--The simplifier is naturally strict in the entire "Expr part" of the-input Core program, because any expression may contain binders, which-we must find in order to extend the SimplEnv accordingly. But types-do not contain binders and so it is tempting to write things like--    simplExpr env (Type ty) = return (Type (substTy env ty))   -- Bad!--This is Bad because the result includes a thunk (substTy env ty) which-retains a reference to the whole simplifier environment; and the next-simplifier iteration will not force this thunk either, because the-line above is not strict in ty.--So instead our strategy is for the simplifier to fully evaluate-OutTypes when it emits them into the output Core program, for example--    simplExpr env (Type ty) = do { ty' <- simplType env ty     -- Good-                                 ; return (Type ty') }--where the only difference from above is that simplType calls seqType-on the result of substTy.--However, SimplCont can also contain OutTypes and it's not necessarily-a good idea to force types on the way in to SimplCont, because they-may end up not being used and forcing them could be a lot of wasted-work. T5631 is a good example of this.--- For ApplyToTy's sc_arg_ty, we force the type on the way in because-  the type will almost certainly appear as a type argument in the-  output program.--- For the hole types in Stop and ApplyToTy, we force the type when we-  emit it into the output program, after obtaining it from-  contResultType. (The hole type in ApplyToTy is only directly used-  to form the result type in a new Stop continuation.)--}-------------------------------------- Simplify a join point, adding the context.--- Context goes *inside* the lambdas. IOW, if the join point has arity n, we do:---   \x1 .. xn -> e => \x1 .. xn -> E[e]--- Note that we need the arity of the join point, since e may be a lambda--- (though this is unlikely). See Note [Join points and case-of-case].-simplJoinRhs :: SimplEnv -> InId -> InExpr -> SimplCont-             -> SimplM OutExpr-simplJoinRhs env bndr expr cont-  | Just arity <- isJoinId_maybe bndr-  =  do { let (join_bndrs, join_body) = collectNBinders arity expr-              mult = contHoleScaling cont-        ; (env', join_bndrs') <- simplLamBndrs env (map (scaleVarBy mult) join_bndrs)-        ; join_body' <- simplExprC env' join_body cont-        ; return $ mkLams join_bndrs' join_body' }--  | otherwise-  = pprPanic "simplJoinRhs" (ppr bndr)------------------------------------simplType :: SimplEnv -> InType -> SimplM OutType-        -- Kept monadic just so we can do the seqType-        -- See Note [Avoiding space leaks in OutType]-simplType env ty-  = -- pprTrace "simplType" (ppr ty $$ ppr (seTvSubst env)) $-    seqType new_ty `seq` return new_ty-  where-    new_ty = substTy env ty------------------------------------simplCoercionF :: SimplEnv -> InCoercion -> SimplCont-               -> SimplM (SimplFloats, OutExpr)-simplCoercionF env co cont-  = do { co' <- simplCoercion env co-       ; rebuild env (Coercion co') cont }--simplCoercion :: SimplEnv -> InCoercion -> SimplM OutCoercion-simplCoercion env co-  = do { opts <- getOptCoercionOpts-       ; let opt_co = optCoercion opts (getTCvSubst env) co-       ; seqCo opt_co `seq` return opt_co }---------------------------------------- | Push a TickIt context outwards past applications and cases, as--- long as this is a non-scoping tick, to let case and application--- optimisations apply.--simplTick :: SimplEnv -> CoreTickish -> InExpr -> SimplCont-          -> SimplM (SimplFloats, OutExpr)-simplTick env tickish expr cont-  -- A scoped tick turns into a continuation, so that we can spot-  -- (scc t (\x . e)) in simplLam and eliminate the scc.  If we didn't do-  -- it this way, then it would take two passes of the simplifier to-  -- reduce ((scc t (\x . e)) e').-  -- NB, don't do this with counting ticks, because if the expr is-  -- bottom, then rebuildCall will discard the continuation.---- XXX: we cannot do this, because the simplifier assumes that--- the context can be pushed into a case with a single branch. e.g.---    scc<f>  case expensive of p -> e--- becomes---    case expensive of p -> scc<f> e------ So I'm disabling this for now.  It just means we will do more--- simplifier iterations that necessary in some cases.----  | tickishScoped tickish && not (tickishCounts tickish)---  = simplExprF env expr (TickIt tickish cont)--  -- For unscoped or soft-scoped ticks, we are allowed to float in new-  -- cost, so we simply push the continuation inside the tick.  This-  -- has the effect of moving the tick to the outside of a case or-  -- application context, allowing the normal case and application-  -- optimisations to fire.-  | tickish `tickishScopesLike` SoftScope-  = do { (floats, expr') <- simplExprF env expr cont-       ; return (floats, mkTick tickish expr')-       }--  -- Push tick inside if the context looks like this will allow us to-  -- do a case-of-case - see Note [case-of-scc-of-case]-  | Select {} <- cont, Just expr' <- push_tick_inside-  = simplExprF env expr' cont--  -- We don't want to move the tick, but we might still want to allow-  -- floats to pass through with appropriate wrapping (or not, see-  -- wrap_floats below)-  --- | not (tickishCounts tickish) || tickishCanSplit tickish-  -- = wrap_floats--  | otherwise-  = no_floating_past_tick-- where--  -- Try to push tick inside a case, see Note [case-of-scc-of-case].-  push_tick_inside =-    case expr0 of-      Case scrut bndr ty alts-             -> Just $ Case (tickScrut scrut) bndr ty (map tickAlt alts)-      _other -> Nothing-   where (ticks, expr0) = stripTicksTop movable (Tick tickish expr)-         movable t      = not (tickishCounts t) ||-                          t `tickishScopesLike` NoScope ||-                          tickishCanSplit t-         tickScrut e    = foldr mkTick e ticks-         -- Alternatives get annotated with all ticks that scope in some way,-         -- but we don't want to count entries.-         tickAlt (Alt c bs e) = Alt c bs (foldr mkTick e ts_scope)-         ts_scope         = map mkNoCount $-                            filter (not . (`tickishScopesLike` NoScope)) ticks--  no_floating_past_tick =-    do { let (inc,outc) = splitCont cont-       ; (floats, expr1) <- simplExprF env expr inc-       ; let expr2    = wrapFloats floats expr1-             tickish' = simplTickish env tickish-       ; rebuild env (mkTick tickish' expr2) outc-       }---- Alternative version that wraps outgoing floats with the tick.  This--- results in ticks being duplicated, as we don't make any attempt to--- eliminate the tick if we re-inline the binding (because the tick--- semantics allows unrestricted inlining of HNFs), so I'm not doing--- this any more.  FloatOut will catch any real opportunities for--- floating.------  wrap_floats =---    do { let (inc,outc) = splitCont cont---       ; (env', expr') <- simplExprF (zapFloats env) expr inc---       ; let tickish' = simplTickish env tickish---       ; let wrap_float (b,rhs) = (zapIdDmdSig (setIdArity b 0),---                                   mkTick (mkNoCount tickish') rhs)---              -- when wrapping a float with mkTick, we better zap the Id's---              -- strictness info and arity, because it might be wrong now.---       ; let env'' = addFloats env (mapFloats env' wrap_float)---       ; rebuild env'' expr' (TickIt tickish' outc)---       }---  simplTickish env tickish-    | Breakpoint ext n ids <- tickish-          = Breakpoint ext n (map (getDoneId . substId env) ids)-    | otherwise = tickish--  -- Push type application and coercion inside a tick-  splitCont :: SimplCont -> (SimplCont, SimplCont)-  splitCont cont@(ApplyToTy { sc_cont = tail }) = (cont { sc_cont = inc }, outc)-    where (inc,outc) = splitCont tail-  splitCont (CastIt co c) = (CastIt co inc, outc)-    where (inc,outc) = splitCont c-  splitCont other = (mkBoringStop (contHoleType other), other)--  getDoneId (DoneId id)  = id-  getDoneId (DoneEx e _) = getIdFromTrivialExpr e -- Note [substTickish] in GHC.Core.Subst-  getDoneId other = pprPanic "getDoneId" (ppr other)---- Note [case-of-scc-of-case]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~--- It's pretty important to be able to transform case-of-case when--- there's an SCC in the way.  For example, the following comes up--- in nofib/real/compress/Encode.hs:------        case scctick<code_string.r1>---             case $wcode_string_r13s wild_XC w1_s137 w2_s138 l_aje---             of _ { (# ww1_s13f, ww2_s13g, ww3_s13h #) ->---             (ww1_s13f, ww2_s13g, ww3_s13h)---             }---        of _ { (ww_s12Y, ww1_s12Z, ww2_s130) ->---        tick<code_string.f1>---        (ww_s12Y,---         ww1_s12Z,---         PTTrees.PT---           @ GHC.Types.Char @ GHC.Types.Int wild2_Xj ww2_s130 r_ajf)---        }------ We really want this case-of-case to fire, because then the 3-tuple--- will go away (indeed, the CPR optimisation is relying on this--- happening).  But the scctick is in the way - we need to push it--- inside to expose the case-of-case.  So we perform this--- transformation on the inner case:------   scctick c (case e of { p1 -> e1; ...; pn -> en })---    ==>---   case (scctick c e) of { p1 -> scc c e1; ...; pn -> scc c en }------ So we've moved a constant amount of work out of the scc to expose--- the case.  We only do this when the continuation is interesting: in--- for now, it has to be another Case (maybe generalise this later).--{--************************************************************************-*                                                                      *-\subsection{The main rebuilder}-*                                                                      *-************************************************************************--}--rebuild :: SimplEnv -> OutExpr -> SimplCont -> SimplM (SimplFloats, OutExpr)--- At this point the substitution in the SimplEnv should be irrelevant;--- only the in-scope set matters-rebuild env expr cont-  = case cont of-      Stop {}          -> return (emptyFloats env, expr)-      TickIt t cont    -> rebuild env (mkTick t expr) cont-      CastIt co cont   -> rebuild env (mkCast expr co) cont-                       -- NB: mkCast implements the (Coercion co |> g) optimisation--      Select { sc_bndr = bndr, sc_alts = alts, sc_env = se, sc_cont = cont }-        -> rebuildCase (se `setInScopeFromE` env) expr bndr alts cont--      StrictArg { sc_fun = fun, sc_cont = cont, sc_fun_ty = fun_ty }-        -> rebuildCall env (addValArgTo fun expr fun_ty ) cont-      StrictBind { sc_bndr = b, sc_body = body-                 , sc_env = se, sc_cont = cont }-        -> do { (floats1, env') <- simplNonRecX (se `setInScopeFromE` env) b expr-                                  -- expr satisfies let/app since it started life-                                  -- in a call to simplNonRecE-              ; (floats2, expr') <- simplLam env' body cont-              ; return (floats1 `addFloats` floats2, expr') }--      ApplyToTy  { sc_arg_ty = ty, sc_cont = cont}-        -> rebuild env (App expr (Type ty)) cont--      ApplyToVal { sc_arg = arg, sc_env = se, sc_dup = dup_flag, sc_cont = cont}-        -- See Note [Avoid redundant simplification]-        -> do { (_, _, arg') <- simplArg env dup_flag se arg-              ; rebuild env (App expr arg') cont }--{--************************************************************************-*                                                                      *-\subsection{Lambdas}-*                                                                      *-************************************************************************--}--{- Note [Optimising reflexivity]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-It's important (for compiler performance) to get rid of reflexivity as soon-as it appears.  See #11735, #14737, and #15019.--In particular, we want to behave well on-- *  e |> co1 |> co2-    where the two happen to cancel out entirely. That is quite common;-    e.g. a newtype wrapping and unwrapping cancel.--- * (f |> co) @t1 @t2 ... @tn x1 .. xm-   Here we will use pushCoTyArg and pushCoValArg successively, which-   build up NthCo stacks.  Silly to do that if co is reflexive.--However, we don't want to call isReflexiveCo too much, because it uses-type equality which is expensive on big types (#14737 comment:7).--A good compromise (determined experimentally) seems to be to call-isReflexiveCo- * when composing casts, and- * at the end--In investigating this I saw missed opportunities for on-the-fly-coercion shrinkage. See #15090.--}---simplCast :: SimplEnv -> InExpr -> Coercion -> SimplCont-          -> SimplM (SimplFloats, OutExpr)-simplCast env body co0 cont0-  = do  { co1   <- {-#SCC "simplCast-simplCoercion" #-} simplCoercion env co0-        ; cont1 <- {-#SCC "simplCast-addCoerce" #-}-                   if isReflCo co1-                   then return cont0  -- See Note [Optimising reflexivity]-                   else addCoerce co1 cont0-        ; {-#SCC "simplCast-simplExprF" #-} simplExprF env body cont1 }-  where-        -- If the first parameter is MRefl, then simplifying revealed a-        -- reflexive coercion. Omit.-        addCoerceM :: MOutCoercion -> SimplCont -> SimplM SimplCont-        addCoerceM MRefl   cont = return cont-        addCoerceM (MCo co) cont = addCoerce co cont--        addCoerce :: OutCoercion -> SimplCont -> SimplM SimplCont-        addCoerce co1 (CastIt co2 cont)  -- See Note [Optimising reflexivity]-          | isReflexiveCo co' = return cont-          | otherwise         = addCoerce co' cont-          where-            co' = mkTransCo co1 co2--        addCoerce co (ApplyToTy { sc_arg_ty = arg_ty, sc_cont = tail })-          | Just (arg_ty', m_co') <- pushCoTyArg co arg_ty-          = {-#SCC "addCoerce-pushCoTyArg" #-}-            do { tail' <- addCoerceM m_co' tail-               ; return (ApplyToTy { sc_arg_ty  = arg_ty'-                                   , sc_cont    = tail'-                                   , sc_hole_ty = coercionLKind co }) }-                                        -- NB!  As the cast goes past, the-                                        -- type of the hole changes (#16312)--        -- (f |> co) e   ===>   (f (e |> co1)) |> co2-        -- where   co :: (s1->s2) ~ (t1->t2)-        --         co1 :: t1 ~ s1-        --         co2 :: s2 ~ t2-        addCoerce co cont@(ApplyToVal { sc_arg = arg, sc_env = arg_se-                                      , sc_dup = dup, sc_cont = tail })-          | Just (m_co1, m_co2) <- pushCoValArg co-          , fixed_rep m_co1-          = {-#SCC "addCoerce-pushCoValArg" #-}-            do { tail' <- addCoerceM m_co2 tail-               ; case m_co1 of {-                   MRefl -> return (cont { sc_cont = tail'-                                         , sc_hole_ty = coercionLKind co }) ;-                      -- Avoid simplifying if possible;-                      -- See Note [Avoiding exponential behaviour]--                   MCo co1 ->-            do { (dup', arg_se', arg') <- simplArg env dup arg_se arg-                    -- When we build the ApplyTo we can't mix the OutCoercion-                    -- 'co' with the InExpr 'arg', so we simplify-                    -- to make it all consistent.  It's a bit messy.-                    -- But it isn't a common case.-                    -- Example of use: #995-               ; return (ApplyToVal { sc_arg  = mkCast arg' co1-                                    , sc_env  = arg_se'-                                    , sc_dup  = dup'-                                    , sc_cont = tail'-                                    , sc_hole_ty = coercionLKind co }) } } }--        addCoerce co cont-          | isReflexiveCo co = return cont  -- Having this at the end makes a huge-                                            -- difference in T12227, for some reason-                                            -- See Note [Optimising reflexivity]-          | otherwise        = return (CastIt co cont)--        fixed_rep :: MCoercionR -> Bool-        fixed_rep MRefl    = True-        fixed_rep (MCo co) = typeHasFixedRuntimeRep $ coercionRKind co-          -- Without this check, we can get an argument which does not-          -- have a fixed runtime representation.-          -- See Note [Representation polymorphism invariants] in GHC.Core-          -- test: typecheck/should_run/EtaExpandLevPoly--simplArg :: SimplEnv -> DupFlag -> StaticEnv -> CoreExpr-         -> SimplM (DupFlag, StaticEnv, OutExpr)-simplArg env dup_flag arg_env arg-  | isSimplified dup_flag-  = return (dup_flag, arg_env, arg)-  | otherwise-  = do { let arg_env' = arg_env `setInScopeFromE` env-       ; arg' <- simplExpr arg_env'  arg-       ; return (Simplified, zapSubstEnv arg_env', arg') }-         -- Return a StaticEnv that includes the in-scope set from 'env',-         -- because arg' may well mention those variables (#20639)--{--************************************************************************-*                                                                      *-\subsection{Lambdas}-*                                                                      *-************************************************************************--}--simplLam :: SimplEnv -> InExpr -> SimplCont-         -> SimplM (SimplFloats, OutExpr)--simplLam env (Lam bndr body) cont = simpl_lam env bndr body cont-simplLam env expr            cont = simplExprF env expr cont--simpl_lam :: SimplEnv -> InBndr -> InExpr -> SimplCont-          -> SimplM (SimplFloats, OutExpr)---- Type beta-reduction-simpl_lam env bndr body (ApplyToTy { sc_arg_ty = arg_ty, sc_cont = cont })-  = do { tick (BetaReduction bndr)-       ; simplLam (extendTvSubst env bndr arg_ty) body cont }---- Value beta-reduction-simpl_lam env bndr body (ApplyToVal { sc_arg = arg, sc_env = arg_se-                                    , sc_cont = cont, sc_dup = dup })-  | isSimplified dup  -- Don't re-simplify if we've simplified it once-                      -- See Note [Avoiding exponential behaviour]-  = do  { tick (BetaReduction bndr)-        ; (floats1, env') <- simplNonRecX env bndr arg-        ; (floats2, expr') <- simplLam env' body cont-        ; return (floats1 `addFloats` floats2, expr') }--  | otherwise-  = do  { tick (BetaReduction bndr)-        ; simplNonRecE env bndr (arg, arg_se) body cont }---- Discard a non-counting tick on a lambda.  This may change the--- cost attribution slightly (moving the allocation of the--- lambda elsewhere), but we don't care: optimisation changes--- cost attribution all the time.-simpl_lam env bndr body (TickIt tickish cont)-  | not (tickishCounts tickish)-  = simpl_lam env bndr body cont---- Not enough args, so there are real lambdas left to put in the result-simpl_lam env bndr body cont-  = do  { let (inner_bndrs, inner_body) = collectBinders body-        ; (env', bndrs') <- simplLamBndrs env (bndr:inner_bndrs)-        ; body'   <- simplExpr env' inner_body-        ; new_lam <- mkLam env' bndrs' body' cont-        ; rebuild env' new_lam cont }----------------simplLamBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)--- Historically this had a special case for when a lambda-binder--- could have a stable unfolding;--- see Historical Note [Case binders and join points]--- But now it is much simpler! We now only remove unfoldings.--- See Note [Never put `OtherCon` unfoldings on lambda binders]-simplLamBndr env bndr = simplBinder env (zapIdUnfolding bndr)--simplLamBndrs :: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr])-simplLamBndrs env bndrs = mapAccumLM simplLamBndr env bndrs---------------------simplNonRecE :: SimplEnv-             -> InId                    -- The binder, always an Id-                                        -- Never a join point-             -> (InExpr, SimplEnv)      -- Rhs of binding (or arg of lambda)-             -> InExpr                  -- Body of the let/lambda-             -> SimplCont-             -> SimplM (SimplFloats, OutExpr)---- simplNonRecE is used for---  * non-top-level non-recursive non-join-point lets in expressions---  * beta reduction------ simplNonRec env b (rhs, rhs_se) body k---   = let env in---     cont< let b = rhs_se(rhs) in body >------ It deals with strict bindings, via the StrictBind continuation,--- which may abort the whole process------ Precondition: rhs satisfies the let/app invariant---               Note [Core let/app invariant] in GHC.Core--simplNonRecE env bndr (rhs, rhs_se) body cont-  | assert (isId bndr && not (isJoinId bndr) ) True-  , Just env' <- preInlineUnconditionally env NotTopLevel bndr rhs rhs_se-  = do { tick (PreInlineUnconditionally bndr)-       ; -- pprTrace "preInlineUncond" (ppr bndr <+> ppr rhs) $-         simplLam env' body cont }--  | otherwise-  = do { (env1, bndr1) <- simplNonRecBndr env bndr--       -- Deal with strict bindings-       -- See Note [Dark corner with representation polymorphism]-       ; if isStrictId bndr1 && sm_case_case (getMode env)-         then simplExprF (rhs_se `setInScopeFromE` env) rhs-                   (StrictBind { sc_bndr = bndr, sc_body = body-                               , sc_env = env, sc_cont = cont, sc_dup = NoDup })--       -- Deal with lazy bindings-         else do-       { (env2, bndr2)    <- addBndrRules env1 bndr bndr1 (BC_Let NotTopLevel NonRecursive)-       ; (floats1, env3)  <- simplLazyBind env2 NotTopLevel NonRecursive bndr bndr2 rhs rhs_se-       ; (floats2, expr') <- simplLam env3 body cont-       ; return (floats1 `addFloats` floats2, expr') } }---------------------simplRecE :: SimplEnv-          -> [(InId, InExpr)]-          -> InExpr-          -> SimplCont-          -> SimplM (SimplFloats, OutExpr)---- simplRecE is used for---  * non-top-level recursive lets in expressions--- Precondition: not a join-point binding-simplRecE env pairs body cont-  = do  { let bndrs = map fst pairs-        ; massert (all (not . isJoinId) bndrs)-        ; env1 <- simplRecBndrs env bndrs-                -- NB: bndrs' don't have unfoldings or rules-                -- We add them as we go down-        ; (floats1, env2)  <- simplRecBind env1 (BC_Let NotTopLevel Recursive) pairs-        ; (floats2, expr') <- simplExprF env2 body cont-        ; return (floats1 `addFloats` floats2, expr') }--{- Note [Dark corner with representation polymorphism]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In `simplNonRecE`, the call to `isStrictId` will fail if the binder-does not have a fixed runtime representation, e.g. if it is of kind (TYPE r).-So we are careful to call `isStrictId` on the OutId, not the InId, in case we have-     ((\(r::RuntimeRep) \(x::TYPE r). blah) Lifted arg)-That will lead to `simplNonRecE env (x::TYPE r) arg`, and we can't tell-if x is lifted or unlifted from that.--We only get such redexes from the compulsory inlining of a wired-in,-representation-polymorphic function like `rightSection` (see-GHC.Types.Id.Make).  Mind you, SimpleOpt should probably have inlined-such compulsory inlinings already, but belt and braces does no harm.--Plus, it turns out that GHC.Driver.Main.hscCompileCoreExpr calls the-Simplifier without first calling SimpleOpt, so anything involving-GHCi or TH and operator sections will fall over if we don't take-care here.--Note [Avoiding exponential behaviour]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-One way in which we can get exponential behaviour is if we simplify a-big expression, and the re-simplify it -- and then this happens in a-deeply-nested way.  So we must be jolly careful about re-simplifying-an expression.  That is why simplNonRecX does not try-preInlineUnconditionally (unlike simplNonRecE).--Example:-  f BIG, where f has a RULE-Then- * We simplify BIG before trying the rule; but the rule does not fire- * We inline f = \x. x True- * So if we did preInlineUnconditionally we'd re-simplify (BIG True)--However, if BIG has /not/ already been simplified, we'd /like/ to-simplify BIG True; maybe good things happen.  That is why--* simplLam has-    - a case for (isSimplified dup), which goes via simplNonRecX, and-    - a case for the un-simplified case, which goes via simplNonRecE--* We go to some efforts to avoid unnecessarily simplifying ApplyToVal,-  in at least two places-    - In simplCast/addCoerce, where we check for isReflCo-    - In rebuildCall we avoid simplifying arguments before we have to-      (see Note [Trying rewrite rules])---************************************************************************-*                                                                      *-                     Join points-*                                                                      *-********************************************************************* -}--{- Note [Rules and unfolding for join points]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose we have--   simplExpr (join j x = rhs                         ) cont-             (      {- RULE j (p:ps) = blah -}       )-             (      {- StableUnfolding j = blah -}   )-             (in blah                                )--Then we will push 'cont' into the rhs of 'j'.  But we should *also* push-'cont' into the RHS of-  * Any RULEs for j, e.g. generated by SpecConstr-  * Any stable unfolding for j, e.g. the result of an INLINE pragma--Simplifying rules and stable-unfoldings happens a bit after-simplifying the right-hand side, so we remember whether or not it-is a join point, and what 'cont' is, in a value of type MaybeJoinCont--#13900 was caused by forgetting to push 'cont' into the RHS-of a SpecConstr-generated RULE for a join point.--}--simplNonRecJoinPoint :: SimplEnv -> InId -> InExpr-                     -> InExpr -> SimplCont-                     -> SimplM (SimplFloats, OutExpr)-simplNonRecJoinPoint env bndr rhs body cont-  | assert (isJoinId bndr ) True-  , Just env' <- preInlineUnconditionally env NotTopLevel bndr rhs env-  = do { tick (PreInlineUnconditionally bndr)-       ; simplExprF env' body cont }--   | otherwise-   = wrapJoinCont env cont $ \ env cont ->-     do { -- We push join_cont into the join RHS and the body;-          -- and wrap wrap_cont around the whole thing-        ; let mult   = contHoleScaling cont-              res_ty = contResultType cont-        ; (env1, bndr1)    <- simplNonRecJoinBndr env bndr mult res_ty-        ; (env2, bndr2)    <- addBndrRules env1 bndr bndr1 (BC_Join cont)-        ; (floats1, env3)  <- simplJoinBind env2 cont bndr bndr2 rhs env-        ; (floats2, body') <- simplExprF env3 body cont-        ; return (floats1 `addFloats` floats2, body') }----------------------simplRecJoinPoint :: SimplEnv -> [(InId, InExpr)]-                  -> InExpr -> SimplCont-                  -> SimplM (SimplFloats, OutExpr)-simplRecJoinPoint env pairs body cont-  = wrapJoinCont env cont $ \ env cont ->-    do { let bndrs  = map fst pairs-             mult   = contHoleScaling cont-             res_ty = contResultType cont-       ; env1 <- simplRecJoinBndrs env bndrs mult res_ty-               -- NB: bndrs' don't have unfoldings or rules-               -- We add them as we go down-       ; (floats1, env2)  <- simplRecBind env1 (BC_Join cont) pairs-       ; (floats2, body') <- simplExprF env2 body cont-       ; return (floats1 `addFloats` floats2, body') }-----------------------wrapJoinCont :: SimplEnv -> SimplCont-             -> (SimplEnv -> SimplCont -> SimplM (SimplFloats, OutExpr))-             -> SimplM (SimplFloats, OutExpr)--- Deal with making the continuation duplicable if necessary,--- and with the no-case-of-case situation.-wrapJoinCont env cont thing_inside-  | contIsStop cont        -- Common case; no need for fancy footwork-  = thing_inside env cont--  | not (sm_case_case (getMode env))-    -- See Note [Join points with -fno-case-of-case]-  = do { (floats1, expr1) <- thing_inside env (mkBoringStop (contHoleType cont))-       ; let (floats2, expr2) = wrapJoinFloatsX floats1 expr1-       ; (floats3, expr3) <- rebuild (env `setInScopeFromF` floats2) expr2 cont-       ; return (floats2 `addFloats` floats3, expr3) }--  | otherwise-    -- Normal case; see Note [Join points and case-of-case]-  = do { (floats1, cont')  <- mkDupableCont env cont-       ; (floats2, result) <- thing_inside (env `setInScopeFromF` floats1) cont'-       ; return (floats1 `addFloats` floats2, result) }------------------------trimJoinCont :: Id -> Maybe JoinArity -> SimplCont -> SimplCont--- Drop outer context from join point invocation (jump)--- See Note [Join points and case-of-case]--trimJoinCont _ Nothing cont-  = cont -- Not a jump-trimJoinCont var (Just arity) cont-  = trim arity cont-  where-    trim 0 cont@(Stop {})-      = cont-    trim 0 cont-      = mkBoringStop (contResultType cont)-    trim n cont@(ApplyToVal { sc_cont = k })-      = cont { sc_cont = trim (n-1) k }-    trim n cont@(ApplyToTy { sc_cont = k })-      = cont { sc_cont = trim (n-1) k } -- join arity counts types!-    trim _ cont-      = pprPanic "completeCall" $ ppr var $$ ppr cont---{- Note [Join points and case-of-case]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When we perform the case-of-case transform (or otherwise push continuations-inward), we want to treat join points specially. Since they're always-tail-called and we want to maintain this invariant, we can do this (for any-evaluation context E):--  E[join j = e-    in case ... of-         A -> jump j 1-         B -> jump j 2-         C -> f 3]--    -->--  join j = E[e]-  in case ... of-       A -> jump j 1-       B -> jump j 2-       C -> E[f 3]--As is evident from the example, there are two components to this behavior:--  1. When entering the RHS of a join point, copy the context inside.-  2. When a join point is invoked, discard the outer context.--We need to be very careful here to remain consistent---neither part is-optional!--We need do make the continuation E duplicable (since we are duplicating it)-with mkDupableCont.---Note [Join points with -fno-case-of-case]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Supose case-of-case is switched off, and we are simplifying--    case (join j x = <j-rhs> in-          case y of-             A -> j 1-             B -> j 2-             C -> e) of <outer-alts>--Usually, we'd push the outer continuation (case . of <outer-alts>) into-both the RHS and the body of the join point j.  But since we aren't doing-case-of-case we may then end up with this totally bogus result--    join x = case <j-rhs> of <outer-alts> in-    case (case y of-             A -> j 1-             B -> j 2-             C -> e) of <outer-alts>--This would be OK in the language of the paper, but not in GHC: j is no longer-a join point.  We can only do the "push continuation into the RHS of the-join point j" if we also push the continuation right down to the /jumps/ to-j, so that it can evaporate there.  If we are doing case-of-case, we'll get to--    join x = case <j-rhs> of <outer-alts> in-    case y of-      A -> j 1-      B -> j 2-      C -> case e of <outer-alts>--which is great.--Bottom line: if case-of-case is off, we must stop pushing the continuation-inwards altogether at any join point.  Instead simplify the (join ... in ...)-with a Stop continuation, and wrap the original continuation around the-outside.  Surprisingly tricky!---************************************************************************-*                                                                      *-                     Variables-*                                                                      *-************************************************************************--}--simplVar :: SimplEnv -> InVar -> SimplM OutExpr--- Look up an InVar in the environment-simplVar env var-  -- Why $! ? See Note [Bangs in the Simplifier]-  | isTyVar var = return $! Type $! (substTyVar env var)-  | isCoVar var = return $! Coercion $! (substCoVar env var)-  | otherwise-  = case substId env var of-        ContEx tvs cvs ids e -> let env' = setSubstEnv env tvs cvs ids-                                in simplExpr env' e-        DoneId var1          -> return (Var var1)-        DoneEx e _           -> return e--simplIdF :: SimplEnv -> InId -> SimplCont -> SimplM (SimplFloats, OutExpr)-simplIdF env var cont-  = case substId env var of-      ContEx tvs cvs ids e ->-          let env' = setSubstEnv env tvs cvs ids-          in simplExprF env' e cont-          -- Don't trim; haven't already simplified e,-          -- so the cont is not embodied in e--      DoneId var1 ->-          let cont' = trimJoinCont var (isJoinId_maybe var1) cont-          in completeCall env var1 cont'--      DoneEx e mb_join ->-          let env' = zapSubstEnv env-              cont' = trimJoinCont var mb_join cont-          in simplExprF env' e cont'-              -- Note [zapSubstEnv]-              -- ~~~~~~~~~~~~~~~~~~-              -- The template is already simplified, so don't re-substitute.-              -- This is VITAL.  Consider-              --      let x = e in-              --      let y = \z -> ...x... in-              --      \ x -> ...y...-              -- We'll clone the inner \x, adding x->x' in the id_subst-              -- Then when we inline y, we must *not* replace x by x' in-              -- the inlined copy!!--------------------------------------------------------------      Dealing with a call site--completeCall :: SimplEnv -> OutId -> SimplCont -> SimplM (SimplFloats, OutExpr)-completeCall env var cont-  | Just expr <- callSiteInline logger uf_opts case_depth var active_unf-                                lone_variable arg_infos interesting_cont-  -- Inline the variable's RHS-  = do { checkedTick (UnfoldingDone var)-       ; dump_inline expr cont-       ; let env1 = zapSubstEnv env-       ; simplExprF env1 expr cont }--  | otherwise-  -- Don't inline; instead rebuild the call-  = do { rule_base <- getSimplRules-       ; let rules = getRules rule_base var-             info = mkArgInfo env var rules-                              n_val_args call_cont-       ; rebuildCall env info cont }--  where-    uf_opts    = seUnfoldingOpts env-    case_depth = seCaseDepth env-    logger     = seLogger env-    (lone_variable, arg_infos, call_cont) = contArgs cont-    n_val_args       = length arg_infos-    interesting_cont = interestingCallContext env call_cont-    active_unf       = activeUnfolding (getMode env) var--    log_inlining doc-      = liftIO $ logDumpFile logger (mkDumpStyle alwaysQualify)-           Opt_D_dump_inlinings-           "" FormatText doc--    dump_inline unfolding cont-      | not (logHasDumpFlag logger Opt_D_dump_inlinings) = return ()-      | not (logHasDumpFlag logger Opt_D_verbose_core2core)-      = when (isExternalName (idName var)) $-            log_inlining $-                sep [text "Inlining done:", nest 4 (ppr var)]-      | otherwise-      = log_inlining $-           sep [text "Inlining done: " <> ppr var,-                nest 4 (vcat [text "Inlined fn: " <+> nest 2 (ppr unfolding),-                              text "Cont:  " <+> ppr cont])]--rebuildCall :: SimplEnv-            -> ArgInfo-            -> SimplCont-            -> SimplM (SimplFloats, OutExpr)--- We decided not to inline, so---    - simplify the arguments---    - try rewrite rules---    - and rebuild------------ Bottoming applications ---------------rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_dmds = [] }) cont-  -- When we run out of strictness args, it means-  -- that the call is definitely bottom; see GHC.Core.Opt.Simplify.Utils.mkArgInfo-  -- Then we want to discard the entire strict continuation.  E.g.-  --    * case (error "hello") of { ... }-  --    * (error "Hello") arg-  --    * f (error "Hello") where f is strict-  --    etc-  -- Then, especially in the first of these cases, we'd like to discard-  -- the continuation, leaving just the bottoming expression.  But the-  -- type might not be right, so we may have to add a coerce.-  | not (contIsTrivial cont)     -- Only do this if there is a non-trivial-                                 -- continuation to discard, else we do it-                                 -- again and again!-  = seqType cont_ty `seq`        -- See Note [Avoiding space leaks in OutType]-    return (emptyFloats env, castBottomExpr res cont_ty)-  where-    res     = argInfoExpr fun rev_args-    cont_ty = contResultType cont------------ Try rewrite RULES ----------------- See Note [Trying rewrite rules]-rebuildCall env info@(ArgInfo { ai_fun = fun, ai_args = rev_args-                              , ai_rules = Just (nr_wanted, rules) }) cont-  | nr_wanted == 0 || no_more_args-  , let info' = info { ai_rules = Nothing }-  = -- We've accumulated a simplified call in <fun,rev_args>-    -- so try rewrite rules; see Note [RULES apply to simplified arguments]-    -- See also Note [Rules for recursive functions]-    do { mb_match <- tryRules env rules fun (reverse rev_args) cont-       ; case mb_match of-             Just (env', rhs, cont') -> simplExprF env' rhs cont'-             Nothing                 -> rebuildCall env info' cont }-  where-    no_more_args = case cont of-                      ApplyToTy  {} -> False-                      ApplyToVal {} -> False-                      _             -> True------------- Simplify applications and casts ---------------rebuildCall env info (CastIt co cont)-  = rebuildCall env (addCastTo info co) cont--rebuildCall env info (ApplyToTy { sc_arg_ty = arg_ty, sc_hole_ty = hole_ty, sc_cont = cont })-  = rebuildCall env (addTyArgTo info arg_ty hole_ty) cont------------ The runRW# rule. Do this after absorbing all arguments --------- See Note [Simplification of runRW#] in GHC.CoreToSTG.Prep.------ runRW# :: forall (r :: RuntimeRep) (o :: TYPE r). (State# RealWorld -> o) -> o--- K[ runRW# rr ty body ]   -->   runRW rr' ty' (\s. K[ body s ])-rebuildCall env (ArgInfo { ai_fun = fun_id, ai_args = rev_args })-            (ApplyToVal { sc_arg = arg, sc_env = arg_se-                        , sc_cont = cont, sc_hole_ty = fun_ty })-  | fun_id `hasKey` runRWKey-  , not (contIsStop cont)  -- Don't fiddle around if the continuation is boring-  , [ TyArg {}, TyArg {} ] <- rev_args-  = do { s <- newId (fsLit "s") Many realWorldStatePrimTy-       ; let (m,_,_) = splitFunTy fun_ty-             env'  = (arg_se `setInScopeFromE` env) `addNewInScopeIds` [s]-             ty'   = contResultType cont-             cont' = ApplyToVal { sc_dup = Simplified, sc_arg = Var s-                                , sc_env = env', sc_cont = cont-                                , sc_hole_ty = mkVisFunTy m realWorldStatePrimTy ty' }-                     -- cont' applies to s, then K-       ; body' <- simplExprC env' arg cont'-       ; let arg'  = Lam s body'-             rr'   = getRuntimeRep ty'-             call' = mkApps (Var fun_id) [mkTyArg rr', mkTyArg ty', arg']-       ; return (emptyFloats env, call') }--rebuildCall env fun_info-            (ApplyToVal { sc_arg = arg, sc_env = arg_se-                        , sc_dup = dup_flag, sc_hole_ty = fun_ty-                        , sc_cont = cont })-  -- Argument is already simplified-  | isSimplified dup_flag     -- See Note [Avoid redundant simplification]-  = rebuildCall env (addValArgTo fun_info arg fun_ty) cont--  -- Strict arguments-  | isStrictArgInfo fun_info-  , sm_case_case (getMode env)-  = -- pprTrace "Strict Arg" (ppr arg $$ ppr (seIdSubst env) $$ ppr (seInScope env)) $-    simplExprF (arg_se `setInScopeFromE` env) arg-               (StrictArg { sc_fun = fun_info, sc_fun_ty = fun_ty-                          , sc_dup = Simplified-                          , sc_cont = cont })-                -- Note [Shadowing]--  -- Lazy arguments-  | otherwise-        -- DO NOT float anything outside, hence simplExprC-        -- There is no benefit (unlike in a let-binding), and we'd-        -- have to be very careful about bogus strictness through-        -- floating a demanded let.-  = do  { arg' <- simplExprC (arg_se `setInScopeFromE` env) arg-                             (mkLazyArgStop arg_ty (lazyArgContext fun_info))-        ; rebuildCall env (addValArgTo fun_info  arg' fun_ty) cont }-  where-    arg_ty = funArgTy fun_ty------------- No further useful info, revert to generic rebuild -------------rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args }) cont-  = rebuild env (argInfoExpr fun rev_args) cont--{- Note [Trying rewrite rules]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider an application (f e1 e2 e3) where the e1,e2,e3 are not yet-simplified.  We want to simplify enough arguments to allow the rules-to apply, but it's more efficient to avoid simplifying e2,e3 if e1 alone-is sufficient.  Example: class ops-   (+) dNumInt e2 e3-If we rewrite ((+) dNumInt) to plusInt, we can take advantage of the-latter's strictness when simplifying e2, e3.  Moreover, suppose we have-  RULE  f Int = \x. x True--Then given (f Int e1) we rewrite to-   (\x. x True) e1-without simplifying e1.  Now we can inline x into its unique call site,-and absorb the True into it all in the same pass.  If we simplified-e1 first, we couldn't do that; see Note [Avoiding exponential behaviour].--So we try to apply rules if either-  (a) no_more_args: we've run out of argument that the rules can "see"-  (b) nr_wanted: none of the rules wants any more arguments---Note [RULES apply to simplified arguments]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-It's very desirable to try RULES once the arguments have been simplified, because-doing so ensures that rule cascades work in one pass.  Consider-   {-# RULES g (h x) = k x-             f (k x) = x #-}-   ...f (g (h x))...-Then we want to rewrite (g (h x)) to (k x) and only then try f's rules. If-we match f's rules against the un-simplified RHS, it won't match.  This-makes a particularly big difference when superclass selectors are involved:-        op ($p1 ($p2 (df d)))-We want all this to unravel in one sweep.--Note [Avoid redundant simplification]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Because RULES apply to simplified arguments, there's a danger of repeatedly-simplifying already-simplified arguments.  An important example is that of-        (>>=) d e1 e2-Here e1, e2 are simplified before the rule is applied, but don't really-participate in the rule firing. So we mark them as Simplified to avoid-re-simplifying them.--Note [Shadowing]-~~~~~~~~~~~~~~~~-This part of the simplifier may break the no-shadowing invariant-Consider-        f (...(\a -> e)...) (case y of (a,b) -> e')-where f is strict in its second arg-If we simplify the innermost one first we get (...(\a -> e)...)-Simplifying the second arg makes us float the case out, so we end up with-        case y of (a,b) -> f (...(\a -> e)...) e'-So the output does not have the no-shadowing invariant.  However, there is-no danger of getting name-capture, because when the first arg was simplified-we used an in-scope set that at least mentioned all the variables free in its-static environment, and that is enough.--We can't just do innermost first, or we'd end up with a dual problem:-        case x of (a,b) -> f e (...(\a -> e')...)--I spent hours trying to recover the no-shadowing invariant, but I just could-not think of an elegant way to do it.  The simplifier is already knee-deep in-continuations.  We have to keep the right in-scope set around; AND we have-to get the effect that finding (error "foo") in a strict arg position will-discard the entire application and replace it with (error "foo").  Getting-all this at once is TOO HARD!---************************************************************************-*                                                                      *-                Rewrite rules-*                                                                      *-************************************************************************--}--tryRules :: SimplEnv -> [CoreRule]-         -> Id -> [ArgSpec]-         -> SimplCont-         -> SimplM (Maybe (SimplEnv, CoreExpr, SimplCont))--tryRules env rules fn args call_cont-  | null rules-  = return Nothing--{- Disabled until we fix #8326-  | fn `hasKey` tagToEnumKey   -- See Note [Optimising tagToEnum#]-  , [_type_arg, val_arg] <- args-  , Select dup bndr ((_,[],rhs1) : rest_alts) se cont <- call_cont-  , isDeadBinder bndr-  = do { let enum_to_tag :: CoreAlt -> CoreAlt-                -- Takes   K -> e  into   tagK# -> e-                -- where tagK# is the tag of constructor K-             enum_to_tag (DataAlt con, [], rhs)-               = assert (isEnumerationTyCon (dataConTyCon con) )-                (LitAlt tag, [], rhs)-              where-                tag = mkLitInt dflags (toInteger (dataConTag con - fIRST_TAG))-             enum_to_tag alt = pprPanic "tryRules: tagToEnum" (ppr alt)--             new_alts = (DEFAULT, [], rhs1) : map enum_to_tag rest_alts-             new_bndr = setIdType bndr intPrimTy-                 -- The binder is dead, but should have the right type-      ; return (Just (val_arg, Select dup new_bndr new_alts se cont)) }--}--  | Just (rule, rule_rhs) <- lookupRule ropts (getUnfoldingInRuleMatch env)-                                        (activeRule (getMode env)) fn-                                        (argInfoAppArgs args) rules-  -- Fire a rule for the function-  = do { checkedTick (RuleFired (ruleName rule))-       ; let cont' = pushSimplifiedArgs zapped_env-                                        (drop (ruleArity rule) args)-                                        call_cont-                     -- (ruleArity rule) says how-                     -- many args the rule consumed--             occ_anald_rhs = occurAnalyseExpr rule_rhs-                 -- See Note [Occurrence-analyse after rule firing]-       ; dump rule rule_rhs-       ; return (Just (zapped_env, occ_anald_rhs, cont')) }-            -- The occ_anald_rhs and cont' are all Out things-            -- hence zapping the environment--  | otherwise  -- No rule fires-  = do { nodump  -- This ensures that an empty file is written-       ; return Nothing }--  where-    ropts      = initRuleOpts dflags-    dflags     = seDynFlags env-    logger     = seLogger env-    zapped_env = zapSubstEnv env  -- See Note [zapSubstEnv]--    printRuleModule rule-      = parens (maybe (text "BUILTIN")-                      (pprModuleName . moduleName)-                      (ruleModule rule))--    dump rule rule_rhs-      | logHasDumpFlag logger Opt_D_dump_rule_rewrites-      = log_rule Opt_D_dump_rule_rewrites "Rule fired" $ vcat-          [ text "Rule:" <+> ftext (ruleName rule)-          , text "Module:" <+>  printRuleModule rule-          , text "Before:" <+> hang (ppr fn) 2 (sep (map ppr args))-          , text "After: " <+> hang (pprCoreExpr rule_rhs) 2-                               (sep $ map ppr $ drop (ruleArity rule) args)-          , text "Cont:  " <+> ppr call_cont ]--      | logHasDumpFlag logger Opt_D_dump_rule_firings-      = log_rule Opt_D_dump_rule_firings "Rule fired:" $-          ftext (ruleName rule)-            <+> printRuleModule rule--      | otherwise-      = return ()--    nodump-      | logHasDumpFlag logger Opt_D_dump_rule_rewrites-      = liftIO $-          touchDumpFile logger Opt_D_dump_rule_rewrites--      | logHasDumpFlag logger Opt_D_dump_rule_firings-      = liftIO $-          touchDumpFile logger Opt_D_dump_rule_firings--      | otherwise-      = return ()--    log_rule flag hdr details-      = liftIO $ logDumpFile logger (mkDumpStyle alwaysQualify) flag "" FormatText-               $ sep [text hdr, nest 4 details]--trySeqRules :: SimplEnv-            -> OutExpr -> InExpr   -- Scrutinee and RHS-            -> SimplCont-            -> SimplM (Maybe (SimplEnv, CoreExpr, SimplCont))--- See Note [User-defined RULES for seq]-trySeqRules in_env scrut rhs cont-  = do { rule_base <- getSimplRules-       ; tryRules in_env (getRules rule_base seqId) seqId out_args rule_cont }-  where-    no_cast_scrut = drop_casts scrut-    scrut_ty  = exprType no_cast_scrut-    seq_id_ty = idType seqId                    -- forall r a (b::TYPE r). a -> b -> b-    res1_ty   = piResultTy seq_id_ty rhs_rep    -- forall a (b::TYPE rhs_rep). a -> b -> b-    res2_ty   = piResultTy res1_ty   scrut_ty   -- forall (b::TYPE rhs_rep). scrut_ty -> b -> b-    res3_ty   = piResultTy res2_ty   rhs_ty     -- scrut_ty -> rhs_ty -> rhs_ty-    res4_ty   = funResultTy res3_ty             -- rhs_ty -> rhs_ty-    rhs_ty    = substTy in_env (exprType rhs)-    rhs_rep   = getRuntimeRep rhs_ty-    out_args  = [ TyArg { as_arg_ty  = rhs_rep-                        , as_hole_ty = seq_id_ty }-                , TyArg { as_arg_ty  = scrut_ty-                        , as_hole_ty = res1_ty }-                , TyArg { as_arg_ty  = rhs_ty-                        , as_hole_ty = res2_ty }-                , ValArg { as_arg = no_cast_scrut-                         , as_dmd = seqDmd-                         , as_hole_ty = res3_ty } ]-    rule_cont = ApplyToVal { sc_dup = NoDup, sc_arg = rhs-                           , sc_env = in_env, sc_cont = cont-                           , sc_hole_ty = res4_ty }--    -- Lazily evaluated, so we don't do most of this--    drop_casts (Cast e _) = drop_casts e-    drop_casts e          = e--{- Note [User-defined RULES for seq]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Given-   case (scrut |> co) of _ -> rhs-look for rules that match the expression-   seq @t1 @t2 scrut-where scrut :: t1-      rhs   :: t2--If you find a match, rewrite it, and apply to 'rhs'.--Notice that we can simply drop casts on the fly here, which-makes it more likely that a rule will match.--See Note [User-defined RULES for seq] in GHC.Types.Id.Make.--Note [Occurrence-analyse after rule firing]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-After firing a rule, we occurrence-analyse the instantiated RHS before-simplifying it.  Usually this doesn't make much difference, but it can-be huge.  Here's an example (simplCore/should_compile/T7785)--  map f (map f (map f xs)--= -- Use build/fold form of map, twice-  map f (build (\cn. foldr (mapFB c f) n-                           (build (\cn. foldr (mapFB c f) n xs))))--= -- Apply fold/build rule-  map f (build (\cn. (\cn. foldr (mapFB c f) n xs) (mapFB c f) n))--= -- Beta-reduce-  -- Alas we have no occurrence-analysed, so we don't know-  -- that c is used exactly once-  map f (build (\cn. let c1 = mapFB c f in-                     foldr (mapFB c1 f) n xs))--= -- Use mapFB rule:   mapFB (mapFB c f) g = mapFB c (f.g)-  -- We can do this because (mapFB c n) is a PAP and hence expandable-  map f (build (\cn. let c1 = mapFB c n in-                     foldr (mapFB c (f.f)) n x))--This is not too bad.  But now do the same with the outer map, and-we get another use of mapFB, and t can interact with /both/ remaining-mapFB calls in the above expression.  This is stupid because actually-that 'c1' binding is dead.  The outer map introduces another c2. If-there is a deep stack of maps we get lots of dead bindings, and lots-of redundant work as we repeatedly simplify the result of firing rules.--The easy thing to do is simply to occurrence analyse the result of-the rule firing.  Note that this occ-anals not only the RHS of the-rule, but also the function arguments, which by now are OutExprs.-E.g.-      RULE f (g x) = x+1--Call   f (g BIG)  -->   (\x. x+1) BIG--The rule binders are lambda-bound and applied to the OutExpr arguments-(here BIG) which lack all internal occurrence info.--Is this inefficient?  Not really: we are about to walk over the result-of the rule firing to simplify it, so occurrence analysis is at most-a constant factor.--Possible improvement: occ-anal the rules when putting them in the-database; and in the simplifier just occ-anal the OutExpr arguments.-But that's more complicated and the rule RHS is usually tiny; so I'm-just doing the simple thing.--Historical note: previously we did occ-anal the rules in Rule.hs,-but failed to occ-anal the OutExpr arguments, which led to the-nasty performance problem described above.---Note [Optimising tagToEnum#]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If we have an enumeration data type:--  data Foo = A | B | C--Then we want to transform--   case tagToEnum# x of   ==>    case x of-     A -> e1                       DEFAULT -> e1-     B -> e2                       1#      -> e2-     C -> e3                       2#      -> e3--thereby getting rid of the tagToEnum# altogether.  If there was a DEFAULT-alternative we retain it (remember it comes first).  If not the case must-be exhaustive, and we reflect that in the transformed version by adding-a DEFAULT.  Otherwise Lint complains that the new case is not exhaustive.-See #8317.--Note [Rules for recursive functions]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-You might think that we shouldn't apply rules for a loop breaker:-doing so might give rise to an infinite loop, because a RULE is-rather like an extra equation for the function:-     RULE:           f (g x) y = x+y-     Eqn:            f a     y = a-y--But it's too drastic to disable rules for loop breakers.-Even the foldr/build rule would be disabled, because foldr-is recursive, and hence a loop breaker:-     foldr k z (build g) = g k z-So it's up to the programmer: rules can cause divergence---************************************************************************-*                                                                      *-                Rebuilding a case expression-*                                                                      *-************************************************************************--Note [Case elimination]-~~~~~~~~~~~~~~~~~~~~~~~-The case-elimination transformation discards redundant case expressions.-Start with a simple situation:--        case x# of      ===>   let y# = x# in e-          y# -> e--(when x#, y# are of primitive type, of course).  We can't (in general)-do this for algebraic cases, because we might turn bottom into-non-bottom!--The code in GHC.Core.Opt.Simplify.Utils.prepareAlts has the effect of generalise-this idea to look for a case where we're scrutinising a variable, and we know-that only the default case can match.  For example:--        case x of-          0#      -> ...-          DEFAULT -> ...(case x of-                         0#      -> ...-                         DEFAULT -> ...) ...--Here the inner case is first trimmed to have only one alternative, the-DEFAULT, after which it's an instance of the previous case.  This-really only shows up in eliminating error-checking code.--Note that GHC.Core.Opt.Simplify.Utils.mkCase combines identical RHSs.  So--        case e of       ===> case e of DEFAULT -> r-           True  -> r-           False -> r--Now again the case may be eliminated by the CaseElim transformation.-This includes things like (==# a# b#)::Bool so that we simplify-      case ==# a# b# of { True -> x; False -> x }-to just-      x-This particular example shows up in default methods for-comparison operations (e.g. in (>=) for Int.Int32)--Note [Case to let transformation]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If a case over a lifted type has a single alternative, and is being-used as a strict 'let' (all isDeadBinder bndrs), we may want to do-this transformation:--    case e of r       ===>   let r = e in ...r...-      _ -> ...r...--We treat the unlifted and lifted cases separately:--* Unlifted case: 'e' satisfies exprOkForSpeculation-  (ok-for-spec is needed to satisfy the let/app invariant).-  This turns     case a +# b of r -> ...r...-  into           let r = a +# b in ...r...-  and thence     .....(a +# b)....--  However, if we have-      case indexArray# a i of r -> ...r...-  we might like to do the same, and inline the (indexArray# a i).-  But indexArray# is not okForSpeculation, so we don't build a let-  in rebuildCase (lest it get floated *out*), so the inlining doesn't-  happen either.  Annoying.--* Lifted case: we need to be sure that the expression is already-  evaluated (exprIsHNF).  If it's not already evaluated-      - we risk losing exceptions, divergence or-        user-specified thunk-forcing-      - even if 'e' is guaranteed to converge, we don't want to-        create a thunk (call by need) instead of evaluating it-        right away (call by value)--  However, we can turn the case into a /strict/ let if the 'r' is-  used strictly in the body.  Then we won't lose divergence; and-  we won't build a thunk because the let is strict.-  See also Note [Case-to-let for strictly-used binders]--Note [Case-to-let for strictly-used binders]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If we have this:-   case <scrut> of r { _ -> ..r.. }--where 'r' is used strictly in (..r..), we can safely transform to-   let r = <scrut> in ...r...--This is a Good Thing, because 'r' might be dead (if the body just-calls error), or might be used just once (in which case it can be-inlined); or we might be able to float the let-binding up or down.-E.g. #15631 has an example.--Note that this can change the error behaviour.  For example, we might-transform-    case x of { _ -> error "bad" }-    --> error "bad"-which is might be puzzling if 'x' currently lambda-bound, but later gets-let-bound to (error "good").--Nevertheless, the paper "A semantics for imprecise exceptions" allows-this transformation. If you want to fix the evaluation order, use-'pseq'.  See #8900 for an example where the loss of this-transformation bit us in practice.--See also Note [Empty case alternatives] in GHC.Core.--Historical notes--There have been various earlier versions of this patch:--* By Sept 18 the code looked like this:-     || scrut_is_demanded_var scrut--    scrut_is_demanded_var :: CoreExpr -> Bool-    scrut_is_demanded_var (Cast s _) = scrut_is_demanded_var s-    scrut_is_demanded_var (Var _)    = isStrUsedDmd (idDemandInfo case_bndr)-    scrut_is_demanded_var _          = False--  This only fired if the scrutinee was a /variable/, which seems-  an unnecessary restriction. So in #15631 I relaxed it to allow-  arbitrary scrutinees.  Less code, less to explain -- but the change-  had 0.00% effect on nofib.--* Previously, in Jan 13 the code looked like this:-     || case_bndr_evald_next rhs--    case_bndr_evald_next :: CoreExpr -> Bool-      -- See Note [Case binder next]-    case_bndr_evald_next (Var v)         = v == case_bndr-    case_bndr_evald_next (Cast e _)      = case_bndr_evald_next e-    case_bndr_evald_next (App e _)       = case_bndr_evald_next e-    case_bndr_evald_next (Case e _ _ _)  = case_bndr_evald_next e-    case_bndr_evald_next _               = False--  This patch was part of fixing #7542. See also-  Note [Eta reduction of an eval'd function] in GHC.Core.Utils.)---Further notes about case elimination-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider:       test :: Integer -> IO ()-                test = print--Turns out that this compiles to:-    Print.test-      = \ eta :: Integer-          eta1 :: Void# ->-          case PrelNum.< eta PrelNum.zeroInteger of wild { __DEFAULT ->-          case hPutStr stdout-                 (PrelNum.jtos eta ($w[] @ Char))-                 eta1-          of wild1 { (# new_s, a4 #) -> PrelIO.lvl23 new_s  }}--Notice the strange '<' which has no effect at all. This is a funny one.-It started like this:--f x y = if x < 0 then jtos x-          else if y==0 then "" else jtos x--At a particular call site we have (f v 1).  So we inline to get--        if v < 0 then jtos x-        else if 1==0 then "" else jtos x--Now simplify the 1==0 conditional:--        if v<0 then jtos v else jtos v--Now common-up the two branches of the case:--        case (v<0) of DEFAULT -> jtos v--Why don't we drop the case?  Because it's strict in v.  It's technically-wrong to drop even unnecessary evaluations, and in practice they-may be a result of 'seq' so we *definitely* don't want to drop those.-I don't really know how to improve this situation.---Note [FloatBinds from constructor wrappers]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If we have FloatBinds coming from the constructor wrapper-(as in Note [exprIsConApp_maybe on data constructors with wrappers]),-we cannot float past them. We'd need to float the FloatBind-together with the simplify floats, unfortunately the-simplifier doesn't have case-floats. The simplest thing we can-do is to wrap all the floats here. The next iteration of the-simplifier will take care of all these cases and lets.--Given data T = MkT !Bool, this allows us to simplify-case $WMkT b of { MkT x -> f x }-to-case b of { b' -> f b' }.--We could try and be more clever (like maybe wfloats only contain-let binders, so we could float them). But the need for the-extra complication is not clear.--Note [Do not duplicate constructor applications]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider this (#20125)-   let x = (a,b)-   in ...(case x of x' -> blah)...x...x...--We want that `case` to vanish (since `x` is bound to a data con) leaving-   let x = (a,b)-   in ...(let x'=x in blah)...x..x...--In rebuildCase, `exprIsConApp_maybe` will succeed on the scrutinee `x`,-since is bound to (a,b).  But in eliminating the case, if the scrutinee-is trivial, we want to bind the case-binder to the scrutinee, /not/ to-the constructor application.  Hence the case_bndr_rhs in rebuildCase.--This applies equally to a non-DEFAULT case alternative, say-   let x = (a,b) in ...(case x of x' { (p,q) -> blah })...-This variant is handled by bind_case_bndr in knownCon.--We want to bind x' to x, and not to a duplicated (a,b)).--}--------------------------------------------------------------      Eliminate the case if possible--rebuildCase, reallyRebuildCase-   :: SimplEnv-   -> OutExpr          -- Scrutinee-   -> InId             -- Case binder-   -> [InAlt]          -- Alternatives (increasing order)-   -> SimplCont-   -> SimplM (SimplFloats, OutExpr)-------------------------------------------------------      1. Eliminate the case if there's a known constructor-----------------------------------------------------rebuildCase env scrut case_bndr alts cont-  | Lit lit <- scrut    -- No need for same treatment as constructors-                        -- because literals are inlined more vigorously-  , not (litIsLifted lit)-  = do  { tick (KnownBranch case_bndr)-        ; case findAlt (LitAlt lit) alts of-            Nothing             -> missingAlt env case_bndr alts cont-            Just (Alt _ bs rhs) -> simple_rhs env [] scrut bs rhs }--  | Just (in_scope', wfloats, con, ty_args, other_args)-      <- exprIsConApp_maybe (getUnfoldingInRuleMatch env) scrut-        -- Works when the scrutinee is a variable with a known unfolding-        -- as well as when it's an explicit constructor application-  , let env0 = setInScopeSet env in_scope'-  = do  { tick (KnownBranch case_bndr)-        ; let scaled_wfloats = map scale_float wfloats-              -- case_bndr_unf: see Note [Do not duplicate constructor applications]-              case_bndr_rhs | exprIsTrivial scrut = scrut-                            | otherwise           = con_app-              con_app = Var (dataConWorkId con) `mkTyApps` ty_args-                                                `mkApps`   other_args-        ; case findAlt (DataAlt con) alts of-            Nothing                   -> missingAlt env0 case_bndr alts cont-            Just (Alt DEFAULT bs rhs) -> simple_rhs env0 scaled_wfloats case_bndr_rhs bs rhs-            Just (Alt _       bs rhs) -> knownCon env0 scrut scaled_wfloats con ty_args-                                                  other_args case_bndr bs rhs cont-        }-  where-    simple_rhs env wfloats case_bndr_rhs bs rhs =-      assert (null bs) $-      do { (floats1, env') <- simplNonRecX env case_bndr case_bndr_rhs-             -- scrut is a constructor application,-             -- hence satisfies let/app invariant-         ; (floats2, expr') <- simplExprF env' rhs cont-         ; case wfloats of-             [] -> return (floats1 `addFloats` floats2, expr')-             _ -> return-               -- See Note [FloatBinds from constructor wrappers]-                   ( emptyFloats env,-                     GHC.Core.Make.wrapFloats wfloats $-                     wrapFloats (floats1 `addFloats` floats2) expr' )}--    -- This scales case floats by the multiplicity of the continuation hole (see-    -- Note [Scaling in case-of-case]).  Let floats are _not_ scaled, because-    -- they are aliases anyway.-    scale_float (GHC.Core.Make.FloatCase scrut case_bndr con vars) =-      let-        scale_id id = scaleVarBy holeScaling id-      in-      GHC.Core.Make.FloatCase scrut (scale_id case_bndr) con (map scale_id vars)-    scale_float f = f--    holeScaling = contHoleScaling cont `mkMultMul` idMult case_bndr-     -- We are in the following situation-     --   case[p] case[q] u of { D x -> C v } of { C x -> w }-     -- And we are producing case[??] u of { D x -> w[x\v]}-     ---     -- What should the multiplicity `??` be? In order to preserve the usage of-     -- variables in `u`, it needs to be `pq`.-     ---     -- As an illustration, consider the following-     --   case[Many] case[1] of { C x -> C x } of { C x -> (x, x) }-     -- Where C :: A %1 -> T is linear-     -- If we were to produce a case[1], like the inner case, we would get-     --   case[1] of { C x -> (x, x) }-     -- Which is ill-typed with respect to linearity. So it needs to be a-     -- case[Many].-------------------------------------------------------      2. Eliminate the case if scrutinee is evaluated-----------------------------------------------------rebuildCase env scrut case_bndr alts@[Alt _ bndrs rhs] cont-  -- See if we can get rid of the case altogether-  -- See Note [Case elimination]-  -- mkCase made sure that if all the alternatives are equal,-  -- then there is now only one (DEFAULT) rhs--  -- 2a.  Dropping the case altogether, if-  --      a) it binds nothing (so it's really just a 'seq')-  --      b) evaluating the scrutinee has no side effects-  | is_plain_seq-  , exprOkForSideEffects scrut-          -- The entire case is dead, so we can drop it-          -- if the scrutinee converges without having imperative-          -- side effects or raising a Haskell exception-          -- See Note [PrimOp can_fail and has_side_effects] in GHC.Builtin.PrimOps-   = simplExprF env rhs cont--  -- 2b.  Turn the case into a let, if-  --      a) it binds only the case-binder-  --      b) unlifted case: the scrutinee is ok-for-speculation-  --           lifted case: the scrutinee is in HNF (or will later be demanded)-  -- See Note [Case to let transformation]-  | all_dead_bndrs-  , doCaseToLet scrut case_bndr-  = do { tick (CaseElim case_bndr)-       ; (floats1, env') <- simplNonRecX env case_bndr scrut-       ; (floats2, expr') <- simplExprF env' rhs cont-       ; return (floats1 `addFloats` floats2, expr') }--  -- 2c. Try the seq rules if-  --     a) it binds only the case binder-  --     b) a rule for seq applies-  -- See Note [User-defined RULES for seq] in GHC.Types.Id.Make-  | is_plain_seq-  = do { mb_rule <- trySeqRules env scrut rhs cont-       ; case mb_rule of-           Just (env', rule_rhs, cont') -> simplExprF env' rule_rhs cont'-           Nothing                      -> reallyRebuildCase env scrut case_bndr alts cont }-  where-    all_dead_bndrs = all isDeadBinder bndrs       -- bndrs are [InId]-    is_plain_seq   = all_dead_bndrs && isDeadBinder case_bndr -- Evaluation *only* for effect--rebuildCase env scrut case_bndr alts cont-  = reallyRebuildCase env scrut case_bndr alts cont---doCaseToLet :: OutExpr          -- Scrutinee-            -> InId             -- Case binder-            -> Bool--- The situation is         case scrut of b { DEFAULT -> body }--- Can we transform thus?   let { b = scrut } in body-doCaseToLet scrut case_bndr-  | isTyCoVar case_bndr    -- Respect GHC.Core-  = isTyCoArg scrut        -- Note [Core type and coercion invariant]--  | isUnliftedType (idType case_bndr)-    -- OK to call isUnliftedType: scrutinees always have a fixed RuntimeRep (see FRRCase)-  = exprOkForSpeculation scrut--  | otherwise  -- Scrut has a lifted type-  = exprIsHNF scrut-    || isStrUsedDmd (idDemandInfo case_bndr)-    -- See Note [Case-to-let for strictly-used binders]-------------------------------------------------------      3. Catch-all case-----------------------------------------------------reallyRebuildCase env scrut case_bndr alts cont-  | not (sm_case_case (getMode env))-  = do { case_expr <- simplAlts env scrut case_bndr alts-                                (mkBoringStop (contHoleType cont))-       ; rebuild env case_expr cont }--  | otherwise-  = do { (floats, env', cont') <- mkDupableCaseCont env alts cont-       ; case_expr <- simplAlts env' scrut-                                (scaleIdBy holeScaling case_bndr)-                                (scaleAltsBy holeScaling alts)-                                cont'-       ; return (floats, case_expr) }-  where-    holeScaling = contHoleScaling cont-    -- Note [Scaling in case-of-case]--{--simplCaseBinder checks whether the scrutinee is a variable, v.  If so,-try to eliminate uses of v in the RHSs in favour of case_bndr; that-way, there's a chance that v will now only be used once, and hence-inlined.--Historical note: we use to do the "case binder swap" in the Simplifier-so there were additional complications if the scrutinee was a variable.-Now the binder-swap stuff is done in the occurrence analyser; see-"GHC.Core.Opt.OccurAnal" Note [Binder swap].--Note [knownCon occ info]-~~~~~~~~~~~~~~~~~~~~~~~~-If the case binder is not dead, then neither are the pattern bound-variables:-        case <any> of x { (a,b) ->-        case x of { (p,q) -> p } }-Here (a,b) both look dead, but come alive after the inner case is eliminated.-The point is that we bring into the envt a binding-        let x = (a,b)-after the outer case, and that makes (a,b) alive.  At least we do unless-the case binder is guaranteed dead.--Note [Case alternative occ info]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When we are simply reconstructing a case (the common case), we always-zap the occurrence info on the binders in the alternatives.  Even-if the case binder is dead, the scrutinee is usually a variable, and *that*-can bring the case-alternative binders back to life.-See Note [Add unfolding for scrutinee]--Note [Improving seq]-~~~~~~~~~~~~~~~~~~~-Consider-        type family F :: * -> *-        type instance F Int = Int--We'd like to transform-        case e of (x :: F Int) { DEFAULT -> rhs }-===>-        case e `cast` co of (x'::Int)-           I# x# -> let x = x' `cast` sym co-                    in rhs--so that 'rhs' can take advantage of the form of x'.  Notice that Note-[Case of cast] (in OccurAnal) may then apply to the result.--We'd also like to eliminate empty types (#13468). So if--    data Void-    type instance F Bool = Void--then we'd like to transform-        case (x :: F Bool) of { _ -> error "urk" }-===>-        case (x |> co) of (x' :: Void) of {}--Nota Bene: we used to have a built-in rule for 'seq' that dropped-casts, so that-    case (x |> co) of { _ -> blah }-dropped the cast; in order to improve the chances of trySeqRules-firing.  But that works in the /opposite/ direction to Note [Improving-seq] so there's a danger of flip/flopping.  Better to make trySeqRules-insensitive to the cast, which is now is.--The need for [Improving seq] showed up in Roman's experiments.  Example:-  foo :: F Int -> Int -> Int-  foo t n = t `seq` bar n-     where-       bar 0 = 0-       bar n = bar (n - case t of TI i -> i)-Here we'd like to avoid repeated evaluating t inside the loop, by-taking advantage of the `seq`.--At one point I did transformation in LiberateCase, but it's more-robust here.  (Otherwise, there's a danger that we'll simply drop the-'seq' altogether, before LiberateCase gets to see it.)--Note [Scaling in case-of-case]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--When two cases commute, if done naively, the multiplicities will be wrong:--  case (case u of w[1] { (x[1], y[1]) } -> f x y) of w'[Many]-  { (z[Many], t[Many]) -> z-  }--The multiplicities here, are correct, but if I perform a case of case:--  case u of w[1]-  { (x[1], y[1]) -> case f x y of w'[Many] of { (z[Many], t[Many]) -> z }-  }--This is wrong! Using `f x y` inside a `case … of w'[Many]` means that `x` and-`y` must have multiplicities `Many` not `1`! The correct solution is to make-all the `1`-s be `Many`-s instead:--  case u of w[Many]-  { (x[Many], y[Many]) -> case f x y of w'[Many] of { (z[Many], t[Many]) -> z }-  }--In general, when commuting two cases, the rule has to be:--  case (case … of x[p] {…}) of y[q] { … }-  ===> case … of x[p*q] { … case … of y[q] { … } }--This is materialised, in the simplifier, by the fact that every time we simplify-case alternatives with a continuation (the surrounded case (or more!)), we must-scale the entire case we are simplifying, by a scaling factor which can be-computed in the continuation (with function `contHoleScaling`).--}--simplAlts :: SimplEnv-          -> OutExpr         -- Scrutinee-          -> InId            -- Case binder-          -> [InAlt]         -- Non-empty-          -> SimplCont-          -> SimplM OutExpr  -- Returns the complete simplified case expression--simplAlts env0 scrut case_bndr alts cont'-  = do  { traceSmpl "simplAlts" (vcat [ ppr case_bndr-                                      , text "cont':" <+> ppr cont'-                                      , text "in_scope" <+> ppr (seInScope env0) ])-        ; (env1, case_bndr1) <- simplBinder env0 case_bndr-        ; let case_bndr2 = case_bndr1 `setIdUnfolding` evaldUnfolding-              env2       = modifyInScope env1 case_bndr2-              -- See Note [Case binder evaluated-ness]--        ; fam_envs <- getFamEnvs-        ; (alt_env', scrut', case_bndr') <- improveSeq fam_envs env2 scrut-                                                       case_bndr case_bndr2 alts--        ; (imposs_deflt_cons, in_alts) <- prepareAlts scrut' case_bndr' alts-          -- NB: it's possible that the returned in_alts is empty: this is handled-          -- by the caller (rebuildCase) in the missingAlt function--        ; alts' <- mapM (simplAlt alt_env' (Just scrut') imposs_deflt_cons case_bndr' cont') in_alts---      ; pprTrace "simplAlts" (ppr case_bndr $$ ppr alts $$ ppr cont') $ return ()--        ; let alts_ty' = contResultType cont'-        -- See Note [Avoiding space leaks in OutType]-        ; seqType alts_ty' `seq`-          mkCase (seDynFlags env0) scrut' case_bndr' alts_ty' alts' }----------------------------------------improveSeq :: (FamInstEnv, FamInstEnv) -> SimplEnv-           -> OutExpr -> InId -> OutId -> [InAlt]-           -> SimplM (SimplEnv, OutExpr, OutId)--- Note [Improving seq]-improveSeq fam_envs env scrut case_bndr case_bndr1 [Alt DEFAULT _ _]-  | Just (Reduction co ty2) <- topNormaliseType_maybe fam_envs (idType case_bndr1)-  = do { case_bndr2 <- newId (fsLit "nt") Many ty2-        ; let rhs  = DoneEx (Var case_bndr2 `Cast` mkSymCo co) Nothing-              env2 = extendIdSubst env case_bndr rhs-        ; return (env2, scrut `Cast` co, case_bndr2) }--improveSeq _ env scrut _ case_bndr1 _-  = return (env, scrut, case_bndr1)----------------------------------------simplAlt :: SimplEnv-         -> Maybe OutExpr  -- The scrutinee-         -> [AltCon]       -- These constructors can't be present when-                           -- matching the DEFAULT alternative-         -> OutId          -- The case binder-         -> SimplCont-         -> InAlt-         -> SimplM OutAlt--simplAlt env _ imposs_deflt_cons case_bndr' cont' (Alt DEFAULT bndrs rhs)-  = assert (null bndrs) $-    do  { let env' = addBinderUnfolding env case_bndr'-                                        (mkOtherCon imposs_deflt_cons)-                -- Record the constructors that the case-binder *can't* be.-        ; rhs' <- simplExprC env' rhs cont'-        ; return (Alt DEFAULT [] rhs') }--simplAlt env scrut' _ case_bndr' cont' (Alt (LitAlt lit) bndrs rhs)-  = assert (null bndrs) $-    do  { env' <- addAltUnfoldings env scrut' case_bndr' (Lit lit)-        ; rhs' <- simplExprC env' rhs cont'-        ; return (Alt (LitAlt lit) [] rhs') }--simplAlt env scrut' _ case_bndr' cont' (Alt (DataAlt con) vs rhs)-  = do  { -- See Note [Adding evaluatedness info to pattern-bound variables]-          let vs_with_evals = addEvals scrut' con vs-        ; (env', vs') <- simplBinders env vs_with_evals--                -- Bind the case-binder to (con args)-        ; let inst_tys' = tyConAppArgs (idType case_bndr')-              con_app :: OutExpr-              con_app   = mkConApp2 con inst_tys' vs'--        ; env'' <- addAltUnfoldings env' scrut' case_bndr' con_app-        ; rhs' <- simplExprC env'' rhs cont'-        ; return (Alt (DataAlt con) vs' rhs') }--{- Note [Adding evaluatedness info to pattern-bound variables]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-addEvals records the evaluated-ness of the bound variables of-a case pattern.  This is *important*.  Consider--     data T = T !Int !Int--     case x of { T a b -> T (a+1) b }--We really must record that b is already evaluated so that we don't-go and re-evaluate it when constructing the result.-See Note [Data-con worker strictness] in GHC.Core.DataCon--NB: simplLamBndrs preserves this eval info--In addition to handling data constructor fields with !s, addEvals-also records the fact that the result of seq# is always in WHNF.-See Note [seq# magic] in GHC.Core.Opt.ConstantFold.  Example (#15226):--  case seq# v s of-    (# s', v' #) -> E--we want the compiler to be aware that v' is in WHNF in E.--Open problem: we don't record that v itself is in WHNF (and we can't-do it here).  The right thing is to do some kind of binder-swap;-see #15226 for discussion.--}--addEvals :: Maybe OutExpr -> DataCon -> [Id] -> [Id]--- See Note [Adding evaluatedness info to pattern-bound variables]-addEvals scrut con vs-  -- Deal with seq# applications-  | Just scr <- scrut-  , isUnboxedTupleDataCon con-  , [s,x] <- vs-    -- Use stripNArgs rather than collectArgsTicks to avoid building-    -- a list of arguments only to throw it away immediately.-  , Just (Var f) <- stripNArgs 4 scr-  , Just SeqOp <- isPrimOpId_maybe f-  , let x' = zapIdOccInfoAndSetEvald MarkedStrict x-  = [s, x']--  -- Deal with banged datacon fields-addEvals _scrut con vs = go vs the_strs-    where-      the_strs = dataConRepStrictness con--      go [] [] = []-      go (v:vs') strs | isTyVar v = v : go vs' strs-      go (v:vs') (str:strs) = zapIdOccInfoAndSetEvald str v : go vs' strs-      go _ _ = pprPanic "Simplify.addEvals"-                (ppr con $$-                 ppr vs  $$-                 ppr_with_length (map strdisp the_strs) $$-                 ppr_with_length (dataConRepArgTys con) $$-                 ppr_with_length (dataConRepStrictness con))-        where-          ppr_with_length list-            = ppr list <+> parens (text "length =" <+> ppr (length list))-          strdisp MarkedStrict = text "MarkedStrict"-          strdisp NotMarkedStrict = text "NotMarkedStrict"--zapIdOccInfoAndSetEvald :: StrictnessMark -> Id -> Id-zapIdOccInfoAndSetEvald str v =-  setCaseBndrEvald str $ -- Add eval'dness info-  zapIdOccInfo v         -- And kill occ info;-                         -- see Note [Case alternative occ info]--addAltUnfoldings :: SimplEnv -> Maybe OutExpr -> OutId -> OutExpr -> SimplM SimplEnv-addAltUnfoldings env scrut case_bndr con_app-  = do { let con_app_unf = mk_simple_unf con_app-             env1 = addBinderUnfolding env case_bndr con_app_unf--             -- See Note [Add unfolding for scrutinee]-             env2 | Many <- idMult case_bndr = case scrut of-                      Just (Var v)           -> addBinderUnfolding env1 v con_app_unf-                      Just (Cast (Var v) co) -> addBinderUnfolding env1 v $-                                                mk_simple_unf (Cast con_app (mkSymCo co))-                      _                      -> env1-                  | otherwise = env1--       ; traceSmpl "addAltUnf" (vcat [ppr case_bndr <+> ppr scrut, ppr con_app])-       ; return env2 }-  where-    -- Force the opts, so that the whole SimplEnv isn't retained-    !opts = seUnfoldingOpts env-    mk_simple_unf = mkSimpleUnfolding opts--addBinderUnfolding :: SimplEnv -> Id -> Unfolding -> SimplEnv-addBinderUnfolding env bndr unf-  | debugIsOn, Just tmpl <- maybeUnfoldingTemplate unf-  = warnPprTrace (not (eqType (idType bndr) (exprType tmpl)))-          "unfolding type mismatch"-          (ppr bndr $$ ppr (idType bndr) $$ ppr tmpl $$ ppr (exprType tmpl)) $-          modifyInScope env (bndr `setIdUnfolding` unf)--  | otherwise-  = modifyInScope env (bndr `setIdUnfolding` unf)--zapBndrOccInfo :: Bool -> Id -> Id--- Consider  case e of b { (a,b) -> ... }--- Then if we bind b to (a,b) in "...", and b is not dead,--- then we must zap the deadness info on a,b-zapBndrOccInfo keep_occ_info pat_id-  | keep_occ_info = pat_id-  | otherwise     = zapIdOccInfo pat_id--{- Note [Case binder evaluated-ness]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We pin on a (OtherCon []) unfolding to the case-binder of a Case,-even though it'll be over-ridden in every case alternative with a more-informative unfolding.  Why?  Because suppose a later, less clever, pass-simply replaces all occurrences of the case binder with the binder itself;-then Lint may complain about the let/app invariant.  Example-    case e of b { DEFAULT -> let v = reallyUnsafePtrEquality# b y in ....-                ; K       -> blah }--The let/app invariant requires that y is evaluated in the call to-reallyUnsafePtrEquality#, which it is.  But we still want that to be true if we-propagate binders to occurrences.--This showed up in #13027.--Note [Add unfolding for scrutinee]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In general it's unlikely that a variable scrutinee will appear-in the case alternatives   case x of { ...x unlikely to appear... }-because the binder-swap in OccurAnal has got rid of all such occurrences-See Note [Binder swap] in "GHC.Core.Opt.OccurAnal".--BUT it is still VERY IMPORTANT to add a suitable unfolding for a-variable scrutinee, in simplAlt.  Here's why-   case x of y-     (a,b) -> case b of c-                I# v -> ...(f y)...-There is no occurrence of 'b' in the (...(f y)...).  But y gets-the unfolding (a,b), and *that* mentions b.  If f has a RULE-    RULE f (p, I# q) = ...-we want that rule to match, so we must extend the in-scope env with a-suitable unfolding for 'y'.  It's *essential* for rule matching; but-it's also good for case-elimination -- suppose that 'f' was inlined-and did multi-level case analysis, then we'd solve it in one-simplifier sweep instead of two.--Exactly the same issue arises in GHC.Core.Opt.SpecConstr;-see Note [Add scrutinee to ValueEnv too] in GHC.Core.Opt.SpecConstr--HOWEVER, given-  case x of y { Just a -> r1; Nothing -> r2 }-we do not want to add the unfolding x -> y to 'x', which might seem cool,-since 'y' itself has different unfoldings in r1 and r2.  Reason: if we-did that, we'd have to zap y's deadness info and that is a very useful-piece of information.--So instead we add the unfolding x -> Just a, and x -> Nothing in the-respective RHSs.--Since this transformation is tantamount to a binder swap, the same caveat as in-Note [Suppressing binder-swaps on linear case] in OccurAnal apply.---************************************************************************-*                                                                      *-\subsection{Known constructor}-*                                                                      *-************************************************************************--We are a bit careful with occurrence info.  Here's an example--        (\x* -> case x of (a*, b) -> f a) (h v, e)--where the * means "occurs once".  This effectively becomes-        case (h v, e) of (a*, b) -> f a)-and then-        let a* = h v; b = e in f a-and then-        f (h v)--All this should happen in one sweep.--}--knownCon :: SimplEnv-         -> OutExpr                                           -- The scrutinee-         -> [FloatBind] -> DataCon -> [OutType] -> [OutExpr]  -- The scrutinee (in pieces)-         -> InId -> [InBndr] -> InExpr                        -- The alternative-         -> SimplCont-         -> SimplM (SimplFloats, OutExpr)--knownCon env scrut dc_floats dc dc_ty_args dc_args bndr bs rhs cont-  = do  { (floats1, env1)  <- bind_args env bs dc_args-        ; (floats2, env2)  <- bind_case_bndr env1-        ; (floats3, expr') <- simplExprF env2 rhs cont-        ; case dc_floats of-            [] ->-              return (floats1 `addFloats` floats2 `addFloats` floats3, expr')-            _ ->-              return ( emptyFloats env-               -- See Note [FloatBinds from constructor wrappers]-                     , GHC.Core.Make.wrapFloats dc_floats $-                       wrapFloats (floats1 `addFloats` floats2 `addFloats` floats3) expr') }-  where-    zap_occ = zapBndrOccInfo (isDeadBinder bndr)    -- bndr is an InId--                  -- Ugh!-    bind_args env' [] _  = return (emptyFloats env', env')--    bind_args env' (b:bs') (Type ty : args)-      = assert (isTyVar b )-        bind_args (extendTvSubst env' b ty) bs' args--    bind_args env' (b:bs') (Coercion co : args)-      = assert (isCoVar b )-        bind_args (extendCvSubst env' b co) bs' args--    bind_args env' (b:bs') (arg : args)-      = assert (isId b) $-        do { let b' = zap_occ b-             -- Note that the binder might be "dead", because it doesn't-             -- occur in the RHS; and simplNonRecX may therefore discard-             -- it via postInlineUnconditionally.-             -- Nevertheless we must keep it if the case-binder is alive,-             -- because it may be used in the con_app.  See Note [knownCon occ info]-           ; (floats1, env2) <- simplNonRecX env' b' arg  -- arg satisfies let/app invariant-           ; (floats2, env3)  <- bind_args env2 bs' args-           ; return (floats1 `addFloats` floats2, env3) }--    bind_args _ _ _ =-      pprPanic "bind_args" $ ppr dc $$ ppr bs $$ ppr dc_args $$-                             text "scrut:" <+> ppr scrut--       -- It's useful to bind bndr to scrut, rather than to a fresh-       -- binding      x = Con arg1 .. argn-       -- because very often the scrut is a variable, so we avoid-       -- creating, and then subsequently eliminating, a let-binding-       -- BUT, if scrut is a not a variable, we must be careful-       -- about duplicating the arg redexes; in that case, make-       -- a new con-app from the args-    bind_case_bndr env-      | isDeadBinder bndr   = return (emptyFloats env, env)-      | exprIsTrivial scrut = return (emptyFloats env-                                     , extendIdSubst env bndr (DoneEx scrut Nothing))-                              -- See Note [Do not duplicate constructor applications]-      | otherwise           = do { dc_args <- mapM (simplVar env) bs-                                         -- dc_ty_args are already OutTypes,-                                         -- but bs are InBndrs-                                 ; let con_app = Var (dataConWorkId dc)-                                                 `mkTyApps` dc_ty_args-                                                 `mkApps`   dc_args-                                 ; simplNonRecX env bndr con_app }----------------------missingAlt :: SimplEnv -> Id -> [InAlt] -> SimplCont-           -> SimplM (SimplFloats, OutExpr)-                -- This isn't strictly an error, although it is unusual.-                -- It's possible that the simplifier might "see" that-                -- an inner case has no accessible alternatives before-                -- it "sees" that the entire branch of an outer case is-                -- inaccessible.  So we simply put an error case here instead.-missingAlt env case_bndr _ cont-  = warnPprTrace True "missingAlt" (ppr case_bndr) $-    -- See Note [Avoiding space leaks in OutType]-    let cont_ty = contResultType cont-    in seqType cont_ty `seq`-       return (emptyFloats env, mkImpossibleExpr cont_ty)--{--************************************************************************-*                                                                      *-\subsection{Duplicating continuations}-*                                                                      *-************************************************************************--Consider-  let x* = case e of { True -> e1; False -> e2 }-  in b-where x* is a strict binding.  Then mkDupableCont will be given-the continuation-   case [] of { True -> e1; False -> e2 } ; let x* = [] in b ; stop-and will split it into-   dupable:      case [] of { True -> $j1; False -> $j2 } ; stop-   join floats:  $j1 = e1, $j2 = e2-   non_dupable:  let x* = [] in b; stop--Putting this back together would give-   let x* = let { $j1 = e1; $j2 = e2 } in-            case e of { True -> $j1; False -> $j2 }-   in b-(Of course we only do this if 'e' wants to duplicate that continuation.)-Note how important it is that the new join points wrap around the-inner expression, and not around the whole thing.--In contrast, any let-bindings introduced by mkDupableCont can wrap-around the entire thing.--Note [Bottom alternatives]-~~~~~~~~~~~~~~~~~~~~~~~~~~-When we have-     case (case x of { A -> error .. ; B -> e; C -> error ..)-       of alts-then we can just duplicate those alts because the A and C cases-will disappear immediately.  This is more direct than creating-join points and inlining them away.  See #4930.--}-----------------------mkDupableCaseCont :: SimplEnv -> [InAlt] -> SimplCont-                  -> SimplM ( SimplFloats  -- Join points (if any)-                            , SimplEnv     -- Use this for the alts-                            , SimplCont)-mkDupableCaseCont env alts cont-  | altsWouldDup alts = do { (floats, cont) <- mkDupableCont env cont-                           ; let env' = bumpCaseDepth $-                                        env `setInScopeFromF` floats-                           ; return (floats, env', cont) }-  | otherwise         = return (emptyFloats env, env, cont)--altsWouldDup :: [InAlt] -> Bool -- True iff strictly > 1 non-bottom alternative-altsWouldDup []  = False        -- See Note [Bottom alternatives]-altsWouldDup [_] = False-altsWouldDup (alt:alts)-  | is_bot_alt alt = altsWouldDup alts-  | otherwise      = not (all is_bot_alt alts)-    -- otherwise case: first alt is non-bot, so all the rest must be bot-  where-    is_bot_alt (Alt _ _ rhs) = exprIsDeadEnd rhs----------------------------mkDupableCont :: SimplEnv-              -> SimplCont-              -> SimplM ( SimplFloats  -- Incoming SimplEnv augmented with-                                       --   extra let/join-floats and in-scope variables-                        , SimplCont)   -- dup_cont: duplicable continuation-mkDupableCont env cont-  = mkDupableContWithDmds env (repeat topDmd) cont--mkDupableContWithDmds-   :: SimplEnv  -> [Demand]  -- Demands on arguments; always infinite-   -> SimplCont -> SimplM ( SimplFloats, SimplCont)--mkDupableContWithDmds env _ cont-  | contIsDupable cont-  = return (emptyFloats env, cont)--mkDupableContWithDmds _ _ (Stop {}) = panic "mkDupableCont"     -- Handled by previous eqn--mkDupableContWithDmds env dmds (CastIt ty cont)-  = do  { (floats, cont') <- mkDupableContWithDmds env dmds cont-        ; return (floats, CastIt ty cont') }---- Duplicating ticks for now, not sure if this is good or not-mkDupableContWithDmds env dmds (TickIt t cont)-  = do  { (floats, cont') <- mkDupableContWithDmds env dmds cont-        ; return (floats, TickIt t cont') }--mkDupableContWithDmds env _-     (StrictBind { sc_bndr = bndr, sc_body = body-                 , sc_env = se, sc_cont = cont})--- See Note [Duplicating StrictBind]--- K[ let x = <> in b ]  -->   join j x = K[ b ]---                             j <>-  = do { let sb_env = se `setInScopeFromE` env-       ; (sb_env1, bndr')      <- simplBinder sb_env bndr-       ; (floats1, join_inner) <- simplLam sb_env1 body cont-          -- No need to use mkDupableCont before simplLam; we-          -- use cont once here, and then share the result if necessary--       ; let join_body = wrapFloats floats1 join_inner-             res_ty    = contResultType cont--       ; mkDupableStrictBind env bndr' join_body res_ty }--mkDupableContWithDmds env _-    (StrictArg { sc_fun = fun, sc_cont = cont-               , sc_fun_ty = fun_ty })-  -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable-  | isNothing (isDataConId_maybe (ai_fun fun))-  , thumbsUpPlanA cont  -- See point (3) of Note [Duplicating join points]-  = -- Use Plan A of Note [Duplicating StrictArg]-    do { let (_ : dmds) = ai_dmds fun-       ; (floats1, cont')  <- mkDupableContWithDmds env dmds cont-                              -- Use the demands from the function to add the right-                              -- demand info on any bindings we make for further args-       ; (floats_s, args') <- mapAndUnzipM (makeTrivialArg env)-                                           (ai_args fun)-       ; return ( foldl' addLetFloats floats1 floats_s-                , StrictArg { sc_fun = fun { ai_args = args' }-                            , sc_cont = cont'-                            , sc_fun_ty = fun_ty-                            , sc_dup = OkToDup} ) }--  | otherwise-  = -- Use Plan B of Note [Duplicating StrictArg]-    --   K[ f a b <> ]   -->   join j x = K[ f a b x ]-    --                         j <>-    do { let rhs_ty       = contResultType cont-             (m,arg_ty,_) = splitFunTy fun_ty-       ; arg_bndr <- newId (fsLit "arg") m arg_ty-       ; let env' = env `addNewInScopeIds` [arg_bndr]-       ; (floats, join_rhs) <- rebuildCall env' (addValArgTo fun (Var arg_bndr) fun_ty) cont-       ; mkDupableStrictBind env' arg_bndr (wrapFloats floats join_rhs) rhs_ty }-  where-    thumbsUpPlanA (StrictArg {})               = False-    thumbsUpPlanA (CastIt _ k)                 = thumbsUpPlanA k-    thumbsUpPlanA (TickIt _ k)                 = thumbsUpPlanA k-    thumbsUpPlanA (ApplyToVal { sc_cont = k }) = thumbsUpPlanA k-    thumbsUpPlanA (ApplyToTy  { sc_cont = k }) = thumbsUpPlanA k-    thumbsUpPlanA (Select {})                  = True-    thumbsUpPlanA (StrictBind {})              = True-    thumbsUpPlanA (Stop {})                    = True--mkDupableContWithDmds env dmds-    (ApplyToTy { sc_cont = cont, sc_arg_ty = arg_ty, sc_hole_ty = hole_ty })-  = do  { (floats, cont') <- mkDupableContWithDmds env dmds cont-        ; return (floats, ApplyToTy { sc_cont = cont'-                                    , sc_arg_ty = arg_ty, sc_hole_ty = hole_ty }) }--mkDupableContWithDmds env dmds-    (ApplyToVal { sc_arg = arg, sc_dup = dup, sc_env = se-                , sc_cont = cont, sc_hole_ty = hole_ty })-  =     -- e.g.         [...hole...] (...arg...)-        --      ==>-        --              let a = ...arg...-        --              in [...hole...] a-        -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable-    do  { let (dmd:_) = dmds   -- Never fails-        ; (floats1, cont') <- mkDupableContWithDmds env dmds cont-        ; let env' = env `setInScopeFromF` floats1-        ; (_, se', arg') <- simplArg env' dup se arg-        ; (let_floats2, arg'') <- makeTrivial env NotTopLevel dmd (fsLit "karg") arg'-        ; let all_floats = floats1 `addLetFloats` let_floats2-        ; return ( all_floats-                 , ApplyToVal { sc_arg = arg''-                              , sc_env = se' `setInScopeFromF` all_floats-                                         -- Ensure that sc_env includes the free vars of-                                         -- arg'' in its in-scope set, even if makeTrivial-                                         -- has turned arg'' into a fresh variable-                                         -- See Note [StaticEnv invariant] in GHC.Core.Opt.Simplify.Utils-                              , sc_dup = OkToDup, sc_cont = cont'-                              , sc_hole_ty = hole_ty }) }--mkDupableContWithDmds env _-    (Select { sc_bndr = case_bndr, sc_alts = alts, sc_env = se, sc_cont = cont })-  =     -- e.g.         (case [...hole...] of { pi -> ei })-        --      ===>-        --              let ji = \xij -> ei-        --              in case [...hole...] of { pi -> ji xij }-        -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable-    do  { tick (CaseOfCase case_bndr)-        ; (floats, alt_env, alt_cont) <- mkDupableCaseCont (se `setInScopeFromE` env) alts cont-                -- NB: We call mkDupableCaseCont here to make cont duplicable-                --     (if necessary, depending on the number of alts)-                -- And this is important: see Note [Fusing case continuations]--        ; let cont_scaling = contHoleScaling cont-          -- See Note [Scaling in case-of-case]-        ; (alt_env', case_bndr') <- simplBinder alt_env (scaleIdBy cont_scaling case_bndr)-        ; alts' <- mapM (simplAlt alt_env' Nothing [] case_bndr' alt_cont) (scaleAltsBy cont_scaling alts)-        -- Safe to say that there are no handled-cons for the DEFAULT case-                -- NB: simplBinder does not zap deadness occ-info, so-                -- a dead case_bndr' will still advertise its deadness-                -- This is really important because in-                --      case e of b { (# p,q #) -> ... }-                -- b is always dead, and indeed we are not allowed to bind b to (# p,q #),-                -- which might happen if e was an explicit unboxed pair and b wasn't marked dead.-                -- In the new alts we build, we have the new case binder, so it must retain-                -- its deadness.-        -- NB: we don't use alt_env further; it has the substEnv for-        --     the alternatives, and we don't want that--        ; (join_floats, alts'') <- mapAccumLM (mkDupableAlt (targetPlatform (seDynFlags env)) case_bndr')-                                              emptyJoinFloats alts'--        ; let all_floats = floats `addJoinFloats` join_floats-                           -- Note [Duplicated env]-        ; return (all_floats-                 , Select { sc_dup  = OkToDup-                          , sc_bndr = case_bndr'-                          , sc_alts = alts''-                          , sc_env  = zapSubstEnv se `setInScopeFromF` all_floats-                                      -- See Note [StaticEnv invariant] in GHC.Core.Opt.Simplify.Utils-                          , sc_cont = mkBoringStop (contResultType cont) } ) }--mkDupableStrictBind :: SimplEnv -> OutId -> OutExpr -> OutType-                    -> SimplM (SimplFloats, SimplCont)-mkDupableStrictBind env arg_bndr join_rhs res_ty-  | exprIsTrivial join_rhs   -- See point (2) of Note [Duplicating join points]-  = return (emptyFloats env-           , StrictBind { sc_bndr = arg_bndr-                        , sc_body = join_rhs-                        , sc_env  = zapSubstEnv env-                          -- See Note [StaticEnv invariant] in GHC.Core.Opt.Simplify.Utils-                        , sc_dup  = OkToDup-                        , sc_cont = mkBoringStop res_ty } )-  | otherwise-  = do { join_bndr <- newJoinId [arg_bndr] res_ty-       ; let arg_info = ArgInfo { ai_fun   = join_bndr-                                , ai_rules = Nothing, ai_args  = []-                                , ai_encl  = False, ai_dmds  = repeat topDmd-                                , ai_discs = repeat 0 }-       ; return ( addJoinFloats (emptyFloats env) $-                  unitJoinFloat                   $-                  NonRec join_bndr                $-                  Lam (setOneShotLambda arg_bndr) join_rhs-                , StrictArg { sc_dup    = OkToDup-                            , sc_fun    = arg_info-                            , sc_fun_ty = idType join_bndr-                            , sc_cont   = mkBoringStop res_ty-                            } ) }--mkDupableAlt :: Platform -> OutId-             -> JoinFloats -> OutAlt-             -> SimplM (JoinFloats, OutAlt)-mkDupableAlt _platform case_bndr jfloats (Alt con alt_bndrs alt_rhs_in)-  | exprIsTrivial alt_rhs_in   -- See point (2) of Note [Duplicating join points]-  = return (jfloats, Alt con alt_bndrs alt_rhs_in)--  | otherwise-  = do  { let rhs_ty'  = exprType alt_rhs_in--              bangs-                | DataAlt c <- con-                = dataConRepStrictness c-                | otherwise = []--              abstracted_binders = abstract_binders alt_bndrs bangs--              abstract_binders :: [Var] -> [StrictnessMark] -> [(Id,StrictnessMark)]-              abstract_binders [] []-                -- Abstract over the case binder too if it's used.-                | isDeadBinder case_bndr  = []-                | otherwise               = [(case_bndr,MarkedStrict)]-              abstract_binders (alt_bndr:alt_bndrs) marks-                -- Abstract over all type variables just in case-                | isTyVar alt_bndr        = (alt_bndr,NotMarkedStrict) : abstract_binders alt_bndrs marks-              abstract_binders (alt_bndr:alt_bndrs) (mark:marks)-                -- The deadness info on the new Ids is preserved by simplBinders-                -- We don't abstract over dead ids here.-                | isDeadBinder alt_bndr   = abstract_binders alt_bndrs marks-                | otherwise               = (alt_bndr,mark) : abstract_binders alt_bndrs marks-              abstract_binders _ _ = pprPanic "abstrict_binders - failed to abstract" (ppr $ Alt con alt_bndrs alt_rhs_in)--              filtered_binders = map fst abstracted_binders-              -- We want to make any binder with an evaldUnfolding strict in the rhs.-              -- See Note [Call-by-value for worker args] (which also applies to join points)-              (rhs_with_seqs) = mkStrictFieldSeqs abstracted_binders alt_rhs_in--              final_args = varsToCoreExprs filtered_binders-                           -- Note [Join point abstraction]--                -- We make the lambdas into one-shot-lambdas.  The-                -- join point is sure to be applied at most once, and doing so-                -- prevents the body of the join point being floated out by-                -- the full laziness pass-              final_bndrs     = map one_shot filtered_binders-              one_shot v | isId v    = setOneShotLambda v-                         | otherwise = v--              -- No lambda binder has an unfolding, but (currently) case binders can,-              -- so we must zap them here.-              join_rhs   = mkLams (map zapIdUnfolding final_bndrs) rhs_with_seqs--        ; join_bndr <- newJoinId filtered_binders rhs_ty'--        ; let join_call = mkApps (Var join_bndr) final_args-              alt'      = Alt con alt_bndrs join_call--        ; return ( jfloats `addJoinFlts` unitJoinFloat (NonRec join_bndr join_rhs)-                 , alt') }-                -- See Note [Duplicated env]--{--Note [Fusing case continuations]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-It's important to fuse two successive case continuations when the-first has one alternative.  That's why we call prepareCaseCont here.-Consider this, which arises from thunk splitting (see Note [Thunk-splitting] in GHC.Core.Opt.WorkWrap):--      let-        x* = case (case v of {pn -> rn}) of-               I# a -> I# a-      in body--The simplifier will find-    (Var v) with continuation-            Select (pn -> rn) (-            Select [I# a -> I# a] (-            StrictBind body Stop--So we'll call mkDupableCont on-   Select [I# a -> I# a] (StrictBind body Stop)-There is just one alternative in the first Select, so we want to-simplify the rhs (I# a) with continuation (StrictBind body Stop)-Supposing that body is big, we end up with-          let $j a = <let x = I# a in body>-          in case v of { pn -> case rn of-                                 I# a -> $j a }-This is just what we want because the rn produces a box that-the case rn cancels with.--See #4957 a fuller example.--Note [Duplicating join points]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-IN #19996 we discovered that we want to be really careful about-inlining join points.   Consider-    case (join $j x = K f x )-         (in case v of      )-         (     p1 -> $j x1  ) of-         (     p2 -> $j x2  )-         (     p3 -> $j x3  )-      K g y -> blah[g,y]--Here the join-point RHS is very small, just a constructor-application (K x y).  So we might inline it to get-    case (case v of        )-         (     p1 -> K f x1  ) of-         (     p2 -> K f x2  )-         (     p3 -> K f x3  )-      K g y -> blah[g,y]--But now we have to make `blah` into a join point, /abstracted/-over `g` and `y`.   In contrast, if we /don't/ inline $j we-don't need a join point for `blah` and we'll get-    join $j x = let g=f, y=x in blah[g,y]-    in case v of-       p1 -> $j x1-       p2 -> $j x2-       p3 -> $j x3--This can make a /massive/ difference, because `blah` can see-what `f` is, instead of lambda-abstracting over it.--To achieve this:--1. Do not postInlineUnconditionally a join point, until the Final-   phase.  (The Final phase is still quite early, so we might consider-   delaying still more.)--2. In mkDupableAlt and mkDupableStrictBind, generate an alterative for-   all alternatives, except for exprIsTrival RHSs. Previously we used-   exprIsDupable.  This generates a lot more join points, but makes-   them much more case-of-case friendly.--   It is definitely worth checking for exprIsTrivial, otherwise we get-   an extra Simplifier iteration, because it is inlined in the next-   round.--3. By the same token we want to use Plan B in-   Note [Duplicating StrictArg] when the RHS of the new join point-   is a data constructor application.  That same Note explains why we-   want Plan A when the RHS of the new join point would be a-   non-data-constructor application--4. You might worry that $j will be inlined by the call-site inliner,-   but it won't because the call-site context for a join is usually-   extremely boring (the arguments come from the pattern match).-   And if not, then perhaps inlining it would be a good idea.--   You might also wonder if we get UnfWhen, because the RHS of the-   join point is no bigger than the call. But in the cases we care-   about it will be a little bigger, because of that free `f` in-       $j x = K f x-   So for now we don't do anything special in callSiteInline--There is a bit of tension between (2) and (3).  Do we want to retain-the join point only when the RHS is-* a constructor application? or-* just non-trivial?-Currently, a bit ad-hoc, but we definitely want to retain the join-point for data constructors in mkDupalbleALt (point 2); that is the-whole point of #19996 described above.--Historical Note [Case binders and join points]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-NB: this entire Note is now irrelevant.  In Jun 21 we stopped-adding unfoldings to lambda binders (#17530).  It was always a-hack and bit us in multiple small and not-so-small ways--Consider this-   case (case .. ) of c {-     I# c# -> ....c....--If we make a join point with c but not c# we get-  $j = \c -> ....c....--But if later inlining scrutinises the c, thus--  $j = \c -> ... case c of { I# y -> ... } ...--we won't see that 'c' has already been scrutinised.  This actually-happens in the 'tabulate' function in wave4main, and makes a significant-difference to allocation.--An alternative plan is this:--   $j = \c# -> let c = I# c# in ...c....--but that is bad if 'c' is *not* later scrutinised.--So instead we do both: we pass 'c' and 'c#' , and record in c's inlining-(a stable unfolding) that it's really I# c#, thus--   $j = \c# -> \c[=I# c#] -> ...c....--Absence analysis may later discard 'c'.--NB: take great care when doing strictness analysis;-    see Note [Lambda-bound unfoldings] in GHC.Core.Opt.DmdAnal.--Also note that we can still end up passing stuff that isn't used.  Before-strictness analysis we have-   let $j x y c{=(x,y)} = (h c, ...)-   in ...-After strictness analysis we see that h is strict, we end up with-   let $j x y c{=(x,y)} = ($wh x y, ...)-and c is unused.--Note [Duplicated env]-~~~~~~~~~~~~~~~~~~~~~-Some of the alternatives are simplified, but have not been turned into a join point-So they *must* have a zapped subst-env.  So we can't use completeNonRecX to-bind the join point, because it might to do PostInlineUnconditionally, and-we'd lose that when zapping the subst-env.  We could have a per-alt subst-env,-but zapping it (as we do in mkDupableCont, the Select case) is safe, and-at worst delays the join-point inlining.--Note [Funky mkLamTypes]-~~~~~~~~~~~~~~~~~~~~~~-Notice the funky mkLamTypes.  If the constructor has existentials-it's possible that the join point will be abstracted over-type variables as well as term variables.- Example:  Suppose we have-        data T = forall t.  C [t]- Then faced with-        case (case e of ...) of-            C t xs::[t] -> rhs- We get the join point-        let j :: forall t. [t] -> ...-            j = /\t \xs::[t] -> rhs-        in-        case (case e of ...) of-            C t xs::[t] -> j t xs--Note [Duplicating StrictArg]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Dealing with making a StrictArg continuation duplicable has turned out-to be one of the trickiest corners of the simplifier, giving rise-to several cases in which the simplier expanded the program's size-*exponentially*.  They include-  #13253 exponential inlining-  #10421 ditto-  #18140 strict constructors-  #18282 another nested-function call case--Suppose we have a call-  f e1 (case x of { True -> r1; False -> r2 }) e3-and f is strict in its second argument.  Then we end up in-mkDupableCont with a StrictArg continuation for (f e1 <> e3).-There are two ways to make it duplicable.--* Plan A: move the entire call inwards, being careful not-  to duplicate e1 or e3, thus:-     let a1 = e1-         a3 = e3-     in case x of { True  -> f a1 r1 a3-                  ; False -> f a1 r2 a3 }--* Plan B: make a join point:-     join $j x = f e1 x e3-     in case x of { True  -> jump $j r1-                  ; False -> jump $j r2 }--  Notice that Plan B is very like the way we handle strict bindings;-  see Note [Duplicating StrictBind].  And Plan B is exactly what we'd-  get if we turned use a case expression to evaluate the strict arg:--       case (case x of { True -> r1; False -> r2 }) of-         r -> f e1 r e3--  So, looking at Note [Duplicating join points], we also want Plan B-  when `f` is a data constructor.--Plan A is often good. Here's an example from #3116-     go (n+1) (case l of-                 1  -> bs'-                 _  -> Chunk p fpc (o+1) (l-1) bs')--If we pushed the entire call for 'go' inside the case, we get-call-pattern specialisation for 'go', which is *crucial* for-this particular program.--Here is another example.-        && E (case x of { T -> F; F -> T })--Pushing the call inward (being careful not to duplicate E)-        let a = E-        in case x of { T -> && a F; F -> && a T }--and now the (&& a F) etc can optimise.  Moreover there might-be a RULE for the function that can fire when it "sees" the-particular case alternative.--But Plan A can have terrible, terrible behaviour. Here is a classic-case:-  f (f (f (f (f True))))--Suppose f is strict, and has a body that is small enough to inline.-The innermost call inlines (seeing the True) to give-  f (f (f (f (case v of { True -> e1; False -> e2 }))))--Now, suppose we naively push the entire continuation into both-case branches (it doesn't look large, just f.f.f.f). We get-  case v of-    True  -> f (f (f (f e1)))-    False -> f (f (f (f e2)))--And now the process repeats, so we end up with an exponentially large-number of copies of f. No good!--CONCLUSION: we want Plan A in general, but do Plan B is there a-danger of this nested call behaviour. The function that decides-this is called thumbsUpPlanA.--Note [Keeping demand info in StrictArg Plan A]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Following on from Note [Duplicating StrictArg], another common code-pattern that can go bad is this:-   f (case x1 of { T -> F; F -> T })-     (case x2 of { T -> F; F -> T })-     ...etc...-when f is strict in all its arguments.  (It might, for example, be a-strict data constructor whose wrapper has not yet been inlined.)--We use Plan A (because there is no nesting) giving-  let a2 = case x2 of ...-      a3 = case x3 of ...-  in case x1 of { T -> f F a2 a3 ... ; F -> f T a2 a3 ... }--Now we must be careful!  a2 and a3 are small, and the OneOcc code in-postInlineUnconditionally may inline them both at both sites; see Note-Note [Inline small things to avoid creating a thunk] in-Simplify.Utils. But if we do inline them, the entire process will-repeat -- back to exponential behaviour.--So we are careful to keep the demand-info on a2 and a3.  Then they'll-be /strict/ let-bindings, which will be dealt with by StrictBind.-That's why contIsDupableWithDmds is careful to propagage demand-info to the auxiliary bindings it creates.  See the Demand argument-to makeTrivial.--Note [Duplicating StrictBind]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We make a StrictBind duplicable in a very similar way to-that for case expressions.  After all,-   let x* = e in b   is similar to    case e of x -> b--So we potentially make a join-point for the body, thus:-   let x = <> in b   ==>   join j x = b-                           in j <>--Just like StrictArg in fact -- and indeed they share code.--Note [Join point abstraction]  Historical note-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-NB: This note is now historical, describing how (in the past) we used-to add a void argument to nullary join points.  But now that "join-point" is not a fuzzy concept but a formal syntactic construct (as-distinguished by the JoinId constructor of IdDetails), each of these-concerns is handled separately, with no need for a vestigial extra-argument.--Join points always have at least one value argument,-for several reasons--* If we try to lift a primitive-typed something out-  for let-binding-purposes, we will *caseify* it (!),-  with potentially-disastrous strictness results.  So-  instead we turn it into a function: \v -> e-  where v::Void#.  The value passed to this function is void,-  which generates (almost) no code.--* CPR.  We used to say "&& isUnliftedType rhs_ty'" here, but now-  we make the join point into a function whenever used_bndrs'-  is empty.  This makes the join-point more CPR friendly.-  Consider:       let j = if .. then I# 3 else I# 4-                  in case .. of { A -> j; B -> j; C -> ... }--  Now CPR doesn't w/w j because it's a thunk, so-  that means that the enclosing function can't w/w either,-  which is a lose.  Here's the example that happened in practice:-          kgmod :: Int -> Int -> Int-          kgmod x y = if x > 0 && y < 0 || x < 0 && y > 0-                      then 78-                      else 5--* Let-no-escape.  We want a join point to turn into a let-no-escape-  so that it is implemented as a jump, and one of the conditions-  for LNE is that it's not updatable.  In CoreToStg, see-  Note [What is a non-escaping let]--* Floating.  Since a join point will be entered once, no sharing is-  gained by floating out, but something might be lost by doing-  so because it might be allocated.--I have seen a case alternative like this:-        True -> \v -> ...-It's a bit silly to add the realWorld dummy arg in this case, making-        $j = \s v -> ...-           True -> $j s-(the \v alone is enough to make CPR happy) but I think it's rare--There's a slight infelicity here: we pass the overall-case_bndr to all the join points if it's used in *any* RHS,-because we don't know its usage in each RHS separately----************************************************************************-*                                                                      *-                    Unfoldings-*                                                                      *-************************************************************************--}--simplLetUnfolding :: SimplEnv-                  -> BindContext-                  -> InId-                  -> OutExpr -> OutType -> ArityType-                  -> Unfolding -> SimplM Unfolding-simplLetUnfolding env bind_cxt id new_rhs rhs_ty arity unf-  | isStableUnfolding unf-  = simplStableUnfolding env bind_cxt id rhs_ty arity unf-  | isExitJoinId id-  = return noUnfolding -- See Note [Do not inline exit join points] in GHC.Core.Opt.Exitify-  | otherwise-  = -- Otherwise, we end up retaining all the SimpleEnv-    let !opts = seUnfoldingOpts env-    in mkLetUnfolding opts (bindContextLevel bind_cxt) InlineRhs id new_rhs----------------------mkLetUnfolding :: UnfoldingOpts -> TopLevelFlag -> UnfoldingSource-               -> InId -> OutExpr -> SimplM Unfolding-mkLetUnfolding !uf_opts top_lvl src id new_rhs-  = return (mkUnfolding uf_opts src is_top_lvl is_bottoming new_rhs)-            -- We make an  unfolding *even for loop-breakers*.-            -- Reason: (a) It might be useful to know that they are WHNF-            --         (b) In GHC.Iface.Tidy we currently assume that, if we want to-            --             expose the unfolding then indeed we *have* an unfolding-            --             to expose.  (We could instead use the RHS, but currently-            --             we don't.)  The simple thing is always to have one.-  where-    -- Might as well force this, profiles indicate up to 0.5MB of thunks-    -- just from this site.-    !is_top_lvl   = isTopLevel top_lvl-    -- See Note [Force bottoming field]-    !is_bottoming = isDeadEndId id----------------------simplStableUnfolding :: SimplEnv -> BindContext-                     -> InId-                     -> OutType-                     -> ArityType      -- Used to eta expand, but only for non-join-points-                     -> Unfolding-                     ->SimplM Unfolding--- Note [Setting the new unfolding]-simplStableUnfolding env bind_cxt id rhs_ty id_arity unf-  = case unf of-      NoUnfolding   -> return unf-      BootUnfolding -> return unf-      OtherCon {}   -> return unf--      DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = args }-        -> do { (env', bndrs') <- simplBinders unf_env bndrs-              ; args' <- mapM (simplExpr env') args-              ; return (mkDFunUnfolding bndrs' con args') }--      CoreUnfolding { uf_tmpl = expr, uf_src = src, uf_guidance = guide }-        | isStableSource src-        -> do { expr' <- case bind_cxt of-                           BC_Join cont -> -- Binder is a join point-                                           -- See Note [Rules and unfolding for join points]-                                           simplJoinRhs unf_env id expr cont-                           BC_Let {} -> -- Binder is not a join point-                                        do { expr' <- simplExprC unf_env expr (mkBoringStop rhs_ty)-                                           ; return (eta_expand expr') }-              ; case guide of-                  UnfWhen { ug_arity = arity-                          , ug_unsat_ok = sat_ok-                          , ug_boring_ok = boring_ok-                          }-                          -- Happens for INLINE things-                        -- Really important to force new_boring_ok as otherwise-                        -- `ug_boring_ok` is a thunk chain of-                        -- inlineBoringExprOk expr0-                        --  || inlineBoringExprOk expr1 || ...-                        --  See #20134-                     -> let !new_boring_ok = boring_ok || inlineBoringOk expr'-                            guide' =-                              UnfWhen { ug_arity = arity-                                      , ug_unsat_ok = sat_ok-                                      , ug_boring_ok = new_boring_ok--                                      }-                        -- Refresh the boring-ok flag, in case expr'-                        -- has got small. This happens, notably in the inlinings-                        -- for dfuns for single-method classes; see-                        -- Note [Single-method classes] in GHC.Tc.TyCl.Instance.-                        -- A test case is #4138-                        -- But retain a previous boring_ok of True; e.g. see-                        -- the way it is set in calcUnfoldingGuidanceWithArity-                        in return (mkCoreUnfolding src is_top_lvl expr' guide')-                            -- See Note [Top-level flag on inline rules] in GHC.Core.Unfold--                  _other              -- Happens for INLINABLE things-                     -> mkLetUnfolding uf_opts top_lvl src id expr' }-                -- If the guidance is UnfIfGoodArgs, this is an INLINABLE-                -- unfolding, and we need to make sure the guidance is kept up-                -- to date with respect to any changes in the unfolding.--        | otherwise -> return noUnfolding   -- Discard unstable unfoldings-  where-    uf_opts    = seUnfoldingOpts env-    -- Forcing this can save about 0.5MB of max residency and the result-    -- is small and easy to compute so might as well force it.-    top_lvl     = bindContextLevel bind_cxt-    !is_top_lvl = isTopLevel top_lvl-    act        = idInlineActivation id-    unf_env    = updMode (updModeForStableUnfoldings act) env-         -- See Note [Simplifying inside stable unfoldings] in GHC.Core.Opt.Simplify.Utils--    -- See Note [Eta-expand stable unfoldings]-    eta_expand expr-      | not eta_on         = expr-      | exprIsTrivial expr = expr-      | otherwise          = etaExpandAT (getInScope env) id_arity expr-    eta_on = sm_eta_expand (getMode env)--{- Note [Eta-expand stable unfoldings]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-For INLINE/INLINABLE things (which get stable unfoldings) there's a danger-of getting-   f :: Int -> Int -> Int -> Blah-   [ Arity = 3                 -- Good arity-   , Unf=Stable (\xy. blah)    -- Less good arity, only 2-   f = \pqr. e--This can happen because f's RHS is optimised more vigorously than-its stable unfolding.  Now suppose we have a call-   g = f x-Because f has arity=3, g will have arity=2.  But if we inline f (using-its stable unfolding) g's arity will reduce to 1, because <blah>-hasn't been optimised yet.  This happened in the 'parsec' library,-for Text.Pasec.Char.string.--Generally, if we know that 'f' has arity N, it seems sensible to-eta-expand the stable unfolding to arity N too. Simple and consistent.--Wrinkles--* See Note [Eta-expansion in stable unfoldings] in-  GHC.Core.Opt.Simplify.Utils--* Don't eta-expand a trivial expr, else each pass will eta-reduce it,-  and then eta-expand again. See Note [Do not eta-expand trivial expressions]-  in GHC.Core.Opt.Simplify.Utils.--* Don't eta-expand join points; see Note [Do not eta-expand join points]-  in GHC.Core.Opt.Simplify.Utils.  We uphold this because the join-point-  case (bind_cxt = BC_Join _) doesn't use eta_expand.--Note [Force bottoming field]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We need to force bottoming, or the new unfolding holds-on to the old unfolding (which is part of the id).--Note [Setting the new unfolding]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-* If there's an INLINE pragma, we simplify the RHS gently.  Maybe we-  should do nothing at all, but simplifying gently might get rid of-  more crap.--* If not, we make an unfolding from the new RHS.  But *only* for-  non-loop-breakers. Making loop breakers not have an unfolding at all-  means that we can avoid tests in exprIsConApp, for example.  This is-  important: if exprIsConApp says 'yes' for a recursive thing, then we-  can get into an infinite loop--If there's a stable unfolding on a loop breaker (which happens for-INLINABLE), we hang on to the inlining.  It's pretty dodgy, but the-user did say 'INLINE'.  May need to revisit this choice.--************************************************************************-*                                                                      *-                    Rules-*                                                                      *-************************************************************************--Note [Rules in a letrec]-~~~~~~~~~~~~~~~~~~~~~~~~-After creating fresh binders for the binders of a letrec, we-substitute the RULES and add them back onto the binders; this is done-*before* processing any of the RHSs.  This is important.  Manuel found-cases where he really, really wanted a RULE for a recursive function-to apply in that function's own right-hand side.--See Note [Forming Rec groups] in "GHC.Core.Opt.OccurAnal"--}--addBndrRules :: SimplEnv -> InBndr -> OutBndr-             -> BindContext-             -> SimplM (SimplEnv, OutBndr)--- Rules are added back into the bin-addBndrRules env in_id out_id bind_cxt-  | null old_rules-  = return (env, out_id)-  | otherwise-  = do { new_rules <- simplRules env (Just out_id) old_rules bind_cxt-       ; let final_id  = out_id `setIdSpecialisation` mkRuleInfo new_rules-       ; return (modifyInScope env final_id, final_id) }-  where-    old_rules = ruleInfoRules (idSpecialisation in_id)--simplImpRules :: SimplEnv -> [CoreRule] -> SimplM [CoreRule]--- Simplify local rules for imported Ids-simplImpRules env rules-  = simplRules env Nothing rules (BC_Let TopLevel NonRecursive)--simplRules :: SimplEnv -> Maybe OutId -> [CoreRule]-           -> BindContext -> SimplM [CoreRule]-simplRules env mb_new_id rules bind_cxt-  = mapM simpl_rule rules-  where-    simpl_rule rule@(BuiltinRule {})-      = return rule--    simpl_rule rule@(Rule { ru_bndrs = bndrs, ru_args = args-                          , ru_fn = fn_name, ru_rhs = rhs-                          , ru_act = act })-      = do { (env', bndrs') <- simplBinders env bndrs-           ; let rhs_ty = substTy env' (exprType rhs)-                 rhs_cont = case bind_cxt of  -- See Note [Rules and unfolding for join points]-                                BC_Let {}    -> mkBoringStop rhs_ty-                                BC_Join cont -> assertPpr join_ok bad_join_msg cont-                 lhs_env = updMode updModeForRules env'-                 rhs_env = updMode (updModeForStableUnfoldings act) env'-                           -- See Note [Simplifying the RHS of a RULE]-                 fn_name' = case mb_new_id of-                              Just id -> idName id-                              Nothing -> fn_name--                 -- join_ok is an assertion check that the join-arity of the-                 -- binder matches that of the rule, so that pushing the-                 -- continuation into the RHS makes sense-                 join_ok = case mb_new_id of-                             Just id | Just join_arity <- isJoinId_maybe id-                                     -> length args == join_arity-                             _ -> False-                 bad_join_msg = vcat [ ppr mb_new_id, ppr rule-                                     , ppr (fmap isJoinId_maybe mb_new_id) ]--           ; args' <- mapM (simplExpr lhs_env) args-           ; rhs'  <- simplExprC rhs_env rhs rhs_cont-           ; return (rule { ru_bndrs = bndrs'-                          , ru_fn    = fn_name'-                          , ru_args  = args'-                          , ru_rhs   = rhs' }) }--{- Note [Simplifying the RHS of a RULE]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We can simplify the RHS of a RULE much as we do the RHS of a stable-unfolding.  We used to use the much more conservative updModeForRules-for the RHS as well as the LHS, but that seems more conservative-than necesary.  Allowing some inlining might, for example, eliminate-a binding.--}--+{-# LANGUAGE CPP #-}++module GHC.Core.Opt.Simplify+  ( SimplifyExprOpts(..), SimplifyOpts(..)+  , simplifyExpr, simplifyPgm+  ) where++import GHC.Prelude++import GHC.Driver.Flags++import GHC.Core+import GHC.Core.Rules+import GHC.Core.Ppr     ( pprCoreBindings, pprCoreExpr )+import GHC.Core.Opt.OccurAnal ( occurAnalysePgm, occurAnalyseExpr )+import GHC.Core.Stats   ( coreBindsSize, coreBindsStats, exprSize )+import GHC.Core.Utils   ( mkTicks, stripTicksTop )+import GHC.Core.Lint    ( LintPassResultConfig, dumpPassResult, lintPassResult )+import GHC.Core.Opt.Simplify.Iteration ( simplTopBinds, simplExpr, simplImpRules )+import GHC.Core.Opt.Simplify.Utils  ( activeRule )+import GHC.Core.Opt.Simplify.Inline ( activeUnfolding )+import GHC.Core.Opt.Simplify.Env+import GHC.Core.Opt.Simplify.Monad+import GHC.Core.Opt.Stats ( simplCountN )+import GHC.Core.FamInstEnv++import GHC.Utils.Error  ( withTiming )+import GHC.Utils.Logger as Logger+import GHC.Utils.Outputable+import GHC.Utils.Constants (debugIsOn)++import GHC.Unit.Env ( UnitEnv, ueEPS )+import GHC.Unit.External+import GHC.Unit.Module.ModGuts++import GHC.Types.Id+import GHC.Types.Id.Info+import GHC.Types.Basic+import GHC.Types.Var.Set+import GHC.Types.Var.Env+import GHC.Types.Tickish+import GHC.Types.Unique.FM++import Control.Monad+import Data.Foldable ( for_ )++{-+************************************************************************+*                                                                      *+        Gentle simplification+*                                                                      *+************************************************************************+-}++-- | Configuration record for `simplifyExpr`.+-- The values of this datatype are /only/ driven by the demands of that function.+data SimplifyExprOpts = SimplifyExprOpts+  { se_fam_inst :: ![FamInst]+  , se_mode :: !SimplMode+  , se_top_env_cfg :: !TopEnvConfig+  }++simplifyExpr :: Logger+             -> ExternalUnitCache+             -> SimplifyExprOpts+             -> CoreExpr+             -> IO CoreExpr+-- simplifyExpr is called by the driver to simplify an+-- expression typed in at the interactive prompt+simplifyExpr logger euc opts expr+  = withTiming logger (text "Simplify [expr]") (const ()) $+    do  { eps <- eucEPS euc ;+        ; let fam_envs = ( eps_fam_inst_env eps+                         , extendFamInstEnvList emptyFamInstEnv $ se_fam_inst opts+                         )+              simpl_env = mkSimplEnv (se_mode opts) fam_envs+              top_env_cfg = se_top_env_cfg opts+              read_eps_rules = eps_rule_base <$> eucEPS euc+              read_ruleenv = updExternalPackageRules emptyRuleEnv <$> read_eps_rules++        ; let sz = exprSize expr++        ; (expr', counts) <- initSmpl logger read_ruleenv top_env_cfg sz $+                             simplExprGently simpl_env expr++        ; Logger.putDumpFileMaybe logger Opt_D_dump_simpl_stats+                  "Simplifier statistics" FormatText (pprSimplCount counts)++        ; Logger.putDumpFileMaybe logger Opt_D_dump_simpl "Simplified expression"+                        FormatCore+                        (pprCoreExpr expr')++        ; return expr'+        }++simplExprGently :: SimplEnv -> CoreExpr -> SimplM CoreExpr+-- Simplifies an expression+--      does occurrence analysis, then simplification+--      and repeats (twice currently) because one pass+--      alone leaves tons of crud.+-- Used (a) for user expressions typed in at the interactive prompt+--      (b) the LHS and RHS of a RULE+--      (c) Template Haskell splices+--+-- The name 'Gently' suggests that the SimplMode is InitialPhase,+-- and in fact that is so.... but the 'Gently' in simplExprGently doesn't+-- enforce that; it just simplifies the expression twice++-- It's important that simplExprGently does eta reduction; see+-- Note [Simplify rule LHS] above.  The+-- simplifier does indeed do eta reduction (it's in GHC.Core.Opt.Simplify.completeLam)+-- but only if -O is on.++simplExprGently env expr = do+    expr1 <- simplExpr env (occurAnalyseExpr expr)+    simplExpr env (occurAnalyseExpr expr1)++{-+************************************************************************+*                                                                      *+\subsection{The driver for the simplifier}+*                                                                      *+************************************************************************+-}++-- | Configuration record for `simplifyPgm`.+-- The values of this datatype are /only/ driven by the demands of that function.+data SimplifyOpts = SimplifyOpts+  { so_dump_core_sizes :: !Bool+  , so_iterations      :: !Int+  , so_mode            :: !SimplMode++  , so_pass_result_cfg :: !(Maybe LintPassResultConfig)+                          -- Nothing => Do not Lint+                          -- Just cfg => Lint like this++  , so_hpt_rules       :: !RuleBase+  , so_top_env_cfg     :: !TopEnvConfig+  }++simplifyPgm :: Logger+            -> UnitEnv+            -> NamePprCtx                -- For dumping+            -> SimplifyOpts+            -> ModGuts+            -> IO (SimplCount, ModGuts)  -- New bindings++simplifyPgm logger unit_env name_ppr_ctx opts+            guts@(ModGuts { mg_module = this_mod+                          , mg_binds = binds, mg_rules = local_rules+                          , mg_fam_inst_env = fam_inst_env })+  = do { (termination_msg, it_count, counts_out, guts')+            <- do_iteration 1 [] binds local_rules++        ; when (logHasDumpFlag logger Opt_D_verbose_core2core+                && logHasDumpFlag logger Opt_D_dump_simpl_stats) $+          logDumpMsg logger+                  "Simplifier statistics for following pass"+                  (vcat [text termination_msg <+> text "after" <+> ppr it_count+                                              <+> text "iterations",+                         blankLine,+                         pprSimplCount counts_out])++        ; return (counts_out, guts')+    }+  where+    dump_core_sizes = so_dump_core_sizes opts+    mode            = so_mode opts+    max_iterations  = so_iterations opts+    top_env_cfg     = so_top_env_cfg opts+    active_rule     = activeRule mode+    active_unf      = activeUnfolding mode+    -- Note the bang in !guts_no_binds.  If you don't force `guts_no_binds`+    -- the old bindings are retained until the end of all simplifier iterations+    !guts_no_binds = guts { mg_binds = [], mg_rules = [] }++    hpt_rule_env :: RuleEnv+    hpt_rule_env = mkRuleEnv guts emptyRuleBase (so_hpt_rules opts)+                   -- emptyRuleBase: no EPS rules yet; we will update+                   -- them on each iteration to pick up the most up to date set++    do_iteration :: Int -- Counts iterations+                 -> [SimplCount] -- Counts from earlier iterations, reversed+                 -> CoreProgram  -- Bindings+                 -> [CoreRule]   -- Local rules for imported Ids+                 -> IO (String, Int, SimplCount, ModGuts)++    do_iteration iteration_no counts_so_far binds local_rules+        -- iteration_no is the number of the iteration we are+        -- about to begin, with '1' for the first+      | iteration_no > max_iterations   -- Stop if we've run out of iterations+      = warnPprTrace (debugIsOn && (max_iterations > 2))+            "Simplifier bailing out"+            ( hang (ppr this_mod <> text ", after"+                    <+> int max_iterations <+> text "iterations"+                    <+> (brackets $ hsep $ punctuate comma $+                         map (int . simplCountN) (reverse counts_so_far)))+                 2 (text "Size =" <+> ppr (coreBindsStats binds))) $++                -- Subtract 1 from iteration_no to get the+                -- number of iterations we actually completed+        return ( "Simplifier bailed out", iteration_no - 1+               , totalise counts_so_far+               , guts_no_binds { mg_binds = binds, mg_rules = local_rules } )++      -- Try and force thunks off the binds; significantly reduces+      -- space usage, especially with -O.  JRS, 000620.+      | let sz = coreBindsSize binds+      , () <- sz `seq` ()     -- Force it+      = do {+                -- Occurrence analysis+           let { tagged_binds = {-# SCC "OccAnal" #-}+                     occurAnalysePgm this_mod active_unf active_rule+                                     local_rules binds+               } ;+           Logger.putDumpFileMaybe logger Opt_D_dump_occur_anal "Occurrence analysis"+                     FormatCore+                     (pprCoreBindings tagged_binds);++                -- read_eps_rules:+                -- We need to read rules from the EPS regularly because simplification can+                -- poke on IdInfo thunks, which in turn brings in new rules+                -- behind the scenes.  Otherwise there's a danger we'll simply+                -- miss the rules for Ids hidden inside imported inlinings+                -- Hence just before attempting to match a rule we read the EPS+                -- value (via read_rule_env) and then combine it with the existing rule base.+                -- See `GHC.Core.Opt.Simplify.Monad.getSimplRules`.+          eps <- ueEPS unit_env ;+           let  { -- base_rule_env contains+                  --    (a) home package rules, fixed across all iterations+                  --    (b) local rules (substituted) from `local_rules` arg to do_iteration+                  -- Forcing base_rule_env to avoid unnecessary allocations.+                  -- Not doing so results in +25.6% allocations of LargeRecord.+                ; !base_rule_env = updLocalRules hpt_rule_env local_rules++                ; read_eps_rules :: IO PackageRuleBase+                ; read_eps_rules = eps_rule_base <$> ueEPS unit_env++                ; read_rule_env :: IO RuleEnv+                ; read_rule_env = updExternalPackageRules base_rule_env <$> read_eps_rules++                ; fam_envs = (eps_fam_inst_env eps, fam_inst_env)+                ; simpl_env = mkSimplEnv mode fam_envs } ;++                -- Simplify the program+           ((binds1, rules1), counts1) <-+             initSmpl logger read_rule_env top_env_cfg sz $+               do { (floats, env1) <- {-# SCC "SimplTopBinds" #-}+                                      simplTopBinds simpl_env tagged_binds++                      -- Apply the substitution to rules defined in this module+                      -- for imported Ids.  Eg  RULE map my_f = blah+                      -- If we have a substitution my_f :-> other_f, we'd better+                      -- apply it to the rule to, or it'll never match+                  ; rules1 <- simplImpRules env1 local_rules++                  ; return (getTopFloatBinds floats, rules1) } ;++                -- Stop if nothing happened; don't dump output+                -- See Note [Which transformations are innocuous] in GHC.Core.Opt.Stats+           if isZeroSimplCount counts1 then+                return ( "Simplifier reached fixed point", iteration_no+                       , totalise (counts1 : counts_so_far)  -- Include "free" ticks+                       , guts_no_binds { mg_binds = binds1, mg_rules = rules1 } )+           else do {+                -- Short out indirections+                -- We do this *after* at least one run of the simplifier+                -- because indirection-shorting uses the export flag on *occurrences*+                -- and that isn't guaranteed to be ok until after the first run propagates+                -- stuff from the binding site to its occurrences+                --+                -- ToDo: alas, this means that indirection-shorting does not happen at all+                --       if the simplifier does nothing (not common, I know, but unsavoury)+           let { binds2 = {-# SCC "ZapInd" #-} shortOutIndirections binds1 } ;++                -- Dump the result of this iteration+           dump_end_iteration logger dump_core_sizes name_ppr_ctx iteration_no counts1 binds2 rules1 ;++           for_ (so_pass_result_cfg opts) $ \pass_result_cfg ->+             lintPassResult logger pass_result_cfg binds2 ;++                -- Loop+           do_iteration (iteration_no + 1) (counts1:counts_so_far) binds2 rules1+           } }+      where+        -- Remember the counts_so_far are reversed+        totalise :: [SimplCount] -> SimplCount+        totalise = foldr (\c acc -> acc `plusSimplCount` c)+                         (zeroSimplCount $ logHasDumpFlag logger Opt_D_dump_simpl_stats)++dump_end_iteration :: Logger -> Bool -> NamePprCtx -> Int+                   -> SimplCount -> CoreProgram -> [CoreRule] -> IO ()+dump_end_iteration logger dump_core_sizes name_ppr_ctx iteration_no counts binds rules+  = dumpPassResult logger dump_core_sizes name_ppr_ctx mb_flag hdr pp_counts binds rules+  where+    mb_flag | logHasDumpFlag logger Opt_D_dump_simpl_iterations = Just Opt_D_dump_simpl_iterations+            | otherwise                                         = Nothing+            -- Show details if Opt_D_dump_simpl_iterations is on++    hdr = "Simplifier iteration=" ++ show iteration_no+    pp_counts = vcat [ text "---- Simplifier counts for" <+> text hdr+                     , pprSimplCount counts+                     , text "---- End of simplifier counts for" <+> text hdr ]++{-+************************************************************************+*                                                                      *+                Shorting out indirections+*                                                                      *+************************************************************************++If we have this:++        x_local = <expression>+        ...bindings...+        x_exported = x_local++where x_exported is exported, and x_local is not, then we replace it with this:++        x_exported = <expression>+        x_local = x_exported+        ...bindings...++Without this we never get rid of the x_exported = x_local thing.  This+save a gratuitous jump (from \tr{x_exported} to \tr{x_local}), and+makes strictness information propagate better.  This used to happen in+the final phase, but it's tidier to do it here.++Note [Messing up the exported Id's RULES]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We must be careful about discarding (obviously) or even merging the+RULES on the exported Id. The example that went bad on me at one stage+was this one:++    iterate :: (a -> a) -> a -> [a]+        [Exported]+    iterate = iterateList++    iterateFB c f x = x `c` iterateFB c f (f x)+    iterateList f x =  x : iterateList f (f x)+        [Not exported]++    {-# RULES+    "iterate"   forall f x.     iterate f x = build (\c _n -> iterateFB c f x)+    "iterateFB"                 iterateFB (:) = iterateList+     #-}++This got shorted out to:++    iterateList :: (a -> a) -> a -> [a]+    iterateList = iterate++    iterateFB c f x = x `c` iterateFB c f (f x)+    iterate f x =  x : iterate f (f x)++    {-# RULES+    "iterate"   forall f x.     iterate f x = build (\c _n -> iterateFB c f x)+    "iterateFB"                 iterateFB (:) = iterate+     #-}++And now we get an infinite loop in the rule system+        iterate f x -> build (\cn -> iterateFB c f x)+                    -> iterateFB (:) f x+                    -> iterate f x++Old "solution":+        use rule switching-off pragmas to get rid+        of iterateList in the first place++But in principle the user *might* want rules that only apply to the Id+they say.  And inline pragmas are similar+   {-# NOINLINE f #-}+   f = local+   local = <stuff>+Then we do not want to get rid of the NOINLINE.++Hence hasShortableIdinfo.+++Note [Rules and indirection-zapping]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Problem: what if x_exported has a RULE that mentions something in ...bindings...?+Then the things mentioned can be out of scope!  Solution+ a) Make sure that in this pass the usage-info from x_exported is+        available for ...bindings...+ b) If there are any such RULES, rec-ify the entire top-level.+    It'll get sorted out next time round++Other remarks+~~~~~~~~~~~~~+If more than one exported thing is equal to a local thing (i.e., the+local thing really is shared), then we do one only:+\begin{verbatim}+        x_local = ....+        x_exported1 = x_local+        x_exported2 = x_local+==>+        x_exported1 = ....++        x_exported2 = x_exported1+\end{verbatim}++We rely on prior eta reduction to simplify things like+\begin{verbatim}+        x_exported = /\ tyvars -> x_local tyvars+==>+        x_exported = x_local+\end{verbatim}+Hence,there's a possibility of leaving unchanged something like this:+\begin{verbatim}+        x_local = ....+        x_exported1 = x_local Int+\end{verbatim}+By the time we've thrown away the types in STG land this+could be eliminated.  But I don't think it's very common+and it's dangerous to do this fiddling in STG land+because we might eliminate a binding that's mentioned in the+unfolding for something.++Note [Indirection zapping and ticks]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Unfortunately this is another place where we need a special case for+ticks. The following happens quite regularly:++        x_local = <expression>+        x_exported = tick<x> x_local++Which we want to become:++        x_exported =  tick<x> <expression>++As it makes no sense to keep the tick and the expression on separate+bindings. Note however that this might increase the ticks scoping+over the execution of x_local, so we can only do this for floatable+ticks. More often than not, other references will be unfoldings of+x_exported, and therefore carry the tick anyway.+-}++type IndEnv = IdEnv (Id, [CoreTickish]) -- Maps local_id -> exported_id, ticks++shortOutIndirections :: CoreProgram -> CoreProgram+shortOutIndirections binds+  | isEmptyVarEnv ind_env = binds+  | no_need_to_flatten    = binds'                      -- See Note [Rules and indirection-zapping]+  | otherwise             = [Rec (flattenBinds binds')] -- for this no_need_to_flatten stuff+  where+    ind_env            = makeIndEnv binds+    -- These exported Ids are the subjects  of the indirection-elimination+    exp_ids            = map fst $ nonDetEltsUFM ind_env+      -- It's OK to use nonDetEltsUFM here because we forget the ordering+      -- by immediately converting to a set or check if all the elements+      -- satisfy a predicate.+    exp_id_set         = mkVarSet exp_ids+    no_need_to_flatten = all (null . ruleInfoRules . idSpecialisation) exp_ids+    binds'             = concatMap zap binds++    zap (NonRec bndr rhs) = [NonRec b r | (b,r) <- zapPair (bndr,rhs)]+    zap (Rec pairs)       = [Rec (concatMap zapPair pairs)]++    zapPair (bndr, rhs)+        | bndr `elemVarSet` exp_id_set+        = []   -- Kill the exported-id binding++        | Just (exp_id, ticks) <- lookupVarEnv ind_env bndr+        , (exp_id', lcl_id') <- transferIdInfo exp_id bndr+        =      -- Turn a local-id binding into two bindings+               --    exp_id = rhs; lcl_id = exp_id+          [ (exp_id', mkTicks ticks rhs),+            (lcl_id', Var exp_id') ]++        | otherwise+        = [(bndr,rhs)]++makeIndEnv :: [CoreBind] -> IndEnv+makeIndEnv binds+  = foldl' add_bind emptyVarEnv binds+  where+    add_bind :: IndEnv -> CoreBind -> IndEnv+    add_bind env (NonRec exported_id rhs) = add_pair env (exported_id, rhs)+    add_bind env (Rec pairs)              = foldl' add_pair env pairs++    add_pair :: IndEnv -> (Id,CoreExpr) -> IndEnv+    add_pair env (exported_id, exported)+        | (ticks, Var local_id) <- stripTicksTop tickishFloatable exported+        , shortMeOut env exported_id local_id+        = extendVarEnv env local_id (exported_id, ticks)+    add_pair env _ = env++shortMeOut :: IndEnv -> Id -> Id -> Bool+shortMeOut ind_env exported_id local_id+-- The if-then-else stuff is just so I can get a pprTrace to see+-- how often I don't get shorting out because of IdInfo stuff+  = if isExportedId exported_id &&              -- Only if this is exported++       isLocalId local_id &&                    -- Only if this one is defined in this+                                                --      module, so that we *can* change its+                                                --      binding to be the exported thing!++       not (isExportedId local_id) &&           -- Only if this one is not itself exported,+                                                --      since the transformation will nuke it++       not (local_id `elemVarEnv` ind_env)      -- Only if not already substituted for+    then+        if hasShortableIdInfo exported_id+        then True       -- See Note [Messing up the exported Id's RULES]+        else warnPprTrace True "Not shorting out" (ppr exported_id) False+    else+        False++hasShortableIdInfo :: Id -> Bool+-- True if there is no user-attached IdInfo on exported_id,+-- so we can safely discard it+-- See Note [Messing up the exported Id's RULES]+hasShortableIdInfo id+  =  isEmptyRuleInfo (ruleInfo info)+  && isDefaultInlinePragma (inlinePragInfo info)+  && not (isStableUnfolding (realUnfoldingInfo info))+  where+     info = idInfo id++{- Note [Transferring IdInfo]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we have+     lcl_id = e; exp_id = lcl_id++and lcl_id has useful IdInfo, we don't want to discard it by going+     gbl_id = e; lcl_id = gbl_id++Instead, transfer IdInfo from lcl_id to exp_id, specifically+* (Stable) unfolding+* Strictness+* Rules+* Inline pragma++Overwriting, rather than merging, seems to work ok.++For the lcl_id we++* Zap the InlinePragma. It might originally have had a NOINLINE, which+  we have now transferred; and we really want the lcl_id to inline now+  that its RHS is trivial!++* Zap any Stable unfolding.  agian, we want lcl_id = gbl_id to inline,+  replacing lcl_id by gbl_id. That won't happen if lcl_id has its original+  great big Stable unfolding+-}++transferIdInfo :: Id -> Id -> (Id, Id)+-- See Note [Transferring IdInfo]+transferIdInfo exported_id local_id+  = ( modifyIdInfo transfer exported_id+    , modifyIdInfo zap_info local_id )+  where+    local_info = idInfo local_id+    transfer exp_info = exp_info `setDmdSigInfo`     dmdSigInfo local_info+                                 `setCprSigInfo`     cprSigInfo local_info+                                 `setUnfoldingInfo`  realUnfoldingInfo local_info+                                 `setInlinePragInfo` inlinePragInfo local_info+                                 `setRuleInfo`       addRuleInfo (ruleInfo exp_info) new_info+    new_info = setRuleInfoHead (idName exported_id)+                               (ruleInfo local_info)+        -- Remember to set the function-name field of the+        -- rules as we transfer them from one function to another++    zap_info lcl_info = lcl_info `setInlinePragInfo` defaultInlinePragma+                                 `setUnfoldingInfo`  noUnfolding
GHC/Core/Opt/Simplify/Env.hs view
@@ -8,34 +8,42 @@  module GHC.Core.Opt.Simplify.Env (         -- * The simplifier mode-        setMode, getMode, updMode, seDynFlags, seUnfoldingOpts, seLogger,+        SimplMode(..), updMode, smPlatform,          -- * Environments         SimplEnv(..), pprSimplEnv,   -- Temp not abstract-        mkSimplEnv, extendIdSubst,+        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,+        getSimplRules, enterRecGroupRHSs,+        reSimplifying, +        SimplEnvIS,  checkSimplEnvIS, pprBadSimplEnvIS,+         -- * Substitution results-        SimplSR(..), mkContEx, substId, lookupRecBndr, refineFromInScope,+        SimplSR(..), mkContEx, substId, lookupRecBndr,          -- * Simplifying 'Id' binders         simplNonRecBndr, simplNonRecJoinBndr, simplRecBndrs, simplRecJoinBndrs,         simplBinder, simplBinders,-        substTy, substTyVar, getTCvSubst,+        substTy, substTyVar, getFullSubst, getTCvSubst,         substCo, substCoVar,          -- * Floats         SimplFloats(..), emptyFloats, isEmptyFloats, mkRecFloats,         mkFloatBind, addLetFloats, addJoinFloats, addFloats,         extendFloats, wrapFloats,+        isEmptyJoinFloats, isEmptyLetFloats,         doFloatFromRhs, getTopFloatBinds,          -- * LetFloats-        LetFloats, letFloatBinds, emptyLetFloats, unitLetFloat,+        LetFloats, FloatEnable(..), letFloatBinds, emptyLetFloats, unitLetFloat,         addLetFlts,  mapLetFloats,          -- * JoinFloats@@ -45,35 +53,43 @@  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.Opt.Monad        ( SimplMode(..) )+import GHC.Core.Rules.Config ( RuleOpts(..) ) import GHC.Core import GHC.Core.Utils-import GHC.Core.Multiplicity     ( scaleScaled )+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.Data.OrdList import GHC.Types.Id as Id-import GHC.Core.Make            ( mkWildValBinder )-import GHC.Driver.Session       ( DynFlags )-import GHC.Builtin.Types-import GHC.Core.TyCo.Rep        ( TyCoBinder(..) )-import qualified GHC.Core.Type as Type-import GHC.Core.Type hiding     ( substTy, substTyVar, substTyVarBndr, extendTvSubst, extendCvSubst )-import qualified GHC.Core.Coercion as Coercion-import GHC.Core.Coercion hiding ( substCo, substCoVar, substCoVarBndr ) 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.Panic.Plain import GHC.Utils.Misc-import GHC.Utils.Logger-import GHC.Types.Unique.FM      ( pprUniqFM ) -import Data.List (mapAccumL)+import Data.List ( intersperse, mapAccumL )  {- ************************************************************************@@ -83,19 +99,96 @@ ************************************************************************ -} +{-+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@@ -104,9 +197,151 @@         -- They are all OutVars, and all bound in this module       , seInScope   :: !InScopeSet       -- OutVars only -      , seCaseDepth :: !Int  -- Depth of multi-branch case alternatives+      , 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@@ -162,11 +397,11 @@              | otherwise = ppr v  type SimplIdSubst = IdEnv SimplSR -- IdId |--> OutExpr-        -- See Note [Extending the Subst] in GHC.Core.Subst+        -- See Note [Extending the IdSubstEnv] in GHC.Core.Subst  -- | A substitution result. data SimplSR-  = DoneEx OutExpr (Maybe JoinArity)+  = 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@@ -191,8 +426,8 @@   ppr (DoneEx e mj) = text "DoneEx" <> pp_mj <+> ppr e     where       pp_mj = case mj of-                Nothing -> empty-                Just n  -> parens (int n)+                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) -}]@@ -261,7 +496,7 @@   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+  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@@ -279,18 +514,21 @@ so that we know to drop the context. Thus we remember which join points we're substituting. -} -mkSimplEnv :: SimplMode -> SimplEnv-mkSimplEnv mode-  = SimplEnv { seMode      = mode-             , seInScope   = init_in_scope-             , seTvSubst   = emptyVarEnv-             , seCvSubst   = emptyVarEnv-             , seIdSubst   = emptyVarEnv-             , seCaseDepth = 0 }+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 Many unitTy))+init_in_scope = mkInScopeSet (unitVarSet (mkWildValBinder ManyTy unitTy))               -- See Note [WildCard binders]  {-@@ -313,23 +551,6 @@ It's a very dark corner of GHC.  Maybe it should be cleaned up. -} -getMode :: SimplEnv -> SimplMode-getMode env = seMode env--seDynFlags :: SimplEnv -> DynFlags-seDynFlags env = sm_dflags (seMode env)--seLogger :: SimplEnv -> Logger-seLogger env = sm_logger (seMode env)---seUnfoldingOpts :: SimplEnv -> UnfoldingOpts-seUnfoldingOpts env = sm_uf_opts (seMode env)---setMode :: SimplMode -> SimplEnv -> SimplEnv-setMode mode env = env { seMode = mode }- updMode :: (SimplMode -> SimplMode) -> SimplEnv -> SimplEnv updMode upd env   = -- Avoid keeping env alive in case inlining fails.@@ -339,6 +560,9 @@ 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@@ -355,6 +579,10 @@   = 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@@ -391,6 +619,13 @@ 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@@ -417,7 +652,12 @@  --------------------- zapSubstEnv :: SimplEnv -> SimplEnv-zapSubstEnv env = env {seTvSubst = emptyVarEnv, seCvSubst = emptyVarEnv, seIdSubst = emptyVarEnv}+-- 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 }@@ -436,7 +676,8 @@ ~~~~~~~~~~~~~~~~ The LetFloats is a bunch of bindings, classified by a FloatFlag. -* All of them satisfy the let/app invariant+The `FloatFlag` contains summary information about the bindings, see the data+type declaration of `FloatFlag`  Examples @@ -447,10 +688,8 @@   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+  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@@ -462,19 +701,22 @@ 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+                -- 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)+                -- 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+                -- 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)@@ -490,10 +732,14 @@ andFF FltOkSpec  _          = FltOkSpec andFF FltLifted  flt        = flt -doFloatFromRhs :: TopLevelFlag -> RecFlag -> Bool -> SimplFloats -> OutExpr -> Bool--- If you change this function look also at FloatIn.noFloatFromRhs-doFloatFromRhs lvl rec strict_bind (SimplFloats { sfLetFloats = LetFloats fs ff }) rhs-  =  not (isNilOL fs) && want_to_float && can_float++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]@@ -502,6 +748,12 @@                    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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -517,9 +769,15 @@ 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)) $@@ -532,11 +790,7 @@           -- 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                = assertPpr (not (isUnliftedType (idType bndr))) (ppr bndr)-                                   -- NB: binders always have a fixed RuntimeRep, so calling-                                   -- isUnliftedType is OK here-                                   FltCareful-      -- Unlifted binders can only be let-bound if exprOkForSpeculation holds+      | otherwise                = FltCareful  unitJoinFloat :: OutBind -> JoinFloats unitJoinFloat bind = assert (all isJoinId (bindersOf bind)) $@@ -599,10 +853,6 @@            , sfInScope    = foldlOL extendInScopeSetBind                                     (sfInScope floats) join_floats } -extendInScopeSetBind :: InScopeSet -> CoreBind -> InScopeSet-extendInScopeSetBind in_scope bind-  = extendInScopeSetList in_scope (bindersOf bind)- 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@@ -641,13 +891,15 @@               | otherwise   = unitJoinFloat (Rec (flattenBinds (fromOL jbs)))  wrapFloats :: SimplFloats -> 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 (SimplFloats { sfLetFloats  = LetFloats bs _+-- Wrap the floats around the expression+wrapFloats (SimplFloats { sfLetFloats  = LetFloats bs flag                         , sfJoinFloats = jbs }) body-  = foldrOL Let (wrapJoinFloats jbs body) bs+  = 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,@@ -801,7 +1053,6 @@     do  { let (!env1, ids1) = mapAccumL substIdBndr env ids         ; seqIds ids1 `seq` return env1 } - --------------- substIdBndr :: SimplEnv -> InBndr -> (SimplEnv, OutBndr) -- Might be a coercion variable@@ -855,7 +1106,7 @@     -- See Note [Bangs in the Simplifier]     !id1  = uniqAway in_scope old_id     !id2  = substIdType env id1-    !id3  = zapFragileIdInfo id2       -- Zaps rules, worker-info, unfolding+    !id3  = zapFragileIdInfo id2      -- Zaps rules, worker-info, unfolding                                       -- and fragile OccInfo     !new_id = adjust_type id3 @@ -886,31 +1137,18 @@ Note [Arity robustness] ~~~~~~~~~~~~~~~~~~~~~~~ We *do* transfer the arity 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.+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] ~~~~~~~~~~~~~~~~~~~~~@@ -959,7 +1197,7 @@ adjustJoinPointType :: Mult                     -> Type     -- New result type                     -> Id       -- Old join-point Id-                    -> Id       -- Adjusted jont-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@@ -974,22 +1212,35 @@   = assert (isJoinId join_id) $     setIdType join_id new_join_ty   where-    orig_ar = idJoinArity join_id-    orig_ty = idType join_id+    join_arity = idJoinArity join_id+    orig_ty    = idType join_id+    res_torc   = typeTypeOrConstraint new_res_ty :: TypeOrConstraint -    new_join_ty = go orig_ar orig_ty :: Type+    new_join_ty = go join_arity orig_ty :: Type -    go 0 _  = new_res_ty-    go n ty | Just (arg_bndr, res_ty) <- splitPiTy_maybe ty-            = mkPiTy (scale_bndr arg_bndr) $-              go (n-1) res_ty-            | otherwise-            = pprPanic "adjustJoinPointType" (ppr orig_ar <+> ppr orig_ty)+    go :: JoinArity -> Type -> Type+    go n ty+      | n == 0+      = new_res_ty -    -- See Note [Bangs in the Simplifier]-    scale_bndr (Anon af t) = Anon af $! (scaleScaled mult t)-    scale_bndr b@(Named _) = b+      | 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:@@ -1023,12 +1274,25 @@ ************************************************************************ -} -getTCvSubst :: SimplEnv -> TCvSubst-getTCvSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env-                      , seCvSubst = cv_env })-  = mkTCvSubst in_scope (tv_env, cv_env)+getTCvSubst :: SimplEnv -> Subst+getTCvSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seCvSubst = cv_env })+  = mkSubst in_scope emptyVarEnv tv_env cv_env -substTy :: SimplEnv -> Type -> Type+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@@ -1037,7 +1301,7 @@ substTyVarBndr :: SimplEnv -> TyVar -> (SimplEnv, TyVar) substTyVarBndr env tv   = case Type.substTyVarBndr (getTCvSubst env) tv of-        (TCvSubst in_scope' tv_env' cv_env', tv')+        (Subst in_scope' _ tv_env' cv_env', tv')            -> (env { seInScope = in_scope', seTvSubst = tv_env', seCvSubst = cv_env' }, tv')  substCoVar :: SimplEnv -> CoVar -> Coercion@@ -1046,7 +1310,7 @@ substCoVarBndr :: SimplEnv -> CoVar -> (SimplEnv, CoVar) substCoVarBndr env cv   = case Coercion.substCoVarBndr (getTCvSubst env) cv of-        (TCvSubst in_scope' tv_env' cv_env', cv')+        (Subst in_scope' _ tv_env' cv_env', cv')            -> (env { seInScope = in_scope', seTvSubst = tv_env', seCvSubst = cv_env' }, cv')  substCo :: SimplEnv -> Coercion -> Coercion@@ -1064,6 +1328,6 @@                 -- in a Note in the id's type itself   where     no_free_vars = noFreeVarsOfType old_ty && noFreeVarsOfType old_w-    subst = TCvSubst in_scope tv_env cv_env+    subst = Subst in_scope emptyIdSubstEnv tv_env cv_env     old_ty = idType id-    old_w  = varMult id+    old_w  = idMult id
+ GHC/Core/Opt/Simplify/Inline.hs view
@@ -0,0 +1,751 @@+{-+(c) The University of Glasgow 2006+(c) The AQUA Project, Glasgow University, 1994-1998++This module contains inlining logic used by the simplifier.+-}++++module GHC.Core.Opt.Simplify.Inline (+        -- * Cheap and cheerful inlining checks.+        couldBeSmallEnoughToInline,+        smallEnoughToInline, activeUnfolding,++        -- * The smart inlining decisions are made by callSiteInline+        callSiteInline, CallCtxt(..),+    ) where++import GHC.Prelude++import GHC.Driver.Flags++import GHC.Core.Opt.Simplify.Env++import GHC.Core+import GHC.Core.Unfold+import GHC.Core.FVs( exprFreeIds )++import GHC.Types.Id+import GHC.Types.Var.Env( InScopeSet, lookupInScope )+import GHC.Types.Var.Set+import GHC.Types.Basic  ( Arity, RecFlag(..), isActive )+import GHC.Utils.Logger+import GHC.Utils.Misc+import GHC.Utils.Outputable+import GHC.Types.Name++import Data.List (isPrefixOf)++{-+************************************************************************+*                                                                      *+\subsection[considerUnfolding]{Given all the info, do (not) do the unfolding}+*                                                                      *+************************************************************************++We use 'couldBeSmallEnoughToInline' to avoid exporting inlinings that+we ``couldn't possibly use'' on the other side.  Can be overridden w/+flaggery.  Just the same as smallEnoughToInline, except that it has no+actual arguments.+-}++couldBeSmallEnoughToInline :: UnfoldingOpts -> Int -> CoreExpr -> Bool+couldBeSmallEnoughToInline opts threshold rhs+  = case sizeExpr opts threshold [] body of+       TooBig -> False+       _      -> True+  where+    (_, body) = collectBinders rhs++----------------+smallEnoughToInline :: UnfoldingOpts -> Unfolding -> Bool+smallEnoughToInline opts (CoreUnfolding {uf_guidance = guidance})+  = case guidance of+       UnfIfGoodArgs {ug_size = size} -> size <= unfoldingUseThreshold opts+       UnfWhen {} -> True+       UnfNever   -> False+smallEnoughToInline _ _+  = False++{-+************************************************************************+*                                                                      *+\subsection{callSiteInline}+*                                                                      *+************************************************************************++This is the key function.  It decides whether to inline a variable at a call site++callSiteInline is used at call sites, so it is a bit more generous.+It's a very important function that embodies lots of heuristics.+A non-WHNF can be inlined if it doesn't occur inside a lambda,+and occurs exactly once or+    occurs once in each branch of a case and is small++If the thing is in WHNF, there's no danger of duplicating work,+so we can inline if it occurs once, or is small++NOTE: we don't want to inline top-level functions that always diverge.+It just makes the code bigger.  Tt turns out that the convenient way to prevent+them inlining is to give them a NOINLINE pragma, which we do in+StrictAnal.addStrictnessInfoToTopId+-}++callSiteInline :: SimplEnv+               -> Logger+               -> Id                    -- The Id+               -> Bool                  -- True if there are no arguments at all (incl type args)+               -> [ArgSummary]          -- One for each value arg; True if it is interesting+               -> CallCtxt              -- True <=> continuation is interesting+               -> Maybe CoreExpr        -- Unfolding, if any+callSiteInline env logger id lone_variable arg_infos cont_info+  = case idUnfolding id of+      -- idUnfolding checks for loop-breakers, returning NoUnfolding+      -- Things with an INLINE pragma may have an unfolding *and*+      -- be a loop breaker  (maybe the knot is not yet untied)+        CoreUnfolding { uf_tmpl = unf_template+                      , uf_cache = unf_cache+                      , uf_guidance = guidance }+          | active_unf -> tryUnfolding env logger id lone_variable+                                    arg_infos cont_info unf_template+                                    unf_cache guidance+          | otherwise -> traceInline logger uf_opts id "Inactive unfolding:" (ppr id) Nothing+        NoUnfolding      -> Nothing+        BootUnfolding    -> Nothing+        OtherCon {}      -> Nothing+        DFunUnfolding {} -> Nothing     -- Never unfold a DFun+  where+    uf_opts    = seUnfoldingOpts env+    active_unf = activeUnfolding (seMode env) id++activeUnfolding :: SimplMode -> Id -> Bool+activeUnfolding mode id+  | isCompulsoryUnfolding (realIdUnfolding id)+  = True   -- Even sm_inline can't override compulsory unfoldings+  | otherwise+  = isActive (sm_phase mode) (idInlineActivation id)+  && sm_inline mode+      -- `or` isStableUnfolding (realIdUnfolding id)+      -- Inline things when+      --  (a) they are active+      --  (b) sm_inline says so, except that for stable unfoldings+      --                         (ie pragmas) we inline anyway++-- | Report the inlining of an identifier's RHS to the user, if requested.+traceInline :: Logger -> UnfoldingOpts -> Id -> String -> SDoc -> a -> a+traceInline logger opts inline_id str doc result+  -- We take care to ensure that doc is used in only one branch, ensuring that+  -- the simplifier can push its allocation into the branch. See Note [INLINE+  -- conditional tracing utilities].+  | enable    = logTraceMsg logger str doc result+  | otherwise = result+  where+    enable+      | logHasDumpFlag logger Opt_D_dump_verbose_inlinings+      = True+      | Just prefix <- unfoldingReportPrefix opts+      = prefix `isPrefixOf` occNameString (getOccName inline_id)+      | otherwise+      = False+{-# INLINE traceInline #-} -- see Note [INLINE conditional tracing utilities]++{- Note [Avoid inlining into deeply nested cases]+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Also called "exponential inlining".++Consider a function f like this: (#18730)++  f arg1 arg2 =+    case ...+      ... -> g arg1+      ... -> g arg2++This function is small. So should be safe to inline.+However sometimes this doesn't quite work out like that.+Consider this code:++    f1 arg1 arg2 ... = ...+        case _foo of+          alt1 -> ... f2 arg1 ...+          alt2 -> ... f2 arg2 ...++    f2 arg1 arg2 ... = ...+        case _foo of+          alt1 -> ... f3 arg1 ...+          alt2 -> ... f3 arg2 ...++    f3 arg1 arg2 ... = ...++    ... repeats up to n times. And then f1 is+    applied to some arguments:++    foo = ... f1 <interestingArgs> ...++Initially f2..fn are not interesting to inline so we don't.  However we see+that f1 is applied to interesting args.  So it's an obvious choice to inline+those:++    foo = ...+          case _foo of+            alt1 -> ... f2 <interestingArg> ...+            alt2 -> ... f2 <interestingArg> ...++As a result we go and inline f2 both mentions of f2 in turn are now applied to+interesting arguments and f2 is small:++    foo = ...+          case _foo of+            alt1 -> ... case _foo of+                alt1 -> ... f3 <interestingArg> ...+                alt2 -> ... f3 <interestingArg> ...++            alt2 -> ... case _foo of+                alt1 -> ... f3 <interestingArg> ...+                alt2 -> ... f3 <interestingArg> ...++The same thing happens for each binding up to f_n, duplicating the amount of inlining+done in each step. Until at some point we are either done or run out of simplifier+ticks/RAM. This pattern happened #18730.++To combat this we introduce one more heuristic when weighing inlining decision.+We keep track of a "case-depth". Which increases each time we look inside a case+expression with more than one alternative.++We then apply a penalty to inlinings based on the case-depth at which they would+be inlined. Bounding the number of inlinings in such a scenario.++The heuristic can be tuned in two ways:++* We can ignore the first n levels of case nestings for inlining decisions using+  -funfolding-case-threshold.++* The penalty grows linear with the depth. It's computed as+     size*(depth-threshold)/scaling.+  Scaling can be set with -funfolding-case-scaling.++Reflections and wrinkles++* See also Note [Do not add unfoldings to join points at birth] in+  GHC.Core.Opt.Simplify.Iteration++* The total case depth is really the wrong thing; it will inhibit inlining of a+  local function, just because there is some giant case nest further out.  What we+  want is the /difference/ in case-depth between the binding site and the call site.+  That could be done quite easily by adding the case-depth to the Unfolding of the+  function.++* What matters more than /depth/ is total /width/; that is how many alternatives+  are in the tree.  We could perhaps multiply depth by width at each case expression.++* There might be a case nest with many alternatives, but the function is called in+  only a handful of them.  So maybe we should ignore case-depth, and instead penalise+  funtions that are called many times -- after all, inlining them bloats code.++  But in the scenario above, we are simplifying an inlined fuction, without doing a+  global occurrence analysis each time.  So if we based the penalty on multiple+  occurences, we should /also/ add a penalty when simplifying an already-simplified+  expression.  We do track this (seInlineDepth) but currently we barely use it.++  An advantage of using occurrences+inline depth is that it'll work when no+  case expressions are involved.  See #15488.++* Test T18730 did not involve join points.  But join points are very prone to+  the same kind of thing.  For exampe in #13253, and several related tickets,+  we got an exponential blowup in code size from a program that looks like+  this.++  let j1a x = case f y     of { True -> p;   False -> q }+      j1b x = case f y     of { True -> q;   False -> p }+      j2a x = case f (y+1) of { True -> j1a x; False -> j1b x}+      j2b x = case f (y+1) of { True -> j1b x; False -> j1a x}+      ...+  in case f (y+10) of { True -> j10a 7; False -> j10b 8 }++  The first danger is this: in Simplifier iteration 1 postInlineUnconditionally+  inlines the last functions, j10a and j10b (they are both small).  Now we have+  two calls to j9a and two to j9b.  In the next Simplifer iteration,+  postInlineUnconditionally inlines all four of these calls, leaving four calls+  to j8a and j8b. Etc.++  Happily, this probably /won't/ happen because the Simplifier works top down, so it'll+  inline j1a/j1b into j2a/j2b, which will make the latter bigger; so the process+  will stop.  But we still need to stop the inline cascade described at the head+  of this Note.++Some guidance on setting these defaults:++* A low threshold (<= 2) is needed to prevent exponential cases from spiraling out of+  control. We picked 2 for no particular reason.++* Scaling the penalty by any more than 30 means the reproducer from+  T18730 won't compile even with reasonably small values of n. Instead+  it will run out of runs/ticks. This means to positively affect the reproducer+  a scaling <= 30 is required.++* A scaling of >= 15 still causes a few very large regressions on some nofib benchmarks.+  (+80% for gc/fulsom, +90% for real/ben-raytrace, +20% for spectral/fibheaps)++* A scaling of >= 25 showed no regressions on nofib. However it showed a number of+  (small) regression for compiler perf benchmarks.++The end result is that we are settling for a scaling of 30, with a threshold of 2.+This gives us minimal compiler perf regressions. No nofib runtime regressions and+will still avoid this pattern sometimes. This is a "safe" default, where we err on+the side of compiler blowup instead of risking runtime regressions.++For cases where the default falls short the flag can be changed to allow+more/less inlining as needed on a per-module basis.++-}++tryUnfolding :: SimplEnv -> Logger -> Id -> Bool -> [ArgSummary] -> CallCtxt+             -> CoreExpr -> UnfoldingCache -> UnfoldingGuidance+             -> Maybe CoreExpr+tryUnfolding env logger id lone_variable arg_infos+             cont_info unf_template unf_cache guidance+ = case guidance of+     UnfNever -> traceInline logger opts id str (text "UnfNever") Nothing++     UnfWhen { ug_arity = uf_arity, ug_unsat_ok = unsat_ok, ug_boring_ok = boring_ok }+        | enough_args && (boring_ok || some_benefit || unfoldingVeryAggressive opts)+                -- See Note [INLINE for small functions] (3)+        -> traceInline logger opts id str (mk_doc some_benefit empty True) (Just unf_template)+        | otherwise+        -> traceInline logger opts id str (mk_doc some_benefit empty False) Nothing+        where+          some_benefit = calc_some_benefit uf_arity True+          enough_args  = (n_val_args >= uf_arity) || (unsat_ok && n_val_args > 0)++     UnfIfGoodArgs { ug_args = arg_discounts, ug_res = res_discount, ug_size = size }+        | isJoinId id, small_enough         -> inline_join_point+        | unfoldingVeryAggressive opts      -> yes+        | is_wf, some_benefit, small_enough -> yes+        | otherwise                         -> no+        where+          yes = traceInline logger opts id str (mk_doc some_benefit extra_doc True)  (Just unf_template)+          no  = traceInline logger opts id str (mk_doc some_benefit extra_doc False) Nothing++          some_benefit = calc_some_benefit (length arg_discounts) False++          -- depth_penalty: see Note [Avoid inlining into deeply nested cases]+          depth_threshold = unfoldingCaseThreshold opts+          depth_scaling   = unfoldingCaseScaling opts+          depth_penalty | case_depth <= depth_threshold = 0+                        | otherwise = (size * (case_depth - depth_threshold)) `div` depth_scaling++          adjusted_size = size + depth_penalty - discount+          small_enough = adjusted_size <= unfoldingUseThreshold opts+          discount = computeDiscount arg_discounts res_discount arg_infos cont_info++          extra_doc = vcat [ ppWhen (isJoinId id) $+                             text "join" <+> fsep [ ppr (v, hasCoreUnfolding (idUnfolding v)+                                                        , fmap (isEvaldUnfolding . idUnfolding) (lookupInScope in_scope v)+                                                        , is_more_evald in_scope v)+                                                  | v <- vselems (exprFreeIds unf_template) ]+                           , text "depth based penalty =" <+> int depth_penalty+                           , text "adjusted size =" <+> int adjusted_size ]++          inline_join_point  -- See Note [Inlining join points]+            | or (zipWith scrut_arg arg_discounts arg_infos) = yes+            | anyVarSet (is_more_evald in_scope) $+              exprFreeIds unf_template                       = yes+            | otherwise                                      = no+          -- scrut_arg is True if the function body has a discount and the arg is a value+          scrut_arg disc ValueArg = disc > 0+          scrut_arg _    _        = False++  where+    opts         = seUnfoldingOpts env+    case_depth   = seCaseDepth env+    inline_depth = seInlineDepth env+    in_scope     = seInScope env++    -- Unpack the UnfoldingCache lazily because it may not be needed, and all+    -- its fields are strict; so evaluating unf_cache at all forces all the+    -- isWorkFree etc computations to take place.  That risks wasting effort for+    -- Ids that are never going to inline anyway.+    -- See Note [UnfoldingCache] in GHC.Core+    UnfoldingCache{ uf_is_work_free = is_wf, uf_expandable = is_exp } = unf_cache++    mk_doc some_benefit extra_doc yes_or_no+      = vcat [ text "arg infos" <+> ppr arg_infos+             , text "interesting continuation" <+> ppr cont_info+             , text "some_benefit" <+> ppr some_benefit+             , text "is exp:" <+> ppr is_exp+             , text "is work-free:" <+> ppr is_wf+             , text "guidance" <+> ppr guidance+             , text "case depth =" <+> int case_depth+             , text "inline depth =" <+> int inline_depth+             , extra_doc+             , text "ANSWER =" <+> if yes_or_no then text "YES" else text "NO"]++    ctx = log_default_dump_context (logFlags logger)+    str = "Considering inlining: " ++ showSDocOneLine ctx (ppr id)+    n_val_args = length arg_infos++           -- some_benefit is used when the RHS is small enough+           -- and the call has enough (or too many) value+           -- arguments (ie n_val_args >= arity). But there must+           -- be *something* interesting about some argument, or the+           -- result context, to make it worth inlining+    calc_some_benefit :: Arity -> Bool -> Bool   -- The Arity is the number of args+                                         -- expected by the unfolding+    calc_some_benefit uf_arity is_inline+       | not saturated = interesting_args       -- Under-saturated+                                        -- Note [Unsaturated applications]+       | otherwise = interesting_args   -- Saturated or over-saturated+                  || interesting_call+      where+        saturated      = n_val_args >= uf_arity+        over_saturated = n_val_args > uf_arity+        interesting_args = any nonTriv arg_infos+                -- NB: (any nonTriv arg_infos) looks at the+                -- over-saturated args too which is "wrong";+                -- but if over-saturated we inline anyway.++        interesting_call+          | over_saturated+          = True+          | otherwise+          = case cont_info of+              CaseCtxt   -> not (lone_variable && is_exp)  -- Note [Lone variables]+              ValAppCtxt -> True                           -- Note [Cast then apply]+              RuleArgCtxt -> uf_arity > 0  -- See Note [RHS of lets]+              DiscArgCtxt -> uf_arity > 0  -- Note [Inlining in ArgCtxt]+              RhsCtxt NonRecursive | is_inline+                          -> uf_arity > 0  -- See Note [RHS of lets]+              _other      -> False         -- See Note [Nested functions]+++vselems :: VarSet -> [Var]+vselems s = nonDetStrictFoldVarSet (\v vs -> v : vs) [] s++is_more_evald :: InScopeSet -> Id -> Bool+-- See Note [Inlining join points]+is_more_evald in_scope v+  | Just v1 <- lookupInScope in_scope v+  , idUnfolding v1 `isBetterUnfoldingThan` idUnfolding v+  = True+  | otherwise+  = False++{- Note [RHS of lets]+~~~~~~~~~~~~~~~~~~~~~+When the call is the argument of a function with a RULE, or the RHS of a let,+we are a little bit keener to inline (in tryUnfolding).  For example+     f y = (y,y,y)+     g y = let x = f y in ...(case x of (a,b,c) -> ...) ...+We'd inline 'f' if the call was in a case context, and it kind-of-is,+only we can't see it.  Also+     x = f v+could be expensive whereas+     x = case v of (a,b) -> a+is patently cheap and may allow more eta expansion.++So, in `interesting_call` in `tryUnfolding`, we treat the RHS of a+/non-recursive/ let as not-totally-boring.  A /recursive/ let isn't+going be inlined so there is much less point.  Hence the (only reason+for the) RecFlag in RhsCtxt++We inline only if `f` has an `UnfWhen` guidance.  I found that being more eager+led to fruitless inlining.  See Note [Seq is boring] wrinkle (SB1) in+GHC.Core.Opt.Simplify.Utils.++Note [Inlining join points]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+In general we /do not/ want to inline join points /even if they are small/.+See Note [Duplicating join points] in GHC.Core.Opt.Simplify.Iteration.++But, assuming it is small, there are various times when we /do/ want to+inline a (non-recursive) join point.  Namely, if either of these hold:++(1) A /scrutinised/ argument (non-zero discount) has a /ValueArg/ info.+    Inlining will give some benefit.++(2) A free variable of the RHS is+    * Is /not/ evaluated at the join point defn site+    * Is evaluated at the join point call site.+    This is the is_more_evald predicate.++(1) is fairly obvious but (2) is less so. Here is the code for `integerGT`+without (2):++  integerGt = \ (x :: Integer) (y :: Integer) ->+     join fail _ = case x of {+       IS x1 -> case y of {+           IS y1 -> case <# x1 y1  of+                      _DEFAULT -> case ==# x1 y1 of+                                    DEFAULT -> True;+                                    1#      -> False+                      1# -> False+           IP ds1 -> False+           IN ds1 -> True++       IP x1 -> case y of {+                 _DEFAULT -> True;+                 IP y1    -> case bigNatCompare x1 y1 of+                               _DEFAULT -> False;+                               GT -> True+       IN x1 -> case y of {+                  _DEFAULT -> False;+                  IN y1    -> case bigNatCompare y1 x1 of+                                _DEFAULT -> False;+                                GT -> True+     in case x of {+       _DEFAULT -> jump fail GHC.Prim.(##);+       IS x1    -> case y of {+                     _DEFAULT -> jump fail GHC.Prim.(##);+                     IS y1 -> tagToEnum# @Bool (># x1 y1)++If we inline `fail` we get /much/ better code.  The only clue is that+`x` and `y` (a) are not evaluated at the definition site, and (b) are+evaluated at the call site.  This predicate is `isBetterUnfoldingThan`.++You might think that the variable should also be /scrutinised/ in the+join-point RHS, but here are two reasons for not taking that into+account.++First, we see code somewhat like this in imaginary/wheel-sieve1:+    let x = <small thunk> in+    join $j = (x,y) in+    case z of+      A -> case x of+             P -> $j+             Q -> blah+      B -> (x,x)+      C -> True+Here `x` can't be duplicated into the branches becuase it is used+in both the join point and the A branch.  But if we inline $j we get+    let x = <small thunk> in+    case z of+      A -> case x of x'+             P -> (x', y)+             Q -> blah+      B -> x+      C -> True+and now we /can/ duplicate x into the branches, at which point:+  * it is used strictly in the A branch (evaluated, but no thunk)+  * it is used lazily in the B branch (still a thunk)+  * it is not used at all in the C branch (no thunk)++Second, spectral/treejoin gets a big win from SpecConstr due+to evaluated-ness. Something like this:+    join $j x = ...(foo fv)...+    in case fv of I# x ->+       ...  jump $j True ...+If we inline $j, SpecConstr sees a call (foo (I# x)) and specialises.++Note [Unsaturated applications]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When a call is not saturated, we *still* inline if one of the+arguments has interesting structure.  That's sometimes very important.+A good example is the Ord instance for Bool in Base:++ Rec {+    $fOrdBool =GHC.Classes.D:Ord+                 @ Bool+                 ...+                 $cmin_ajX++    $cmin_ajX [Occ=LoopBreaker] :: Bool -> Bool -> Bool+    $cmin_ajX = GHC.Classes.$dmmin @ Bool $fOrdBool+  }++But the defn of GHC.Classes.$dmmin is:++  $dmmin :: forall a. GHC.Classes.Ord a => a -> a -> a+    {- Arity: 3, HasNoCafRefs, Strictness: SLL,+       Unfolding: (\ @ a $dOrd :: GHC.Classes.Ord a x :: a y :: a ->+                   case @ a GHC.Classes.<= @ a $dOrd x y of wild {+                     GHC.Types.False -> y GHC.Types.True -> x }) -}++We *really* want to inline $dmmin, even though it has arity 3, in+order to unravel the recursion.+++Note [Things to watch]+~~~~~~~~~~~~~~~~~~~~~~+*   { y = I# 3; x = y `cast` co; ...case (x `cast` co) of ... }+    Assume x is exported, so not inlined unconditionally.+    Then we want x to inline unconditionally; no reason for it+    not to, and doing so avoids an indirection.++*   { x = I# 3; ....f x.... }+    Make sure that x does not inline unconditionally!+    Lest we get extra allocation.++Note [Nested functions]+~~~~~~~~~~~~~~~~~~~~~~~+At one time we treated a call of a non-top-level function as+"interesting" (regardless of how boring the context) in the hope+that inlining it would eliminate the binding, and its allocation.+Specifically, in the default case of interesting_call we had+   _other -> not is_top && uf_arity > 0++But actually postInlineUnconditionally does some of this and overall+it makes virtually no difference to nofib.  So I simplified away this+special case++Note [Cast then apply]+~~~~~~~~~~~~~~~~~~~~~~+Consider+   myIndex = __inline_me ( (/\a. <blah>) |> co )+   co :: (forall a. a -> a) ~ (forall a. T a)+     ... /\a.\x. case ((myIndex a) |> sym co) x of { ... } ...++We need to inline myIndex to unravel this; but the actual call (myIndex a) has+no value arguments.  The ValAppCtxt gives it enough incentive to inline.++Note [Inlining in ArgCtxt]+~~~~~~~~~~~~~~~~~~~~~~~~~~+The condition (arity > 0) here is very important, because otherwise+we end up inlining top-level stuff into useless places; eg+   x = I# 3#+   f = \y.  g x+This can make a very big difference: it adds 16% to nofib 'integer' allocs,+and 20% to 'power'.++At one stage I replaced this condition by 'True' (leading to the above+slow-down).  The motivation was test eyeball/inline1.hs; but that seems+to work ok now.++NOTE: arguably, we should inline in ArgCtxt only if the result of the+call is at least CONLIKE.  At least for the cases where we use ArgCtxt+for the RHS of a 'let', we only profit from the inlining if we get a+CONLIKE thing (modulo lets).++Note [Lone variables]+~~~~~~~~~~~~~~~~~~~~~+See also Note [Interaction of exprIsWorkFree and lone variables]+which appears below++The "lone-variable" case is important.  I spent ages messing about+with unsatisfactory variants, but this is nice.  The idea is that if a+variable appears all alone++        as an arg of lazy fn, or rhs    BoringCtxt+        as scrutinee of a case          CaseCtxt+        as arg of a fn                  ArgCtxt+AND+        it is bound to a cheap expression++then we should not inline it (unless there is some other reason,+e.g. it is the sole occurrence).  That is what is happening at+the use of 'lone_variable' in 'interesting_call'.++Why?  At least in the case-scrutinee situation, turning+        let x = (a,b) in case x of y -> ...+into+        let x = (a,b) in case (a,b) of y -> ...+and thence to+        let x = (a,b) in let y = (a,b) in ...+is bad if the binding for x will remain.++Another example: I discovered that strings+were getting inlined straight back into applications of 'error'+because the latter is strict.+        s = "foo"+        f = \x -> ...(error s)...++Fundamentally such contexts should not encourage inlining because, provided+the RHS is "expandable" (see Note [exprIsExpandable] in GHC.Core.Utils) the+context can ``see'' the unfolding of the variable (e.g. case or a+RULE) so there's no gain.++However, watch out:++ * Consider this:+        foo = \n. [n])  {-# INLINE foo #-}+        bar = foo 20    {-# INLINE bar #-}+        baz = \n. case bar of { (m:_) -> m + n }+   Here we really want to inline 'bar' so that we can inline 'foo'+   and the whole thing unravels as it should obviously do.  This is+   important: in the NDP project, 'bar' generates a closure data+   structure rather than a list.++   So the non-inlining of lone_variables should only apply if the+   unfolding is regarded as expandable; because that is when+   exprIsConApp_maybe looks through the unfolding.  Hence the "&&+   is_exp" in the CaseCtxt branch of interesting_call++ * Even a type application or coercion isn't a lone variable.+   Consider+        case $fMonadST @ RealWorld of { :DMonad a b c -> c }+   We had better inline that sucker!  The case won't see through it.++   For now, I'm treating treating a variable applied to types+   in a *lazy* context "lone". The motivating example was+        f = /\a. \x. BIG+        g = /\a. \y.  h (f a)+   There's no advantage in inlining f here, and perhaps+   a significant disadvantage.  Hence some_val_args in the Stop case++Note [Interaction of exprIsWorkFree and lone variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The lone-variable test says "don't inline if a case expression+scrutinises a lone variable whose unfolding is cheap".  It's very+important that, under these circumstances, exprIsConApp_maybe+can spot a constructor application. So, for example, we don't+consider+        let x = e in (x,x)+to be cheap, and that's good because exprIsConApp_maybe doesn't+think that expression is a constructor application.++In the 'not (lone_variable && is_wf)' test, I used to test is_value+rather than is_wf, which was utterly wrong, because the above+expression responds True to exprIsHNF, which is what sets is_value.++This kind of thing can occur if you have++        {-# INLINE foo #-}+        foo = let x = e in (x,x)++which Roman did.+++-}++computeDiscount :: [Int] -> Int -> [ArgSummary] -> CallCtxt+                -> Int+computeDiscount arg_discounts res_discount arg_infos cont_info++  = 10          -- Discount of 10 because the result replaces the call+                -- so we count 10 for the function itself++    + 10 * length actual_arg_discounts+               -- Discount of 10 for each arg supplied,+               -- because the result replaces the call++    + total_arg_discount + res_discount'+  where+    actual_arg_discounts = zipWith mk_arg_discount arg_discounts arg_infos+    total_arg_discount   = sum actual_arg_discounts++    mk_arg_discount _        TrivArg    = 0+    mk_arg_discount _        NonTrivArg = 10+    mk_arg_discount discount ValueArg   = discount++    res_discount'+      | LT <- arg_discounts `compareLength` arg_infos+      = res_discount   -- Over-saturated+      | otherwise+      = case cont_info of+           BoringCtxt  -> 0+           CaseCtxt    -> res_discount  -- Presumably a constructor+           ValAppCtxt  -> res_discount  -- Presumably a function+           _           -> 40 `min` res_discount+                -- ToDo: this 40 `min` res_discount doesn't seem right+                --   for DiscArgCtxt it shouldn't matter because the function will+                --       get the arg discount for any non-triv arg+                --   for RuleArgCtxt we do want to be keener to inline; but not only+                --       constructor results+                --   for RhsCtxt I suppose that exposing a data con is good in general+                --   And 40 seems very arbitrary+                --+                -- res_discount can be very large when a function returns+                -- constructors; but we only want to invoke that large discount+                -- when there's a case continuation.+                -- Otherwise we, rather arbitrarily, threshold it.  Yuk.+                -- But we want to avoid inlining large functions that return+                -- constructors into contexts that are simply "interesting"
+ GHC/Core/Opt/Simplify/Iteration.hs view
@@ -0,0 +1,4827 @@+{-+(c) The AQUA Project, Glasgow University, 1993-1998++\section[Simplify]{The main module of the simplifier}+-}+++{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE MultiWayIf #-}++module GHC.Core.Opt.Simplify.Iteration ( simplTopBinds, simplExpr, simplImpRules ) where++import GHC.Prelude++import GHC.Driver.Flags++import GHC.Core+import GHC.Core.Opt.Simplify.Monad+import GHC.Core.Opt.ConstantFold+import GHC.Core.Type hiding ( substCo, substTy, substTyVar, extendTvSubst, extendCvSubst )+import GHC.Core.TyCo.Compare( eqType )+import GHC.Core.Opt.Simplify.Env+import GHC.Core.Opt.Simplify.Inline+import GHC.Core.Opt.Simplify.Utils+import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr, zapLambdaBndrs, scrutOkForBinderSwap, BinderSwapDecision (..) )+import GHC.Core.Make       ( FloatBind, mkImpossibleExpr, castBottomExpr )+import qualified GHC.Core.Make+import GHC.Core.Coercion hiding ( substCo, substCoVar )+import GHC.Core.Reduction+import GHC.Core.Coercion.Opt    ( optCoercion )+import GHC.Core.FamInstEnv      ( FamInstEnv, topNormaliseType_maybe )+import GHC.Core.DataCon+import GHC.Core.Opt.Stats ( Tick(..) )+import GHC.Core.Ppr     ( pprCoreExpr )+import GHC.Core.Unfold+import GHC.Core.Unfold.Make+import GHC.Core.Utils+import GHC.Core.Opt.Arity ( ArityType, exprArity, arityTypeBotSigs_maybe+                          , pushCoTyArg, pushCoValArg, exprIsDeadEnd+                          , typeArity, arityTypeArity, etaExpandAT )+import GHC.Core.SimpleOpt ( exprIsConApp_maybe, joinPointBinding_maybe, joinPointBindings_maybe )+import GHC.Core.FVs     ( mkRuleInfo {- exprsFreeIds -} )+import GHC.Core.Rules   ( lookupRule, getRules )+import GHC.Core.Multiplicity++import GHC.Types.Literal   ( litIsLifted ) --, mkLitInt ) -- temporarily commented out. See #8326+import GHC.Types.SourceText+import GHC.Types.Id+import GHC.Types.Id.Make   ( seqId )+import GHC.Types.Id.Info+import GHC.Types.Name   ( mkSystemVarName, isExternalName, getOccFS )+import GHC.Types.Demand+import GHC.Types.Unique ( hasKey )+import GHC.Types.Basic+import GHC.Types.Tickish+import GHC.Types.Var    ( isTyCoVar )+import GHC.Builtin.Types.Prim( realWorldStatePrimTy )+import GHC.Builtin.Names( runRWKey, seqHashKey )++import GHC.Data.Maybe   ( isNothing, orElse, mapMaybe )+import GHC.Data.FastString+import GHC.Unit.Module ( moduleName )+import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Utils.Constants (debugIsOn)+import GHC.Utils.Monad  ( mapAccumLM, liftIO )+import GHC.Utils.Logger+import GHC.Utils.Misc++import Control.Monad+import Data.List.NonEmpty (NonEmpty (..))++{-+The guts of the simplifier is in this module, but the driver loop for+the simplifier is in GHC.Core.Opt.Pipeline++Note [The big picture]+~~~~~~~~~~~~~~~~~~~~~~+The general shape of the simplifier is this:++  simplExpr :: SimplEnv -> InExpr -> SimplCont -> SimplM (SimplFloats, OutExpr)+  simplBind :: SimplEnv -> InBind -> SimplM (SimplFloats, SimplEnv)++ * SimplEnv contains+     - Simplifier mode+     - Ambient substitution+     - InScopeSet++ * SimplFloats contains+     - Let-floats (which includes ok-for-spec case-floats)+     - Join floats+     - InScopeSet (including all the floats)++ * Expressions+      simplExpr :: SimplEnv -> InExpr -> SimplCont+                -> SimplM (SimplFloats, OutExpr)+   The result of simplifying an /expression/ is (floats, expr)+      - A bunch of floats (let bindings, join bindings)+      - A simplified expression.+   The overall result is effectively (let floats in expr)++ * Bindings+      simplBind :: SimplEnv -> InBind -> SimplM (SimplFloats, SimplEnv)+   The result of simplifying a binding is+     - A bunch of floats, the last of which is the simplified binding+       There may be auxiliary bindings too; see prepareRhs+     - An environment suitable for simplifying the scope of the binding++   The floats may also be empty, if the binding is inlined unconditionally;+   in that case the returned SimplEnv will have an augmented substitution.++   The returned floats and env both have an in-scope set, and they are+   guaranteed to be the same.++Eta expansion+~~~~~~~~~~~~~~+For eta expansion, we want to catch things like++        case e of (a,b) -> \x -> case a of (p,q) -> \y -> r++If the \x was on the RHS of a let, we'd eta expand to bring the two+lambdas together.  And in general that's a good thing to do.  Perhaps+we should eta expand wherever we find a (value) lambda?  Then the eta+expansion at a let RHS can concentrate solely on the PAP case.++Note [In-scope set as a substitution]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+As per Note [Lookups in in-scope set], an in-scope set can act as+a substitution. Specifically, it acts as a substitution from variable to+variables /with the same unique/.++Why do we need this? Well, during the course of the simplifier, we may want to+adjust inessential properties of a variable. For instance, when performing a+beta-reduction, we change++    (\x. e) u ==> let x = u in e++We typically want to add an unfolding to `x` so that it inlines to (the+simplification of) `u`.++We do that by adding the unfolding to the binder `x`, which is added to the+in-scope set. When simplifying occurrences of `x` (every occurrence!), they are+replaced by their “updated” version from the in-scope set, hence inherit the+unfolding. This happens in `SimplEnv.substId`.++Another example. Consider++   case x of y { Node a b -> ...y...+               ; Leaf v   -> ...y... }++In the Node branch want y's unfolding to be (Node a b); in the Leaf branch we+want y's unfolding to be (Leaf v). We achieve this by adding the appropriate+unfolding to y, and re-adding it to the in-scope set. See the calls to+`addBinderUnfolding` in `Simplify.addAltUnfoldings` and elsewhere.++It's quite convenient. This way we don't need to manipulate the substitution all+the time: every update to a binder is automatically reflected to its bound+occurrences.++Note [Bangs in the Simplifier]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Both SimplFloats and SimplEnv do *not* generally benefit from making+their fields strict. I don't know if this is because of good use of+laziness or unintended side effects like closures capturing more variables+after WW has run.++But the end result is that we keep these lazy, but force them in some places+where we know it's beneficial to the compiler.++Similarly environments returned from functions aren't *always* beneficial to+force. In some places they would never be demanded so forcing them early+increases allocation. In other places they almost always get demanded so+it's worthwhile to force them early.++Would it be better to through every allocation of e.g. SimplEnv and decide+wether or not to make this one strict? Absolutely! Would be a good use of+someones time? Absolutely not! I made these strict that showed up during+a profiled build or which I noticed while looking at core for one reason+or another.++The result sadly is that we end up with "random" bangs in the simplifier+where we sometimes force e.g. the returned environment from a function and+sometimes we don't for the same function. Depending on the context around+the call. The treatment is also not very consistent. I only added bangs+where I saw it making a difference either in the core or benchmarks. Some+patterns where it would be beneficial aren't convered as a consequence as+I neither have the time to go through all of the core and some cases are+too small to show up in benchmarks.++++************************************************************************+*                                                                      *+\subsection{Bindings}+*                                                                      *+************************************************************************+-}++simplTopBinds :: SimplEnv -> [InBind] -> SimplM (SimplFloats, SimplEnv)+-- See Note [The big picture]+simplTopBinds env0 binds0+  = do  {       -- Put all the top-level binders into scope at the start+                -- so that if a rewrite rule has unexpectedly brought+                -- anything into scope, then we don't get a complaint about that.+                -- It's rather as if the top-level binders were imported.+                -- See Note [Glomming] in "GHC.Core.Opt.OccurAnal".+        -- See Note [Bangs in the Simplifier]+        ; !env1 <- {-#SCC "simplTopBinds-simplRecBndrs" #-} simplRecBndrs env0 (bindersOfBinds binds0)+        ; (floats, env2) <- {-#SCC "simplTopBinds-simpl_binds" #-} simpl_binds env1 binds0+        ; freeTick SimplifierDone+        ; return (floats, env2) }+  where+        -- We need to track the zapped top-level binders, because+        -- they should have their fragile IdInfo zapped (notably occurrence info)+        -- That's why we run down binds and bndrs' simultaneously.+        --+    simpl_binds :: SimplEnv -> [InBind] -> SimplM (SimplFloats, SimplEnv)+    simpl_binds env []           = return (emptyFloats env, env)+    simpl_binds env (bind:binds) = do { (float,  env1) <- simpl_bind env bind+                                      ; (floats, env2) <- simpl_binds env1 binds+                                      -- See Note [Bangs in the Simplifier]+                                      ; let !floats1 = float `addFloats` floats+                                      ; return (floats1, env2) }++    simpl_bind env (Rec pairs)+      = simplRecBind env (BC_Let TopLevel Recursive) pairs+    simpl_bind env (NonRec b r)+      = do { let bind_cxt = BC_Let TopLevel NonRecursive+           ; (env', b') <- addBndrRules env b (lookupRecBndr env b) bind_cxt+           ; simplRecOrTopPair env' bind_cxt b b' r }++{-+************************************************************************+*                                                                      *+        Lazy bindings+*                                                                      *+************************************************************************++simplRecBind is used for+        * recursive bindings only+-}++simplRecBind :: SimplEnv -> BindContext+             -> [(InId, InExpr)]+             -> SimplM (SimplFloats, SimplEnv)+simplRecBind env0 bind_cxt pairs0+  = do  { (env1, triples) <- mapAccumLM add_rules env0 pairs0+        ; let new_bndrs = map sndOf3 triples+        ; (rec_floats, env2) <- enterRecGroupRHSs env1 new_bndrs $ \env ->+                                go env triples+        ; return (mkRecFloats rec_floats, env2) }+  where+    add_rules :: SimplEnv -> (InBndr,InExpr) -> SimplM (SimplEnv, (InBndr, OutBndr, InExpr))+        -- Add the (substituted) rules to the binder+    add_rules env (bndr, rhs)+        = do { (env', bndr') <- addBndrRules env bndr (lookupRecBndr env bndr) bind_cxt+             ; return (env', (bndr, bndr', rhs)) }++    go env [] = return (emptyFloats env, env)++    go env ((old_bndr, new_bndr, rhs) : pairs)+        = do { (float, env1) <- simplRecOrTopPair env bind_cxt+                                                  old_bndr new_bndr rhs+             ; (floats, env2) <- go env1 pairs+             ; return (float `addFloats` floats, env2) }++{-+simplOrTopPair is used for+        * recursive bindings (whether top level or not)+        * top-level non-recursive bindings++It assumes the binder has already been simplified, but not its IdInfo.+-}++simplRecOrTopPair :: SimplEnv+                  -> BindContext+                  -> InId -> OutBndr -> InExpr  -- Binder and rhs+                  -> SimplM (SimplFloats, SimplEnv)++simplRecOrTopPair env bind_cxt old_bndr new_bndr rhs+  | Just env' <- preInlineUnconditionally env (bindContextLevel bind_cxt)+                                          old_bndr rhs env+  = {-#SCC "simplRecOrTopPair-pre-inline-uncond" #-}+    simplTrace "SimplBindr:inline-uncond1" (ppr old_bndr) $+    do { tick (PreInlineUnconditionally old_bndr)+       ; return ( emptyFloats env, env' ) }++  | otherwise+  = case bind_cxt of+      BC_Join is_rec cont -> simplTrace "SimplBind:join" (ppr old_bndr) $+                             simplJoinBind is_rec cont+                                           (old_bndr,env) (new_bndr,env) (rhs,env)++      BC_Let top_lvl is_rec -> simplTrace "SimplBind:normal" (ppr old_bndr) $+                               simplLazyBind top_lvl is_rec+                                             (old_bndr,env) (new_bndr,env) (rhs,env)++simplTrace :: String -> SDoc -> SimplM a -> SimplM a+simplTrace herald doc thing_inside = do+  logger <- getLogger+  if logHasDumpFlag logger Opt_D_verbose_core2core+    then logTraceMsg logger herald doc thing_inside+    else thing_inside++--------------------------+simplLazyBind :: TopLevelFlag -> RecFlag+              -> (InId, SimplEnv)       -- InBinder, and static env for its unfolding (if any)+              -> (OutId, SimplEnv)      -- OutBinder, and SimplEnv after simplifying that binder+                                        -- The OutId has IdInfo (notably RULES),+                                        -- except arity, unfolding+              -> (InExpr, SimplEnv)     -- The RHS and its static environment+              -> SimplM (SimplFloats, SimplEnv)+-- Precondition: Ids only, no TyVars; not a JoinId+-- Precondition: rhs obeys the let-can-float invariant+simplLazyBind top_lvl is_rec (bndr,unf_se) (bndr1,env) (rhs,rhs_se)+  = assert (isId bndr )+    assertPpr (not (isJoinId bndr)) (ppr bndr) $+    -- pprTrace "simplLazyBind" ((ppr bndr <+> ppr bndr1) $$ ppr rhs $$ ppr (seIdSubst rhs_se)) $+    do  { let   !rhs_env     = rhs_se `setInScopeFromE` env -- See Note [Bangs in the Simplifier]+                (tvs, body) = case collectTyAndValBinders rhs of+                                (tvs, [], body)+                                  | surely_not_lam body -> (tvs, body)+                                _                       -> ([], rhs)++                surely_not_lam (Lam {})     = False+                surely_not_lam (Tick t e)+                  | not (tickishFloatable t) = surely_not_lam e+                   -- eta-reduction could float+                surely_not_lam _            = True+                        -- Do not do the "abstract tyvar" thing if there's+                        -- a lambda inside, because it defeats eta-reduction+                        --    f = /\a. \x. g a x+                        -- should eta-reduce.++        ; (body_env, tvs') <- {-#SCC "simplBinders" #-} simplBinders rhs_env tvs+                -- See Note [Floating and type abstraction] in GHC.Core.Opt.Simplify.Utils++        -- Simplify the RHS+        ; let rhs_cont = mkRhsStop (substTy body_env (exprType body))+                                   is_rec (idDemandInfo bndr)+        ; (body_floats0, body0) <- {-#SCC "simplExprF" #-} simplExprF body_env body rhs_cont++        -- ANF-ise a constructor or PAP rhs+        ; (body_floats2, body2) <- {-#SCC "prepareBinding" #-}+                                   prepareBinding env top_lvl is_rec+                                                  False  -- Not strict; this is simplLazyBind+                                                  bndr1 body_floats0 body0+          -- Subtle point: we do not need or want tvs' in the InScope set+          -- of body_floats2, so we pass in 'env' not 'body_env'.+          -- Don't want: if tvs' are in-scope in the scope of this let-binding, we may do+          -- more renaming than necessary => extra work (see !7777 and test T16577).+          -- Don't need: we wrap tvs' around the RHS anyway.++        ; (rhs_floats, body3)+            <-  if isEmptyFloats body_floats2 || null tvs then   -- Simple floating+                     {-#SCC "simplLazyBind-simple-floating" #-}+                     return (body_floats2, body2)++                else -- Non-empty floats, and non-empty tyvars: do type-abstraction first+                     {-#SCC "simplLazyBind-type-abstraction-first" #-}+                     do { (poly_binds, body3) <- abstractFloats (seUnfoldingOpts env) top_lvl+                                                                tvs' body_floats2 body2+                        ; let poly_floats = foldl' extendFloats (emptyFloats env) poly_binds+                        ; return (poly_floats, body3) }++        ; let env1 = env `setInScopeFromF` rhs_floats+        ; rhs' <- rebuildLam env1 tvs' body3 rhs_cont+        ; (bind_float, env2) <- completeBind (BC_Let top_lvl is_rec) (bndr,unf_se) (bndr1,rhs',env1)+        ; return (rhs_floats `addFloats` bind_float, env2) }++--------------------------+simplJoinBind :: RecFlag+              -> SimplCont+              -> (InId, SimplEnv)       -- InBinder, with static env for its unfolding+              -> (OutId, SimplEnv)      -- OutBinder; SimplEnv has the binder in scope+                                        -- The OutId has IdInfo, except arity, unfolding+              -> (InExpr, SimplEnv)     -- The right hand side and its env+              -> SimplM (SimplFloats, SimplEnv)+simplJoinBind is_rec cont (old_bndr, unf_se) (new_bndr, env) (rhs, rhs_se)+  = do  { let rhs_env = rhs_se `setInScopeFromE` env+        ; rhs' <- simplJoinRhs rhs_env old_bndr rhs cont+        ; completeBind (BC_Join is_rec cont) (old_bndr, unf_se) (new_bndr, rhs', env) }++--------------------------+simplAuxBind :: String+             -> SimplEnv+             -> InId            -- Old binder; not a JoinId+             -> OutExpr         -- Simplified RHS+             -> SimplM (SimplFloats, SimplEnv)+-- A specialised variant of completeBindX used to construct non-recursive+-- auxiliary bindings, notably in knownCon.+--+-- The binder comes from a case expression (case binder or alternative)+-- and so does not have rules, unfolding, inline pragmas etc.+--+-- Precondition: rhs satisfies the let-can-float invariant++simplAuxBind _str env bndr new_rhs+  | assertPpr (isId bndr && not (isJoinId bndr)) (ppr bndr) $+    isDeadBinder bndr   -- Not uncommon; e.g. case (a,b) of c { (p,q) -> p }+  = return (emptyFloats env, env)    --  Here c is dead, and we avoid+                                     --  creating the binding c = (a,b)++  -- Next we have a fast-path for cases that would be inlined unconditionally by+  -- completeBind: but it seems not uncommon, and it turns to be a little more+  -- efficient (in compile time allocations) to do it here.+  -- Effectively this is just a vastly-simplified postInlineUnconditionally+  --   See Note [Post-inline for single-use things] in GHC.Core.Opt.Simplify.Utils+  -- We could instead use postInlineUnconditionally itself, but I think it's simpler+  --   and more direct to focus on the "hot" cases.+  -- e.g. auxiliary bindings have no NOLINE pragmas, RULEs, or stable unfoldings+  | exprIsTrivial new_rhs  -- Short-cut for let x = y in ...+    || case (idOccInfo bndr) of+          OneOcc{ occ_n_br = 1, occ_in_lam = NotInsideLam } -> True+          _                                                 -> False+  = return ( emptyFloats env+           , extendCvIdSubst env bndr new_rhs )  -- bndr can be a CoVar++  | otherwise+  = do  { -- ANF-ise the RHS+          let !occ_fs = getOccFS bndr+        ; (anf_floats, rhs1) <- prepareRhs env NotTopLevel occ_fs new_rhs+        ; unless (isEmptyLetFloats anf_floats) (tick LetFloatFromLet)+        ; let rhs_floats = emptyFloats env `addLetFloats` anf_floats++          -- Simplify the binder and complete the binding+        ; (env1, new_bndr) <- simplBinder (env `setInScopeFromF` rhs_floats) bndr+        ; (bind_float, env2) <- completeBind (BC_Let NotTopLevel NonRecursive)+                                             (bndr,env) (new_bndr, rhs1, env1)++        ; return (rhs_floats `addFloats` bind_float, env2) }+++{- *********************************************************************+*                                                                      *+           Cast worker/wrapper+*                                                                      *+************************************************************************++Note [Cast worker/wrapper]+~~~~~~~~~~~~~~~~~~~~~~~~~~+When we have a binding+   x = e |> co+we want to do something very similar to worker/wrapper:+   $wx = e+   x = $wx |> co++We call this making a cast worker/wrapper in tryCastWorkerWrapper.++The main motivaiton is that x can be inlined freely.  There's a chance+that e will be a constructor application or function, or something+like that, so moving the coercion to the usage site may well cancel+the coercions and lead to further optimisation.  Example:++     data family T a :: *+     data instance T Int = T Int++     foo :: Int -> Int -> Int+     foo m n = ...+        where+          t = T m+          go 0 = 0+          go n = case t of { T m -> go (n-m) }+                -- This case should optimise++A second reason for doing cast worker/wrapper is that the worker/wrapper+pass after strictness analysis can't deal with RHSs like+     f = (\ a b c. blah) |> co+Instead, it relies on cast worker/wrapper to get rid of the cast,+leaving a simpler job for demand-analysis worker/wrapper.  See #19874.++Wrinkles++1. We must /not/ do cast w/w on+     f = g |> co+   otherwise it'll just keep repeating forever! You might think this+   is avoided because the call to tryCastWorkerWrapper is guarded by+   preInlineUnconditinally, but I'm worried that a loop-breaker or an+   exported Id might say False to preInlineUnonditionally.++2. We need to be careful with inline/noinline pragmas:+       rec { {-# NOINLINE f #-}+             f = (...g...) |> co+           ; g = ...f... }+   This is legitimate -- it tells GHC to use f as the loop breaker+   rather than g.  Now we do the cast thing, to get something like+       rec { $wf = ...g...+           ; f = $wf |> co+           ; g = ...f... }+   Where should the NOINLINE pragma go?  If we leave it on f we'll get+     rec { $wf = ...g...+         ; {-# NOINLINE f #-}+           f = $wf |> co+         ; g = ...f... }+   and that is bad: the whole point is that we want to inline that+   cast!  We want to transfer the pagma to $wf:+      rec { {-# NOINLINE $wf #-}+            $wf = ...g...+          ; f = $wf |> co+          ; g = ...f... }+   c.f. Note [Worker/wrapper for NOINLINE functions] in GHC.Core.Opt.WorkWrap.++3. We should still do cast w/w even if `f` is INLINEABLE.  E.g.+      {- f: Stable unfolding = <stable-big> -}+      f = (\xy. <big-body>) |> co+   Then we want to w/w to+      {- $wf: Stable unfolding = <stable-big> |> sym co -}+      $wf = \xy. <big-body>+      f = $wf |> co+   Notice that the stable unfolding moves to the worker!  Now demand analysis+   will work fine on $wf, whereas it has trouble with the original f.+   c.f. Note [Worker/wrapper for INLINABLE functions] in GHC.Core.Opt.WorkWrap.+   This point also applies to strong loopbreakers with INLINE pragmas, see+   wrinkle (4).++4. We should /not/ do cast w/w for non-loop-breaker INLINE functions (hence+   hasInlineUnfolding in tryCastWorkerWrapper, which responds False to+   loop-breakers) because they'll definitely be inlined anyway, cast and+   all. And if we do cast w/w for an INLINE function with arity zero, we get+   something really silly: we inline that "worker" right back into the wrapper!+   Worse than a no-op, because we have then lost the stable unfolding.++All these wrinkles are exactly like worker/wrapper for strictness analysis:+  f is the wrapper and must inline like crazy+  $wf is the worker and must carry f's original pragma+See Note [Worker/wrapper for INLINABLE functions]+and Note [Worker/wrapper for NOINLINE functions] in GHC.Core.Opt.WorkWrap.++See #17673, #18093, #18078, #19890.++Note [Preserve strictness in cast w/w]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In the Note [Cast worker/wrapper] transformation, keep the strictness info.+Eg+        f = e `cast` co    -- f has strictness SSL+When we transform to+        f' = e             -- f' also has strictness SSL+        f = f' `cast` co   -- f still has strictness SSL++Its not wrong to drop it on the floor, but better to keep it.++Note [Preserve RuntimeRep info in cast w/w]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We must not do cast w/w when the presence of the coercion is needed in order+to determine the runtime representation.++Example:++  Suppose we have a type family:++    type F :: RuntimeRep+    type family F where+      F = LiftedRep++  together with a type `ty :: TYPE F` and a top-level binding++    a :: ty |> TYPE F[0]++  The kind of `ty |> TYPE F[0]` is `LiftedRep`, so `a` is a top-level lazy binding.+  However, were we to apply cast w/w, we would get:++    b :: ty+    b = ...++    a :: ty |> TYPE F[0]+    a = b `cast` GRefl (TYPE F[0])++  Now we are in trouble because `ty :: TYPE F` does not have a known runtime+  representation, because we need to be able to reduce the nullary type family+  application `F` to find that out.++Conclusion: only do cast w/w when doing so would not lose the RuntimeRep+information. That is, when handling `Cast rhs co`, don't attempt cast w/w+unless the kind of the type of rhs is concrete, in the sense of+Note [Concrete types] in GHC.Tc.Utils.Concrete.+-}++tryCastWorkerWrapper :: SimplEnv -> BindContext+                     -> InId -> OutId -> OutExpr+                     -> SimplM (SimplFloats, SimplEnv)+-- See Note [Cast worker/wrapper]+tryCastWorkerWrapper env bind_cxt old_bndr bndr (Cast rhs co)+  | BC_Let top_lvl is_rec <- bind_cxt  -- Not join points+  , not (isDFunId bndr) -- nor DFuns; cast w/w is no help, and we can't transform+                        --            a DFunUnfolding in mk_worker_unfolding+  , not (exprIsTrivial rhs)        -- Not x = y |> co; Wrinkle 1+  , not (hasInlineUnfolding info)  -- Not INLINE things: Wrinkle 4+  , typeHasFixedRuntimeRep work_ty    -- Don't peel off a cast if doing so would+                                      -- lose the underlying runtime representation.+                                      -- See Note [Preserve RuntimeRep info in cast w/w]+  , not (isOpaquePragma (idInlinePragma old_bndr)) -- Not for OPAQUE bindings+                                                   -- See Note [OPAQUE pragma]+  = do  { uniq <- getUniqueM+        ; let work_name = mkSystemVarName uniq occ_fs+              work_id   = mkLocalIdWithInfo work_name ManyTy work_ty work_info+              is_strict = isStrictId bndr++        ; (rhs_floats, work_rhs) <- prepareBinding env top_lvl is_rec is_strict+                                                   work_id (emptyFloats env) rhs++        ; work_unf <- mk_worker_unfolding top_lvl work_id work_rhs+        ; let  work_id_w_unf = work_id `setIdUnfolding` work_unf+               floats   = rhs_floats `addLetFloats`+                          unitLetFloat (NonRec work_id_w_unf work_rhs)++               triv_rhs = Cast (Var work_id_w_unf) co++        ; if postInlineUnconditionally env bind_cxt old_bndr bndr triv_rhs+             -- Almost always True, because the RHS is trivial+             -- In that case we want to eliminate the binding fast+             -- We conservatively use postInlineUnconditionally so that we+             -- check all the right things+          then do { tick (PostInlineUnconditionally bndr)+                  ; return ( floats+                           , extendIdSubst (setInScopeFromF env floats) old_bndr $+                             DoneEx triv_rhs NotJoinPoint ) }++          else do { wrap_unf <- mkLetUnfolding env top_lvl VanillaSrc bndr False triv_rhs+                  ; let bndr' = bndr `setInlinePragma` mkCastWrapperInlinePrag (idInlinePragma bndr)+                                `setIdUnfolding`  wrap_unf+                        floats' = floats `extendFloats` NonRec bndr' triv_rhs+                  ; return ( floats', setInScopeFromF env floats' ) } }+  where+    -- Force the occ_fs so that the old Id is not retained in the new Id.+    !occ_fs = getOccFS bndr+    work_ty = coercionLKind co+    info   = idInfo bndr+    work_arity = arityInfo info `min` typeArity work_ty++    work_info = vanillaIdInfo `setDmdSigInfo`     dmdSigInfo info+                              `setCprSigInfo`     cprSigInfo info+                              `setDemandInfo`     demandInfo info+                              `setInlinePragInfo` inlinePragInfo info+                              `setArityInfo`      work_arity+           -- We do /not/ want to transfer OccInfo, Rules+           -- Note [Preserve strictness in cast w/w]+           -- and Wrinkle 2 of Note [Cast worker/wrapper]++    ----------- Worker unfolding -----------+    -- Stable case: if there is a stable unfolding we have to compose with (Sym co);+    --   the next round of simplification will do the job+    -- Non-stable case: use work_rhs+    -- Wrinkle 3 of Note [Cast worker/wrapper]+    mk_worker_unfolding top_lvl work_id work_rhs+      = case realUnfoldingInfo info of -- NB: the real one, even for loop-breakers+           unf@(CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src })+             | isStableSource src -> return (unf { uf_tmpl = mkCast unf_rhs (mkSymCo co) })+           _ -> mkLetUnfolding env top_lvl VanillaSrc work_id False work_rhs++tryCastWorkerWrapper env _ _ bndr rhs  -- All other bindings+  = do { traceSmpl "tcww:no" (vcat [ text "bndr:" <+> ppr bndr+                                   , text "rhs:" <+> ppr rhs ])+        ; return (mkFloatBind env (NonRec bndr rhs)) }++mkCastWrapperInlinePrag :: InlinePragma -> InlinePragma+-- See Note [Cast worker/wrapper]+mkCastWrapperInlinePrag (InlinePragma { inl_inline = fn_inl, inl_act = fn_act, inl_rule = rule_info })+  = InlinePragma { inl_src    = SourceText $ fsLit "{-# INLINE"+                 , inl_inline = fn_inl       -- See Note [Worker/wrapper for INLINABLE functions]+                 , inl_sat    = Nothing      --     in GHC.Core.Opt.WorkWrap+                 , inl_act    = wrap_act     -- See Note [Wrapper activation]+                 , inl_rule   = rule_info }  --     in GHC.Core.Opt.WorkWrap+                                -- RuleMatchInfo is (and must be) unaffected+  where+    -- See Note [Wrapper activation] in GHC.Core.Opt.WorkWrap+    -- But simpler, because we don't need to disable during InitialPhase+    wrap_act | isNeverActive fn_act = activateDuringFinal+             | otherwise            = fn_act+++{- *********************************************************************+*                                                                      *+           prepareBinding, prepareRhs, makeTrivial+*                                                                      *+********************************************************************* -}++prepareBinding :: SimplEnv -> TopLevelFlag -> RecFlag -> Bool+               -> Id   -- Used only for its OccName; can be InId or OutId+               -> SimplFloats -> OutExpr+               -> SimplM (SimplFloats, OutExpr)+-- In (prepareBinding ... bndr floats rhs), the binding is really just+--    bndr = let floats in rhs+-- Maybe we can ANF-ise this binding and float out; e.g.+--    bndr = let a = f x in K a a (g x)+-- we could float out to give+--    a    = f x+--    tmp  = g x+--    bndr = K a a tmp+-- That's what prepareBinding does+-- Precondition: binder is not a JoinId+-- Postcondition: the returned SimplFloats contains only let-floats+prepareBinding env top_lvl is_rec strict_bind bndr rhs_floats rhs+  = do { -- Never float join-floats out of a non-join let-binding (which this is)+         -- So wrap the body in the join-floats right now+         -- Hence: rhs_floats1 consists only of let-floats+         let (rhs_floats1, rhs1) = wrapJoinFloatsX rhs_floats rhs++         -- rhs_env: add to in-scope set the binders from rhs_floats+         -- so that prepareRhs knows what is in scope in rhs+       ; let rhs_env = env `setInScopeFromF` rhs_floats1+             -- Force the occ_fs so that the old Id is not retained in the new Id.+             !occ_fs = getOccFS bndr++       -- Now ANF-ise the remaining rhs+       ; (anf_floats, rhs2) <- prepareRhs rhs_env top_lvl occ_fs rhs1++       -- Finally, decide whether or not to float+       ; let all_floats = rhs_floats1 `addLetFloats` anf_floats+       ; if doFloatFromRhs (seFloatEnable env) top_lvl is_rec strict_bind all_floats rhs2+         then -- Float!+              do { tick LetFloatFromLet+                 ; return (all_floats, rhs2) }++         else -- Abandon floating altogether; revert to original rhs+              -- Since we have already built rhs1, we just need to add+              -- rhs_floats1 to it+              return (emptyFloats env, wrapFloats rhs_floats1 rhs1) }++{- Note [prepareRhs]+~~~~~~~~~~~~~~~~~~~~+prepareRhs takes a putative RHS, checks whether it's a PAP or+constructor application and, if so, converts it to ANF, so that the+resulting thing can be inlined more easily.  Thus+        x = (f a, g b)+becomes+        t1 = f a+        t2 = g b+        x = (t1,t2)++We also want to deal well cases like this+        v = (f e1 `cast` co) e2+Here we want to make e1,e2 trivial and get+        x1 = e1; x2 = e2; v = (f x1 `cast` co) v2+That's what the 'go' loop in prepareRhs does+-}++prepareRhs :: HasDebugCallStack+           => SimplEnv -> TopLevelFlag+           -> FastString    -- Base for any new variables+           -> OutExpr+           -> SimplM (LetFloats, OutExpr)+-- Transforms a RHS into a better RHS by ANF'ing args+-- for expandable RHSs: constructors and PAPs+-- e.g        x = Just e+-- becomes    a = e               -- 'a' is fresh+--            x = Just a+-- See Note [prepareRhs]+prepareRhs env top_lvl occ rhs0+  | is_expandable = anfise rhs0+  | otherwise     = return (emptyLetFloats, rhs0)+  where+    -- We can't use exprIsExpandable because the WHOLE POINT is that+    -- we want to treat (K <big>) as expandable, because we are just+    -- about "anfise" the <big> expression.  exprIsExpandable would+    -- just say no!+    is_expandable = go rhs0 0+       where+         go (Var fun) n_val_args       = isExpandableApp fun n_val_args+         go (App fun arg) n_val_args+           | isTypeArg arg             = go fun n_val_args+           | otherwise                 = go fun (n_val_args + 1)+         go (Cast rhs _)  n_val_args   = go rhs n_val_args+         go (Tick _ rhs)  n_val_args   = go rhs n_val_args+         go _             _            = False++    anfise :: OutExpr -> SimplM (LetFloats, OutExpr)+    anfise (Cast rhs co)+        = do { (floats, rhs') <- anfise rhs+             ; return (floats, Cast rhs' co) }+    anfise (App fun (Type ty))+        = do { (floats, rhs') <- anfise fun+             ; return (floats, App rhs' (Type ty)) }+    anfise (App fun arg)+        = do { (floats1, fun') <- anfise fun+             ; (floats2, arg') <- makeTrivial env top_lvl topDmd occ arg+             ; return (floats1 `addLetFlts` floats2, App fun' arg') }+    anfise (Var fun)+        = return (emptyLetFloats, Var fun)++    anfise (Tick t rhs)+        -- We want to be able to float bindings past this+        -- tick. Non-scoping ticks don't care.+        | tickishScoped t == NoScope+        = do { (floats, rhs') <- anfise rhs+             ; return (floats, Tick t rhs') }++        -- On the other hand, for scoping ticks we need to be able to+        -- copy them on the floats, which in turn is only allowed if+        -- we can obtain non-counting ticks.+        | (not (tickishCounts t) || tickishCanSplit t)+        = do { (floats, rhs') <- anfise rhs+             ; let tickIt (id, expr) = (id, mkTick (mkNoCount t) expr)+                   floats' = mapLetFloats floats tickIt+             ; return (floats', Tick t rhs') }++    anfise other = return (emptyLetFloats, other)++makeTrivialArg :: HasDebugCallStack => SimplEnv -> ArgSpec -> SimplM (LetFloats, ArgSpec)+makeTrivialArg env arg@(ValArg { as_arg = e, as_dmd = dmd })+  = do { (floats, e') <- makeTrivial env NotTopLevel dmd (fsLit "arg") e+       ; return (floats, arg { as_arg = e' }) }+makeTrivialArg _ arg@(TyArg {})+  = return (emptyLetFloats, arg)++makeTrivial :: HasDebugCallStack+            => SimplEnv -> TopLevelFlag -> Demand+            -> FastString  -- ^ A "friendly name" to build the new binder from+            -> OutExpr+            -> SimplM (LetFloats, OutExpr)+-- Binds the expression to a variable, if it's not trivial, returning the variable+-- For the Demand argument, see Note [Keeping demand info in StrictArg Plan A]+makeTrivial env top_lvl dmd occ_fs expr+  | exprIsTrivial expr                          -- Already trivial+  || not (bindingOk top_lvl expr expr_ty)       -- Cannot trivialise+                                                --   See Note [Cannot trivialise]+  = return (emptyLetFloats, expr)++  | Cast expr' co <- expr+  = do { (floats, triv_expr) <- makeTrivial env top_lvl dmd occ_fs expr'+       ; return (floats, Cast triv_expr co) }++  | otherwise -- 'expr' is not of form (Cast e co)+  = do  { (floats, expr1) <- prepareRhs env top_lvl occ_fs expr+        ; uniq <- getUniqueM+        ; let name = mkSystemVarName uniq occ_fs+              var  = mkLocalIdWithInfo name ManyTy expr_ty id_info++        -- Now something very like completeBind,+        -- but without the postInlineUnconditionally part+        ; (arity_type, expr2) <- tryEtaExpandRhs env (BC_Let top_lvl NonRecursive) var expr1+          -- Technically we should extend the in-scope set in 'env' with+          -- the 'floats' from prepareRHS; but they are all fresh, so there is+          -- no danger of introducing name shadowing in eta expansion++        ; unf <- mkLetUnfolding env top_lvl VanillaSrc var False expr2++        ; let final_id = addLetBndrInfo var arity_type unf+              bind     = NonRec final_id expr2++        ; traceSmpl "makeTrivial" (vcat [text "final_id" <+> ppr final_id, text "rhs" <+> ppr expr2 ])+        ; return ( floats `addLetFlts` unitLetFloat bind, Var final_id ) }+  where+    id_info = vanillaIdInfo `setDemandInfo` dmd+    expr_ty = exprType expr++bindingOk :: TopLevelFlag -> CoreExpr -> Type -> Bool+-- True iff we can have a binding of this expression at this level+-- Precondition: the type is the type of the expression+bindingOk top_lvl expr expr_ty+  | isTopLevel top_lvl = exprIsTopLevelBindable expr expr_ty+  | otherwise          = True++{- Note [Cannot trivialise]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider:+   f :: Int -> Addr#++   foo :: Bar+   foo = Bar (f 3)++Then we can't ANF-ise foo, even though we'd like to, because+we can't make a top-level binding for the Addr# (f 3). And if+so we don't want to turn it into+   foo = let x = f 3 in Bar x+because we'll just end up inlining x back, and that makes the+simplifier loop.  Better not to ANF-ise it at all.++Literal strings are an exception.++   foo = Ptr "blob"#++We want to turn this into:++   foo1 = "blob"#+   foo = Ptr foo1++See Note [Core top-level string literals] in GHC.Core.++************************************************************************+*                                                                      *+          Completing a lazy binding+*                                                                      *+************************************************************************++completeBind+  * deals only with Ids, not TyVars+  * takes an already-simplified binder and RHS+  * is used for both recursive and non-recursive bindings+  * is used for both top-level and non-top-level bindings++It does the following:+  - tries discarding a dead binding+  - tries PostInlineUnconditionally+  - add unfolding [this is the only place we add an unfolding]+  - add arity+  - extend the InScopeSet of the SimplEnv++It does *not* attempt to do let-to-case.  Why?  Because it is used for+  - top-level bindings (when let-to-case is impossible)+  - many situations where the "rhs" is known to be a WHNF+                (so let-to-case is inappropriate).++Nor does it do the atomic-argument thing+-}++completeBind :: BindContext+             -> (InId, SimplEnv)           -- Old binder, and the static envt in which to simplify+                                           --   its stable unfolding (if any)+             -> (OutId, OutExpr, SimplEnv) -- New binder and rhs; can be a JoinId.+                                           -- And the SimplEnv with that OutId in scope.+             -> SimplM (SimplFloats, SimplEnv)+-- completeBind may choose to do its work+--      * by extending the substitution (e.g. let x = y in ...)+--      * or by adding to the floats in the envt+--+-- Binder /can/ be a JoinId+-- Precondition: rhs obeys the let-can-float invariant+completeBind bind_cxt (old_bndr, unf_se) (new_bndr, new_rhs, env)+ | isCoVar old_bndr+ = case new_rhs of+     Coercion co -> return (emptyFloats env, extendCvSubst env old_bndr co)+     _           -> return (mkFloatBind env (NonRec new_bndr new_rhs))++ | otherwise+ = assert (isId new_bndr) $+   do { let old_info = idInfo old_bndr+            old_unf  = realUnfoldingInfo old_info++         -- Do eta-expansion on the RHS of the binding+         -- See Note [Eta-expanding at let bindings] in GHC.Core.Opt.Simplify.Utils+      ; (new_arity, eta_rhs) <- tryEtaExpandRhs env bind_cxt new_bndr new_rhs++        -- Simplify the unfolding; see Note [Environment for simplLetUnfolding]+      ; new_unfolding <- simplLetUnfolding (unf_se `setInScopeFromE` env)+                            bind_cxt old_bndr+                            eta_rhs (idType new_bndr) new_arity old_unf++      ; let new_bndr_w_info = addLetBndrInfo new_bndr new_arity new_unfolding+        -- See Note [In-scope set as a substitution]++      ; if postInlineUnconditionally env bind_cxt old_bndr new_bndr_w_info eta_rhs++        then -- Inline and discard the binding+             do  { tick (PostInlineUnconditionally old_bndr)+                 ; let unf_rhs = maybeUnfoldingTemplate new_unfolding `orElse` eta_rhs+                          -- See Note [Use occ-anald RHS in postInlineUnconditionally]+                 ; simplTrace "PostInlineUnconditionally" (ppr new_bndr <+> ppr unf_rhs) $+                   return ( emptyFloats env+                          , extendIdSubst env old_bndr $+                            DoneEx unf_rhs (idJoinPointHood new_bndr)) }+                -- Use the substitution to make quite, quite sure that the+                -- substitution will happen, since we are going to discard the binding++        else -- Keep the binding; do cast worker/wrapper+--             simplTrace "completeBind" (vcat [ text "bndrs" <+> ppr old_bndr <+> ppr new_bndr+--                                             , text "eta_rhs" <+> ppr eta_rhs ]) $+             tryCastWorkerWrapper env bind_cxt old_bndr new_bndr_w_info eta_rhs }++addLetBndrInfo :: OutId -> ArityType -> Unfolding -> OutId+addLetBndrInfo new_bndr new_arity_type new_unf+  = new_bndr `setIdInfo` info5+  where+    new_arity = arityTypeArity new_arity_type+    info1 = idInfo new_bndr `setArityInfo` new_arity++    -- Unfolding info: Note [Setting the new unfolding]+    info2 = info1 `setUnfoldingInfo` new_unf++    -- Demand info: Note [Setting the demand info]+    info3 | isEvaldUnfolding new_unf+          = lazifyDemandInfo info2 `orElse` info2+          | otherwise+          = info2++    -- Bottoming bindings: see Note [Bottoming bindings]+    info4 = case arityTypeBotSigs_maybe new_arity_type of+        Nothing -> info3+        Just (ar, str_sig, cpr_sig) -> assert (ar == new_arity) $+                                       info3 `setDmdSigInfo` str_sig+                                             `setCprSigInfo` cpr_sig++     -- Zap call arity info. We have used it by now (via+     -- `tryEtaExpandRhs`), and the simplifier can invalidate this+     -- information, leading to broken code later (e.g. #13479)+    info5 = zapCallArityInfo info4+++{- Note [Bottoming bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have+   let x = error "urk"+   in ...(case x of <alts>)...+or+   let f = \y. error (y ++ "urk")+   in ...(case f "foo" of <alts>)...++Then we'd like to drop the dead <alts> immediately.  So it's good to+propagate the info that x's (or f's) RHS is bottom to x's (or f's)+IdInfo as rapidly as possible.++We use tryEtaExpandRhs on every binding, and it turns out that the+arity computation it performs (via GHC.Core.Opt.Arity.findRhsArity) already+does a simple bottoming-expression analysis.  So all we need to do+is propagate that info to the binder's IdInfo.++This showed up in #12150; see comment:16.++There is a second reason for settting  the strictness signature. Consider+   let -- f :: <[S]b>+       f = \x. error "urk"+   in ...(f a b c)...+Then, in GHC.Core.Opt.Arity.findRhsArity we'll use the demand-info on `f`+to eta-expand to+   let f = \x y z. error "urk"+   in ...(f a b c)...++But now f's strictness signature has too short an arity; see+GHC.Core.Opt.DmdAnal Note [idArity varies independently of dmdTypeDepth].+Fortuitously, the same strictness-signature-fixup code+gives the function a new strictness signature with the right number of+arguments.  Example in stranal/should_compile/EtaExpansion.++Note [Setting the demand info]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If the unfolding is a value, the demand info may+go pear-shaped, so we nuke it.  Example:+     let x = (a,b) in+     case x of (p,q) -> h p q x+Here x is certainly demanded. But after we've nuked+the case, we'll get just+     let x = (a,b) in h a b x+and now x is not demanded (I'm assuming h is lazy)+This really happens.  Similarly+     let f = \x -> e in ...f..f...+After inlining f at some of its call sites the original binding may+(for example) be no longer strictly demanded.+The solution here is a bit ad hoc...++Note [Use occ-anald RHS in postInlineUnconditionally]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we postInlineUnconditionally 'f in+  let f = \x -> x True in ...(f blah)...+then we'd like to inline the /occ-anald/ RHS for 'f'.  If we+use the non-occ-anald version, we'll end up with a+    ...(let x = blah in x True)...+and hence an extra Simplifier iteration.++We already /have/ the occ-anald version in the Unfolding for+the Id.  Well, maybe not /quite/ always.  If the binder is Dead,+postInlineUnconditionally will return True, but we may not have an+unfolding because it's too big. Hence the belt-and-braces `orElse`+in the defn of unf_rhs.  The Nothing case probably never happens.++Note [Environment for simplLetUnfolding]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We need to be rather careful about the static environment in which+we simplify a stable unfolding.  Consider (#24242):++  f x = let y_Xb = ... in+        let step1_Xb {Stable unfolding = ....y_Xb...} = rhs in+         ...++Note that `y_Xb` and `step1_Xb` have the same unique (`Xb`). This can happen;+see Note [Shadowing in Core] in GHC.Core, and Note [Shadowing in the Simplifier].+This is perfectly fine. The `y_Xb` in the stable unfolding of the non-+recursive binding for `step1` refers, of course, to `let y_Xb = ....`.+When simplifying the binder `step1_Xb` we'll give it a new unique, and+extend the static environment with [Xb :-> step1_Xc], say.++But when simplifying step1's stable unfolding, we must use static environment+/before/ simplifying the binder `step1_Xb`; that is, a static envt that maps+[Xb :-> y_Xb], /not/ [Xb :-> step1_Xc].++That is why we pass around a pair `(InId, SimplEnv)` for the binder, keeping+track of the right environment for the unfolding of that InId.  See the type+of `simplLazyBind`, `simplJoinBind`, `completeBind`.++This only matters when we have+  - A non-recursive binding for f+  - has a stable unfolding+  - and that unfolding mentions a variable y+  - that has the same unique as f.+So triggering  a bug here is really hard!++************************************************************************+*                                                                      *+\subsection[Simplify-simplExpr]{The main function: simplExpr}+*                                                                      *+************************************************************************++The reason for this OutExprStuff stuff is that we want to float *after*+simplifying a RHS, not before.  If we do so naively we get quadratic+behaviour as things float out.++To see why it's important to do it after, consider this (real) example:++        let t = f x+        in fst t+==>+        let t = let a = e1+                    b = e2+                in (a,b)+        in fst t+==>+        let a = e1+            b = e2+            t = (a,b)+        in+        a       -- Can't inline a this round, cos it appears twice+==>+        e1++Each of the ==> steps is a round of simplification.  We'd save a+whole round if we float first.  This can cascade.  Consider++        let f = g d+        in \x -> ...f...+==>+        let f = let d1 = ..d.. in \y -> e+        in \x -> ...f...+==>+        let d1 = ..d..+        in \x -> ...(\y ->e)...++Only in this second round can the \y be applied, and it+might do the same again.+-}++simplExpr :: SimplEnv -> CoreExpr -> SimplM CoreExpr+simplExpr !env (Type ty) -- See Note [Bangs in the Simplifier]+  = do { ty' <- simplType env ty  -- See Note [Avoiding space leaks in OutType]+       ; return (Type ty') }++simplExpr env expr+  = simplExprC env expr (mkBoringStop expr_out_ty)+  where+    expr_out_ty :: OutType+    expr_out_ty = substTy env (exprType expr)+    -- NB: Since 'expr' is term-valued, not (Type ty), this call+    --     to exprType will succeed.  exprType fails on (Type ty).++simplExprC :: SimplEnv+           -> InExpr     -- A term-valued expression, never (Type ty)+           -> SimplCont+           -> SimplM OutExpr+        -- Simplify an expression, given a continuation+simplExprC env expr cont+  = -- pprTrace "simplExprC" (ppr expr $$ ppr cont) $+    do  { (floats, expr') <- simplExprF env expr cont+        ; -- pprTrace "simplExprC ret" (ppr expr $$ ppr expr') $+          -- pprTrace "simplExprC ret3" (ppr (seInScope env')) $+          -- pprTrace "simplExprC ret4" (ppr (seLetFloats env')) $+          return (wrapFloats floats expr') }++--------------------------------------------------+simplExprF :: SimplEnv+           -> InExpr     -- A term-valued expression, never (Type ty)+           -> SimplCont+           -> SimplM (SimplFloats, OutExpr)++simplExprF !env e !cont -- See Note [Bangs in the Simplifier]+  = -- pprTrace "simplExprF" (vcat+    --  [ ppr e+    --  , text "cont =" <+> ppr cont+    --  , text "inscope =" <+> ppr (seInScope env)+    --  , text "tvsubst =" <+> ppr (seTvSubst env)+    --  , text "idsubst =" <+> ppr (seIdSubst env)+    --  , text "cvsubst =" <+> ppr (seCvSubst env)+    --  ]) $+    simplExprF1 env e cont++simplExprF1 :: HasDebugCallStack+            => SimplEnv -> InExpr -> SimplCont+            -> SimplM (SimplFloats, OutExpr)++simplExprF1 _ (Type ty) cont+  = pprPanic "simplExprF: type" (ppr ty <+> text"cont: " <+> ppr cont)+    -- simplExprF does only with term-valued expressions+    -- The (Type ty) case is handled separately by simplExpr+    -- and by the other callers of simplExprF++simplExprF1 env (Var v)        cont = {-#SCC "simplInId" #-} simplInId env v cont+simplExprF1 env (Lit lit)      cont = {-#SCC "rebuild" #-} rebuild env (Lit lit) cont+simplExprF1 env (Tick t expr)  cont = {-#SCC "simplTick" #-} simplTick env t expr cont+simplExprF1 env (Cast body co) cont = {-#SCC "simplCast" #-} simplCast env body co cont+simplExprF1 env (Coercion co)  cont = {-#SCC "simplCoercionF" #-} simplCoercionF env co cont++simplExprF1 env (App fun arg) cont+  = {-#SCC "simplExprF1-App" #-} case arg of+      Type ty -> do { -- The argument type will (almost) certainly be used+                      -- in the output program, so just force it now.+                      -- See Note [Avoiding space leaks in OutType]+                      arg' <- simplType env ty++                      -- But use substTy, not simplType, to avoid forcing+                      -- the hole type; it will likely not be needed.+                      -- See Note [The hole type in ApplyToTy]+                    ; let hole' = substTy env (exprType fun)++                    ; simplExprF env fun $+                      ApplyToTy { sc_arg_ty  = arg'+                                , sc_hole_ty = hole'+                                , sc_cont    = cont } }+      _       ->+          -- Crucially, sc_hole_ty is a /lazy/ binding.  It will+          -- be forced only if we need to run contHoleType.+          -- When these are forced, we might get quadratic behavior;+          -- this quadratic blowup could be avoided by drilling down+          -- to the function and getting its multiplicities all at once+          -- (instead of one-at-a-time). But in practice, we have not+          -- observed the quadratic behavior, so this extra entanglement+          -- seems not worthwhile.+        simplExprF env fun $+        ApplyToVal { sc_arg = arg, sc_env = env+                   , sc_hole_ty = substTy env (exprType fun)+                   , sc_dup = NoDup, sc_cont = cont }++simplExprF1 env expr@(Lam {}) cont+  = {-#SCC "simplExprF1-Lam" #-}+    simplLam env (zapLambdaBndrs expr n_args) cont+        -- zapLambdaBndrs: the issue here is under-saturated lambdas+        --   (\x1. \x2. e) arg1+        -- Here x1 might have "occurs-once" occ-info, because occ-info+        -- is computed assuming that a group of lambdas is applied+        -- all at once.  If there are too few args, we must zap the+        -- occ-info, UNLESS the remaining binders are one-shot+  where+    n_args = countArgs cont+        -- NB: countArgs counts all the args (incl type args)+        -- and likewise drop counts all binders (incl type lambdas)++simplExprF1 env (Case scrut bndr _ alts) cont+  = {-#SCC "simplExprF1-Case" #-}+    simplExprF env scrut (Select { sc_dup = NoDup, sc_bndr = bndr+                                 , sc_alts = alts+                                 , sc_env = env, sc_cont = cont })++simplExprF1 env (Let (Rec pairs) body) cont+  | Just pairs' <- joinPointBindings_maybe pairs+  = {-#SCC "simplRecJoinPoin" #-} simplRecJoinPoint env pairs' body cont++  | otherwise+  = {-#SCC "simplRecE" #-} simplRecE env pairs body cont++simplExprF1 env (Let (NonRec bndr rhs) body) cont+  | Type ty <- rhs    -- First deal with type lets (let a = Type ty in e)+  = {-#SCC "simplExprF1-NonRecLet-Type" #-}+    assert (isTyVar bndr) $+    do { ty' <- simplType env ty+       ; simplExprF (extendTvSubst env bndr ty') body cont }++  | Just env' <- preInlineUnconditionally env NotTopLevel bndr rhs env+    -- Because of the let-can-float invariant, it's ok to+    -- inline freely, or to drop the binding if it is dead.+  = do { simplTrace "SimplBindr:inline-uncond2" (ppr bndr) $+         tick (PreInlineUnconditionally bndr)+       ; simplExprF env' body cont }++  -- Now check for a join point.  It's better to do the preInlineUnconditionally+  -- test first, because joinPointBinding_maybe has to eta-expand, so a trivial+  -- binding like { j = j2 |> co } would first be eta-expanded and then inlined+  -- Better to test preInlineUnconditionally first.+  | Just (bndr', rhs') <- joinPointBinding_maybe bndr rhs+  = {-#SCC "simplNonRecJoinPoint" #-}+    simplNonRecJoinPoint env bndr' rhs' body cont++  | otherwise+  = {-#SCC "simplNonRecE" #-}+    simplNonRecE env FromLet bndr (rhs, env) body cont++{- Note [Avoiding space leaks in OutType]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Since the simplifier is run for multiple iterations, we need to ensure+that any thunks in the output of one simplifier iteration are forced+by the evaluation of the next simplifier iteration. Otherwise we may+retain multiple copies of the Core program and leak a terrible amount+of memory (as in #13426).++The simplifier is naturally strict in the entire "Expr part" of the+input Core program, because any expression may contain binders, which+we must find in order to extend the SimplEnv accordingly. But types+do not contain binders and so it is tempting to write things like++    simplExpr env (Type ty) = return (Type (substTy env ty))   -- Bad!++This is Bad because the result includes a thunk (substTy env ty) which+retains a reference to the whole simplifier environment; and the next+simplifier iteration will not force this thunk either, because the+line above is not strict in ty.++So instead our strategy is for the simplifier to fully evaluate+OutTypes when it emits them into the output Core program, for example++    simplExpr env (Type ty) = do { ty' <- simplType env ty     -- Good+                                 ; return (Type ty') }++where the only difference from above is that simplType calls seqType+on the result of substTy.++However, SimplCont can also contain OutTypes and it's not necessarily+a good idea to force types on the way in to SimplCont, because they+may end up not being used and forcing them could be a lot of wasted+work. T5631 is a good example of this.++- For ApplyToTy's sc_arg_ty, we force the type on the way in because+  the type will almost certainly appear as a type argument in the+  output program.++- For the hole types in Stop and ApplyToTy, we force the type when we+  emit it into the output program, after obtaining it from+  contResultType. (The hole type in ApplyToTy is only directly used+  to form the result type in a new Stop continuation.)+-}++---------------------------------+-- Simplify a join point, adding the context.+-- Context goes *inside* the lambdas. IOW, if the join point has arity n, we do:+--   \x1 .. xn -> e => \x1 .. xn -> E[e]+-- Note that we need the arity of the join point, since e may be a lambda+-- (though this is unlikely). See Note [Join points and case-of-case].+simplJoinRhs :: SimplEnv -> InId -> InExpr -> SimplCont+             -> SimplM OutExpr+simplJoinRhs env bndr expr cont+  | JoinPoint arity <- idJoinPointHood bndr+  =  do { let (join_bndrs, join_body) = collectNBinders arity expr+              mult = contHoleScaling cont+        ; (env', join_bndrs') <- simplLamBndrs env (map (scaleVarBy mult) join_bndrs)+        ; join_body' <- simplExprC env' join_body cont+        ; return $ mkLams join_bndrs' join_body' }++  | otherwise+  = pprPanic "simplJoinRhs" (ppr bndr)++---------------------------------+simplType :: SimplEnv -> InType -> SimplM OutType+        -- Kept monadic just so we can do the seqType+        -- See Note [Avoiding space leaks in OutType]+simplType env ty+  = -- pprTrace "simplType" (ppr ty $$ ppr (seTvSubst env)) $+    seqType new_ty `seq` return new_ty+  where+    new_ty = substTy env ty++---------------------------------+simplCoercionF :: SimplEnv -> InCoercion -> SimplCont+               -> SimplM (SimplFloats, OutExpr)+simplCoercionF env co cont+  = do { co' <- simplCoercion env co+       ; rebuild env (Coercion co') cont }++simplCoercion :: SimplEnv -> InCoercion -> SimplM OutCoercion+simplCoercion env co+  = do { let opt_co | reSimplifying env = substCo env co+                    | otherwise         = optCoercion opts subst co+             -- If (reSimplifying env) is True we have already simplified+             -- this coercion once, and we don't want do so again; doing+             -- so repeatedly risks non-linear behaviour+             -- See Note [Inline depth] in GHC.Core.Opt.Simplify.Env+       ; seqCo opt_co `seq` return opt_co }+  where+    subst = getTCvSubst env+    opts  = seOptCoercionOpts env++-----------------------------------+-- | Push a TickIt context outwards past applications and cases, as+-- long as this is a non-scoping tick, to let case and application+-- optimisations apply.++simplTick :: SimplEnv -> CoreTickish -> InExpr -> SimplCont+          -> SimplM (SimplFloats, OutExpr)+simplTick env tickish expr cont+  -- A scoped tick turns into a continuation, so that we can spot+  -- (scc t (\x . e)) in simplLam and eliminate the scc.  If we didn't do+  -- it this way, then it would take two passes of the simplifier to+  -- reduce ((scc t (\x . e)) e').+  -- NB, don't do this with counting ticks, because if the expr is+  -- bottom, then rebuildCall will discard the continuation.++--------------------------+--  | tickishScoped tickish && not (tickishCounts tickish)+--  = simplExprF env expr (TickIt tickish cont)+-- XXX: we cannot do this, because the simplifier assumes that+-- the context can be pushed into a case with a single branch. e.g.+--    scc<f>  case expensive of p -> e+-- becomes+--    case expensive of p -> scc<f> e+--+-- So I'm disabling this for now.  It just means we will do more+-- simplifier iterations that necessary in some cases.+--------------------------++  -- For unscoped or soft-scoped ticks, we are allowed to float in new+  -- cost, so we simply push the continuation inside the tick.  This+  -- has the effect of moving the tick to the outside of a case or+  -- application context, allowing the normal case and application+  -- optimisations to fire.+  | tickish `tickishScopesLike` SoftScope+  = do { (floats, expr') <- simplExprF env expr cont+       ; return (floats, mkTick tickish expr')+       }++  -- Push tick inside if the context looks like this will allow us to+  -- do a case-of-case - see Note [case-of-scc-of-case]+  | Select {} <- cont, Just expr' <- push_tick_inside+  = simplExprF env expr' cont++  -- We don't want to move the tick, but we might still want to allow+  -- floats to pass through with appropriate wrapping (or not, see+  -- wrap_floats below)+  --- | not (tickishCounts tickish) || tickishCanSplit tickish+  -- = wrap_floats++  | otherwise+  = no_floating_past_tick++ where++  -- Try to push tick inside a case, see Note [case-of-scc-of-case].+  push_tick_inside =+    case expr0 of+      Case scrut bndr ty alts+             -> Just $ Case (tickScrut scrut) bndr ty (map tickAlt alts)+      _other -> Nothing+   where (ticks, expr0) = stripTicksTop movable (Tick tickish expr)+         movable t      = not (tickishCounts t) ||+                          t `tickishScopesLike` NoScope ||+                          tickishCanSplit t+         tickScrut e    = foldr mkTick e ticks+         -- Alternatives get annotated with all ticks that scope in some way,+         -- but we don't want to count entries.+         tickAlt (Alt c bs e) = Alt c bs (foldr mkTick e ts_scope)+         ts_scope         = map mkNoCount $+                            filter (not . (`tickishScopesLike` NoScope)) ticks++  no_floating_past_tick =+    do { let (inc,outc) = splitCont cont+       ; (floats, expr1) <- simplExprF env expr inc+       ; let expr2    = wrapFloats floats expr1+             tickish' = simplTickish env tickish+       ; rebuild env (mkTick tickish' expr2) outc+       }++-- Alternative version that wraps outgoing floats with the tick.  This+-- results in ticks being duplicated, as we don't make any attempt to+-- eliminate the tick if we re-inline the binding (because the tick+-- semantics allows unrestricted inlining of HNFs), so I'm not doing+-- this any more.  FloatOut will catch any real opportunities for+-- floating.+--+--  wrap_floats =+--    do { let (inc,outc) = splitCont cont+--       ; (env', expr') <- simplExprF (zapFloats env) expr inc+--       ; let tickish' = simplTickish env tickish+--       ; let wrap_float (b,rhs) = (zapIdDmdSig (setIdArity b 0),+--                                   mkTick (mkNoCount tickish') rhs)+--              -- when wrapping a float with mkTick, we better zap the Id's+--              -- strictness info and arity, because it might be wrong now.+--       ; let env'' = addFloats env (mapFloats env' wrap_float)+--       ; rebuild env'' expr' (TickIt tickish' outc)+--       }+++  simplTickish env tickish+    | Breakpoint ext bid ids <- tickish+          = Breakpoint ext bid (mapMaybe (getDoneId . substId env) ids)+    | otherwise = tickish++  -- Push type application and coercion inside a tick+  splitCont :: SimplCont -> (SimplCont, SimplCont)+  splitCont cont@(ApplyToTy { sc_cont = tail }) = (cont { sc_cont = inc }, outc)+    where (inc,outc) = splitCont tail+  splitCont cont@(CastIt { sc_cont = tail }) = (cont { sc_cont = inc }, outc)+    where (inc,outc) = splitCont tail+  splitCont other = (mkBoringStop (contHoleType other), other)++  getDoneId (DoneId id)  = Just id+  getDoneId (DoneEx (Var id) _) = Just id+  getDoneId (DoneEx e _) = getIdFromTrivialExpr_maybe e -- Note [substTickish] in GHC.Core.Subst+  getDoneId other = pprPanic "getDoneId" (ppr other)++-- Note [case-of-scc-of-case]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~+-- It's pretty important to be able to transform case-of-case when+-- there's an SCC in the way.  For example, the following comes up+-- in nofib/real/compress/Encode.hs:+--+--        case scctick<code_string.r1>+--             case $wcode_string_r13s wild_XC w1_s137 w2_s138 l_aje+--             of _ { (# ww1_s13f, ww2_s13g, ww3_s13h #) ->+--             (ww1_s13f, ww2_s13g, ww3_s13h)+--             }+--        of _ { (ww_s12Y, ww1_s12Z, ww2_s130) ->+--        tick<code_string.f1>+--        (ww_s12Y,+--         ww1_s12Z,+--         PTTrees.PT+--           @ GHC.Types.Char @ GHC.Types.Int wild2_Xj ww2_s130 r_ajf)+--        }+--+-- We really want this case-of-case to fire, because then the 3-tuple+-- will go away (indeed, the CPR optimisation is relying on this+-- happening).  But the scctick is in the way - we need to push it+-- inside to expose the case-of-case.  So we perform this+-- transformation on the inner case:+--+--   scctick c (case e of { p1 -> e1; ...; pn -> en })+--    ==>+--   case (scctick c e) of { p1 -> scc c e1; ...; pn -> scc c en }+--+-- So we've moved a constant amount of work out of the scc to expose+-- the case.  We only do this when the continuation is interesting: in+-- for now, it has to be another Case (maybe generalise this later).++{-+************************************************************************+*                                                                      *+\subsection{The main rebuilder}+*                                                                      *+************************************************************************+-}++rebuild :: SimplEnv -> OutExpr -> SimplCont -> SimplM (SimplFloats, OutExpr)+rebuild env expr cont = rebuild_go (zapSubstEnv env) expr cont++rebuild_go :: SimplEnvIS -> OutExpr -> SimplCont -> SimplM (SimplFloats, OutExpr)+-- SimplEnvIS: at this point the substitution in the SimplEnv is irrelevant;+-- only the in-scope set matters, plus the flags.+rebuild_go env expr cont+  = assertPpr (checkSimplEnvIS env) (pprBadSimplEnvIS env) $+    case cont of+      Stop {}          -> return (emptyFloats env, expr)+      TickIt t cont    -> rebuild_go env (mkTick t expr) cont+      CastIt { sc_co = co, sc_opt = opt, sc_cont = cont }+        -> rebuild_go env (mkCast expr co') cont+           -- NB: mkCast implements the (Coercion co |> g) optimisation+        where+          co' = optOutCoercion env co opt++      Select { sc_bndr = bndr, sc_alts = alts, sc_env = se, sc_cont = cont }+        -> rebuildCase (se `setInScopeFromE` env) expr bndr alts cont++      StrictArg { sc_fun = fun, sc_cont = cont, sc_fun_ty = fun_ty }+        -> rebuildCall env (addValArgTo fun expr fun_ty) cont++      StrictBind { sc_bndr = b, sc_body = body, sc_env = se+                 , sc_cont = cont, sc_from = from_what }+        -> completeBindX (se `setInScopeFromE` env) from_what b expr body cont++      ApplyToTy  { sc_arg_ty = ty, sc_cont = cont}+        -> rebuild_go env (App expr (Type ty)) cont++      ApplyToVal { sc_arg = arg, sc_env = se, sc_dup = dup_flag+                 , sc_cont = cont, sc_hole_ty = fun_ty }+        -- See Note [Avoid redundant simplification]+        -> do { (_, _, arg') <- simplLazyArg env dup_flag fun_ty Nothing se arg+              ; rebuild_go env (App expr arg') cont }++completeBindX :: SimplEnv+              -> FromWhat+              -> InId -> OutExpr   -- Non-recursively bind this Id to this (simplified) expression+                                   -- (the let-can-float invariant may not be satisfied)+              -> InExpr            -- In this body+              -> SimplCont         -- Consumed by this continuation+              -> SimplM (SimplFloats, OutExpr)+completeBindX env from_what bndr rhs body cont+  | FromBeta arg_levity <- from_what+  , needsCaseBindingL arg_levity rhs -- Enforcing the let-can-float-invariant+  = do { (env1, bndr1)   <- simplNonRecBndr env bndr  -- Lambda binders don't have rules+       ; (floats, expr') <- simplNonRecBody env1 from_what body cont+       -- Do not float floats past the Case binder below+       ; let expr'' = wrapFloats floats expr'+             case_expr = Case rhs bndr1 (contResultType cont) [Alt DEFAULT [] expr'']+       ; return (emptyFloats env, case_expr) }++  | otherwise -- Make a let-binding+  = do  { (env1, bndr1) <- simplNonRecBndr env bndr+        ; (env2, bndr2) <- addBndrRules env1 bndr bndr1 (BC_Let NotTopLevel NonRecursive)++        ; let is_strict = isStrictId bndr2+              -- isStrictId: use simplified binder because the InId bndr might not have+              -- a fixed runtime representation, which isStrictId doesn't expect+              -- c.f. Note [Dark corner with representation polymorphism]++        ; (rhs_floats, rhs1) <- prepareBinding env NotTopLevel NonRecursive is_strict+                                               bndr2 (emptyFloats env) rhs+              -- NB: it makes a surprisingly big difference (5% in compiler allocation+              -- in T9630) to pass 'env' rather than 'env1'.  It's fine to pass 'env',+              -- because this is completeBindX, so bndr is not in scope in the RHS.++        ; let env3 = env2 `setInScopeFromF` rhs_floats+        ; (bind_float, env4) <- completeBind (BC_Let NotTopLevel NonRecursive)+                                             (bndr,env) (bndr2, rhs1, env3)+              -- Must pass env1 to completeBind in case simplBinder had to clone,+              -- and extended the substitution with [bndr :-> new_bndr]++        -- Simplify the body+        ; (body_floats, body') <- simplNonRecBody env4 from_what body cont++        ; let all_floats = rhs_floats `addFloats` bind_float `addFloats` body_floats+        ; return ( all_floats, body' ) }++{-+************************************************************************+*                                                                      *+\subsection{Lambdas}+*                                                                      *+************************************************************************+-}++{- Note [Optimising reflexivity]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It's important (for compiler performance) to get rid of reflexivity as soon+as it appears.  See #11735, #14737, and #15019.++In particular, we want to behave well on++ *  e |> co1 |> co2+    where the two happen to cancel out entirely. That is quite common;+    e.g. a newtype wrapping and unwrapping cancel.+++ * (f |> co) @t1 @t2 ... @tn x1 .. xm+   Here we will use pushCoTyArg and pushCoValArg successively, which+   build up SelCo stacks.  Silly to do that if co is reflexive.++However, we don't want to call isReflexiveCo too much, because it uses+type equality which is expensive on big types (#14737 comment:7).++A good compromise (determined experimentally) seems to be to call+isReflexiveCo+ * when composing casts, and+ * at the end++In investigating this I saw missed opportunities for on-the-fly+coercion shrinkage. See #15090.++Note [Avoid re-simplifying coercions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In some benchmarks (with deeply nested cases) we successively push+casts onto the SimplCont.  We don't want to call the coercion optimiser+on each successive composition -- that's at least quadratic.  So:++* The CastIt constructor in SimplCont has a `sc_opt :: Bool` flag to+  record whether the coercion optimiser has been applied to the coercion.++* In `simplCast`, when we see (Cast e co), we simplify `co` to get+  an OutCoercion, and built a CastIt with sc_opt=True.++  Actually not quite: if we are simplifying the result of inlining an+  unfolding (seInlineDepth > 0), then instead of /optimising/ it again,+  just /substitute/ which is cheaper.  See `simplCoercion`.++* In `addCoerce` (in `simplCast`) if we combine this new coercion with+  an existing once, we build a CastIt for (co1 ; co2) with sc_opt=False.++* When unpacking a CastIt, in `rebuildCall` and `rebuild`, we optimise+  the (presumably composed) coercion if sc_opt=False; this is done+  by `optOutCoercion`.++* When duplicating a continuation in `mkDupableContWithDmds`, before+  duplicating a CastIt, optimise the coercion. Otherwise we'll end up+  optimising it separately in the duplicate copies.+-}+++optOutCoercion :: SimplEnvIS -> OutCoercion -> Bool -> OutCoercion+-- See Note [Avoid re-simplifying coercions]+optOutCoercion env co already_optimised+  | already_optimised = co  -- See Note [Avoid re-simplifying coercions]+  | otherwise         = optCoercion opts empty_subst co+  where+    empty_subst = mkEmptySubst (seInScope env)+    opts = seOptCoercionOpts env++simplCast :: SimplEnv -> InExpr -> InCoercion -> SimplCont+          -> SimplM (SimplFloats, OutExpr)+simplCast env body co0 cont0+  = do  { co1   <- {-#SCC "simplCast-simplCoercion" #-} simplCoercion env co0+        ; cont1 <- {-#SCC "simplCast-addCoerce" #-}+                   if isReflCo co1+                   then return cont0  -- See Note [Optimising reflexivity]+                   else addCoerce co1 True cont0+                        -- True <=> co1 is optimised+        ; {-#SCC "simplCast-simplExprF" #-} simplExprF env body cont1 }+  where++        -- If the first parameter is MRefl, then simplifying revealed a+        -- reflexive coercion. Omit.+        addCoerceM :: MOutCoercion -> Bool -> SimplCont -> SimplM SimplCont+        addCoerceM MRefl    _   cont = return cont+        addCoerceM (MCo co) opt cont = addCoerce co opt cont++        addCoerce :: OutCoercion -> Bool -> SimplCont -> SimplM SimplCont+        addCoerce co1 _ (CastIt { sc_co = co2, sc_cont = cont })  -- See Note [Optimising reflexivity]+          = addCoerce (mkTransCo co1 co2) False cont+                      -- False: (mkTransCo co1 co2) is not fully optimised+                      -- See Note [Avoid re-simplifying coercions]++        addCoerce co opt (ApplyToTy { sc_arg_ty = arg_ty, sc_cont = tail })+          | Just (arg_ty', m_co') <- pushCoTyArg co arg_ty+          = {-#SCC "addCoerce-pushCoTyArg" #-}+            do { tail' <- addCoerceM m_co' opt tail+               ; return (ApplyToTy { sc_arg_ty  = arg_ty'+                                   , sc_cont    = tail'+                                   , sc_hole_ty = coercionLKind co }) }+                                        -- NB!  As the cast goes past, the+                                        -- type of the hole changes (#16312)+        -- (f |> co) e   ===>   (f (e |> co1)) |> co2+        -- where   co :: (s1->s2) ~ (t1->t2)+        --         co1 :: t1 ~ s1+        --         co2 :: s2 ~ t2+        addCoerce co opt cont@(ApplyToVal { sc_arg = arg, sc_env = arg_se+                                          , sc_dup = dup, sc_cont = tail+                                          , sc_hole_ty = fun_ty })+          | not opt  -- pushCoValArg duplicates the coercion, so optimise first+          = addCoerce (optOutCoercion (zapSubstEnv env) co opt) True cont++          | Just (m_co1, m_co2) <- pushCoValArg co+          , fixed_rep m_co1+          = {-#SCC "addCoerce-pushCoValArg" #-}+            do { tail' <- addCoerceM m_co2 opt tail+               ; case m_co1 of {+                   MRefl -> return (cont { sc_cont = tail'+                                         , sc_hole_ty = coercionLKind co }) ;+                      -- See Note [Avoiding simplifying repeatedly]++                   MCo co1 ->+            do { (dup', arg_se', arg') <- simplLazyArg env dup fun_ty Nothing arg_se arg+                    -- When we build the ApplyTo we can't mix the OutCoercion+                    -- 'co' with the InExpr 'arg', so we simplify+                    -- to make it all consistent.  It's a bit messy.+                    -- But it isn't a common case.+                    -- Example of use: #995+               ; return (ApplyToVal { sc_arg  = mkCast arg' co1+                                    , sc_env  = arg_se'+                                    , sc_dup  = dup'+                                    , sc_cont = tail'+                                    , sc_hole_ty = coercionLKind co }) } } }++        addCoerce co opt cont+          | isReflCo co = return cont  -- Having this at the end makes a huge+                                       -- difference in T12227, for some reason+                                       -- See Note [Optimising reflexivity]+          | otherwise = return (CastIt { sc_co = co, sc_opt = opt, sc_cont = cont })++        fixed_rep :: MCoercionR -> Bool+        fixed_rep MRefl    = True+        fixed_rep (MCo co) = typeHasFixedRuntimeRep $ coercionRKind co+          -- Without this check, we can get an argument which does not+          -- have a fixed runtime representation.+          -- See Note [Representation polymorphism invariants] in GHC.Core+          -- test: typecheck/should_run/EtaExpandLevPoly++simplLazyArg :: SimplEnvIS              -- ^ Used only for its InScopeSet+             -> DupFlag+             -> OutType                 -- ^ Type of the function applied to this arg+             -> Maybe ArgInfo           -- ^ Just <=> This arg `ai` occurs in an app+                                        --   `f a1 ... an` where we have ArgInfo on+                                        --   how `f` uses `ai`, affecting the Stop+                                        --   continuation passed to 'simplExprC'+             -> StaticEnv -> CoreExpr   -- ^ Expression with its static envt+             -> SimplM (DupFlag, StaticEnv, OutExpr)+simplLazyArg env dup_flag fun_ty mb_arg_info arg_env arg+  | isSimplified dup_flag+  = return (dup_flag, arg_env, arg)+  | otherwise+  = do { let arg_env' = arg_env `setInScopeFromE` env+       ; let arg_ty = funArgTy fun_ty+       ; let stop = case mb_arg_info of+               Nothing -> mkBoringStop arg_ty+               Just ai -> mkLazyArgStop arg_ty ai+       ; arg' <- simplExprC arg_env' arg stop+       ; return (Simplified, zapSubstEnv arg_env', arg') }+         -- Return a StaticEnv that includes the in-scope set from 'env',+         -- because arg' may well mention those variables (#20639)++{-+************************************************************************+*                                                                      *+\subsection{Lambdas}+*                                                                      *+************************************************************************+-}++simplNonRecBody :: SimplEnv -> FromWhat+                -> InExpr -> SimplCont+                -> SimplM (SimplFloats, OutExpr)+simplNonRecBody env from_what body cont+  = case from_what of+      FromLet     -> simplExprF env body cont+      FromBeta {} -> simplLam   env body cont++simplLam :: SimplEnv -> InExpr -> SimplCont+         -> SimplM (SimplFloats, OutExpr)++simplLam env (Lam bndr body) cont = simpl_lam env bndr body cont+simplLam env expr            cont = simplExprF env expr cont++simpl_lam :: HasDebugCallStack+          => SimplEnv -> InBndr -> InExpr -> SimplCont+          -> SimplM (SimplFloats, OutExpr)++-- Type beta-reduction+simpl_lam env bndr body (ApplyToTy { sc_arg_ty = arg_ty, sc_cont = cont })+  = do { tick (BetaReduction bndr)+       ; simplLam (extendTvSubst env bndr arg_ty) body cont }++-- Coercion beta-reduction+simpl_lam env bndr body (ApplyToVal { sc_arg = Coercion arg_co, sc_env = arg_se+                                    , sc_cont = cont })+  = assertPpr (isCoVar bndr) (ppr bndr) $+    do { tick (BetaReduction bndr)+       ; let arg_co' = substCo (arg_se `setInScopeFromE` env) arg_co+       ; simplLam (extendCvSubst env bndr arg_co') body cont }++-- Value beta-reduction+-- This works for /coercion/ lambdas too+simpl_lam env bndr body (ApplyToVal { sc_arg = arg, sc_env = arg_se+                                    , sc_cont = cont, sc_dup = dup+                                    , sc_hole_ty = fun_ty})+  = do { tick (BetaReduction bndr)+       ; let from_what = FromBeta arg_levity+             arg_levity+               | isForAllTy fun_ty = assertPpr (isCoVar bndr) (ppr bndr) Unlifted+               | otherwise         = typeLevity (funArgTy fun_ty)+             -- Example:  (\(cv::a ~# b). blah) co+             -- The type of (\cv.blah) can be (forall cv. ty); see GHC.Core.Utils.mkLamType++             -- Using fun_ty: see Note [Dark corner with representation polymorphism]+             -- e.g  (\r \(a::TYPE r) \(x::a). blah) @LiftedRep @Int arg+             --      When we come to `x=arg` we must choose lazy/strict correctly+             --      It's wrong to err in either direction+             --      But fun_ty is an OutType, so is fully substituted++       ; if | Just env' <- preInlineUnconditionally env NotTopLevel bndr arg arg_se+            , not (needsCaseBindingL arg_levity arg)+              -- Ok to test arg::InExpr in needsCaseBinding because+              -- exprOkForSpeculation is stable under simplification+            , not ( isSimplified dup &&  -- See (SR2) in Note [Avoiding simplifying repeatedly]+                    not (exprIsTrivial arg) &&+                    not (isDeadOcc (idOccInfo bndr)) )+            -> do { simplTrace "SimplBindr:inline-uncond3" (ppr bndr) $+                    tick (PreInlineUnconditionally bndr)+                  ; simplLam env' body cont }++            | isSimplified dup  -- Don't re-simplify if we've simplified it once+                                -- Including don't preInlineUnconditionally+                                -- See Note [Avoiding simplifying repeatedly]+            -> completeBindX env from_what bndr arg body cont++            | otherwise+            -> simplNonRecE env from_what bndr (arg, arg_se) body cont }++-- Discard a non-counting tick on a lambda.  This may change the+-- cost attribution slightly (moving the allocation of the+-- lambda elsewhere), but we don't care: optimisation changes+-- cost attribution all the time.+simpl_lam env bndr body (TickIt tickish cont)+  | not (tickishCounts tickish)+  = simpl_lam env bndr body cont++-- Not enough args, so there are real lambdas left to put in the result+simpl_lam env bndr body cont+  = do  { let (inner_bndrs, inner_body) = collectBinders body+        ; (env', bndrs') <- simplLamBndrs env (bndr:inner_bndrs)+        ; body'   <- simplExpr env' inner_body+        ; new_lam <- rebuildLam env' bndrs' body' cont+        ; rebuild env' new_lam cont }++-------------+simplLamBndr :: SimplEnv -> InBndr -> SimplM (SimplEnv, OutBndr)+-- Historically this had a special case for when a lambda-binder+-- could have a stable unfolding;+-- see Historical Note [Case binders and join points]+-- But now it is much simpler! We now only remove unfoldings.+-- See Note [Never put `OtherCon` unfoldings on lambda binders]+simplLamBndr env bndr = simplBinder env (zapIdUnfolding bndr)++simplLamBndrs :: SimplEnv -> [InBndr] -> SimplM (SimplEnv, [OutBndr])+simplLamBndrs env bndrs = mapAccumLM simplLamBndr env bndrs++------------------+simplNonRecE :: HasDebugCallStack+             => SimplEnv+             -> FromWhat+             -> InId               -- The binder, always an Id+                                   -- Never a join point+                                   -- The static env for its unfolding (if any) is the first parameter+             -> (InExpr, SimplEnv) -- Rhs of binding (or arg of lambda)+             -> InExpr             -- Body of the let/lambda+             -> SimplCont+             -> SimplM (SimplFloats, OutExpr)++-- simplNonRecE is used for+--  * from=FromLet:  a non-top-level non-recursive non-join-point let-expression+--  * from=FromBeta: a binding arising from a beta reduction+--+-- simplNonRecE env b (rhs, rhs_se) body k+--   = let env in+--     cont< let b = rhs_se(rhs) in body >+--+-- It deals with strict bindings, via the StrictBind continuation,+-- which may abort the whole process.+--+-- from_what=FromLet => the RHS satisfies the let-can-float invariant+-- Otherwise it may or may not satisfy it.++simplNonRecE env from_what bndr (rhs, rhs_se) body cont+  | assert (isId bndr && not (isJoinId bndr) ) $+    is_strict_bind+  = -- Evaluate RHS strictly+    simplExprF (rhs_se `setInScopeFromE` env) rhs+               (StrictBind { sc_bndr = bndr, sc_body = body, sc_from = from_what+                           , sc_env = env, sc_cont = cont, sc_dup = NoDup })++  | otherwise  -- Evaluate RHS lazily+  = do { (env1, bndr1)    <- simplNonRecBndr env bndr+       ; (env2, bndr2)    <- addBndrRules env1 bndr bndr1 (BC_Let NotTopLevel NonRecursive)+       ; (floats1, env3)  <- simplLazyBind NotTopLevel NonRecursive+                                           (bndr,env) (bndr2,env2) (rhs,rhs_se)+       ; (floats2, expr') <- simplNonRecBody env3 from_what body cont+       ; return (floats1 `addFloats` floats2, expr') }++  where+    is_strict_bind = case from_what of+       FromBeta Unlifted -> True+       -- If we are coming from a beta-reduction (FromBeta) we must+       -- establish the let-can-float invariant, so go via StrictBind+       -- If not, the invariant holds already, and it's optional.++       -- (FromBeta Lifted) or FromLet: look at the demand info+       _ -> seCaseCase env && isStrUsedDmd (idDemandInfo bndr)+++------------------+simplRecE :: SimplEnv+          -> [(InId, InExpr)]+          -> InExpr+          -> SimplCont+          -> SimplM (SimplFloats, OutExpr)++-- simplRecE is used for+--  * non-top-level recursive lets in expressions+-- Precondition: not a join-point binding+simplRecE env pairs body cont+  = do  { let bndrs = map fst pairs+        ; massert (all (not . isJoinId) bndrs)+        ; env1 <- simplRecBndrs env bndrs+                -- NB: bndrs' don't have unfoldings or rules+                -- We add them as we go down+        ; (floats1, env2)  <- simplRecBind env1 (BC_Let NotTopLevel Recursive) pairs+        ; (floats2, expr') <- simplExprF env2 body cont+        ; return (floats1 `addFloats` floats2, expr') }++{- Note [Dark corner with representation polymorphism]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In `simplNonRecE`, the call to `needsCaseBinding` or to `isStrictId` will fail+if the binder does not have a fixed runtime representation, e.g. if it is of kind (TYPE r).+So we are careful to call `isStrictId` on the OutId, not the InId, in case we have+     ((\(r::RuntimeRep) \(x::TYPE r). blah) Lifted arg)+That will lead to `simplNonRecE env (x::TYPE r) arg`, and we can't tell+if x is lifted or unlifted from that.++We only get such redexes from the compulsory inlining of a wired-in,+representation-polymorphic function like `rightSection` (see+GHC.Types.Id.Make).  Mind you, SimpleOpt should probably have inlined+such compulsory inlinings already, but belt and braces does no harm.++Plus, it turns out that GHC.Driver.Main.hscCompileCoreExpr calls the+Simplifier without first calling SimpleOpt, so anything involving+GHCi or TH and operator sections will fall over if we don't take+care here.++Note [Avoiding simplifying repeatedly]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+One way in which we can get exponential behaviour is if we simplify a+big expression, and then re-simplify it -- and then this happens in a+deeply-nested way.  So we must be jolly careful about re-simplifying+an expression (#13379).++Example:+  f BIG, where f has a RULE+Then+ * We simplify BIG before trying the rule; but the rule does not fire+   (forcing this simplification is why we have the RULE in this example)+ * We inline f = \x. g x, in `simpl_lam`+ * So if `simpl_lam` did preInlineUnconditionally we get (g BIG)+ * Now if g has a RULE we'll simplify BIG again, and this whole thing can+   iterate.+ * However, if `f` did not have a RULE, so that BIG has /not/ already been+   simplified, we /want/ to do preInlineUnconditionally in simpl_lam.++So we go to some effort to avoid repeatedly simplifying the same thing:++* ApplyToVal has a (sc_dup :: DupFlag) field which records if the argument+  has been evaluated.++* simplArg checks this flag to avoid re-simplifying.++* simpl_lam has:+    - a case for (isSimplified dup), which goes via completeBindX, and+    - a case for an un-simplified argument, which tries preInlineUnconditionally++* We go to some efforts to avoid unnecessarily simplifying ApplyToVal,+  in at least two places+    - In simplCast/addCoerce, where we check for isReflCo+    - We sometimes try rewrite RULES befoe simplifying arguments;+      see Note [tryRules: plan (BEFORE)]++Wrinkles:++(SR1) All that said /postInlineUnconditionally/ (called in `completeBind`) does+    fire in the above (f BIG) situation.  See Note [Post-inline for single-use+    things] in Simplify.Utils.  This certainly risks repeated simplification,+    but in practice seems to be a small win.++(SR2) When considering preInlineUnconditionally in `simpl_lam`, if the+   expression is trivial, or it is dead (the binder doesn't occur), then there+   is no danger of simplifying repeatedly. But there is a benefit: it can save+   a simplifier iteration.  So we check for that.+++************************************************************************+*                                                                      *+                     Join points+*                                                                      *+********************************************************************* -}++{- Note [Rules and unfolding for join points]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have++   simplExpr (join j x = rhs                         ) cont+             (      {- RULE j (p:ps) = blah -}       )+             (      {- StableUnfolding j = blah -}   )+             (in blah                                )++Then we will push 'cont' into the rhs of 'j'.  But we should *also* push+'cont' into the RHS of+  * Any RULEs for j, e.g. generated by SpecConstr+  * Any stable unfolding for j, e.g. the result of an INLINE pragma++Simplifying rules and stable-unfoldings happens a bit after+simplifying the right-hand side, so we remember whether or not it+is a join point, and what 'cont' is, in a value of type MaybeJoinCont++#13900 was caused by forgetting to push 'cont' into the RHS+of a SpecConstr-generated RULE for a join point.+-}++simplNonRecJoinPoint :: SimplEnv -> InId -> InExpr+                     -> InExpr -> SimplCont+                     -> SimplM (SimplFloats, OutExpr)+simplNonRecJoinPoint env bndr rhs body cont+   = assert (isJoinId bndr ) $+     wrapJoinCont env cont $ \ env cont ->+     do { -- We push join_cont into the join RHS and the body;+          -- and wrap wrap_cont around the whole thing+        ; let mult   = contHoleScaling cont+              res_ty = contResultType cont+        ; (env1, bndr1)    <- simplNonRecJoinBndr env bndr mult res_ty+        ; (env2, bndr2)    <- addBndrRules env1 bndr bndr1 (BC_Join NonRecursive cont)+        ; (floats1, env3)  <- simplJoinBind NonRecursive cont (bndr,env) (bndr2,env2) (rhs,env)+        ; (floats2, body') <- simplExprF env3 body cont+        ; return (floats1 `addFloats` floats2, body') }+++------------------+simplRecJoinPoint :: SimplEnv -> [(InId, InExpr)]+                  -> InExpr -> SimplCont+                  -> SimplM (SimplFloats, OutExpr)+simplRecJoinPoint env pairs body cont+  = wrapJoinCont env cont $ \ env cont ->+    do { let bndrs  = map fst pairs+             mult   = contHoleScaling cont+             res_ty = contResultType cont+       ; env1 <- simplRecJoinBndrs env bndrs mult res_ty+               -- NB: bndrs' don't have unfoldings or rules+               -- We add them as we go down+       ; (floats1, env2)  <- simplRecBind env1 (BC_Join Recursive cont) pairs+       ; (floats2, body') <- simplExprF env2 body cont+       ; return (floats1 `addFloats` floats2, body') }++--------------------+wrapJoinCont :: SimplEnv -> SimplCont+             -> (SimplEnv -> SimplCont -> SimplM (SimplFloats, OutExpr))+             -> SimplM (SimplFloats, OutExpr)+-- Deal with making the continuation duplicable if necessary,+-- and with the no-case-of-case situation.+wrapJoinCont env cont thing_inside+  | contIsStop cont        -- Common case; no need for fancy footwork+  = thing_inside env cont++  | not (seCaseCase env)+    -- See Note [Join points with -fno-case-of-case]+  = do { (floats1, expr1) <- thing_inside env (mkBoringStop (contHoleType cont))+       ; let (floats2, expr2) = wrapJoinFloatsX floats1 expr1+       ; (floats3, expr3) <- rebuild (env `setInScopeFromF` floats2) expr2 cont+       ; return (floats2 `addFloats` floats3, expr3) }++  | otherwise+    -- Normal case; see Note [Join points and case-of-case]+  = do { (floats1, cont')  <- mkDupableCont env cont+       ; (floats2, result) <- thing_inside (env `setInScopeFromF` floats1) cont'+       ; return (floats1 `addFloats` floats2, result) }+++--------------------+trimJoinCont :: Id         -- Used only in error message+             -> JoinPointHood+             -> SimplCont -> SimplCont+-- Drop outer context from join point invocation (jump)+-- See Note [Join points and case-of-case]++trimJoinCont _ NotJoinPoint cont+  = cont -- Not a jump+trimJoinCont var (JoinPoint arity) cont+  = trim arity cont+  where+    trim 0 cont@(Stop {})+      = cont+    trim 0 cont+      = mkBoringStop (contResultType cont)+    trim n cont@(ApplyToVal { sc_cont = k })+      = cont { sc_cont = trim (n-1) k }+    trim n cont@(ApplyToTy { sc_cont = k })+      = cont { sc_cont = trim (n-1) k } -- join arity counts types!+    trim _ cont+      = pprPanic "completeCall" $ ppr var $$ ppr cont+++{- Note [Join points and case-of-case]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we perform the case-of-case transform (or otherwise push continuations+inward), we want to treat join points specially. Since they're always+tail-called and we want to maintain this invariant, we can do this (for any+evaluation context E):++  E[join j = e+    in case ... of+         A -> jump j 1+         B -> jump j 2+         C -> f 3]++    -->++  join j = E[e]+  in case ... of+       A -> jump j 1+       B -> jump j 2+       C -> E[f 3]++As is evident from the example, there are two components to this behavior:++  1. When entering the RHS of a join point, copy the context inside.+  2. When a join point is invoked, discard the outer context.++We need to be very careful here to remain consistent---neither part is+optional!++We need do make the continuation E duplicable (since we are duplicating it)+with mkDupableCont.+++Note [Join points with -fno-case-of-case]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Supose case-of-case is switched off, and we are simplifying++    case (join j x = <j-rhs> in+          case y of+             A -> j 1+             B -> j 2+             C -> e) of <outer-alts>++Usually, we'd push the outer continuation (case . of <outer-alts>) into+both the RHS and the body of the join point j.  But since we aren't doing+case-of-case we may then end up with this totally bogus result++    join x = case <j-rhs> of <outer-alts> in+    case (case y of+             A -> j 1+             B -> j 2+             C -> e) of <outer-alts>++This would be OK in the language of the paper, but not in GHC: j is no longer+a join point.  We can only do the "push continuation into the RHS of the+join point j" if we also push the continuation right down to the /jumps/ to+j, so that it can evaporate there.  If we are doing case-of-case, we'll get to++    join x = case <j-rhs> of <outer-alts> in+    case y of+      A -> j 1+      B -> j 2+      C -> case e of <outer-alts>++which is great.++Bottom line: if case-of-case is off, we must stop pushing the continuation+inwards altogether at any join point.  Instead simplify the (join ... in ...)+with a Stop continuation, and wrap the original continuation around the+outside.  Surprisingly tricky!+++************************************************************************+*                                                                      *+                     Variables+*                                                                      *+************************************************************************++Note [zapSubstEnv]+~~~~~~~~~~~~~~~~~~+When simplifying something that has already been simplified, be sure to+zap the SubstEnv.  This is VITAL.  Consider+     let x = e in+     let y = \z -> ...x... in+     \ x -> ...y...++We'll clone the inner \x, adding x->x' in the id_subst Then when we+inline y, we must *not* replace x by x' in the inlined copy!!++Note [Fast path for lazy data constructors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For applications of a /lazy/ data constructor worker, the full glory of+rebuildCall is a waste of effort;+* They never inline, obviously+* They have no rewrite rules+* Lazy constructors don't need the `StrictArg` treatment.+So it's fine to zoom straight to `rebuild` which just rebuilds the+call in a very straightforward way.++For a data constructor worker that is strict (see Note [Strict fields in Core])+we take the slow path, so that we'll transform+  K (case x of (a,b) -> a)  -->   case x of (a,b) -> K a+via the StrictArg case of rebuildCall++Some programs have a /lot/ of data constructors in the source program+(compiler/perf/T9961 is an example), so this fast path can be very+valuable.+-}++simplInVar :: SimplEnv -> InVar -> SimplM OutExpr+-- Look up an InVar in the environment+simplInVar env var+  -- Why $! ? See Note [Bangs in the Simplifier]+  | isTyVar var = return $! Type $! (substTyVar env var)+  | isCoVar var = return $! Coercion $! (substCoVar env var)+  | otherwise+  = case substId env var of+        ContEx tvs cvs ids e -> let env' = setSubstEnv env tvs cvs ids+                                in simplExpr env' e+        DoneId var1          -> return (Var var1)+        DoneEx e _           -> return e++simplInId :: SimplEnv -> InId -> SimplCont -> SimplM (SimplFloats, OutExpr)+simplInId env var cont+  | Just dc <- isDataConWorkId_maybe var+  , isLazyDataConRep dc                    -- See Note [Fast path for lazy data constructors]+  = rebuild zapped_env (Var var) cont+  | otherwise+  = case substId env var of+      ContEx tvs cvs ids e -> simplExprF env' e cont+        -- Don't trimJoinCont; haven't already simplified e,+        -- so the cont is not embodied in e+        where+          env' = setSubstEnv env tvs cvs ids++      DoneId out_id -> simplOutId zapped_env out_id cont'+        where+          cont' = trimJoinCont out_id (idJoinPointHood out_id) cont++      DoneEx e mb_join -> simplExprF zapped_env e cont'+        where+          cont' = trimJoinCont var mb_join cont+  where+    zapped_env =  zapSubstEnv env  -- See Note [zapSubstEnv]++---------------------------------------------------------+simplOutId :: SimplEnvIS -> OutId -> SimplCont -> SimplM (SimplFloats, OutExpr)++---------- The runRW# rule ------+-- See Note [Simplification of runRW#] in GHC.CoreToSTG.Prep.+--+-- runRW# :: forall (r :: RuntimeRep) (o :: TYPE r). (State# RealWorld -> o) -> o+-- K[ runRW# @rr @hole_ty body ]   -->   runRW @rr' @ty' (\s. K[ body s ])+simplOutId env fun cont+  | fun `hasKey` runRWKey+  , ApplyToTy  { sc_cont = cont1 } <- cont+  , ApplyToTy  { sc_cont = cont2, sc_arg_ty = hole_ty } <- cont1+  , ApplyToVal { sc_cont = cont3, sc_arg = arg+               , sc_env = arg_se, sc_hole_ty = fun_ty } <- cont2+  -- Do this even if (contIsStop cont), or if seCaseCase is off.+  -- See Note [No eta-expansion in runRW#]+  = do { let arg_env = arg_se `setInScopeFromE` env++             overall_res_ty = contResultType cont3+             -- hole_ty is the type of the current runRW# application+             (outer_cont, new_runrw_res_ty, inner_cont)+                | seCaseCase env = (mkBoringStop overall_res_ty, overall_res_ty, cont3)+                | otherwise      = (cont3, hole_ty, mkBoringStop hole_ty)+                -- Only when case-of-case is on. See GHC.Driver.Config.Core.Opt.Simplify+                --    Note [Case-of-case and full laziness]++       -- If the argument is a literal lambda already, take a short cut+       -- This isn't just efficiency:+       --    * If we don't do this we get a beta-redex every time, so the+       --      simplifier keeps doing more iterations.+       --    * Even more important: see Note [No eta-expansion in runRW#]+       ; arg' <- case arg of+           Lam s body -> do { (env', s') <- simplBinder arg_env s+                            ; body' <- simplExprC env' body inner_cont+                            ; return (Lam s' body') }+                            -- Important: do not try to eta-expand this lambda+                            -- See Note [No eta-expansion in runRW#]++           _ -> do { s' <- newId (fsLit "s") ManyTy realWorldStatePrimTy+                   ; let (m,_,_) = splitFunTy fun_ty+                         env'  = arg_env `addNewInScopeIds` [s']+                         cont' = ApplyToVal { sc_dup = Simplified, sc_arg = Var s'+                                            , sc_env = env', sc_cont = inner_cont+                                            , sc_hole_ty = mkVisFunTy m realWorldStatePrimTy new_runrw_res_ty }+                                -- cont' applies to s', then K+                   ; body' <- simplExprC env' arg cont'+                   ; return (Lam s' body') }++       ; let rr'   = getRuntimeRep new_runrw_res_ty+             call' = mkApps (Var fun) [mkTyArg rr', mkTyArg new_runrw_res_ty, arg']+       ; rebuild env call' outer_cont }++-- Normal case for (f e1 .. en)+simplOutId env fun cont+  = -- Try rewrite rules: Plan (BEFORE) in Note [When to apply rewrite rules]+    do { rule_base <- getSimplRules+       ; let rules_for_me = getRules rule_base fun+             out_args     = contOutArgs env cont :: [OutExpr]+       ; mb_match <- if not (null rules_for_me) &&+                        (isClassOpId fun || activeUnfolding (seMode env) fun)+                     then tryRules env rules_for_me fun out_args+                     else return Nothing+       ; case mb_match of {+             Just (rule_arity, rhs) -> simplExprF env rhs $+                                       dropContArgs rule_arity cont ;+             Nothing ->++    -- Try inlining+    do { logger <- getLogger+       ; mb_inline <- tryInlining env logger fun cont+       ; case mb_inline of{+            Just expr -> do { checkedTick (UnfoldingDone fun)+                            ; simplExprF env expr cont } ;+            Nothing ->++    -- Neither worked, so just rebuild+    do { let arg_info = mkArgInfo env fun rules_for_me cont+       ; rebuildCall env arg_info cont+    } } } } }++---------------------------------------------------------+--      Dealing with a call site++rebuildCall :: SimplEnvIS -> ArgInfo -> SimplCont+            -> SimplM (SimplFloats, OutExpr)+-- SimplEnvIS: at this point the substitution in the SimplEnv is irrelevant;+-- it is usually empty, and regardless should be ignored.+-- Only the in-scope set matters, plus the seMode flags++-- Check the invariant+rebuildCall env arg_info _cont+  | assertPpr (checkSimplEnvIS env) (pprBadSimplEnvIS env $$ ppr arg_info) False+  = pprPanic "rebuildCall" empty++---------- Bottoming applications --------------+rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_dmds = [] }) cont+  -- When we run out of strictness args, it means+  -- that the call is definitely bottom; see GHC.Core.Opt.Simplify.Utils.mkArgInfo+  -- Then we want to discard the entire strict continuation.  E.g.+  --    * case (error "hello") of { ... }+  --    * (error "Hello") arg+  --    * f (error "Hello") where f is strict+  --    etc+  -- Then, especially in the first of these cases, we'd like to discard+  -- the continuation, leaving just the bottoming expression.  But the+  -- type might not be right, so we may have to add a coerce.+  | not (contIsTrivial cont)     -- Only do this if there is a non-trivial+                                 -- continuation to discard, else we do it+                                 -- again and again!+  = seqType cont_ty `seq`        -- See Note [Avoiding space leaks in OutType]+    return (emptyFloats env, castBottomExpr res cont_ty)+  where+    res     = argInfoExpr fun rev_args+    cont_ty = contResultType cont++---------- Simplify type applications --------------+rebuildCall env info (ApplyToTy { sc_arg_ty = arg_ty, sc_hole_ty = hole_ty, sc_cont = cont })+  = rebuildCall env (addTyArgTo info arg_ty hole_ty) cont++---------- Simplify value arguments --------------------+rebuildCall env fun_info+            (ApplyToVal { sc_arg = arg, sc_env = arg_se+                        , sc_dup = dup_flag, sc_hole_ty = fun_ty+                        , sc_cont = cont })+  -- Argument is already simplified+  | isSimplified dup_flag     -- See Note [Avoid redundant simplification]+  = rebuildCall env (addValArgTo fun_info arg fun_ty) cont++  -- Strict arguments+  | isStrictArgInfo fun_info+  , seCaseCase env    -- Only when case-of-case is on. See GHC.Driver.Config.Core.Opt.Simplify+                      --    Note [Case-of-case and full laziness]+  = -- pprTrace "Strict Arg" (ppr arg $$ ppr (seIdSubst env) $$ ppr (seInScope env)) $+    simplExprF (arg_se `setInScopeFromE` env) arg+               (StrictArg { sc_fun = fun_info, sc_fun_ty = fun_ty+                          , sc_dup = Simplified+                          , sc_cont = cont })+                -- Note [Shadowing in the Simplifier]++  -- Lazy arguments+  | otherwise+        -- DO NOT float anything outside, hence simplExprC+        -- There is no benefit (unlike in a let-binding), and we'd+        -- have to be very careful about bogus strictness through+        -- floating a demanded let.+  = do  { (_, _, arg') <- simplLazyArg env dup_flag fun_ty (Just fun_info) arg_se arg+        ; rebuildCall env (addValArgTo fun_info  arg' fun_ty) cont }++---------- No further useful info, revert to generic rebuild ------------+rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_rules = rules }) cont+  | null rules+  = rebuild env (argInfoExpr fun rev_args) cont+  | otherwise  -- Try rules again: Plan (AFTER) in Note [When to apply rewrite rules]+  = do { let args = reverse rev_args+       ; mb_match <- tryRules env rules fun (map argSpecArg args)+       ; case mb_match of+           Just (rule_arity, rhs) -> simplExprF env rhs $+                                     pushSimplifiedArgs env (drop rule_arity args) cont+           Nothing -> rebuild env (argInfoExpr fun rev_args) cont }++-----------------------------------+tryInlining :: SimplEnv -> Logger -> OutId -> SimplCont -> SimplM (Maybe OutExpr)+tryInlining env logger var cont+  | Just expr <- callSiteInline env logger var lone_variable arg_infos interesting_cont+  = do { dump_inline expr cont+       ; return (Just expr) }++  | otherwise+  = return Nothing++  where+    (lone_variable, arg_infos, call_cont) = contArgs cont+    interesting_cont = interestingCallContext env call_cont++    log_inlining doc+      = liftIO $ logDumpFile logger (mkDumpStyle alwaysQualify)+           Opt_D_dump_inlinings+           "" FormatText doc++    dump_inline unfolding cont+      | not (logHasDumpFlag logger Opt_D_dump_inlinings) = return ()+      | not (logHasDumpFlag logger Opt_D_verbose_core2core)+      = when (isExternalName (idName var)) $+            log_inlining $+                sep [text "Inlining done:", nest 4 (ppr var)]+      | otherwise+      = log_inlining $+           sep [text "Inlining done: " <> ppr var,+                nest 4 (vcat [text "Inlined fn: " <+> nest 2 (ppr unfolding),+                              text "Cont:  " <+> ppr cont])]+++{- Note [When to apply rewrite rules]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Should we apply rewrite rules before simplifying the arguments, or after?+Each is highly desirable in some cases, and in fact we do both!++  - Plan (BEFORE) selectively, in `simplOutId`+    See Note [tryRules: plan (BEFORE)]++  - Plan (AFTER) always, in the finishing-up case of `rebuildCall`+    See Note [tryRules: plan (AFTER)]++Historical note.  Pre-2025, GHC only did tryRules once, when it had simplified+enough arguments to saturate all the RULEs it had in hand.  But alas, if a new+unrelated RULE showed up (but did not fire), it could nevertheless change the+simplifier's behaviour a bit; and that messed up deterministic compilation+(#25170).  (This was particularly nasty if the rule wasn't even transitively+below the module being compiled.)  Current solution: ensure that adding a new,+unrelated rule that never fires does not change the simplifier behaviour.  End+of historical note.++Note [tryRules: plan (BEFORE)]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It is sometimes desirable to apply RULES before simplifying the function+arguments.  We do so in `simplOutId`.++We do so /selectively/ (see (BF2)), in two particular cases:++* Class ops+     (+) dNumInt e2 e3+  If we rewrite ((+) dNumInt) to plusInt, we can take advantage of the+  latter's strictness when simplifying e2, e3.  Moreover, if+      (+) dNumInt e2 e3   -->    (\x y -> ....) e2 e3+  Frequently `x` is used just once in the body of the (\x y -> ...).+  If `e2` is un-simplified we can preInlineUnconditinally and that saves+  simplifying `e2` twice. See Note [Avoiding simplifying repeatedly].++* Specialisation RULES.  In general we try to arrange that inlining is disabled+  (via a pragma) if a rewrite rule should apply, so that the rule has a decent+  chance to fire before we inline the function.++  But it turns out that (especially when type-class specialisation or+  SpecConstr is involved) it is very helpful for the the rewrite rule to+  "win" over inlining when both are active at once: see #21851, #22097.++  So if the Id has an unfolding, we want to try RULES before we try inlining.++Wrinkles:++(BF1) Each un-simplified argument has its own static environment, stored+  in its `ApplyToVal` nodes.   So we can't just match on the un-simplified+  arguments: we  have to apply that static environment as a substitution+  first!  This is done lazily in `GHC.Core.Opt.Simplify.Utils.contOutArgs`,+  so it'll be done just enough to allow the rule to match, or not.++(BF2) The "selectively" in Plan (BEFORE) is a bit ad-hoc:++  * We want Plan (BEFORE) for class ops (see above in this Note)++  * But we do NOT want Plan (BEFORE) for primops, because the constant-folding+    rules are quite complicated and expensive, and we don't want to try them+    twice.  Moreover the benefts of Plan (BEFORE), described in the Note, don't+    apply to primops.++Note [tryRules: plan (AFTER)]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It's very desirable to try RULES once the arguments have been simplified,+because doing so ensures that rule cascades work in one pass. We do this+in the finishing-up case of `rebuildCall`.++Consider+   {-# RULES g (h x) = k x+             f (k x) = x #-}+   ...f (g (h x))...+Then we want to rewrite (g (h x)) to (k x) and only then try f's rules. If+we match f's rules against the un-simplified RHS, it won't match.  This+makes a particularly big difference for++* Superclass selectors+        op ($p1 ($p2 (df d)))+  We want all this to unravel in one sweep++* Constant folding+        +# 3# (+# 4# 5#)+  We want this to happen in one pass++Note [Avoid redundant simplification]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Because RULES often apply to simplified arguments (see Note [Plan (AFTER)]),+there's a danger of simplifying already-simplified arguments.  For example,+suppose we have+   RULE f (x,y) = $sf x  y+and the expression+   f (p,q) e1 e2+With Plan (AFTER) by the time the rule fires, we will have already simplified e1, e2,+and we want to avoid doing so a second time.  So ApplyToVal records if the argument+is already Simplified.++Note [Shadowing in the Simplifier]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+This part of the simplifier may return an expression that has shadowing.+(See Note [Shadowing in Core] in GHC.Core.hs.) Consider+        f (...(\a -> e)...) (case y of (a,b) -> e')+where f is strict in its second arg+If we simplify the innermost one first we get (...(\a -> e)...)+Simplifying the second arg makes us float the case out, so we end up with+        case y of (a,b) -> f (...(\a -> e)...) e'+So the output does not have the no-shadowing invariant.  However, there is+no danger of getting name-capture, because when the first arg was simplified+we used an in-scope set that at least mentioned all the variables free in its+static environment, and that is enough.++We can't just do innermost first, or we'd end up with a dual problem:+        case x of (a,b) -> f e (...(\a -> e')...)++I spent hours trying to recover the no-shadowing invariant, but I just could+not think of an elegant way to do it.  The simplifier is already knee-deep in+continuations.  We have to keep the right in-scope set around; AND we have+to get the effect that finding (error "foo") in a strict arg position will+discard the entire application and replace it with (error "foo").  Getting+all this at once is TOO HARD!++See also Note [Shadowing in prepareAlts] in GHC.Core.Opt.Simplify.Utils.++Note [No eta-expansion in runRW#]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we see `runRW# (\s. blah)` we must not attempt to eta-expand that+lambda.  Why not?  Because+* `blah` can mention join points bound outside the runRW#+* eta-expansion uses arityType, and+* `arityType` cannot cope with free join Ids:++So the simplifier spots the literal lambda, and simplifies inside it.+It's a very special lambda, because it is the one the OccAnal spots and+allows join points bound /outside/ to be called /inside/.++See Note [No free join points in arityType] in GHC.Core.Opt.Arity++************************************************************************+*                                                                      *+                Rewrite rules+*                                                                      *+************************************************************************+-}++tryRules :: SimplEnv -> [CoreRule]+         -> OutId -> [OutExpr]+         -> SimplM (Maybe (FullArgCount, CoreExpr))++tryRules env rules fn args+  | Just (rule, rule_rhs) <- lookupRule ropts in_scope_env+                                        act_fun fn args rules+  -- Fire a rule for the function+  = do { logger <- getLogger+       ; checkedTick (RuleFired (ruleName rule))+       ; let occ_anald_rhs = occurAnalyseExpr rule_rhs+                 -- See Note [Occurrence-analyse after rule firing]+       ; dump logger rule rule_rhs+       ; return (Just (ruleArity rule, occ_anald_rhs)) }++  | otherwise  -- No rule fires+  = do { logger <- getLogger+       ; nodump logger  -- This ensures that an empty file is written+       ; return Nothing }++  where+    ropts        = seRuleOpts env :: RuleOpts+    in_scope_env = getUnfoldingInRuleMatch env :: InScopeEnv+    act_fun      = activeRule (seMode env) :: Activation -> Bool++    printRuleModule rule+      = parens (maybe (text "BUILTIN")+                      (pprModuleName . moduleName)+                      (ruleModule rule))++    dump logger rule rule_rhs+      | logHasDumpFlag logger Opt_D_dump_rule_rewrites+      = log_rule Opt_D_dump_rule_rewrites "Rule fired" $ vcat+          [ text "Rule:" <+> ftext (ruleName rule)+          , text "Module:" <+>  printRuleModule rule+          , text "Full arity:" <+>  ppr (ruleArity rule)+          , text "Before:" <+> hang (ppr fn) 2 (sep (map ppr args))+          , text "After: " <+> pprCoreExpr rule_rhs ]++      | logHasDumpFlag logger Opt_D_dump_rule_firings+      = log_rule Opt_D_dump_rule_firings "Rule fired:" $+          ftext (ruleName rule)+            <+> printRuleModule rule++      | otherwise+      = return ()++    nodump logger+      | logHasDumpFlag logger Opt_D_dump_rule_rewrites+      = liftIO $+          touchDumpFile logger Opt_D_dump_rule_rewrites++      | logHasDumpFlag logger Opt_D_dump_rule_firings+      = liftIO $+          touchDumpFile logger Opt_D_dump_rule_firings++      | otherwise+      = return ()++    log_rule flag hdr details+      = do+      { logger <- getLogger+      ; liftIO $ logDumpFile logger (mkDumpStyle alwaysQualify) flag "" FormatText+               $ sep [text hdr, nest 4 details]+      }++trySeqRules :: SimplEnv+            -> OutExpr -> InExpr   -- Scrutinee and RHS+            -> SimplCont+            -> SimplM (Maybe (CoreExpr, SimplCont))+-- See Note [User-defined RULES for seq]+-- `in_env` applies to `rhs :: InExpr` but not to `scrut :: OutExpr`+trySeqRules in_env scrut rhs cont+  = do { rule_base <- getSimplRules+       ; let seq_rules = getRules rule_base seqId+       ; mb_match <- tryRules in_env seq_rules seqId out_args+       ; case mb_match of+            Nothing                -> return Nothing+            Just (rule_arity, rhs) -> return (Just (rhs, cont'))+                where+                  cont' = pushSimplifiedArgs in_env (drop rule_arity out_arg_specs) rule_cont+       }+  where+    no_cast_scrut = drop_casts scrut++    -- All these are OutTypes+    scrut_ty  = exprType no_cast_scrut+    seq_id_ty = idType seqId                    -- forall r a (b::TYPE r). a -> b -> b+    res1_ty   = piResultTy seq_id_ty rhs_rep    -- forall a (b::TYPE rhs_rep). a -> b -> b+    res2_ty   = piResultTy res1_ty   scrut_ty   -- forall (b::TYPE rhs_rep). scrut_ty -> b -> b+    res3_ty   = piResultTy res2_ty   rhs_ty     -- scrut_ty -> rhs_ty -> rhs_ty+    res4_ty   = funResultTy res3_ty             -- rhs_ty -> rhs_ty+    rhs_ty    = substTy in_env (exprType rhs)+    rhs_rep   = getRuntimeRep rhs_ty++    out_args = [Type rhs_rep, Type scrut_ty, Type rhs_ty, no_cast_scrut]+               -- Cheaper than (map argSpecArg out_arg_specs)+    out_arg_specs  = [ TyArg { as_arg_ty  = rhs_rep+                        , as_hole_ty = seq_id_ty }+                     , TyArg { as_arg_ty  = scrut_ty+                             , as_hole_ty = res1_ty }+                     , TyArg { as_arg_ty  = rhs_ty+                             , as_hole_ty = res2_ty }+                     , ValArg { as_arg = no_cast_scrut+                              , as_dmd = seqDmd+                              , as_hole_ty = res3_ty } ]+    rule_cont = ApplyToVal { sc_dup = NoDup, sc_arg = rhs+                           , sc_env = in_env, sc_cont = cont+                           , sc_hole_ty = res4_ty }++    -- Lazily evaluated, so we don't do most of this+    drop_casts (Cast e _) = drop_casts e+    drop_casts e          = e++{- Note [User-defined RULES for seq]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Given+   case (scrut |> co) of _ -> rhs+look for rules that match the expression+   seq @t1 @t2 scrut+where scrut :: t1+      rhs   :: t2++If you find a match, rewrite it, and apply to 'rhs'.++Notice that we can simply drop casts on the fly here, which+makes it more likely that a rule will match.++See Note [User-defined RULES for seq] in GHC.Types.Id.Make.++Note [Occurrence-analyse after rule firing]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+After firing a rule, we occurrence-analyse the instantiated RHS before+simplifying it.  Usually this doesn't make much difference, but it can+be huge.  Here's an example (simplCore/should_compile/T7785)++  map f (map f (map f xs)++= -- Use build/fold form of map, twice+  map f (build (\cn. foldr (mapFB c f) n+                           (build (\cn. foldr (mapFB c f) n xs))))++= -- Apply fold/build rule+  map f (build (\cn. (\cn. foldr (mapFB c f) n xs) (mapFB c f) n))++= -- Beta-reduce+  -- Alas we have no occurrence-analysed, so we don't know+  -- that c is used exactly once+  map f (build (\cn. let c1 = mapFB c f in+                     foldr (mapFB c1 f) n xs))++= -- Use mapFB rule:   mapFB (mapFB c f) g = mapFB c (f.g)+  -- We can do this because (mapFB c n) is a PAP and hence expandable+  map f (build (\cn. let c1 = mapFB c n in+                     foldr (mapFB c (f.f)) n x))++This is not too bad.  But now do the same with the outer map, and+we get another use of mapFB, and t can interact with /both/ remaining+mapFB calls in the above expression.  This is stupid because actually+that 'c1' binding is dead.  The outer map introduces another c2. If+there is a deep stack of maps we get lots of dead bindings, and lots+of redundant work as we repeatedly simplify the result of firing rules.++The easy thing to do is simply to occurrence analyse the result of+the rule firing.  Note that this occ-anals not only the RHS of the+rule, but also the function arguments, which by now are OutExprs.+E.g.+      RULE f (g x) = x+1++Call   f (g BIG)  -->   (\x. x+1) BIG++The rule binders are lambda-bound and applied to the OutExpr arguments+(here BIG) which lack all internal occurrence info.++Is this inefficient?  Not really: we are about to walk over the result+of the rule firing to simplify it, so occurrence analysis is at most+a constant factor.++Note, however, that the rule RHS is /already/ occ-analysed; see+Note [OccInfo in unfoldings and rules] in GHC.Core.  There is something+unsatisfactory about doing it twice; but the rule RHS is usually very+small, and this is simple.++Note [Rules for recursive functions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+You might think that we shouldn't apply rules for a loop breaker:+doing so might give rise to an infinite loop, because a RULE is+rather like an extra equation for the function:+     RULE:           f (g x) y = x+y+     Eqn:            f a     y = a-y++But it's too drastic to disable rules for loop breakers.+Even the foldr/build rule would be disabled, because foldr+is recursive, and hence a loop breaker:+     foldr k z (build g) = g k z+So it's up to the programmer: rules can cause divergence+++************************************************************************+*                                                                      *+                Rebuilding a case expression+*                                                                      *+************************************************************************++Note [Case elimination]+~~~~~~~~~~~~~~~~~~~~~~~+The case-elimination transformation discards redundant case expressions.+Start with a simple situation:++        case x# of      ===>   let y# = x# in e+          y# -> e++(when x#, y# are of primitive type, of course).  We can't (in general)+do this for algebraic cases, because we might turn bottom into+non-bottom!++The code in GHC.Core.Opt.Simplify.Utils.prepareAlts has the effect of generalise+this idea to look for a case where we're scrutinising a variable, and we know+that only the default case can match.  For example:++        case x of+          0#      -> ...+          DEFAULT -> ...(case x of+                         0#      -> ...+                         DEFAULT -> ...) ...++Here the inner case is first trimmed to have only one alternative, the+DEFAULT, after which it's an instance of the previous case.  This+really only shows up in eliminating error-checking code.++Note that GHC.Core.Opt.Simplify.Utils.mkCase combines identical RHSs.  So++        case e of       ===> case e of DEFAULT -> r+           True  -> r+           False -> r++Now again the case may be eliminated by the CaseElim transformation.+This includes things like (==# a# b#)::Bool so that we simplify+      case ==# a# b# of { True -> x; False -> x }+to just+      x+This particular example shows up in default methods for+comparison operations (e.g. in (>=) for Int.Int32)++Note [Case to let transformation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If a case over a lifted type has a single alternative, and is being+used as a strict 'let' (all isDeadBinder bndrs), we may want to do+this transformation:++    case e of r       ===>   let r = e in ...r...+      _ -> ...r...++We treat the unlifted and lifted cases separately:++* Unlifted case: 'e' satisfies exprOkForSpeculation+  (ok-for-spec is needed to satisfy the let-can-float invariant).+  This turns     case a +# b of r -> ...r...+  into           let r = a +# b in ...r...+  and thence     .....(a +# b)....++  However, if we have+      case indexArray# a i of r -> ...r...+  we might like to do the same, and inline the (indexArray# a i).+  But indexArray# is not okForSpeculation, so we don't build a let+  in rebuildCase (lest it get floated *out*), so the inlining doesn't+  happen either.  Annoying.++* Lifted case: we need to be sure that the expression is already+  evaluated (exprIsHNF).  If it's not already evaluated+      - we risk losing exceptions, divergence or+        user-specified thunk-forcing+      - even if 'e' is guaranteed to converge, we don't want to+        create a thunk (call by need) instead of evaluating it+        right away (call by value)++  However, we can turn the case into a /strict/ let if the 'r' is+  used strictly in the body.  Then we won't lose divergence; and+  we won't build a thunk because the let is strict.+  See also Note [Case-to-let for strictly-used binders]++Note [Case-to-let for strictly-used binders]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we have this:+   case <scrut> of r { _ -> ..r.. }+where 'r' is used strictly in (..r..), we /could/ safely transform to+   let r = <scrut> in ...r...+As a special case,  we have a plain `seq` like+   case r of r1 { _ -> ...r1... }+where `r` is used strictly, we /could/ simply drop the `case` to get+   ...r....++HOWEVER, there are some serious downsides to this transformation, so+GHC doesn't do it any longer (#24251):++* Suppose the Simplifier sees+     case x of y* { __DEFAULT ->+     let z = case y of { __DEFAULT -> expr } in+     z+1 }+  The "y*" means "y is used strictly in its scope.  Now we may:+     - Eliminate the inner case because `y` is evaluated.+  Now the demand-info on `y` is not right, because `y` is no longer used+  strictly in its scope.  But it is hard to spot that without doing a new+  demand analysis.  So there is a danger that we will subsequently:+     - Eliminate the outer case because `y` is used strictly+  Yikes!  We can't eliminate both!++* It introduces space leaks (#24251).  Consider+      go 0 where go x = x `seq` go (x + 1)+  It is an infinite loop, true, but it should not leak space. Yet if we drop+  the `seq`, it will.  Another great example is #21741.++* Dropping the outer `case` can change the error behaviour.  For example,+  we might transform+       case x of { _ -> error "bad" }    -->     error "bad"+  which is might be puzzling if 'x' currently lambda-bound, but later gets+  let-bound to (error "good").  Tht is OK accoring to the paper "A semantics for+  imprecise exceptions", but see #8900 for an example where the loss of this+  transformation bit us in practice.++* If we have (case e of x -> f x), where `f` is strict, then it looks as if `x`+  is strictly used, and we could soundly transform to+     let x = e in f x+  But if f's strictness info got worse (which can happen in in obscure cases;+  see #21392) then we might have turned a non-thunk into a thunk!  Bad.++Lacking this "drop-strictly-used-seq" transformation means we can end up with+some redundant-looking evals.  For example, consider+    f x y = case x of DEFAULT ->    -- A redundant-looking eval+            case y of+              True  -> case x of { Nothing -> False; Just z  -> z }+              False -> case x of { Nothing -> True;  Just z  -> z }+That outer eval will be retained right through to code generation.  But,+perhaps surprisingly, that is probably a /good/ thing:++   Key point: those inner (case x) expressions will be compiled a simple 'if',+   because the code generator can see that `x` is, at those points, evaluated+   and properly tagged.++If we dropped the outer eval, both the inner (case x) expressions would need to+do a proper eval, pushing a return address, with an info table. See the example+in #15631 where, in the Description, the (case ys) will be a simple multi-way+jump.++In fact (#24251), when I stopped GHC implementing the drop-strictly-used-seqs+transformation, binary sizes fell by 1%, and a few programs actually allocated+less and ran faster.  A case in point is nofib/imaginary/digits-of-e2. (I'm not+sure exactly why it improves so much, though.)++Slightly related: Note [Empty case alternatives] in GHC.Core.++Historical notes:++There have been various earlier versions of this patch:++* By Sept 18 the code looked like this:+     || scrut_is_demanded_var scrut++    scrut_is_demanded_var :: CoreExpr -> Bool+    scrut_is_demanded_var (Cast s _) = scrut_is_demanded_var s+    scrut_is_demanded_var (Var _)    = isStrUsedDmd (idDemandInfo case_bndr)+    scrut_is_demanded_var _          = False++  This only fired if the scrutinee was a /variable/, which seems+  an unnecessary restriction. So in #15631 I relaxed it to allow+  arbitrary scrutinees.  Less code, less to explain -- but the change+  had 0.00% effect on nofib.++* Previously, in Jan 13 the code looked like this:+     || case_bndr_evald_next rhs++    case_bndr_evald_next :: CoreExpr -> Bool+      -- See Note [Case binder next]+    case_bndr_evald_next (Var v)         = v == case_bndr+    case_bndr_evald_next (Cast e _)      = case_bndr_evald_next e+    case_bndr_evald_next (App e _)       = case_bndr_evald_next e+    case_bndr_evald_next (Case e _ _ _)  = case_bndr_evald_next e+    case_bndr_evald_next _               = False++  This patch was part of fixing #7542. See also+  Note [Eta reduction soundness], criterion (E) in GHC.Core.Utils.)+++Further notes about case elimination+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider:       test :: Integer -> IO ()+                test = print++Turns out that this compiles to:+    Print.test+      = \ eta :: Integer+          eta1 :: Void# ->+          case PrelNum.< eta PrelNum.zeroInteger of wild { __DEFAULT ->+          case hPutStr stdout+                 (PrelNum.jtos eta ($w[] @ Char))+                 eta1+          of wild1 { (# new_s, a4 #) -> PrelIO.lvl23 new_s  }}++Notice the strange '<' which has no effect at all. This is a funny one.+It started like this:++f x y = if x < 0 then jtos x+          else if y==0 then "" else jtos x++At a particular call site we have (f v 1).  So we inline to get++        if v < 0 then jtos x+        else if 1==0 then "" else jtos x++Now simplify the 1==0 conditional:++        if v<0 then jtos v else jtos v++Now common-up the two branches of the case:++        case (v<0) of DEFAULT -> jtos v++Why don't we drop the case?  Because it's strict in v.  It's technically+wrong to drop even unnecessary evaluations, and in practice they+may be a result of 'seq' so we *definitely* don't want to drop those.+I don't really know how to improve this situation.+++Note [FloatBinds from constructor wrappers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we have FloatBinds coming from the constructor wrapper+(as in Note [exprIsConApp_maybe on data constructors with wrappers]),+we cannot float past them. We'd need to float the FloatBind+together with the simplify floats, unfortunately the+simplifier doesn't have case-floats. The simplest thing we can+do is to wrap all the floats here. The next iteration of the+simplifier will take care of all these cases and lets.++Given data T = MkT !Bool, this allows us to simplify+case $WMkT b of { MkT x -> f x }+to+case b of { b' -> f b' }.++We could try and be more clever (like maybe wfloats only contain+let binders, so we could float them). But the need for the+extra complication is not clear.++Note [Do not duplicate constructor applications]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this (#20125)+   let x = (a,b)+   in ...(case x of x' -> blah)...x...x...++We want that `case` to vanish (since `x` is bound to a data con) leaving+   let x = (a,b)+   in ...(let x'=x in blah)...x..x...++In rebuildCase, `exprIsConApp_maybe` will succeed on the scrutinee `x`,+since is bound to (a,b).  But in eliminating the case, if the scrutinee+is trivial, we want to bind the case-binder to the scrutinee, /not/ to+the constructor application.  Hence the case_bndr_rhs in rebuildCase.++This applies equally to a non-DEFAULT case alternative, say+   let x = (a,b) in ...(case x of x' { (p,q) -> blah })...+This variant is handled by bind_case_bndr in knownCon.++We want to bind x' to x, and not to a duplicated (a,b)).+-}++---------------------------------------------------------+--      Eliminate the case if possible++rebuildCase, reallyRebuildCase+   :: SimplEnv+   -> OutExpr          -- Scrutinee+   -> InId             -- Case binder+   -> [InAlt]          -- Alternatives (increasing order)+   -> SimplCont+   -> SimplM (SimplFloats, OutExpr)++--------------------------------------------------+--      1. Eliminate the case if there's a known constructor+--------------------------------------------------++rebuildCase env scrut case_bndr alts cont+  | Lit lit <- scrut    -- No need for same treatment as constructors+                        -- because literals are inlined more vigorously+  , not (litIsLifted lit)+  = do  { tick (KnownBranch case_bndr)+        ; case findAlt (LitAlt lit) alts of+            Nothing             -> missingAlt env case_bndr alts cont+            Just (Alt _ bs rhs) -> simple_rhs env [] scrut bs rhs }++  | Just (in_scope', wfloats, con, ty_args, other_args)+      <- exprIsConApp_maybe (getUnfoldingInRuleMatch env) scrut+        -- Works when the scrutinee is a variable with a known unfolding+        -- as well as when it's an explicit constructor application+  , let env0 = setInScopeSet env in_scope'+  = do  { tick (KnownBranch case_bndr)+        ; let scaled_wfloats = map scale_float wfloats+              -- case_bndr_unf: see Note [Do not duplicate constructor applications]+              case_bndr_rhs | exprIsTrivial scrut = scrut+                            | otherwise           = con_app+              con_app = Var (dataConWorkId con) `mkTyApps` ty_args+                                                `mkApps`   other_args+        ; case findAlt (DataAlt con) alts of+            Nothing                   -> missingAlt env0 case_bndr alts cont+            Just (Alt DEFAULT bs rhs) -> simple_rhs env0 scaled_wfloats case_bndr_rhs bs rhs+            Just (Alt _       bs rhs) -> knownCon env0 scrut scaled_wfloats con ty_args+                                                  other_args case_bndr bs rhs cont+        }+  where+    simple_rhs env wfloats case_bndr_rhs bs rhs =+      assert (null bs) $+      do { (floats1, env') <- simplAuxBind "rebuildCase" env case_bndr case_bndr_rhs+             -- scrut is a constructor application,+             -- hence satisfies let-can-float invariant+         ; (floats2, expr') <- simplExprF env' rhs cont+         ; case wfloats of+             [] -> return (floats1 `addFloats` floats2, expr')+             _ -> return+               -- See Note [FloatBinds from constructor wrappers]+                   ( emptyFloats env,+                     GHC.Core.Make.wrapFloats wfloats $+                     wrapFloats (floats1 `addFloats` floats2) expr' )}++    -- This scales case floats by the multiplicity of the continuation hole (see+    -- Note [Scaling in case-of-case]).  Let floats are _not_ scaled, because+    -- they are aliases anyway.+    scale_float (GHC.Core.Make.FloatCase scrut case_bndr con vars) =+      let+        scale_id id = scaleVarBy holeScaling id+      in+      GHC.Core.Make.FloatCase scrut (scale_id case_bndr) con (map scale_id vars)+    scale_float f = f++    holeScaling = contHoleScaling cont `mkMultMul` idMult case_bndr+     -- We are in the following situation+     --   case[p] case[q] u of { D x -> C v } of { C x -> w }+     -- And we are producing case[??] u of { D x -> w[x\v]}+     --+     -- What should the multiplicity `??` be? In order to preserve the usage of+     -- variables in `u`, it needs to be `pq`.+     --+     -- As an illustration, consider the following+     --   case[Many] case[1] of { C x -> C x } of { C x -> (x, x) }+     -- Where C :: A %1 -> T is linear+     -- If we were to produce a case[1], like the inner case, we would get+     --   case[1] of { C x -> (x, x) }+     -- Which is ill-typed with respect to linearity. So it needs to be a+     -- case[Many].++--------------------------------------------------+--      2. Eliminate the case if scrutinee is evaluated+--------------------------------------------------++rebuildCase env scrut case_bndr alts@[Alt _ bndrs rhs] cont+  -- See if we can get rid of the case altogether+  -- See Note [Case elimination]+  -- mkCase made sure that if all the alternatives are equal,+  -- then there is now only one (DEFAULT) rhs++  -- 2a.  Dropping the case altogether, if+  --      a) it binds nothing (so it's really just a 'seq')+  --      b) evaluating the scrutinee has no side effects+  | is_plain_seq+  , exprOkToDiscard scrut+          -- The entire case is dead, so we can drop it+          -- if the scrutinee converges without having imperative+          -- side effects or raising a Haskell exception+   = simplExprF env rhs cont++  -- 2b.  Turn the case into a let, if+  --      a) it binds only the case-binder+  --      b) unlifted case: the scrutinee is ok-for-speculation+  --           lifted case: the scrutinee is in HNF (or will later be demanded)+  -- See Note [Case to let transformation]+  | all_dead_bndrs+  , doCaseToLet scrut case_bndr+  = do { tick (CaseElim case_bndr)+       ; (floats1, env')  <- simplAuxBind "rebuildCaseAlt1" env case_bndr scrut+       ; (floats2, expr') <- simplExprF env' rhs cont+       ; return (floats1 `addFloats` floats2, expr') }++  -- 2c. Try the seq rules if+  --     a) it binds only the case binder+  --     b) a rule for seq applies+  -- See Note [User-defined RULES for seq] in GHC.Types.Id.Make+  | is_plain_seq+  = do { mb_rule <- trySeqRules env scrut rhs cont+       ; case mb_rule of+           Just (rule_rhs, cont') -> simplExprF (zapSubstEnv env) rule_rhs cont'+           Nothing                -> reallyRebuildCase env scrut case_bndr alts cont }++--------------------------------------------------+--      3. Primop-related case-rules+--------------------------------------------------++  |Just (scrut', case_bndr', alts') <- caseRules2 scrut case_bndr alts+  = reallyRebuildCase env scrut' case_bndr' alts' cont++  where+    all_dead_bndrs = all isDeadBinder bndrs       -- bndrs are [InId]+    is_plain_seq   = all_dead_bndrs && isDeadBinder case_bndr -- Evaluation *only* for effect++rebuildCase env scrut case_bndr alts cont+  = reallyRebuildCase env scrut case_bndr alts cont++doCaseToLet :: OutExpr          -- Scrutinee+            -> InId             -- Case binder+            -> Bool+-- The situation is         case scrut of b { DEFAULT -> body }+-- Can we transform thus?   let { b = scrut } in body+doCaseToLet scrut case_bndr+  | isTyCoVar case_bndr    -- Respect GHC.Core+  = isTyCoArg scrut        -- Note [Core type and coercion invariant]++  | isUnliftedType (exprType scrut)+    -- We can call isUnliftedType here: scrutinees always have a fixed RuntimeRep (see FRRCase).+    -- Note however that we must check 'scrut' (which is an 'OutExpr') and not 'case_bndr'+    -- (which is an 'InId'): see Note [Dark corner with representation polymorphism].+    -- Using `exprType` is typically cheap because `scrut` is typically a variable.+    -- We could instead use mightBeUnliftedType (idType case_bndr), but that hurts+    -- the brain more.  Consider that if this test ever turns out to be a perf+    -- problem (which seems unlikely).+  = exprOkForSpeculation scrut++  | otherwise  -- Scrut has a lifted type+  = exprIsHNF scrut+       --    || isStrUsedDmd (idDemandInfo case_bndr)+       -- We no longer look at the demand on the case binder+       -- See Note [Case-to-let for strictly-used binders]++--------------------------------------------------+--      3. Catch-all case+--------------------------------------------------++reallyRebuildCase env scrut case_bndr alts cont+  | not (seCaseCase env)    -- Only when case-of-case is on.+                            -- See GHC.Driver.Config.Core.Opt.Simplify+                            --    Note [Case-of-case and full laziness]+  = do { case_expr <- simplAlts env scrut case_bndr alts+                                (mkBoringStop (contHoleType cont))+       ; rebuild (zapSubstEnv env) case_expr cont }++  | otherwise+  = do { (floats, env', cont') <- mkDupableCaseCont env alts cont+       ; case_expr <- simplAlts env' scrut+                                (scaleIdBy holeScaling case_bndr)+                                (scaleAltsBy holeScaling alts)+                                cont'+       ; return (floats, case_expr) }+  where+    holeScaling = contHoleScaling cont+    -- Note [Scaling in case-of-case]++{-+simplCaseBinder checks whether the scrutinee is a variable, v.  If so,+try to eliminate uses of v in the RHSs in favour of case_bndr; that+way, there's a chance that v will now only be used once, and hence+inlined.++Historical note: we use to do the "case binder swap" in the Simplifier+so there were additional complications if the scrutinee was a variable.+Now the binder-swap stuff is done in the occurrence analyser; see+"GHC.Core.Opt.OccurAnal" Note [Binder swap].++Note [knownCon occ info]+~~~~~~~~~~~~~~~~~~~~~~~~+If the case binder is not dead, then neither are the pattern bound+variables:+        case <any> of x { (a,b) ->+        case x of { (p,q) -> p } }+Here (a,b) both look dead, but come alive after the inner case is eliminated.+The point is that we bring into the envt a binding+        let x = (a,b)+after the outer case, and that makes (a,b) alive.  At least we do unless+the case binder is guaranteed dead.++Note [DataAlt occ info]+~~~~~~~~~~~~~~~~~~~~~~~+Our general goal is to preserve dead-ness occ-info on the field binders of a+case alternative. Why? It's generally a good idea, but one specific reason is to+support (SEQ4) of Note [seq# magic].++But we have to be careful: even if the field binder is not mentioned in the case+alternative and thus annotated IAmDead by OccurAnal, it might "come back to+life" in one of two ways:++ 1. If the case binder is alive, its unfolding might bring back the field+    binder, as in Note [knownCon occ info]:+      case blah of y { I# _ -> $wf (case y of I# v -> v) }+      ==>+      case blah of y { I# v -> $wf v }+ 2. Even if the case binder appears to be dead, there is the scenario in+    Note [Add unfolding for scrutinee], in which the fields come back to live+    through the unfolding of variable scrutinee, as follows:+      join j = case x of Just v -> blah v; Nothing -> ... in+      case x of Just _ -> jump j; Nothing -> ...+      ==> { inline j, unfold x to Just v, simplify }+      join j = case x of Just v -> blah v; Nothing -> ... in+      case x of Just v -> blah v; Nothing -> ...++Thus, when we are simply reconstructing a case (the common case), and the+case binder is not dead, or the scrutinee is a variable, we zap the+occurrence info on DataAlt field binders. See `adjustFieldOccInfo`.++Note [Improving seq]+~~~~~~~~~~~~~~~~~~~~+Consider+        type family F :: * -> *+        type instance F Int = Int++We'd like to transform+        case e of (x :: F Int) { DEFAULT -> rhs }+===>+        case e `cast` co of (x'::Int)+           I# x# -> let x = x' `cast` sym co+                    in rhs++so that 'rhs' can take advantage of the form of x'.  Notice that Note+[Case of cast] (in OccurAnal) may then apply to the result.++We'd also like to eliminate empty types (#13468). So if++    data Void+    type instance F Bool = Void++then we'd like to transform+        case (x :: F Bool) of { _ -> error "urk" }+===>+        case (x |> co) of (x' :: Void) of {}++Nota Bene: we used to have a built-in rule for 'seq' that dropped+casts, so that+    case (x |> co) of { _ -> blah }+dropped the cast; in order to improve the chances of trySeqRules+firing.  But that works in the /opposite/ direction to Note [Improving+seq] so there's a danger of flip/flopping.  Better to make trySeqRules+insensitive to the cast, which is now is.++The need for [Improving seq] showed up in Roman's experiments.  Example:+  foo :: F Int -> Int -> Int+  foo t n = t `seq` bar n+     where+       bar 0 = 0+       bar n = bar (n - case t of TI i -> i)+Here we'd like to avoid repeated evaluating t inside the loop, by+taking advantage of the `seq`.++At one point I did transformation in LiberateCase, but it's more+robust here.  (Otherwise, there's a danger that we'll simply drop the+'seq' altogether, before LiberateCase gets to see it.)++Note [Scaling in case-of-case]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++When two cases commute, if done naively, the multiplicities will be wrong:++  case (case u of w[1] { (x[1], y[1]) } -> f x y) of w'[Many]+  { (z[Many], t[Many]) -> z+  }++The multiplicities here, are correct, but if I perform a case of case:++  case u of w[1]+  { (x[1], y[1]) -> case f x y of w'[Many] of { (z[Many], t[Many]) -> z }+  }++This is wrong! Using `f x y` inside a `case … of w'[Many]` means that `x` and+`y` must have multiplicities `Many` not `1`! The correct solution is to make+all the `1`-s be `Many`-s instead:++  case u of w[Many]+  { (x[Many], y[Many]) -> case f x y of w'[Many] of { (z[Many], t[Many]) -> z }+  }++In general, when commuting two cases, the rule has to be:++  case (case … of x[p] {…}) of y[q] { … }+  ===> case … of x[p*q] { … case … of y[q] { … } }++This is materialised, in the simplifier, by the fact that every time we simplify+case alternatives with a continuation (the surrounded case (or more!)), we must+scale the entire case we are simplifying, by a scaling factor which can be+computed in the continuation (with function `contHoleScaling`).+-}++simplAlts :: SimplEnv+          -> OutExpr         -- Scrutinee+          -> InId            -- Case binder+          -> [InAlt]         -- Non-empty+          -> SimplCont+          -> SimplM OutExpr  -- Returns the complete simplified case expression++simplAlts env0 scrut case_bndr alts cont'+  = do  { traceSmpl "simplAlts" (vcat [ ppr case_bndr+                                      , text "cont':" <+> ppr cont'+                                      , text "in_scope" <+> ppr (seInScope env0) ])+        ; (env1, case_bndr1) <- simplBinder env0 case_bndr+        ; let case_bndr2 = case_bndr1 `setIdUnfolding` evaldUnfolding+              env2       = modifyInScope env1 case_bndr2+              -- See Note [Case binder evaluated-ness]+              fam_envs   = seFamEnvs env0++        ; (alt_env', scrut', case_bndr') <- improveSeq fam_envs env2 scrut+                                                       case_bndr case_bndr2 alts++        ; (imposs_deflt_cons, in_alts) <- prepareAlts scrut' case_bndr alts+          -- NB: it's possible that the returned in_alts is empty: this is handled+          --     by the caller (rebuildCase) in the missingAlt function+          -- NB: pass case_bndr::InId, not case_bndr' :: OutId, to prepareAlts+          --     See Note [Shadowing in prepareAlts] in GHC.Core.Opt.Simplify.Utils++        ; alts' <- forM in_alts $+            simplAlt alt_env' (Just scrut') imposs_deflt_cons+                     case_bndr' (scrutOkForBinderSwap scrut) cont'++        ; let alts_ty' = contResultType cont'+        -- See Note [Avoiding space leaks in OutType]+        ; seqType alts_ty' `seq`+          mkCase (seMode env0) scrut' case_bndr' alts_ty' alts' }+++------------------------------------+improveSeq :: (FamInstEnv, FamInstEnv) -> SimplEnv+           -> OutExpr -> InId -> OutId -> [InAlt]+           -> SimplM (SimplEnv, OutExpr, OutId)+-- Note [Improving seq]+improveSeq fam_envs env scrut case_bndr case_bndr1 [Alt DEFAULT _ _]+  | Just (Reduction co ty2) <- topNormaliseType_maybe fam_envs (idType case_bndr1)+  = do { case_bndr2 <- newId (fsLit "nt") ManyTy ty2+        ; let rhs  = DoneEx (Var case_bndr2 `Cast` mkSymCo co) NotJoinPoint+              env2 = extendIdSubst env case_bndr rhs+        ; return (env2, scrut `Cast` co, case_bndr2) }++improveSeq _ env scrut _ case_bndr1 _+  = return (env, scrut, case_bndr1)+++------------------------------------+simplAlt :: SimplEnv+         -> Maybe OutExpr       -- The scrutinee+         -> [AltCon]            -- These constructors can't be present when+                                -- matching the DEFAULT alternative+         -> OutId               -- The case binder `bndr`+         -> BinderSwapDecision  -- DoBinderSwap v co <==> scrut = Just (v |> co),+                                --           add unfolding `v :-> bndr |> sym co`+         -> SimplCont+         -> InAlt+         -> SimplM OutAlt++simplAlt env _scrut' imposs_deflt_cons case_bndr' bndr_swap' cont' (Alt DEFAULT bndrs rhs)+  = assert (null bndrs) $+    do  { let env' = addDefaultUnfoldings env case_bndr' bndr_swap' imposs_deflt_cons+        ; rhs' <- simplExprC env' rhs cont'+        ; return (Alt DEFAULT [] rhs') }++simplAlt env _scrut' _ case_bndr' bndr_swap' cont' (Alt (LitAlt lit) bndrs rhs)+  = assert (null bndrs) $+    do  { let env' = addAltUnfoldings env case_bndr' bndr_swap' (Lit lit)+        ; rhs' <- simplExprC env' rhs cont'+        ; return (Alt (LitAlt lit) [] rhs') }++simplAlt env scrut' _ case_bndr' bndr_swap' cont' (Alt (DataAlt con) vs rhs)+  = do  { -- See Note [Adding evaluatedness info to pattern-bound variables]+          -- and Note [DataAlt occ info]+        ; let vs_with_info = adjustFieldsIdInfo scrut' case_bndr' bndr_swap' con vs+          -- Adjust evaluated-ness and occ-info flags before `simplBinders`+          -- because the latter extends the in-scope set, which propagates this+          -- adjusted info to use sites.+        ; (env', vs') <- simplBinders env vs_with_info++                -- Bind the case-binder to (con args)+        ; let inst_tys' = tyConAppArgs (idType case_bndr')+              con_app :: OutExpr+              con_app = mkConApp2 con inst_tys' vs'+              env''   = addAltUnfoldings env' case_bndr' bndr_swap' con_app++        ; rhs' <- simplExprC env'' rhs cont'+        ; return (Alt (DataAlt con) vs' rhs') }++{- Note [Adding evaluatedness info to pattern-bound variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+addEvals records the evaluated-ness of the bound variables of+a case pattern.  This is *important*.  Consider++     data T = T !Int !Int++     case x of { T a b -> T (a+1) b }++We really must record that b is already evaluated so that we don't+go and re-evaluate it when constructing the result.+See Note [Strict fields in Core] in GHC.Core.++NB: simplLamBndrs preserves this eval info++In addition to handling data constructor fields with !s, addEvals+also records the fact that the result of seq# is always in WHNF.+See Note [seq# magic] in GHC.Types.Id.Make.  Example (#15226):++  case seq# v s of+    (# s', v' #) -> E++we want the compiler to be aware that v' is in WHNF in E.++Open problem: we don't record that v itself is in WHNF (and we can't+do it here).  The right thing is to do some kind of binder-swap;+see #15226 for discussion.+-}++adjustFieldsIdInfo :: Maybe OutExpr -> OutId -> BinderSwapDecision -> DataCon -> [Id] -> [Id]+-- See Note [Adding evaluatedness info to pattern-bound variables]+-- and Note [DataAlt occ info]+adjustFieldsIdInfo scrut case_bndr bndr_swap con vs+  -- Deal with seq# applications+  | Just scr <- scrut+  , isUnboxedTupleDataCon con+  , [s,x] <- vs+    -- Use stripNArgs rather than collectArgsTicks to avoid building+    -- a list of arguments only to throw it away immediately.+  , Just (Var f) <- stripNArgs 4 scr+  , f `hasKey` seqHashKey+  , let x' = setCaseBndrEvald MarkedStrict x+  = map (adjustFieldOccInfo case_bndr bndr_swap) [s, x']++  -- Deal with banged datacon fields+  -- This case is quite allocation sensitive to T9233 which has a large record+  -- with strict fields. Hence we try not to update vs twice!+adjustFieldsIdInfo _scrut case_bndr bndr_swap con vs+  | Nothing <- dataConWrapId_maybe con+      -- A common fast path; no need to allocate the_strs when they are all lazy+      -- anyway! It shaves off 2% in T9675+  = map (adjustFieldOccInfo case_bndr bndr_swap) vs+  | otherwise+  = go vs the_strs+  where+    the_strs = dataConRepStrictness con++    go [] [] = []+    go (v:vs') strs | isTyVar v = v : go vs' strs+    go (v:vs') (str:strs) = adjustFieldOccInfo case_bndr bndr_swap (setCaseBndrEvald str v) : go vs' strs+    go _ _ = pprPanic "Simplify.adjustFieldsIdInfo"+              (ppr con $$+               ppr vs  $$+               ppr_with_length (map strdisp the_strs) $$+               ppr_with_length (dataConRepArgTys con) $$+               ppr_with_length (dataConRepStrictness con))+      where+        ppr_with_length list+          = ppr list <+> parens (text "length =" <+> ppr (length list))+        strdisp :: StrictnessMark -> SDoc+        strdisp MarkedStrict = text "MarkedStrict"+        strdisp NotMarkedStrict = text "NotMarkedStrict"++adjustFieldOccInfo :: OutId -> BinderSwapDecision -> CoreBndr -> CoreBndr+-- Kill occ info if we do binder swap and the case binder is alive;+-- see Note [DataAlt occ info]+adjustFieldOccInfo case_bndr bndr_swap field_bndr+  | isTyVar field_bndr+  = field_bndr++  | not (isDeadBinder case_bndr)  -- (1) in the Note: If the case binder is alive,+  = zapIdOccInfo field_bndr       -- the field binders might come back alive++  | DoBinderSwap{} <- bndr_swap   -- (2) in the Note: If binder swap might take place,+  = zapIdOccInfo field_bndr       -- the case binder might come back alive++  | otherwise+  = field_bndr                    -- otherwise the field binders stay dead++addDefaultUnfoldings :: SimplEnv -> OutId -> BinderSwapDecision -> [AltCon] -> SimplEnv+addDefaultUnfoldings env case_bndr bndr_swap imposs_deflt_cons+  = env2+  where+    unf = mkOtherCon imposs_deflt_cons+          -- Record the constructors that the case-binder *can't* be.+    env1 = addBinderUnfolding env case_bndr unf+    env2 | DoBinderSwap v _mco <- bndr_swap+         = addBinderUnfolding env1 v unf+         | otherwise = env1+++addAltUnfoldings :: SimplEnv -> OutId -> BinderSwapDecision -> OutExpr -> SimplEnv+addAltUnfoldings env case_bndr bndr_swap con_app+  = env2+  where+    con_app_unf = mk_simple_unf con_app+    env1 = addBinderUnfolding env case_bndr con_app_unf++    -- See Note [Add unfolding for scrutinee]+    env2 | DoBinderSwap v mco <- bndr_swap+         = addBinderUnfolding env1 v $+              if isReflMCo mco  -- isReflMCo: avoid calling mk_simple_unf+              then con_app_unf  --            twice in the common case+              else mk_simple_unf (mkCastMCo con_app mco)++         | otherwise = env1++    -- Force the opts, so that the whole SimplEnv isn't retained+    !opts = seUnfoldingOpts env+    mk_simple_unf = mkSimpleUnfolding opts++addBinderUnfolding :: SimplEnv -> Id -> Unfolding -> SimplEnv+addBinderUnfolding env bndr unf+  | debugIsOn, Just tmpl <- maybeUnfoldingTemplate unf+  = warnPprTrace (not (eqType (idType bndr) (exprType tmpl)))+          "unfolding type mismatch"+          (ppr bndr $$ ppr (idType bndr) $$ ppr tmpl $$ ppr (exprType tmpl)) $+          modifyInScope env (bndr `setIdUnfolding` unf)++  | otherwise+  = modifyInScope env (bndr `setIdUnfolding` unf)++zapBndrOccInfo :: Bool -> Id -> Id+-- Consider  case e of b { (a,b) -> ... }+-- Then if we bind b to (a,b) in "...", and b is not dead,+-- then we must zap the deadness info on a,b+zapBndrOccInfo keep_occ_info pat_id+  | keep_occ_info = pat_id+  | otherwise     = zapIdOccInfo pat_id++{- Note [Case binder evaluated-ness]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We pin on a (OtherCon []) unfolding to the case-binder of a Case,+even though it'll be over-ridden in every case alternative with a more+informative unfolding.  Why?  Because suppose a later, less clever, pass+simply replaces all occurrences of the case binder with the binder itself;+then Lint may complain about the let-can-float invariant.  Example+    case e of b { DEFAULT -> let v = reallyUnsafePtrEquality# b y in ....+                ; K       -> blah }++The let-can-float invariant requires that y is evaluated in the call to+reallyUnsafePtrEquality#, which it is.  But we still want that to be true if we+propagate binders to occurrences.++This showed up in #13027.++Note [Add unfolding for scrutinee]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In general it's unlikely that a variable scrutinee will appear+in the case alternatives   case x of { ...x unlikely to appear... }+because the binder-swap in OccurAnal has got rid of all such occurrences+See Note [Binder swap] in "GHC.Core.Opt.OccurAnal".++BUT it is still VERY IMPORTANT to add a suitable unfolding for a+variable scrutinee, in simplAlt.  Here's why+   case x of y+     (a,b) -> case b of c+                I# v -> ...(f y)...+There is no occurrence of 'b' in the (...(f y)...).  But y gets+the unfolding (a,b), and *that* mentions b.  If f has a RULE+    RULE f (p, I# q) = ...+we want that rule to match, so we must extend the in-scope env with a+suitable unfolding for 'y'.  It's *essential* for rule matching; but+it's also good for case-elimination -- suppose that 'f' was inlined+and did multi-level case analysis, then we'd solve it in one+simplifier sweep instead of two.++HOWEVER, given+  case x of y { Just a -> r1; Nothing -> r2 }+we do not want to add the unfolding x -> y to 'x', which might seem cool,+since 'y' itself has different unfoldings in r1 and r2.  Reason: if we+did that, we'd have to zap y's deadness info and that is a very useful+piece of information.++So instead we add the unfolding x -> Just a, and x -> Nothing in the+respective RHSs.++Since this transformation is tantamount to a binder swap, we use+GHC.Core.Opt.OccurAnal.scrutOkForBinderSwap to do the check.++Exactly the same issue arises in GHC.Core.Opt.SpecConstr;+see Note [Add scrutinee to ValueEnv too] in GHC.Core.Opt.SpecConstr+++************************************************************************+*                                                                      *+\subsection{Known constructor}+*                                                                      *+************************************************************************++We are a bit careful with occurrence info.  Here's an example++        (\x* -> case x of (a*, b) -> f a) (h v, e)++where the * means "occurs once".  This effectively becomes+        case (h v, e) of (a*, b) -> f a)+and then+        let a* = h v; b = e in f a+and then+        f (h v)++All this should happen in one sweep.+-}++knownCon :: SimplEnv+         -> OutExpr                                           -- The scrutinee+         -> [FloatBind] -> DataCon -> [OutType] -> [OutExpr]  -- The scrutinee (in pieces)+         -> InId -> [InBndr] -> InExpr                        -- The alternative+         -> SimplCont+         -> SimplM (SimplFloats, OutExpr)++knownCon env scrut dc_floats dc dc_ty_args dc_args bndr bs rhs cont+  = do  { (floats1, env1)  <- bind_args env bs dc_args+        ; (floats2, env2)  <- bind_case_bndr env1+        ; (floats3, expr') <- simplExprF env2 rhs cont+        ; case dc_floats of+            [] ->+              return (floats1 `addFloats` floats2 `addFloats` floats3, expr')+            _ ->+              return ( emptyFloats env+               -- See Note [FloatBinds from constructor wrappers]+                     , GHC.Core.Make.wrapFloats dc_floats $+                       wrapFloats (floats1 `addFloats` floats2 `addFloats` floats3) expr') }+  where+    zap_occ = zapBndrOccInfo (isDeadBinder bndr)    -- bndr is an InId++                  -- Ugh!+    bind_args env' [] _  = return (emptyFloats env', env')++    bind_args env' (b:bs') (Type ty : args)+      = assert (isTyVar b )+        bind_args (extendTvSubst env' b ty) bs' args++    bind_args env' (b:bs') (Coercion co : args)+      = assert (isCoVar b )+        bind_args (extendCvSubst env' b co) bs' args++    bind_args env' (b:bs') (arg : args)+      = assert (isId b) $+        do { let b' = zap_occ b+             -- zap_occ: the binder might be "dead", because it doesn't+             -- occur in the RHS; and simplAuxBind may therefore discard it.+             -- Nevertheless we must keep it if the case-binder is alive,+             -- because it may be used in the con_app.  See Note [knownCon occ info]+           ; (floats1, env2) <- simplAuxBind "knownCon" env' b' arg  -- arg satisfies let-can-float invariant+           ; (floats2, env3) <- bind_args env2 bs' args+           ; return (floats1 `addFloats` floats2, env3) }++    bind_args _ _ _ =+      pprPanic "bind_args" $ ppr dc $$ ppr bs $$ ppr dc_args $$+                             text "scrut:" <+> ppr scrut++       -- It's useful to bind bndr to scrut, rather than to a fresh+       -- binding      x = Con arg1 .. argn+       -- because very often the scrut is a variable, so we avoid+       -- creating, and then subsequently eliminating, a let-binding+       -- BUT, if scrut is a not a variable, we must be careful+       -- about duplicating the arg redexes; in that case, make+       -- a new con-app from the args+    bind_case_bndr env+      | isDeadBinder bndr   = return (emptyFloats env, env)+      | exprIsTrivial scrut = return (emptyFloats env+                                     , extendIdSubst env bndr (DoneEx scrut NotJoinPoint))+                              -- See Note [Do not duplicate constructor applications]+      | otherwise           = do { dc_args <- mapM (simplInVar env) bs+                                         -- dc_ty_args are already OutTypes,+                                         -- but bs are InBndrs+                                 ; let con_app = Var (dataConWorkId dc)+                                                 `mkTyApps` dc_ty_args+                                                 `mkApps`   dc_args+                                 ; simplAuxBind "case-bndr" env bndr con_app }++-------------------+missingAlt :: SimplEnv -> Id -> [InAlt] -> SimplCont+           -> SimplM (SimplFloats, OutExpr)+                -- This isn't strictly an error, although it is unusual.+                -- It's possible that the simplifier might "see" that+                -- an inner case has no accessible alternatives before+                -- it "sees" that the entire branch of an outer case is+                -- inaccessible.  So we simply put an error case here instead.+missingAlt env case_bndr _ cont+  = warnPprTrace True "missingAlt" (ppr case_bndr) $+    -- See Note [Avoiding space leaks in OutType]+    let cont_ty = contResultType cont+    in seqType cont_ty `seq`+       return (emptyFloats env, mkImpossibleExpr cont_ty "Simplify.Iteration.missingAlt")++{-+************************************************************************+*                                                                      *+\subsection{Duplicating continuations}+*                                                                      *+************************************************************************++Consider+  let x* = case e of { True -> e1; False -> e2 }+  in b+where x* is a strict binding.  Then mkDupableCont will be given+the continuation+   case [] of { True -> e1; False -> e2 } ; let x* = [] in b ; stop+and will split it into+   dupable:      case [] of { True -> $j1; False -> $j2 } ; stop+   join floats:  $j1 = e1, $j2 = e2+   non_dupable:  let x* = [] in b; stop++Putting this back together would give+   let x* = let { $j1 = e1; $j2 = e2 } in+            case e of { True -> $j1; False -> $j2 }+   in b+(Of course we only do this if 'e' wants to duplicate that continuation.)+Note how important it is that the new join points wrap around the+inner expression, and not around the whole thing.++In contrast, any let-bindings introduced by mkDupableCont can wrap+around the entire thing.++Note [Bottom alternatives]+~~~~~~~~~~~~~~~~~~~~~~~~~~+When we have+     case (case x of { A -> error .. ; B -> e; C -> error ..)+       of alts+then we can just duplicate those alts because the A and C cases+will disappear immediately.  This is more direct than creating+join points and inlining them away.  See #4930.+-}++--------------------+mkDupableCaseCont :: SimplEnv -> [InAlt] -> SimplCont+                  -> SimplM ( SimplFloats  -- Join points (if any)+                            , SimplEnv     -- Use this for the alts+                            , SimplCont)+mkDupableCaseCont env alts cont+  | altsWouldDup alts = do { (floats, cont) <- mkDupableCont env cont+                           ; let env' = bumpCaseDepth $+                                        env `setInScopeFromF` floats+                           ; return (floats, env', cont) }+  | otherwise         = return (emptyFloats env, env, cont)++altsWouldDup :: [InAlt] -> Bool -- True iff strictly > 1 non-bottom alternative+altsWouldDup []  = False        -- See Note [Bottom alternatives]+altsWouldDup [_] = False+altsWouldDup (alt:alts)+  | is_bot_alt alt = altsWouldDup alts+  | otherwise      = not (all is_bot_alt alts)+    -- otherwise case: first alt is non-bot, so all the rest must be bot+  where+    is_bot_alt (Alt _ _ rhs) = exprIsDeadEnd rhs++-------------------------+mkDupableCont :: SimplEnv+              -> SimplCont+              -> SimplM ( SimplFloats  -- Incoming SimplEnv augmented with+                                       --   extra let/join-floats and in-scope variables+                        , SimplCont)   -- dup_cont: duplicable continuation+mkDupableCont env cont+  = mkDupableContWithDmds (zapSubstEnv env) (repeat topDmd) cont++mkDupableContWithDmds+   :: SimplEnvIS  -> [Demand]  -- Demands on arguments; always infinite+   -> SimplCont -> SimplM ( SimplFloats, SimplCont)++mkDupableContWithDmds env _ cont+  -- Check the invariant+  | assertPpr (checkSimplEnvIS env) (pprBadSimplEnvIS env) False+  = pprPanic "mkDupableContWithDmds" empty++  | contIsDupable cont+  = return (emptyFloats env, cont)++mkDupableContWithDmds _ _ (Stop {}) = panic "mkDupableCont"     -- Handled by previous eqn++mkDupableContWithDmds env dmds (CastIt { sc_co = co, sc_opt = opt, sc_cont = cont })+  = do  { (floats, cont') <- mkDupableContWithDmds env dmds cont+        ; return (floats, CastIt { sc_co = optOutCoercion env co opt+                                 , sc_opt = True, sc_cont = cont' }) }+                 -- optOutCoercion: see Note [Avoid re-simplifying coercions]++-- Duplicating ticks for now, not sure if this is good or not+mkDupableContWithDmds env dmds (TickIt t cont)+  = do  { (floats, cont') <- mkDupableContWithDmds env dmds cont+        ; return (floats, TickIt t cont') }++mkDupableContWithDmds env _+     (StrictBind { sc_bndr = bndr, sc_body = body, sc_from = from_what+                 , sc_env = se, sc_cont = cont})+-- See Note [Duplicating StrictBind]+-- K[ let x = <> in b ]  -->   join j x = K[ b ]+--                             j <>+  = do { let sb_env = se `setInScopeFromE` env+       ; (sb_env1, bndr')      <- simplBinder sb_env bndr+       ; (floats1, join_inner) <- simplNonRecBody sb_env1 from_what body cont+          -- No need to use mkDupableCont before simplNonRecBody; we+          -- use cont once here, and then share the result if necessary++       ; let join_body = wrapFloats floats1 join_inner+             res_ty    = contResultType cont++       ; mkDupableStrictBind env bndr' join_body res_ty }++mkDupableContWithDmds env _+    (StrictArg { sc_fun = fun, sc_cont = cont+               , sc_fun_ty = fun_ty })+  -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable+  | isNothing (isDataConId_maybe (ai_fun fun))+         -- isDataConId: see point (DJ4) of Note [Duplicating join points]+  , thumbsUpPlanA cont+  = -- Use Plan A of Note [Duplicating StrictArg]+--    pprTrace "Using plan A" (ppr (ai_fun fun) $$ text "args" <+> ppr (ai_args fun) $$ text "cont" <+> ppr cont) $+    do { let _ :| dmds = expectNonEmpty $ ai_dmds fun+       ; (floats1, cont')  <- mkDupableContWithDmds env dmds cont+                              -- Use the demands from the function to add the right+                              -- demand info on any bindings we make for further args+       ; (floats_s, args') <- mapAndUnzipM (makeTrivialArg env)+                                           (ai_args fun)+       ; return ( foldl' addLetFloats floats1 floats_s+                , StrictArg { sc_fun = fun { ai_args = args' }+                            , sc_cont = cont'+                            , sc_fun_ty = fun_ty+                            , sc_dup = OkToDup} ) }++  | otherwise+  = -- Use Plan B of Note [Duplicating StrictArg]+    --   K[ f a b <> ]   -->   join j x = K[ f a b x ]+    --                         j <>+    do { let rhs_ty       = contResultType cont+             (m,arg_ty,_) = splitFunTy fun_ty+       ; arg_bndr <- newId (fsLit "arg") m arg_ty+       ; let env' = env `addNewInScopeIds` [arg_bndr]+       ; (floats, join_rhs) <- rebuildCall env' (addValArgTo fun (Var arg_bndr) fun_ty) cont+       ; mkDupableStrictBind env' arg_bndr (wrapFloats floats join_rhs) rhs_ty }+  where+    thumbsUpPlanA (StrictArg {})               = False+    thumbsUpPlanA (StrictBind {})              = True+    thumbsUpPlanA (Stop {})                    = True+    thumbsUpPlanA (Select {})                  = True+    thumbsUpPlanA (CastIt { sc_cont = k })     = thumbsUpPlanA k+    thumbsUpPlanA (TickIt _ k)                 = thumbsUpPlanA k+    thumbsUpPlanA (ApplyToVal { sc_cont = k }) = thumbsUpPlanA k+    thumbsUpPlanA (ApplyToTy  { sc_cont = k }) = thumbsUpPlanA k++mkDupableContWithDmds env dmds+    (ApplyToTy { sc_cont = cont, sc_arg_ty = arg_ty, sc_hole_ty = hole_ty })+  = do  { (floats, cont') <- mkDupableContWithDmds env dmds cont+        ; return (floats, ApplyToTy { sc_cont = cont'+                                    , sc_arg_ty = arg_ty, sc_hole_ty = hole_ty }) }++mkDupableContWithDmds env dmds+    (ApplyToVal { sc_arg = arg, sc_dup = dup, sc_env = se+                , sc_cont = cont, sc_hole_ty = hole_ty })+  =     -- e.g.         [...hole...] (...arg...)+        --      ==>+        --              let a = ...arg...+        --              in [...hole...] a+        -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable+    do  { let dmd:|cont_dmds = expectNonEmpty dmds+        ; (floats1, cont') <- mkDupableContWithDmds env cont_dmds cont+        ; let env' = env `setInScopeFromF` floats1+        ; (_, se', arg') <- simplLazyArg env' dup hole_ty Nothing se arg+        ; (let_floats2, arg'') <- makeTrivial env NotTopLevel dmd (fsLit "karg") arg'+        ; let all_floats = floats1 `addLetFloats` let_floats2+        ; return ( all_floats+                 , ApplyToVal { sc_arg = arg''+                              , sc_env = se' `setInScopeFromF` all_floats+                                         -- Ensure that sc_env includes the free vars of+                                         -- arg'' in its in-scope set, even if makeTrivial+                                         -- has turned arg'' into a fresh variable+                                         -- See Note [StaticEnv invariant] in GHC.Core.Opt.Simplify.Utils+                              , sc_dup = OkToDup, sc_cont = cont'+                              , sc_hole_ty = hole_ty }) }++mkDupableContWithDmds env _+    (Select { sc_bndr = case_bndr, sc_alts = alts, sc_env = se, sc_cont = cont })+  =     -- e.g.         (case [...hole...] of { pi -> ei })+        --      ===>+        --              let ji = \xij -> ei+        --              in case [...hole...] of { pi -> ji xij }+        -- NB: sc_dup /= OkToDup; that is caught earlier by contIsDupable+    do  { tick (CaseOfCase case_bndr)+        ; (floats, alt_env, alt_cont) <- mkDupableCaseCont (se `setInScopeFromE` env) alts cont+                -- NB: We call mkDupableCaseCont here to make cont duplicable+                --     (if necessary, depending on the number of alts)+                -- And this is important: see Note [Fusing case continuations]++        ; let cont_scaling = contHoleScaling cont+          -- See Note [Scaling in case-of-case]+        ; (alt_env', case_bndr') <- simplBinder alt_env (scaleIdBy cont_scaling case_bndr)+        ; alts' <- forM (scaleAltsBy cont_scaling alts) $+            simplAlt alt_env' Nothing [] case_bndr' NoBinderSwap alt_cont+                -- Safe to say that there are no handled-cons for the DEFAULT case+                -- NB: simplBinder does not zap deadness occ-info, so+                -- a dead case_bndr' will still advertise its deadness+                -- This is really important because in+                --      case e of b { (# p,q #) -> ... }+                -- b is always dead, and indeed we are not allowed to bind b to (# p,q #),+                -- which might happen if e was an explicit unboxed pair and b wasn't marked dead.+                -- In the new alts we build, we have the new case binder, so it must retain+                -- its deadness.+        -- NB: we don't use alt_env further; it has the substEnv for+        --     the alternatives, and we don't want that++        ; (join_floats, alts'') <- mapAccumLM (mkDupableAlt env case_bndr')+                                              emptyJoinFloats alts'++        ; let all_floats = floats `addJoinFloats` join_floats+                           -- Note [Duplicated env]+        ; return (all_floats+                 , Select { sc_dup  = OkToDup+                          , sc_bndr = case_bndr'+                          , sc_alts = alts''+                          , sc_env  = zapSubstEnv se `setInScopeFromF` all_floats+                                      -- See Note [StaticEnv invariant] in GHC.Core.Opt.Simplify.Utils+                          , sc_cont = mkBoringStop (contResultType cont) } ) }++mkDupableStrictBind :: SimplEnv -> OutId -> OutExpr -> OutType+                    -> SimplM (SimplFloats, SimplCont)+mkDupableStrictBind env arg_bndr join_rhs res_ty+  | uncondInlineJoin [arg_bndr] join_rhs+     -- See point (DJ2) of Note [Duplicating join points]+  = return (emptyFloats env+           , StrictBind { sc_bndr = arg_bndr+                        , sc_body = join_rhs+                        , sc_env  = zapSubstEnv env+                        , sc_from = FromLet+                          -- See Note [StaticEnv invariant] in GHC.Core.Opt.Simplify.Utils+                        , sc_dup  = OkToDup+                        , sc_cont = mkBoringStop res_ty } )+  | otherwise+  = do { join_bndr <- newJoinId [arg_bndr] res_ty+       ; let arg_info = ArgInfo { ai_fun   = join_bndr+                                , ai_rules = [], ai_args  = []+                                , ai_encl  = False, ai_dmds  = repeat topDmd+                                , ai_discs = repeat 0 }+       ; return ( addJoinFloats (emptyFloats env) $+                  unitJoinFloat                   $+                  NonRec join_bndr                $+                  Lam (setOneShotLambda arg_bndr) join_rhs+                , StrictArg { sc_dup    = OkToDup+                            , sc_fun    = arg_info+                            , sc_fun_ty = idType join_bndr+                            , sc_cont   = mkBoringStop res_ty+                            } ) }++mkDupableAlt :: SimplEnv -> OutId+             -> JoinFloats -> OutAlt+             -> SimplM (JoinFloats, OutAlt)+mkDupableAlt _env case_bndr jfloats (Alt con alt_bndrs alt_rhs_in)+  | uncondInlineJoin alt_bndrs alt_rhs_in+    -- See point (DJ2) of Note [Duplicating join points]+  = return (jfloats, Alt con alt_bndrs alt_rhs_in)++  | otherwise+  = do  { let rhs_ty'  = exprType alt_rhs_in++              bangs+                | DataAlt c <- con+                = dataConRepStrictness c+                | otherwise = []++              abstracted_binders = abstract_binders alt_bndrs bangs++              abstract_binders :: [Var] -> [StrictnessMark] -> [(Id,StrictnessMark)]+              abstract_binders [] []+                -- Abstract over the case binder too if it's used.+                | isDeadBinder case_bndr  = []+                | otherwise               = [(case_bndr,MarkedStrict)]+              abstract_binders (alt_bndr:alt_bndrs) marks+                -- Abstract over all type variables just in case+                | isTyVar alt_bndr        = (alt_bndr,NotMarkedStrict) : abstract_binders alt_bndrs marks+              abstract_binders (alt_bndr:alt_bndrs) (mark:marks)+                -- The deadness info on the new Ids is preserved by simplBinders+                -- We don't abstract over dead ids here.+                | isDeadBinder alt_bndr   = abstract_binders alt_bndrs marks+                | otherwise               = (alt_bndr,mark) : abstract_binders alt_bndrs marks+              abstract_binders _ _ = pprPanic "abstrict_binders - failed to abstract" (ppr $ Alt con alt_bndrs alt_rhs_in)++              filtered_binders = map fst abstracted_binders+              -- We want to make any binder with an evaldUnfolding strict in the rhs.+              -- See Note [Call-by-value for worker args] (which also applies to join points)+              rhs_with_seqs = mkStrictFieldSeqs abstracted_binders alt_rhs_in++              final_args = varsToCoreExprs filtered_binders+                           -- Note [Join point abstraction]++                -- We make the lambdas into one-shot-lambdas.  The+                -- join point is sure to be applied at most once, and doing so+                -- prevents the body of the join point being floated out by+                -- the full laziness pass+              final_bndrs     = map one_shot filtered_binders+              one_shot v | isId v    = setOneShotLambda v+                         | otherwise = v++              -- No lambda binder has an unfolding, but (currently) case binders can,+              -- so we must zap them here.+              join_rhs   = mkLams (map zapIdUnfolding final_bndrs) rhs_with_seqs++        ; join_bndr <- newJoinId filtered_binders rhs_ty'+        ; let -- join_bndr_w_unf = join_bndr `setIdUnfolding`+              --                   mkUnfolding uf_opts VanillaSrc False False join_rhs Nothing+              -- See Note [Do not add unfoldings to join points at birth]+              join_call = mkApps (Var join_bndr) final_args+              alt'      = Alt con alt_bndrs join_call++        ; return ( jfloats `addJoinFlts` unitJoinFloat (NonRec join_bndr join_rhs)+                 , alt') }+                -- See Note [Duplicated env]++{-+Note [Do not add unfoldings to join points at birth]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this (#15360)++   case (case (case (case ...))) of+      Left x  -> e1+      Right y -> e2++We will make a join point for e1, e2, thus+    $j1a x = e1+    $j1b y = e2++Now those join point calls count as "duplicable" , so we feel free to duplicate+them into the loop nest.  And each of those calls are then subject to+callSiteInline, which might inline them, if e1, e2 are reasonably small.  Now,+if this applies recursive to the next `case` inwards, and so on, the net+effect is that we can get an exponential number of calls to $j1a and $j1b, and+an exponential number of inlinings (since each is done independently).++This hit #15360 (not a complicated program!) badly.  Our simple solution is this:+when a join point is born, we don't give it an unfolding, so it will not be inlined+at its call sites, at least not in that pass.  So we end up with+    $j1a x = e1+    $j1b y = e2+    $j2a x = ...$j1a ... $j1b...+    $j2b x = ...$j1a ... $j1b...+    ... and so on...++In the next iteration of the Simplifier we are into Note [Avoid inlining into+deeply nested cases] in Simplify.Inline, which is still a challenge.  But at+least we have a chance. If we add inlinings at birth we never get that chance.++Wrinkle++(JU1) It turns out that the same problem shows up in a different guise, via+      Note [Post-inline for single-use things] in Simplify.Utils.  I think+      we have something like+         case K (join $j x = <rhs> in jblah) of K y{OneOcc} -> blah+      where $j is a freshly-born join point.  After case-of-known-constructor+      wo we end up substituting (join $j x = <rhs> in jblah) for `y` in `blah`;+      and thus we re-simplify that join binding.  In test T15630 this results in+      massive duplication.++      So in `simplLetUnfolding` we spot this case a bit hackily; a freshly-born+      join point will have OccInfo of ManyOccs, unlike an existing join point which+      will have OneOcc.  So in simplLetUnfolding we kill the unfolding of a freshly+      born join point.++I can't quite articulate precisely why this is so important.  But it makes a+MASSIVE difference in T15630 (a fantastic test case); and at worst it'll merely+delay inlining join points by one simplifier iteration.++In effect (JU1) just extends the original Note [Do not add unfoldings to join+points at birth] to occasions where we re-visit the same join-point in the same+Simplifier iteration.++Note [Fusing case continuations]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It's important to fuse two successive case continuations when the+first has one alternative.  That's why we call prepareCaseCont here.+Consider this, which arises from thunk splitting (see Note [Thunk+splitting] in GHC.Core.Opt.WorkWrap):++      let+        x* = case (case v of {pn -> rn}) of+               I# a -> I# a+      in body++The simplifier will find+    (Var v) with continuation+            Select (pn -> rn) (+            Select [I# a -> I# a] (+            StrictBind body Stop++So we'll call mkDupableCont on+   Select [I# a -> I# a] (StrictBind body Stop)+There is just one alternative in the first Select, so we want to+simplify the rhs (I# a) with continuation (StrictBind body Stop)+Supposing that body is big, we end up with+          let $j a = <let x = I# a in body>+          in case v of { pn -> case rn of+                                 I# a -> $j a }+This is just what we want because the rn produces a box that+the case rn cancels with.++See #4957 a fuller example.++Note [Duplicating join points]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In #19996 we discovered that we want to be really careful about+inlining join points.   Consider+    case (join $j x = K f x )+         (in case v of      )+         (     p1 -> $j x1  ) of+         (     p2 -> $j x2  )+         (     p3 -> $j x3  )+      K g y -> blah[g,y]++Here the join-point RHS is very small, just a constructor+application (K f x).  So we might inline it to get+    case (case v of          )+         (     p1 -> K f x1  ) of+         (     p2 -> K f x2  )+         (     p3 -> K f x3  )+      K g y -> blah[g,y]++But now we have to make `blah` into a join point, /abstracted/+over `g` and `y`. We get+    join $j2 g y = blah+    in case v of+         p1 -> $j2 f x1+         p2 -> $j2 f x2+         p3 -> $j2 f x3+So now we can't see that `g` is always `f` in `blah`.++In contrast, if we /don't/ inline $j we+don't need a new join point for `blah` and we'll get+    join $j' x = let g=f, y=x in blah[g,y]+    in case v of+       p1 -> $j' x1+       p2 -> $j' x2+       p3 -> $j' x3++This can make a /massive/ difference, because `blah` can see+what `f` is, instead of lambda-abstracting over it.++If instead the RHS of the join point is a simple application that has no free+variables, as in++    case (join $j x f = K f x )+         (in case v of      )+         (     p1 -> $j x1 f1 ) of+         (     p2 -> $j x2 f2 )+         (     p3 -> $j x3 f3 )+      K g y -> blah[g,y]++then no information can be gained by preserving the join point (c.f. `f` being+free in the join point above and being useful to `blah`). In this case, it's+more beneficial to inline the join point (see (DJ3)(c)) to allow further+optimisations to fire. An example where failing to do this went wrong is #25723.++Beyond this, not-inlining join points reduces duplication.  In the above+example, if `blah` was small enough we'd inline it, but that duplicates code,+for no gain.  Best just to keep not-inline the join point in the first place.+So not-inlining join points is our default: but see Note [Inlining join points]+in GHC.Core.Opt.Simplify.Inline for when we /do/ inline them.++To achieve this parsimonious inlining of join points, we need to do two things:+(a) create a join point even if the RHS is small; and (b) don't do+unconditional-inlining for join points.++(DJ1) Do not postInlineUnconditionally a join point, ever. Doing+   postInlineUnconditionally is primarily to push allocation into cold+   branches; but a join point doesn't allocate, so that's a non-motivation.++(DJ2) In mkDupableAlt and mkDupableStrictBind, generate an alterative for /all/+   alternatives, /except/ for ones that will definitely inline unconditionally+   straight away.  (In that case it's silly to make a join point in the first+   place; it just takes an extra Simplifier iteration to undo.)  This choice is+   made by GHC.Core.Unfold.uncondInlineJoin.++   This plan generates a lot of join points, but makes them much more+   case-of-case friendly.++(DJ3) When should `uncondInlineJoin` return True?+   (a) (exprIsTrivial rhs); this includes uses of unsafeEqualityProof etc; see+     the defn of exprIsTrivial.  Also nullary constructors.++   (b) The RHS is a call ($j x y z), where the arguments are all trivial and $j+     is a join point: there is no point in creating an indirection.++   (c) The RHS is a data constructor application (K x y z) where++      - all the args x,y,z are trivial+      - the free LocalIds of `f x y z` are a subset of the join point binders++      Examples that return True+        $j x y = K y (x |> co)+        $j x y = x (y @Int)+      Examples that return False+        $j x = K y x    -- y is free+        $j y = f y      -- f is free++      Not duplicating these join points has no benefits and blocks other important+      optimisations from firing (see #25723)++(DJ4) By the same token we want to use Plan B in Note [Duplicating StrictArg] when+   the RHS of the new join point is a data constructor application.  See the+   call to isDataConId in the StrictArg case of mkDupableContWithDmds.++   That same Note [Duplicating StrictArg] explains why we sometimes want Plan A+   when the RHS of the new join point would be a non-data-constructor+   application++(DJ5) You might worry that $j = K x y might look so small that it is inlined+   by the call site inliner, defeating (DJ3). But in fact++   - The UnfoldingGuidance for a join point is only UnfWhen (unconditional)+     if `uncondInlineJoin` is true; see GHC.Core.Unfold.uncondInline++   - `GHC.Core.Opt.Simplify.Inline.tryUnfolding` has a special case for join+     points, described Note [Inlining join points] in that module.++Historical Note [Case binders and join points]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+NB: this entire Note is now irrelevant.  In Jun 21 we stopped+adding unfoldings to lambda binders (#17530).  It was always a+hack and bit us in multiple small and not-so-small ways++Consider this+   case (case .. ) of c {+     I# c# -> ....c....++If we make a join point with c but not c# we get+  $j = \c -> ....c....++But if later inlining scrutinises the c, thus++  $j = \c -> ... case c of { I# y -> ... } ...++we won't see that 'c' has already been scrutinised.  This actually+happens in the 'tabulate' function in wave4main, and makes a significant+difference to allocation.++An alternative plan is this:++   $j = \c# -> let c = I# c# in ...c....++but that is bad if 'c' is *not* later scrutinised.++So instead we do both: we pass 'c' and 'c#' , and record in c's inlining+(a stable unfolding) that it's really I# c#, thus++   $j = \c# -> \c[=I# c#] -> ...c....++Absence analysis may later discard 'c'.++NB: take great care when doing strictness analysis;+    see Note [Lambda-bound unfoldings] in GHC.Core.Opt.DmdAnal.++Also note that we can still end up passing stuff that isn't used.  Before+strictness analysis we have+   let $j x y c{=(x,y)} = (h c, ...)+   in ...+After strictness analysis we see that h is strict, we end up with+   let $j x y c{=(x,y)} = ($wh x y, ...)+and c is unused.++Note [Duplicated env]+~~~~~~~~~~~~~~~~~~~~~+Some of the alternatives are simplified, but have not been turned into a join point+So they *must* have a zapped subst-env.  So we can't use completeNonRecX to+bind the join point, because it might to do PostInlineUnconditionally, and+we'd lose that when zapping the subst-env.  We could have a per-alt subst-env,+but zapping it (as we do in mkDupableCont, the Select case) is safe, and+at worst delays the join-point inlining.++Note [Funky mkLamTypes]+~~~~~~~~~~~~~~~~~~~~~~+Notice the funky mkLamTypes.  If the constructor has existentials+it's possible that the join point will be abstracted over+type variables as well as term variables.+ Example:  Suppose we have+        data T = forall t.  C [t]+ Then faced with+        case (case e of ...) of+            C t xs::[t] -> rhs+ We get the join point+        let j :: forall t. [t] -> ...+            j = /\t \xs::[t] -> rhs+        in+        case (case e of ...) of+            C t xs::[t] -> j t xs++Note [Duplicating StrictArg]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Dealing with making a StrictArg continuation duplicable has turned out+to be one of the trickiest corners of the simplifier, giving rise+to several cases in which the simplier expanded the program's size+*exponentially*.  They include+  #13253 exponential inlining+  #10421 ditto+  #18140 strict constructors+  #18282 another nested-function call case++Suppose we have a call+  f e1 (case x of { True -> r1; False -> r2 }) e3+and f is strict in its second argument.  Then we end up in+mkDupableCont with a StrictArg continuation for (f e1 <> e3).+There are two ways to make it duplicable.++* Plan A: move the entire call inwards, being careful not+  to duplicate e1 or e3, thus:+     let a1 = e1+         a3 = e3+     in case x of { True  -> f a1 r1 a3+                  ; False -> f a1 r2 a3 }++* Plan B: make a join point:+     join $j x = f e1 x e3+     in case x of { True  -> jump $j r1+                  ; False -> jump $j r2 }++  Notice that Plan B is very like the way we handle strict bindings;+  see Note [Duplicating StrictBind].  And Plan B is exactly what we'd+  get if we turned use a case expression to evaluate the strict arg:++       case (case x of { True -> r1; False -> r2 }) of+         r -> f e1 r e3++  So, looking at Note [Duplicating join points], we also want Plan B+  when `f` is a data constructor.++Plan A is often good:++* The calls to `f` may well be able to inline, since they are now applied+  to more informative arguments, `r1`, `r2`. For example:+        && E (case x of { T -> F; F -> T })+  Pushing the call inward (being careful not to duplicate E) we get+        let a = E+        in case x of { T -> && a F; F -> && a T }+  and now the (&& a F) etc can optimise.++* Moreover there might be a RULE for the function that can fire when it "sees"+  the particular case alternative.++* More specialisation can happen.  Here's an example from #3116+     go (n+1) (case l of+                 1  -> bs'+                 _  -> Chunk p fpc (o+1) (l-1) bs')++  If we pushed the entire call for 'go' inside the case, we get+  call-pattern specialisation for 'go', which is *crucial* for+  this particular program.++But Plan A can have terrible, terrible behaviour. Here is a classic+case:+  f (f (f (f (f True))))++Suppose f is strict, and has a body that is small enough to inline.+The innermost call inlines (seeing the True) to give+  f (f (f (f (case v of { True -> e1; False -> e2 }))))++Now, suppose we naively push the entire continuation into both+case branches (it doesn't look large, just f.f.f.f). We get+  case v of+    True  -> f (f (f (f e1)))+    False -> f (f (f (f e2)))++And now the process repeats, so we end up with an exponentially large+number of copies of f. No good!++CONCLUSION: we want Plan A in general, but do Plan B is there a+danger of this nested call behaviour. The function that decides+this is called thumbsUpPlanA.++Note [Keeping demand info in StrictArg Plan A]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Following on from Note [Duplicating StrictArg], another common code+pattern that can go bad is this:+   f (case x1 of { T -> F; F -> T })+     (case x2 of { T -> F; F -> T })+     ...etc...+when f is strict in all its arguments.  (It might, for example, be a+strict data constructor whose wrapper has not yet been inlined.)++We use Plan A (because there is no nesting) giving+  let a2 = case x2 of ...+      a3 = case x3 of ...+  in case x1 of { T -> f F a2 a3 ... ; F -> f T a2 a3 ... }++Now we must be careful!  a2 and a3 are small, and the OneOcc code in+postInlineUnconditionally may inline them both at both sites; see Note+Note [Inline small things to avoid creating a thunk] in+Simplify.Utils. But if we do inline them, the entire process will+repeat -- back to exponential behaviour.++So we are careful to keep the demand-info on a2 and a3.  Then they'll+be /strict/ let-bindings, which will be dealt with by StrictBind.+That's why contIsDupableWithDmds is careful to propagage demand+info to the auxiliary bindings it creates.  See the Demand argument+to makeTrivial.++Note [Duplicating StrictBind]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We make a StrictBind duplicable in a very similar way to+that for case expressions.  After all,+   let x* = e in b   is similar to    case e of x -> b++So we potentially make a join-point for the body, thus:+   let x = <> in b   ==>   join j x = b+                           in j <>++Just like StrictArg in fact -- and indeed they share code.++Note [Join point abstraction]  Historical note+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+NB: This note is now historical, describing how (in the past) we used+to add a void argument to nullary join points.  But now that "join+point" is not a fuzzy concept but a formal syntactic construct (as+distinguished by the JoinId constructor of IdDetails), each of these+concerns is handled separately, with no need for a vestigial extra+argument.++Join points always have at least one value argument,+for several reasons++* If we try to lift a primitive-typed something out+  for let-binding-purposes, we will *caseify* it (!),+  with potentially-disastrous strictness results.  So+  instead we turn it into a function: \v -> e+  where v::Void#.  The value passed to this function is void,+  which generates (almost) no code.++* CPR.  We used to say "&& isUnliftedType rhs_ty'" here, but now+  we make the join point into a function whenever used_bndrs'+  is empty.  This makes the join-point more CPR friendly.+  Consider:       let j = if .. then I# 3 else I# 4+                  in case .. of { A -> j; B -> j; C -> ... }++  Now CPR doesn't w/w j because it's a thunk, so+  that means that the enclosing function can't w/w either,+  which is a lose.  Here's the example that happened in practice:+          kgmod :: Int -> Int -> Int+          kgmod x y = if x > 0 && y < 0 || x < 0 && y > 0+                      then 78+                      else 5++* Let-no-escape.  We want a join point to turn into a let-no-escape+  so that it is implemented as a jump, and one of the conditions+  for LNE is that it's not updatable.  In CoreToStg, see+  Note [What is a non-escaping let]++* Floating.  Since a join point will be entered once, no sharing is+  gained by floating out, but something might be lost by doing+  so because it might be allocated.++I have seen a case alternative like this:+        True -> \v -> ...+It's a bit silly to add the realWorld dummy arg in this case, making+        $j = \s v -> ...+           True -> $j s+(the \v alone is enough to make CPR happy) but I think it's rare++There's a slight infelicity here: we pass the overall+case_bndr to all the join points if it's used in *any* RHS,+because we don't know its usage in each RHS separately++++************************************************************************+*                                                                      *+                    Unfoldings+*                                                                      *+************************************************************************+-}++simplLetUnfolding :: SimplEnv+                  -> BindContext+                  -> InId+                  -> OutExpr -> OutType -> ArityType+                  -> Unfolding -> SimplM Unfolding+simplLetUnfolding env bind_cxt id new_rhs rhs_ty arity unf+  | isStableUnfolding unf+  = simplStableUnfolding env bind_cxt id rhs_ty arity unf++  | freshly_born_join_point id+  = -- This is a tricky one!+    -- See wrinkle (JU1) in Note [Do not add unfoldings to join points at birth]+    return noUnfolding++  | isExitJoinId id+  = -- See Note [Do not inline exit join points] in GHC.Core.Opt.Exitify+    return noUnfolding++  | otherwise+  = mkLetUnfolding env (bindContextLevel bind_cxt) VanillaSrc id is_join_point new_rhs++  where+    is_join_point = isJoinId id+    freshly_born_join_point id = is_join_point && isManyOccs (idOccInfo id)+      -- OLD: too_many_occs (OneOcc { occ_n_br = n }) = n > 10 -- See #23627++-------------------+mkLetUnfolding :: SimplEnv -> TopLevelFlag -> UnfoldingSource+               -> InId -> Bool    -- True <=> this is a join point+               -> OutExpr -> SimplM Unfolding+mkLetUnfolding env top_lvl src id is_join new_rhs+  = return (mkUnfolding uf_opts src is_top_lvl is_bottoming is_join new_rhs Nothing)+            -- We make an  unfolding *even for loop-breakers*.+            -- Reason: (a) It might be useful to know that they are WHNF+            --         (b) In GHC.Iface.Tidy we currently assume that, if we want to+            --             expose the unfolding then indeed we *have* an unfolding+            --             to expose.  (We could instead use the RHS, but currently+            --             we don't.)  The simple thing is always to have one.+  where+    -- !opts: otherwise, we end up retaining all the SimpleEnv+    !uf_opts = seUnfoldingOpts env++    -- Might as well force this, profiles indicate up to+    -- 0.5MB of thunks just from this site.+    !is_top_lvl   = isTopLevel top_lvl+    -- See Note [Force bottoming field]+    !is_bottoming = isDeadEndId id++-------------------+simplStableUnfolding :: SimplEnv -> BindContext+                     -> InId+                     -> OutType+                     -> ArityType      -- Used to eta expand, but only for non-join-points+                     -> Unfolding+                     ->SimplM Unfolding+-- Note [Setting the new unfolding]+simplStableUnfolding env bind_cxt id rhs_ty id_arity unf+  = case unf of+      NoUnfolding   -> return unf+      BootUnfolding -> return unf+      OtherCon {}   -> return unf++      DFunUnfolding { df_bndrs = bndrs, df_con = con, df_args = args }+        -> do { (env', bndrs') <- simplBinders unf_env bndrs+              ; args' <- mapM (simplExpr env') args+              ; return (mkDFunUnfolding bndrs' con args') }++      CoreUnfolding { uf_tmpl = expr, uf_src = src, uf_guidance = guide }+        | isStableSource src+        -> do { expr' <- case bind_cxt of+                  BC_Join _ cont    -> -- Binder is a join point+                                       -- See Note [Rules and unfolding for join points]+                                       simplJoinRhs unf_env id expr cont+                  BC_Let _ is_rec -> -- Binder is not a join point+                                     do { let cont = mkRhsStop rhs_ty is_rec topDmd+                                           -- mkRhsStop: switch off eta-expansion at the top level+                                        ; expr' <- simplExprC unf_env expr cont+                                        ; return (eta_expand expr') }+              ; case guide of+                  UnfWhen { ug_boring_ok = boring_ok }+                     -- Happens for INLINE things+                     -- Really important to force new_boring_ok since otherwise+                     --   `ug_boring_ok` is a thunk chain of+                     --   inlineBoringExprOk expr0 || inlineBoringExprOk expr1 || ...+                     -- See #20134+                     -> let !new_boring_ok = boring_ok || inlineBoringOk expr'+                            guide' = guide { ug_boring_ok = new_boring_ok }+                        -- Refresh the boring-ok flag, in case expr'+                        -- has got small. This happens, notably in the inlinings+                        -- for dfuns for single-method classes; see+                        -- Note [Single-method classes] in GHC.Tc.TyCl.Instance.+                        -- A test case is #4138+                        -- But retain a previous boring_ok of True; e.g. see+                        -- the way it is set in calcUnfoldingGuidanceWithArity+                        in return (mkCoreUnfolding src is_top_lvl expr' Nothing guide')+                            -- See Note [Top-level flag on inline rules] in GHC.Core.Unfold++                  _other              -- Happens for INLINABLE things+                     -> mkLetUnfolding env top_lvl src id False expr' }+                -- If the guidance is UnfIfGoodArgs, this is an INLINABLE+                -- unfolding, and we need to make sure the guidance is kept up+                -- to date with respect to any changes in the unfolding.++        | otherwise -> return noUnfolding   -- Discard unstable unfoldings+  where+    -- Forcing this can save about 0.5MB of max residency and the result+    -- is small and easy to compute so might as well force it.+    top_lvl     = bindContextLevel bind_cxt+    !is_top_lvl = isTopLevel top_lvl+    act        = idInlineActivation id+    unf_env    = updMode (updModeForStableUnfoldings act) env+         -- See Note [Simplifying inside stable unfoldings] in GHC.Core.Opt.Simplify.Utils++    -- See Note [Eta-expand stable unfoldings]+    -- Use the arity from the main Id (in id_arity), rather than computing it from rhs+    -- Not used for join points+    eta_expand expr | seEtaExpand env+                    , exprArity expr < arityTypeArity id_arity+                    , wantEtaExpansion expr+                    = etaExpandAT (getInScope env) id_arity expr+                    | otherwise+                    = expr++{- Note [Eta-expand stable unfoldings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For INLINE/INLINABLE things (which get stable unfoldings) there's a danger+of getting+   f :: Int -> Int -> Int -> Blah+   [ Arity = 3                 -- Good arity+   , Unf=Stable (\xy. blah)    -- Less good arity, only 2+   f = \pqr. e++This can happen because f's RHS is optimised more vigorously than+its stable unfolding.  Now suppose we have a call+   g = f x+Because f has arity=3, g will have arity=2.  But if we inline f (using+its stable unfolding) g's arity will reduce to 1, because <blah>+hasn't been optimised yet.  This happened in the 'parsec' library,+for Text.Pasec.Char.string.++Generally, if we know that 'f' has arity N, it seems sensible to+eta-expand the stable unfolding to arity N too. Simple and consistent.++Wrinkles++* See Historical-note [Eta-expansion in stable unfoldings] in+  GHC.Core.Opt.Simplify.Utils++* Don't eta-expand a trivial expr, else each pass will eta-reduce it,+  and then eta-expand again. See Note [Which RHSs do we eta-expand?]+  in GHC.Core.Opt.Simplify.Utils.++* Don't eta-expand join points; see Note [Do not eta-expand join points]+  in GHC.Core.Opt.Simplify.Utils.  We uphold this because the join-point+  case (bind_cxt = BC_Join {}) doesn't use eta_expand.++Note [Force bottoming field]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We need to force bottoming, or the new unfolding holds+on to the old unfolding (which is part of the id).++Note [Setting the new unfolding]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+* If there's an INLINE pragma, we simplify the RHS gently.  Maybe we+  should do nothing at all, but simplifying gently might get rid of+  more crap.++* If not, we make an unfolding from the new RHS.  But *only* for+  non-loop-breakers. Making loop breakers not have an unfolding at all+  means that we can avoid tests in exprIsConApp, for example.  This is+  important: if exprIsConApp says 'yes' for a recursive thing, then we+  can get into an infinite loop++If there's a stable unfolding on a loop breaker (which happens for+INLINABLE), we hang on to the inlining.  It's pretty dodgy, but the+user did say 'INLINE'.  May need to revisit this choice.++************************************************************************+*                                                                      *+                    Rules+*                                                                      *+************************************************************************++Note [Rules in a letrec]+~~~~~~~~~~~~~~~~~~~~~~~~+After creating fresh binders for the binders of a letrec, we+substitute the RULES and add them back onto the binders; this is done+*before* processing any of the RHSs.  This is important.  Manuel found+cases where he really, really wanted a RULE for a recursive function+to apply in that function's own right-hand side.++See Note [Forming Rec groups] in "GHC.Core.Opt.OccurAnal"+-}++addBndrRules :: SimplEnv -> InBndr -> OutBndr+             -> BindContext+             -> SimplM (SimplEnv, OutBndr)+-- Rules are added back into the bin+addBndrRules env in_id out_id bind_cxt+  | null old_rules+  = return (env, out_id)+  | otherwise+  = do { new_rules <- simplRules env (Just out_id) old_rules bind_cxt+       ; let final_id  = out_id `setIdSpecialisation` mkRuleInfo new_rules+       ; return (modifyInScope env final_id, final_id) }+  where+    old_rules = ruleInfoRules (idSpecialisation in_id)++simplImpRules :: SimplEnv -> [CoreRule] -> SimplM [CoreRule]+-- Simplify local rules for imported Ids+simplImpRules env rules+  = simplRules env Nothing rules (BC_Let TopLevel NonRecursive)++simplRules :: SimplEnv -> Maybe OutId -> [CoreRule]+           -> BindContext -> SimplM [CoreRule]+simplRules env mb_new_id rules bind_cxt+  = mapM simpl_rule rules+  where+    simpl_rule rule@(BuiltinRule {})+      = return rule++    simpl_rule rule@(Rule { ru_bndrs = bndrs, ru_args = args+                          , ru_fn = fn_name, ru_rhs = rhs+                          , ru_act = act })+      = do { (env', bndrs') <- simplBinders env bndrs+           ; let rhs_ty = substTy env' (exprType rhs)+                 rhs_cont = case bind_cxt of  -- See Note [Rules and unfolding for join points]+                                BC_Let {}      -> mkBoringStop rhs_ty+                                BC_Join _ cont -> assertPpr join_ok bad_join_msg cont+                 lhs_env = updMode updModeForRules env'+                 rhs_env = updMode (updModeForStableUnfoldings act) env'+                           -- See Note [Simplifying the RHS of a RULE]+                 -- Force this to avoid retaining reference to old Id+                 !fn_name' = case mb_new_id of+                              Just id -> idName id+                              Nothing -> fn_name++                 -- join_ok is an assertion check that the join-arity of the+                 -- binder matches that of the rule, so that pushing the+                 -- continuation into the RHS makes sense+                 join_ok = case mb_new_id of+                             Just id | JoinPoint join_arity <- idJoinPointHood id+                                     -> length args == join_arity+                             _ -> False+                 bad_join_msg = vcat [ ppr mb_new_id, ppr rule+                                     , ppr (fmap idJoinPointHood mb_new_id) ]++           ; args' <- mapM (simplExpr lhs_env) args+           ; rhs'  <- simplExprC rhs_env rhs rhs_cont+           ; return (rule { ru_bndrs = bndrs'+                          , ru_fn    = fn_name'+                          , ru_args  = args'+                          , ru_rhs   = occurAnalyseExpr rhs' }) }+                            -- Remember to occ-analyse, to drop dead code.+                            -- See Note [OccInfo in unfoldings and rules] in GHC.Core++{- Note [Simplifying the RHS of a RULE]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We can simplify the RHS of a RULE much as we do the RHS of a stable+unfolding.  We used to use the much more conservative updModeForRules+for the RHS as well as the LHS, but that seems more conservative+than necesary.  Allowing some inlining might, for example, eliminate+a binding.+-}
GHC/Core/Opt/Simplify/Monad.hs view
@@ -7,9 +7,9 @@  module GHC.Core.Opt.Simplify.Monad (         -- The monad-        SimplM,+        TopEnvConfig(..), SimplM,         initSmpl, traceSmpl,-        getSimplRules, getFamEnvs, getOptCoercionOpts,+        getSimplRules,          -- Unique supply         MonadUnique(..), newId, newJoinId,@@ -24,18 +24,14 @@  import GHC.Types.Var       ( Var, isId, mkLocalVar ) import GHC.Types.Name      ( mkSystemVarName )-import GHC.Types.Id        ( Id, mkSysLocalOrCoVar )+import GHC.Types.Id        ( Id, mkSysLocalOrCoVarM ) import GHC.Types.Id.Info   ( IdDetails(..), vanillaIdInfo, setArityInfo ) import GHC.Core.Type       ( Type, Mult )-import GHC.Core.FamInstEnv ( FamInstEnv )-import GHC.Core            ( RuleEnv(..), RuleBase)+import GHC.Core.Opt.Stats import GHC.Core.Rules import GHC.Core.Utils      ( mkLamTypes )-import GHC.Core.Coercion.Opt import GHC.Types.Unique.Supply-import GHC.Driver.Session-import GHC.Driver.Config-import GHC.Core.Opt.Monad+import GHC.Driver.Flags import GHC.Utils.Outputable import GHC.Data.FastString import GHC.Utils.Monad@@ -44,7 +40,7 @@ import GHC.Utils.Panic     (throwGhcExceptionIO, GhcException (..)) import GHC.Types.Basic     ( IntWithInf, treatZeroAsInf, mkIntWithInf ) import Control.Monad       ( ap )-import GHC.Core.Multiplicity        ( pattern Many )+import GHC.Core.Multiplicity        ( pattern ManyTy ) import GHC.Exts( oneShot )  {-@@ -53,13 +49,10 @@ \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+  =  SM'  { unSM :: SimplTopEnv                  -> SimplCount                  -> IO (result, SimplCount)}     -- We only need IO here for dump output, but since we already have it@@ -76,54 +69,53 @@   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 { st_flags     :: DynFlags+  = 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_query_rulebase :: IO RuleBase-          -- ^ The action to retrieve an up-to-date EPS RuleBase+        , 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]-        , st_mod_rules :: RuleEnv-        , st_fams      :: (FamInstEnv, FamInstEnv)--        , st_co_opt_opts :: !OptCoercionOpts-            -- ^ Coercion optimiser options         } -initSmpl :: Logger -> DynFlags -> IO RuleBase -> RuleEnv -> (FamInstEnv, FamInstEnv)-         -> Int                 -- Size of the bindings, used to limit-                                -- the number of ticks we allow+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 dflags qrb rules fam_envs size m+initSmpl logger read_ruleenv cfg size m   = do -- No init count; set to 0-       let simplCount = zeroSimplCount dflags-       (result, count) <- unSM m env simplCount-       return (result, count)+       let simplCount = zeroSimplCount $ logHasDumpFlag logger Opt_D_dump_simpl_stats+       unSM m env simplCount   where-    env = STE { st_flags = dflags+    env = STE { st_config = cfg               , st_logger = logger-              , st_query_rulebase = qrb-              , st_mod_rules = rules-              , st_max_ticks = computeMaxTicks dflags size-              , st_fams = fam_envs-              , st_co_opt_opts = initOptCoercionOpts dflags+              , st_max_ticks = computeMaxTicks cfg size+              , st_read_ruleenv = read_ruleenv               } -computeMaxTicks :: DynFlags -> Int -> IntWithInf+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 dflags size+computeMaxTicks cfg size   = treatZeroAsInf $     fromInteger ((toInteger (size + base_size)                   * toInteger (tick_factor * magic_multiplier))           `div` 100)   where-    tick_factor      = simplTickFactor dflags+    tick_factor      = te_tick_factor cfg     base_size        = 100     magic_multiplier = 40         -- MAGIC NUMBER, multiplies the simplTickFactor@@ -188,39 +180,33 @@ ************************************************************************ -} --- See Note [Uniques for wired-in prelude things and known masks] in GHC.Builtin.Uniques-simplMask :: Char-simplMask = 's'+-- 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 simplMask-    getUniqueM = liftIO $ uniqFromMask simplMask--instance HasDynFlags SimplM where-    getDynFlags = SM (\st_env sc -> return (st_flags st_env, sc))+    getUniqueSupplyM = liftIO $ mkSplitUniqSupply simplTag+    getUniqueM = liftIO $ uniqFromTag simplTag  instance HasLogger SimplM where-    getLogger = SM (\st_env sc -> return (st_logger st_env, sc))+    getLogger = gets st_logger  instance MonadIO SimplM where-    liftIO m = SM $ \_ sc -> do-      x <- m-      return (x, sc)+    liftIO = liftIOWithEnv . const  getSimplRules :: SimplM RuleEnv-getSimplRules = SM (\st_env sc -> do-    eps_rules <- st_query_rulebase st_env-    return (extendRuleEnv (st_mod_rules st_env) eps_rules, sc))+getSimplRules = liftIOWithEnv st_read_ruleenv -getFamEnvs :: SimplM (FamInstEnv, FamInstEnv)-getFamEnvs = SM (\st_env sc -> return (st_fams st_env, sc))+liftIOWithEnv :: (SimplTopEnv -> IO a) -> SimplM a+liftIOWithEnv m = SM (\st_env sc -> do+    x <- m st_env+    return (x, sc)) -getOptCoercionOpts :: SimplM OptCoercionOpts-getOptCoercionOpts = SM (\st_env sc -> return (st_co_opt_opts st_env, sc))+gets :: (SimplTopEnv -> a) -> SimplM a+gets f = liftIOWithEnv (return . f)  newId :: FastString -> Mult -> Type -> SimplM Id-newId fs w ty = do uniq <- getUniqueM-                   return (mkSysLocalOrCoVar fs uniq w ty)+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@@ -233,9 +219,8 @@              join_arity = length bndrs              details    = JoinId join_arity Nothing              id_info    = vanillaIdInfo `setArityInfo` arity---                                        `setOccInfo` strongLoopBreaker -       ; return (mkLocalVar details name Many join_id_ty id_info) }+       ; return (mkLocalVar details name ManyTy join_id_ty id_info) }  {- ************************************************************************@@ -249,8 +234,10 @@ getSimplCount = SM (\_st_env sc -> return (sc, sc))  tick :: Tick -> SimplM ()-tick t = SM (\st_env sc -> let sc' = doSimplTick (st_flags st_env) t sc-                              in sc' `seq` return ((), sc'))+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@@ -259,8 +246,10 @@            if st_max_ticks st_env <= mkIntWithInf (simplCountN sc)            then throwGhcExceptionIO $                   PprProgramError "Simplifier ticks exhausted" (msg sc)-           else let sc' = doSimplTick (st_flags st_env) t sc-                in sc' `seq` return ((), 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
GHC/Core/Opt/Simplify/Utils.hs view
@@ -8,2583 +8,2810 @@  module GHC.Core.Opt.Simplify.Utils (         -- Rebuilding-        mkLam, mkCase, prepareAlts, tryEtaExpandRhs,--        -- Inlining,-        preInlineUnconditionally, postInlineUnconditionally,-        activeUnfolding, activeRule,-        getUnfoldingInRuleMatch,-        simplEnvForGHCi, updModeForStableUnfoldings, updModeForRules,--        -- The BindContext type-        BindContext(..), bindContextLevel,--        -- The continuation type-        SimplCont(..), DupFlag(..), StaticEnv,-        isSimplified, contIsStop,-        contIsDupable, contResultType, contHoleType, contHoleScaling,-        contIsTrivial, contArgs,-        countArgs,-        mkBoringStop, mkRhsStop, mkLazyArgStop, contIsRhsOrArg,-        interestingCallContext,--        -- ArgInfo-        ArgInfo(..), ArgSpec(..), mkArgInfo,-        addValArgTo, addCastTo, addTyArgTo,-        argInfoExpr, argInfoAppArgs, pushSimplifiedArgs,-        isStrictArgInfo, lazyArgContext,--        abstractFloats,--        -- Utilities-        isExitJoinId-    ) where--import GHC.Prelude--import GHC.Driver.Session--import GHC.Core-import GHC.Types.Literal ( isLitRubbish )-import GHC.Core.Opt.Simplify.Env-import GHC.Core.Opt.Monad        ( SimplMode(..), Tick(..) )-import qualified GHC.Core.Subst-import GHC.Core.Ppr-import GHC.Core.TyCo.Ppr ( pprParendType )-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.Logger-import GHC.Utils.Panic-import GHC.Utils.Panic.Plain-import GHC.Utils.Trace--import Control.Monad    ( when )-import Data.List        ( sortBy )--{- *********************************************************************-*                                                                      *-                The BindContext type-*                                                                      *-********************************************************************* -}---- What sort of binding is this? A let-binding or a join-binding?-data BindContext-  = BC_Let                 -- A regular let-binding-      TopLevelFlag RecFlag--  | BC_Join                -- A join point with continuation k-      SimplCont            -- See Note [Rules and unfolding for join points]-                           -- in GHC.Core.Opt.Simplify--bindContextLevel :: BindContext -> TopLevelFlag-bindContextLevel (BC_Let top_lvl _) = top_lvl-bindContextLevel (BC_Join {})       = NotTopLevel---{- *********************************************************************-*                                                                      *-                The SimplCont and DupFlag types-*                                                                      *-************************************************************************--A SimplCont allows the simplifier to traverse the expression in a-zipper-like fashion.  The SimplCont represents the rest of the expression,-"above" the point of interest.--You can also think of a SimplCont as an "evaluation context", using-that term in the way it is used for operational semantics. This is the-way I usually think of it, For example you'll often see a syntax for-evaluation context looking like-        C ::= []  |  C e   |  case C of alts  |  C `cast` co-That's the kind of thing we are doing here, and I use that syntax in-the comments.---Key points:-  * A SimplCont describes a *strict* context (just like-    evaluation contexts do).  E.g. Just [] is not a SimplCont--  * A SimplCont describes a context that *does not* bind-    any variables.  E.g. \x. [] is not a SimplCont--}--data SimplCont-  = Stop                -- Stop[e] = e-        OutType         -- Type of the <hole>-        CallCtxt        -- Tells if there is something interesting about-                        --          the 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              -- (CastIt co K)[e] = K[ e `cast` co ]-        OutCoercion             -- The coercion simplified-                                -- Invariant: never an identity coercion-        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_bndr  :: InId-      , sc_body  :: InExpr-      , sc_env   :: StaticEnv      -- See Note [StaticEnv invariant]-      , sc_cont  :: SimplCont }--  | StrictArg           -- (StrictArg (f e1 ..en) K)[e] = K[ f e1 .. en e ]-      { sc_dup  :: DupFlag     -- Always Simplified or OkToDup-      , sc_fun  :: ArgInfo     -- Specifies f, e1..en, Whether f has rules, etc-                               --     plus demands and discount flags for *this* arg-                               --          and further args-                               --     So ai_dmds and ai_discs are never empty-      , sc_fun_ty :: OutType   -- Type of the function (f e1 .. en),-                               -- presumably (arg_ty -> res_ty)-                               -- where res_ty is expected by sc_cont-      , sc_cont :: SimplCont }--  | TickIt              -- (TickIt t K)[e] = K[ tick t e ]-        CoreTickish     -- Tick tickish <hole>-        SimplCont--type StaticEnv = SimplEnv       -- Just the static part is relevant--data 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 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 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, sc_hole_ty = hole_ty })-    = (hang (text "ApplyToVal" <+> ppr dup <+> text "hole" <+> ppr 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_env = se, sc_cont = cont })-    = (text "Select" <+> ppr dup <+> ppr bndr) $$-       whenPprDebug (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-     (<hole> @Int) :: Int-What is the type of <hole>?  It could be (forall a. Int) or (forall a. a),-and there is no way to know which, so we must record it.--In a chain of applications  (f @t1 @t2 @t3) we'll lazily compute exprType-for (f @t1) and (f @t1 @t2), which is potentially non-linear; but it probably-doesn't matter because we'll never compute them all.--************************************************************************-*                                                                      *-                ArgInfo and ArgSpec-*                                                                      *-************************************************************************--}--data ArgInfo-  = ArgInfo {-        ai_fun   :: OutId,      -- The function-        ai_args  :: [ArgSpec],  -- ...applied to these args (which are in *reverse* order)--        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_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 (beyong 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)--  | CastBy OutCoercion                -- Cast by this; c.f. CastIt--instance Outputable ArgInfo where-  ppr (ArgInfo { ai_fun = fun, ai_args = args, ai_dmds = dmds })-    = text "ArgInfo" <+> braces-         (sep [ text "fun =" <+> ppr fun-              , text "dmds =" <+> ppr dmds-              , text "args =" <+> ppr args ])--instance Outputable ArgSpec where-  ppr (ValArg { as_arg = arg })  = text "ValArg" <+> ppr arg-  ppr (TyArg { as_arg_ty = ty }) = text "TyArg" <+> ppr ty-  ppr (CastBy c)                 = text "CastBy" <+> ppr c--addValArgTo :: ArgInfo ->  OutExpr -> OutType -> ArgInfo-addValArgTo ai arg hole_ty-  | ArgInfo { ai_dmds = dmd:dmds, ai_discs = _:discs, ai_rules = rules } <- 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-       , ai_rules = decRules rules }-  | 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-                                  , ai_rules = decRules (ai_rules ai) }-  where-    arg_spec = TyArg { as_arg_ty = arg_ty, as_hole_ty = hole_ty }--addCastTo :: ArgInfo -> OutCoercion -> ArgInfo-addCastTo ai co = ai { ai_args = CastBy co : ai_args ai }--isStrictArgInfo :: ArgInfo -> Bool--- True if the function is strict in the next argument-isStrictArgInfo (ArgInfo { ai_dmds = dmds })-  | dmd:_ <- dmds = isStrUsedDmd dmd-  | otherwise     = False--argInfoAppArgs :: [ArgSpec] -> [OutExpr]-argInfoAppArgs []                              = []-argInfoAppArgs (CastBy {}                : _)  = []  -- Stop at a cast-argInfoAppArgs (ValArg { as_arg = arg }  : as) = arg     : 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 { as_arg = arg, as_hole_ty = hole_ty }-             -> ApplyToVal { sc_arg = arg, sc_env = env, sc_dup = Simplified-                           , sc_hole_ty = hole_ty, 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 { as_arg = arg }  : as) = go as `App` arg-    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 GHC.Core.Unfold-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 (CastIt _ k)     = contIsRhs k   -- For f = e |> co, treat e as Rhs context-contIsRhs _                = False----------------------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 _ 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 _ k)                                      = contIsTrivial k-contIsTrivial _                                                 = False----------------------contResultType :: SimplCont -> OutType-contResultType (Stop ty _)                  = ty-contResultType (CastIt _ 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 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 _ _) = One-contHoleScaling (CastIt _ 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 _ cont)                 = 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 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 _ 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 :: SimplEnv-          -> Id-          -> [CoreRule] -- Rules for function-          -> Int        -- Number of value args-          -> SimplCont  -- Context of the call-          -> ArgInfo--mkArgInfo env fun rules n_val_args call_cont-  | n_val_args < idArity fun            -- Note [Unsaturated functions]-  = ArgInfo { ai_fun = fun, ai_args = []-            , ai_rules = fun_rules-            , ai_encl = False-            , ai_dmds = vanilla_dmds-            , ai_discs = vanilla_discounts }-  | otherwise-  = ArgInfo { ai_fun   = fun-            , ai_args = []-            , ai_rules = fun_rules-            , ai_encl  = interestingArgContext rules call_cont-            , ai_dmds  = add_type_strictness (idType fun) arg_dmds-            , ai_discs = arg_discounts }-  where-    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_dmds, arg_dmds :: [Demand]-    vanilla_dmds  = repeat topDmd--    arg_dmds-      | not (sm_inline (seMode 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'-             | Just Unlifted <- typeLevity_maybe arg_ty-             = strictifyDmd dmd-             | otherwise-             -- Something that's not definitely unlifted.-             -- If the type is representation-polymorphic, we can't know whether-             -- it's strict.-             = dmd-      = dmd' : add_type_strictness fun_ty' rest_dmds--      | 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, application etc.) then we-inline, otherwise we don't.--Previously some_benefit used to return True only if the variable was-applied to some value arguments.  This didn't work:--        let x = _coerce_ (T Int) Int (I# 3) in-        case _coerce_ Int (T Int) x of-                I# y -> ....--we want to inline x, but can't see that it's a constructor in a case-scrutinee position, and some_benefit is False.--Another example:--dMonadST = _/\_ t -> :Monad (g1 _@_ t, g2 _@_ t, g3 _@_ t)--....  case dMonadST _@_ x0 of (a,b,c) -> ....--we'd really like to inline dMonadST here, but we *don't* want to-inline if the case expression is just--        case x of y { DEFAULT -> ... }--since we can just eliminate this case instead (x is in WHNF).  Similar-applies when x is bound to a lambda expression.  Hence-contIsInteresting looks for case expressions with just a single-default case.--Note [No case of case is boring]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If we see-   case f x of <alts>--we'd usually treat the context as interesting, to encourage 'f' to-inline.  But if case-of-case is off, it's really not so interesting-after all, because we are unlikely to be able to push the case-expression into the branches of any case in f's unfolding.  So, to-reduce unnecessary code expansion, we just make the context look boring.-This made a small compile-time perf improvement in perf/compiler/T6048,-and it looks plausible to me.--}--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-      -- 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'--interestingCallContext :: SimplEnv -> SimplCont -> CallCtxt--- See Note [Interesting call context]-interestingCallContext env cont-  = interesting cont-  where-    interesting (Select {})-       | sm_case_case (getMode env) = CaseCtxt-       | otherwise                  = BoringCtxt-       -- See Note [No case of case is boring]--    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 _ 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 <hole> 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 { sc_fun = fun }) = ai_encl fun-    go (StrictBind {})              = False      -- ??-    go (CastIt _ c)                 = go c-    go (Stop _ RuleArgCtxt)         = True-    go (Stop _ _)                   = False-    go (TickIt _ c)                 = go c--{- 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-       | 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)--{--************************************************************************-*                                                                      *-                  SimplMode-*                                                                      *-************************************************************************--The SimplMode controls several switches; see its definition in-GHC.Core.Opt.Monad-        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 :: Logger -> DynFlags -> SimplEnv-simplEnvForGHCi logger dflags-  = mkSimplEnv $ SimplMode { sm_names  = ["GHCi"]-                           , sm_phase  = InitialPhase-                           , sm_logger = logger-                           , sm_dflags = dflags-                           , sm_uf_opts = uf_opts-                           , sm_rules  = rules_on-                           , sm_inline = False-                              -- Do not do any inlining, in case we expose some-                              -- unboxed tuple stuff that confuses the bytecode-                              -- interpreter-                           , sm_eta_expand = eta_expand_on-                           , sm_cast_swizzle = True-                           , sm_case_case  = True-                           , sm_pre_inline = pre_inline_on-                           }-  where-    rules_on      = gopt Opt_EnableRewriteRules   dflags-    eta_expand_on = gopt Opt_DoLambdaEtaExpansion dflags-    pre_inline_on = gopt Opt_SimplPreInlining     dflags-    uf_opts       = unfoldingOpts                 dflags--updModeForStableUnfoldings :: Activation -> SimplMode -> SimplMode-updModeForStableUnfoldings unf_act current_mode-  = current_mode { sm_phase      = phaseFromActivation unf_act-                 , sm_eta_expand = False-                 , sm_inline     = True }-    -- sm_phase: see Note [Simplifying inside stable unfoldings]-    -- sm_eta_expand: see Note [Eta-expansion in stable unfoldings]-    -- 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]-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.-Moreover, 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.--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]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We don't do eta-expansion inside stable unfoldings.  It's extra work,-and can be expensive (the bizarre T18223 is a case in point).--See Note [Occurrence analysis for lambda binders] in GHC.Core.Opt.OccurAnal.--Historical note. There was /previously/ another reason not to do 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 previously did 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 didn't work properly (#9509).-But now it does: see Note [Account for casts in binding] in GHC.Core.Opt.Specialise---Note [Inlining in gentle mode]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Something is inlined if-   (i)   the sm_inline flag is on, AND-   (ii)  the thing has an INLINE pragma, AND-   (iii) the thing is inlinable in the earliest phase.--Example of why (iii) is important:-  {-# INLINE [~1] g #-}-  g = ...--  {-# INLINE f #-}-  f x = g (g x)--If we were to inline g into f's inlining, then an importing module would-never be able to do-        f e --> g (g e) ---> RULE fires-because the stable unfolding for f has had g inlined into it.--On the other hand, it is bad not to do ANY inlining into an-stable unfolding, because then recursive knots in instance declarations-don't get unravelled.--However, *sometimes* SimplGently must do no call-site inlining at all-(hence sm_inline = False).  Before full laziness we must be careful-not to inline wrappers, because doing so inhibits floating-    e.g. ...(case f x of ...)...-    ==> ...(case (case x of I# x# -> fw x#) of ...)...-    ==> ...(case x of I# x# -> case fw x# of ...)...-and now the redex (f x) isn't floatable any more.--The no-inlining thing is also important for Template Haskell.  You might be-compiling in one-shot mode with -O2; but when TH compiles a splice before-running it, we don't want to use -O2.  Indeed, we don't want to inline-anything, because the byte-code interpreter might get confused about-unboxed tuples and suchlike.--Note [Simplifying inside stable unfoldings]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We must take care with simplification inside stable unfoldings (which come from-INLINE pragmas).--First, consider the following example-        let f = \pq -> BIG-        in-        let g = \y -> f y y-            {-# INLINE g #-}-        in ...g...g...g...g...g...-Now, if that's the ONLY occurrence of f, it might be inlined inside g,-and thence copied multiple times when g is inlined. HENCE we treat-any occurrence in a stable unfolding as a multiple occurrence, not a single-one; see OccurAnal.addRuleUsage.--Second, we do want *do* to some modest rules/inlining stuff in stable-unfoldings, partly to eliminate senseless crap, and partly to break-the recursive knots generated by instance declarations.--However, suppose we have-        {-# INLINE <act> f #-}-        f = <rhs>-meaning "inline f in phases p where activation <act>(p) holds".-Then what inlinings/rules can we apply to the copy of <rhs> captured in-f's stable unfolding?  Our model is that literally <rhs> is substituted for-f when it is inlined.  So our conservative plan (implemented by-updModeForStableUnfoldings) is this:--  --------------------------------------------------------------  When simplifying the RHS of a stable unfolding, set the phase-  to the phase in which the stable unfolding first becomes active-  ---------------------------------------------------------------That ensures that--  a) Rules/inlinings that *cease* being active before p will-     not apply to the stable unfolding, consistent with it being-     inlined in its *original* form in phase p.--  b) Rules/inlinings that only become active *after* p will-     not apply to the stable unfolding, again to be consistent with-     inlining the *original* rhs in phase p.--For example,-        {-# INLINE f #-}-        f x = ...g...--        {-# NOINLINE [1] g #-}-        g y = ...--        {-# RULE h g = ... #-}-Here we must not inline g into f's RHS, even when we get to phase 0,-because when f is later inlined into some other module we want the-rule for h to fire.--Similarly, consider-        {-# INLINE f #-}-        f x = ...g...--        g y = ...-and suppose that there are auto-generated specialisations and a strictness-wrapper for g.  The specialisations get activation AlwaysActive, and the-strictness wrapper get activation (ActiveAfter 0).  So the strictness-wrepper fails the test and won't be inlined into f's stable unfolding. That-means f can inline, expose the specialised call to g, so the specialisation-rules can fire.--A note about wrappers-~~~~~~~~~~~~~~~~~~~~~-It's also important not to inline a worker back into a wrapper.-A wrapper looks like-        wraper = inline_me (\x -> ...worker... )-Normally, the inline_me prevents the worker getting inlined into-the wrapper (initially, the worker's only call site!).  But,-if the wrapper is sure to be called, the strictness analyser will-mark it 'demanded', so when the RHS is simplified, it'll get an ArgOf-continuation.--}--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--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 = isActive (sm_phase mode) (idInlineActivation id)-       -- When sm_rules was off we used to test for a /stable/ unfolding,-       -- but that seems wrong (#20941)-------------------------activeRule :: SimplMode -> Activation -> Bool--- Nothing => No rules at all-activeRule mode-  | not (sm_rules mode) = \_ -> False     -- Rewriting is off-  | otherwise           = isActive (sm_phase mode)--{--************************************************************************-*                                                                      *-                  preInlineUnconditionally-*                                                                      *-************************************************************************--preInlineUnconditionally-~~~~~~~~~~~~~~~~~~~~~~~~-@preInlineUnconditionally@ examines a bndr to see if it is used just-once in a completely safe way, so that it is safe to discard the-binding inline its RHS at the (unique) usage site, REGARDLESS of how-big the RHS might be.  If this is the case we don't simplify the RHS-first, but just inline it un-simplified.--This is much better than first simplifying a perhaps-huge RHS and then-inlining and re-simplifying it.  Indeed, it can be at least quadratically-better.  Consider--        x1 = e1-        x2 = e2[x1]-        x3 = e3[x2]-        ...etc...-        xN = eN[xN-1]--We may end up simplifying e1 N times, e2 N-1 times, e3 N-3 times etc.-This can happen with cascades of functions too:--        f1 = \x1.e1-        f2 = \xs.e2[f1]-        f3 = \xs.e3[f3]-        ...etc...--THE MAIN INVARIANT is this:--        ----  preInlineUnconditionally invariant ------   IF preInlineUnconditionally chooses to inline x = <rhs>-   THEN doing the inlining should not change the occurrence-        info for the free vars of <rhs>-        ------------------------------------------------For example, it's tempting to look at trivial binding like-        x = y-and inline it unconditionally.  But suppose x is used many times,-but this is the unique occurrence of y.  Then inlining x would change-y's occurrence info, which breaks the invariant.  It matters: y-might have a BIG rhs, which will now be dup'd at every occurrence of x.---Even RHSs labelled InlineMe aren't caught here, because there might be-no benefit from inlining at the call site.--[Sept 01] Don't unconditionally inline a top-level thing, because that-can simply make a static thing into something built dynamically.  E.g.-        x = (a,b)-        main = \s -> h x--[Remember that we treat \s as a one-shot lambda.]  No point in-inlining x unless there is something interesting about the call site.--But watch out: if you aren't careful, some useful foldr/build fusion-can be lost (most notably in spectral/hartel/parstof) because the-foldr didn't see the build.  Doing the dynamic allocation isn't a big-deal, in fact, but losing the fusion can be.  But the right thing here-seems to be to do a callSiteInline based on the fact that there is-something interesting about the call site (it's strict).  Hmm.  That-seems a bit fragile.--Conclusion: inline top level things gaily until FinalPhase (the last-phase), at which point don't.--Note [pre/postInlineUnconditionally in gentle mode]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Even in gentle mode we want to do preInlineUnconditionally.  The-reason is that too little clean-up happens if you don't inline-use-once things.  Also a bit of inlining is *good* for full laziness;-it can expose constant sub-expressions.  Example in-spectral/mandel/Mandel.hs, where the mandelset function gets a useful-let-float if you inline windowToViewport--However, as usual for Gentle mode, do not inline things that are-inactive in the initial stages.  See Note [Gentle mode].--Note [Stable unfoldings and preInlineUnconditionally]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Surprisingly, do not pre-inline-unconditionally Ids with INLINE pragmas!-Example--   {-# INLINE f #-}-   f :: Eq a => a -> a-   f x = ...--   fInt :: Int -> Int-   fInt = f Int dEqInt--   ...fInt...fInt...fInt...--Here f occurs just once, in the RHS of fInt. But if we inline it there-it might make fInt look big, and we'll lose the opportunity to inline f-at each of fInt's call sites.  The INLINE pragma will only inline when-the application is saturated for exactly this reason; and we don't-want PreInlineUnconditionally to second-guess it. A live example is #3736.-    c.f. Note [Stable unfoldings and postInlineUnconditionally]--NB: this only applies for INLINE things. Do /not/ switch off-preInlineUnconditionally for--* INLINABLE. It just says to GHC "inline this if you like".  If there-  is a unique occurrence, we want to inline the stable unfolding, not-  the RHS.--* NONLINE[n] just switches off inlining until phase n.  We should-  respect that, but after phase n, just behave as usual.--* NoUserInlinePrag.  There is no pragma at all. This ends up on wrappers.-  (See #18815.)--Note [Top-level bottoming Ids]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Don't inline top-level Ids that are bottoming, even if they are used just-once, because FloatOut has gone to some trouble to extract them out.-Inlining them won't make the program run faster!--Note [Do not inline CoVars unconditionally]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Coercion variables appear inside coercions, and the RHS of a let-binding-is a term (not a coercion) so we can't necessarily inline the latter in-the former.--}--preInlineUnconditionally-    :: SimplEnv -> TopLevelFlag -> InId-    -> InExpr -> StaticEnv  -- These two go together-    -> Maybe SimplEnv       -- Returned env has extended substitution--- Precondition: rhs satisfies the let/app invariant--- See Note [Core let/app invariant] in GHC.Core--- Reason: we don't want to inline single uses, or discard dead bindings,---         for unlifted, side-effect-ful bindings-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 = sm_pre_inline mode-    mode   = getMode env-    active = isActive (sm_phase mode) (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 _          = False-      -- not ticks.  Counting ticks cannot be duplicated, and non-counting-      -- ticks around a Lam will disappear anyway.--    early_phase = sm_phase mode /= 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.--{--************************************************************************-*                                                                      *-                  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-    -> OutId            -- The binder (*not* a CoVar), including its unfolding-    -> OccInfo          -- From the InId-    -> OutExpr-    -> Bool--- Precondition: rhs satisfies the let/app invariant--- See Note [Core let/app invariant] in GHC.Core--- Reason: we don't want to inline single uses, or discard dead bindings,---         for unlifted, side-effect-ful bindings-postInlineUnconditionally env bind_cxt bndr occ_info rhs-  | not active                  = False-  | isWeakLoopBreaker occ_info  = False -- If it's a loop-breaker of any kind, don't inline-                                        -- because it might be referred to "earlier"-  | isStableUnfolding unfolding = False -- Note [Stable unfoldings and postInlineUnconditionally]-  | isTopLevel (bindContextLevel bind_cxt)-                                = False -- Note [Top level and postInlineUnconditionally]-  | exprIsTrivial rhs           = True-  | BC_Join {} <- bind_cxt              -- See point (1) of Note [Duplicating join points]-  , not (phase == FinalPhase)   = False -- in Simplify.hs-  | 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  -- See Note [Suppress exponential blowup]--           && smallEnoughToInline uf_opts unfolding     -- Small enough to dup-                        -- ToDo: consider discount on smallEnoughToInline if int_cxt is true-                        ---                        -- NB: Do NOT inline arbitrarily big things, even if occ_n_br=1-                        -- 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.--           && (in_lam == NotInsideLam ||-                        -- Outside a lambda, we want to be reasonably aggressive-                        -- about inlining into multiple branches of case-                        -- e.g. let x = <non-value>-                        --      in case y of { C1 -> ..x..; C2 -> ..x..; C3 -> ... }-                        -- Inlining can be a big win if C3 is the hot-spot, even if-                        -- the uses in C1, C2 are not 'interesting'-                        -- An example that gets worse if you add int_cxt here is 'clausify'--                (isCheapUnfolding unfolding && int_cxt == IsInteresting))-                        -- 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 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!--  where-    unfolding = idUnfolding bndr-    uf_opts   = seUnfoldingOpts env-    phase     = sm_phase (getMode 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 [Suppress exponential blowup]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In #13253, and several related tickets, we got an exponential blowup-in code size from postInlineUnconditionally.  The trouble comes when-we have-  let j1a = case f y     of { True -> p;   False -> q }-      j1b = case f y     of { True -> q;   False -> p }-      j2a = case f (y+1) of { True -> j1a; False -> j1b }-      j2b = case f (y+1) of { True -> j1b; False -> j1a }-      ...-  in case f (y+10) of { True -> j10a; False -> j10b }--when there are many branches. In pass 1, postInlineUnconditionally-inlines j10a and j10b (they are both small).  Now we have two calls-to j9a and two to j9b.  In pass 2, postInlineUnconditionally inlines-all four of these calls, leaving four calls to j8a and j8b. Etc.-Yikes!  This is exponential!--A possible plan: stop doing postInlineUnconditionally-for some fixed, smallish number of branches, say 4. But that turned-out to be bad: see Note [Inline small things to avoid creating a thunk].-And, as it happened, the problem with #13253 was solved in a-different way (Note [Duplicating StrictArg] in Simplify).--So I just set an arbitrary, high limit of 100, to stop any-totally exponential behaviour.--This still leaves the nasty possibility that /ordinary/ inlining (not-postInlineUnconditionally) might inline these join points, each of-which is individually quiet small.  I'm still not sure what to do-about this (e.g. see #15488).--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-*                                                                      *-************************************************************************--}--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]------ NB: the SimplEnv already includes the [OutBndr] in its in-scope set-mkLam _env [] body _cont-  = return body-mkLam env bndrs body cont-  = {-#SCC "mkLam" #-}---    pprTrace "mkLam" (ppr bndrs $$ ppr body $$ ppr cont) $-    do { dflags <- getDynFlags-       ; mkLam' dflags bndrs body }-  where-    mode = getMode env--    mkLam' :: DynFlags -> [OutBndr] -> OutExpr -> SimplM OutExpr-    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 (Cast body co)-      | -- Note [Casts and lambdas]-        sm_cast_swizzle mode-      , not (any bad bndrs)-      = 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-      | gopt Opt_DoEtaReduction dflags-      , Just etad_lam <- {-# SCC "tryee" #-} tryEtaReduce bndrs body-      = do { tick (EtaReduction (head bndrs))-           ; return etad_lam }--      | not (contIsRhs cont)   -- See Note [Eta expanding lambdas]-      , sm_eta_expand mode-      , any isRuntimeVar bndrs-      , let body_arity = {-# SCC "eta" #-} exprEtaExpandArity dflags body-      , expandableArityType body_arity-      = do { tick (EtaExpansion (head bndrs))-           ; let res = {-# SCC "eta3" #-}-                       mkLams bndrs $-                       etaExpandAT in_scope body_arity body-           ; traceSmpl "eta expand" (vcat [text "before" <+> ppr (mkLams bndrs body)-                                          , text "after" <+> ppr res])-           ; return res }--      | otherwise-      = return (mkLams bndrs body)-      where-        in_scope = getInScope env  -- Includes 'bndrs'--{--Note [Eta expanding lambdas]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-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 [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))--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 -> OutId -> OutExpr-                -> SimplM (ArityType, OutExpr)--- See Note [Eta-expanding at let bindings]--- If tryEtaExpandRhs rhs = (n, is_bot, rhs') then---   (a) rhs' has manifest arity n---   (b) if is_bot is True then rhs' applied to n args is guaranteed bottom-tryEtaExpandRhs env bndr rhs-  | Just join_arity <- isJoinId_maybe bndr-  = do { let (join_bndrs, join_body) = collectNBinders join_arity rhs-             oss   = [idOneShotInfo id | id <- join_bndrs, isId id]-             arity_type | exprIsDeadEnd join_body = mkBotArityType oss-                        | otherwise               = mkTopArityType oss-       ; return (arity_type, rhs) }-         -- Note [Do not eta-expand join points]-         -- But do return the correct arity and bottom-ness, because-         -- these are used to set the bndr's IdInfo (#15517)-         -- Note [Invariants on join points] invariant 2b, in GHC.Core--  | sm_eta_expand mode      -- Provided eta-expansion is on-  , new_arity > old_arity   -- And the current manifest arity isn't enough-  , want_eta rhs-  = do { tick (EtaExpansion bndr)-       ; return (arity_type, etaExpandAT in_scope arity_type rhs) }--  | otherwise-  = return (arity_type, rhs)--  where-    mode      = getMode env-    in_scope  = getInScope env-    dflags    = sm_dflags mode-    old_arity = exprArity rhs--    arity_type = findRhsArity dflags bndr rhs old_arity-                 `maxWithArity` idCallArity bndr-    new_arity = arityTypeArity arity_type--    -- See Note [Which RHSs do we eta-expand?]-    want_eta (Cast e _)                  = want_eta e-    want_eta (Tick _ e)                  = want_eta e-    want_eta (Lam b e) | isTyVar b       = want_eta e-    want_eta (App e a) | exprIsTrivial a = want_eta e-    want_eta (Var {})                    = False-    want_eta (Lit {})                    = False-    want_eta _ = True-{--    want_eta _ = case arity_type of-                   ATop (os:_) -> isOneShotInfo os-                   ATop []     -> False-                   ABot {}     -> 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?--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---************************************************************************-*                                                                      *-\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.  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 (#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.--  * We get the variables to abstract over by filtering down the-    the main_tvs for the original function, picking only ones-    mentioned in the abstracted body. This means:-    - they are automatically in dependency order, because main_tvs is-    - there is no issue about non-determinism-    - we don't gratuitiously change order, which may help (in a tiny-      way) with CSE and/or the compiler-debugging experience--}--abstractFloats :: UnfoldingOpts -> TopLevelFlag -> [OutTyVar] -> SimplFloats-              -> OutExpr -> SimplM ([OutBind], OutExpr)-abstractFloats uf_opts top_lvl main_tvs floats body-  = assert (notNull body_floats) $-    assert (isNilOL (sfJoinFloats floats)) $-    do  { (subst, float_binds) <- mapAccumLM abstract empty_subst body_floats-        ; return (float_binds, GHC.Core.Subst.substExpr subst body) }-  where-    is_top_lvl  = isTopLevel top_lvl-    body_floats = letFloatBinds (sfLetFloats floats)-    empty_subst = GHC.Core.Subst.mkEmptySubst (sfInScope floats)--    abstract :: GHC.Core.Subst.Subst -> OutBind -> SimplM (GHC.Core.Subst.Subst, OutBind)-    abstract subst (NonRec id rhs)-      = 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 = filter (`elemVarSet` free_tvs) main_tvs-        free_tvs = closeOverKinds $-                   exprSomeFreeVars isTyVar rhs'--    abstract subst (Rec prs)-       = do { (poly_ids, poly_apps) <- mapAndUnzipM (mk_poly1 tvs_here) ids-            ; 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) = 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 = scopedSort main_tvs--    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 InlineRhs is_top_lvl False poly_rhs--        -- 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 CoreUtils 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!--}--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 (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)-                    _     -> []---{--************************************************************************-*                                                                      *-                mkCase-*                                                                      *-************************************************************************--mkCase tries these things--* Note [Merge Nested Cases]-* Note [Eliminate Identity Case]-* Note [Scrutinee Constant Folding]--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 scrutises the same variable as the outer case. This-transformation is called Case Merging.  It avoids that the same-variable is scrutinised multiple times.--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--* Do not apply caseRules if there is just a single DEFAULT alternative-     case e +# 3# of b { DEFAULT -> rhs }-  If we applied the transformation here we would (stupidly) get-     case a of b' { DEFAULT -> let b = e +# 3# in rhs }-  and now the process may repeat, because that let will really-  be a case.--* 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--* 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'.--* In dataToTag we might need to make up some fake binders;-  see Note [caseRules for dataToTag] in GHC.Core.Opt.ConstantFold--}--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 (Alt 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 (Alt con args rhs) = assert (outer_bndr `notElem` args)-                                            (Alt con args (wrap_rhs rhs))-                -- Simplifier's no-shadowing invariant should ensure-                -- that outer_bndr is not shadowed by the inner patterns-              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@(Alt _ _ rhs1 : _)      -- 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) (tail 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 dflags scrut bndr alts_ty alts = mkCase2 dflags scrut bndr alts_ty alts-------------------------------------------------------      2. Scrutinee Constant Folding-----------------------------------------------------mkCase2 dflags scrut bndr alts_ty alts-  | -- See Note [Scrutinee Constant Folding]-    case alts of  -- Not if there is just a DEFAULT alternative-      [Alt DEFAULT _ _] -> False-      _                 -> True-  , gopt Opt_CaseFolding dflags-  , Just (scrut', tx_con, mk_orig) <- caseRules (targetPlatform dflags) scrut-  = do { bndr' <- newId (fsLit "lwild") Many (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 dflags scrut' bndr' alts_ty $-         add_default (re_sort alts')-       }--  | 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-    ---    -- 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 sligthtly 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 _dflags 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-  && isOneOcc (idOccInfo id)-  && occ_in_lam (idOccInfo id) == IsInsideLam--{--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 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.+        rebuildLam, mkCase, prepareAlts,+        tryEtaExpandRhs, wantEtaExpansion,++        -- Inlining,+        preInlineUnconditionally, postInlineUnconditionally,+        activeRule,+        getUnfoldingInRuleMatch,+        updModeForStableUnfoldings, updModeForRules,++        -- The BindContext type+        BindContext(..), bindContextLevel,++        -- The continuation type+        SimplCont(..), DupFlag(..), FromWhat(..), StaticEnv,+        isSimplified, contIsStop,+        contIsDupable, contResultType, contHoleType, contHoleScaling,+        contIsTrivial, contArgs, contIsRhs,+        countArgs, contOutArgs, dropContArgs,+        mkBoringStop, mkRhsStop, mkLazyArgStop,+        interestingCallContext,++        -- ArgInfo+        ArgInfo(..), ArgSpec(..), mkArgInfo,+        addValArgTo, addTyArgTo,+        argInfoExpr, argSpecArg,+        pushSimplifiedArgs,+        isStrictArgInfo, lazyArgContext,++        abstractFloats,++        -- Utilities+        isExitJoinId+    ) where++import GHC.Prelude hiding (head, init, last, tail)+import qualified GHC.Prelude as Partial (head)++import GHC.Core+import GHC.Types.Literal ( isLitRubbish )+import GHC.Core.Opt.Simplify.Env+import GHC.Core.Opt.Simplify.Inline( smallEnoughToInline )+import GHC.Core.Opt.Stats ( Tick(..) )+import qualified GHC.Core.Subst+import GHC.Core.Ppr+import GHC.Core.TyCo.Ppr ( pprParendType )+import GHC.Core.FVs+import GHC.Core.Utils+import GHC.Core.Opt.Arity+import GHC.Core.Unfold+import GHC.Core.Unfold.Make+import GHC.Core.Opt.Simplify.Monad+import GHC.Core.Type     hiding( substTy )+import GHC.Core.Coercion hiding( substCo )+import GHC.Core.DataCon ( dataConWorkId, isNullaryRepDataCon )+import GHC.Core.Multiplicity+import GHC.Core.Opt.ConstantFold++import GHC.Types.Name+import GHC.Types.Id+import GHC.Types.Id.Info+import GHC.Types.Tickish+import GHC.Types.Demand+import GHC.Types.Var.Set+import GHC.Types.Basic++import GHC.Data.OrdList ( isNilOL )+import GHC.Data.FastString ( fsLit )++import GHC.Utils.Misc+import GHC.Utils.Monad+import GHC.Utils.Outputable+import GHC.Utils.Panic++import Control.Monad    ( when )+import Data.List        ( sortBy )+import GHC.Types.Name.Env+import Data.Graph++{- *********************************************************************+*                                                                      *+                The BindContext type+*                                                                      *+********************************************************************* -}++-- What sort of binding is this? A let-binding or a join-binding?+data BindContext+  = BC_Let                 -- A regular let-binding+      TopLevelFlag RecFlag++  | BC_Join                -- A join point with continuation k+      RecFlag              -- See Note [Rules and unfolding for join points]+      SimplCont            -- in GHC.Core.Opt.Simplify++bindContextLevel :: BindContext -> TopLevelFlag+bindContextLevel (BC_Let top_lvl _) = top_lvl+bindContextLevel (BC_Join {})       = NotTopLevel++bindContextRec :: BindContext -> RecFlag+bindContextRec (BC_Let _ rec_flag)  = rec_flag+bindContextRec (BC_Join rec_flag _) = rec_flag++isJoinBC :: BindContext -> Bool+isJoinBC (BC_Let {})  = False+isJoinBC (BC_Join {}) = True+++{- *********************************************************************+*                                                                      *+                The SimplCont and DupFlag types+*                                                                      *+************************************************************************++A SimplCont allows the simplifier to traverse the expression in a+zipper-like fashion.  The SimplCont represents the rest of the expression,+"above" the point of interest.++You can also think of a SimplCont as an "evaluation context", using+that term in the way it is used for operational semantics. This is the+way I usually think of it, For example you'll often see a syntax for+evaluation context looking like+        C ::= []  |  C e   |  case C of alts  |  C `cast` co+That's the kind of thing we are doing here, and I use that syntax in+the comments.+++Key points:+  * A SimplCont describes a *strict* context (just like+    evaluation contexts do).  E.g. Just [] is not a SimplCont++  * A SimplCont describes a context that *does not* bind+    any variables.  E.g. \x. [] is not a SimplCont+-}++data SimplCont+  = Stop                -- ^ Stop[e] = e+        OutType         -- ^ Type of the <hole>+        CallCtxt        -- ^ Tells if there is something interesting about+                        --          the syntactic context, and hence the inliner+                        --          should be a bit keener (see interestingCallContext)+                        -- Specifically:+                        --     This is an argument of a function that has RULES+                        --     Inlining the call might allow the rule to fire+                        -- Never ValAppCxt (use ApplyToVal instead)+                        -- or CaseCtxt (use Select instead)+        SubDemand       -- ^ The evaluation context of e. Tells how e is evaluated.+                        -- This fuels eta-expansion or eta-reduction without looking+                        -- at lambda bodies, for example.+                        --+                        -- See Note [Eta reduction based on evaluation context]+                        -- The evaluation context for other SimplConts can be+                        -- reconstructed with 'contEvalContext'+++  | CastIt              -- (CastIt co K)[e] = K[ e `cast` co ]+      { sc_co   :: OutCoercion  -- The coercion simplified+                                -- Invariant: never an identity coercion+      , sc_opt  :: Bool         -- True <=> sc_co has had optCoercion applied to it+                                --      See Note [Avoid re-simplifying coercions]+                                --      in GHC.Core.Opt.Simplify.Iteration+      , sc_cont :: SimplCont }++  | ApplyToVal         -- (ApplyToVal arg K)[e] = K[ e arg ]+      { sc_dup     :: DupFlag   -- See Note [DupFlag invariants]+      , sc_hole_ty :: OutType   -- Type of the function, presumably (forall a. blah)+                                -- See Note [The hole type in ApplyToTy]+      , sc_arg  :: InExpr       -- The argument,+      , sc_env  :: StaticEnv    -- see Note [StaticEnv invariant]+      , sc_cont :: SimplCont }++  | ApplyToTy          -- (ApplyToTy ty K)[e] = K[ e ty ]+      { sc_arg_ty  :: OutType     -- Argument type+      , sc_hole_ty :: OutType     -- Type of the function, presumably (forall a. blah)+                                  -- See Note [The hole type in ApplyToTy]+      , sc_cont    :: SimplCont }++  | Select             -- (Select alts K)[e] = K[ case e of alts ]+      { sc_dup  :: DupFlag        -- See Note [DupFlag invariants]+      , sc_bndr :: InId           -- case binder+      , sc_alts :: [InAlt]        -- Alternatives+      , sc_env  :: StaticEnv      -- See Note [StaticEnv invariant]+      , sc_cont :: SimplCont }++  -- The two strict forms have no DupFlag, because we never duplicate them+  | StrictBind          -- (StrictBind x b K)[e] = let x = e in K[b]+                        --       or, equivalently,  = K[ (\x.b) e ]+      { sc_dup   :: DupFlag        -- See Note [DupFlag invariants]+      , sc_from  :: FromWhat+      , sc_bndr  :: InId+      , sc_body  :: InExpr+      , sc_env   :: StaticEnv      -- Static env for both sc_bndr (stable unfolding thereof)+                                   -- and sc_body.  Also see Note [StaticEnv invariant]+      , sc_cont  :: SimplCont }++  | StrictArg           -- (StrictArg (f e1 ..en) K)[e] = K[ f e1 .. en e ]+      { sc_dup  :: DupFlag     -- Always Simplified or OkToDup+      , sc_fun  :: ArgInfo     -- Specifies f, e1..en, Whether f has rules, etc+                               --     plus demands and discount flags for *this* arg+                               --          and further args+                               --     So ai_dmds and ai_discs are never empty+      , sc_fun_ty :: OutType   -- Type of the function (f e1 .. en),+                               -- presumably (arg_ty -> res_ty)+                               -- where res_ty is expected by sc_cont+      , sc_cont :: SimplCont }++  | TickIt              -- (TickIt t K)[e] = K[ tick t e ]+        CoreTickish     -- Tick tickish <hole>+        SimplCont++type StaticEnv = SimplEnv       -- Just the static part is relevant++data FromWhat = FromLet | FromBeta Levity++-- See Note [DupFlag invariants]+data DupFlag = NoDup       -- Unsimplified, might be big+             | Simplified  -- Simplified+             | OkToDup     -- Simplified and small++isSimplified :: DupFlag -> Bool+isSimplified NoDup = False+isSimplified _     = True       -- Invariant: the subst-env is empty++perhapsSubstTy :: DupFlag -> StaticEnv -> Type -> Type+perhapsSubstTy dup env ty+  | isSimplified dup = ty+  | otherwise        = substTy env ty++{- Note [StaticEnv invariant]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We pair up an InExpr or InAlts with a StaticEnv, which establishes the+lexical scope for that InExpr.++When we simplify that InExpr/InAlts, we use+  - Its captured StaticEnv+  - Overriding its InScopeSet with the larger one at the+    simplification point.++Why override the InScopeSet?  Example:+      (let y = ey in f) ex+By the time we simplify ex, 'y' will be in scope.++However the InScopeSet in the StaticEnv is not irrelevant: it should+include all the free vars of applying the substitution to the InExpr.+Reason: contHoleType uses perhapsSubstTy to apply the substitution to+the expression, and that (rightly) gives ASSERT failures if the InScopeSet+isn't big enough.++Note [DupFlag invariants]+~~~~~~~~~~~~~~~~~~~~~~~~~+In both ApplyToVal { se_dup = dup, se_env = env, se_cont = k}+   and  Select { se_dup = dup, se_env = env, se_cont = k}+the following invariants hold++  (a) if dup = OkToDup, then continuation k is also ok-to-dup+  (b) if dup = OkToDup or Simplified, the subst-env is empty,+               or at least is always ignored; the payload is+               already an OutThing+-}++instance Outputable DupFlag where+  ppr OkToDup    = text "ok"+  ppr NoDup      = text "nodup"+  ppr Simplified = text "simpl"++instance Outputable SimplCont where+  ppr (Stop ty interesting eval_sd)+    = text "Stop" <> brackets (sep $ punctuate comma pps) <+> ppr ty+    where+      pps = [ppr interesting] ++ [ppr eval_sd | eval_sd /= topSubDmd]+  ppr (CastIt { sc_co = co, sc_cont = cont })+    = (text "CastIt" <+> pprOptCo co) $$ ppr cont+  ppr (TickIt t cont)+    = (text "TickIt" <+> ppr t) $$ ppr cont+  ppr (ApplyToTy  { sc_arg_ty = ty, sc_cont = cont })+    = (text "ApplyToTy" <+> pprParendType ty) $$ ppr cont+  ppr (ApplyToVal { sc_arg = arg, sc_dup = dup, sc_cont = cont, sc_hole_ty = hole_ty })+    = (hang (text "ApplyToVal" <+> ppr dup <+> text "hole-ty:" <+> pprParendType hole_ty)+          2 (pprParendExpr arg))+      $$ ppr cont+  ppr (StrictBind { sc_bndr = b, sc_cont = cont })+    = (text "StrictBind" <+> ppr b) $$ ppr cont+  ppr (StrictArg { sc_fun = ai, sc_cont = cont })+    = (text "StrictArg" <+> ppr (ai_fun ai)) $$ ppr cont+  ppr (Select { sc_dup = dup, sc_bndr = bndr, sc_alts = alts, sc_cont = cont })+    = (text "Select" <+> ppr dup <+> ppr bndr) $$+      whenPprDebug (nest 2 $ ppr alts) $$ ppr cont+++{- Note [The hole type in ApplyToTy]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The sc_hole_ty field of ApplyToTy records the type of the "hole" in the+continuation.  It is absolutely necessary to compute contHoleType, but it is+not used for anything else (and hence may not be evaluated).++Why is it necessary for contHoleType?  Consider the continuation+     ApplyToType Int (Stop Int)+corresponding to+     (<hole> @Int) :: Int+What is the type of <hole>?  It could be (forall a. Int) or (forall a. a),+and there is no way to know which, so we must record it.++In a chain of applications  (f @t1 @t2 @t3) we'll lazily compute exprType+for (f @t1) and (f @t1 @t2), which is potentially non-linear; but it probably+doesn't matter because we'll never compute them all.++************************************************************************+*                                                                      *+                ArgInfo and ArgSpec+*                                                                      *+************************************************************************+-}++data ArgInfo+  = ArgInfo {+        ai_fun   :: OutId,      -- The function+        ai_args  :: [ArgSpec],  -- ...applied to these args (which are in *reverse* order)+                                -- NB: all these argumennts are already simplified++        ai_rules :: [CoreRule], -- Rules for this function+        ai_encl  :: Bool,       -- Flag saying whether this function+                                -- or an enclosing one has rules (recursively)+                                --      True => be keener to inline in all args++        ai_dmds :: [Demand],    -- Demands on remaining value arguments (beyond ai_args)+                                --   Usually infinite, but if it is finite it guarantees+                                --   that the function diverges after being given+                                --   that number of args++        ai_discs :: [Int]       -- Discounts for remaining value arguments (beyond ai_args)+                                --   non-zero => be keener to inline+                                --   Always infinite+    }++data ArgSpec+  = ValArg { as_dmd  :: Demand        -- Demand placed on this argument+           , as_arg  :: OutExpr       -- Apply to this (coercion or value); c.f. ApplyToVal+           , as_hole_ty :: OutType }  -- Type of the function (presumably t1 -> t2)++  | TyArg { as_arg_ty  :: OutType     -- Apply to this type; c.f. ApplyToTy+          , as_hole_ty :: OutType }   -- Type of the function (presumably forall a. blah)++instance Outputable ArgInfo where+  ppr (ArgInfo { ai_fun = fun, ai_args = args, ai_dmds = dmds, ai_rules = rules })+    = text "ArgInfo" <+> braces+         (sep [ text "fun =" <+> ppr fun+              , text "dmds(first 10) =" <+> ppr (take 10 dmds)+              , text "args =" <+> ppr args+              , text "rewrite =" <+> ppr rules ])++instance Outputable ArgSpec where+  ppr (ValArg { as_arg = arg })  = text "ValArg" <+> ppr arg+  ppr (TyArg { as_arg_ty = ty }) = text "TyArg" <+> ppr ty++addValArgTo :: ArgInfo ->  OutExpr -> OutType -> ArgInfo+addValArgTo ai arg hole_ty+  | ArgInfo { ai_dmds = dmd:dmds, ai_discs = _:discs } <- ai+      -- Pop the top demand and and discounts off+  , let arg_spec = ValArg { as_arg = arg, as_hole_ty = hole_ty, as_dmd = dmd }+  = ai { ai_args    = arg_spec : ai_args ai+       , ai_dmds    = dmds+       , ai_discs   = discs }+  | otherwise+  = pprPanic "addValArgTo" (ppr ai $$ ppr arg)+    -- There should always be enough demands and discounts++addTyArgTo :: ArgInfo -> OutType -> OutType -> ArgInfo+addTyArgTo ai arg_ty hole_ty = ai { ai_args    = arg_spec : ai_args ai }+  where+    arg_spec = TyArg { as_arg_ty = arg_ty, as_hole_ty = hole_ty }++isStrictArgInfo :: ArgInfo -> Bool+-- True if the function is strict in the next argument+isStrictArgInfo (ArgInfo { ai_dmds = dmds })+  | dmd:_ <- dmds = isStrUsedDmd dmd+  | otherwise     = False++pushSimplifiedArgs :: SimplEnv+                   -> [ArgSpec]   -- In normal, forward order+                   -> SimplCont -> SimplCont+pushSimplifiedArgs env args cont = foldr (pushSimplifiedArg env) cont args+-- pushSimplifiedRevArgs env args cont = foldl' (\k a -> pushSimplifiedArg env a k) cont args++pushSimplifiedArg :: SimplEnv -> ArgSpec -> SimplCont -> SimplCont+pushSimplifiedArg _env (TyArg { as_arg_ty = arg_ty, as_hole_ty = hole_ty }) cont+  = ApplyToTy  { sc_arg_ty = arg_ty, sc_hole_ty = hole_ty, sc_cont = cont }+pushSimplifiedArg env (ValArg { as_arg = arg, as_hole_ty = hole_ty }) cont+  = ApplyToVal { sc_arg = arg, sc_env = env, sc_dup = Simplified+                 -- The SubstEnv will be ignored since sc_dup=Simplified+               , sc_hole_ty = hole_ty, sc_cont = cont }++argSpecArg :: ArgSpec -> OutExpr+argSpecArg (ValArg { as_arg = arg })   = arg+argSpecArg (TyArg  { as_arg_ty = ty }) = Type ty++argInfoExpr :: OutId -> [ArgSpec] -> OutExpr+-- NB: the [ArgSpec] is reversed so that the first arg+-- in the list is the last one in the application+argInfoExpr fun rev_args+  = go rev_args+  where+    go []                              = Var fun+    go (ValArg { as_arg = arg }  : as) = go as `App` arg+    go (TyArg { as_arg_ty = ty } : as) = go as `App` Type ty++{-+************************************************************************+*                                                                      *+                Functions on SimplCont+*                                                                      *+************************************************************************+-}++mkBoringStop :: OutType -> SimplCont+mkBoringStop ty = Stop ty BoringCtxt topSubDmd++mkRhsStop :: OutType -> RecFlag -> Demand -> SimplCont+-- See Note [RHS of lets] in GHC.Core.Unfold+mkRhsStop ty is_rec bndr_dmd = Stop ty (RhsCtxt is_rec) (subDemandIfEvaluated bndr_dmd)++mkLazyArgStop :: OutType -> ArgInfo -> SimplCont+mkLazyArgStop ty fun_info = Stop ty (lazyArgContext fun_info) arg_sd+  where+    arg_sd = subDemandIfEvaluated (Partial.head (ai_dmds fun_info))++-------------------+contIsRhs :: SimplCont -> Maybe RecFlag+contIsRhs (Stop _ (RhsCtxt is_rec) _) = Just is_rec+contIsRhs (CastIt { sc_cont = k })    = contIsRhs k   -- For f = e |> co, treat e as Rhs context+contIsRhs _                           = Nothing++-------------------+contIsStop :: SimplCont -> Bool+contIsStop (Stop {}) = True+contIsStop _         = False++contIsDupable :: SimplCont -> Bool+contIsDupable (Stop {})                         = True+contIsDupable (ApplyToTy  { sc_cont = k })      = contIsDupable k+contIsDupable (ApplyToVal { sc_dup = OkToDup }) = True -- See Note [DupFlag invariants]+contIsDupable (Select { sc_dup = OkToDup })     = True -- ...ditto...+contIsDupable (StrictArg { sc_dup = OkToDup })  = True -- ...ditto...+contIsDupable (CastIt { sc_cont = k })          = contIsDupable k+contIsDupable _                                 = False++-------------------+contIsTrivial :: SimplCont -> Bool+contIsTrivial (Stop {})                                         = True+contIsTrivial (ApplyToTy { sc_cont = k })                       = contIsTrivial k+-- This one doesn't look right.  A value application is not trivial+-- contIsTrivial (ApplyToVal { sc_arg = Coercion _, sc_cont = k }) = contIsTrivial k+contIsTrivial (CastIt { sc_cont = k })                          = contIsTrivial k+contIsTrivial _                                                 = False++-------------------+contResultType :: SimplCont -> OutType+contResultType (Stop ty _ _)                = ty+contResultType (CastIt { sc_cont = k })     = contResultType k+contResultType (StrictBind { sc_cont = k }) = contResultType k+contResultType (StrictArg { sc_cont = k })  = contResultType k+contResultType (Select { sc_cont = k })     = contResultType k+contResultType (ApplyToTy  { sc_cont = k }) = contResultType k+contResultType (ApplyToVal { sc_cont = k }) = contResultType k+contResultType (TickIt _ k)                 = contResultType k++contHoleType :: SimplCont -> OutType+contHoleType (Stop ty _ _)                    = ty+contHoleType (TickIt _ k)                     = contHoleType k+contHoleType (CastIt { sc_co = co })          = coercionLKind co+contHoleType (StrictBind { sc_bndr = b, sc_dup = dup, sc_env = se })+  = perhapsSubstTy dup se (idType b)+contHoleType (StrictArg  { sc_fun_ty = ty })  = funArgTy ty+contHoleType (ApplyToTy  { sc_hole_ty = ty }) = ty  -- See Note [The hole type in ApplyToTy]+contHoleType (ApplyToVal { sc_hole_ty = ty }) = ty  -- See Note [The hole type in ApplyToTy]+contHoleType (Select { sc_dup = d, sc_bndr =  b, sc_env = se })+  = perhapsSubstTy d se (idType b)+++-- Computes the multiplicity scaling factor at the hole. That is, in (case [] of+-- x ::(p) _ { … }) (respectively for arguments of functions), the scaling+-- factor is p. And in E[G[]], the scaling factor is the product of the scaling+-- factor of E and that of G.+--+-- The scaling factor at the hole of E[] is used to determine how a binder+-- should be scaled if it commutes with E. This appears, in particular, in the+-- case-of-case transformation.+contHoleScaling :: SimplCont -> Mult+contHoleScaling (Stop _ _ _) = OneTy+contHoleScaling (CastIt { sc_cont = k })+  = contHoleScaling k+contHoleScaling (StrictBind { sc_bndr = id, sc_cont = k })+  = idMult id `mkMultMul` contHoleScaling k+contHoleScaling (Select { sc_bndr = id, sc_cont = k })+  = idMult id `mkMultMul` contHoleScaling k+contHoleScaling (StrictArg { sc_fun_ty = fun_ty, sc_cont = k })+  = w `mkMultMul` contHoleScaling k+  where+    (w, _, _) = splitFunTy fun_ty+contHoleScaling (ApplyToTy { sc_cont = k }) = contHoleScaling k+contHoleScaling (ApplyToVal { sc_cont = k }) = contHoleScaling k+contHoleScaling (TickIt _ k) = contHoleScaling k++-------------------+countArgs :: SimplCont -> Int+-- Count all arguments, including types, coercions,+-- and other values; skipping over casts.+countArgs (ApplyToTy  { sc_cont = cont }) = 1 + countArgs cont+countArgs (ApplyToVal { sc_cont = cont }) = 1 + countArgs cont+countArgs (CastIt     { sc_cont = cont }) = countArgs cont+countArgs _                               = 0++countValArgs :: SimplCont -> Int+-- Count value arguments only+countValArgs (ApplyToTy  { sc_cont = cont }) = countValArgs cont+countValArgs (ApplyToVal { sc_cont = cont }) = 1 + countValArgs cont+countValArgs (CastIt     { sc_cont = cont }) = countValArgs cont+countValArgs _                               = 0++-------------------+contArgs :: SimplCont -> (Bool, [ArgSummary], SimplCont)+-- Summarises value args, discards type args and coercions+-- The returned continuation of the call is only used to+-- answer questions like "are you interesting?"+contArgs cont+  | lone cont = (True, [], cont)+  | otherwise = go [] cont+  where+    lone (ApplyToTy  {}) = False  -- See Note [Lone variables] in GHC.Core.Unfold+    lone (ApplyToVal {}) = False  -- NB: even a type application or cast+    lone (CastIt {})     = False  --     stops it being "lone"+    lone _               = True++    go args (ApplyToVal { sc_arg = arg, sc_env = se, sc_cont = k })+                                        = go (is_interesting arg se : args) k+    go args (ApplyToTy { sc_cont = k }) = go args k+    go args (CastIt { sc_cont = k })    = go args k+    go args k                           = (False, reverse args, k)++    is_interesting arg se = interestingArg se arg+                   -- Do *not* use short-cutting substitution here+                   -- because we want to get as much IdInfo as possible++contOutArgs :: SimplEnv -> SimplCont -> [OutExpr]+-- Get the leading arguments from the `SimplCont`, as /OutExprs/+contOutArgs env cont+  = go cont+  where+    in_scope = seInScope env++    go (ApplyToTy { sc_arg_ty = ty, sc_cont = cont })+      = Type ty : go cont++    go (ApplyToVal { sc_dup = dup, sc_arg = arg, sc_env = env, sc_cont = cont })+      | isSimplified dup = arg : go cont+      | otherwise        = GHC.Core.Subst.substExpr (getFullSubst in_scope env) arg : go cont+        -- Make sure we apply the static environment `sc_env` as a substitution+        --   to get an OutExpr.  See (BF1) in Note [tryRules: plan (BEFORE)]+        --   in GHC.Core.Opt.Simplify.Iteration+        -- NB: we use substExpr, not substExprSC: we want to get the benefit of+        --     knowing what is evaluated etc, via the in-scope set++    -- No more arguments+    go _ = []++dropContArgs :: FullArgCount -> SimplCont -> SimplCont+dropContArgs 0 cont = cont+dropContArgs n (ApplyToTy  { sc_cont = cont }) = dropContArgs (n-1) cont+dropContArgs n (ApplyToVal { sc_cont = cont }) = dropContArgs (n-1) cont+dropContArgs n cont = pprPanic "dropContArgs" (ppr n $$ ppr cont)++-- | Describes how the 'SimplCont' will evaluate the hole as a 'SubDemand'.+-- This can be more insightful than the limited syntactic context that+-- 'SimplCont' provides, because the 'Stop' constructor might carry a useful+-- 'SubDemand'.+-- For example, when simplifying the argument `e` in `f e` and `f` has the+-- demand signature `<MP(S,A)>`, this function will give you back `P(S,A)` when+-- simplifying `e`.+--+-- PRECONDITION: Don't call with 'ApplyToVal'. We haven't thoroughly thought+-- about what to do then and no call sites so far seem to care.+contEvalContext :: SimplCont -> SubDemand+contEvalContext k = case k of+  Stop _ _ sd              -> sd+  TickIt _ k               -> contEvalContext k+  CastIt   { sc_cont = k } -> contEvalContext k+  ApplyToTy{ sc_cont = k } -> contEvalContext k+    --  ApplyToVal{sc_cont=k}      -> mkCalledOnceDmd $ contEvalContext k+    -- Not 100% sure that's correct, . Here's an example:+    --   f (e x) and f :: <SC(S,C(1,L))>+    -- then what is the evaluation context of 'e' when we simplify it? E.g.,+    --   simpl e (ApplyToVal x $ Stop "C(S,C(1,L))")+    -- then it *should* be "C(1,C(S,C(1,L))", so perhaps correct after all.+    -- But for now we just panic:+  ApplyToVal{}               -> pprPanic "contEvalContext" (ppr k)+  StrictArg{sc_fun=fun_info} -> subDemandIfEvaluated (Partial.head (ai_dmds fun_info))+  StrictBind{sc_bndr=bndr}   -> subDemandIfEvaluated (idDemandInfo bndr)+  Select{}                   -> topSubDmd+    -- Perhaps reconstruct the demand on the scrutinee by looking at field+    -- and case binder dmds, see addCaseBndrDmd. No priority right now.++-------------------+mkArgInfo :: SimplEnv -> Id -> [CoreRule] -> SimplCont -> ArgInfo+mkArgInfo env fun rules_for_fun cont+  | n_val_args < idArity fun            -- Note [Unsaturated functions]+  = ArgInfo { ai_fun = fun, ai_args = []+            , ai_rules = rules_for_fun+            , ai_encl = False+            , ai_dmds = vanilla_dmds+            , ai_discs = vanilla_discounts }+  | otherwise+  = ArgInfo { ai_fun   = fun+            , ai_args  = []+            , ai_rules = rules_for_fun+            , ai_encl  = fun_has_rules || contHasRules cont+            , ai_dmds  = add_type_strictness (idType fun) arg_dmds+            , ai_discs = arg_discounts }+  where+    n_val_args  = countValArgs cont++    fun_has_rules = not (null rules_for_fun)++    vanilla_discounts, arg_discounts :: [Int]+    vanilla_discounts = repeat 0+    arg_discounts = case idUnfolding fun of+                        CoreUnfolding {uf_guidance = UnfIfGoodArgs {ug_args = discounts}}+                              -> discounts ++ vanilla_discounts+                        _     -> vanilla_discounts++    vanilla_dmds, arg_dmds :: [Demand]+    vanilla_dmds  = repeat topDmd++    arg_dmds+      | not (seInline env)+      = vanilla_dmds -- See Note [Do not expose strictness if sm_inline=False]+      | otherwise+      = -- add_type_str fun_ty $+        case splitDmdSig (idDmdSig fun) of+          (demands, result_info)+                | not (demands `lengthExceeds` n_val_args)+                ->      -- Enough args, use the strictness given.+                        -- For bottoming functions we used to pretend that the arg+                        -- is lazy, so that we don't treat the arg as an+                        -- interesting context.  This avoids substituting+                        -- top-level bindings for (say) strings into+                        -- calls to error.  But now we are more careful about+                        -- inlining lone variables, so its ok+                        -- (see GHC.Core.Op.Simplify.Utils.analyseCont)+                   if isDeadEndDiv result_info then+                        demands  -- Finite => result is bottom+                   else+                        demands ++ vanilla_dmds+               | otherwise+               -> warnPprTrace True "More demands than arity" (ppr fun <+> ppr (idArity fun)+                                <+> ppr n_val_args <+> ppr demands) $+                  vanilla_dmds      -- Not enough args, or no strictness++    add_type_strictness :: Type -> [Demand] -> [Demand]+    -- If the function arg types are strict, record that in the 'strictness bits'+    -- No need to instantiate because unboxed types (which dominate the strict+    --   types) can't instantiate type variables.+    -- add_type_strictness is done repeatedly (for each call);+    --   might be better once-for-all in the function+    -- But beware primops/datacons with no strictness++    add_type_strictness fun_ty dmds+      | null dmds = []++      | Just (_, fun_ty') <- splitForAllTyCoVar_maybe fun_ty+      = add_type_strictness fun_ty' dmds     -- Look through foralls++      | Just (_, _, arg_ty, fun_ty') <- splitFunTy_maybe fun_ty        -- Add strict-type info+      , dmd : rest_dmds <- dmds+      , let dmd'+             | definitelyUnliftedType arg_ty+             = strictifyDmd dmd+             | otherwise+             -- Something that's not definitely unlifted.+             -- If the type is representation-polymorphic, we can't know whether+             -- it's strict.+             = dmd+      = dmd' : add_type_strictness fun_ty' rest_dmds++      | otherwise+      = dmds++{- Note [Unsaturated functions]+  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider (test eyeball/inline4)+        x = a:as+        y = f x+where f has arity 2.  Then we do not want to inline 'x', because+it'll just be floated out again.  Even if f has lots of discounts+on its first argument -- it must be saturated for these to kick in++Note [Do not expose strictness if sm_inline=False]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+#15163 showed a case in which we had++  {-# INLINE [1] zip #-}+  zip = undefined++  {-# RULES "foo" forall as bs. stream (zip as bs) = ..blah... #-}++If we expose zip's bottoming nature when simplifying the LHS of the+RULE we get+  {-# RULES "foo" forall as bs.+                   stream (case zip of {}) = ..blah... #-}+discarding the arguments to zip.  Usually this is fine, but on the+LHS of a rule it's not, because 'as' and 'bs' are now not bound on+the LHS.++This is a pretty pathological example, so I'm not losing sleep over+it, but the simplest solution was to check sm_inline; if it is False,+which it is on the LHS of a rule (see updModeForRules), then don't+make use of the strictness info for the function.+-}+++{-+************************************************************************+*                                                                      *+        Interesting arguments+*                                                                      *+************************************************************************++Note [Interesting call context]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We want to avoid inlining an expression where there can't possibly be+any gain, such as in an argument position.  Hence, if the continuation+is interesting (eg. a case scrutinee that isn't just a seq, application etc.)+then we inline, otherwise we don't.++Previously some_benefit used to return True only if the variable was+applied to some value arguments.  This didn't work:++        let x = _coerce_ (T Int) Int (I# 3) in+        case _coerce_ Int (T Int) x of+                I# y -> ....++we want to inline x, but can't see that it's a constructor in a case+scrutinee position, and some_benefit is False.++Another example:++dMonadST = _/\_ t -> :Monad (g1 _@_ t, g2 _@_ t, g3 _@_ t)++....  case dMonadST _@_ x0 of (a,b,c) -> ....++we'd really like to inline dMonadST here, but we *don't* want to+inline if the case expression is just++        case x of y { DEFAULT -> ... }++since we can just eliminate this case instead (x is in WHNF).  Similar+applies when x is bound to a lambda expression.  Hence+contIsInteresting looks for case expressions with just a single+default case.++Note [No case of case is boring]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we see+   case f x of <alts>++we'd usually treat the context as interesting, to encourage 'f' to+inline.  But if case-of-case is off, it's really not so interesting+after all, because we are unlikely to be able to push the case+expression into the branches of any case in f's unfolding.  So, to+reduce unnecessary code expansion, we just make the context look boring.+This made a small compile-time perf improvement in perf/compiler/T6048,+and it looks plausible to me.++Note [Seq is boring]+~~~~~~~~~~~~~~~~~~~~+Suppose+  f x = case v of+          True  -> Just x+          False -> Just (x-1)++Now consider these variants of+   case (f x) of ...++1. [Dead case binder]: inline f+      case f x of b{-dead-} { DEFAULT -> blah[no b] }+   Inlining (f x) will allow us to avoid ever allocating (Just x),+   since the case binder `b` is dead.  We will end up with a+     join point for blah, thus+         join j = blah in+         case v of { True -> j; False -> j }+   which will turn into (case v of DEFAULT -> blah)+   All good++2. [Live case binder, live alt binders]: inline f+       case f x of b { Just y -> blah[y,b] }+   Inlining (f x) will mean we still allocate (Just x),+   but we also get to bind `y` without fetching it out of the Just, thus+         join j y b = blah[y,b]+         case v of { True -> j x (Just x)+                   ; False -> let y = x-1 in j y (Just y) }+   Inlining (f x) has a small benefit, perhaps.+   (To T14955 it makes a surprisingly large difference of ~30% to inline here.)++3. [Live case binder, dead alt binders]: maybe don't inline f+      case f x of b { DEFAULT -> blah[b] }+   Inlining (f x) will still mean we allocate (Just x). We'd get:+         join j b = blah[b]+         case v of { True -> j (Just x); False -> j (Just (x-1)) }+   No new optimisations are revealed. Nothing is gained.+   (This is the situation in T22317.)++   A variant is when we have a data constructor with dead binders:+       case g x of b { (x{-dead-}, x{-dead-}) -> blah[b, no x, no y] }+   Instead of DEFAULT we have a single constructor alternative+   with all dead binders.  Again, no gain from inlining (f x)++4. [Live case binder, dead alt binders]: small f+   Suppose f is CPR'd, so it looks like+       f x = case $wf x of (# a #) -> Just a+   Then even in case (3) we want to inline:+      case f x of b { DEFAULT -> blah[b] }+   -->+      case $wf x of (# a #) ->+      let b = Just a in blah[b]+   This is very good; we now know a lot about `b` (instead of nothing)+   and `blah` might benefit.  Similarly if `f` has a join point+      f x = join $j y = Just y in ...+   Again the case (f x) is now consuming a constructor (Just y).++   This is very like the situation described in Note [RHS of lets]+   in GHC.Core.Opt.Simplify.Inline; (case e of b -> blah) is just+   like a strict `let`.++Conclusion: in interestingCallCtxt, a case-expression (i.e. Select continuation)+usually gives a CaseCtxt (cases 1,2); but when (cases 3,4):+  * It has a non-dead case-binder+  * It has one alternative+  * All the binders in the alternative are dead+then the `case` is just a strict let-binding, so use RhsCtxt NonRecursive.+This RhsCtxt gives a small incentive for small functions to inline.+That incentive is what is needed in case (4).++Wrinkle (SB1).  The 'small incentive' is implemented by `calc_some_benefit` in+GHC.Core.Opt.Simplify.Inline.tryUnfolding.  We restrict the incentive just to+funtions that have unfolding guidance of `UnfWhen`, which particularly includes+wrappers created by CPR, exactly case (4) above.  Without this limitation I+got too much fruitless inlining, which led to regressions (#22317 is an example).++A good example of a function where this 'small incentive' is important is+GHC.Internal.Bignum.Integer where we ended up with calls like this:+     case (integerSignum a b) of r -> ...+but were failing to inline integerSignum, even though it always returns+a single constructor, so it is very helpful to inline it. There is also an+issue of confluence-of-the-simplifier.  Suppose we have+    f x = case x of r -> ...+and the Simplifier sees+    f (integerSigNum a b)+Because `f` scrutines `x`, the unfolding guidance for f gives a discount+for `x`; and that discount makes interestingCallContext for the context+`f <>` return DiscArgCtxt, which again gives that incentive.  We don't want+the incentive to disappear when we inline `f`!+-}++lazyArgContext :: ArgInfo -> CallCtxt+-- Use this for lazy arguments+lazyArgContext (ArgInfo { ai_encl = encl_rules, ai_discs = discs })+  | encl_rules                = RuleArgCtxt+  | disc:_ <- discs, disc > 0 = DiscArgCtxt  -- Be keener here+  | otherwise                 = BoringCtxt   -- Nothing interesting++strictArgContext :: ArgInfo -> CallCtxt+strictArgContext (ArgInfo { ai_encl = encl_rules, ai_discs = discs })+-- Use this for strict arguments+  | encl_rules                = RuleArgCtxt+  | disc:_ <- discs, disc > 0 = DiscArgCtxt  -- Be keener here+  | otherwise                 = RhsCtxt NonRecursive+      -- Why RhsCtxt?  if we see f (g x), and f is strict, we+      -- want to be a bit more eager to inline g, because it may+      -- expose an eval (on x perhaps) that can be eliminated or+      -- shared. I saw this in nofib 'boyer2', RewriteFuns.onewayunify1+      -- It's worth an 18% improvement in allocation for this+      -- particular benchmark; 5% on 'mate' and 1.3% on 'multiplier'+      --+      -- Why NonRecursive?  Becuase it's a bit like+      --   let a = g x in f a++interestingCallContext :: SimplEnv -> SimplCont -> CallCtxt+-- See Note [Interesting call context]+interestingCallContext env cont+  = interesting cont+  where+    interesting (Select {sc_alts=alts, sc_bndr=case_bndr})+      | not (seCaseCase env)         = BoringCtxt -- See Note [No case of case is boring]+      | [Alt _ bs _] <- alts+      , all isDeadBinder bs+      , not (isDeadBinder case_bndr) = RhsCtxt NonRecursive -- See Note [Seq is boring]+      | otherwise                    = CaseCtxt+++    interesting (ApplyToVal {}) = ValAppCtxt+        -- Can happen if we have (f Int |> co) y+        -- If f has an INLINE prag we need to give it some+        -- motivation to inline. See Note [Cast then apply]+        -- in GHC.Core.Unfold++    interesting (StrictArg { sc_fun = fun }) = strictArgContext fun+    interesting (StrictBind {})              = BoringCtxt+    interesting (Stop _ cci _)               = cci+    interesting (TickIt _ k)                 = interesting k+    interesting (ApplyToTy { sc_cont = k })  = interesting k+    interesting (CastIt { sc_cont = k })     = interesting k+        -- If this call is the arg of a strict function, the context+        -- is a bit interesting.  If we inline here, we may get useful+        -- evaluation information to avoid repeated evals: e.g.+        --      x + (y * z)+        -- Here the contIsInteresting makes the '*' keener to inline,+        -- which in turn exposes a constructor which makes the '+' inline.+        -- Assuming that +,* aren't small enough to inline regardless.+        --+        -- It's also very important to inline in a strict context for things+        -- like+        --              foldr k z (f x)+        -- Here, the context of (f x) is strict, and if f's unfolding is+        -- a build it's *great* to inline it here.  So we must ensure that+        -- the context for (f x) is not totally uninteresting.++contHasRules :: SimplCont -> Bool+-- If the argument has form (f x y), where x,y are boring,+-- and f is marked INLINE, then we don't want to inline f.+-- But if the context of the argument is+--      g (f x y)+-- where g has rules, then we *do* want to inline f, in case it+-- exposes a rule that might fire.  Similarly, if the context is+--      h (g (f x x))+-- where h has rules, then we do want to inline f.  So contHasRules+-- tries to see if the context of the f-call is a call to a function+-- with rules.+--+-- The ai_encl flag makes this happen; if it's+-- set, the inliner gets just enough keener to inline f+-- regardless of how boring f's arguments are, if it's marked INLINE+--+-- The alternative would be to *always* inline an INLINE function,+-- regardless of how boring its context is; but that seems overkill+-- For example, it'd mean that wrapper functions were always inlined+contHasRules cont+  = go cont+  where+    go (ApplyToVal { sc_cont = cont }) = go cont+    go (ApplyToTy  { sc_cont = cont }) = go cont+    go (CastIt { sc_cont = cont })     = go cont+    go (StrictArg { sc_fun = fun })    = ai_encl fun+    go (Stop _ RuleArgCtxt _)          = True+    go (TickIt _ c)                    = go c+    go (Select {})                     = False+    go (StrictBind {})                 = False      -- ??+    go (Stop _ _ _)                    = False++{- Note [Interesting arguments]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+An argument is interesting if it deserves a discount for unfoldings+with a discount in that argument position.  The idea is to avoid+unfolding a function that is applied only to variables that have no+unfolding (i.e. they are probably lambda bound): f x y z There is+little point in inlining f here.++Generally, *values* (like (C a b) and (\x.e)) deserve discounts.  But+we must look through lets, eg (let x = e in C a b), because the let will+float, exposing the value, if we inline.  That makes it different to+exprIsHNF.++Before 2009 we said it was interesting if the argument had *any* structure+at all; i.e. (hasSomeUnfolding v).  But does too much inlining; see #3016.++But we don't regard (f x y) as interesting, unless f is unsaturated.+If it's saturated and f hasn't inlined, then it's probably not going+to now!++Note [Conlike is interesting]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+        f d = ...((*) d x y)...+        ... f (df d')...+where df is con-like. Then we'd really like to inline 'f' so that the+rule for (*) (df d) can fire.  To do this+  a) we give a discount for being an argument of a class-op (eg (*) d)+  b) we say that a con-like argument (eg (df d)) is interesting+-}++interestingArg :: SimplEnv -> CoreExpr -> ArgSummary+-- See Note [Interesting arguments]+interestingArg env e = go env 0 e+  where+    -- n is # value args to which the expression is applied+    go env n (Var v)+       = case substId env v of+           DoneId v'            -> go_var n v'+           DoneEx e _           -> go (zapSubstEnv env)             n e+           ContEx tvs cvs ids e -> go (setSubstEnv env tvs cvs ids) n e++    go _   _ (Lit l)+       | isLitRubbish l        = TrivArg -- Leads to unproductive inlining in WWRec, #20035+       | otherwise             = ValueArg+    go _   _ (Type _)          = TrivArg+    go _   _ (Coercion _)      = TrivArg+    go env n (App fn (Type _)) = go env n fn+    go env n (App fn _)        = go env (n+1) fn+    go env n (Tick _ a)        = go env n a+    go env n (Cast e _)        = go env n e+    go env n (Lam v e)+       | isTyVar v             = go env n e+       | n>0                   = NonTrivArg     -- (\x.b) e   is NonTriv+       | otherwise             = ValueArg+    go _ _ (Case {})           = NonTrivArg+    go env n (Let b e)         = case go env' n e of+                                   ValueArg -> ValueArg+                                   _        -> NonTrivArg+                               where+                                 env' = env `addNewInScopeIds` bindersOf b++    go_var n v+       | isConLikeId v = ValueArg   -- Experimenting with 'conlike' rather that+                                    --    data constructors here+                                    -- DFuns are con-like; see Note [Conlike is interesting]+       | idArity v > n = ValueArg   -- Catches (eg) primops with arity but no unfolding+       | n > 0         = NonTrivArg -- Saturated or unknown call+       | otherwise  -- n==0, no value arguments; look for an interesting unfolding+       = case idUnfolding v of+           OtherCon [] -> NonTrivArg   -- It's evaluated, but that's all we know+           OtherCon _  -> ValueArg     -- Evaluated and we know it isn't these constructors+              -- See Note [OtherCon and interestingArg]+           DFunUnfolding {} -> ValueArg   -- We konw that idArity=0+           CoreUnfolding{ uf_cache = cache }+             | uf_is_conlike cache -> ValueArg    -- Includes constructor applications+             | uf_is_value cache   -> NonTrivArg  -- Things like partial applications+             | otherwise           -> TrivArg+           BootUnfolding           -> TrivArg+           NoUnfolding             -> TrivArg++{- Note [OtherCon and interestingArg]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+interstingArg returns+   (a) NonTrivArg for an arg with an OtherCon [] unfolding+   (b) ValueArg for an arg with an OtherCon [c1,c2..] unfolding.++Reason for (a): I found (in the GHC.Internal.Bignum.Integer module) that I was+inlining a pretty big function when all we knew was that its arguments+were evaluated, nothing more.  That in turn make the enclosing function+too big to inline elsewhere.++Reason for (b): we want to inline integerCompare here+  integerLt# :: Integer -> Integer -> Bool#+  integerLt# (IS x) (IS y)                  = x <# y+  integerLt# x y | LT <- integerCompare x y = 1#+  integerLt# _ _                            = 0#++************************************************************************+*                                                                      *+                  SimplMode+*                                                                      *+************************************************************************+-}++updModeForStableUnfoldings :: Activation -> SimplMode -> SimplMode+-- See Note [The environments of the Simplify pass]+updModeForStableUnfoldings unf_act current_mode+  = current_mode { sm_phase      = phaseFromActivation unf_act+                 , sm_eta_expand = False+                 , sm_inline     = True }+       -- sm_eta_expand: see Note [Eta expansion in stable unfoldings and rules]+       -- sm_rules: just inherit; sm_rules might be "off"+       --           because of -fno-enable-rewrite-rules+  where+    phaseFromActivation (ActiveAfter _ n) = Phase n+    phaseFromActivation _                 = InitialPhase++updModeForRules :: SimplMode -> SimplMode+-- See Note [Simplifying rules]+-- See Note [The environments of the Simplify pass]+updModeForRules current_mode+  = current_mode { sm_phase        = InitialPhase+                 , sm_inline       = False+                      -- See Note [Do not expose strictness if sm_inline=False]+                 , sm_rules        = False+                 , sm_cast_swizzle = False+                      -- See Note [Cast swizzling on rule LHSs]+                 , sm_eta_expand   = False }++{- Note [Simplifying rules]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When simplifying a rule LHS, refrain from /any/ inlining or applying+of other RULES. Doing anything to the LHS is plain confusing, because+it means that what the rule matches is not what the user+wrote. c.f. #10595, and #10528.++* sm_inline, sm_rules: inlining (or applying rules) on rule LHSs risks+  introducing Ticks into the LHS, which makes matching+  trickier. #10665, #10745.++  Doing this to either side confounds tools like HERMIT, which seek to reason+  about and apply the RULES as originally written. See #10829.++  See also Note [Do not expose strictness if sm_inline=False]++* sm_eta_expand: the template (LHS) of a rule must only mention coercion+  /variables/ not arbitrary coercions.  See Note [Casts in the template] in+  GHC.Core.Rules.  Eta expansion can create new coercions; so we switch+  it off.++There is, however, one case where we are pretty much /forced/ to transform the+LHS of a rule: postInlineUnconditionally. For instance, in the case of++    let f = g @Int in f++We very much want to inline f into the body of the let. However, to do so (and+be able to safely drop f's binding) we must inline into all occurrences of f,+including those in the LHS of rules.++This can cause somewhat surprising results; for instance, in #18162 we found+that a rule template contained ticks in its arguments, because+postInlineUnconditionally substituted in a trivial expression that contains+ticks. See Note [Tick annotations in RULE matching] in GHC.Core.Rules for+details.++Note [Cast swizzling on rule LHSs]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In the LHS of a RULE we may have+       (\x. blah |> CoVar cv)+where `cv` is a coercion variable.  Critically, we really only want+coercion /variables/, not general coercions, on the LHS of a RULE.  So+we don't want to swizzle this to+      (\x. blah) |> (Refl xty `FunCo` CoVar cv)+So we switch off cast swizzling in updModeForRules.++Note [Eta expansion in stable unfoldings and rules]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+SPJ Jul 22: whether or not eta-expansion is switched on in a stable+unfolding, or the RHS of a RULE, seems to be a bit moot. But switching+it on adds clutter, so I'm experimenting with switching off+eta-expansion in such places.++In the olden days, we really /wanted/ to switch it off.++    Old note: If we have a stable unfolding+      f :: Ord a => a -> IO ()+      -- Unfolding template+      --    = /\a \(d:Ord a) (x:a). bla+    we do not want to eta-expand to+      f :: Ord a => a -> IO ()+      -- Unfolding template+      --    = (/\a \(d:Ord a) (x:a) (eta:State#). bla eta) |> co+    because now specialisation of the overloading doesn't work properly+    (see Note [Specialisation shape] in GHC.Core.Opt.Specialise), #9509.+    So we disable eta-expansion in stable unfoldings.++But this old note is no longer relevant because the specialiser has+improved: see Note [Account for casts in binding] in+GHC.Core.Opt.Specialise.  So we seem to have a free choice.++Note [Inlining in gentle mode]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Something is inlined if+   (i)   the sm_inline flag is on, AND+   (ii)  the thing has an INLINE pragma, AND+   (iii) the thing is inlinable in the earliest phase.++Example of why (iii) is important:+  {-# INLINE [~1] g #-}+  g = ...++  {-# INLINE f #-}+  f x = g (g x)++If we were to inline g into f's inlining, then an importing module would+never be able to do+        f e --> g (g e) ---> RULE fires+because the stable unfolding for f has had g inlined into it.++On the other hand, it is bad not to do ANY inlining into an+stable unfolding, because then recursive knots in instance declarations+don't get unravelled.++However, *sometimes* SimplGently must do no call-site inlining at all+(hence sm_inline = False).  Before full laziness we must be careful+not to inline wrappers, because doing so inhibits floating+    e.g. ...(case f x of ...)...+    ==> ...(case (case x of I# x# -> fw x#) of ...)...+    ==> ...(case x of I# x# -> case fw x# of ...)...+and now the redex (f x) isn't floatable any more.++The no-inlining thing is also important for Template Haskell.  You might be+compiling in one-shot mode with -O2; but when TH compiles a splice before+running it, we don't want to use -O2.  Indeed, we don't want to inline+anything, because the byte-code interpreter might get confused about+unboxed tuples and suchlike.++Note [Simplifying inside stable unfoldings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We must take care with simplification inside stable unfoldings (which come from+INLINE pragmas).++First, consider the following example+        let f = \pq -> BIG+        in+        let g = \y -> f y y+            {-# INLINE g #-}+        in ...g...g...g...g...g...+Now, if that's the ONLY occurrence of f, it might be inlined inside g,+and thence copied multiple times when g is inlined. HENCE we treat+any occurrence in a stable unfolding as a multiple occurrence, not a single+one; see OccurAnal.addRuleUsage.++Second, we do want *do* to some modest rules/inlining stuff in stable+unfoldings, partly to eliminate senseless crap, and partly to break+the recursive knots generated by instance declarations.++However, suppose we have+        {-# INLINE <act> f #-}+        f = <rhs>+meaning "inline f in phases p where activation <act>(p) holds".+Then what inlinings/rules can we apply to the copy of <rhs> captured in+f's stable unfolding?  Our model is that literally <rhs> is substituted for+f when it is inlined.  So our conservative plan (implemented by+updModeForStableUnfoldings) is this:++  -------------------------------------------------------------+  When simplifying the RHS of a stable unfolding, set the phase+  to the phase in which the stable unfolding first becomes active+  -------------------------------------------------------------++That ensures that++  a) Rules/inlinings that *cease* being active before p will+     not apply to the stable unfolding, consistent with it being+     inlined in its *original* form in phase p.++  b) Rules/inlinings that only become active *after* p will+     not apply to the stable unfolding, again to be consistent with+     inlining the *original* rhs in phase p.++For example,+        {-# INLINE f #-}+        f x = ...g...++        {-# NOINLINE [1] g #-}+        g y = ...++        {-# RULE h g = ... #-}+Here we must not inline g into f's RHS, even when we get to phase 0,+because when f is later inlined into some other module we want the+rule for h to fire.++Similarly, consider+        {-# INLINE f #-}+        f x = ...g...++        g y = ...+and suppose that there are auto-generated specialisations and a strictness+wrapper for g.  The specialisations get activation AlwaysActive, and the+strictness wrapper get activation (ActiveAfter 0).  So the strictness+wrepper fails the test and won't be inlined into f's stable unfolding. That+means f can inline, expose the specialised call to g, so the specialisation+rules can fire.++A note about wrappers+~~~~~~~~~~~~~~~~~~~~~+It's also important not to inline a worker back into a wrapper.+A wrapper looks like+        wraper = inline_me (\x -> ...worker... )+Normally, the inline_me prevents the worker getting inlined into+the wrapper (initially, the worker's only call site!).  But,+if the wrapper is sure to be called, the strictness analyser will+mark it 'demanded', so when the RHS is simplified, it'll get an ArgOf+continuation.+-}++getUnfoldingInRuleMatch :: SimplEnv -> InScopeEnv+-- When matching in RULE, we want to "look through" an unfolding+-- (to see a constructor) if *rules* are on, even if *inlinings*+-- are not.  A notable example is DFuns, which really we want to+-- match in rules like (op dfun) in gentle mode. Another example+-- is 'otherwise' which we want exprIsConApp_maybe to be able to+-- see very early on+getUnfoldingInRuleMatch env+  = ISE in_scope id_unf+  where+    in_scope = seInScope env+    phase    = sePhase env+    id_unf   = whenActiveUnfoldingFun (isActive phase)+     -- When sm_rules was off we used to test for a /stable/ unfolding,+     -- but that seems wrong (#20941)++----------------------+activeRule :: SimplMode -> Activation -> Bool+-- Nothing => No rules at all+activeRule mode+  | not (sm_rules mode) = \_ -> False     -- Rewriting is off+  | otherwise           = isActive (sm_phase mode)++{-+************************************************************************+*                                                                      *+                  preInlineUnconditionally+*                                                                      *+************************************************************************++preInlineUnconditionally+~~~~~~~~~~~~~~~~~~~~~~~~+@preInlineUnconditionally@ examines a bndr to see if it is used just+once in a completely safe way, so that it is safe to discard the+binding inline its RHS at the (unique) usage site, REGARDLESS of how+big the RHS might be.  If this is the case we don't simplify the RHS+first, but just inline it un-simplified.++This is much better than first simplifying a perhaps-huge RHS and then+inlining and re-simplifying it.  Indeed, it can be at least quadratically+better.  Consider++        x1 = e1+        x2 = e2[x1]+        x3 = e3[x2]+        ...etc...+        xN = eN[xN-1]++We may end up simplifying e1 N times, e2 N-1 times, e3 N-3 times etc.+This can happen with cascades of functions too:++        f1 = \x1.e1+        f2 = \xs.e2[f1]+        f3 = \xs.e3[f3]+        ...etc...++THE MAIN INVARIANT is this:++        ----  preInlineUnconditionally invariant -----+   IF preInlineUnconditionally chooses to inline x = <rhs>+   THEN doing the inlining should not change the occurrence+        info for the free vars of <rhs>+        ----------------------------------------------++For example, it's tempting to look at trivial binding like+        x = y+and inline it unconditionally.  But suppose x is used many times,+but this is the unique occurrence of y.  Then inlining x would change+y's occurrence info, which breaks the invariant.  It matters: y+might have a BIG rhs, which will now be dup'd at every occurrence of x.+++Even RHSs labelled InlineMe aren't caught here, because there might be+no benefit from inlining at the call site.++[Sept 01] Don't unconditionally inline a top-level thing, because that+can simply make a static thing into something built dynamically.  E.g.+        x = (a,b)+        main = \s -> h x++[Remember that we treat \s as a one-shot lambda.]  No point in+inlining x unless there is something interesting about the call site.++But watch out: if you aren't careful, some useful foldr/build fusion+can be lost (most notably in spectral/hartel/parstof) because the+foldr didn't see the build.  Doing the dynamic allocation isn't a big+deal, in fact, but losing the fusion can be.  But the right thing here+seems to be to do a callSiteInline based on the fact that there is+something interesting about the call site (it's strict).  Hmm.  That+seems a bit fragile.++Conclusion: inline top level things gaily until FinalPhase (the last+phase), at which point don't.++Note [pre/postInlineUnconditionally in gentle mode]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Even in gentle mode we want to do preInlineUnconditionally.  The+reason is that too little clean-up happens if you don't inline+use-once things.  Also a bit of inlining is *good* for full laziness;+it can expose constant sub-expressions.  Example in+spectral/mandel/Mandel.hs, where the mandelset function gets a useful+let-float if you inline windowToViewport++However, as usual for Gentle mode, do not inline things that are+inactive in the initial stages.  See Note [Gentle mode].++Note [Stable unfoldings and preInlineUnconditionally]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Surprisingly, do not pre-inline-unconditionally Ids with INLINE pragmas!+Example++   {-# INLINE f #-}+   f :: Eq a => a -> a+   f x = ...++   fInt :: Int -> Int+   fInt = f Int dEqInt++   ...fInt...fInt...fInt...++Here f occurs just once, in the RHS of fInt. But if we inline it there+it might make fInt look big, and we'll lose the opportunity to inline f+at each of fInt's call sites.  The INLINE pragma will only inline when+the application is saturated for exactly this reason; and we don't+want PreInlineUnconditionally to second-guess it. A live example is #3736.+    c.f. Note [Stable unfoldings and postInlineUnconditionally]++NB: this only applies for INLINE things. Do /not/ switch off+preInlineUnconditionally for++* INLINABLE. It just says to GHC "inline this if you like".  If there+  is a unique occurrence, we want to inline the stable unfolding, not+  the RHS.++* NONLINE[n] just switches off inlining until phase n.  We should+  respect that, but after phase n, just behave as usual.++* NoUserInlinePrag.  There is no pragma at all. This ends up on wrappers.+  (See #18815.)++Note [Top-level bottoming Ids]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Don't inline top-level Ids that are bottoming, even if they are used just+once, because FloatOut has gone to some trouble to extract them out.+Inlining them won't make the program run faster!++Note [Do not inline CoVars unconditionally]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Coercion variables appear inside coercions, and the RHS of a let-binding+is a term (not a coercion) so we can't necessarily inline the latter in+the former.+-}++preInlineUnconditionally+    :: SimplEnv -> TopLevelFlag -> InId+    -> InExpr -> StaticEnv  -- These two go together+    -> Maybe SimplEnv       -- Returned env has extended substitution+-- Precondition: rhs satisfies the let-can-float invariant+-- See Note [Core let-can-float invariant] in GHC.Core+-- Reason: we don't want to inline single uses, or discard dead bindings,+--         for unlifted, side-effect-ful bindings+preInlineUnconditionally env top_lvl bndr rhs rhs_env+  | not pre_inline_unconditionally           = Nothing+  | not active                               = Nothing+  | isTopLevel top_lvl && isDeadEndId bndr   = Nothing -- Note [Top-level bottoming Ids]+  | isCoVar bndr                             = Nothing -- Note [Do not inline CoVars unconditionally]+  | isExitJoinId bndr                        = Nothing -- Note [Do not inline exit join points]+                                                       -- in module Exitify+  | not (one_occ (idOccInfo bndr))           = Nothing+  | not (isStableUnfolding unf)              = Just $! (extend_subst_with rhs)++  -- See Note [Stable unfoldings and preInlineUnconditionally]+  | not (isInlinePragma inline_prag)+  , Just inl <- maybeUnfoldingTemplate unf   = Just $! (extend_subst_with inl)+  | otherwise                                = Nothing+  where+    unf = idUnfolding bndr+    extend_subst_with inl_rhs = extendIdSubst env bndr $! (mkContEx rhs_env inl_rhs)++    one_occ IAmDead = True -- Happens in ((\x.1) v)+    one_occ OneOcc{ occ_n_br   = 1+                  , occ_in_lam = NotInsideLam }   = isNotTopLevel top_lvl || early_phase+    one_occ OneOcc{ occ_n_br   = 1+                  , occ_in_lam = IsInsideLam+                  , occ_int_cxt = IsInteresting } = canInlineInLam rhs+    one_occ _                                     = False++    pre_inline_unconditionally = sePreInline env+    active = isActive (sePhase env) (inlinePragmaActivation inline_prag)+             -- See Note [pre/postInlineUnconditionally in gentle mode]+    inline_prag = idInlinePragma bndr++-- Be very careful before inlining inside a lambda, because (a) we must not+-- invalidate occurrence information, and (b) we want to avoid pushing a+-- single allocation (here) into multiple allocations (inside lambda).+-- Inlining a *function* with a single *saturated* call would be ok, mind you.+--      || (if is_cheap && not (canInlineInLam rhs) then pprTrace "preinline" (ppr bndr <+> ppr rhs) ok else ok)+--      where+--              is_cheap = exprIsCheap rhs+--              ok = is_cheap && int_cxt++        --      int_cxt         The context isn't totally boring+        -- E.g. let f = \ab.BIG in \y. map f xs+        --      Don't want to substitute for f, because then we allocate+        --      its closure every time the \y is called+        -- But: let f = \ab.BIG in \y. map (f y) xs+        --      Now we do want to substitute for f, even though it's not+        --      saturated, because we're going to allocate a closure for+        --      (f y) every time round the loop anyhow.++        -- canInlineInLam => free vars of rhs are (Once in_lam) or Many,+        -- so substituting rhs inside a lambda doesn't change the occ info.+        -- Sadly, not quite the same as exprIsHNF.+    canInlineInLam (Lit _)    = True+    canInlineInLam (Lam b e)  = isRuntimeVar b || canInlineInLam e+    canInlineInLam (Tick t e) = not (tickishIsCode t) && canInlineInLam e+    canInlineInLam (Var v)    = case idOccInfo v of+                                  OneOcc { occ_in_lam = IsInsideLam } -> True+                                  ManyOccs {}                         -> True+                                  _                                   -> False+    canInlineInLam _          = False+      -- not ticks.  Counting ticks cannot be duplicated, and non-counting+      -- ticks around a Lam will disappear anyway.++    early_phase = sePhase env /= FinalPhase+    -- If we don't have this early_phase test, consider+    --      x = length [1,2,3]+    -- The full laziness pass carefully floats all the cons cells to+    -- top level, and preInlineUnconditionally floats them all back in.+    -- Result is (a) static allocation replaced by dynamic allocation+    --           (b) many simplifier iterations because this tickles+    --               a related problem; only one inlining per pass+    --+    -- On the other hand, I have seen cases where top-level fusion is+    -- lost if we don't inline top level thing (e.g. string constants)+    -- Hence the test for phase zero (which is the phase for all the final+    -- simplifications).  Until phase zero we take no special notice of+    -- top level things, but then we become more leery about inlining+    -- them.+    --+    -- What exactly to check in `early_phase` above is the subject of #17910.+    --+    -- !10088 introduced an additional Simplifier iteration in LargeRecord+    -- because we first FloatOut `case unsafeEqualityProof of ... -> I# 2#`+    -- (a non-trivial value) which we immediately inline back in.+    -- Ideally, we'd never have inlined it because the binding turns out to+    -- be expandable; unfortunately we need an iteration of the Simplifier to+    -- attach the proper unfolding and can't check isExpandableUnfolding right+    -- here.+    -- (Nor can we check for `exprIsExpandable rhs`, because that needs to look+    -- at the non-existent unfolding for the `I# 2#` which is also floated out.)++{-+************************************************************************+*                                                                      *+                  postInlineUnconditionally+*                                                                      *+************************************************************************++postInlineUnconditionally+~~~~~~~~~~~~~~~~~~~~~~~~~+@postInlineUnconditionally@ decides whether to unconditionally inline+a thing based on the form of its RHS; in particular if it has a+trivial RHS.  If so, we can inline and discard the binding altogether.++NB: a loop breaker has must_keep_binding = True and non-loop-breakers+only have *forward* references. Hence, it's safe to discard the binding++NOTE: This isn't our last opportunity to inline.  We're at the binding+site right now, and we'll get another opportunity when we get to the+occurrence(s)++Note that we do this unconditional inlining only for trivial RHSs.+Don't inline even WHNFs inside lambdas; doing so may simply increase+allocation when the function is called. This isn't the last chance; see+NOTE above.++NB: Even inline pragmas (e.g. IMustBeINLINEd) are ignored here Why?+Because we don't even want to inline them into the RHS of constructor+arguments. See NOTE above++NB: At one time even NOINLINE was ignored here: if the rhs is trivial+it's best to inline it anyway.  We often get a=E; b=a from desugaring,+with both a and b marked NOINLINE.  But that seems incompatible with+our new view that inlining is like a RULE, so I'm sticking to the 'active'+story for now.++NB: unconditional inlining of this sort can introduce ticks in places that+may seem surprising; for instance, the LHS of rules. See Note [Simplifying+rules] for details.+-}++postInlineUnconditionally+    :: SimplEnv -> BindContext+    -> InId -> OutId    -- The binder (*not* a CoVar), including its unfolding+    -> OutExpr+    -> Bool+-- Precondition: rhs satisfies the let-can-float invariant+-- See Note [Core let-can-float invariant] in GHC.Core+-- Reason: we don't want to inline single uses, or discard dead bindings,+--         for unlifted, side-effect-ful bindings+postInlineUnconditionally env bind_cxt old_bndr bndr rhs+  | not active                  = False+  | isWeakLoopBreaker occ_info  = False -- If it's a loop-breaker of any kind, don't inline+                                        -- because it might be referred to "earlier"+  | isStableUnfolding unfolding = False -- Note [Stable unfoldings and postInlineUnconditionally]+  | isTopLevel (bindContextLevel bind_cxt)+                                = False -- Note [Top level and postInlineUnconditionally]+  | exprIsTrivial rhs           = True+  | BC_Join {} <- bind_cxt      = False -- See point (1) of Note [Duplicating join points]+                                        --     in GHC.Core.Opt.Simplify.Iteration+  | otherwise+  = case occ_info of+      OneOcc { occ_in_lam = in_lam, occ_int_cxt = int_cxt, occ_n_br = n_br }+        -- See Note [Inline small things to avoid creating a thunk]++        | n_br >= 100 -> False  -- See #23627++        | n_br == 1, NotInsideLam <- in_lam  -- One syntactic occurrence+        -> True                              -- See Note [Post-inline for single-use things]++--        | is_unlifted                        -- Unlifted binding, hence ok-for-spec+--        -> True                              -- hence cheap to inline probably just a primop+--                                             -- Not a big deal either way+-- No, this is wrong.  {v = p +# q; x = K v}.+-- Don't inline v; it'll just get floated out again. Stupid.++        | is_demanded+        -> False                            -- No allocation (it'll be a case expression in the end)+                                            -- so inlining duplicates code but nothing more++        | otherwise+        -> work_ok in_lam int_cxt && smallEnoughToInline uf_opts unfolding+              -- Multiple syntactic occurences; but lazy, and small enough to dup+              -- ToDo: consider discount on smallEnoughToInline if int_cxt is true++      IAmDead -> True   -- This happens; for example, the case_bndr during case of+                        -- known constructor:  case (a,b) of x { (p,q) -> ... }+                        -- Here x isn't mentioned in the RHS, so we don't want to+                        -- create the (dead) let-binding  let x = (a,b) in ...++      _ -> False++  where+    work_ok NotInsideLam _              = True+    work_ok IsInsideLam  IsInteresting  = isCheapUnfolding unfolding+    work_ok IsInsideLam  NotInteresting = False+      -- NotInsideLam: outside a lambda, we want to be reasonably aggressive+      -- about inlining into multiple branches of case+      -- e.g. let x = <non-value>+      --      in case y of { C1 -> ..x..; C2 -> ..x..; C3 -> ... }+      -- Inlining can be a big win if C3 is the hot-spot, even if+      -- the uses in C1, C2 are not 'interesting'+      -- An example that gets worse if you add int_cxt here is 'clausify'++      -- InsideLam: check for acceptable work duplication, using isCheapUnfoldign+      -- int_cxt to prevent us inlining inside a lambda without some+      -- good reason.  See the notes on int_cxt in preInlineUnconditionally++--    is_unlifted = isUnliftedType (idType bndr)+    is_demanded = isStrUsedDmd (idDemandInfo bndr)+    occ_info    = idOccInfo old_bndr+    unfolding   = idUnfolding bndr+    uf_opts     = seUnfoldingOpts env+    phase       = sePhase env+    active      = isActive phase (idInlineActivation bndr)+        -- See Note [pre/postInlineUnconditionally in gentle mode]++{- Note [Inline small things to avoid creating a thunk]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The point of examining occ_info here is that for *non-values* that+occur outside a lambda, the call-site inliner won't have a chance+(because it doesn't know that the thing only occurs once).  The+pre-inliner won't have gotten it either, if the thing occurs in more+than one branch So the main target is things like++     let x = f y in+     case v of+        True  -> case x of ...+        False -> case x of ...++This is very important in practice; e.g. wheel-seive1 doubles+in allocation if you miss this out.  And bits of GHC itself start+to allocate more.  An egregious example is test perf/compiler/T14697,+where GHC.Driver.CmdLine.$wprocessArgs allocated hugely more.++Note [Post-inline for single-use things]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we have++   let x = rhs in ...x...++and `x` is used exactly once, and not inside a lambda, then we will usually+preInlineUnconditinally. But we can still get this situation in+postInlineUnconditionally:++  case K rhs of K x -> ...x....++Here we'll use `simplAuxBind` to bind `x` to (the already-simplified) `rhs`;+and `x` is used exactly once.  It's beneficial to inline right away; otherwise+we risk creating++   let x = rhs in ...x...++which will take another iteration of the Simplifier to eliminate.  We do this in+two places++1. In the full `postInlineUnconditionally` look for the special case+   of "one occurrence, not under a lambda", and inline unconditionally then.++   This is a bit risky: see Note [Avoiding simplifying repeatedly] in+   Simplify.Iteration.  But in practice it seems to be a small win.++2. `simplAuxBind` does a kind of poor-man's `postInlineUnconditionally`.  It+   does not need to account for many of the cases (e.g. top level) that the+   full `postInlineUnconditionally` does.  Moreover, we don't have an+   OutId, which `postInlineUnconditionally` needs.  I got a slight improvement+   in compiler performance when I added this test.++Here's an example that we don't currently handle well:+     let f = if b then Left (\x.BIG) else Right (\y.BIG)+     in \y. ....case f of {...} ....+Here f is used just once, and duplicating the case work is fine (exprIsCheap).+But+ - We can't preInlineUnconditionally because that would invalidate+   the occ info for b.+ - We can't postInlineUnconditionally because the RHS is big, and+   that risks exponential behaviour+ - We can't call-site inline, because the rhs is big+Alas!+++Note [Top level and postInlineUnconditionally]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We don't do postInlineUnconditionally for top-level things (even for+ones that are trivial):++  * Doing so will inline top-level error expressions that have been+    carefully floated out by FloatOut.  More generally, it might+    replace static allocation with dynamic.++  * Even for trivial expressions there's a problem.  Consider+      {-# RULE "foo" forall (xs::[T]). reverse xs = ruggle xs #-}+      blah xs = reverse xs+      ruggle = sort+    In one simplifier pass we might fire the rule, getting+      blah xs = ruggle xs+    but in *that* simplifier pass we must not do postInlineUnconditionally+    on 'ruggle' because then we'll have an unbound occurrence of 'ruggle'++    If the rhs is trivial it'll be inlined by callSiteInline, and then+    the binding will be dead and discarded by the next use of OccurAnal++  * There is less point, because the main goal is to get rid of local+    bindings used in multiple case branches.++  * The inliner should inline trivial things at call sites anyway.++  * The Id might be exported.  We could check for that separately,+    but since we aren't going to postInlineUnconditionally /any/+    top-level bindings, we don't need to test.++Note [Stable unfoldings and postInlineUnconditionally]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Do not do postInlineUnconditionally if the Id has a stable unfolding,+otherwise we lose the unfolding.  Example++     -- f has stable unfolding with rhs (e |> co)+     --   where 'e' is big+     f = e |> co++Then there's a danger we'll optimise to++     f' = e+     f = f' |> co++and now postInlineUnconditionally, losing the stable unfolding on f.  Now f'+won't inline because 'e' is too big.++    c.f. Note [Stable unfoldings and preInlineUnconditionally]+++************************************************************************+*                                                                      *+        Rebuilding a lambda+*                                                                      *+************************************************************************+-}++rebuildLam :: SimplEnv+           -> [OutBndr] -> OutExpr+           -> SimplCont+           -> SimplM OutExpr+-- (rebuildLam env bndrs body cont)+-- returns expr which means the same as \bndrs. body+--+-- But it tries+--      a) eta reduction, if that gives a trivial expression+--      b) eta expansion [only if there are some value lambdas]+--+-- NB: the SimplEnv already includes the [OutBndr] in its in-scope set++rebuildLam _env [] body _cont+  = return body++rebuildLam env bndrs@(bndr:_) body cont+  = {-# SCC "rebuildLam" #-} try_eta bndrs body+  where+    rec_ids  = seRecIds env+    in_scope = getInScope env  -- Includes 'bndrs'+    mb_rhs   = contIsRhs cont++    -- See Note [Eta reduction based on evaluation context]+    eval_sd = contEvalContext cont+        -- NB: cont is never ApplyToVal, because beta-reduction would+        -- have happened.  So contEvalContext can panic on ApplyToVal.++    try_eta :: [OutBndr] -> OutExpr -> SimplM OutExpr+    try_eta bndrs body+      | -- Try eta reduction+        seDoEtaReduction env+      , Just etad_lam <- tryEtaReduce rec_ids bndrs body eval_sd+      = do { tick (EtaReduction bndr)+           ; return etad_lam }++      | -- Try eta expansion+        Nothing <- mb_rhs  -- See Note [Eta expanding lambdas]+      , seEtaExpand env+      , any isRuntimeVar bndrs  -- Only when there is at least one value lambda already+      , Just body_arity <- exprEtaExpandArity (seArityOpts env) body+      = do { tick (EtaExpansion bndr)+           ; let body' = etaExpandAT in_scope body_arity body+           ; traceSmpl "eta expand" (vcat [text "before" <+> ppr body+                                          , text "after" <+> ppr body'])+           -- NB: body' might have an outer Cast, but if so+           --     mk_lams will pull it further out, past 'bndrs' to the top+           ; return (mk_lams bndrs body') }++      | otherwise+      = return (mk_lams bndrs body)++    mk_lams :: [OutBndr] -> OutExpr -> OutExpr+    -- mk_lams pulls casts and ticks to the top+    mk_lams bndrs body@(Lam {})+      = mk_lams (bndrs ++ bndrs1) body1+      where+        (bndrs1, body1) = collectBinders body++    mk_lams bndrs (Tick t expr)+      | tickishFloatable t+      = mkTick t (mk_lams bndrs expr)++    mk_lams bndrs (Cast body co)+      | -- Note [Casts and lambdas]+        seCastSwizzle env+      , not (any bad bndrs)+      = mkCast (mk_lams bndrs body) (mkPiCos Representational bndrs co)+      where+        co_vars  = tyCoVarsOfCo co+        bad bndr = isCoVar bndr && bndr `elemVarSet` co_vars++    mk_lams bndrs body+      = mkLams bndrs body++{-+Note [Eta expanding lambdas]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In general we *do* want to eta-expand lambdas. Consider+   f (\x -> case x of (a,b) -> \s -> blah)+where 's' is a state token, and hence can be eta expanded.  This+showed up in the code for GHc.IO.Handle.Text.hPutChar, a rather+important function!++The eta-expansion will never happen unless we do it now.  (Well, it's+possible that CorePrep will do it, but CorePrep only has a half-baked+eta-expander that can't deal with casts.  So it's much better to do it+here.)++However, when the lambda is let-bound, as the RHS of a let, we have a+better eta-expander (in the form of tryEtaExpandRhs), so we don't+bother to try expansion in mkLam in that case; hence the contIsRhs+guard.++Note [Casts and lambdas]+~~~~~~~~~~~~~~~~~~~~~~~~+Consider+        (\(x:tx). (\(y:ty). e) `cast` co)++We float the cast out, thus+        (\(x:tx) (y:ty). e) `cast` (tx -> co)++We do this for at least three reasons:++1. There is a danger here that the two lambdas look separated, and the+   full laziness pass might float an expression to between the two.++2. The occurrence analyser will mark x as InsideLam if the Lam nodes+   are separated (see the Lam case of occAnal).  By floating the cast+   out we put the two Lams together, so x can get a vanilla Once+   annotation.  If this lambda is the RHS of a let, which we inline,+   we can do preInlineUnconditionally on that x=arg binding.  With the+   InsideLam OccInfo, we can't do that, which results in an extra+   iteration of the Simplifier.++3. It may cancel with another cast.  E.g+      (\x. e |> co1) |> co2+   If we float out co1 it might cancel with co2.  Similarly+      let f = (\x. e |> co1) in ...+   If we float out co1, and then do cast worker/wrapper, we get+      let f1 = \x.e; f = f1 |> co1 in ...+   and now we can inline f, hoping that co1 may cancel at a call site.++TL;DR: put the lambdas together if at all possible.++In general, here's the transformation:+        \x. e `cast` co   ===>   (\x. e) `cast` (tx -> co)+        /\a. e `cast` co  ===>   (/\a. e) `cast` (/\a. co)+        /\g. e `cast` co  ===>   (/\g. e) `cast` (/\g. co)+                          (if not (g `in` co))++We call this "cast swizzling". It is controlled by sm_cast_swizzle.+See also Note [Cast swizzling on rule LHSs]++Wrinkles++* Notice that it works regardless of 'e'.  Originally it worked only+  if 'e' was itself a lambda, but in some cases that resulted in+  fruitless iteration in the simplifier.  A good example was when+  compiling Text.ParserCombinators.ReadPrec, where we had a definition+  like    (\x. Get `cast` g)+  where Get is a constructor with nonzero arity.  Then mkLam eta-expanded+  the Get, and the next iteration eta-reduced it, and then eta-expanded+  it again.++* Note also the side condition for the case of coercion binders, namely+  not (any bad bndrs).  It does not make sense to transform+          /\g. e `cast` g  ==>  (/\g.e) `cast` (/\g.g)+  because the latter is not well-kinded.+++************************************************************************+*                                                                      *+              Eta expansion+*                                                                      *+************************************************************************+-}++tryEtaExpandRhs :: SimplEnv -> BindContext -> OutId -> OutExpr+                -> SimplM (ArityType, OutExpr)+-- See Note [Eta-expanding at let bindings]+tryEtaExpandRhs env bind_cxt bndr rhs+  | seEtaExpand env         -- If Eta-expansion is on+  , wantEtaExpansion rhs    -- and we'd like to eta-expand e+  , do_eta_expand           -- and e's manifest arity is lower than+                            --     what it could be+                            --     (never true for join points)+  =                         -- Do eta-expansion.+    assertPpr( not (isJoinBC bind_cxt) ) (ppr bndr) $+       -- assert: this never happens for join points; see GHC.Core.Opt.Arity+       --         Note [Do not eta-expand join points]+    do { tick (EtaExpansion bndr)+       ; return (arity_type, etaExpandAT in_scope arity_type rhs) }++  | otherwise+  = return (arity_type, rhs)++  where+    in_scope   = getInScope env+    arity_opts = seArityOpts env+    is_rec     = bindContextRec bind_cxt+    (do_eta_expand, arity_type) = findRhsArity arity_opts is_rec bndr rhs++wantEtaExpansion :: CoreExpr -> Bool+-- Mostly True; but False of PAPs which will immediately eta-reduce again+-- See Note [Which RHSs do we eta-expand?]+wantEtaExpansion (Cast e _)             = wantEtaExpansion e+wantEtaExpansion (Tick _ e)             = wantEtaExpansion e+wantEtaExpansion (Lam b e) | isTyVar b  = wantEtaExpansion e+wantEtaExpansion (App e _)              = wantEtaExpansion e+wantEtaExpansion (Var {})               = False+wantEtaExpansion (Lit {})               = False+wantEtaExpansion _                      = True++{-+Note [Eta-expanding at let bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We now eta expand at let-bindings, which is where the payoff comes.+The most significant thing is that we can do a simple arity analysis+(in GHC.Core.Opt.Arity.findRhsArity), which we can't do for free-floating lambdas++One useful consequence of not eta-expanding lambdas is this example:+   genMap :: C a => ...+   {-# INLINE genMap #-}+   genMap f xs = ...++   myMap :: D a => ...+   {-# INLINE myMap #-}+   myMap = genMap++Notice that 'genMap' should only inline if applied to two arguments.+In the stable unfolding for myMap we'll have the unfolding+    (\d -> genMap Int (..d..))+We do not want to eta-expand to+    (\d f xs -> genMap Int (..d..) f xs)+because then 'genMap' will inline, and it really shouldn't: at least+as far as the programmer is concerned, it's not applied to two+arguments!++Note [Which RHSs do we eta-expand?]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We don't eta-expand:++* Trivial RHSs, e.g.     f = g+  If we eta expand do+    f = \x. g x+  we'll just eta-reduce again, and so on; so the+  simplifier never terminates.++* PAPs: see Note [Do not eta-expand PAPs]++What about things like this?+   f = case y of p -> \x -> blah++Here we do eta-expand.  This is a change (Jun 20), but if we have+really decided that f has arity 1, then putting that lambda at the top+seems like a Good idea.++Note [Do not eta-expand PAPs]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We used to have old_arity = manifestArity rhs, which meant that we+would eta-expand even PAPs.  But this gives no particular advantage,+and can lead to a massive blow-up in code size, exhibited by #9020.+Suppose we have a PAP+    foo :: IO ()+    foo = returnIO ()+Then we can eta-expand to+    foo = (\eta. (returnIO () |> sym g) eta) |> g+where+    g :: IO () ~ State# RealWorld -> (# State# RealWorld, () #)++But there is really no point in doing this, and it generates masses of+coercions and whatnot that eventually disappear again. For T9020, GHC+allocated 6.6G before, and 0.8G afterwards; and residency dropped from+1.8G to 45M.++Moreover, if we eta expand+        f = g d  ==>  f = \x. g d x+that might in turn make g inline (if it has an inline pragma), which+we might not want.  After all, INLINE pragmas say "inline only when+saturated" so we don't want to be too gung-ho about saturating!++But note that this won't eta-expand, say+  f = \g -> map g+Does it matter not eta-expanding such functions?  I'm not sure.  Perhaps+strictness analysis will have less to bite on?+++************************************************************************+*                                                                      *+\subsection{Floating lets out of big lambdas}+*                                                                      *+************************************************************************++Note [Floating and type abstraction]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this:+        x = /\a. C e1 e2+We'd like to float this to+        y1 = /\a. e1+        y2 = /\a. e2+        x  = /\a. C (y1 a) (y2 a)+for the usual reasons: we want to inline x rather vigorously.++You may think that this kind of thing is rare.  But in some programs it is+common.  For example, if you do closure conversion you might get:++        data a :-> b = forall e. (e -> a -> b) :$ e++        f_cc :: forall a. a :-> a+        f_cc = /\a. (\e. id a) :$ ()++Now we really want to inline that f_cc thing so that the+construction of the closure goes away.++So I have elaborated simplLazyBind to understand right-hand sides that look+like+        /\ a1..an. body++and treat them specially. The real work is done in+GHC.Core.Opt.Simplify.Utils.abstractFloats, but there is quite a bit of plumbing+in simplLazyBind as well.++The same transformation is good when there are lets in the body:++        /\abc -> let(rec) x = e in b+   ==>+        let(rec) x' = /\abc -> let x = x' a b c in e+        in+        /\abc -> let x = x' a b c in b++This is good because it can turn things like:++        let f = /\a -> letrec g = ... g ... in g+into+        letrec g' = /\a -> ... g' a ...+        in+        let f = /\ a -> g' a++which is better.  In effect, it means that big lambdas don't impede+let-floating.++This optimisation is CRUCIAL in eliminating the junk introduced by+desugaring mutually recursive definitions.  Don't eliminate it lightly!++[May 1999]  If we do this transformation *regardless* then we can+end up with some pretty silly stuff.  For example,++        let+            st = /\ s -> let { x1=r1 ; x2=r2 } in ...+        in ..+becomes+        let y1 = /\s -> r1+            y2 = /\s -> r2+            st = /\s -> ...[y1 s/x1, y2 s/x2]+        in ..++Unless the "..." is a WHNF there is really no point in doing this.+Indeed it can make things worse.  Suppose x1 is used strictly,+and is of the form++        x1* = case f y of { (a,b) -> e }++If we abstract this wrt the tyvar we then can't do the case inline+as we would normally do.++That's why the whole transformation is part of the same process that+floats let-bindings and constructor arguments out of RHSs.  In particular,+it is guarded by the doFloatFromRhs call in simplLazyBind.++Note [Which type variables to abstract over]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Abstract only over the type variables free in the rhs wrt which the+new binding is abstracted.  Several points worth noting++(AB1) The naive approach of abstracting wrt the+      tyvars free in the Id's /type/ fails. Consider:+          /\ a b -> let t :: (a,b) = (e1, e2)+                        x :: a     = fst t+                    in ...+      Here, b isn't free in x's type, but we must nevertheless+      abstract wrt b as well, because t's type mentions b.+      Since t is floated too, we'd end up with the bogus:+           poly_t = /\ a b -> (e1, e2)+           poly_x = /\ a   -> fst (poly_t a *b*)++(AB2) We must do closeOverKinds.  Example (#10934):+       f = /\k (f:k->*) (a:k). let t = AccFailure @ (f a) in ...+      Here we want to float 't', but we must remember to abstract over+      'k' as well, even though it is not explicitly mentioned in the RHS,+      otherwise we get+         t = /\ (f:k->*) (a:k). AccFailure @ (f a)+      which is obviously bogus.++(AB3) We get the variables to abstract over by filtering down the+      the main_tvs for the original function, picking only ones+      mentioned in the abstracted body. This means:+      - they are automatically in dependency order, because main_tvs is+      - there is no issue about non-determinism+      - we don't gratuitously change order, which may help (in a tiny+        way) with CSE and/or the compiler-debugging experience++(AB4) For a recursive group, it's a bit of a pain to work out the minimal+      set of tyvars over which to abstract:+           /\ a b c.  let x = ...a... in+                      letrec { p = ...x...q...+                               q = .....p...b... } in+                      ...+      Since 'x' is abstracted over 'a', the {p,q} group must be abstracted+      over 'a' (because x is replaced by (poly_x a)) as well as 'b'.+      Remember this bizarre case too:+           x::a = x+      Here, we must abstract 'x' over 'a'.++      Why is it worth doing this?  Partly tidiness; and partly #22459+      which showed that it's harder to do polymorphic specialisation well+      if there are dictionaries abstracted over unnecessary type variables.+      See Note [Weird special case for SpecDict] in GHC.Core.Opt.Specialise++(AB5) We do dependency analysis on recursive groups prior to determining+      which variables to abstract over.+      This is useful, because ANFisation in prepareBinding may float out+      values out of a complex recursive binding, e.g.,+          letrec { xs = g @a "blah"# ((:) 1 []) xs } in ...+        ==> { prepareBinding }+          letrec { foo = "blah"#+                   bar = [42]+                   xs = g @a foo bar xs } in+          ...+      and we don't want to abstract foo and bar over @a.++      (Why is it OK to float the unlifted `foo` there?+      See Note [Core top-level string literals] in GHC.Core;+      it is controlled by GHC.Core.Opt.Simplify.Env.unitLetFloat.)++      It is also necessary to do dependency analysis, because+      otherwise (in #24551) we might get `foo = \@_ -> "missing"#` at the+      top-level, and that triggers a CoreLint error because `foo` is *not*+      manifestly a literal string.+-}++abstractFloats :: UnfoldingOpts -> TopLevelFlag -> [OutTyVar] -> SimplFloats+              -> OutExpr -> SimplM ([OutBind], OutExpr)+abstractFloats uf_opts top_lvl main_tvs floats body+  = assert (notNull body_floats) $+    assert (isNilOL (sfJoinFloats floats)) $+    do  { let sccs = concatMap to_sccs body_floats+        ; (subst, float_binds) <- mapAccumLM abstract empty_subst sccs+        ; return (float_binds, GHC.Core.Subst.substExpr subst body) }+  where+    is_top_lvl  = isTopLevel top_lvl+    body_floats = letFloatBinds (sfLetFloats floats)+    empty_subst = GHC.Core.Subst.mkEmptySubst (sfInScope floats)++    -- See wrinkle (AB5) in Note [Which type variables to abstract over]+    -- for why we need to re-do dependency analysis+    to_sccs :: OutBind -> [SCC (Id, CoreExpr, VarSet)]+    to_sccs (NonRec id e) = [AcyclicSCC (id, e, emptyVarSet)] -- emptyVarSet: abstract doesn't need it+    to_sccs (Rec prs)     = sccs+      where+        (ids,rhss) = unzip prs+        sccs = depAnal (\(id,_rhs,_fvs) -> [getName id])+                       (\(_id,_rhs,fvs) -> nonDetStrictFoldVarSet ((:) . getName) [] fvs) -- Wrinkle (AB3)+                       (zip3 ids rhss (map exprFreeVars rhss))++    abstract :: GHC.Core.Subst.Subst -> SCC (Id, CoreExpr, VarSet) -> SimplM (GHC.Core.Subst.Subst, OutBind)+    abstract subst (AcyclicSCC (id, rhs, _empty_var_set))+      = do { (poly_id1, poly_app) <- mk_poly1 tvs_here id+           ; let (poly_id2, poly_rhs) = mk_poly2 poly_id1 tvs_here rhs'+                 !subst' = GHC.Core.Subst.extendIdSubst subst id poly_app+           ; return (subst', NonRec poly_id2 poly_rhs) }+      where+        rhs' = GHC.Core.Subst.substExpr subst rhs++        -- tvs_here: see Note [Which type variables to abstract over]+        tvs_here = choose_tvs (exprSomeFreeVars isTyVar rhs')++    abstract subst (CyclicSCC trpls)+      = do { (poly_ids, poly_apps) <- mapAndUnzipM (mk_poly1 tvs_here) ids+           ; let subst' = GHC.Core.Subst.extendSubstList subst (ids `zip` poly_apps)+                 poly_pairs = [ mk_poly2 poly_id tvs_here rhs'+                              | (poly_id, rhs) <- poly_ids `zip` rhss+                              , let rhs' = GHC.Core.Subst.substExpr subst' rhs ]+           ; return (subst', Rec poly_pairs) }+      where+        (ids,rhss,_fvss) = unzip3 trpls++        -- tvs_here: see Note [Which type variables to abstract over]+        tvs_here = choose_tvs (mapUnionVarSet get_bind_fvs trpls)++        -- See wrinkle (AB4) in Note [Which type variables to abstract over]+        get_bind_fvs (id,_rhs,rhs_fvs) = tyCoVarsOfType (idType id) `unionVarSet` get_rec_rhs_tvs rhs_fvs+        get_rec_rhs_tvs rhs_fvs        = nonDetStrictFoldVarSet get_tvs emptyVarSet rhs_fvs+                                  -- nonDet is safe because of wrinkle (AB3)++        get_tvs :: Var -> VarSet -> VarSet+        get_tvs var free_tvs+           | isTyVar var      -- CoVars have been substituted away+           = extendVarSet free_tvs var+           | isCoVar var  -- CoVars can be free in the RHS, but they are never let-bound;+           = free_tvs     -- Do not call lookupIdSubst_maybe, though (#23426)+                          --    because it has a non-CoVar precondition+           | Just poly_app <- GHC.Core.Subst.lookupIdSubst_maybe subst var+           = -- 'var' is like 'x' in (AB4)+             exprSomeFreeVars isTyVar poly_app `unionVarSet` free_tvs+           | otherwise+           = free_tvs++    choose_tvs free_tvs+       = filter (`elemVarSet` all_free_tvs) main_tvs  -- (AB3)+       where+         all_free_tvs = closeOverKinds free_tvs       -- (AB2)++    mk_poly1 :: [TyVar] -> Id -> SimplM (Id, CoreExpr)+    mk_poly1 tvs_here var+      = do { uniq <- getUniqueM+           ; let  poly_name = setNameUnique (idName var) uniq      -- Keep same name+                  poly_ty   = mkInfForAllTys tvs_here (idType var) -- But new type of course+                  poly_id   = transferPolyIdInfo var tvs_here $ -- Note [transferPolyIdInfo] in GHC.Types.Id+                              mkLocalId poly_name (idMult var) poly_ty+           ; return (poly_id, mkTyApps (Var poly_id) (mkTyVarTys tvs_here)) }+                -- In the olden days, it was crucial to copy the occInfo of the original var,+                -- because we were looking at occurrence-analysed but as yet unsimplified code!+                -- In particular, we mustn't lose the loop breakers.  BUT NOW we are looking+                -- at already simplified code, so it doesn't matter+                --+                -- It's even right to retain single-occurrence or dead-var info:+                -- Suppose we started with  /\a -> let x = E in B+                -- where x occurs once in B. Then we transform to:+                --      let x' = /\a -> E in /\a -> let x* = x' a in B+                -- where x* has an INLINE prag on it.  Now, once x* is inlined,+                -- the occurrences of x' will be just the occurrences originally+                -- pinned on x.++    mk_poly2 :: Id -> [TyVar] -> CoreExpr -> (Id, CoreExpr)+    mk_poly2 poly_id tvs_here rhs+      = (poly_id `setIdUnfolding` unf, poly_rhs)+      where+        poly_rhs = mkLams tvs_here rhs+        unf = mkUnfolding uf_opts VanillaSrc is_top_lvl False False poly_rhs Nothing++        -- We want the unfolding.  Consider+        --      let+        --            x = /\a. let y = ... in Just y+        --      in body+        -- Then we float the y-binding out (via abstractFloats and addPolyBind)+        -- but 'x' may well then be inlined in 'body' in which case we'd like the+        -- opportunity to inline 'y' too.++{-+Note [Abstract over coercions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If a coercion variable (g :: a ~ Int) is free in the RHS, then so is the+type variable a.  Rather than sort this mess out, we simply bale out and abstract+wrt all the type variables if any of them are coercion variables.+++Historical note: if you use let-bindings instead of a substitution, beware of this:++                -- Suppose we start with:+                --+                --      x = /\ a -> let g = G in E+                --+                -- Then we'll float to get+                --+                --      x = let poly_g = /\ a -> G+                --          in /\ a -> let g = poly_g a in E+                --+                -- But now the occurrence analyser will see just one occurrence+                -- of poly_g, not inside a lambda, so the simplifier will+                -- PreInlineUnconditionally poly_g back into g!  Badk to square 1!+                -- (I used to think that the "don't inline lone occurrences" stuff+                --  would stop this happening, but since it's the *only* occurrence,+                --  PreInlineUnconditionally kicks in first!)+                --+                -- Solution: put an INLINE note on g's RHS, so that poly_g seems+                --           to appear many times.  (NB: mkInlineMe eliminates+                --           such notes on trivial RHSs, so do it manually.)++************************************************************************+*                                                                      *+                prepareAlts+*                                                                      *+************************************************************************++prepareAlts tries these things:++1.  filterAlts: eliminate alternatives that cannot match, including+    the DEFAULT alternative.  Here "cannot match" includes knowledge+    from GADTs++2.  refineDefaultAlt: if the DEFAULT alternative can match only one+    possible constructor, then make that constructor explicit.+    e.g.+        case e of x { DEFAULT -> rhs }+     ===>+        case e of x { (a,b) -> rhs }+    where the type is a single constructor type.  This gives better code+    when rhs also scrutinises x or e.+    See GHC.Core.Utils Note [Refine DEFAULT case alternatives]++3. combineIdenticalAlts: combine identical alternatives into a DEFAULT.+   See CoreUtils Note [Combine identical alternatives], which also+   says why we do this on InAlts not on OutAlts++4. Returns a list of the constructors that cannot holds in the+   DEFAULT alternative (if there is one)++It's a good idea to do this stuff before simplifying the alternatives, to+avoid simplifying alternatives we know can't happen, and to come up with+the list of constructors that are handled, to put into the IdInfo of the+case binder, for use when simplifying the alternatives.++Eliminating the default alternative in (1) isn't so obvious, but it can+happen:++data Colour = Red | Green | Blue++f x = case x of+        Red -> ..+        Green -> ..+        DEFAULT -> h x++h y = case y of+        Blue -> ..+        DEFAULT -> [ case y of ... ]++If we inline h into f, the default case of the inlined h can't happen.+If we don't notice this, we may end up filtering out *all* the cases+of the inner case y, which give us nowhere to go!++Note [Shadowing in prepareAlts]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Note that we pass case_bndr::InId to prepareAlts; an /InId/, not an+/OutId/.  This is vital, because `refineDefaultAlt` uses `tys` to build+a new /InAlt/.  If you pass an OutId, we'll end up applying the+substitution twice: disaster (#23012).++However this does mean that filling in the default alt might be+delayed by a simplifier cycle, because an InId has less info than an+OutId.  Test simplCore/should_compile/simpl013 apparently shows this+up, although I'm not sure exactly how..+-}++prepareAlts :: OutExpr -> InId -> [InAlt] -> SimplM ([AltCon], [InAlt])+-- The returned alternatives can be empty, none are possible+--+-- Note that case_bndr is an InId; see Note [Shadowing in prepareAlts]+prepareAlts scrut case_bndr alts+  | Just (tc, tys) <- splitTyConApp_maybe (idType case_bndr)+  = do { us <- getUniquesM+       ; let (idcs1, alts1) = filterAlts tc tys imposs_cons alts+             (yes2,  alts2) = refineDefaultAlt us (idMult case_bndr) tc tys idcs1 alts1+               -- The multiplicity on case_bndr's is the multiplicity of the+               -- case expression The newly introduced patterns in+               -- refineDefaultAlt must be scaled by this multiplicity+             (yes3, idcs3, alts3) = combineIdenticalAlts idcs1 alts2+             -- "idcs" stands for "impossible default data constructors"+             -- i.e. the constructors that can't match the default case+       ; when yes2 $ tick (FillInCaseDefault case_bndr)+       ; when yes3 $ tick (AltMerge case_bndr)+       ; return (idcs3, alts3) }++  | otherwise  -- Not a data type, so nothing interesting happens+  = return ([], alts)+  where+    imposs_cons = case scrut of+                    Var v -> otherCons (idUnfolding v)+                    _     -> []++{- Note [Merging nested cases]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The basic case-merge stuff is described in Note [Merge Nested Cases] in GHC.Core.Utils++We do it here in `prepareAlts` (on InAlts) rather than after (on OutAlts) for two reasons:++* It "belongs" here with `filterAlts`, `refineDefaultAlt` and `combineIdenticalAlts`.++* In test perf/compiler/T22428 I found that I was getting extra Simplifer iterations:+    1. Create a join point+    2. That join point gets inlined at all call sites, so it is now dead.+    3. Case-merge happened, but left behind some trivial bindings (see `mergeCaseAlts`)+    4. Get rid of the trivial bindings+  The first two seem reasonable.  It's imaginable that we could do better on+  (3), by making case-merge join-point-aware, but it's not trivial.  But the+  fourth is just stupid.  Rather than always do an extra iteration, it's better+  to do the transformation on the input-end of teh Simplifier.+-}++{-+************************************************************************+*                                                                      *+                mkCase+*                                                                      *+************************************************************************++mkCase tries these things++* Note [Eliminate Identity Case]+* Note [Scrutinee Constant Folding]++Note [Eliminate Identity Case]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+        case e of               ===> e+                True  -> True;+                False -> False++and similar friends.++Note [Scrutinee Constant Folding]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+     case x op# k# of _ {  ===> case x of _ {+        a1# -> e1                  (a1# inv_op# k#) -> e1+        a2# -> e2                  (a2# inv_op# k#) -> e2+        ...                        ...+        DEFAULT -> ed              DEFAULT -> ed++     where (x op# k#) inv_op# k# == x++And similarly for commuted arguments and for some unary operations.++The purpose of this transformation is not only to avoid an arithmetic+operation at runtime but to allow other transformations to apply in cascade.++Example with the "Merge Nested Cases" optimization (from #12877):++      main = case t of t0+         0##     -> ...+         DEFAULT -> case t0 `minusWord#` 1## of t1+            0##     -> ...+            DEFAULT -> case t1 `minusWord#` 1## of t2+               0##     -> ...+               DEFAULT -> case t2 `minusWord#` 1## of _+                  0##     -> ...+                  DEFAULT -> ...++  becomes:++      main = case t of _+      0##     -> ...+      1##     -> ...+      2##     -> ...+      3##     -> ...+      DEFAULT -> ...++There are some wrinkles.++Wrinkle 1:+  Do not apply caseRules if there is just a single DEFAULT alternative,+  unless the case-binder is dead. Example:+     case e +# 3# of b { DEFAULT -> rhs }+  If we applied the transformation here we would (stupidly) get+     case e of b' { DEFAULT -> let b = b' +# 3# in rhs }+  and now the process may repeat, because that let will really+  be a case. But if the original case binder b is dead, we instead get+     case e of b' { DEFAULT -> rhs }+  and there is no such problem.++  See Note [Example of case-merging and caseRules] for a compelling+  example of why this dead-binder business can be really important.+++Wrinkle 2:+  The type of the scrutinee might change.  E.g.+        case tagToEnum (x :: Int#) of (b::Bool)+          False -> e1+          True -> e2+  ==>+        case x of (b'::Int#)+          DEFAULT -> e1+          1#      -> e2++Wrinkle 3:+  The case binder may be used in the right hand sides, so we need+  to make a local binding for it, if it is alive.  e.g.+         case e +# 10# of b+           DEFAULT -> blah...b...+           44#     -> blah2...b...+  ===>+         case e of b'+           DEFAULT -> let b = b' +# 10# in blah...b...+           34#     -> let b = 44# in blah2...b...++  Note that in the non-DEFAULT cases we know what to bind 'b' to,+  whereas in the DEFAULT case we must reconstruct the original value.+  But NB: we use b'; we do not duplicate 'e'.++Wrinkle 4:+  In dataToTag we might need to make up some fake binders;+  see Note [caseRules for dataToTag] in GHC.Core.Opt.ConstantFold+++Note [Example of case-merging and caseRules]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The case-transformation rules are quite powerful. Here's a+subtle example from #22375.  We start with++  data T = A | B | ...+    deriving Eq++  f :: T -> String+  f x = if | x==A -> "one"+           | x==B -> "two"+           | ...++In Core after a bit of simplification we get:++    f x = case dataToTagLarge# x of a# { _DEFAULT ->+          case a# of+            _DEFAULT -> case dataToTagLarge# x of b# { _DEFAULT ->+                        case b# of+                           _DEFAULT -> ...+                           1# -> "two"+                        }+            0# -> "one"+          }++Now consider what mkCase does to these case expressions.+The case-merge transformation Note [Merge Nested Cases]+does this (affecting both pairs of cases):++    f x = case dataToTagLarge# x of a# {+             _DEFAULT -> case dataToTagLarge# x of b# {+                          _DEFAULT -> ...+                          1# -> "two"+                         }+             0# -> "one"+          }++Now Note [caseRules for dataToTag] does its work, again+on both dataToTagLarge# cases:++    f x = case x of x1 {+             _DEFAULT -> case dataToTagLarge# x1 of a# { _DEFAULT ->+                         case x of x2 {+                           _DEFAULT -> case dataToTagLarge# x2 of b# { _DEFAULT -> ... }+                           B -> "two"+                         }}+             A -> "one"+          }+++The new dataToTagLarge# calls come from the "reconstruct scrutinee" part of+caseRules (note that a# and b# were not dead in the original program+before all this merging).  However, since a# and b# /are/ in fact dead+in the resulting program, we are left with redundant dataToTagLarge# calls.+But they are easily eliminated by doing caseRules again, in+the next Simplifier iteration, this time noticing that a# and b# are+dead.  Hence the "dead-binder" sub-case of Wrinkle 1 of Note+[Scrutinee Constant Folding] above.  Once we do this we get++    f x = case x of x1 {+             _DEFAULT -> case x1 of x2 { _DEFAULT ->+                         case x1 of x2 {+                            _DEFAULT -> case x2 of x3 { _DEFAULT -> ... }+                            B -> "two"+                         }}+             A -> "one"+          }++and now we can do case-merge again, getting the desired++    f x = case x of+            A -> "one"+            B -> "two"+            ...++-}++mkCase, mkCase1, mkCase2, mkCase3+   :: SimplMode+   -> OutExpr -> OutId+   -> OutType -> [OutAlt]               -- Alternatives in standard (increasing) order+   -> SimplM OutExpr++--------------------------------------------------+--      1. Merge Nested Cases+--         See Note [Merge Nested Cases]+--             Note [Example of case-merging and caseRules]+--             Note [Cascading case merge]+--------------------------------------------------++mkCase mode scrut outer_bndr alts_ty alts+  | sm_case_merge mode+  , Just (joins, alts') <- mergeCaseAlts outer_bndr alts+  = do  { tick (CaseMerge outer_bndr)+        ; case_expr <- mkCase1 mode scrut outer_bndr alts_ty alts'+        ; return (mkLets joins case_expr) }+        -- mkCase1: don't call mkCase recursively!+        -- Firstly, there's no point, because inner alts have already had+        -- mkCase applied to them, so they won't have a case in their default+        -- Secondly, if you do, you get an infinite loop, because the bindCaseBndr+        -- in munge_rhs may put a case into the DEFAULT branch!+  | otherwise+  = mkCase1 mode scrut outer_bndr alts_ty alts++--------------------------------------------------+--      2. Eliminate Identity Case+--         See Note [Eliminate Identity Case]+--------------------------------------------------++mkCase1 _mode scrut case_bndr _ alts@(Alt _ _ rhs1 : alts')      -- Identity case+  | all identity_alt alts+  = do { tick (CaseIdentity case_bndr)+       ; return (mkTicks ticks $ re_cast scrut rhs1) }+  where+    ticks = concatMap (\(Alt _ _ rhs) -> stripTicksT tickishFloatable rhs) alts'+    identity_alt (Alt con args rhs) = check_eq rhs con args++    check_eq (Cast rhs co) con args        -- See Note [RHS casts]+      = not (any (`elemVarSet` tyCoVarsOfCo co) args) && check_eq rhs con args+    check_eq (Tick t e) alt args+      = tickishFloatable t && check_eq e alt args++    check_eq (Lit lit) (LitAlt lit') _     = lit == lit'+    check_eq (Var v) _ _  | v == case_bndr = True+    check_eq (Var v)   (DataAlt con) args+      | null arg_tys, null args            = v == dataConWorkId con+                                             -- Optimisation only+    check_eq rhs        (DataAlt con) args = cheapEqExpr' tickishFloatable rhs $+                                             mkConApp2 con arg_tys args+    check_eq _          _             _    = False++    arg_tys = tyConAppArgs (idType case_bndr)++        -- Note [RHS casts]+        -- ~~~~~~~~~~~~~~~~+        -- We've seen this:+        --      case e of x { _ -> x `cast` c }+        -- And we definitely want to eliminate this case, to give+        --      e `cast` c+        -- So we throw away the cast from the RHS, and reconstruct+        -- it at the other end.  All the RHS casts must be the same+        -- if (all identity_alt alts) holds.+        --+        -- Don't worry about nested casts, because the simplifier combines them++    re_cast scrut (Cast rhs co) = Cast (re_cast scrut rhs) co+    re_cast scrut _             = scrut++mkCase1 mode scrut bndr alts_ty alts = mkCase2 mode scrut bndr alts_ty alts+++--------------------------------------------------+--      2. Scrutinee Constant Folding+--         See Note [Scrutinee Constant Folding]+--------------------------------------------------++mkCase2 mode scrut bndr alts_ty alts+  | -- See Note [Scrutinee Constant Folding]+    case alts of+      [Alt DEFAULT _ _] -> isDeadBinder bndr -- see wrinkle 1+      _                 -> True+  , sm_case_folding mode+  , Just (scrut', tx_con, mk_orig) <- caseRules (smPlatform mode) scrut+  = do { bndr' <- newId (fsLit "lwild") ManyTy (exprType scrut')++       ; alts' <- mapMaybeM (tx_alt tx_con mk_orig bndr') alts+                  -- mapMaybeM: discard unreachable alternatives+                  -- See Note [Unreachable caseRules alternatives]+                  -- in GHC.Core.Opt.ConstantFold++       ; mkCase3 mode scrut' bndr' alts_ty $+         add_default (re_sort alts')+       }++  | otherwise+  = mkCase3 mode scrut bndr alts_ty alts+  where+    -- We need to keep the correct association between the scrutinee and its+    -- binder if the latter isn't dead. Hence we wrap rhs of alternatives with+    -- "let bndr = ... in":+    --+    --     case v + 10 of y        =====> case v of y'+    --        20      -> e1                 10      -> let y = 20      in e1+    --        DEFAULT -> e2                 DEFAULT -> let y = y' + 10 in e2+    --+    -- This wrapping is done in tx_alt; we use mk_orig, returned by caseRules,+    -- to construct an expression equivalent to the original one, for use+    -- in the DEFAULT case++    tx_alt :: (AltCon -> Maybe AltCon) -> (Id -> CoreExpr) -> Id+           -> CoreAlt -> SimplM (Maybe CoreAlt)+    tx_alt tx_con mk_orig new_bndr (Alt con bs rhs)+      = case tx_con con of+          Nothing   -> return Nothing+          Just con' -> do { bs' <- mk_new_bndrs new_bndr con'+                          ; return (Just (Alt con' bs' rhs')) }+      where+        rhs' | isDeadBinder bndr = rhs+             | otherwise         = bindNonRec bndr orig_val rhs++        orig_val = case con of+                      DEFAULT    -> mk_orig new_bndr+                      LitAlt l   -> Lit l+                      DataAlt dc -> mkConApp2 dc (tyConAppArgs (idType bndr)) bs++    mk_new_bndrs new_bndr (DataAlt dc)+      | not (isNullaryRepDataCon dc)+      = -- For non-nullary data cons we must invent some fake binders+        -- See Note [caseRules for dataToTag] in GHC.Core.Opt.ConstantFold+        do { us <- getUniquesM+           ; let (ex_tvs, arg_ids) = dataConRepInstPat us (idMult new_bndr) dc+                                        (tyConAppArgs (idType new_bndr))+           ; return (ex_tvs ++ arg_ids) }+    mk_new_bndrs _ _ = return []++    re_sort :: [CoreAlt] -> [CoreAlt]+    -- Sort the alternatives to re-establish+    -- GHC.Core Note [Case expression invariants]+    re_sort alts = sortBy cmpAlt alts++    add_default :: [CoreAlt] -> [CoreAlt]+    -- See Note [Literal cases]+    add_default (Alt (LitAlt {}) bs rhs : alts) = Alt DEFAULT bs rhs : alts+    add_default alts                            = alts++{- Note [Literal cases]+~~~~~~~~~~~~~~~~~~~~~~~+If we have+  case tagToEnum (a ># b) of+     False -> e1+     True  -> e2++then caseRules for TagToEnum will turn it into+  case tagToEnum (a ># b) of+     0# -> e1+     1# -> e2++Since the case is exhaustive (all cases are) we can convert it to+  case tagToEnum (a ># b) of+     DEFAULT -> e1+     1#      -> e2++This may generate slightly better code (although it should not, since+all cases are exhaustive) and/or optimise better.  I'm not certain that+it's necessary, but currently we do make this change.  We do it here,+NOT in the TagToEnum rules (see "Beware" in Note [caseRules for tagToEnum]+in GHC.Core.Opt.ConstantFold)+-}++--------------------------------------------------+--      Catch-all+--------------------------------------------------+mkCase3 _mode scrut bndr alts_ty alts+  = return (Case scrut bndr alts_ty alts)++-- See Note [Exitification] and Note [Do not inline exit join points] in+-- GHC.Core.Opt.Exitify+-- This lives here (and not in Id) because occurrence info is only valid on+-- InIds, so it's crucial that isExitJoinId is only called on freshly+-- occ-analysed code. It's not a generic function you can call anywhere.+isExitJoinId :: Var -> Bool+isExitJoinId id+  = isJoinId id+  && case idOccInfo id of+        OneOcc { occ_in_lam = IsInsideLam } -> True+        _                                   -> False++{-+Note [Dead binders]+~~~~~~~~~~~~~~~~~~~~+Note that dead-ness is maintained by the simplifier, so that it is+accurate after simplification as well as before.+ -}
GHC/Core/Opt/SpecConstr.hs view
@@ -1,2550 +1,2946 @@-{--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}--}----{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}--module GHC.Core.Opt.SpecConstr(-        specConstrProgram,-        SpecConstrAnnotation(..)-    ) where--import GHC.Prelude--import GHC.Driver.Session ( DynFlags(..), GeneralFlag( Opt_SpecConstrKeen )-                          , gopt, hasPprDebug )--import GHC.Core-import GHC.Core.Subst-import GHC.Core.Utils-import GHC.Core.Unfold-import GHC.Core.FVs     ( exprsFreeVarsList )-import GHC.Core.Opt.Monad-import GHC.Core.Opt.WorkWrap.Utils-import GHC.Core.DataCon-import GHC.Core.Coercion hiding( substCo )-import GHC.Core.Rules-import GHC.Core.Type     hiding ( substTy )-import GHC.Core.TyCon   (TyCon, tyConUnique, tyConName )-import GHC.Core.Multiplicity-import GHC.Core.Ppr     ( pprParendExpr )-import GHC.Core.Make    ( mkImpossibleExpr )--import GHC.Unit.Module-import GHC.Unit.Module.ModGuts--import GHC.Types.Literal ( litIsLifted )-import GHC.Types.Id-import GHC.Types.Var.Env-import GHC.Types.Var.Set-import GHC.Types.Name-import GHC.Types.Tickish-import GHC.Types.Basic-import GHC.Types.Demand-import GHC.Types.Cpr-import GHC.Types.Unique.Supply-import GHC.Types.Unique.FM--import GHC.Data.Maybe     ( orElse, catMaybes, isJust, isNothing )-import GHC.Data.Pair-import GHC.Data.FastString--import GHC.Utils.Misc-import GHC.Utils.Outputable-import GHC.Utils.Panic.Plain-import GHC.Utils.Panic-import GHC.Utils.Constants (debugIsOn)-import GHC.Utils.Monad-import GHC.Utils.Trace--import GHC.Builtin.Names ( specTyConKey )--import GHC.Exts( SpecConstrAnnotation(..) )-import GHC.Serialized   ( deserializeWithData )--import Control.Monad    ( zipWithM )-import Data.List (nubBy, sortBy, partition, dropWhileEnd, mapAccumL )-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 GHC.Core.Opt.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; #4448)-  * Only specialise on recursive types a finite number of times-        (see is_too_recursive; #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.)  #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.--------------------------------------------------------                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-      -- pprTraceM "specConstrInput" (ppr $ mg_binds guts)-      let binds' = reverse $ fst $ initUs us $ do-                    -- Note [Top-level recursive groups]-                    (env, binds) <- goEnv (initScEnv dflags this_mod annos)-                                          (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 #7865:--        let {-          a'_shr =-            case xs_af8 of _ {-              [] -> acc_af6;-              : ds_dgt [Dmd=<L,A>] ds_dgu [Dmd=<L,A>] ->-                (expensive x_af7, x_af7-            } } in-        let {-          ds_sht =-            case a'_shr of _ { (p'_afd, q'_afe) ->-            TSpecConstr_DoubleInline.recursive-              (GHC.Types.: @ GHC.Types.Int x_af7 wild_X6) (q'_afe, p'_afd)-            } } in--When processed knowing that xs_af8 was bound to a cons, we simplify to-   a'_shr = (expensive x_af7, x_af7)-and we do NOT want to inline that at the occurrence of a'_shr in ds_sht.-(There are other occurrences of a'_shr.)  No no no.--It would be possible to do some on-the-fly ANF-ising, so that a'_shr turned-into a work-free value again, thus-   a1 = expensive x_af7-   a'_shr = (a1, x_af7)-but that's more work, so until its shown to be important I'm going to-leave it for now.--Note [Making SpecConstr keener]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider this, in (perf/should_run/T9339)-   last (filter odd [1..1000])--After optimisation, including SpecConstr, we get:-   f :: Int# -> Int -> Int-   f x y = case remInt# x 2# of-             __DEFAULT -> case x of-                            __DEFAULT -> f (+# wild_Xp 1#) (I# x)-                            1000000# -> ...-             0# -> case x of-                     __DEFAULT -> f (+# wild_Xp 1#) y-                    1000000#   -> y--Not good!  We build an (I# x) box every time around the loop.-SpecConstr (as described in the paper) does not specialise f, despite-the call (f ... (I# x)) because 'y' is not scrutinised in the body.-But it is much better to specialise f for the case where the argument-is of form (I# x); then we build the box only when returning y, which-is on the cold path.--Another example:--   f x = ...(g x)....--Here 'x' is not scrutinised in f's body; but if we did specialise 'f'-then the call (g x) might allow 'g' to be specialised in turn.--So sc_keen controls whether or not we take account of whether argument is-scrutinised in the body.  True <=> ignore that, and specialise whenever-the function is applied to a data constructor.--}--data ScEnv = SCE { sc_dflags    :: DynFlags,-                   sc_uf_opts   :: !UnfoldingOpts, -- ^ Unfolding options-                   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 Name 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 "<Lambda>"------------------------initScEnv :: DynFlags -> Module -> UniqFM Name SpecConstrAnnotation -> ScEnv-initScEnv dflags this_mod anns-  = SCE { sc_dflags      = 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,-          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 (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--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 _  Nothing   = env-extendValEnv env id (Just cv)- | valueIsWorkFree cv      -- Don't duplicate work!!  #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) (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-  | Just ty' <- coreView ty = forceSpecArgTy env ty'--forceSpecArgTy env ty-  | Just (tycon, tys) <- splitTyConApp_maybe ty-  , tycon /= funTyCon-      = tyConUnique tycon == 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.--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-        ---        -- 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 (++)--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--{- 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 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 "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 Alt _ bs rhs = findAlt con alts-                                  `orElse` Alt 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' (Alt 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, Alt 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-                           -- See 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--        -- Specialized + original binding-        ; let spec_bnds = mkLets [NonRec b r | (b,r) <- ruleInfoBinds rhs_info specs] body'-        -- ; pprTraceM "spec_bnds" $ (ppr spec_bnds)--        ; return (body_usg { scu_calls = scu_calls body_usg `delVarEnv` bndr' }-                    `combineUsage` spec_usg,  -- Note [spec_usg includes rhs_usg]-                  spec_bnds-                  )-        }----- 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 (zipWithEqual "scExpr'" ruleInfoBinds rhs_infos specs))-                        -- zipWithEqual: length of returned [SpecInfo]-                        -- should be the same as incoming [RhsInfo]--        ; 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. <blah> in ...$j True...$j True...--Here $j is an arbitrary let-bound function, but it often comes up for-join points.  We might like to specialise $j for its call patterns.-Notice the difference from a letrec, where we look for call patterns-in the *RHS* of the function.  Here we look for call patterns in the-*body* of the let.--At one point I predicated this on the RHS mentioning the outer-recursive function, but that's not essential and might even be-harmful.  I'm not sure.--}--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 env body_usage (Rec prs)-  | Just threshold <- sc_size env-  , not force_spec-  , not (all (couldBeSmallEnoughToInline (sc_uf_opts 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-      = -- 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, 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 })-  | 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, 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 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)   -- 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, rule_number)-  | CP { cp_qvars = qvars, cp_args = pats, cp_strict_args = cbv_args } <- call_pat-  = do  { 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---      ; pprTrace "spec_one {" (vcat [ text "function:" <+> ppr fn <+> ppr (idUnique fn)---                                    , text "sc_count:" <+> ppr (sc_count env)---                                    , text "pats:" <+> ppr pats---                                    , text "-->" <+> ppr spec_name---                                    , text "bndrs" <+> ppr arg_bndrs---                                    , text "body" <+> ppr body---                                    , text "how_bound" <+> ppr (sc_how_bound env) ]) $---        return ()--        -- Specialise the body-        -- ; pprTraceM "body_subst_for" $ ppr (spec_occ) $$ ppr (sc_subst body_env)-        ; (spec_usg, spec_body) <- scExpr body_env body----      ; pprTrace "done spec_one }" (ppr fn $$ ppr (scu_calls spec_usg)) $---        return ()--                -- And build the results-        ; let spec_body_ty   = exprType spec_body-              (spec_lam_args1, spec_sig, spec_arity1, spec_join_arity1)-                  = calcSpecInfo fn call_pat extra_bndrs-                  -- Annotate the variables with the strictness information from-                  -- the function (see Note [Strictness information in worker binders])--              (spec_lam_args, spec_call_args, spec_arity, spec_join_arity)-                  | needsVoidWorkerArg fn arg_bndrs spec_lam_args1-                  , (spec_lam_args, spec_call_args, _) <- addVoidWorkerArg spec_lam_args1 []-                      -- needsVoidWorkerArg: usual w/w hack to avoid generating-                      -- a spec_rhs of unlifted type and no args.-                  , !spec_arity      <- spec_arity1 + 1-                  , !spec_join_arity <- fmap (+ 1) spec_join_arity1-                  = (spec_lam_args,  spec_call_args, spec_arity,  spec_join_arity)-                  | otherwise-                  = (spec_lam_args1, spec_lam_args1, spec_arity1, spec_join_arity1)--              spec_id    = asWorkerLikeId $-                           mkLocalId spec_name Many-                                     (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-              spec_rhs   = mkLams spec_lam_args (mkSeqs cbv_args spec_body_ty spec_body)-              rule_rhs   = mkVarApps (Var spec_id) $-                           dropTail (length extra_bndrs) spec_call_args-              inline_act = idInlineActivation fn-              this_mod   = sc_module 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 [SpecConstr and strict fields]-mkSeqs :: [Var] -> Type -> CoreExpr -> CoreExpr-mkSeqs seqees res_ty rhs =-  foldr addEval rhs seqees-    where-      addEval :: Var -> CoreExpr -> CoreExpr-      addEval arg_id rhs-        -- Argument representing strict field and it's worth passing via cbv-        | shouldStrictifyIdForCbv arg_id-        = Case (Var arg_id) arg_id res_ty ([Alt DEFAULT [] rhs])-        | otherwise-        = rhs---{- Note [SpecConst needs to add void args first]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider a function-    f start @t = e-We want to specialize for a partially applied call `f True`.-See also Note [SpecConstr call patterns], second Wrinkle.-Naively we would expect to get-    $sf @t = $se-    RULE: f True = $sf-The specialized function only takes a single type argument-so we add a void argument to prevent it from turning into-a thunk. See Note [Protecting the last value argument] for details-why. Normally we would add the void argument after the-type argument giving us:-    $sf :: forall t. Void# -> bla-    $sf @t void = $se-    RULE: f True = $sf void# (wrong)-But if you look closely this wouldn't typecheck!-If we substitute `f True` with `$sf void#` we expect the type argument to be applied first-but we apply void# first.-The easist fix seems to be just to add the void argument to the front of the arguments.-Now we get:-    $sf :: Void# -> forall t. bla-    $sf void @t = $se-    RULE: f True = $sf void#-And now we can substitute `f True` with `$sf void#` with everything working out nicely!--}--calcSpecInfo :: Id                     -- The original function-             -> CallPat                -- Call pattern-             -> [Var]                  -- Extra bndrs-             -> ( [Var]                     -- Demand-decorated binders-                , DmdSig                    -- Strictness of specialised thing-                , Arity, Maybe JoinArity )  -- Arities of specialised thing--- Calcuate bits of IdInfo for the specialised function--- See Note [Transfer strictness]--- See Note [Strictness information in worker binders]-calcSpecInfo fn (CP { cp_qvars = qvars, cp_args = pats }) extra_bndrs-  | isJoinId fn    -- Join points have strictness and arity for LHS only-  = ( bndrs_w_dmds-    , mkClosedDmdSig qvar_dmds div-    , count isId qvars-    , Just (length qvars) )-  | otherwise-  = ( bndrs_w_dmds-    , mkClosedDmdSig (qvar_dmds ++ extra_dmds) div-    , count isId qvars + count isId extra_bndrs-    , Nothing )-  where-    DmdSig (DmdType _ fn_dmds div) = idDmdSig fn--    val_pats   = filterOut isTypeArg pats -- value args at call sites, used to determine how many demands to drop-                                          -- from the original functions demand and for setting up dmd_env.-    qvar_dmds  = [ lookupVarEnv dmd_env qv `orElse` topDmd | qv <- qvars, isId qv ]-    extra_dmds = dropList val_pats fn_dmds--    bndrs_w_dmds =  set_dmds qvars       qvar_dmds-                 ++ set_dmds extra_bndrs extra_dmds--    set_dmds :: [Var] -> [Demand] -> [Var]-    set_dmds [] _   = []-    set_dmds vs  [] = vs  -- Run out of demands-    set_dmds (v:vs) ds@(d:ds') | isTyVar v = v                   : set_dmds vs ds-                               | otherwise = setIdDemandInfo v d : set_dmds vs ds'--    dmd_env = go emptyVarEnv fn_dmds val_pats--    go :: DmdEnv -> [Demand] -> [CoreExpr] -> DmdEnv-    -- 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 :: DmdEnv -> Demand -> CoreExpr -> DmdEnv-    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, 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 callToPats.--* The list of argument patterns can certainly be shorter than the-  lambdas in the function definition (under-saturated).  For example-      f x y = case x of { True -> e1; False -> e2 }-      ....map (f True) e...-  We want to specialise `f` for `f True`.--* In fact we deliberately shrink the list of argument patterns,-  cp_args, by trimming off all the boring ones at the end (see-  `dropWhileEnd is_boring` in callToPats).  Since the RULE only-  applies when it is saturated, this shrinking makes the RULE more-  applicable.  But it does mean that the argument patterns do not-  necessarily saturate the lambdas of the function.--* It's important that the pattern arguments do not look like-     e |> Refl-  or-    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 |> co)) ...--where 'co' is a coercion variable not in scope at f's definition site.-If we aren't careful we'll get--    let $sf a co = e (K @(a |> co))-        RULE "SC:f" forall a co.  f (K @(a |> co)) = $sf a co-        f = e-    in ...--But alas, when we match the call we won't bind 'co', because type-matching-(for good reasons) discards casts).--I don't know how to solve this, so for now I'm just discarding any-call patterns that-  * Mentions a coercion variable in a type argument-  * That is not in scope at the binding of the function--I think this is very rare.--It is important (e.g. #14936) that this /only/ applies to-coercions mentioned in casts.  We don't want to be discombobulated-by casts in terms!  For example, consider-   f ((e1,e2) |> sym co)-where, say,-   f  :: Foo -> blah-   co :: Foo ~R (Int,Int)--Here we definitely do want to specialise for that pair!  We do not-match on the structure of the coercion; instead we just match on a-coercion variable, so the RULE looks like--   forall (x::Int, y::Int, co :: (Int,Int) ~R Foo)-     f ((x,y) |> co) = $sf x y co--Often the body of f looks like-   f arg = ...(case arg |> co' of-                (x,y) -> blah)...--so that the specialised f will turn into-   $sf x y co = let arg = (x,y) |> co-                in ...(case arg>| co' of-                         (x,y) -> blah)....--which will simplify to not use 'co' at all.  But we can't guarantee-that co will end up unused, so we still pass it.  Absence analysis-may remove it later.--Note that this /also/ discards the call pattern if we have a cast in a-/term/, although in fact Rules.match does make a very flaky and-fragile attempt to match coercions.  e.g. a call like-    f (Maybe Age) (Nothing |> co) blah-    where co :: Maybe Int ~ Maybe Age-will be discarded.  It's extremely fragile to match on the form of a-coercion, so I think it's better just not to try.  A more complicated-alternative would be to discard calls that mention coercion variables-only in kind-casts, but I'm doing the simple thing for now.--}--data CallPat = CP { cp_qvars :: [Var]           -- Quantified variables-                  , cp_args  :: [CoreExpr]      -- Arguments-                  , cp_strict_args :: [Var] }   -- Arguments we want to pass unlifted even if they are boxed-     -- See Note [SpecConstr call patterns]--instance Outputable CallPat where-  ppr (CP { cp_qvars = qvars, cp_args = args, cp_strict_args =  strict })-    = text "CP" <> braces (sep [ text "cp_qvars =" <+> ppr qvars <> comma-                               , text "cp_args =" <+> ppr args-                               , text "cp_strict_args = " <> ppr strict ])--callsToNewPats :: ScEnv -> Id-               -> SpecInfo-               -> [ArgOcc] -> [Call]-               -> 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-              max_args = maxWorkerArgs (sc_dflags env)-              too_big (CP { cp_qvars = vars, cp_args = args })-                = not (isWorkerSmallEnough max_args (valArgCount args) vars)-                  -- We are about to construct w/w pair in 'spec_one'.-                  -- Omit specialisation leading to high arity workers.-                  -- See Note [Limit w/w arity] in GHC.Core.Opt.WorkWrap.Utils--                -- Discard specialisations if there are too many of them-              (pats_were_discarded, trimmed_pats) = trim_pats env fn spec_info small_pats----        ; pprTrace "callsToPats" (vcat [ text "calls to" <+> ppr fn <> colon <+> ppr calls---                                       , text "done_specs:" <+> ppr (map os_pat done_specs)---                                       , text "good_pats:" <+> ppr good_pats ]) $---          return ()--        ; return (have_boring_call || pats_were_discarded, trimmed_pats) }-          -- If any of the calls does not give rise to a specialisation, either-          -- because it is boring, or because there are too many specialisations,-          -- return a flag to say so, so that we know to keep the original function.---trim_pats :: ScEnv -> Id -> SpecInfo -> [CallPat] -> (Bool, [CallPat])--- True <=> some patterns were discarded--- See Note [Choosing patterns]-trim_pats env fn (SI { si_n_specs = done_spec_count }) pats-  | sc_force env-    || isNothing mb_scc-    || n_remaining >= n_pats-  = -- pprTrace "trim_pats: no-trim" (ppr (sc_force env) $$ ppr mb_scc $$ ppr n_remaining $$ ppr n_pats)-    (False, pats)          -- No need to trim--  | otherwise-  = emit_trace $  -- Need to trim, so keep the best ones-    (True, 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 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 result-       | debugIsOn || hasPprDebug (sc_dflags env)-         -- Suppress this scary message for ordinary users!  #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 "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) ]---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@(Call fn args con_env)-  = do  { let in_scope = substInScope (sc_subst env)--        ; arg_tripples <- zipWith3M (argToPat env in_scope con_env) args bndr_occs (map (const NotMarkedStrict) args)-                   -- This zip trims the args to be no longer than-                   -- the lambdas in the function definition (bndr_occs)--          -- Drop boring patterns from the end-          -- See Note [SpecConstr call patterns]-        ; let arg_tripples' | isJoinId fn = arg_tripples-                            | otherwise   = dropWhileEnd is_boring arg_tripples-              is_boring (interesting, _,_) = not interesting-              (interesting_s, pats, cbv_ids) = unzip3 arg_tripples'-              interesting           = or interesting_s--        ; let pat_fvs = exprsFreeVarsList pats-                -- To get determinism we need the list of free variables in-                -- deterministic order. Otherwise we end up creating-                -- 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] at the top--              (ktvs, ids)   = partition isTyVar qvars-              qvars'        = scopedSort 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   = updateIdTypeAndMult expandTypeSynonyms id-                -- See Note [Free type variables of the qvar types]--              -- Bad coercion variables: see Note [SpecConstr and casts]-              bad_covars :: CoVarSet-              bad_covars = mapUnionVarSet get_bad_covars pats-              get_bad_covars :: CoreArg -> CoVarSet-              get_bad_covars (Type ty) = filterVarSet bad_covar (tyCoVarsOfType ty)-              get_bad_covars _         = emptyVarSet-              bad_covar v = isId v && not (is_in_scope v)--        ; -- pprTrace "callToPats"  (ppr args $$ ppr bndr_occs) $-          warnPprTrace (not (isEmptyVarSet bad_covars))-              "SpecConstr: bad covars"-              (ppr bad_covars $$ ppr call) $-          if interesting && isEmptyVarSet bad_covars-          then-              -- pprTraceM "callToPatsOut" (-              --   text "fun" <> ppr fn $$-              --   ppr (CP { cp_qvars = qvars', cp_args = pats })) >>-              return (Just (CP { cp_qvars = qvars', cp_args = pats, cp_strict_args = concat cbv_ids }))-          else return Nothing }--    -- argToPat takes an actual argument, and returns an abstracted-    -- 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.--{- 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--}--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 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), strict_args) } }-  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-argToPat1 env in_scope val_env arg arg_occ _arg_str-  | Just (ConVal (DataAlt dc) args) <- isValue val_env arg-  , not (ignoreDataCon env dc)        -- See Note [NoSpecConstr]-  , Just arg_occs <- mb_scrut dc-  = do { let (ty_args, rest_args) = splitAtList (dataConUnivTyVars dc) args-             con_str, matched_str :: [StrictnessMark]-             -- con_str corrresponds 1-1 with the /value/ arguments-             -- matched_str corresponds 1-1 with /all/ arguments-             con_str = dataConRepStrictness dc-             matched_str = match_vals con_str rest_args-      --  ; pprTraceM "bangs" (ppr (length rest_args == length con_str) $$-      --       ppr dc $$-      --       ppr con_str $$-      --       ppr rest_args $$-      --       ppr (map isTypeArg rest_args))-       ; prs <- zipWith3M (argToPat env in_scope val_env) rest_args arg_occs matched_str-       ; let args' = map sndOf3 prs :: [CoreArg]-       ; assertPpr (length con_str == length (filter isRuntimeArg rest_args))-            ( ppr con_str $$ ppr rest_args $$-              ppr (length con_str) $$ ppr (length rest_args)-            ) $ return ()-       ; return (True, mkConApp dc (ty_args ++ args'), concat (map thdOf3 prs)) }-  where-    mb_scrut dc = case arg_occ of-                ScrutOcc bs | Just occs <- lookupUFM bs dc-                            -> Just (occs)  -- See Note [Reboxing]-                _other      | sc_force env || sc_keen env-                            -> Just (repeat UnkOcc)-                            | otherwise-                            -> Nothing-    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 || case arg_occ of { ScrutOcc {} -> True-                                    ; UnkOcc      -> False-                                    ; NoOcc       -> False } -- (a)-  , is_value                                                 -- (b)-       -- Ignoring sc_keen here to avoid gratuitously incurring Note [Reboxing]-       -- So sc_keen focused just on f (I# x), where we have freshly-allocated-       -- box that we can eliminate in the caller-  , not (ignoreType env (varType v))-  -- 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--  -- 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") Many ty-       -- ; pprTraceM "wildCardPat" (ppr id' <+> ppr (idUnfolding id'))-       ; return (False, varToCoreExpr id, if isMarkedStrict str then [id] else []) }--isValue :: ValueEnv -> CoreExpr -> Maybe Value-isValue _env (Lit lit)-  | 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 (CP { cp_qvars = vs1, cp_args = as1 })-        (CP { cp_qvars = vs2, cp_args = as2 })-  = all2 same as1 as2-  where-    -- If the args are the same, their strictness marks will be too so we don't compare those.-    same (Var v1) (Var v2)-        | v1 `elem` vs1 = v2 `elem` vs2-        | v2 `elem` vs2 = False-        | 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 = warnPprTrace (bad e1 || bad e2) "samePat" (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.+{-# LANGUAGE LambdaCase #-}+{-+ToDo [Oct 2013]+~~~~~~~~~~~~~~~+1. Nuke ForceSpecConstr for good (it is subsumed by GHC.Types.SPEC in ghc-prim)+2. Nuke NoSpecConstr+++(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++\section[SpecConstr]{Specialise over constructors}+-}++module GHC.Core.Opt.SpecConstr(+        specConstrProgram,+        SpecConstrAnnotation(..),+        SpecFailWarning(..)+    ) where++import GHC.Prelude++import GHC.Driver.DynFlags ( DynFlags(..), GeneralFlag( Opt_SpecConstrKeen )+                          , gopt, hasPprDebug )++import GHC.Core+import GHC.Core.Subst+import GHC.Core.Utils+import GHC.Core.Unfold+import GHC.Core.Opt.Simplify.Inline+import GHC.Core.FVs     ( exprsFreeVarsList, exprFreeVars )+import GHC.Core.Opt.Monad+import GHC.Core.Opt.WorkWrap.Utils+import GHC.Core.Opt.OccurAnal( BinderSwapDecision(..), scrutOkForBinderSwap )+import GHC.Core.DataCon+import GHC.Core.Class( classTyVars )+import GHC.Core.Coercion hiding( substCo )+import GHC.Core.Rules+import GHC.Core.Predicate ( scopedSort, typeDeterminesValue )+import GHC.Core.Type     hiding ( substTy )+import GHC.Core.TyCon   (TyCon, tyConName )+import GHC.Core.Multiplicity+import GHC.Core.Ppr     ( pprParendExpr )+import GHC.Core.Make    ( mkImpossibleExpr )++import GHC.Unit.Module+import GHC.Unit.Module.ModGuts++import GHC.Types.Error (MessageClass(..), Severity(..), DiagnosticReason(WarningWithoutFlag), ResolvedDiagnosticReason (..))+import GHC.Types.Literal ( litIsLifted )+import GHC.Types.Id+import GHC.Types.Id.Info ( IdDetails(..) )+import GHC.Types.Id.Make ( voidArgId, voidPrimId )+import GHC.Types.Var.Env+import GHC.Types.Var.Set+import GHC.Types.Name+import GHC.Types.Tickish+import GHC.Types.Basic+import GHC.Types.Demand+import GHC.Types.Cpr+import GHC.Types.Unique.Supply+import GHC.Types.Unique.FM+import GHC.Types.Unique( hasKey )++import GHC.Data.Maybe     ( fromMaybe, orElse, catMaybes, isJust, isNothing )+import GHC.Data.FastString++import GHC.Utils.Misc+import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Utils.Constants (debugIsOn)+import GHC.Utils.Monad++import GHC.Builtin.Names ( specTyConKey )++import GHC.Exts( SpecConstrAnnotation(..) )+import GHC.Serialized   ( deserializeWithData )++import Control.Monad+import Data.List ( sortBy, partition, dropWhileEnd, mapAccumL )+import Data.List.NonEmpty ( NonEmpty (..) )+import Data.Maybe( mapMaybe )+import Data.Ord( comparing )+import Data.Tuple++{-+-----------------------------------------------------+                        Game plan+-----------------------------------------------------++Consider+        drop n []     = []+        drop 0 xs     = []+        drop n (x:xs) = drop (n-1) xs++After the first time round, we could pass n unboxed.  This happens in+numerical code too.  Here's what it looks like in Core:++        drop n xs = case xs of+                      []     -> []+                      (y:ys) -> case n of+                                  I# n# -> case n# of+                                             0 -> []+                                             _ -> drop (I# (n# -# 1#)) xs++Notice that the recursive call has an explicit constructor as argument.+Noticing this, we can make a specialised version of drop++        RULE: drop (I# n#) xs ==> drop' n# xs++        drop' n# xs = let n = I# n# in ...orig RHS...++Now the simplifier will apply the specialisation in the rhs of drop', giving++        drop' n# xs = case xs of+                      []     -> []+                      (y:ys) -> case n# of+                                  0 -> []+                                  _ -> drop' (n# -# 1#) xs++Much better!++We'd also like to catch cases where a parameter is carried along unchanged,+but evaluated each time round the loop:++        f i n = if i>0 || i>n then i else f (i*2) n++Here f isn't strict in n, but we'd like to avoid evaluating it each iteration.+In Core, by the time we've w/wd (f is strict in i) we get++        f i# n = case i# ># 0 of+                   False -> I# i#+                   True  -> case n of { I# n# ->+                            case i# ># n# of+                                False -> I# i#+                                True  -> f (i# *# 2#) n++At the call to f, we see that the argument, n is known to be (I# n#),+and n is evaluated elsewhere in the body of f, so we can play the same+trick as above.+++Note [Reboxing]+~~~~~~~~~~~~~~~+We must be careful not to allocate the same constructor twice.  Consider+        f p = (...(case p of (a,b) -> e)...p...,+               ...let t = (r,s) in ...t...(f t)...)+At the recursive call to f, we can see that t is a pair.  But we do NOT want+to make a specialised copy:+        f' a b = let p = (a,b) in (..., ...)+because now t is allocated by the caller, then r and s are passed to the+recursive call, which allocates the (r,s) pair again.++This happens if+  (a) the argument p is used in other than a case-scrutinisation way.+  (b) the argument to the call is not a 'fresh' tuple; you have to+        look into its unfolding to see that it's a tuple++Hence the "OR" part of Note [Good arguments] below.++ALTERNATIVE 2: pass both boxed and unboxed versions.  This no longer saves+allocation, but does perhaps save evals. In the RULE we'd have+something like++  f (I# x#) = f' (I# x#) x#++If at the call site the (I# x) was an unfolding, then we'd have to+rely on CSE to eliminate the duplicate allocation.... This alternative+doesn't look attractive enough to pursue.++ALTERNATIVE 3: ignore the reboxing problem.  The trouble is that+the conservative reboxing story prevents many useful functions from being+specialised.  Example:+        foo :: Maybe Int -> Int -> Int+        foo   (Just m) 0 = 0+        foo x@(Just m) n = foo x (n-m)+Here the use of 'x' will clearly not require boxing in the specialised function.++The strictness analyser has the same problem, in fact.  Example:+        f p@(a,b) = ...+If we pass just 'a' and 'b' to the worker, it might need to rebox the+pair to create (a,b).  A more sophisticated analysis might figure out+precisely the cases in which this could happen, but the strictness+analyser does no such analysis; it just passes 'a' and 'b', and hopes+for the best.++So my current choice is to make SpecConstr similarly aggressive, and+ignore the bad potential of reboxing.+++Note [Good arguments]+~~~~~~~~~~~~~~~~~~~~~+So we look for++* A self-recursive function.  Ignore mutual recursion for now,+  because it's less common, and the code is simpler for self-recursion.++* EITHER++   a) At a recursive call, one or more parameters is an explicit+      constructor application+        AND+      That same parameter is scrutinised by a case somewhere in+      the RHS of the function++  OR++    b) At a recursive call, one or more parameters has an unfolding+       that is an explicit constructor application+        AND+      That same parameter is scrutinised by a case somewhere in+      the RHS of the function+        AND+      Those are the only uses of the parameter (see Note [Reboxing])+++What to abstract over+~~~~~~~~~~~~~~~~~~~~~+There's a bit of a complication with type arguments.  If the call+site looks like++        f p = ...f ((:) [a] x xs)...++then our specialised function look like++        f_spec x xs = let p = (:) [a] x xs in ....as before....++This only makes sense if either+  a) the type variable 'a' is in scope at the top of f, or+  b) the type variable 'a' is an argument to f (and hence fs)++Actually, (a) may hold for value arguments too, in which case+we may not want to pass them.  Suppose 'x' is in scope at f's+defn, but xs is not.  Then we'd like++        f_spec xs = let p = (:) [a] x xs in ....as before....++Similarly (b) may hold too.  If x is already an argument at the+call, no need to pass it again.++Finally, if 'a' is not in scope at the call site, we could abstract+it as we do the term variables:++        f_spec a x xs = let p = (:) [a] x xs in ...as before...++So the grand plan is:++        * abstract the call site to a constructor-only pattern+          e.g.  C x (D (f p) (g q))  ==>  C s1 (D s2 s3)++        * Find the free variables of the abstracted pattern++        * Pass these variables, less any that are in scope at+          the fn defn.  But see Note [Shadowing in SpecConstr] below.+++NOTICE that we only abstract over variables that are not in scope,+so we're in no danger of shadowing variables used in "higher up"+in f_spec's RHS.+++Note [Shadowing in SpecConstr]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In this pass we gather up usage information that may mention variables+that are bound between the usage site and the definition site; or (more+seriously) may be bound to something different at the definition site.+For example:++        f x = letrec g y v = let x = ...+                             in ...(g (a,b) x)...++Since 'x' is in scope at the call site, we may make a rewrite rule that+looks like+        RULE forall a,b. g (a,b) x = ...+But this rule will never match, because it's really a different 'x' at+the call site -- and that difference will be manifest by the time the+simplifier gets to it.  [A worry: the simplifier doesn't *guarantee*+no-shadowing, so perhaps it may not be distinct?]++Anyway, the rule isn't actually wrong, it's just not useful.  One possibility+is to run deShadowBinds before running SpecConstr, but instead we run the+simplifier.  That gives the simplest possible program for SpecConstr to+chew on; and it virtually guarantees no shadowing.++Note [Specialising for constant parameters]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+This one is about specialising on a *constant* (but not necessarily+constructor) argument++    foo :: Int -> (Int -> Int) -> Int+    foo 0 f = 0+    foo m f = foo (f m) (+1)++It produces++    lvl_rmV :: GHC.Base.Int -> GHC.Base.Int+    lvl_rmV =+      \ (ds_dlk :: GHC.Base.Int) ->+        case ds_dlk of wild_alH { GHC.Base.I# x_alG ->+        GHC.Base.I# (GHC.Prim.+# x_alG 1)++    T.$wfoo :: GHC.Prim.Int# -> (GHC.Base.Int -> GHC.Base.Int) ->+    GHC.Prim.Int#+    T.$wfoo =+      \ (ww_sme :: GHC.Prim.Int#) (w_smg :: GHC.Base.Int -> GHC.Base.Int) ->+        case ww_sme of ds_Xlw {+          __DEFAULT ->+        case w_smg (GHC.Base.I# ds_Xlw) of w1_Xmo { GHC.Base.I# ww1_Xmz ->+        T.$wfoo ww1_Xmz lvl_rmV+        };+          0 -> 0+        }++The recursive call has lvl_rmV as its argument, so we could create a specialised copy+with that argument baked in; that is, not passed at all.   Now it can perhaps be inlined.++When is this worth it?  Call the constant 'lvl'+- If 'lvl' has an unfolding that is a constructor, see if the corresponding+  parameter is scrutinised anywhere in the body.++- If 'lvl' has an unfolding that is a inlinable function, see if the corresponding+  parameter is applied (...to enough arguments...?)++  Also do this is if the function has RULES?++Also++Note [Specialising for lambda parameters]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+    foo :: Int -> (Int -> Int) -> Int+    foo 0 f = 0+    foo m f = foo (f m) (\n -> n-m)++This is subtly different from the previous one in that we get an+explicit lambda as the argument:++    T.$wfoo :: GHC.Prim.Int# -> (GHC.Base.Int -> GHC.Base.Int) ->+    GHC.Prim.Int#+    T.$wfoo =+      \ (ww_sm8 :: GHC.Prim.Int#) (w_sma :: GHC.Base.Int -> GHC.Base.Int) ->+        case ww_sm8 of ds_Xlr {+          __DEFAULT ->+        case w_sma (GHC.Base.I# ds_Xlr) of w1_Xmf { GHC.Base.I# ww1_Xmq ->+        T.$wfoo+          ww1_Xmq+          (\ (n_ad3 :: GHC.Base.Int) ->+             case n_ad3 of wild_alB { GHC.Base.I# x_alA ->+             GHC.Base.I# (GHC.Prim.-# x_alA ds_Xlr)+             })+        };+          0 -> 0+        }++I wonder if SpecConstr couldn't be extended to handle this? After all,+lambda is a sort of constructor for functions and perhaps it already+has most of the necessary machinery?++Furthermore, there's an immediate win, because you don't need to allocate the lambda+at the call site; and if perchance it's called in the recursive call, then you+may avoid allocating it altogether.  Just like for constructors.++Looks cool, but probably rare...but it might be easy to implement.+++Note [SpecConstr for casts]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+    data family T a :: *+    data instance T Int = T Int++    foo n = ...+       where+         go (T 0) = 0+         go (T n) = go (T (n-1))++The recursive call ends up looking like+        go (T (I# ...) `cast` g)+So we want to spot the constructor application inside the cast.+That's why we have the Cast case in argToPat++Note [Seeding recursive groups]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For a recursive group that is either+  * nested, or+  * top-level, but with no exported Ids+we can see all the calls to the function, so we seed the specialisation+loop from the calls in the body, and /not/ from the calls in the RHS.+Consider:++  bar m n = foo n (n,n) (n,n) (n,n) (n,n)+   where+     foo n p q r s+       | n == 0    = m+       | n > 3000  = case p of { (p1,p2) -> foo (n-1) (p2,p1) q r s }+       | n > 2000  = case q of { (q1,q2) -> foo (n-1) p (q2,q1) r s }+       | n > 1000  = case r of { (r1,r2) -> foo (n-1) p q (r2,r1) s }+       | otherwise = case s of { (s1,s2) -> foo (n-1) p q r (s2,s1) }++If we start with the RHSs of 'foo', we get lots and lots of specialisations,+most of which are not needed.  But if we start with the (single) call+in the rhs of 'bar' we get exactly one fully-specialised copy, and all+the recursive calls go to this fully-specialised copy. Indeed, the original+function is later collected as dead code.  This is very important in+specialising the loops arising from stream fusion, for example in NDP where+we were getting literally hundreds of (mostly unused) specialisations of+a local function.++In a case like the above we end up never calling the original un-specialised+function.  (Although we still leave its code around just in case.)++Wrinkles++* Boring calls. If we find any boring calls in the body, including+  *unsaturated* ones, such as+      letrec foo x y = ....foo...+      in map foo xs+  then we will end up calling the un-specialised function, so then we+  *should* use the calls in the un-specialised RHS as seeds.  We call+  these "boring call patterns", and callsToNewPats reports if it finds+  any of these.  Then 'specialise' unleashes the usage info from the+  un-specialised RHS.++* Exported Ids. `specialise` /also/ unleashes `si_mb_unspec`+  for exported Ids.  That way we are sure to generate usage info from+  the /un-specialised/ RHS of an exported function.++More precisely:++* Always start from the calls in the body of the let or (for top level)+  calls in the rest of the module.  See the body_calls in the call to+  `specialise` in `specNonRec`, and to `go` in `specRec`.++* si_mb_unspec holds the usage from the unspecialised RHS.+  See `initSpecInfo`.++* `specialise` will unleash si_mb_unspec, if+  - `callsToNewPats` reports "boring calls found", or+  - this is a top-level exported Id.++Historical note.  At an earlier point, if a top-level Id was exported,+we used only seeds from the RHS, and /not/from the body. But Dimitrios+had an example where using call patterns from the body (the other defns+in the module) was crucial.  And doing so improved nofib allocation results:+    multiplier: 4%   better+    minimax:    2.8% better+In any case, it is easier to do!++Note [Do not specialise diverging functions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Specialising a function that just diverges is a waste of code.+Furthermore, it broke GHC (simpl014) thus:+   {-# STR Sb #-}+   f = \x. case x of (a,b) -> f x+If we specialise f we get+   f = \x. case x of (a,b) -> fspec a b+But fspec doesn't have decent strictness info.  As it happened,+(f x) :: IO t, so the state hack applied and we eta expanded fspec,+and hence f.  But now f's strictness is less than its arity, which+breaks an invariant.+++Note [Forcing specialisation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+With stream fusion and in other similar cases, we want to fully+specialise some (but not necessarily all!) loops regardless of their+size and the number of specialisations.++We allow a library to do this, in one of two ways (one which is+deprecated):++  1) Add a parameter of type GHC.Types.SPEC (from ghc-prim) to the loop body.++  2) (Deprecated) Annotate a type with ForceSpecConstr from GHC.Exts,+     and then add *that* type as a parameter to the loop body++The reason #2 is deprecated is because it requires GHCi, which isn't+available for things like a cross compiler using stage1.++Here's a (simplified) example from the `vector` package. You may bring+the special 'force specialization' type into scope by saying:++  import GHC.Types (SPEC(..))++or by defining your own type (again, deprecated):++  data SPEC = SPEC | SPEC2+  {-# ANN type SPEC ForceSpecConstr #-}++(Note this is the exact same definition of GHC.Types.SPEC, just+without the annotation.)++After that, you say:++  foldl :: (a -> b -> a) -> a -> Stream b -> a+  {-# INLINE foldl #-}+  foldl f z (Stream step s _) = foldl_loop SPEC z s+    where+      foldl_loop !sPEC z s = case step s of+                              Yield x s' -> foldl_loop sPEC (f z x) s'+                              Skip       -> foldl_loop sPEC z s'+                              Done       -> z++SpecConstr will spot the SPEC parameter and always fully specialise+foldl_loop. Note that++  * We have to prevent the SPEC argument from being removed by+    w/w which is why (a) SPEC is a sum type, and (b) we have to seq on+    the SPEC argument.++  * And lastly, the SPEC argument is ultimately eliminated by+    SpecConstr itself so there is no runtime overhead.++This is all quite ugly; we ought to come up with a better design.++ForceSpecConstr arguments are spotted in scExpr' and scTopBinds which then set+sc_force to True when calling specLoop. This flag does four things:++(FS1) Ignore specConstrThreshold, to specialise functions of arbitrary size+        (see scTopBind)+(FS2) Ignore specConstrCount, to make arbitrary numbers of specialisations+        (see specialise)+(FS3) Specialise even for arguments that are not scrutinised in the loop+        (see argToPat; #4448)+(FS4) Only specialise on recursive types a finite number of times+        (see sc_recursive; #5550; Note [Limit recursive specialisation])+(FS5) Use a different restriction on the maximum number of arguments which+        the optimisation will specialise. We tried removing the limit on worker+        args for forced specs (#14003) but this caused issues when specializing+        code for large data structures (#25197).+        This is handled by `too_many_worker_args` in `callsToNewPats`++The flag holds only for specialising a single binding group, and NOT+for nested bindings.  (So really it should be passed around explicitly+and not stored in ScEnv.)  #14379 turned out to be caused by+   f SPEC x = let g1 x = ...+              in ...+We force-specialise f (because of the SPEC), but that generates a specialised+copy of g1 (as well as the original).  Alas g1 has a nested binding g2; and+in each copy of g1 we get an unspecialised and specialised copy of g2; and so+on. Result, exponential.  So the force-spec flag now only applies to one+level of bindings at a time.++Mechanism for this one-level-only thing:++ - Switch it on at the call to specRec, in scExpr and scTopBinds+ - Switch it off when doing the RHSs;+   this can be done very conveniently in decreaseSpecCount++What alternatives did I consider?++* Annotating the loop itself doesn't work because (a) it is local and+  (b) it will be w/w'ed and having w/w propagating annotations somehow+  doesn't seem like a good idea. The types of the loop arguments+  really seem to be the most persistent thing.++* Annotating the types that make up the loop state doesn't work,+  either, because (a) it would prevent us from using types like Either+  or tuples here, (b) we don't want to restrict the set of types that+  can be used in Stream states and (c) some types are fixed by the+  user (e.g., the accumulator here) but we still want to specialise as+  much as possible.++Alternatives to ForceSpecConstr+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Instead of giving the loop an extra argument of type SPEC, we+also considered *wrapping* arguments in SPEC, thus+  data SPEC a = SPEC a | SPEC2++  loop = \arg -> case arg of+                     SPEC state ->+                        case state of (x,y) -> ... loop (SPEC (x',y')) ...+                        S2 -> error ...+The idea is that a SPEC argument says "specialise this argument+regardless of whether the function case-analyses it".  But this+doesn't work well:+  * SPEC must still be a sum type, else the strictness analyser+    eliminates it+  * But that means that 'loop' won't be strict in its real payload+This loss of strictness in turn screws up specialisation, because+we may end up with calls like+   loop (SPEC (case z of (p,q) -> (q,p)))+Without the SPEC, if 'loop' were strict, the case would move out+and we'd see loop applied to a pair. But if 'loop' isn't strict+this doesn't look like a specialisable call.++Note [Limit recursive specialisation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It is possible for ForceSpecConstr to cause an infinite loop of specialisation.+Because there is no limit on the number of specialisations, a recursive call with+a recursive constructor as an argument (for example, list cons) will generate+a specialisation for that constructor. If the resulting specialisation also+contains a recursive call with the constructor, this could proceed indefinitely.++For example, if ForceSpecConstr is on:+  loop :: [Int] -> [Int] -> [Int]+  loop z []         = z+  loop z (x:xs)     = loop (x:z) xs+this example will create a specialisation for the pattern+  loop (a:b) c      = loop' a b c++  loop' a b []      = (a:b)+  loop' a b (x:xs)  = loop (x:(a:b)) xs+and a new pattern is found:+  loop (a:(b:c)) d  = loop'' a b c d+which can continue indefinitely.++Roman's suggestion to fix this was to stop after a couple of times on recursive types,+but still specialising on non-recursive types as much as possible.++To implement this, we count the number of times we have gone round the+"specialise recursively" loop ('go' in 'specRec').  Once have gone round+more than N times (controlled by -fspec-constr-recursive=N) we check++  - If sc_force is off, and sc_count is (Just max) then we don't+    need to do anything: trim_pats will limit the number of specs++  - Otherwise check if any function has now got more than (sc_count env)+    specialisations.  If sc_count is "no limit" then we arbitrarily+    choose 10 as the limit (ugh).++See #5550.   Also #13623, where this test had become over-aggressive,+and we lost a wonderful specialisation that we really wanted!++Note [NoSpecConstr]+~~~~~~~~~~~~~~~~~~~+The ignoreDataCon stuff allows you to say+    {-# ANN type T NoSpecConstr #-}+to mean "don't specialise on arguments of this type".  It was added+before we had ForceSpecConstr.  Lacking ForceSpecConstr we specialised+regardless of size; and then we needed a way to turn that *off*.  Now+that we have ForceSpecConstr, this NoSpecConstr is probably redundant.+(Used only for PArray, TODO: remove?)++Note [SpecConstr and strict fields]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We treat strict fields in SpecConstr the same way we do in W/W.+That is we make the specialized function strict in arguments+representing strict fields. See Note [Call-by-value for worker args]+for why we do this.++(SCF1) The arg_id might be an /imported/ Id like M.foo_acf (see #24944).+  We don't want to make+     case M.foo_acf of M.foo_acf { DEFAULT -> blah }+  because the binder of a case-expression should never be imported.  Rather,+  we must localise it thus:+     case M.foo_acf of foo_acf { DEFAULT -> blah }+  We keep the same unique, so in the next round of simplification we'll replace+  any M.foo_acf's in `blah` by `foo_acf`.++  c.f. Note [Localise pattern binders] in GHC.HsToCore.Utils.++Note [Specialising on dictionaries]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In #21386, SpecConstr saw this call:++   $wgo 100# @.. ($fMonadStateT @.. @.. $fMonadIdentity)++where $wgo :: Int# -> forall m. Monad m => blah++You might think that the type-class Specialiser would have specialised+this, but there are good reasons why not: the Specialiser ran too early.+But regardless, SpecConstr can and should!  It's easy:++* isValue: treat ($fblah d1 .. dn)+  like a constructor application.++* scApp: treat (op_sel d), a class method selection,+  like a case expression++* Float that dictionary application to top level, thus+    lvl = $fMonadStateT @.. @.. $fMonadIdentity+  so the call looks like+    ($wgo 100# @.. lvl)++  Why? This way dictionaries will appear as top level binders which we+  can trivially match in rules.  (CSE runs before SpecConstr, so we+  may hope to common-up duplicate top-level dictionaries.)+  For the floating part, see the "Arguments" case of Note+  [Floating to the top] in GHC.Core.Opt.SetLevels.++  We could be more clever, perhaps, and generate a RULE like+     $wgo _  @.. ($fMonadStateT @.. @.. $fMonadIdentity) = $s$wgo ...+  but that would mean making argToPat able to spot dfun applications as+  well as constructor applications.++Wrinkles:++* This should all work perfectly fine for newtype classes.  Mind you,+  currently newtype classes are inlined fairly agressively, but we+  may change that. And it would take extra code to exclude them, as+  well as being unnecessary.++* In isValue, we (mis-) use LambdaVal for this ($fblah d1 .. dn)+  because ConVal requires us to list the data constructor and+  fields, and that is (a) inconvenient and (b) unnecessary for+  class methods.++-----------------------------------------------------+                Stuff not yet handled+-----------------------------------------------------++Here are notes arising from Roman's work that I don't want to lose.++Example 1+~~~~~~~~~+    data T a = T !a++    foo :: Int -> T Int -> Int+    foo 0 t = 0+    foo x t | even x    = case t of { T n -> foo (x-n) t }+            | otherwise = foo (x-1) t++SpecConstr does no specialisation, because the second recursive call+looks like a boxed use of the argument.  A pity.++    $wfoo_sFw :: GHC.Prim.Int# -> T.T GHC.Base.Int -> GHC.Prim.Int#+    $wfoo_sFw =+      \ (ww_sFo [Just L] :: GHC.Prim.Int#) (w_sFq [Just L] :: T.T GHC.Base.Int) ->+         case ww_sFo of ds_Xw6 [Just L] {+           __DEFAULT ->+                case GHC.Prim.remInt# ds_Xw6 2 of wild1_aEF [Dead Just A] {+                  __DEFAULT -> $wfoo_sFw (GHC.Prim.-# ds_Xw6 1) w_sFq;+                  0 ->+                    case w_sFq of wild_Xy [Just L] { T.T n_ad5 [Just U(L)] ->+                    case n_ad5 of wild1_aET [Just A] { GHC.Base.I# y_aES [Just L] ->+                    $wfoo_sFw (GHC.Prim.-# ds_Xw6 y_aES) wild_Xy+                    } } };+           0 -> 0++Example 2+~~~~~~~~~+    data a :*: b = !a :*: !b+    data T a = T !a++    foo :: (Int :*: T Int) -> Int+    foo (0 :*: t) = 0+    foo (x :*: t) | even x    = case t of { T n -> foo ((x-n) :*: t) }+                  | otherwise = foo ((x-1) :*: t)++Very similar to the previous one, except that the parameters are now in+a strict tuple. Before SpecConstr, we have++    $wfoo_sG3 :: GHC.Prim.Int# -> T.T GHC.Base.Int -> GHC.Prim.Int#+    $wfoo_sG3 =+      \ (ww_sFU [Just L] :: GHC.Prim.Int#) (ww_sFW [Just L] :: T.T+    GHC.Base.Int) ->+        case ww_sFU of ds_Xws [Just L] {+          __DEFAULT ->+        case GHC.Prim.remInt# ds_Xws 2 of wild1_aEZ [Dead Just A] {+          __DEFAULT ->+            case ww_sFW of tpl_B2 [Just L] { T.T a_sFo [Just A] ->+            $wfoo_sG3 (GHC.Prim.-# ds_Xws 1) tpl_B2             -- $wfoo1+            };+          0 ->+            case ww_sFW of wild_XB [Just A] { T.T n_ad7 [Just S(L)] ->+            case n_ad7 of wild1_aFd [Just L] { GHC.Base.I# y_aFc [Just L] ->+            $wfoo_sG3 (GHC.Prim.-# ds_Xws y_aFc) wild_XB        -- $wfoo2+            } } };+          0 -> 0 }++We get two specialisations:+"SC:$wfoo1" [0] __forall {a_sFB :: GHC.Base.Int sc_sGC :: GHC.Prim.Int#}+                  Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int a_sFB)+                  = Foo.$s$wfoo1 a_sFB sc_sGC ;+"SC:$wfoo2" [0] __forall {y_aFp :: GHC.Prim.Int# sc_sGC :: GHC.Prim.Int#}+                  Foo.$wfoo sc_sGC (Foo.T @ GHC.Base.Int (GHC.Base.I# y_aFp))+                  = Foo.$s$wfoo y_aFp sc_sGC ;++But perhaps the first one isn't good.  After all, we know that tpl_B2 is+a T (I# x) really, because T is strict and Int has one constructor.  (We can't+unbox the strict fields, because T is polymorphic!)++************************************************************************+*                                                                      *+\subsection{Top level wrapper stuff}+*                                                                      *+************************************************************************+-}++specConstrProgram :: ModGuts -> CoreM ModGuts+specConstrProgram guts+  = do { env0 <- initScEnv guts+       ; us   <- getUniqueSupplyM+       ; let (_usg, binds', warnings) = initUs_ us $+                              scTopBinds env0 (mg_binds guts)++       ; when (not (null warnings)) $ msg specConstr_warn_class (warn_msg warnings)++       ; return (guts { mg_binds = binds' }) }++  where+    specConstr_warn_class = MCDiagnostic SevWarning (ResolvedDiagnosticReason WarningWithoutFlag) Nothing+    warn_msg :: SpecFailWarnings -> SDoc+    warn_msg warnings = text "SpecConstr encountered one or more function(s) with a SPEC argument that resulted in too many arguments," $$+                        text "which resulted in no specialization being generated for these functions:" $$+                        nest 2 (vcat (map ppr warnings)) $$+                        (text "If this is expected you might want to increase -fmax-forced-spec-args to force specialization anyway.")+scTopBinds :: ScEnv -> [InBind] -> UniqSM (ScUsage, [OutBind], [SpecFailWarning])+scTopBinds _env []     = return (nullUsage, [], [])+scTopBinds env  (b:bs) = do { (usg, b', bs', warnings) <- scBind TopLevel env b $+                                                (\env -> scTopBinds env bs)+                            ; return (usg, b' ++ bs', warnings) }++{-+************************************************************************+*                                                                      *+\subsection{Environment: goes downwards}+*                                                                      *+************************************************************************++Note [ConVal work-free-ness]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The sc_vals field keeps track of in-scope value bindings, and is used in+two ways:++(1) To do case-of-known-constructor in a case expression.  E.g. if sc_vals+    includes [x :-> ConVal Just e], then we can simplify+      case x of Just y -> ...+    with the case-of-known-constructor transformation. (Yes this is+    done by the Simplifier, but SpecConstr creates new opportunities when+    it makes a specialised RHS for a function.)++    For (1) it is crucial that the arguments are /work-free/; see (CV1)+    below.++(2) To figure out call pattresns. E.g. if sc_vals includes+    [x :-> ConVal Just e], and we have call (f x), then we might want+    to specialise `f (Just _)`++    For (2) it is /not/ important that the constructor arguments are work-free;+    indeed, it would be bad to insist on that. For example+       let x = Just <expensive>+       in ....(f x)...+    Here we want to specialise for `f (Just _)`, and we won't do so if we+    don't allow [x :-> ConVal Just e] into the environment.  Does this ever happen?+    Yes: see #24282.++    (Yes, the Simplifier will ANF that let-binding, but SpecConstr can+    make more: see (CV1) for an example.)++Wrinkle:++(CV1) Why is work-free-ness important for (1)?  In the example in (1) above, of `e` is+      expensive, we do /not/ want to simplify+         case x of { Just y -> ... }  ==>   let y = e in ...+      because the x-binding still exists and we've now duplicated `e`.++      This seldom happens because let-bound constructor applications are ANF-ised, but+      it can happen as a result of on-the-fly transformations in SpecConstr itself.+      Here is #7865:++              let { a'_shr =+                      case xs_af8 of _ {+                        [] -> acc_af6;+                        : ds_dgt [Dmd=<L,A>] ds_dgu [Dmd=<L,A>] ->+                          (expensive x_af7, x_af7+                      } } in+              let { ds_sht =+                      case a'_shr of _ { (p'_afd, q'_afe) ->+                      TSpecConstr_DoubleInline.recursive+                        (GHC.Types.: @ GHC.Types.Int x_af7 wild_X6) (q'_afe, p'_afd)+                      } } in++      When processed knowing that xs_af8 was bound to a cons, we simplify to+         a'_shr = (expensive x_af7, x_af7)+      and we do NOT want to inline that at the occurrence of a'_shr in ds_sht.+      (There are other occurrences of a'_shr.)  No no no.++      It would be possible to do some on-the-fly ANF-ising, so that a'_shr turned+      into a work-free value again, thus+         a1 = expensive x_af7+         a'_shr = (a1, x_af7)+      but that's more work, so until its shown to be important I'm going to+      leave it for now.++Note [Making SpecConstr keener]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this, in (perf/should_run/T9339)+   last (filter odd [1..1000])++After optimisation, including SpecConstr, we get:+   f :: Int# -> Int -> Int+   f x y = case remInt# x 2# of+             __DEFAULT -> case x of+                            __DEFAULT -> f (+# wild_Xp 1#) (I# x)+                            1000000# -> ...+             0# -> case x of+                     __DEFAULT -> f (+# wild_Xp 1#) y+                    1000000#   -> y++Not good!  We build an (I# x) box every time around the loop.+SpecConstr (as described in the paper) does not specialise f, despite+the call (f ... (I# x)) because 'y' is not scrutinised in the body.+But it is much better to specialise f for the case where the argument+is of form (I# x); then we build the box only when returning y, which+is on the cold path.++Another example:++   f x = ...(g x)....++Here 'x' is not scrutinised in f's body; but if we did specialise 'f'+then the call (g x) might allow 'g' to be specialised in turn.++So sc_keen controls whether or not we take account of whether argument is+scrutinised in the body.  True <=> ignore that, and specialise whenever+the function is applied to a data constructor.+-}++-- | Options for Specializing over constructors in Core.+data SpecConstrOpts = SpecConstrOpts+  { sc_max_args  :: !Int+  -- ^ The threshold at which a worker-wrapper transformation used as part of+  -- this pass will no longer happen, measured in the number of arguments.++  , sc_max_forced_args  :: !Int+  -- ^ The threshold at which a worker-wrapper transformation used as part of+  -- this pass will no longer happen even if a SPEC arg was used to force+  -- specialization. Measured in the number of arguments.+  -- See Note [Forcing specialisation]++  , sc_debug     :: !Bool+  -- ^ Whether to print debug information++  , sc_uf_opts   :: !UnfoldingOpts+  -- ^ Unfolding options++  , sc_module    :: !Module+  -- ^ The name of the module being processed++  , sc_size      :: !(Maybe Int)+  -- ^ Size threshold: Nothing => no limit++  , sc_count     :: !(Maybe Int)+  -- ^ Max # of specialisations for any one function. Nothing => no limit.+  -- See Note [Avoiding exponential blowup] and decreaseSpecCount++  , sc_recursive :: !Int+  -- ^ Max # of specialisations over recursive type. Stops+  -- ForceSpecConstr from diverging.++  , sc_keen      :: !Bool+  -- ^ Specialise on arguments that are known constructors, even if they are+  -- not scrutinised in the body. See Note [Making SpecConstr keener].+  }++data ScEnv = SCE { sc_opts      :: !SpecConstrOpts,+                   sc_force     :: Bool,        -- Force specialisation?+                                                -- See Note [Forcing specialisation]++                   sc_subst     :: Subst,       -- Current substitution+                                                -- Maps InIds to OutExprs++                   sc_how_bound :: HowBoundEnv,+                        -- Binds interesting non-top-level variables+                        -- Domain is OutVars (*after* applying the substitution)++                   sc_vals      :: ValueEnv,+                        -- Domain is OutIds (*after* applying the substitution)+                        -- Used even for top-level bindings (but not imported ones)++                   sc_annotations :: UniqFM Name SpecConstrAnnotation+             }++---------------------+type HowBoundEnv = VarEnv HowBound      -- Domain is OutVars++---------------------+type ValueEnv = IdEnv Value            -- Domain is OutIds++data Value = ConVal            -- Constructor application+                  Bool             -- True <=> all args are work-free+                                   --      See Note [ConVal work-free-ness]+                  AltCon           -- Never DEFAULT+                  [CoreArg]        -- Saturates the constructor+           | LambdaVal         -- Inlinable lambdas or PAPs++instance Outputable Value where+   ppr LambdaVal            = text "<Lambda>"+   ppr (ConVal wf con args)+     | null args = ppr con+     | otherwise = parens (ppr con <> braces pp_wf <+> interpp'SP args)+     where+       pp_wf | wf        = text "wf"+             | otherwise = text "not-wf"+++---------------------+initScOpts :: DynFlags -> Module -> SpecConstrOpts+initScOpts dflags this_mod = SpecConstrOpts+        { sc_max_args    = maxWorkerArgs dflags,+          sc_max_forced_args = maxForcedSpecArgs dflags,+          sc_debug       = hasPprDebug dflags,+          sc_uf_opts     = unfoldingOpts dflags,+          sc_module      = this_mod,+          sc_size        = specConstrThreshold dflags,+          sc_count       = specConstrCount     dflags,+          sc_recursive   = specConstrRecursive dflags,+          sc_keen        = gopt Opt_SpecConstrKeen dflags+        }++initScEnv :: ModGuts -> CoreM ScEnv+initScEnv guts+  = do { dflags    <- getDynFlags+       ; (_, anns) <- getFirstAnnotations deserializeWithData guts+       ; this_mod  <- getModule+       ; return (SCE { sc_opts        = initScOpts dflags this_mod,+                       sc_force       = False,+                       sc_subst       = init_subst,+                       sc_how_bound   = emptyVarEnv,+                       sc_vals        = emptyVarEnv,+                       sc_annotations = anns }) }+  where+    init_subst = mkEmptySubst $ mkInScopeSetBndrs (mg_binds guts)+        -- Acccount for top-level bindings that are not in dependency order;+        -- see Note [Glomming] in GHC.Core.Opt.OccurAnal+        -- Easiest thing is to bring all the top level binders into scope at once,+        -- as if  at once, as if all the top-level decls were mutually recursive.++data HowBound = RecFun  -- These are the recursive functions for which+                        -- we seek interesting call patterns++              | RecArg  -- These are those functions' arguments, or their sub-components;+                        -- we gather occurrence information for these++instance Outputable HowBound where+  ppr RecFun = text "RecFun"+  ppr RecArg = text "RecArg"++scForce :: ScEnv -> Bool -> ScEnv+scForce env b = env { sc_force = b }++lookupHowBound :: ScEnv -> OutId -> Maybe HowBound+lookupHowBound env id = lookupVarEnv (sc_how_bound env) id++scSubstId :: ScEnv -> InId -> OutExpr+scSubstId env v = lookupIdSubst (sc_subst env) v+++++-- The !subst ensures that we force the selection `(sc_subst env)`, which avoids+-- retaining all of `env` when we only need `subst`.  The `Solo` means that the+-- substitution itself is lazy, because that type is often discarded.+-- The callers of `scSubstTy` always force the result (to unpack the `Solo`)+-- so we get the desired effect: we leave a thunk, but retain only the subst,+-- not the whole env.+--+-- Fully forcing the result of `scSubstTy` regresses performance (#22102)+scSubstTy :: ScEnv -> InType -> Solo OutType+scSubstTy env ty =+  let !subst = sc_subst env+  in MkSolo (substTyUnchecked subst ty)++scSubstCo :: ScEnv -> Coercion -> Coercion+scSubstCo env co = substCo (sc_subst env) co++zapScSubst :: ScEnv -> ScEnv+zapScSubst env = env { sc_subst = zapSubst (sc_subst env) }++extendScInScope :: ScEnv -> [Var] -> ScEnv+        -- Bring the quantified variables into scope+extendScInScope env qvars+  = env { sc_subst = extendSubstInScopeList (sc_subst env) qvars }++        -- Extend the substitution+extendScSubst :: ScEnv -> Var -> OutExpr -> ScEnv+extendScSubst env var expr = env { sc_subst = extendSubst (sc_subst env) var expr }++extendScSubstList :: ScEnv -> [(Var,OutExpr)] -> ScEnv+extendScSubstList env prs = env { sc_subst = extendSubstList (sc_subst env) prs }++extendHowBound :: ScEnv -> [Var] -> HowBound -> ScEnv+extendHowBound env bndrs how_bound+  = env { sc_how_bound = extendVarEnvList (sc_how_bound env)+                            [(bndr,how_bound) | bndr <- bndrs] }++extendBndrsWith :: HowBound -> ScEnv -> [Var] -> (ScEnv, [Var])+extendBndrsWith how_bound env bndrs+  = (env { sc_subst = subst', sc_how_bound = hb_env' }, bndrs')+  where+    (subst', bndrs') = substBndrs (sc_subst env) bndrs+    hb_env' = sc_how_bound env `extendVarEnvList`+                    [(bndr,how_bound) | bndr <- bndrs']++extendBndrWith :: HowBound -> ScEnv -> Var -> (ScEnv, Var)+extendBndrWith how_bound env bndr+  = (env { sc_subst = subst', sc_how_bound = hb_env' }, bndr')+  where+    (subst', bndr') = substBndr (sc_subst env) bndr+    hb_env' = extendVarEnv (sc_how_bound env) bndr' how_bound++extendRecBndrs :: ScEnv -> [Var] -> (ScEnv, [Var])+extendRecBndrs env bndrs  = (env { sc_subst = subst' }, bndrs')+                      where+                        (subst', bndrs') = substRecBndrs (sc_subst env) bndrs++extendBndrs :: ScEnv -> [Var] -> (ScEnv, [Var])+extendBndrs env bndrs = mapAccumL extendBndr env bndrs++extendBndr :: ScEnv -> Var -> (ScEnv, Var)+extendBndr env bndr  = (env { sc_subst = subst' }, bndr')+                     where+                       (subst', bndr') = substBndr (sc_subst env) bndr++extendValEnv :: ScEnv -> Id -> Maybe Value -> ScEnv+extendValEnv env id mb_val+  = case mb_val of+      Nothing -> env+      Just cv -> env { sc_vals = extendVarEnv (sc_vals env) id cv }++extendCaseBndrs :: ScEnv -> OutExpr -> OutId -> AltCon -> [Var] -> (ScEnv, [Var])+-- When we encounter+--      case scrut of b+--          C x y -> ...+-- we want to bind b, to (C x y)+-- NB1: Extends only the sc_vals part of the envt+-- NB2: Kill the dead-ness info on the pattern binders x,y, since+--      they are potentially made alive by the [b -> C x y] binding+extendCaseBndrs env scrut case_bndr con alt_bndrs+   = (env2, alt_bndrs')+ where+   live_case_bndr = not (isDeadBinder case_bndr)+   env1 | DoBinderSwap v mco <- scrutOkForBinderSwap scrut+        , isReflMCo mco  = extendValEnv env v cval+        | otherwise      = env  -- See Note [Add scrutinee to ValueEnv too]+   env2 | live_case_bndr = extendValEnv env1 case_bndr cval+        | otherwise      = env1++   alt_bndrs' | case scrut of { Var {} -> True; _ -> live_case_bndr }+              = map zap alt_bndrs+              | otherwise+              = alt_bndrs++   cval = case con of+                DEFAULT    -> Nothing+                LitAlt {}  -> Just (ConVal True con [])+                DataAlt {} -> Just (ConVal True con vanilla_args)+                      where+                        vanilla_args = map Type (tyConAppArgs (idType case_bndr)) +++                                       varsToCoreExprs alt_bndrs++   zap v | isTyVar v = v                -- See NB2 above+         | otherwise = zapIdOccInfo v+++decreaseSpecCount :: ScEnv -> Int -> ScEnv+-- See Note [Avoiding exponential blowup]+decreaseSpecCount env _n_specs+  = env { sc_force = False   -- See Note [Forcing specialisation]+        , sc_opts = opts { sc_count = case sc_count opts of+                             Nothing -> Nothing+                             Just n  -> Just $! dec n+            }+        }+  where+    opts  = sc_opts env+    dec n = n `div` 2  -- See Note [Avoiding exponential blowup]++    -- Or:   n `div` (n_specs + 1)+    -- See the historical note part of Note [Avoiding exponential blowup]+    -- The "+1" takes account of the original function;++---------------------------------------------------+-- See Note [Forcing specialisation]+ignoreType    :: ScEnv -> Type   -> Bool+ignoreDataCon  :: ScEnv -> DataCon -> Bool+forceSpecBndr :: ScEnv -> Var    -> Bool++ignoreDataCon env dc = ignoreTyCon env (dataConTyCon dc)++ignoreType env ty+  = case tyConAppTyCon_maybe ty of+      Just tycon -> ignoreTyCon env tycon+      _          -> False++ignoreTyCon :: ScEnv -> TyCon -> Bool+ignoreTyCon env tycon+  = lookupUFM (sc_annotations env) (tyConName tycon) == Just NoSpecConstr++forceSpecBndr env var = forceSpecFunTy env . snd . splitForAllTyCoVars . varType $ var++forceSpecFunTy :: ScEnv -> Type -> Bool+forceSpecFunTy env = any (forceSpecArgTy env) . map scaledThing . fst . splitFunTys++forceSpecArgTy :: ScEnv -> Type -> Bool+forceSpecArgTy env ty+  | isFunTy ty+  = False++  | Just (tycon, tys) <- splitTyConApp_maybe ty+  = tycon `hasKey` specTyConKey+    || lookupUFM (sc_annotations env) (tyConName tycon) == Just ForceSpecConstr+    || any (forceSpecArgTy env) tys++forceSpecArgTy _ _ = False++{-+Note [Add scrutinee to ValueEnv too]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this:+   case x of y+     (a,b) -> case b of c+                I# v -> ...(f y)...+By the time we get to the call (f y), the ValueEnv+will have a binding for y, and for c+    y -> (a,b)+    c -> I# v+BUT that's not enough!  Looking at the call (f y) we+see that y is pair (a,b), but we also need to know what 'b' is.+So in extendCaseBndrs we must *also* add the binding+   b -> I# v+else we lose a useful specialisation for f.  This is necessary even+though the simplifier has systematically replaced uses of 'x' with 'y'+and 'b' with 'c' in the code.  The use of 'b' in the ValueEnv came+from outside the case.  See #4908 for the live example.++It's very like the binder-swap story, so we use scrutOkForBinderSwap+to identify suitable scrutinees -- but only if there is no cast+(isReflMCo) because that's all that the ValueEnv allows.++Note [Avoiding exponential blowup]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The sc_count field of the ScEnv says how many times we are prepared to+duplicate a single function.  But we must take care with recursive+specialisations.  Consider++        let $j1 = let $j2 = let $j3 = ...+                            in+                            ...$j3...+                  in+                  ...$j2...+        in+        ...$j1...++If we specialise $j1 then in each specialisation (as well as the original)+we can specialise $j2, and similarly $j3.  Even if we make just *one*+specialisation of each, because we also have the original we'll get 2^n+copies of $j3, which is not good.++So when recursively specialising we divide the sc_count (the maximum+number of specialisations, in the ScEnv) by two.  You might think that+gives us n*(n/2)*(n/4)... copies of the innnermost thing, which is+still exponential the depth.  But we use integer division, rounding+down, so if the starting sc_count is 3, we'll get 3 -> 1 -> 0, and+stop.  In fact, simply subtracting 1 would be good enough, for the same+reason.++Historical note: in the past we divided by (n_specs+1), where n_specs+is the number of specialisations at this level; but that gets us down+to zero jolly quickly, which I found led to some regressions.  (An+example is nofib/spectral/fibheaps, the getMin' function inside the+outer function $sfibToList, which has several interesting call+patterns.)++************************************************************************+*                                                                      *+\subsection{Usage information: flows upwards}+*                                                                      *+************************************************************************+-}++data ScUsage+   = SCU {+        scu_calls :: CallEnv,           -- Calls+                                        -- The functions are a subset of the+                                        --      RecFuns in the ScEnv++        scu_occs :: !(IdEnv ArgOcc)     -- Information on argument occurrences+     }                                  -- The domain is OutIds++type CallEnv = IdEnv [Call]  -- Domain is OutIds+data Call    = Call OutId [CoreArg] ValueEnv+        -- The arguments of the call, together with the+        -- env giving the constructor bindings at the call site+        -- We keep the function mainly for debug output+        --+        -- The call is not necessarily saturated; we just put+        -- in however many args are visible at the call site++instance Outputable ScUsage where+  ppr (SCU { scu_calls = calls, scu_occs = occs })+    = text "SCU" <+> braces (sep [ text "calls =" <+> ppr calls+                                 , text "occs =" <+> ppr occs ])++instance Outputable Call where+  ppr (Call fn args _) = ppr fn <+> fsep (map pprParendExpr args)++nullUsage :: ScUsage+nullUsage = SCU { scu_calls = emptyVarEnv, scu_occs = emptyVarEnv }++combineCalls :: CallEnv -> CallEnv -> CallEnv+combineCalls = plusVarEnv_C (++)++delCallsFor :: ScUsage -> [Var] -> ScUsage+delCallsFor env bndrs = env { scu_calls = scu_calls env `delVarEnvList` bndrs }++combineUsage :: ScUsage -> ScUsage -> ScUsage+combineUsage u1 u2 = SCU { scu_calls = combineCalls (scu_calls u1) (scu_calls u2),+                           scu_occs  = plusVarEnv_C combineOcc (scu_occs u1) (scu_occs u2) }++combineUsages :: [ScUsage] -> ScUsage+combineUsages = foldr1WithDefault nullUsage combineUsage++lookupOccs :: Traversable f => ScUsage -> f OutVar -> (ScUsage, f ArgOcc)+lookupOccs (SCU { scu_calls = sc_calls, scu_occs = sc_occs }) bndrs+  = (SCU {scu_calls = sc_calls, scu_occs = delVarEnvList sc_occs bndrs},+    fromMaybe NoOcc . lookupVarEnv sc_occs <$> bndrs)++data ArgOcc = NoOcc     -- Doesn't occur at all; or a type argument+            | UnkOcc    -- Used in some unknown way++            | ScrutOcc  -- See Note [ScrutOcc]+                 (DataConEnv [ArgOcc])+                     -- [ArgOcc]: how the sub-components are used++deadArgOcc :: ArgOcc -> Bool+deadArgOcc (ScrutOcc {}) = False+deadArgOcc UnkOcc        = False+deadArgOcc NoOcc         = True++specialisableArgOcc :: ArgOcc -> Bool+-- | Does this occurrence represent one worth specializing for.+specialisableArgOcc UnkOcc        = False+specialisableArgOcc NoOcc         = False+specialisableArgOcc (ScrutOcc {}) = True+++{- Note [ScrutOcc]+~~~~~~~~~~~~~~~~~~+An occurrence of ScrutOcc indicates that the thing, or a `cast` version of the thing,+is *only* taken apart or applied.++  Functions, literal: ScrutOcc emptyUFM+  Data constructors:  ScrutOcc subs,++where (subs :: UniqFM [ArgOcc]) gives usage of the *pattern-bound* components,+The domain of the UniqFM is the Unique of the data constructor++The [ArgOcc] is the occurrences of the *pattern-bound* components+of the data structure.  E.g.+        data T a = forall b. MkT a b (b->a)+A pattern binds b, x::a, y::b, z::b->a, but not 'a'!++-}++instance Outputable ArgOcc where+  ppr (ScrutOcc xs) = text "scrut-occ" <> ppr xs+  ppr UnkOcc        = text "unk-occ"+  ppr NoOcc         = text "no-occ"++evalScrutOcc :: ArgOcc+-- We use evalScrutOcc for+--   - mkVarUsage: applied functions+--   - scApp: dicts that are the argument of a classop+evalScrutOcc = ScrutOcc emptyUFM++-- Experimentally, this version of combineOcc makes ScrutOcc "win", so+-- that if the thing is scrutinised anywhere then we get to see that+-- in the overall result, even if it's also used in a boxed way+-- This might be too aggressive; see Note [Reboxing] Alternative 3+combineOcc :: ArgOcc -> ArgOcc -> ArgOcc+combineOcc NoOcc         occ           = occ+combineOcc occ           NoOcc         = occ+combineOcc (ScrutOcc xs) (ScrutOcc ys) = ScrutOcc (plusUFM_C combineOccs xs ys)+combineOcc UnkOcc        (ScrutOcc ys) = ScrutOcc ys+combineOcc (ScrutOcc xs) UnkOcc        = ScrutOcc xs+combineOcc UnkOcc        UnkOcc        = UnkOcc++combineOccs :: [ArgOcc] -> [ArgOcc] -> [ArgOcc]+combineOccs xs ys = zipWithEqual combineOcc xs ys++setScrutOcc :: ScEnv -> ScUsage -> OutExpr -> ArgOcc -> ScUsage+-- _Overwrite_ the occurrence info for the scrutinee, if the scrutinee+-- is a variable, and an interesting variable+setScrutOcc env usg (Cast e _) occ      = setScrutOcc env usg e occ+setScrutOcc env usg (Tick _ e) occ      = setScrutOcc env usg e occ+setScrutOcc env usg (Var v)    occ+  | Just RecArg <- lookupHowBound env v = usg { scu_occs = extendVarEnv (scu_occs usg) v occ }+  | otherwise                           = usg+setScrutOcc _env usg _other _occ        -- Catch-all+  = usg++{-+************************************************************************+*                                                                      *+\subsection{The main recursive function}+*                                                                      *+************************************************************************++The main recursive function gathers up usage information, and+creates specialised versions of functions.+-}++scBind :: TopLevelFlag -> ScEnv -> InBind+       -> (ScEnv -> UniqSM (ScUsage, a, [SpecFailWarning]))   -- Specialise the scope of the binding+       -> UniqSM (ScUsage, [OutBind], a, [SpecFailWarning])+scBind top_lvl env (NonRec bndr rhs) do_body+  | isTyVar bndr         -- Type-lets may be created by doBeta+  = do { (final_usage, body', warnings) <- do_body (extendScSubst env bndr rhs)+       ; return (final_usage, [], body', warnings) }++  | not (isTopLevel top_lvl)  -- Nested non-recursive value binding+    -- See Note [Specialising local let bindings]+  = do  { let (body_env, bndr') = extendBndr env bndr+              -- Not necessary at top level; but here we are nested++        ; (rhs_info, rhs_ws)  <- scRecRhs env (bndr',rhs)++        ; let body_env2 = extendHowBound body_env [bndr'] RecFun+              rhs'      = ri_new_rhs rhs_info+              body_env3 = extendValEnv body_env2 bndr' (isValue (sc_vals env) rhs')++        ; (body_usg, body', warnings_body) <- do_body body_env3++          -- Now make specialised copies of the binding,+          -- based on calls in body_usg+        ; (spec_usg, specs, warnings_bnd) <- specNonRec env (scu_calls body_usg) rhs_info+          -- NB: For non-recursive bindings we inherit sc_force flag from+          -- the parent function (see Note [Forcing specialisation])++        -- Specialized + original binding+        ; let spec_bnds  = [NonRec b r | (b,r) <- ruleInfoBinds rhs_info specs]+              bind_usage = (body_usg `delCallsFor` [bndr'])+                           `combineUsage` spec_usg -- Note [spec_usg includes rhs_usg]++        ; return (bind_usage, spec_bnds, body', mconcat [warnings_bnd, warnings_body, rhs_ws])+        }++  | otherwise  -- Top-level, non-recursive value binding+    -- At top level we do not specialise non-recursive bindings; that+    -- is, we do not call specNonRec, passing the calls from the body.+    -- The original paper only specialised /recursive/ bindings, but+    -- we later started specialising nested non-recursive bindings:+    -- see Note [Specialising local let bindings]+    --+    -- I tried always specialising non-recursive top-level bindings too,+    -- but found some regressions (see !8135).  So I backed off.+  = do { (rhs_usage, rhs', ws_rhs)   <- scExpr env rhs++       -- At top level, we've already put all binders into scope; see initScEnv+       -- Hence no need to call `extendBndr`. But we still want to+       -- extend the `ValueEnv` to record the value of this binder.+       ; let body_env = extendValEnv env bndr (isValue (sc_vals env) rhs')+       ; (body_usage, body', body_warnings) <- do_body body_env++       ; return (rhs_usage `combineUsage` body_usage, [NonRec bndr rhs'], body', body_warnings ++ ws_rhs) }++scBind top_lvl env (Rec prs) do_body+  | isTopLevel top_lvl+  , Just threshold <- sc_size (sc_opts env)+  , not force_spec -- See Note [Forcing specialisation], point (FS1)+  , not (all (couldBeSmallEnoughToInline (sc_uf_opts (sc_opts env)) threshold) rhss)+  = -- Do no specialisation if the RHSs are too big+    -- ToDo: I'm honestly not sure of the rationale of this size-testing, nor+    --       why it only applies at top level. But that's the way it has been+    --       for a while. See #21456.+    do  { (body_usg, body', warnings_body) <- do_body rhs_env2+        ; (rhs_usgs, rhss', rhs_ws) <- mapAndUnzip3M (scExpr env) rhss+        ; let all_usg = (combineUsages rhs_usgs `combineUsage` body_usg)+                        `delCallsFor` bndrs'+              bind'   = Rec (bndrs' `zip` rhss')+        ; return (all_usg, [bind'], body', warnings_body ++ concat rhs_ws) }++  | otherwise+  = do  { (rhs_infos, rhs_wss) <- mapAndUnzipM (scRecRhs rhs_env2) (bndrs' `zip` rhss)+        ; let rhs_ws = mconcat rhs_wss+        ; (body_usg, body', warnings_body) <- do_body rhs_env2++        ; (spec_usg, specs, spec_ws) <- specRec (scForce rhs_env2 force_spec)+                                          (scu_calls body_usg) rhs_infos+                -- Do not unconditionally generate specialisations from rhs_usgs+                -- Instead use them only if we find an unspecialised call+                -- See Note [Seeding recursive groups]++        ; let all_usg = (spec_usg `combineUsage` body_usg)  -- Note [spec_usg includes rhs_usg]+                        `delCallsFor` bndrs'+              bind'   = Rec (concat (zipWithEqual ruleInfoBinds rhs_infos specs))+                        -- zipWithEqual: length of returned [SpecInfo]+                        -- should be the same as incoming [RhsInfo]++        ; return (all_usg, [bind'], body', mconcat [warnings_body,rhs_ws,spec_ws]) }+  where+    (bndrs,rhss) = unzip prs+    force_spec   = any (forceSpecBndr env) bndrs    -- Note [Forcing specialisation]++    (rhs_env1,bndrs') | isTopLevel top_lvl = (env, bndrs)+                      | otherwise          = extendRecBndrs env bndrs+       -- At top level, we've already put all binders into scope; see initScEnv++    rhs_env2 = extendHowBound rhs_env1 bndrs' RecFun++{- Note [Specialising local let bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It is not uncommon to find this++   let $j = \x. <blah> in ...$j True...$j True...++Here $j is an arbitrary let-bound function, but it often comes up for+join points.  We might like to specialise $j for its call patterns.+Notice the difference from a letrec, where we look for call patterns+in the *RHS* of the function.  Here we look for call patterns in the+*body* of the let.++At one point I predicated this on the RHS mentioning the outer+recursive function, but that's not essential and might even be+harmful.  I'm not sure.+-}++withWarnings :: SpecFailWarnings -> (ScUsage, CoreExpr, SpecFailWarnings) -> (ScUsage, CoreExpr, SpecFailWarnings)+withWarnings ws (use,expr,ws2) = (use,expr,ws ++ ws2)++------------------------+scExpr, scExpr' :: ScEnv -> CoreExpr -> UniqSM (ScUsage, CoreExpr, SpecFailWarnings)+        -- The unique supply is needed when we invent+        -- a new name for the specialised function and its args++scExpr env e = scExpr' env e++scExpr' env (Var v)      = case scSubstId env v of+                            Var v' -> return (mkVarUsage env v' [], Var v', [])+                            e'     -> scExpr (zapScSubst env) e'++scExpr' env (Type t)     =+  let !(MkSolo ty') = scSubstTy env t+  in return (nullUsage, Type ty', [])+scExpr' env (Coercion c) = return (nullUsage, Coercion (scSubstCo env c), [])+scExpr' _   e@(Lit {})   = return (nullUsage, e, [])+scExpr' env (Tick t e)   = do (usg, e', ws) <- scExpr env e+                              return (usg, Tick (scTickish env t) e', ws)+scExpr' env (Cast e co)  = do (usg, e', ws) <- scExpr env e+                              return (usg, mkCast e' (scSubstCo env co), ws)+                              -- Important to use mkCast here+                              -- See Note [SpecConstr call patterns]+scExpr' env e@(App _ _)  = scApp env (collectArgs e)+scExpr' env (Lam b e)    = do let (env', b') = extendBndr env b+                              (usg, e', ws) <- scExpr env' e+                              return (usg, Lam b' e', ws)++scExpr' env (Let bind body)+  = do { (final_usage, binds', body', ws) <- scBind NotTopLevel env bind $+                                         (\env -> scExpr env body)+       ; return (final_usage, mkLets binds' body', ws) }++scExpr' env (Case scrut b ty alts)+  = do  { (scrut_usg, scrut', ws) <- scExpr env scrut+        ; case isValue (sc_vals env) scrut' of+                Just (ConVal args_are_work_free con args)+                   | args_are_work_free -> sc_con_app con args scrut' ws+                     -- Don't duplicate work!!  #7865+                     -- See Note [ConVal work-free-ness] (1)+                _other -> sc_vanilla scrut_usg scrut' ws+        }+  where+    sc_con_app con args scrut' ws  -- Known constructor; simplify+     = do { let Alt _ bs rhs = findAlt con alts+                                  `orElse` Alt DEFAULT [] (mkImpossibleExpr ty "SpecConstr")+                alt_env'     = extendScSubstList env ((b,scrut') : bs `zip` trimConArgs con args)+          ; (use',expr',ws_new) <- scExpr alt_env' rhs+          ; return (use',expr',ws ++ ws_new) }++    sc_vanilla scrut_usg scrut' ws -- Normal case+     = do { let (alt_env,b') = extendBndrWith RecArg env b+                        -- Record RecArg for the components++          ; (alt_usgs, alt_occs, alts', ws_alts) <- mapAndUnzip4M (sc_alt alt_env scrut' b') alts++          ; let scrut_occ  = foldr combineOcc NoOcc alt_occs+                scrut_usg' = setScrutOcc env scrut_usg scrut' scrut_occ+                -- The combined usage of the scrutinee is given+                -- by scrut_occ, which is passed to setScrutOcc, which+                -- in turn treats a bare-variable scrutinee specially+          ; let !(MkSolo ty') = scSubstTy env ty++          ; return (foldr combineUsage scrut_usg' alt_usgs,+                    Case scrut' b' ty'  alts', ws ++ concat ws_alts) }++    single_alt = isSingleton alts++    sc_alt env scrut' b' (Alt con bs rhs)+     = do { let (env1, bs1) = extendBndrsWith RecArg env bs+                (env2, bs2) = extendCaseBndrs env1 scrut' b' con bs1+          ; (usg, rhs', ws) <- scExpr env2 rhs+          ; let (usg', b_occ:|arg_occs) = lookupOccs usg (b':|bs2)+                scrut_occ = case con of+                               DataAlt dc -- See Note [Do not specialise evals]+                                  | not (single_alt && all deadArgOcc arg_occs)+                                  -> ScrutOcc (unitUFM dc arg_occs)+                               _  -> UnkOcc+          ; return (usg', b_occ `combineOcc` scrut_occ, Alt con bs2 rhs', ws) }+++-- | Substitute the free variables captured by a breakpoint.+-- Variables are dropped if they have a non-variable substitution, like in+-- 'GHC.Opt.Specialise.specTickish'.+scTickish :: ScEnv -> CoreTickish -> CoreTickish+scTickish SCE {sc_subst = subst} = substTickish subst++{- Note [Do not specialise evals]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+   f x y = case x of I# _ ->+           if y>1 then f x (y-1) else x++Here `x` is scrutinised by a case, but only in an eval-like way; the+/component/ of the I# is unused.  We don't want to specialise this+function, even if we find a call (f (I# z)), because nothing is gained+  * No case branches are discarded+  * No allocation in removed+The specialised version would take an unboxed Int#, pass it along,+and rebox it at the end.++In fact this can cause significant regression.  In #21763 we had:+like+  f = ... case x of x' { I# n ->+          join j y = rhs+          in ...jump j x'...++Now if we specialise `j` for the argument `I# n`, we'll end up reboxing+it in `j`, without even removing an allocation from the call site.++Reboxing is always a worry.  But here we can ameliorate the problem as+follows.++* In scExpr (Case ...), for a /single-alternative/ case expression, in+  which the pattern binders are all unused, we build a UnkOcc for+  the scrutinee, not one that maps the data constructor; we don't treat+  this occurrence as a reason for specialisation.++* Conveniently, SpecConstr is doing its own occurrence analysis, so+  the "unused" bit is just looking for NoOcc++* Note that if we have+    f x = case x of { True -> e1; False -> e2 }+  then even though the pattern binders are unused (there are none), it is+  still worth specialising on x. Hence the /single-alternative/ guard.+-}++scApp :: ScEnv -> (InExpr, [InExpr]) -> UniqSM (ScUsage, CoreExpr, SpecFailWarnings)++scApp env (Var fn, args)        -- Function is a variable+  = assert (not (null args)) $+    do  { args_w_usgs <- mapM (scExpr env) args+        ; let (arg_usgs, args', arg_ws) = unzip3 args_w_usgs+              arg_usg = combineUsages arg_usgs+              arg_w = concat arg_ws+        ; case scSubstId env fn of+            fn'@(Lam {}) -> withWarnings arg_w <$> scExpr (zapScSubst env) (doBeta fn' args')+                        -- Do beta-reduction and try again++            Var fn' -> return (arg_usg' `combineUsage` mkVarUsage env fn' args',+                               mkApps (Var fn') args', arg_w )+               where+                 -- arg_usg': see Note [Specialising on dictionaries]+                 arg_usg' | Just cls <- isClassOpId_maybe fn'+                          , dict_arg : _ <- dropList (classTyVars cls) args'+                          = setScrutOcc env arg_usg dict_arg evalScrutOcc+                          | otherwise+                          = arg_usg++            other_fn' -> return (arg_usg, mkApps other_fn' args', arg_w) }+                -- NB: doing this ignores any usage info from the substituted+                --     function, but I don't think that matters.  If it does+                --     we can fix it.+  where+    doBeta :: OutExpr -> [OutExpr] -> OutExpr+    doBeta (Lam bndr body) (arg : args) = Let (NonRec bndr arg) (doBeta body args)+    doBeta fn              args         = mkApps fn args++-- The function is almost always a variable, but not always.+-- In particular, if this pass follows float-in,+-- which it may, we can get+--      (let f = ...f... in f) arg1 arg2+scApp env (other_fn, args)+  = do  { (fn_usg,   fn', fn_ws)   <- scExpr env other_fn+        ; (arg_usgs, args', arg_ws) <- mapAndUnzip3M (scExpr env) args+        ; return (combineUsages arg_usgs `combineUsage` fn_usg, mkApps fn' args', combineSpecWarning fn_ws (concat arg_ws)) }++----------------------+mkVarUsage :: ScEnv -> Id -> [CoreExpr] -> ScUsage+mkVarUsage env fn args+  = case lookupHowBound env fn of+        Just RecFun -> SCU { scu_calls = unitVarEnv fn [Call fn args (sc_vals env)]+                           , scu_occs  = emptyVarEnv }+        Just RecArg -> SCU { scu_calls = emptyVarEnv+                           , scu_occs  = unitVarEnv fn arg_occ }+        Nothing     -> nullUsage+  where+    arg_occ | null args = UnkOcc+            | otherwise = evalScrutOcc++----------------------+scRecRhs :: ScEnv -> (OutId, InExpr) -> UniqSM (RhsInfo, SpecFailWarnings)+scRecRhs env (bndr,rhs)+  = do  { let (arg_bndrs,body)       = collectBinders rhs+              (body_env, arg_bndrs') = extendBndrsWith RecArg env arg_bndrs+        ; (body_usg, body', body_ws)         <- scExpr body_env body+        ; let (rhs_usg, arg_occs)    = lookupOccs body_usg arg_bndrs'+        ; return (RI { ri_rhs_usg = rhs_usg+                     , ri_fn = bndr, ri_new_rhs = mkLams arg_bndrs' body'+                     , ri_lam_bndrs = arg_bndrs, ri_lam_body = body+                     , ri_arg_occs = arg_occs }, body_ws) }+                -- The arg_occs says how the visible,+                -- lambda-bound binders of the RHS are used+                -- (including the TyVar binders)+                -- Two pats are the same if they match both ways++----------------------+ruleInfoBinds :: RhsInfo -> SpecInfo -> [(Id,CoreExpr)]+ruleInfoBinds (RI { ri_fn = fn, ri_new_rhs = new_rhs })+              (SI { si_specs = specs })+  = [(id,rhs) | OS { os_id = id, os_rhs = rhs } <- specs] +++              -- First the specialised bindings++    [(fn `addIdSpecialisations` rules, new_rhs)]+              -- And now the original binding+  where+    rules = [r | OS { os_rule = r } <- specs]++{-+************************************************************************+*                                                                      *+                The specialiser itself+*                                                                      *+************************************************************************+-}++data RhsInfo+  = RI { ri_fn :: OutId                 -- The binder+       , ri_new_rhs :: OutExpr          -- The specialised RHS (in current envt)+       , ri_rhs_usg :: ScUsage          -- Usage info from specialising RHS++       , ri_lam_bndrs :: [InVar]       -- The *original* RHS (\xs.body)+       , ri_lam_body  :: InExpr        --   Note [Specialise original body]+       , ri_arg_occs  :: [ArgOcc]      -- Info on how the xs occur in body+    }++data SpecInfo       -- Info about specialisations for a particular Id+  = SI { si_specs :: [OneSpec]          -- The specialisations we have+                                        -- generated for this function++       , si_n_specs :: Int              -- Length of si_specs; used for numbering them++       , si_mb_unspec :: Maybe ScUsage  -- Just cs  => we have not yet used calls in the+       }                                --             from calls in the *original* RHS as+                                        --             seeds for new specialisations;+                                        --             if you decide to do so, here is the+                                        --             RHS usage (which has not yet been+                                        --             unleashed)+                                        -- Nothing => we have+                                        -- See Note [Seeding recursive groups]+                                        -- See Note [spec_usg includes rhs_usg]++        -- One specialisation: Rule plus definition+data OneSpec =+  OS { os_pat  :: CallPat    -- Call pattern that generated this specialisation+     , os_rule :: CoreRule   -- Rule connecting original id with the specialisation+     , os_id   :: OutId      -- Spec id+     , os_rhs  :: OutExpr }  -- Spec rhs++initSpecInfo :: RhsInfo -> SpecInfo+initSpecInfo (RI { ri_rhs_usg = rhs_usg })+  = SI { si_specs = [], si_n_specs = 0, si_mb_unspec = Just rhs_usg }+    -- si_mb_unspec: add in rhs_usg if there are any boring calls,+    --               or if the bndr is exported++----------------------+specNonRec :: ScEnv+           -> CallEnv         -- Calls in body+           -> RhsInfo         -- Structure info usage info for un-specialised RHS+           -> UniqSM (ScUsage, SpecInfo, [SpecFailWarning])       -- Usage from RHSs (specialised and not)+                                               --     plus details of specialisations++specNonRec env body_calls rhs_info+  = specialise env body_calls rhs_info (initSpecInfo rhs_info)++----------------------+specRec :: ScEnv+        -> CallEnv                         -- Calls in body+        -> [RhsInfo]                       -- Structure info and usage info for un-specialised RHSs+        -> UniqSM (ScUsage, [SpecInfo], SpecFailWarnings)+                                           -- Usage from all RHSs (specialised and not)+                                           --     plus details of specialisations++specRec env body_calls rhs_infos+  = go 1 body_calls nullUsage (map initSpecInfo rhs_infos) []+    -- body_calls: see Note [Seeding recursive groups]+    -- NB: 'go' always calls 'specialise' once, which in turn unleashes+    --     si_mb_unspec if there are any boring calls in body_calls,+    --     or if any of the Id(s) are exported+  where+    opts = sc_opts env++    -- Loop, specialising, until you get no new specialisations+    go, go_again :: Int   -- Which iteration of the "until no new specialisations"+                          -- loop we are on; first iteration is 1+                 -> CallEnv   -- Seed calls+                              -- Two accumulating parameters:+                 -> ScUsage      -- Usage from earlier specialisations+                 -> [SpecInfo]   -- Details of specialisations so far+                 -> SpecFailWarnings -- Warnings so far+                 -> UniqSM (ScUsage, [SpecInfo], SpecFailWarnings)+    go n_iter seed_calls usg_so_far spec_infos ws_so_far+      = -- pprTrace "specRec3" (vcat [ text "bndrs" <+> ppr (map ri_fn rhs_infos)+        --                           , text "iteration" <+> int n_iter+        --                          , text "spec_infos" <+> ppr (map (map os_pat . si_specs) spec_infos)+        --                    ]) $+        do  { specs_w_usg <- zipWithM (specialise env seed_calls) rhs_infos spec_infos++            ; let (extra_usg_s, all_spec_infos, extra_ws ) = unzip3 specs_w_usg+                  extra_usg = combineUsages extra_usg_s+                  all_usg   = usg_so_far `combineUsage` extra_usg+                  new_calls = scu_calls extra_usg+            ; go_again n_iter new_calls all_usg all_spec_infos (ws_so_far ++ concat extra_ws) }++    -- go_again deals with termination+    go_again n_iter seed_calls usg_so_far spec_infos ws_so_far+      | isEmptyVarEnv seed_calls+      = return (usg_so_far, spec_infos, ws_so_far)++      -- Limit recursive specialisation+      -- See Note [Limit recursive specialisation]+      | n_iter > sc_recursive opts  -- Too many iterations of the 'go' loop+      , sc_force env || isNothing (sc_count opts)+           -- If both of these are false, the sc_count+           -- threshold will prevent non-termination+           -- See Note [Forcing specialisation], point (FS4) and (FS2)+      , any ((> the_limit) . si_n_specs) spec_infos+      = -- Give up on specialisation, but don't forget to include the rhs_usg+        -- for the unspecialised function, since it may now be called+        -- pprTrace "specRec2" (ppr (map (map os_pat . si_specs) spec_infos)) $+        let rhs_usgs = combineUsages (mapMaybe si_mb_unspec spec_infos)+        in return (usg_so_far `combineUsage` rhs_usgs, spec_infos, ws_so_far)++      | otherwise+      = go (n_iter + 1) seed_calls usg_so_far spec_infos ws_so_far++    -- See Note [Limit recursive specialisation]+    the_limit = case sc_count opts of+                  Nothing  -> 10    -- Ugh!+                  Just max -> max++----------------------+specialise+   :: ScEnv+   -> CallEnv                     -- Info on newly-discovered calls to this function+   -> RhsInfo+   -> SpecInfo                    -- Original RHS plus patterns dealt with+   -> UniqSM (ScUsage, SpecInfo, [SpecFailWarning])  -- New specialised versions and their usage++-- See Note [spec_usg includes rhs_usg]++-- Note: this only generates *specialised* bindings+-- The original binding is added by ruleInfoBinds+--+-- Note: the rhs here is the optimised version of the original rhs+-- So when we make a specialised copy of the RHS, we're starting+-- from an RHS whose nested functions have been optimised already.++specialise env bind_calls (RI { ri_fn = fn, ri_lam_bndrs = arg_bndrs+                              , ri_lam_body = body, ri_arg_occs = arg_occs })+               spec_info@(SI { si_specs = specs, si_n_specs = spec_count+                             , si_mb_unspec = mb_unspec })+  | isDeadEndId fn  -- Note [Do not specialise diverging functions]+                    -- /and/ do not generate specialisation seeds from its RHS+  = -- pprTrace "specialise bot" (ppr fn) $+    return (nullUsage, spec_info, [])++  | not (isNeverActive (idInlineActivation fn))+      -- See Note [Transfer activation]+      -- Don't specialise OPAQUE things, see Note [OPAQUE pragma].+      -- Since OPAQUE things are always never-active (see+      -- GHC.Parser.PostProcess.mkOpaquePragma) this guard never fires for+      -- OPAQUE things.+  , not (null arg_bndrs)                         -- Only specialise functions+  , Just all_calls <- lookupVarEnv bind_calls fn -- Some calls to it+  = -- pprTrace "specialise entry {" (ppr fn <+> ppr all_calls) $+    do  { (boring_call, pats_discarded, new_pats, warnings)+             <- callsToNewPats env fn spec_info arg_occs all_calls++        ; let n_pats = length new_pats+--        ; when (not (null new_pats) || isJust mb_unspec) $+--          pprTraceM "specialise" (vcat [ ppr fn <+> text "with" <+> int n_pats <+> text "good patterns"+--                                       , text "boring_call:" <+> ppr boring_call+--                                       , text "pats_discarded:" <+> ppr pats_discarded+--                                       , text "old spec_count" <+> ppr spec_count+--                                       , text "spec count limit" <+> ppr (sc_count (sc_opts env))+--                                       , text "mb_unspec" <+> ppr (isJust mb_unspec)+--                                       , text "arg_occs" <+> ppr arg_occs+--                                       , text "new_pats" <+> ppr new_pats])++        ; let spec_env = decreaseSpecCount env n_pats+        ; (spec_usgs, new_specs, new_wss) <- mapAndUnzip3M (spec_one spec_env fn arg_bndrs body)+                                                 (new_pats `zip` [spec_count..])+                -- See Note [Specialise original body]++        ; let spec_usg = combineUsages spec_usgs++              unspec_rhs_needed = pats_discarded || boring_call || isExportedId fn++              -- If there were any boring calls among the seeds (= all_calls), then those+              -- calls will call the un-specialised function.  So we should use the seeds+              -- from the _unspecialised_ function's RHS, which are in mb_unspec, by returning+              -- then in new_usg.+              (new_usg, mb_unspec') = case mb_unspec of+                  Just rhs_usg | unspec_rhs_needed+                               -> (spec_usg `combineUsage` rhs_usg, Nothing)+                  _            -> (spec_usg,                      mb_unspec)++--        ; pprTraceM "specialise return }" $+--          vcat [ ppr fn+--               , text "unspec_rhs_needed:" <+> ppr unspec_rhs_needed+--               , text "new calls:" <+> ppr (scu_calls new_usg)]++        ; return (new_usg, SI { si_specs     = new_specs ++ specs+                              , si_n_specs   = spec_count + n_pats+                              , si_mb_unspec = mb_unspec' }+                 ,warnings ++ concat new_wss) }++  | otherwise  -- No calls, inactive, or not a function+               -- Behave as if there was a single, boring call+  = -- pprTrace "specialise inactive" (ppr fn $$ ppr mb_unspec) $+    case mb_unspec of    -- Behave as if there was a single, boring call+      Just rhs_usg -> return (rhs_usg, spec_info { si_mb_unspec = Nothing }, [])+                         -- See Note [spec_usg includes rhs_usg]+      Nothing      -> return (nullUsage, spec_info, [])+++---------------------+spec_one :: ScEnv+         -> OutId       -- Function+         -> [InVar]     -- Lambda-binders of RHS; should match patterns+         -> InExpr      -- Body of the original function+         -> (CallPat, Int)+         -> UniqSM (ScUsage, OneSpec, SpecFailWarnings)   -- Rule and binding, warnings if any++-- spec_one creates a specialised copy of the function, together+-- with a rule for using it.  I'm very proud of how short this+-- function is, considering what it does :-).++{-+  Example++     In-scope: a, x::a+     f = /\b \y::[(a,b)] -> ....f (b,c) ((:) (a,(b,c)) (x,v) (h w))...+          [c::*, v::(b,c) are presumably bound by the (...) part]+  ==>+     f_spec = /\ b c \ v::(b,c) hw::[(a,(b,c))] ->+                  (...entire body of f...) [b -> (b,c),+                                            y -> ((:) (a,(b,c)) (x,v) hw)]++     RULE:  forall b::* c::*,           -- Note, *not* forall a, x+                   v::(b,c),+                   hw::[(a,(b,c))] .++            f (b,c) ((:) (a,(b,c)) (x,v) hw) = f_spec b c v hw+-}++spec_one env fn arg_bndrs body (call_pat, rule_number)+  | CP { cp_qvars = qvars, cp_args = pats, cp_strict_args = cbv_args } <- call_pat+  = do  { -- pprTraceM "spec_one {" (ppr fn <+> ppr pats)++        ; spec_uniq <- getUniqueM+        ; let env1 = extendScSubstList (extendScInScope env qvars)+                                       (arg_bndrs `zip` pats)+              (body_env, extra_bndrs) = extendBndrs env1 (dropList pats arg_bndrs)+              -- Remember, there may be fewer pats than arg_bndrs+              -- See Note [SpecConstr call patterns]+              -- extra_bndrs will then be arguments in the specialized version+              -- which are *not* applied to arguments immediately at the call sites.+              -- e.g. let f x y = ... in map (f True) xs+              -- will result in y becoming an extra_bndr++              fn_name  = idName fn+              fn_loc   = nameSrcSpan fn_name+              fn_occ   = nameOccName fn_name+              spec_occ = mkSpecOcc fn_occ+              -- We use fn_occ rather than fn in the rule_name string+              -- as we don't want the uniq to end up in the rule, and+              -- hence in the ABI, as that can cause spurious ABI+              -- changes (#4012).+              rule_name  = mkFastString ("SC:" ++ occNameString fn_occ ++ show rule_number)+              spec_name  = mkInternalName spec_uniq spec_occ fn_loc++        -- Specialise the body+        -- ; pprTraceM "body_subst_for" $ ppr (spec_occ) $$ ppr (sc_subst body_env)+        ; (spec_usg, spec_body, body_warnings) <- scExpr body_env body++                -- And build the results+        ; (qvars', pats') <- generaliseDictPats qvars pats+        ; let spec_body_ty = exprType spec_body+              (spec_lam_args, spec_call_args, spec_sig)+                  = calcSpecInfo fn arg_bndrs call_pat extra_bndrs++              spec_arity = count isId spec_lam_args+              spec_join_arity | isJoinId fn = JoinPoint (length spec_call_args)+                              | otherwise   = NotJoinPoint+              spec_id    = asWorkerLikeId $+                           mkLocalId spec_name ManyTy+                                     (mkLamTypes spec_lam_args spec_body_ty)+                             -- See Note [Transfer strictness]+                             `setIdDmdSig`    spec_sig+                             `setIdCprSig`    topCprSig+                             `setIdArity`     spec_arity+                             `asJoinId_maybe` spec_join_arity++        -- Conditionally use result of new worker-wrapper transform+        -- mkSeqs: see Note [SpecConstr and strict fields]+              spec_rhs = mkLams spec_lam_args (mkSeqs cbv_args spec_body_ty spec_body)+              rule_rhs = mkVarApps (Var spec_id) spec_call_args+              inline_act = idInlineActivation fn+              this_mod   = sc_module $ sc_opts env+              rule       = mkRule this_mod True {- Auto -} True {- Local -}+                                  rule_name inline_act+                                  fn_name qvars' pats' rule_rhs+                           -- See Note [Transfer activation]++--        ; pprTraceM "spec_one end }" $+--          vcat [ text "function:" <+> ppr fn <+> braces (ppr (idUnique fn))+--               , text "pats:" <+> ppr pats+--               , text "call_pat:" <+> ppr call_pat+--               , text "-->" <+> ppr spec_name+--               , text "bndrs" <+> ppr arg_bndrs+--               , text "extra_bndrs" <+> ppr extra_bndrs+--               , text "cbv_args" <+> ppr cbv_args+--               , text "spec_lam_args" <+> ppr spec_lam_args+--               , text "spec_call_args" <+> ppr spec_call_args+--               , text "rule_rhs" <+> ppr rule_rhs+--               , text "adds_void_worker_arg" <+> ppr add_void_arg+----               , text "body" <+> ppr body+----               , text "spec_rhs" <+> ppr spec_rhs+----               , text "how_bound" <+> ppr (sc_how_bound env) ]+--               ]+        ; return (spec_usg, OS { os_pat = call_pat, os_rule = rule+                               , os_id = spec_id+                               , os_rhs = spec_rhs }, body_warnings) }++generaliseDictPats :: [Var] -> [CoreExpr]  -- Quantified vars and pats+                   -> UniqSM ([Var], [CoreExpr]) -- New quantified vars and pats+-- See Note [generaliseDictPats]+generaliseDictPats qvars pats+  = do { (extra_qvars, pats') <- mapAccumLM go [] pats+       ; case extra_qvars of+             [] -> return (qvars,                pats)+             _  -> return (qvars ++ extra_qvars, pats') }+  where+    qvar_set = mkVarSet qvars+    go :: [Id] -> CoreExpr -> UniqSM ([Id], CoreExpr)+    go extra_qvs pat+       | not (isTyCoArg pat)+       , let pat_ty = exprType pat+       , typeDeterminesValue pat_ty+       , exprFreeVars pat `disjointVarSet` qvar_set+       = do { id <- mkSysLocalOrCoVarM (fsLit "dict") ManyTy pat_ty+            ; return (id:extra_qvs, Var id) }+       | otherwise+       = return (extra_qvs, pat)++mkSeqs :: [Var] -> Type -> CoreExpr -> CoreExpr+-- See Note [SpecConstr and strict fields]+mkSeqs seqees res_ty rhs =+  foldr addEval rhs seqees+    where+      addEval :: Var -> CoreExpr -> CoreExpr+      addEval arg_id rhs+        -- Argument representing strict field and it's worth passing via cbv+        | shouldStrictifyIdForCbv arg_id+        = Case (Var arg_id)+               (localiseId arg_id)  -- See (SCF1) in Note [SpecConstr and strict fields]+               res_ty+               ([Alt DEFAULT [] rhs])++        | otherwise+        = rhs+++{- Note [SpecConstr void argument insertion]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider a function+    f :: Bool -> forall t. blah+    f start @t = e+We want to specialize for a partially applied call `f True`.+See also Note [SpecConstr call patterns], second Wrinkle.+Naively we would expect to get+    $sf :: forall t. blah+    $sf @t = $se+    RULE: f True = $sf+The specialized function only takes a single type argument so we add a+void argument to prevent it from turning into a thunk. See Note+[Protecting the last value argument] for details why. Normally we+would add the void argument after the type argument giving us:++    $sf :: forall t. Void# -> bla+    $sf @t void = $se+    RULE: f True = $sf void# (wrong)++But if you look closely this wouldn't typecheck!  If we substitute `f+True` with `$sf void#` we expect the type argument to be applied first+but we apply void# first.  The easiest fix seems to be just to add the+void argument to the front of the arguments.  Now we get:++    $sf :: Void# -> forall t. bla+    $sf void @t = $se+    RULE: f True = $sf void#++And now we can substitute `f True` with `$sf void#` with everything working out nicely!++More precisely, in `calcSpecInfo`+(i)  we need the void arg to /precede/ the `extra_bndrs`, but+(ii) it must still /follow/ `qvar_bndrs`.++Example to illustrate (ii):+  f :: forall r (a :: TYPE r). Bool -> a+  f = /\r. /\(a::TYPE r). \b. body++  {- Specialise for f _ _ True -}++  $sf :: forall r (a :: TYPE r). Void# -> a+  $sf = /\r. /\(a::TYPE r). \v. body[True/b]+  RULE: forall r (a :: TYPE r). f @r @a True = $sf @r @a void#++The void argument must follow the foralls, lest the forall be+ill-kinded.  See Note [Worker/wrapper needs to add void arg last] in+GHC.Core.Opt.WorkWrap.Utils.++Note [generaliseDictPats]+~~~~~~~~~~~~~~~~~~~~~~~~~+Consider these two rules (#21831, item 2):+  RULE "SPEC:foo"  forall d1 d2. foo @Int @Integer d1 d2 = $sfoo1+  RULE "SC:foo"    forall a. foo @Int @a $fNumInteger = $sfoo2 @a+The former comes from the type class specialiser, the latter from SpecConstr.+Note that $fNumInteger is a top-level binding for Num Integer.++The trouble is that neither is more general than the other.  In a call+   (foo @Int @Integer $fNumInteger d)+it isn't clear which rule to fire.++The trouble is that the SpecConstr rule fires on a /specific/ dict, $fNumInteger,+but actually /could/ fire regardless.  That is, it could be+  RULE "SC:foo"    forall a d. foo @Int @a d = $sfoo2 @a++Now, it is clear that SPEC:foo is more specific.  But GHC can't tell+that, because SpecConstr doesn't know that dictionary arguments are+singleton types!  So generaliseDictPats teaches it this fact.  It+spots such patterns (using typeDeterminesValue), and quantifies over+the dictionary.  Now we get++  RULE "SC:foo"    forall a d. foo @Int @a d = $sfoo2 @a++And /now/ "SPEC:foo" is clearly more specific: we can instantiate the new+"SC:foo" to match the (prefix of) "SPEC:foo".+-}++calcSpecInfo :: Id           -- The original function+             -> [InVar]      -- Lambda binders of original RHS+             -> CallPat      -- Call pattern+             -> [Var]        -- Extra bndrs+             -> ( [Var]           -- Demand-decorated lambda binders+                                  --   for RHS of specialised function+                , [Var]           -- Args for call site+                , DmdSig )        -- Strictness of specialised thing+-- Calculate bits of IdInfo for the specialised function+-- See Note [Transfer strictness]+-- See Note [Strictness information in worker binders]+calcSpecInfo fn arg_bndrs (CP { cp_qvars = qvars, cp_args = pats }) extra_bndrs+  = ( spec_lam_bndrs_w_dmds+    , spec_call_args+    , zapDmdEnvSig (DmdSig (dt{dt_args = spec_fn_dmds})) )+  where+    DmdSig dt@DmdType{dt_args=fn_dmds} = idDmdSig fn+    spec_fn_dmds = [idDemandInfo b | b <- spec_lam_bndrs_w_dmds, isId b]++    val_pats   = filterOut isTypeArg pats+                 -- Value args at call sites, used to determine how many demands to drop+                 -- from the original functions demand and for setting up arg_dmd_env.+    arg_dmd_env = go emptyVarEnv fn_dmds val_pats+    qvar_dmds  = [ lookupVarEnv arg_dmd_env qv `orElse` topDmd | qv <- qvars, isId qv ]+    extra_dmds = dropList val_pats fn_dmds++    -- Annotate the variables with the strictness information from+    -- the function (see Note [Strictness information in worker binders])+    qvars_w_dmds          = set_dmds qvars       qvar_dmds+    extras_w_dmds         = set_dmds extra_bndrs extra_dmds+    spec_lam_bndrs_w_dmds = final_qvars_w_dmds ++ extras_w_dmds++    (final_qvars_w_dmds, spec_call_args)+       | needsVoidWorkerArg fn arg_bndrs (qvars ++ extra_bndrs)+         -- Usual w/w hack to avoid generating+         -- a spec_rhs of unlifted or ill-kinded type and no args.+         -- See Note [SpecConstr void argument insertion]+       = ( qvars_w_dmds ++ [voidArgId], qvars ++ [voidPrimId] )+       | otherwise+       = ( qvars_w_dmds,                qvars )++    set_dmds :: [Var] -> [Demand] -> [Var]+    set_dmds [] _   = []+    set_dmds vs  [] = vs  -- Run out of demands+    set_dmds (v:vs) ds@(d:ds') | isTyVar v = v                   : set_dmds vs ds+                               | otherwise = setIdDemandInfo v d : set_dmds vs ds'++    go :: VarEnv Demand -> [Demand] -> [CoreExpr] -> VarEnv Demand+    -- We've filtered out all the type patterns already+    go env (d:ds) (pat : pats)     = go (go_one env d pat) ds pats+    go env _      _                = env++    go_one :: VarEnv Demand -> Demand -> CoreExpr -> VarEnv Demand+    go_one env d          (Var v) = extendVarEnv_C plusDmd env v d+    go_one env (_n :* cd) e -- NB: _n does not have to be strict+      | (Var _, args) <- collectArgs e+      , Just (_b, ds) <- viewProd (length args) cd -- TODO: We may want to look at boxity _b, though...+      = go env ds args+    go_one env _  _ = env++{-+Note [spec_usg includes rhs_usg]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In calls to 'specialise', the returned ScUsage must include the rhs_usg in+the passed-in SpecInfo in si_mb_unspec, unless there are no calls at all to+the function.++The caller can, indeed must, assume this.  They should not combine in rhs_usg+themselves, or they'll get rhs_usg twice -- and that can lead to an exponential+blowup of duplicates in the CallEnv.  This is what gave rise to the massive+performance loss in #8852.++Note [Specialise original body]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The RhsInfo for a binding keeps the *original* body of the binding.  We+must specialise that, *not* the result of applying specExpr to the RHS+(which is also kept in RhsInfo). Otherwise we end up specialising a+specialised RHS, and that can lead directly to exponential behaviour.++Note [Transfer activation]+~~~~~~~~~~~~~~~~~~~~~~~~~~+  This note is for SpecConstr, but exactly the same thing+  happens in the overloading specialiser; see+  Note [Auto-specialisation and RULES] in GHC.Core.Opt.Specialise.++In which phase should the specialise-constructor rules be active?+Originally I made them always-active, but Manuel found that this+defeated some clever user-written rules.  Then I made them active only+in FinalPhase; after all, currently, the specConstr transformation is+only run after the simplifier has reached FinalPhase, but that meant+that specialisations didn't fire inside wrappers; see test+simplCore/should_compile/spec-inline.++So now I just use the inline-activation of the parent Id, as the+activation for the specialisation RULE, just like the main specialiser;++This in turn means there is no point in specialising NOINLINE things,+so we test for that.++Note [Transfer strictness]+~~~~~~~~~~~~~~~~~~~~~~~~~~+We must transfer strictness information from the original function to+the specialised one.  Suppose, for example++  f has strictness     SSx+        and a RULE     f (a:as) b = f_spec a as b++Now we want f_spec to have strictness  LLSx, otherwise we'll use call-by-need+when calling f_spec instead of call-by-value.  And that can result in+unbounded worsening in space (cf the classic foldl vs foldl')++See #3437 for a good example.++The function calcSpecStrictness performs the calculation.++Note [Strictness information in worker binders]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+After having calculated the strictness annotation for the worker (see Note+[Transfer strictness] above), we also want to have this information attached to+the worker’s arguments, for the benefit of later passes. The function+handOutStrictnessInformation decomposes the strictness annotation calculated by+calcSpecStrictness and attaches them to the variables.+++************************************************************************+*                                                                      *+\subsection{Argument analysis}+*                                                                      *+************************************************************************++This code deals with analysing call-site arguments to see whether+they are constructor applications.++Note [Free type variables of the qvar types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In a call (f @a x True), that we want to specialise, what variables should+we quantify over.  Clearly over 'a' and 'x', but what about any type variables+free in x's type?  In fact we don't need to worry about them because (f @a)+can only be a well-typed application if its type is compatible with x, so any+variables free in x's type must be free in (f @a), and hence either be gathered+via 'a' itself, or be in scope at f's defn.  Hence we just take+  (exprsFreeVars pats).++BUT phantom type synonyms can mess this reasoning up,+  eg   x::T b   with  type T b = Int+So we apply expandTypeSynonyms to the bound Ids.+See # 5458.  Yuk.++Note [SpecConstr call patterns]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A "call patterns" that we collect is going to become the LHS of a RULE.++Wrinkles:++* The list of argument patterns, cp_args, is no longer than the+  visible lambdas of the binding, ri_arg_occs.  This is done via+  the zipWithM in callToPat.++* The list of argument patterns can certainly be shorter than the+  lambdas in the function definition (under-saturated).  For example+      f x y = case x of { True -> e1; False -> e2 }+      ....map (f True) e...+  We want to specialise `f` for `f True`.++* In fact we deliberately shrink the list of argument patterns,+  cp_args, by trimming off all the boring ones at the end (see+  `dropWhileEnd is_boring` in callToPat).  Since the RULE only+  applies when it is saturated, this shrinking makes the RULE more+  applicable.  But it does mean that the argument patterns do not+  necessarily saturate the lambdas of the function.++* It's important that the pattern arguments do not look like+     e |> Refl+  or+    e |> g1 |> g2+  because both of these will be optimised by Simplify.simplRule. In the+  former case such optimisation benign, because the rule will match more+  terms; but in the latter we may lose a binding of 'g1' or 'g2', and+  end up with a rule LHS that doesn't bind the template variables+  (#10602).++  The simplifier eliminates such things, but SpecConstr itself constructs+  new terms by substituting.  So the 'mkCast' in the Cast case of scExpr+  is very important!++Note [Choosing patterns]+~~~~~~~~~~~~~~~~~~~~~~~~+If we get lots of patterns we may not want to make a specialisation+for each of them (code bloat), so we choose as follows, implemented+by trim_pats.++* The flag -fspec-constr-count-N sets the sc_count field+  of the ScEnv to (Just n).  This limits the total number+  of specialisations for a given function to N.++* -fno-spec-constr-count sets the sc_count field to Nothing,+  which switches of the limit.++* The ghastly ForceSpecConstr trick also switches of the limit+  for a particular function++* Otherwise we sort the patterns to choose the most general+  ones first; more general => more widely applicable.++Note [SpecConstr and casts]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider (#14270) a call like++    let f = e+    in ... f (K @(a |> cv)) ...++where 'cv' is a coercion variable not in scope at f's definition site.+If we aren't careful we'll get++    let $sf a cv = e (K @(a |> cv))+        RULE "SC:f" forall a cv.  f (K @(a |> cv)) = $sf a co+        f = e+    in ...++But alas, when we match the call we may fail to bind 'co', because the rule+matcher in GHC.Core.Rules cannot reliably bind coercion variables that appear+in casts (see Note [Casts in the template] in GHC.Core.Rules).++This seems intractable (see #23209). So:++* Key point: we /never/ quantify over coercion variables in a SpecConstr rule.+  If we would need to quantify over a coercion variable, we just discard the+  call pattern. See the test for `bad_covars` in callToPat.++* However (#14936) we /do/ still allow casts in call patterns. For example+     f ((e1,e2) |> sym co)+  where, say,+     f  :: Foo -> blah   -- Foo is a newtype+     f = f_rhs+     co :: Foo ~R (Int,Int)+  We want to specialise on that pair!++So for our function f, we might generate+  RULE forall x y.  f ((x,y) |> co) = $sf x y+  $sf x y = f_rhs ((x,y) |> co)++This works provided the free vars of `co` are either in-scope at the+definition of `f`, or quantified. For the latter, suppose `f` was polymorphic:++     f2  :: Foo2 a -> blah   -- Foo is a newtype+     f2 = f2_rhs+     co2 :: Foo a ~R (a,a)++Then it's fine for `co2` to mention `a`.  We'll get+  RULE forall a (x::a) (y::a).  f2 @a ((x,y) |> co2) = $sf2 a x y+  $sf2 @a x y = f2_rhs ((x,y) |> co2)+-}++data CallPat = CP { cp_qvars :: [Var]           -- Quantified variables+                  , cp_args  :: [CoreExpr]      -- Arguments+                  , cp_strict_args :: [Var] }   -- Arguments we want to pass unlifted even if they are boxed+                                                -- See Note [SpecConstr and strict fields]++     -- See Note [SpecConstr call patterns]++instance Outputable CallPat where+  ppr (CP { cp_qvars = qvars, cp_args = args, cp_strict_args =  strict })+    = text "CP" <> braces (sep [ text "cp_qvars =" <+> ppr qvars <> comma+                               , text "cp_args =" <+> ppr args+                               , text "cp_strict_args = " <> ppr strict ])++newtype SpecFailWarning = SpecFailForcedArgCount { spec_failed_fun_name :: Name }++type SpecFailWarnings = [SpecFailWarning]++instance Outputable SpecFailWarning where+  ppr (SpecFailForcedArgCount name) = ppr name <+> pprDefinedAt name++combineSpecWarning :: SpecFailWarnings -> SpecFailWarnings -> SpecFailWarnings+combineSpecWarning = (++)++data ArgCountResult = WorkerSmallEnough | WorkerTooLarge | WorkerTooLargeForced Name++callsToNewPats :: ScEnv -> Id+               -> SpecInfo+               -> [ArgOcc] -> [Call]+               -> UniqSM ( Bool        -- At least one boring call+                         , Bool        -- Patterns were discarded+                         , [CallPat]   -- Patterns to specialise+                         , [SpecFailWarning] -- Things that didn't specialise we want to warn the user about)+                         )+-- Result has no duplicate patterns,+-- nor ones mentioned in si_specs (hence "new" patterns)+-- Bool indicates that there was at least one boring pattern+-- The "New" in the name means "patterns that are not already covered+-- by an existing specialisation"+callsToNewPats env fn spec_info@(SI { si_specs = done_specs }) bndr_occs calls+  = do  { mb_pats <- mapM (callToPat env bndr_occs) calls++        ; let have_boring_call = any isNothing mb_pats++              good_pats :: [CallPat]+              good_pats = catMaybes mb_pats++              in_scope = substInScopeSet (sc_subst env)++              -- Remove patterns we have already done+              new_pats = filterOut is_done good_pats+              is_done p = any is_better done_specs+                 where+                   is_better done = betterPat in_scope (os_pat done) p++              -- Remove duplicates+              non_dups = subsumePats in_scope new_pats++              -- Remove ones that have too many worker variables+              (small_pats, arg_count_warnings) = partitionByWorkerSize too_many_worker_args non_dups++              -- too_many_worker_args :: CallPat -> Either SpecFailWarning Bool+              too_many_worker_args (CP { cp_qvars = vars, cp_args = args })+                | sc_force env+                -- See (FS5) of Note [Forcing specialisation]+                = if (isWorkerSmallEnough (sc_max_forced_args $ sc_opts env) (valArgCount args) vars)+                    then WorkerSmallEnough+                    else WorkerTooLargeForced (idName fn)+                | (isWorkerSmallEnough (sc_max_args $ sc_opts env) (valArgCount args) vars)+                = WorkerSmallEnough+                | otherwise = WorkerTooLarge+                  -- We are about to construct w/w pair in 'spec_one'.+                  -- Omit specialisation leading to high arity workers.+                  -- See Note [Limit w/w arity] in GHC.Core.Opt.WorkWrap.Utils++                -- Discard specialisations if there are too many of them+              (pats_were_discarded, trimmed_pats) = trim_pats env fn spec_info small_pats++--        ; pprTraceM "callsToPats" (vcat [ text "calls to" <+> ppr fn <> colon <+> ppr calls+--                                        , text "good_pats:" <+> ppr good_pats+--                                        , text "new_pats:" <+> ppr new_pats+--                                        , text "non_dups:" <+> ppr non_dups+--                                        , text "small_pats:" <+> ppr small_pats+--                                        , text "done_specs:" <+> ppr (map os_pat done_specs)+--                                        , text "trimmed_pats:" <+> ppr trimmed_pats ])++        ; return (have_boring_call, pats_were_discarded, trimmed_pats, arg_count_warnings) }+          -- If any of the calls does not give rise to a specialisation, either+          -- because it is boring, or because there are too many specialisations,+          -- return a flag to say so, so that we know to keep the original function.+  where+    partitionByWorkerSize worker_size pats = go pats [] []+      where+        go [] small warnings = (small, warnings)+        go (p:ps) small warnings =+          case worker_size p of+            WorkerSmallEnough -> go ps (p:small) warnings+            WorkerTooLarge -> go ps small warnings+            WorkerTooLargeForced name -> go ps small (SpecFailForcedArgCount name : warnings)+++trim_pats :: ScEnv -> Id -> SpecInfo -> [CallPat] -> (Bool, [CallPat])+-- True <=> some patterns were discarded+-- See Note [Choosing patterns]+trim_pats env fn (SI { si_n_specs = done_spec_count }) pats+  | False <- sc_force env+  , Just max_specs <- mb_scc+  , let n_remaining = max_specs - done_spec_count+  , n_remaining < n_pats+  = emit_trace max_specs n_remaining $  -- Need to trim, so keep the best ones+    (True, take n_remaining sorted_pats)++  | otherwise+  = -- pprTrace "trim_pats: no-trim" (ppr (sc_force env) $$ ppr mb_scc $$ ppr n_remaining $$ ppr n_pats)+    (False, pats)          -- No need to trim++  where+    n_pats         = length pats+    spec_count'    = n_pats + done_spec_count+    mb_scc         = sc_count $ sc_opts env++    sorted_pats = map fst $+                  sortBy (comparing snd) $+                  [(pat, pat_cons pat) | pat <- pats]+     -- Sort in order of increasing number of constructors+     -- (i.e. decreasing generality) and pick the initial+     -- segment of this list++    pat_cons :: CallPat -> Int+    -- How many data constructors of literals are in+    -- the pattern.  More data-cons => less general+    pat_cons (CP { cp_qvars = qs, cp_args = ps })+       = foldr ((+) . n_cons) 0 ps+       where+          q_set = mkVarSet qs+          n_cons (Var v) | v `elemVarSet` q_set = 0+                         | otherwise            = 1+          n_cons (Cast e _)  = n_cons e+          n_cons (App e1 e2) = n_cons e1 + n_cons e2+          n_cons (Lit {})    = 1+          n_cons _           = 0++    emit_trace max_specs n_remaining result+       | debugIsOn || sc_debug (sc_opts env)+         -- Suppress this scary message for ordinary users!  #5125+       = pprTrace "SpecConstr" msg result+       | otherwise+       = result+      where+        msg = vcat+          [ sep+              [ text "Function" <+> quotes (ppr fn)+              , nest 2+                  ( text "has" <+>+                    speakNOf spec_count' (text "call pattern") <> comma <+>+                    text "but the limit is" <+> int max_specs ) ]+          , text "Use -fspec-constr-count=n to set the bound"+          , text "done_spec_count =" <+> int done_spec_count+          , text "Keeping " <+> int n_remaining <> text ", out of" <+> int n_pats+          , text "Discarding:" <+> ppr (drop n_remaining sorted_pats) ]++callToPat :: ScEnv -> [ArgOcc] -> Call -> UniqSM (Maybe CallPat)+        -- The [Var] is the variables to quantify over in the rule+        --      Type variables come first, since they may scope+        --      over the following term variables+        -- The [CoreExpr] are the argument patterns for the rule+callToPat env bndr_occs call@(Call fn args con_env)+  = do  { let in_scope = substInScopeSet (sc_subst env)++        ; arg_triples <- zipWith3M (argToPat env in_scope con_env) args bndr_occs (map (const NotMarkedStrict) args)+                   -- This zip trims the args to be no longer than+                   -- the lambdas in the function definition (bndr_occs)++          -- Drop boring patterns from the end+          -- See Note [SpecConstr call patterns]+        ; let arg_triples' | isJoinId fn     = arg_triples+                           | otherwise       = dropWhileEnd is_boring arg_triples+              is_boring (interesting, _,_)   = not interesting+              (interesting_s, pats, cbv_ids) = unzip3 arg_triples'+              interesting                    = or interesting_s++        ; let pat_fvs = exprsFreeVarsList pats+                -- To get determinism we need the list of free variables in+                -- deterministic order. Otherwise we end up creating+                -- lambdas with different argument orders. See+                -- determinism/simplCore/should_compile/spec-inline-determ.hs+                -- for an example. For explanation of determinism+                -- considerations See Note [Unique Determinism] in GHC.Types.Unique.++              in_scope_vars = getInScopeVars in_scope+              is_in_scope v = v `elemVarSet` in_scope_vars+              qvars         = filterOut is_in_scope pat_fvs+                -- Quantify over variables that are not in scope+                -- at the call site+                -- See Note [Free type variables of the qvar types]+                -- See Note [Shadowing in SpecConstr] at the top++              (qktvs, qids) = partition isTyVar qvars+              qvars'        = scopedSort qktvs ++ map sanitise qids+                -- Order into kind variables, type variables, term variables+                -- The kind of a type variable may mention a kind variable+                -- and the type of a term variable may mention a type variable++              sanitise id = updateIdTypeAndMult expandTypeSynonyms id+                -- See Note [Free type variables of the qvar types]++        -- Check for bad coercion variables: see Note [SpecConstr and casts]+        ; let bad_covars = filter isCoVar qids+        ; warnPprTrace (not (null bad_covars))+              "SpecConstr: bad covars"+              (ppr bad_covars $$ ppr call) $++          if interesting && null bad_covars+          then do { let cp_res = CP { cp_qvars = qvars', cp_args = pats+                                    , cp_strict_args = concat cbv_ids }+--                  ; pprTraceM "callToPatOut" $+--                    vcat [ text "fn:" <+> ppr fn+--                         , text "args:" <+> ppr args+--                         , text "bndr_occs:" <+> ppr bndr_occs+--                         , text "pat_fvs:" <+> ppr pat_fvs+--                         , text "cp_res:" <+> ppr cp_res ]+                  ; return (Just cp_res) }+          else return Nothing }++    -- argToPat takes an actual argument, and returns an abstracted+    -- version, consisting of just the "constructor skeleton" of the+    -- argument, with non-constructor sub-expression replaced by new+    -- placeholder variables.  For example:+    --    C a (D (f x) (g y))  ==>  C p1 (D p2 p3)++argToPat :: ScEnv+         -> InScopeSet                  -- What's in scope at the fn defn site+         -> ValueEnv                    -- ValueEnv at the call site+         -> CoreArg                     -- A call arg (or component thereof)+         -> ArgOcc+         -> StrictnessMark              -- Tells us if this argument is a strict field of a data constructor+                                        -- See Note [SpecConstr and strict fields]+         -> UniqSM (Bool, CoreArg, [Id])++-- Returns (interesting, pat),+-- where pat is the pattern derived from the argument+--            interesting=True if the pattern is non-trivial (not a variable or type)+-- E.g.         x:xs         --> (True, x:xs)+--              f xs         --> (False, w)        where w is a fresh wildcard+--              (f xs, 'c')  --> (True, (w, 'c'))  where w is a fresh wildcard+--              \x. x+y      --> (True, \x. x+y)+--              lvl7         --> (True, lvl7)      if lvl7 is bound+--                                                 somewhere further out++argToPat env in_scope val_env arg arg_occ arg_str+  = do+    -- pprTraceM "argToPatIn" (ppr arg)+    !res <- argToPat1 env in_scope val_env arg arg_occ arg_str+    -- pprTraceM "argToPatOut" (ppr res)+    return res++argToPat1 :: ScEnv+  -> InScopeSet+  -> ValueEnv+  -> Expr CoreBndr+  -> ArgOcc+  -> StrictnessMark+  -> UniqSM (Bool, Expr CoreBndr, [Id])+argToPat1 _env _in_scope _val_env arg@(Type {}) _arg_occ _arg_str+  = return (False, arg, [])++argToPat1 env in_scope val_env (Tick _ arg) arg_occ arg_str+  = argToPat env in_scope val_env arg arg_occ arg_str+        -- Note [Tick annotations in call patterns]+        -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+        -- Ignore Notes.  In particular, we want to ignore any InlineMe notes+        -- Perhaps we should not ignore profiling notes, but I'm going to+        -- ride roughshod over them all for now.+        --- See Note [Tick annotations in RULE matching] in GHC.Core.Rules++argToPat1 env in_scope val_env (Let _ arg) arg_occ arg_str+  = argToPat env in_scope val_env arg arg_occ arg_str+        -- See Note [Matching lets] in "GHC.Core.Rules"+        -- Look through let expressions+        -- e.g.         f (let v = rhs in (v,w))+        -- Here we can specialise for f (v,w)+        -- because the rule-matcher will look through the let.++   -- Casts: see Note [SpecConstr and casts]+argToPat1 env in_scope val_env (Cast arg co) arg_occ arg_str+  | not (ignoreType env ty2)+  = do  { (interesting, arg', strict_args) <- argToPat env in_scope val_env arg arg_occ arg_str+        ; if not interesting then+                wildCardPat ty2 arg_str+          else+                return (interesting, Cast arg' co, strict_args) }+  where+    ty2 = coercionRKind co++  -- Check for a constructor application+  -- NB: this *precedes* the Var case, so that we catch nullary constrs+argToPat1 env in_scope val_env arg arg_occ _arg_str+  | Just (ConVal _wf (DataAlt dc) args) <- isValue val_env arg+    -- Ignore `_wf` here; see Note [ConVal work-free-ness] (2)+  , not (ignoreDataCon env dc)        -- See Note [NoSpecConstr]+  , Just arg_occs <- mb_scrut dc+  = do { let (ty_args, rest_args) = splitAtList (dataConUnivTyVars dc) args+             con_str, matched_str :: [StrictnessMark]+             -- con_str corresponds 1-1 with the /value/ arguments+             -- matched_str corresponds 1-1 with /all/ arguments+             con_str = dataConRepStrictness dc+             matched_str = match_vals con_str rest_args+      --  ; pprTraceM "bangs" (ppr (length rest_args == length con_str) $$+      --       ppr dc $$+      --       ppr con_str $$+      --       ppr rest_args $$+      --       ppr (map isTypeArg rest_args))+       ; prs <- zipWith3M (argToPat env in_scope val_env) rest_args arg_occs matched_str+       ; let args' = map sndOf3 prs :: [CoreArg]+       ; assertPpr (length con_str == length (filter isRuntimeArg rest_args))+            ( ppr con_str $$ ppr rest_args $$+              ppr (length con_str) $$ ppr (length rest_args)+            ) $ return ()+       ; return (True, mkConApp dc (ty_args ++ args'), concat (map thdOf3 prs)) }+  where+    mb_scrut dc = case arg_occ of+                ScrutOcc bs | Just occs <- lookupUFM bs dc+                            -> Just (occs)  -- See Note [Reboxing]+                _other      | sc_force env || sc_keen (sc_opts env)+                            -> Just (repeat UnkOcc)+                            | otherwise+                            -> Nothing+    match_vals bangs (arg:args)+      | isTypeArg arg+      = NotMarkedStrict : match_vals bangs args+      | (b:bs) <- bangs+      = b : match_vals bs args+    match_vals [] [] = []+    match_vals as bs =+        pprPanic "spec-constr:argToPat - Bangs don't match value arguments"+            (text "arg:" <> ppr arg $$+             text "remaining args:" <> ppr as $$+             text "remaining bangs:" <> ppr bs)++  -- Check if the argument is a variable that+  --    (a) is used in an interesting way in the function body+  ---       i.e. ScrutOcc. UnkOcc and NoOcc are not interesting+  --        (NoOcc means we could drop the argument, but that's the+  --         business of absence analysis, not SpecConstr.)+  --    (b) we know what its value is+  -- In that case it counts as "interesting"+argToPat1 env in_scope val_env (Var v) arg_occ arg_str+  | sc_force env || specialisableArgOcc arg_occ  -- (a)+    -- See Note [Forcing specialisation], point (FS3)+  , is_value                                     -- (b)+       -- Ignoring sc_keen here to avoid gratuitously incurring Note [Reboxing]+       -- So sc_keen focused just on f (I# x), where we have freshly-allocated+       -- box that we can eliminate in the caller+  , not (ignoreType env (varType v))+  -- See Note [SpecConstr and strict fields]+  = return (True, Var v, if isMarkedStrict arg_str then [v] else mempty)+  where+    is_value+        | isLocalId v = v `elemInScopeSet` in_scope+                        && isJust (lookupVarEnv val_env v)+                -- Local variables have values in val_env+        | otherwise   = isValueUnfolding (idUnfolding v)+                -- Imports have unfoldings++--      I'm really not sure what this comment means+--      And by not wild-carding we tend to get forall'd+--      variables that are in scope, which in turn can+--      expose the weakness in let-matching+--      See Note [Matching lets] in GHC.Core.Rules++  -- Check for a variable bound inside the function.+  -- Don't make a wild-card, because we may usefully share+  --    e.g.  f a = let x = ... in f (x,x)+  -- NB: this case follows the lambda and con-app cases!!+-- argToPat _in_scope _val_env (Var v) _arg_occ+--   = return (False, Var v)+        -- SLPJ : disabling this to avoid proliferation of versions+        -- also works badly when thinking about seeding the loop+        -- from the body of the let+        --       f x y = letrec g z = ... in g (x,y)+        -- We don't want to specialise for that *particular* x,y+++{- Disabled; see Note [Matching cases] in "GHC.Core.Rules"+argToPat env in_scope val_env (Case scrut _ _ [(_, _, rhs)]) arg_occ+  | exprOkForSpeculation scrut  -- See Note [Matching cases] in "GHC.Core.Rules"+  = argToPat env in_scope val_env rhs arg_occ+-}++{-      Disabling lambda specialisation for now+        It's fragile, and the spec_loop can be infinite+argToPat in_scope val_env arg arg_occ+  | is_value_lam arg+  = return (True, arg)+  where+    is_value_lam (Lam v e)         -- Spot a value lambda, even if+        | isId v       = True      -- it is inside a type lambda+        | otherwise    = is_value_lam e+    is_value_lam other = False+-}++  -- The default case: make a wild-card+  -- We use this for coercions too+argToPat1 _env _in_scope _val_env arg _arg_occ arg_str+  = wildCardPat (exprType arg) arg_str++-- | wildCardPats are always boring+wildCardPat :: Type -> StrictnessMark -> UniqSM (Bool, CoreArg, [Id])+wildCardPat ty str+  = do { id <- mkSysLocalOrCoVarM (fsLit "sc") ManyTy ty+       -- ; pprTraceM "wildCardPat" (ppr id' <+> ppr (idUnfolding id'))+       ; return (False, varToCoreExpr id, if isMarkedStrict str then [id] else []) }++isValue :: ValueEnv -> CoreExpr -> Maybe Value+isValue _env (Lit lit)+  | litIsLifted lit = Nothing+  | otherwise       = Just (ConVal True (LitAlt lit) [])++isValue env (Var v)+  | Just cval <- lookupVarEnv env v+  = Just cval  -- You might think we could look in the idUnfolding here+               -- but that doesn't take account of which branch of a+               -- case we are in, which is the whole point++  | not (isLocalId v)+  , isCheapUnfolding unf+  , Just rhs <- maybeUnfoldingTemplate unf  -- Succeds if isCheapUnfolding does+  = isValue env rhs   -- Can't use isEvaldUnfolding because+                      -- we want to consult the `env`+  where+    unf = idUnfolding v+        -- However we do want to consult the unfolding+        -- as well, for let-bound constructors!++isValue env (Lam b e)+  | isTyVar b = case isValue env e of+                  Just _  -> Just LambdaVal+                  Nothing -> Nothing+  | otherwise = Just LambdaVal++isValue env (Tick t e)+  | not (tickishIsCode t)+  = isValue env e++isValue _env expr       -- Maybe it's a constructor application+  | (Var fun, args, _) <- collectArgsTicks (not . tickishIsCode) expr+  = case idDetails fun of+        DataConWorkId con | args `lengthAtLeast` dataConRepArity con+                -- Check saturated; might be > because the+                --                  arity excludes type args+                -> Just (ConVal (all exprIsWorkFree args) (DataAlt con) args)++        DFunId {} -> Just LambdaVal+        -- DFunId: see Note [Specialising on dictionaries]++        _other | valArgCount args < idArity fun+                -- Under-applied function+               -> Just LambdaVal        -- Partial application++        _other -> Nothing++isValue _env _expr = Nothing++betterPat :: InScopeSet -> CallPat -> CallPat -> Bool+-- pat1    f @a   (Just @a   (x::a))+--      is better than+-- pat2    f @Int (Just @Int (x::Int))+-- That is, we can instantiate pat1 to get pat2, using only type instantiate+-- See Note [Pattern duplicate elimination]+betterPat is (CP { cp_qvars = vs1, cp_args = as1 })+             (CP { cp_qvars = vs2, cp_args = as2 })+  | equalLength as1 as2+  = case matchExprs ise vs1 as1 as2 of+      Just (_, ms) -> all exprIsTrivial ms+      Nothing      -> False++  | otherwise -- We must handle patterns of unequal length separately (#24282)+  = False  -- For the pattern with more args, the last arg is "interesting"+           -- but the corresponding one on the other is "not interesting";+           -- So we can't get from one to the other with only exprIsTrivial+           -- instantiation.  Example nofib/spectral/ansi, function `loop`:+           --    P1: loop (I# x) (a : b)+           --    P2: loop (I# y)           -- Pattern eta-reduced+           -- Neither is better than the other, in the sense of betterPat+  where+    ise = ISE (is `extendInScopeSetList` vs2) (const noUnfolding)++subsumePats :: InScopeSet -> [CallPat] -> [CallPat]+-- Remove any patterns subsumed by others+-- See Note [Pattern duplicate elimination]+-- Other than deleting subsumed patterns, this operation is a no-op;+-- in particular it does not reverse the input.  It should not matter+-- but in #24282 it did; doing it this way keeps the existing behaviour.+subsumePats is pats = foldl add [] pats+  where+    add :: [CallPat] -> CallPat -> [CallPat]+    add []        ci                         = [ci]+    add (ci1:cis) ci2 | betterPat is ci1 ci2 = ci1 : cis+                      | betterPat is ci2 ci1 = ci2 : cis+                      | otherwise            = ci1 : add cis ci2++{-+Note [Pattern duplicate elimination]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider f :: (a,a) -> blah, and two calls+   f @Int  (x,y)+   f @Bool (p,q)++The danger is that we'll generate two *essentially identical* specialisations,+both for pairs, but with different types instantiating `a` (see #24229).++But we'll only make a `CallPat` for an argument (a,b) if `foo` scrutinises+that argument.  So SpecConstr should never need to specialise f's polymorphic+type arguments.  Even with only one of these calls we should be able to+generalise to the `CallPat`++  cp_qvars = [a, r::a, s::a], cp_args = [@a (r,s)]++Doing so isn't trivial, though.++For now we content ourselves with a simpler plan: eliminate a call pattern+if another pattern subsumes it; this is done by `subsumePats`.+For example here are two patterns++  cp_qvars = [a, r::a, s::a],  cp_args = [@a (r,s)]+  cp_qvars = [x::Int, y::Int], cp_args = [@Int (x,y)]++The first can be instantiated to the second, /by instantiating types only/.+This subsumption relationship is checked by `betterPat`.  Note that if+we have++  cp_qvars = [a, r::a, s::a], cp_args = [@a (r,s)]+  cp_qvars = [],              cp_args = [@Bool (True,False)]++the first does *not* subsume the second; the second is more specific.++In our initial example with `f @Int` and `f @Bool` neither subsumes the other,+so we will get two essentially-identical specialisations. Boo.  We rely on our+crude throttling mechanisms to stop this getting out of control -- with+polymorphic recursion we can generate an infinite number of specialisations.+Example is Data.Sequence.adjustTree, I think. -}
GHC/Core/Opt/Specialise.hs view
@@ -1,2968 +1,3669 @@---{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}--{--(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.Session-import GHC.Driver.Ppr-import GHC.Driver.Config-import GHC.Driver.Config.Diagnostic-import GHC.Driver.Env--import GHC.Tc.Utils.TcType hiding( substTy )--import GHC.Core.Type  hiding( substTy, extendTvSubstList )-import GHC.Core.Multiplicity-import GHC.Core.Predicate-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.Rules-import GHC.Core.Utils     ( exprIsTrivial, getIdFromTrivialExpr_maybe-                          , mkCast, exprType )-import GHC.Core.FVs-import GHC.Core.TyCo.Rep (TyCoBinder (..))-import GHC.Core.Opt.Arity     ( collectBindersPushingCo-                              , etaExpandToJoinPointRule )--import GHC.Builtin.Types  ( unboxedUnitTy )--import GHC.Data.Maybe     ( mapMaybe, maybeToList, isJust )-import GHC.Data.Bag-import GHC.Data.FastString-import GHC.Data.List.SetOps--import GHC.Types.Basic-import GHC.Types.Unique.Supply-import GHC.Types.Unique.DFM-import GHC.Types.Name-import GHC.Types.Tickish-import GHC.Types.Id.Make  ( voidArgId, voidPrimId )-import GHC.Types.Var      ( isLocalVar )-import GHC.Types.Var.Set-import GHC.Types.Var.Env-import GHC.Types.Id-import GHC.Types.Error--import GHC.Utils.Error ( mkMCDiagnostic )-import GHC.Utils.Monad    ( foldlM )-import GHC.Utils.Misc-import GHC.Utils.Outputable-import GHC.Utils.Panic-import GHC.Utils.Trace--import GHC.Unit.Module( Module )-import GHC.Unit.Module.ModGuts-import GHC.Unit.External--{--************************************************************************-*                                                                      *-\subsection[notes-Specialise]{Implementation notes [SLPJ, Aug 18 1993]}-*                                                                      *-************************************************************************--These notes describe how we implement specialisation to eliminate-overloading.--The specialisation pass works on Core-syntax, complete with all the explicit dictionary application,-abstraction and construction as added by the type checker.  The-existing type checker remains largely as it is.--One important thought: the {\em types} passed to an overloaded-function, and the {\em dictionaries} passed are mutually redundant.-If the same function is applied to the same type(s) then it is sure to-be applied to the same dictionary(s)---or rather to the same {\em-values}.  (The arguments might look different but they will evaluate-to the same value.)--Second important thought: we know that we can make progress by-treating dictionary arguments as static and worth specialising on.  So-we can do without binding-time analysis, and instead specialise on-dictionary arguments and no others.--The basic idea-~~~~~~~~~~~~~~-Suppose we have--        let f = <f_rhs>-        in <body>--and suppose f is overloaded.--STEP 1: CALL-INSTANCE COLLECTION--We traverse <body>, accumulating all applications of f to types and-dictionaries.--(Might there be partial applications, to just some of its types and-dictionaries?  In principle yes, but in practice the type checker only-builds applications of f to all its types and dictionaries, so partial-applications could only arise as a result of transformation, and even-then I think it's unlikely.  In any case, we simply don't accumulate such-partial applications.)---STEP 2: EQUIVALENCES--So now we have a collection of calls to f:-        f t1 t2 d1 d2-        f t3 t4 d3 d4-        ...-Notice that f may take several type arguments.  To avoid ambiguity, we-say that f is called at type t1/t2 and t3/t4.--We take equivalence classes using equality of the *types* (ignoring-the dictionary args, which as mentioned previously are redundant).--STEP 3: SPECIALISATION--For each equivalence class, choose a representative (f t1 t2 d1 d2),-and create a local instance of f, defined thus:--        f@t1/t2 = <f_rhs> t1 t2 d1 d2--f_rhs presumably has some big lambdas and dictionary lambdas, so lots-of simplification will now result.  However we don't actually *do* that-simplification.  Rather, we leave it for the simplifier to do.  If we-*did* do it, though, we'd get more call instances from the specialised-RHS.  We can work out what they are by instantiating the call-instance-set from f's RHS with the types t1, t2.--Add this new id to f's IdInfo, to record that f has a specialised version.--Before doing any of this, check that f's IdInfo doesn't already-tell us about an existing instance of f at the required type/s.-(This might happen if specialisation was applied more than once, or-it might arise from user SPECIALIZE pragmas.)--Recursion-~~~~~~~~~-Wait a minute!  What if f is recursive?  Then we can't just plug in-its right-hand side, can we?--But it's ok.  The type checker *always* creates non-recursive definitions-for overloaded recursive functions.  For example:--        f x = f (x+x)           -- Yes I know its silly--becomes--        f a (d::Num a) = let p = +.sel a d-                         in-                         letrec fl (y::a) = fl (p y y)-                         in-                         fl--We still have recursion for non-overloaded functions which we-specialise, but the recursive call should get specialised to the-same recursive version.---Polymorphism 1-~~~~~~~~~~~~~~--All this is crystal clear when the function is applied to *constant-types*; that is, types which have no type variables inside.  But what if-it is applied to non-constant types?  Suppose we find a call of f at type-t1/t2.  There are two possibilities:--(a) The free type variables of t1, t2 are in scope at the definition point-of f.  In this case there's no problem, we proceed just as before.  A common-example is as follows.  Here's the Haskell:--        g y = let f x = x+x-              in f y + f y--After typechecking we have--        g a (d::Num a) (y::a) = let f b (d'::Num b) (x::b) = +.sel b d' x x-                                in +.sel a d (f a d y) (f a d y)--Notice that the call to f is at type type "a"; a non-constant type.-Both calls to f are at the same type, so we can specialise to give:--        g a (d::Num a) (y::a) = let f@a (x::a) = +.sel a d x x-                                in +.sel a d (f@a y) (f@a y)---(b) The other case is when the type variables in the instance types-are *not* in scope at the definition point of f.  The example we are-working with above is a good case.  There are two instances of (+.sel a d),-but "a" is not in scope at the definition of +.sel.  Can we do anything?-Yes, we can "common them up", a sort of limited common sub-expression deal.-This would give:--        g a (d::Num a) (y::a) = let +.sel@a = +.sel a d-                                    f@a (x::a) = +.sel@a x x-                                in +.sel@a (f@a y) (f@a y)--This can save work, and can't be spotted by the type checker, because-the two instances of +.sel weren't originally at the same type.--Further notes on (b)--* There are quite a few variations here.  For example, the defn of-  +.sel could be floated outside the \y, to attempt to gain laziness.-  It certainly mustn't be floated outside the \d because the d has to-  be in scope too.--* We don't want to inline f_rhs in this case, because-that will duplicate code.  Just commoning up the call is the point.--* Nothing gets added to +.sel's IdInfo.--* Don't bother unless the equivalence class has more than one item!--Not clear whether this is all worth it.  It is of course OK to-simply discard call-instances when passing a big lambda.--Polymorphism 2 -- Overloading-~~~~~~~~~~~~~~-Consider a function whose most general type is--        f :: forall a b. Ord a => [a] -> b -> b--There is really no point in making a version of g at Int/Int and another-at Int/Bool, because it's only instantiating the type variable "a" which-buys us any efficiency. Since g is completely polymorphic in b there-ain't much point in making separate versions of g for the different-b types.--That suggests that we should identify which of g's type variables-are constrained (like "a") and which are unconstrained (like "b").-Then when taking equivalence classes in STEP 2, we ignore the type args-corresponding to unconstrained type variable.  In STEP 3 we make-polymorphic versions.  Thus:--        f@t1/ = /\b -> <f_rhs> t1 b d1 d2--We do this.---Dictionary floating-~~~~~~~~~~~~~~~~~~~-Consider this--        f a (d::Num a) = let g = ...-                         in-                         ...(let d1::Ord a = Num.Ord.sel a d in g a d1)...--Here, g is only called at one type, but the dictionary isn't in scope at the-definition point for g.  Usually the type checker would build a-definition for d1 which enclosed g, but the transformation system-might have moved d1's defn inward.  Solution: float dictionary bindings-outwards along with call instances.--Consider--        f x = let g p q = p==q-                  h r s = (r+s, g r s)-              in-              h x x---Before specialisation, leaving out type abstractions we have--        f df x = let g :: Eq a => a -> a -> Bool-                     g dg p q = == dg p q-                     h :: Num a => a -> a -> (a, Bool)-                     h dh r s = let deq = eqFromNum dh-                                in (+ dh r s, g deq r s)-              in-              h df x x--After specialising h we get a specialised version of h, like this:--                    h' r s = let deq = eqFromNum df-                             in (+ df r s, g deq r s)--But we can't naively make an instance for g from this, because deq is not in scope-at the defn of g.  Instead, we have to float out the (new) defn of deq-to widen its scope.  Notice that this floating can't be done in advance -- it only-shows up when specialisation is done.--User SPECIALIZE pragmas-~~~~~~~~~~~~~~~~~~~~~~~-Specialisation pragmas can be digested by the type checker, and implemented-by adding extra definitions along with that of f, in the same way as before--        f@t1/t2 = <f_rhs> t1 t2 d1 d2--Indeed the pragmas *have* to be dealt with by the type checker, because-only it knows how to build the dictionaries d1 and d2!  For example--        g :: Ord a => [a] -> [a]-        {-# SPECIALIZE f :: [Tree Int] -> [Tree Int] #-}--Here, the specialised version of g is an application of g's rhs to the-Ord dictionary for (Tree Int), which only the type checker can conjure-up.  There might not even *be* one, if (Tree Int) is not an instance of-Ord!  (All the other specialision has suitable dictionaries to hand-from actual calls.)--Problem.  The type checker doesn't have to hand a convenient <f_rhs>, because-it is buried in a complex (as-yet-un-desugared) binding group.-Maybe we should say--        f@t1/t2 = f* t1 t2 d1 d2--where f* is the Id f with an IdInfo which says "inline me regardless!".-Indeed all the specialisation could be done in this way.-That in turn means that the simplifier has to be prepared to inline absolutely-any in-scope let-bound thing.---Again, the pragma should permit polymorphism in unconstrained variables:--        h :: Ord a => [a] -> b -> b-        {-# SPECIALIZE h :: [Int] -> b -> b #-}--We *insist* that all overloaded type variables are specialised to ground types,-(and hence there can be no context inside a SPECIALIZE pragma).-We *permit* unconstrained type variables to be specialised to-        - a ground type-        - or left as a polymorphic type variable-but nothing in between.  So--        {-# SPECIALIZE h :: [Int] -> [c] -> [c] #-}--is *illegal*.  (It can be handled, but it adds complication, and gains the-programmer nothing.)---SPECIALISING INSTANCE DECLARATIONS-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider--        instance Foo a => Foo [a] where-                ...-        {-# SPECIALIZE instance Foo [Int] #-}--The original instance decl creates a dictionary-function-definition:--        dfun.Foo.List :: forall a. Foo a -> Foo [a]--The SPECIALIZE pragma just makes a specialised copy, just as for-ordinary function definitions:--        dfun.Foo.List@Int :: Foo [Int]-        dfun.Foo.List@Int = dfun.Foo.List Int dFooInt--The information about what instance of the dfun exist gets added to-the dfun's IdInfo in the same way as a user-defined function too.---Automatic instance decl specialisation?-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Can instance decls be specialised automatically?  It's tricky.-We could collect call-instance information for each dfun, but-then when we specialised their bodies we'd get new call-instances-for ordinary functions; and when we specialised their bodies, we might get-new call-instances of the dfuns, and so on.  This all arises because of-the unrestricted mutual recursion between instance decls and value decls.--Still, there's no actual problem; it just means that we may not do all-the specialisation we could theoretically do.--Furthermore, instance decls are usually exported and used non-locally,-so we'll want to compile enough to get those specialisations done.--Lastly, there's no such thing as a local instance decl, so we can-survive solely by spitting out *usage* information, and then reading that-back in as a pragma when next compiling the file.  So for now,-we only specialise instance decls in response to pragmas.---SPITTING OUT USAGE INFORMATION-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--To spit out usage information we need to traverse the code collecting-call-instance information for all imported (non-prelude?) functions-and data types. Then we equivalence-class it and spit it out.--This is done at the top-level when all the call instances which escape-must be for imported functions and data types.--*** Not currently done ***---Partial specialisation by pragmas-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-What about partial specialisation:--        k :: (Ord a, Eq b) => [a] -> b -> b -> [a]-        {-# SPECIALIZE k :: Eq b => [Int] -> b -> b -> [a] #-}--or even--        {-# SPECIALIZE k :: Eq b => [Int] -> [b] -> [b] -> [a] #-}--Seems quite reasonable.  Similar things could be done with instance decls:--        instance (Foo a, Foo b) => Foo (a,b) where-                ...-        {-# SPECIALIZE instance Foo a => Foo (a,Int) #-}-        {-# SPECIALIZE instance Foo b => Foo (Int,b) #-}--Ho hum.  Things are complex enough without this.  I pass.---Requirements for the simplifier-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The simplifier has to be able to take advantage of the specialisation.--* When the simplifier finds an application of a polymorphic f, it looks in-f's IdInfo in case there is a suitable instance to call instead.  This converts--        f t1 t2 d1 d2   ===>   f_t1_t2--Note that the dictionaries get eaten up too!--* Dictionary selection operations on constant dictionaries must be-  short-circuited:--        +.sel Int d     ===>  +Int--The obvious way to do this is in the same way as other specialised-calls: +.sel has inside it some IdInfo which tells that if it's applied-to the type Int then it should eat a dictionary and transform to +Int.--In short, dictionary selectors need IdInfo inside them for constant-methods.--* Exactly the same applies if a superclass dictionary is being-  extracted:--        Eq.sel Int d   ===>   dEqInt--* Something similar applies to dictionary construction too.  Suppose-dfun.Eq.List is the function taking a dictionary for (Eq a) to-one for (Eq [a]).  Then we want--        dfun.Eq.List Int d      ===> dEq.List_Int--Where does the Eq [Int] dictionary come from?  It is built in-response to a SPECIALIZE pragma on the Eq [a] instance decl.--In short, dfun Ids need IdInfo with a specialisation for each-constant instance of their instance declaration.--All this uses a single mechanism: the SpecEnv inside an Id---What does the specialisation IdInfo look like?-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--The SpecEnv of an Id maps a list of types (the template) to an expression--        [Type]  |->  Expr--For example, if f has this RuleInfo:--        [Int, a]  ->  \d:Ord Int. f' a--it means that we can replace the call--        f Int t  ===>  (\d. f' t)--This chucks one dictionary away and proceeds with the-specialised version of f, namely f'.---What can't be done this way?-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-There is no way, post-typechecker, to get a dictionary for (say)-Eq a from a dictionary for Eq [a].  So if we find--        ==.sel [t] d--we can't transform to--        eqList (==.sel t d')--where-        eqList :: (a->a->Bool) -> [a] -> [a] -> Bool--Of course, we currently have no way to automatically derive-eqList, nor to connect it to the Eq [a] instance decl, but you-can imagine that it might somehow be possible.  Taking advantage-of this is permanently ruled out.--Still, this is no great hardship, because we intend to eliminate-overloading altogether anyway!--A note about non-tyvar dictionaries-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Some Ids have types like--        forall a,b,c. Eq a -> Ord [a] -> tau--This seems curious at first, because we usually only have dictionary-args whose types are of the form (C a) where a is a type variable.-But this doesn't hold for the functions arising from instance decls,-which sometimes get arguments with types of form (C (T a)) for some-type constructor T.--Should we specialise wrt this compound-type dictionary?  We used to say-"no", saying:-        "This is a heuristic judgement, as indeed is the fact that we-        specialise wrt only dictionaries.  We choose *not* to specialise-        wrt compound dictionaries because at the moment the only place-        they show up is in instance decls, where they are simply plugged-        into a returned dictionary.  So nothing is gained by specialising-        wrt them."--But it is simpler and more uniform to specialise wrt these dicts too;-and in future GHC is likely to support full fledged type signatures-like-        f :: Eq [(a,b)] => ...---************************************************************************-*                                                                      *-\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--              -- 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 $ mkInScopeSet $ mkVarSet $-                                       bindersOfBinds binds-                          , se_interesting = emptyVarSet-                          , se_module = this_mod-                          , se_dflags = dflags }--             go []           = return ([], emptyUDs)-             go (bind:binds) = do (binds', uds) <- go binds-                                  (bind', uds') <- specBind top_env bind uds-                                  return (bind' ++ binds', uds')--             -- Specialise the bindings of this module-       ; (binds', uds) <- runSpecM (go binds)--       ; (spec_rules, spec_binds) <- specImports top_env local_rules 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-*                                                                      *-********************************************************************* -}--specImports :: SpecEnv-            -> [CoreRule]-            -> UsageDetails-            -> CoreM ([CoreRule], [CoreBind])-specImports top_env local_rules-            (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 { hpt_rules <- getRuleBase-       ; let rule_base = extendRuleBaseList hpt_rules local_rules--       ; (spec_rules, spec_binds) <- spec_imports top_env [] rule_base-                                                  dict_binds calls--             -- Don't forget to wrap the specialized bindings with-             -- bindings for the needed dictionaries.-             -- See Note [Wrap bindings returned by specImports]-             -- and Note [Glom the bindings if imported functions are specialised]-       ; let final_binds-               | null spec_binds = wrapDictBinds dict_binds []-               | otherwise       = [Rec $ flattenBinds $-                                    wrapDictBinds dict_binds spec_binds]--       ; return (spec_rules, final_binds)-    }---- | Specialise a set of calls to imported bindings-spec_imports :: SpecEnv          -- Passed in so that all top-level Ids are in scope-             -> [Id]             -- Stack of imported functions being specialised-                                 -- See Note [specImport call stack]-             -> RuleBase         -- Rules from this module and the home package-                                 -- (but not external packages, which can change)-             -> Bag DictBind     -- Dict bindings, used /only/ for filterCalls-                                 -- See Note [Avoiding loops in specImports]-             -> CallDetails      -- Calls for imported things-             -> CoreM ( [CoreRule]   -- New rules-                      , [CoreBind] ) -- Specialised bindings-spec_imports top_env callers rule_base dict_binds calls-  = do { let import_calls = dVarEnvElts calls-       -- ; debugTraceMsg (text "specImports {" <+>-       --                  vcat [ text "calls:" <+> ppr import_calls-       --                       , text "dict_binds:" <+> ppr dict_binds ])-       ; (rules, spec_binds) <- go rule_base import_calls-       -- ; debugTraceMsg (text "End specImports }" <+> ppr import_calls)--       ; return (rules, spec_binds) }-  where-    go :: RuleBase -> [CallInfoSet] -> CoreM ([CoreRule], [CoreBind])-    go _ [] = return ([], [])-    go rb (cis : other_calls)-      = do { -- debugTraceMsg (text "specImport {" <+> ppr cis)-           ; (rules1, spec_binds1) <- spec_import top_env callers rb dict_binds cis-           -- ; debugTraceMsg (text "specImport }" <+> ppr cis)--           ; (rules2, spec_binds2) <- go (extendRuleBaseList rb rules1) other_calls-           ; return (rules1 ++ rules2, spec_binds1 ++ spec_binds2) }--spec_import :: SpecEnv               -- Passed in so that all top-level Ids are in scope-            -> [Id]                  -- Stack of imported functions being specialised-                                     -- See Note [specImport call stack]-            -> RuleBase              -- Rules from this module-            -> Bag DictBind          -- Dict bindings, used /only/ for filterCalls-                                     -- See Note [Avoiding loops in specImports]-            -> CallInfoSet           -- Imported function and calls for it-            -> CoreM ( [CoreRule]    -- New rules-                     , [CoreBind] )  -- Specialised bindings-spec_import top_env callers rb dict_binds cis@(CIS fn _)-  | isIn "specImport" fn callers-  = 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 good_calls-  = return ([], [])--  | 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-       ; hsc_env <- getHscEnv-       ; eps <- liftIO $ hscEPS hsc_env-       ; vis_orphs <- getVisibleOrphanMods-       ; let rules_for_fn = getRules (RuleEnv [rb, eps_rule_base eps] vis_orphs) fn--       ; (rules1, spec_pairs, MkUD { ud_binds = dict_binds1, ud_calls = new_calls })-            <- -- debugTraceMsg (text "specImport1" <+> vcat [ppr fn, ppr good_calls, ppr rhs]) >>-                (runSpecM $ specCalls True top_env rules_for_fn good_calls 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-       -- ; debugTraceMsg (text "specImport 2" <+> (ppr fn $$ ppr rules1 $$ ppr spec_binds1))-       ; (rules2, spec_binds2) <- spec_imports top_env-                                               (fn:callers)-                                               (extendRuleBaseList rb rules1)-                                               (dict_binds `unionBags` dict_binds1)-                                               new_calls--       ; let final_binds = wrapDictBinds dict_binds1 $-                           spec_binds2 ++ spec_binds1--       ; return (rules2 ++ rules1, final_binds) }--  | otherwise-  = do { tryWarnMissingSpecs dflags callers fn good_calls-       ; return ([], [])}--  where-    dflags = se_dflags top_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--- See Note [Specialise imported INLINABLE things]-canSpecImport dflags fn-  | CoreUnfolding { uf_src = src, uf_tmpl = rhs } <- unf-  , isStableSource src-  = Just rhs   -- By default, specialise only imported things that have a stable-               -- unfolding; that is, have an INLINE or INLINABLE pragma-               -- 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--    -- CoreUnfolding case does /not/ include DFunUnfoldings;-    -- We only specialise DFunUnfoldings with -fspecialise-aggressively-    -- See Note [Do not specialise imported DFuns]--  | 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)-        (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.--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--#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.----************************************************************************-*                                                                      *-\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_interesting :: VarSet-             -- Dict Ids that we know something about-             -- and hence may be worth specialising against-             -- See Note [Interesting dictionary arguments]--       , se_module :: Module-       , se_dflags :: DynFlags-     }--instance Outputable SpecEnv where-  ppr (SE { se_subst = subst, se_interesting = interesting })-    = text "SE" <+> braces (sep $ punctuate comma-        [ text "subst =" <+> ppr subst-        , text "interesting =" <+> ppr interesting ])--specVar :: SpecEnv -> Id -> CoreExpr-specVar env v = Core.lookupIdSubst (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 {})-  = 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-       ; 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) }-----------------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 env (Breakpoint ext ix ids)-  = Breakpoint ext 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 [Alt 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')-                              [Alt con args' (Var sc_arg')]-                       | sc_arg' <- sc_args' ]--             -- 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 ]-             env_rhs' = env_rhs { se_subst = Core.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      = [ DB { db_bind = NonRec sc_arg_flt sc_rhs-                                  , db_fvs  = 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'    = 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 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-          return (Alt 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--        ; let zapped_fn = zapIdDemandInfo fn-              -- We zap the demand info because the binding may float,-              -- which would invaidate the demand info (see #17810 for example).-              -- Destroying demand info is not terrible; specialisation is-              -- always followed soon by demand analysis.-      ; (fn', spec_defns, body_uds1) <- specDefn rhs_env body_uds zapped_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 db_bind 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 ([db_bind 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 False 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 :: 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 'already_covered'--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 "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-  = warnPprTrace (not (exprIsTrivial rhs) && notNull calls_for_me)-          "Missed specialisation opportunity" (ppr fn $$ _trace_doc) $-          -- Note [Specialisation shape]-    -- pprTrace "specDefn: none" (ppr fn <+> ppr calls_for_me) $-    return ([], [], emptyUDs)-  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_local  = isLocalId fn-    is_dfun   = isDFunId fn-    dflags    = se_dflags env-    ropts     = initRuleOpts dflags-    this_mod  = se_module env-        -- 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]--    in_scope = Core.substInScope (se_subst env)--    already_covered :: RuleOpts -> [CoreRule] -> [CoreExpr] -> Bool-    already_covered ropts new_rules args      -- Note [Specialisations already covered]-       = isJust (lookupRule ropts (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)--    -----------------------------------------------------------        -- 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   = call_args ++ repeat UnspecArg-                               | otherwise = call_args-                               -- See Note [Specialising DFuns]-           ; ( useful, rhs_env2, leftover_bndrs-             , rule_bndrs, rule_lhs_args-             , spec_bndrs1, dx_binds, spec_args) <- specHeader env rhs_bndrs all_call_args----           ; pprTrace "spec_call" (vcat [ text "call info: " <+> ppr _ci---                                        , text "useful:    " <+> ppr useful---                                        , text "rule_bndrs:" <+> ppr rule_bndrs---                                        , text "lhs_args:  " <+> ppr rule_lhs_args---                                        , text "spec_bndrs:" <+> ppr spec_bndrs1---                                        , text "spec_args: " <+> ppr spec_args---                                        , text "dx_binds:  " <+> ppr dx_binds---                                        , text "rhs_env2:  " <+> ppr (se_subst rhs_env2)---                                        , ppr dx_binds ]) $---             return ()--           ; if not useful  -- No useful specialisation-                || already_covered ropts rules_acc rule_lhs_args-             then return spec_acc-             else-        do { -- Run the specialiser on the specialised RHS-             -- The "1" suffix is before we maybe add the void arg-           ; (spec_rhs1, rhs_uds) <- specLam rhs_env2 (spec_bndrs1 ++ leftover_bndrs) rhs_body-           ; let spec_fn_ty1 = exprType spec_rhs1--                 -- 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-                 add_void_arg = isUnliftedType spec_fn_ty1 && not (isJoinId fn)-                 (spec_bndrs, spec_rhs, spec_fn_ty)-                   | add_void_arg = ( voidPrimId : spec_bndrs1-                                    , Lam        voidArgId  spec_rhs1-                                    , mkVisFunTyMany unboxedUnitTy spec_fn_ty1)-                   | otherwise   = (spec_bndrs1, spec_rhs1, spec_fn_ty1)--                 join_arity_decr = length rule_lhs_args - length spec_bndrs-                 spec_join_arity | Just orig_join_arity <- isJoinId_maybe fn-                                 = Just (orig_join_arity - join_arity_decr)-                                 | otherwise-                                 = Nothing--           ; spec_fn <- newSpecIdSM fn spec_fn_ty spec_join_arity-           ; 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"--                rule_name = mkFastString $ showSDoc dflags $-                            herald <+> ftext (occNameFS (getOccName fn))-                                   <+> hsep (mapMaybe ppr_call_key_ty call_args)-                            -- 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_lhs_args-                                  (mkVarApps (Var spec_fn) spec_bndrs)--                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-                -- See Note [Specialising Calls]-                spec_uds = foldr consDictBind rhs_uds dx_binds--                simpl_opts = initSimpleOpts dflags--                ---------------------------------------                -- 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 "GHC.Core.Opt.OccurAnal"--                  | isInlinablePragma inl_prag-                  = (inl_prag { inl_inline = NoUserInlinePrag }, noUnfolding)--                  | otherwise-                  = (inl_prag, specUnfolding simpl_opts spec_bndrs (`mkApps` spec_args)-                                             rule_lhs_args fn_unf)--                ---------------------------------------                -- Adding arity information just propagates it a bit faster-                --      See Note [Arity decrease] in GHC.Core.Opt.Simplify-                -- Copy InlinePragma information from the parent Id.-                -- So if f has INLINE[1] so does spec_fn-                arity_decr     = count isValArg rule_lhs_args - count isId spec_bndrs-                spec_f_w_arity = spec_fn `setIdArity`      max 0 (fn_arity - arity_decr)-                                         `setInlinePragma` spec_inl_prag-                                         `setIdUnfolding`  spec_unf-                                         `asJoinId_maybe`  spec_join_arity--                _rule_trace_doc = vcat [ ppr fn <+> dcolon <+> ppr fn_type-                                       , ppr spec_fn  <+> dcolon <+> ppr spec_fn_ty-                                       , ppr rhs_bndrs, ppr call_args-                                       , ppr spec_rule-                                       ]--           ; -- pprTrace "spec_call: rule" _rule_trace_doc-             return ( spec_rule                  : rules_acc-                    , (spec_f_w_arity, spec_rhs) : pairs_acc-                    , spec_uds           `plusUDs` uds_acc-                    ) } }--{- Note [Specialising DFuns]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-DFuns have a special sort of unfolding (DFunUnfolding), and these are-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 UnspecArgs, so 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.specUnfolding.--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 [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 7 @T1 @T2 @T3 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. Note, however, that we-only drop dead arguments if:--  1. We don’t specialise on them.-  2. They come before an argument we do specialise on.--  The right thing to do is to produce a LitRubbish; it should rapidly-  disappear.  Rather like GHC.Core.Opt.WorkWrap.Utils.mk_absent_let.--Note [Zap occ info in rule binders]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-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-But both varToCoreExpr (when constructing the LHS args), and the-simplifier (when simplifying the LHS args), will transform to-   RULE forall (d:Num Int) (g :: F Int ~ F Int).-        f Int Int d <F Int> = f_spec-by replacing g with Refl.  So now 'g' is unbound, which results in a later-crash. So we use Refl right off the bat, and do not forall-quantify 'g':- * varToCoreExpr generates a Refl- * exprsFreeIdsList returns the Ids bound by the args,-   which won't include g--You might wonder if this will match as often, but the simplifier replaces-complicated Refl coercions with Refl pretty aggressively.--Note [Orphans and auto-generated rules]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When we specialise an INLINABLE function, or when we have--fspecialise-aggressively, we auto-generate RULES that are orphans.-We don't want to warn about these, or we'd generate a lot of warnings.-Thus, we only warn about user-specified orphan rules.--Indeed, we don't even treat the module as an orphan module if it has-auto-generated *rule* orphans.  Orphan modules are read every time we-compile, so they are pretty obtrusive and slow down every compilation,-even non-optimised ones.  (Reason: for type class instances it's a-type correctness issue.)  But specialisation rules are strictly for-*optimisation* only so it's fine not to read the interface.--What this means is that a SPEC rules from auto-specialisation in-module M will be used in other modules only if M.hi has been read for-some other reason, which is actually pretty likely.--Note [From non-recursive to recursive]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Even in the non-recursive case, if any dict-binds depend on 'fn' we might-have built a recursive knot--      f a d x = <blah>-      MkUD { ud_binds = NonRec d7  (MkD ..f..)-           , ud_calls = ...(f T d7)... }--The we generate--     Rec { fs x = <blah>[T/a, d7/d]-           f a d x = <blah>-               RULE f T _ = fs-           d7 = ...f... }--Here the recursion is only through the RULE.--However we definitely should /not/ make the Rec in this wildly common-case:-      d = ...-      MkUD { ud_binds = NonRec d7 (...d...)-           , ud_calls = ...(f T d7)... }--Here we want simply to add d to the floats, giving-      MkUD { ud_binds = NonRec d (...)-                        NonRec d7 (...d...)-           , ud_calls = ...(f T d7)... }--In general, we need only make this Rec if-  - there are some specialisations (spec_binds non-empty)-  - there are some dict_binds that depend on f (dump_dbs non-empty)--Note [Avoiding loops (DFuns)]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When specialising /dictionary functions/ we must be very careful to-avoid building loops. Here is an example that bit us badly, on-several distinct occasions.--Here is one: #3591-     class Eq a => C a-     instance Eq [a] => C [a]--This translates to-     dfun :: Eq [a] -> C [a]-     dfun a d = MkD a d (meth d)--     d4 :: Eq [T] = <blah>-     d2 ::  C [T] = dfun T d4-     d1 :: Eq [T] = $p1 d2-     d3 ::  C [T] = dfun T d1--None of these definitions is recursive. What happened was that we-generated a specialisation:-     RULE forall d. dfun T d = dT  :: C [T]-     dT = (MkD a d (meth d)) [T/a, d1/d]-        = MkD T d1 (meth d1)--But now we use the RULE on the RHS of d2, to get-    d2 = dT = MkD d1 (meth d1)-    d1 = $p1 d2--and now d1 is bottom!  The problem is that when specialising 'dfun' we-should first dump "below" the binding all floated dictionary bindings-that mention 'dfun' itself.  So d2 and d3 (and hence d1) must be-placed below 'dfun', and thus unavailable to it when specialising-'dfun'.  That in turn means that the call (dfun T d1) must be-discarded.  On the other hand, the call (dfun T d4) is fine, assuming-d4 doesn't mention dfun.--Solution:-  Discard all calls that mention dictionaries that depend-  (directly or indirectly) on the dfun we are specialising.-  This is done by 'filterCalls'--Note [Avoiding loops (non-DFuns)]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The whole Note [Avoiding loops (DFuns)] things applies only to DFuns.-It's important /not/ to apply filterCalls to non-DFuns. For example:--  class C a where { foo,bar :: [a] -> [a] }--  instance C Int where-     foo x = r_bar x-     bar xs = reverse xs--  r_bar :: C a => [a] -> [a]-  r_bar xs = bar (xs ++ xs)--That translates to:--    r_bar a (c::C a) (xs::[a]) = bar a d (xs ++ xs)--    Rec { $fCInt :: C Int = MkC foo_help reverse-          foo_help (xs::[Int]) = r_bar Int $fCInt xs }--The call (r_bar $fCInt) mentions $fCInt,-                        which mentions foo_help,-                        which mentions r_bar--But we DO want to specialise r_bar at Int:-    Rec { $fCInt :: C Int = MkC foo_help reverse-          foo_help (xs::[Int]) = r_bar Int $fCInt xs--          r_bar a (c::C a) (xs::[a]) = bar a d (xs ++ xs)-            RULE r_bar Int _ = r_bar_Int--          r_bar_Int xs = bar Int $fCInt (xs ++ xs)-           }--Note that, because of its RULE, r_bar joins the recursive-group.  (In this case it'll unravel a short moment later.)-See test simplCore/should_compile/T19599a.--Another example is #19599, which looked like this:--   class (Show a, Enum a) => MyShow a where-      myShow :: a -> String--   myShow_impl :: MyShow a => a -> String--   foo :: Int -> String-   foo = myShow_impl @Int $fMyShowInt--   Rec { $fMyShowInt = MkMyShowD $fEnumInt $fShowInt $cmyShow-       ; $cmyShow = myShow_impl @Int $fMyShowInt }--Here, we really do want to specialise `myShow_impl @Int $fMyShowInt`.---Note [Specialising a recursive group]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-    let rec { f x = ...g x'...-            ; g y = ...f y'.... }-    in f 'a'-Here we specialise 'f' at Char; but that is very likely to lead to-a specialisation of 'g' at Char.  We must do the latter, else the-whole point of specialisation is lost.--But we do not want to keep iterating to a fixpoint, because in the-presence of polymorphic recursion we might generate an infinite number-of specialisations.--So we use the following heuristic:-  * Arrange the rec block in dependency order, so far as possible-    (the occurrence analyser already does this)--  * Specialise it much like a sequence of lets--  * Then go through the block a second time, feeding call-info from-    the RHSs back in the bottom, as it were--In effect, the ordering maxmimises the effectiveness of each sweep,-and we do just two sweeps.   This should catch almost every case of-monomorphic recursion -- the exception could be a very knotted-up-recursion with multiple cycles tied up together.--This plan is implemented in the Rec case of specBindItself.--Note [Specialisations already covered]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We obviously don't want to generate two specialisations for the same-argument pattern.  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.--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 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 #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 #4874.--}--{- *********************************************************************-*                                                                      *-                   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 UnspecType   = text "UnspecType"-  ppr (SpecDict d) = text "SpecDict" <+> ppr d-  ppr UnspecArg    = text "UnspecArg"--specArgFreeVars :: SpecArg -> VarSet-specArgFreeVars (SpecType ty) = tyCoVarsOfType ty-specArgFreeVars (SpecDict dx) = exprFreeVars dx-specArgFreeVars UnspecType    = emptyVarSet-specArgFreeVars UnspecArg     = emptyVarSet--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 dShowA 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, dShowA :-> 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, dShowA :-> 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-     :: SpecEnv-     -> [InBndr]    -- The 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--                -- Returned arguments-              , SpecEnv      -- Substitution to apply to the body of 'f'-              , [OutBndr]    -- Leftover binders from the original function 'f'-                             --   that don’t have a corresponding SpecArg--                -- RULE helpers-              , [OutBndr]    -- Binders for the RULE-              , [OutExpr]    -- Args for the LHS of the rule--                -- Specialised function helpers-              , [OutBndr]    -- Binders for $sf-              , [DictBind]   -- Auxiliary dictionary bindings-              , [OutExpr]    -- Specialised arguments for unfolding-                             -- Same length as "args for LHS of rule"-              )---- 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 env (bndr : bndrs) (SpecType t : args)-  = do { let env' = extendTvSubstList env [(bndr, t)]-       ; (useful, env'', leftover_bndrs, rule_bs, rule_es, bs', dx, spec_args)-            <- specHeader env' bndrs args-       ; pure ( useful-              , env''-              , leftover_bndrs-              , rule_bs-              , Type t : rule_es-              , bs'-              , dx-              , Type t : 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 env (bndr : bndrs) (UnspecType : args)-  = do { let (env', bndr') = substBndr env bndr-       ; (useful, env'', leftover_bndrs, rule_bs, rule_es, bs', dx, spec_args)-            <- specHeader env' bndrs args-       ; pure ( useful-              , env''-              , leftover_bndrs-              , bndr' : rule_bs-              , varToCoreExpr bndr' : rule_es-              , bndr' : bs'-              , dx-              , varToCoreExpr bndr' : 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 env (bndr : bndrs) (SpecDict d : args)-  = do { bndr' <- newDictBndr env bndr -- See Note [Zap occ info in rule binders]-       ; let (env', dx_bind, spec_dict) = bindAuxiliaryDict env bndr bndr' d-       ; (_, env'', leftover_bndrs, rule_bs, rule_es, bs', dx, spec_args)-             <- specHeader env' bndrs args-       ; pure ( True      -- Ha!  A useful specialisation!-              , env''-              , leftover_bndrs-              -- See Note [Evidence foralls]-              , exprFreeIdsList (varToCoreExpr bndr') ++ rule_bs-              , varToCoreExpr bndr' : rule_es-              , bs'-              , maybeToList dx_bind ++ dx-              , spec_dict : spec_args-              )-       }---- Finally, we have the unspecialised 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 env (bndr : bndrs) (UnspecArg : args)-  = do { -- see Note [Zap occ info in rule binders]-         let (env', bndr') = substBndr env (zapIdOccInfo bndr)-       ; (useful, env'', leftover_bndrs, rule_bs, rule_es, bs', dx, spec_args)-             <- specHeader env' bndrs args-       ; pure ( useful-              , env''-              , leftover_bndrs-              , bndr' : rule_bs-              , varToCoreExpr bndr' : rule_es-              , if isDeadBinder bndr-                  then bs' -- see Note [Drop dead args from specialisations]-                  else bndr' : bs'-              , dx-              , varToCoreExpr bndr' : spec_args-              )-       }---- If we run out of binders, stop immediately--- See Note [Specialisation Must Preserve Sharing]-specHeader env [] _ = pure (False, env, [], [], [], [], [], [])---- Return all remaining binders from the original function. These have the--- invariant that they should all correspond to unspecialised arguments, so--- it's safe to stop processing at this point.-specHeader env bndrs []-  = pure (False, env', bndrs', [], [], [], [], [])-  where-    (env', bndrs') = substBndrs env bndrs----- | Binds a dictionary argument to a fresh name, to preserve sharing-bindAuxiliaryDict-  :: SpecEnv-  -> InId -> OutId -> OutExpr -- Original dict binder, and the witnessing expression-  -> ( SpecEnv        -- Substitute for orig_dict_id-     , Maybe DictBind -- Auxiliary dict binding, if any-     , OutExpr)        -- Witnessing expression (always trivial)-bindAuxiliaryDict env@(SE { se_subst = subst, se_interesting = interesting })-                  orig_dict_id fresh_dict_id dict_expr--  -- If the dictionary argument is trivial,-  -- don’t bother creating a new dict binding; just substitute-  | Just dict_id <- getIdFromTrivialExpr_maybe dict_expr-  = let env' = env { se_subst = Core.extendSubst subst orig_dict_id dict_expr-                                `Core.extendInScope` dict_id-                          -- See Note [Keep the old dictionaries interesting]-                   , se_interesting = interesting `extendVarSet` dict_id }-    in (env', Nothing, dict_expr)--  | otherwise  -- Non-trivial dictionary arg; make an auxiliary binding-  = let dict_bind = mkDB (NonRec fresh_dict_id dict_expr)-        env' = env { se_subst = Core.extendSubst subst orig_dict_id (Var fresh_dict_id)-                                `Core.extendInScope` fresh_dict_id-                      -- See Note [Make the new dictionaries interesting]-                   , se_interesting = interesting `extendVarSet` fresh_dict_id }-    in (env', Just dict_bind, Var fresh_dict_id)--{--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 [Keep the old dictionaries interesting]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In bindAuxiliaryDict, we don’t bother creating a new dict binding if-the dict expression is trivial. For example, if we have--    f = \ @m1 (d1 :: Monad m1) -> ...--and we specialize it at the pattern--    [SpecType IO, SpecArg $dMonadIO]--it would be silly to create a new binding for $dMonadIO; it’s already-a binding! So we just extend the substitution directly:--    m1 :-> IO-    d1 :-> $dMonadIO--But this creates a new subtlety: the dict expression might be a dict-binding we floated out while specializing another function. For-example, we might have--    d2 = $p1Monad $dMonadIO -- floated out by bindAuxiliaryDict-    $sg = h @IO d2-    h = \ @m2 (d2 :: Applicative m2) -> ...--and end up specializing h at the following pattern:--    [SpecType IO, SpecArg d2]--When we created the d2 binding in the first place, we locally marked-it as interesting while specializing g as described above by-Note [Make the new dictionaries interesting]. But when we go to-specialize h, it isn’t in the SpecEnv anymore, so we’ve lost the-knowledge that we should specialize on it.--To fix this, we have to explicitly add d2 *back* to the interesting-set. That way, it will still be considered interesting while-specializing the body of h. See !2913.--}---{- *********************************************************************-*                                                                      *-            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)-data DictBind = DB { db_bind :: CoreBind, db_fvs :: 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 now we can-successfully specialise 'f'.--So the DictBinds in (ud_binds :: Bag DictBind) may contain-non-dictionary bindings too.--}--instance Outputable DictBind where-  ppr (DB { db_bind = bind, db_fvs = fvs })-    = text "DB" <+> braces (sep [ text "bind:" <+> ppr bind-                                , text "fvs: " <+> ppr fvs ])--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 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 already_covered in specCalls--data CallInfo-  = CI { ci_key  :: [SpecArg]   -- All arguments-       , ci_fvs  :: IdSet       -- Free Ids of the ci_key call-                                -- _not_ including the main id itself, of course-                                -- NB: excluding tyvars:-    }--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 :: SpecArg -> Maybe SDoc-ppr_call_key_ty (SpecType ty) = Just $ char '@' <> pprParendType ty-ppr_call_key_ty UnspecType    = Just $ char '_'-ppr_call_key_ty (SpecDict _)  = Nothing-ppr_call_key_ty UnspecArg     = Nothing--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 :: [TyCoBinder] -> [PredType]-getTheta = fmap tyBinderType . filter isInvisibleBinder . filter (not . isNamedBinder)----------------------------------------------------------------singleCall :: Id -> [SpecArg] -> UsageDetails-singleCall id args-  = MkUD {ud_binds = emptyBag,-          ud_calls = unitDVarEnv id $ CIS id $-                     unitBag (CI { ci_key  = args -- used to be tys-                                 , ci_fvs  = call_fvs }) }-  where-    call_fvs = foldr (unionVarSet . specArgFreeVars) emptyVarSet args-        -- 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-  | wantCallsFor env f    -- We want it, and...-  , not (null ci_key)     -- this call site has a useful specialisation-  = -- pprTrace "mkCallUDs: keeping" _trace_doc-    singleCall 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-             -- Drop trailing args until we get to a SpecDict-             -- In this way the RULE has as few args as possible,-             -- which broadens its applicability, since rules only-             -- fire when saturated--    mk_spec_arg :: CoreExpr -> TyCoBinder -> SpecArg-    mk_spec_arg arg (Named bndr)-      |  binderVar bndr `elemVarSet` constrained_tyvars-      = case arg of-          Type ty -> SpecType ty-          _       -> pprPanic "ci_key" $ ppr arg-      |  otherwise = UnspecType--    -- For "InvisArg", 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 InvisArg pred)-      | not (isIPLikePred (scaledThing pred))-              -- See Note [Type determines value]-      , interestingDict env arg-              -- See Note [Interesting dictionary arguments]-      = SpecDict arg--      | otherwise = UnspecArg--    mk_spec_arg _ (Anon VisArg _)-      = UnspecArg--wantCallsFor :: SpecEnv -> Id -> Bool-wantCallsFor _env _f = True- -- We could reduce the size of the UsageDetails by being less eager- -- about collecting calls for 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 [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.--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 #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 = 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)         = 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 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)] -> Bag DictBind -> DictBind-recWithDumpedDicts pairs dbs-  = DB { db_bind = Rec bindings, db_fvs = fvs }-  where-    (bindings, fvs) = foldr add ([], emptyVarSet)-                                (dbs `snocBag` 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--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-  = foldr add binds dbs-  where-    add (DB { db_bind = bind }) binds = bind : binds--wrapDictBindsE :: Bag DictBind -> CoreExpr -> CoreExpr-wrapDictBindsE dbs expr-  = foldr add expr dbs-  where-    add (DB { db_bind = 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,--- 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 (DFuns)]-------------------------filterCalls :: CallInfoSet -> Bag DictBind -> [CallInfo]--- Remove dominated calls--- and loopy DFuns (Note [Avoiding loops (DFuns)])-filterCalls (CIS fn call_bag) dbs-  | isDFunId fn  -- Note [Avoiding loops (DFuns)] applies only to DFuns-  = filter ok_call unfiltered_calls-  | otherwise         -- Do not apply it to non-DFuns-  = unfiltered_calls  -- See Note [Avoiding loops (non-DFuns)]-  where-    unfiltered_calls = bagToList call_bag--    dump_set = foldl' go (unitVarSet fn) dbs-      -- This dump-set could also be computed by splitDictBinds-      --   (_,_,dump_set) = splitDictBinds dbs {fn}-      -- 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-------------------------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-   = foldl' 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-        | DB { db_bind = bind, db_fvs = fvs } <- db-        , 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 }) = fvs `disjointVarSet` bs--deleteCallsFor :: [Id] -> CallDetails -> CallDetails--- Remove calls *for* bs-deleteCallsFor bs calls = delDVarEnvList calls bs--{--************************************************************************-*                                                                      *-\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 `plusUDs` uds2)--extendTvSubstList :: SpecEnv -> [(TyVar,Type)] -> SpecEnv-extendTvSubstList env tv_binds-  = env { se_subst = Core.extendTvSubstList (se_subst env) tv_binds }--substTy :: SpecEnv -> Type -> Type-substTy env ty = Core.substTy (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 :: SpecEnv -> [CoreBndr] -> (SpecEnv, [CoreBndr])-substBndrs env bs = case Core.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') = Core.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') = Core.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 (mkUserLocal (nameOccName n) uniq Many 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  = mkUserLocal new_occ uniq Many new_ty (getSrcSpan name)-                          `asJoinId_maybe` join_arity_maybe-        ; return new_id }+{-# LANGUAGE MultiWayIf #-}++{-+(c) The GRASP/AQUA Project, Glasgow University, 1993-1998++\section[Specialise]{Stamping out overloading, and (optionally) polymorphism}+-}++module GHC.Core.Opt.Specialise ( specProgram, specUnfolding ) where++import GHC.Prelude++import GHC.Driver.DynFlags+import GHC.Driver.Config+import GHC.Driver.Config.Diagnostic+import GHC.Driver.Config.Core.Rules ( initRuleOpts )++import GHC.Core.Type  hiding( substTy, substCo, extendTvSubst, zapSubst )+import GHC.Core.SimpleOpt( defaultSimpleOpts, simpleOptExprWith, exprIsConApp_maybe )+import GHC.Core.Predicate+import GHC.Core.Class( classMethods )+import GHC.Core.Coercion( Coercion )+import GHC.Core.Opt.Monad+import qualified GHC.Core.Subst as Core+import GHC.Core.Unfold.Make+import GHC.Core+import GHC.Core.Make      ( mkLitRubbish )+import GHC.Core.Unify     ( tcMatchTy )+import GHC.Core.Rules+import GHC.Core.Utils     ( exprIsTrivial, exprIsTopLevelBindable+                          , mkCast, exprType, exprIsHNF+                          , stripTicksTop, mkInScopeSetBndrs )+import GHC.Core.FVs+import GHC.Core.Opt.Arity( collectBindersPushingCo )++import GHC.Builtin.Types  ( unboxedUnitTy )++import GHC.Data.Maybe     ( isJust )+import GHC.Data.Bag+import GHC.Data.OrdList+import GHC.Data.List.SetOps++import GHC.Types.Basic+import GHC.Types.Unique.Supply+import GHC.Types.Unique.DFM+import GHC.Types.Name+import GHC.Types.Tickish+import GHC.Types.Id.Make  ( voidArgId, voidPrimId )+import GHC.Types.Var+import GHC.Types.Var.Set+import GHC.Types.Var.Env+import GHC.Types.Id+import GHC.Types.Id.Info+import GHC.Types.Error++import GHC.Utils.Error ( mkMCDiagnostic )+import GHC.Utils.Monad    ( foldlM )+import GHC.Utils.Misc+import GHC.Utils.FV+import GHC.Utils.Outputable+import GHC.Utils.Panic++import GHC.Unit.Module( Module )+import GHC.Unit.Module.ModGuts+import GHC.Core.Unfold++import Data.List( partition )+import Data.List.NonEmpty ( NonEmpty (..) )+import GHC.Core.Subst (substTickish)+import GHC.Core.TyCon (tyConClass_maybe)+import GHC.Core.DataCon (dataConTyCon)++{-+************************************************************************+*                                                                      *+\subsection[notes-Specialise]{Implementation notes [SLPJ, Aug 18 1993]}+*                                                                      *+************************************************************************++These notes describe how we implement specialisation to eliminate+overloading.++The specialisation pass works on Core+syntax, complete with all the explicit dictionary application,+abstraction and construction as added by the type checker.  The+existing type checker remains largely as it is.++One important thought: the {\em types} passed to an overloaded+function, and the {\em dictionaries} passed are mutually redundant.+If the same function is applied to the same type(s) then it is sure to+be applied to the same dictionary(s)---or rather to the same {\em+values}.  (The arguments might look different but they will evaluate+to the same value.)++Second important thought: we know that we can make progress by+treating dictionary arguments as static and worth specialising on.  So+we can do without binding-time analysis, and instead specialise on+dictionary arguments and no others.++The basic idea+~~~~~~~~~~~~~~+Suppose we have++        let f = <f_rhs>+        in <body>++and suppose f is overloaded.++STEP 1: CALL-INSTANCE COLLECTION++We traverse <body>, accumulating all applications of f to types and+dictionaries.++(Might there be partial applications, to just some of its types and+dictionaries?  In principle yes, but in practice the type checker only+builds applications of f to all its types and dictionaries, so partial+applications could only arise as a result of transformation, and even+then I think it's unlikely.  In any case, we simply don't accumulate such+partial applications.)+++STEP 2: EQUIVALENCES++So now we have a collection of calls to f:+        f t1 t2 d1 d2+        f t3 t4 d3 d4+        ...+Notice that f may take several type arguments.  To avoid ambiguity, we+say that f is called at type t1/t2 and t3/t4.++We take equivalence classes using equality of the *types* (ignoring+the dictionary args, which as mentioned previously are redundant).++STEP 3: SPECIALISATION++For each equivalence class, choose a representative (f t1 t2 d1 d2),+and create a local instance of f, defined thus:++        f@t1/t2 = <f_rhs> t1 t2 d1 d2++f_rhs presumably has some big lambdas and dictionary lambdas, so lots+of simplification will now result.  However we don't actually *do* that+simplification.  Rather, we leave it for the simplifier to do.  If we+*did* do it, though, we'd get more call instances from the specialised+RHS.  We can work out what they are by instantiating the call-instance+set from f's RHS with the types t1, t2.++Add this new id to f's IdInfo, to record that f has a specialised version.++Before doing any of this, check that f's IdInfo doesn't already+tell us about an existing instance of f at the required type/s.+(This might happen if specialisation was applied more than once, or+it might arise from user SPECIALIZE pragmas.)++Recursion+~~~~~~~~~+Wait a minute!  What if f is recursive?  Then we can't just plug in+its right-hand side, can we?++But it's ok.  The type checker *always* creates non-recursive definitions+for overloaded recursive functions.  For example:++        f x = f (x+x)           -- Yes I know its silly++becomes++        f a (d::Num a) = let p = +.sel a d+                         in+                         letrec fl (y::a) = fl (p y y)+                         in+                         fl++We still have recursion for non-overloaded functions which we+specialise, but the recursive call should get specialised to the+same recursive version.+++Polymorphism 1+~~~~~~~~~~~~~~++All this is crystal clear when the function is applied to *constant+types*; that is, types which have no type variables inside.  But what if+it is applied to non-constant types?  Suppose we find a call of f at type+t1/t2.  There are two possibilities:++(a) The free type variables of t1, t2 are in scope at the definition point+of f.  In this case there's no problem, we proceed just as before.  A common+example is as follows.  Here's the Haskell:++        g y = let f x = x+x+              in f y + f y++After typechecking we have++        g a (d::Num a) (y::a) = let f b (d'::Num b) (x::b) = +.sel b d' x x+                                in +.sel a d (f a d y) (f a d y)++Notice that the call to f is at type type "a"; a non-constant type.+Both calls to f are at the same type, so we can specialise to give:++        g a (d::Num a) (y::a) = let f@a (x::a) = +.sel a d x x+                                in +.sel a d (f@a y) (f@a y)+++(b) The other case is when the type variables in the instance types+are *not* in scope at the definition point of f.  The example we are+working with above is a good case.  There are two instances of (+.sel a d),+but "a" is not in scope at the definition of +.sel.  Can we do anything?+Yes, we can "common them up", a sort of limited common sub-expression deal.+This would give:++        g a (d::Num a) (y::a) = let +.sel@a = +.sel a d+                                    f@a (x::a) = +.sel@a x x+                                in +.sel@a (f@a y) (f@a y)++This can save work, and can't be spotted by the type checker, because+the two instances of +.sel weren't originally at the same type.++Further notes on (b)++* There are quite a few variations here.  For example, the defn of+  +.sel could be floated outside the \y, to attempt to gain laziness.+  It certainly mustn't be floated outside the \d because the d has to+  be in scope too.++* We don't want to inline f_rhs in this case, because+that will duplicate code.  Just commoning up the call is the point.++* Nothing gets added to +.sel's IdInfo.++* Don't bother unless the equivalence class has more than one item!++Not clear whether this is all worth it.  It is of course OK to+simply discard call-instances when passing a big lambda.++Polymorphism 2 -- Overloading+~~~~~~~~~~~~~~+Consider a function whose most general type is++        f :: forall a b. Ord a => [a] -> b -> b++There is really no point in making a version of g at Int/Int and another+at Int/Bool, because it's only instantiating the type variable "a" which+buys us any efficiency. Since g is completely polymorphic in b there+ain't much point in making separate versions of g for the different+b types.++That suggests that we should identify which of g's type variables+are constrained (like "a") and which are unconstrained (like "b").+Then when taking equivalence classes in STEP 2, we ignore the type args+corresponding to unconstrained type variable.  In STEP 3 we make+polymorphic versions.  Thus:++        f@t1/ = /\b -> <f_rhs> t1 b d1 d2++We do this.+++Dictionary floating+~~~~~~~~~~~~~~~~~~~+Consider this++        f a (d::Num a) = let g = ...+                         in+                         ...(let d1::Ord a = Num.Ord.sel a d in g a d1)...++Here, g is only called at one type, but the dictionary isn't in scope at the+definition point for g.  Usually the type checker would build a+definition for d1 which enclosed g, but the transformation system+might have moved d1's defn inward.  Solution: float dictionary bindings+outwards along with call instances.++Consider++        f x = let g p q = p==q+                  h r s = (r+s, g r s)+              in+              h x x+++Before specialisation, leaving out type abstractions we have++        f df x = let g :: Eq a => a -> a -> Bool+                     g dg p q = == dg p q+                     h :: Num a => a -> a -> (a, Bool)+                     h dh r s = let deq = eqFromNum dh+                                in (+ dh r s, g deq r s)+              in+              h df x x++After specialising h we get a specialised version of h, like this:++                    h' r s = let deq = eqFromNum df+                             in (+ df r s, g deq r s)++But we can't naively make an instance for g from this, because deq is not in scope+at the defn of g.  Instead, we have to float out the (new) defn of deq+to widen its scope.  Notice that this floating can't be done in advance -- it only+shows up when specialisation is done.++User SPECIALIZE pragmas+~~~~~~~~~~~~~~~~~~~~~~~+Specialisation pragmas can be digested by the type checker, and implemented+by adding extra definitions along with that of f, in the same way as before++        f@t1/t2 = <f_rhs> t1 t2 d1 d2++Indeed the pragmas *have* to be dealt with by the type checker, because+only it knows how to build the dictionaries d1 and d2!  For example++        g :: Ord a => [a] -> [a]+        {-# SPECIALIZE f :: [Tree Int] -> [Tree Int] #-}++Here, the specialised version of g is an application of g's rhs to the+Ord dictionary for (Tree Int), which only the type checker can conjure+up.  There might not even *be* one, if (Tree Int) is not an instance of+Ord!  (All the other specialisation has suitable dictionaries to hand+from actual calls.)++Problem.  The type checker doesn't have to hand a convenient <f_rhs>, because+it is buried in a complex (as-yet-un-desugared) binding group.+Maybe we should say++        f@t1/t2 = f* t1 t2 d1 d2++where f* is the Id f with an IdInfo which says "inline me regardless!".+Indeed all the specialisation could be done in this way.+That in turn means that the simplifier has to be prepared to inline absolutely+any in-scope let-bound thing.+++Again, the pragma should permit polymorphism in unconstrained variables:++        h :: Ord a => [a] -> b -> b+        {-# SPECIALIZE h :: [Int] -> b -> b #-}++We *insist* that all overloaded type variables are specialised to ground types,+(and hence there can be no context inside a SPECIALIZE pragma).+We *permit* unconstrained type variables to be specialised to+        - a ground type+        - or left as a polymorphic type variable+but nothing in between.  So++        {-# SPECIALIZE h :: [Int] -> [c] -> [c] #-}++is *illegal*.  (It can be handled, but it adds complication, and gains the+programmer nothing.)+++SPECIALISING INSTANCE DECLARATIONS+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider++        instance Foo a => Foo [a] where+                ...+        {-# SPECIALIZE instance Foo [Int] #-}++The original instance decl creates a dictionary-function+definition:++        dfun.Foo.List :: forall a. Foo a -> Foo [a]++The SPECIALIZE pragma just makes a specialised copy, just as for+ordinary function definitions:++        dfun.Foo.List@Int :: Foo [Int]+        dfun.Foo.List@Int = dfun.Foo.List Int dFooInt++The information about what instance of the dfun exist gets added to+the dfun's IdInfo in the same way as a user-defined function too.+++Automatic instance decl specialisation?+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Can instance decls be specialised automatically?  It's tricky.+We could collect call-instance information for each dfun, but+then when we specialised their bodies we'd get new call-instances+for ordinary functions; and when we specialised their bodies, we might get+new call-instances of the dfuns, and so on.  This all arises because of+the unrestricted mutual recursion between instance decls and value decls.++Still, there's no actual problem; it just means that we may not do all+the specialisation we could theoretically do.++Furthermore, instance decls are usually exported and used non-locally,+so we'll want to compile enough to get those specialisations done.++Lastly, there's no such thing as a local instance decl, so we can+survive solely by spitting out *usage* information, and then reading that+back in as a pragma when next compiling the file.  So for now,+we only specialise instance decls in response to pragmas.+++SPITTING OUT USAGE INFORMATION+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++To spit out usage information we need to traverse the code collecting+call-instance information for all imported (non-prelude?) functions+and data types. Then we equivalence-class it and spit it out.++This is done at the top-level when all the call instances which escape+must be for imported functions and data types.++*** Not currently done ***+++Partial specialisation by pragmas+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+What about partial specialisation:++        k :: (Ord a, Eq b) => [a] -> b -> b -> [a]+        {-# SPECIALIZE k :: Eq b => [Int] -> b -> b -> [a] #-}++or even++        {-# SPECIALIZE k :: Eq b => [Int] -> [b] -> [b] -> [a] #-}++Seems quite reasonable.  Similar things could be done with instance decls:++        instance (Foo a, Foo b) => Foo (a,b) where+                ...+        {-# SPECIALIZE instance Foo a => Foo (a,Int) #-}+        {-# SPECIALIZE instance Foo b => Foo (Int,b) #-}++Ho hum.  Things are complex enough without this.  I pass.+++Requirements for the simplifier+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The simplifier has to be able to take advantage of the specialisation.++* When the simplifier finds an application of a polymorphic f, it looks in+f's IdInfo in case there is a suitable instance to call instead.  This converts++        f t1 t2 d1 d2   ===>   f_t1_t2++Note that the dictionaries get eaten up too!++* Dictionary selection operations on constant dictionaries must be+  short-circuited:++        +.sel Int d     ===>  +Int++The obvious way to do this is in the same way as other specialised+calls: +.sel has inside it some IdInfo which tells that if it's applied+to the type Int then it should eat a dictionary and transform to +Int.++In short, dictionary selectors need IdInfo inside them for constant+methods.++* Exactly the same applies if a superclass dictionary is being+  extracted:++        Eq.sel Int d   ===>   dEqInt++* Something similar applies to dictionary construction too.  Suppose+dfun.Eq.List is the function taking a dictionary for (Eq a) to+one for (Eq [a]).  Then we want++        dfun.Eq.List Int d      ===> dEq.List_Int++Where does the Eq [Int] dictionary come from?  It is built in+response to a SPECIALIZE pragma on the Eq [a] instance decl.++In short, dfun Ids need IdInfo with a specialisation for each+constant instance of their instance declaration.++All this uses a single mechanism: the SpecEnv inside an Id+++What does the specialisation IdInfo look like?+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++The SpecEnv of an Id maps a list of types (the template) to an expression++        [Type]  |->  Expr++For example, if f has this RuleInfo:++        [Int, a]  ->  \d:Ord Int. f' a++it means that we can replace the call++        f Int t  ===>  (\d. f' t)++This chucks one dictionary away and proceeds with the+specialised version of f, namely f'.+++What can't be done this way?+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There is no way, post-typechecker, to get a dictionary for (say)+Eq a from a dictionary for Eq [a].  So if we find++        ==.sel [t] d++we can't transform to++        eqList (==.sel t d')++where+        eqList :: (a->a->Bool) -> [a] -> [a] -> Bool++Of course, we currently have no way to automatically derive+eqList, nor to connect it to the Eq [a] instance decl, but you+can imagine that it might somehow be possible.  Taking advantage+of this is permanently ruled out.++Still, this is no great hardship, because we intend to eliminate+overloading altogether anyway!++A note about non-tyvar dictionaries+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Some Ids have types like++        forall a,b,c. Eq a -> Ord [a] -> tau++This seems curious at first, because we usually only have dictionary+args whose types are of the form (C a) where a is a type variable.+But this doesn't hold for the functions arising from instance decls,+which sometimes get arguments with types of form (C (T a)) for some+type constructor T.++Should we specialise wrt this compound-type dictionary?  We used to say+"no", saying:+        "This is a heuristic judgement, as indeed is the fact that we+        specialise wrt only dictionaries.  We choose *not* to specialise+        wrt compound dictionaries because at the moment the only place+        they show up is in instance decls, where they are simply plugged+        into a returned dictionary.  So nothing is gained by specialising+        wrt them."++But it is simpler and more uniform to specialise wrt these dicts too;+and in future GHC is likely to support full fledged type signatures+like+        f :: Eq [(a,b)] => ...+++Note [Specialisation and overlapping instances]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Here is at tricky case (see a comment in MR !8916):++    module A where+      class C a where+        meth :: a -> String+      instance {-# OVERLAPPABLE #-} C (Maybe a) where+        meth _ = "Maybe"++      {-# SPECIALISE f :: Maybe a -> Bool -> String #-}+      f :: C a => a -> Bool -> String+      f a True = f a False+      f a _    = meth a++    module B where+      import A++      instance C (Maybe Int) where+        meth _ = "Int"++      main = putStrLn $ f (Just 42 :: Maybe Int) True++Running main without optimisations yields "Int", the correct answer.+Activating optimisations yields "Maybe" due to a rewrite rule in module+A generated by the SPECIALISE pragma:++    RULE "USPEC f" forall a (d :: C a). f @a d = $sf++In B we get the call (f @(Maybe Int) (d :: C (Maybe Int))), and+that rewrites to $sf, but that isn't really right.++Overlapping instances mean that `C (Maybe Int)` is not a singleton+type: there two distinct dictionaries that have this type.  And that+spells trouble for specialistion, which really asssumes singleton+types.++For now, we just accept this problem, but it may bite us one day.+One solution would be to decline to expose any specialisation rules+to an importing module -- but that seems a bit drastic.+++************************************************************************+*                                                                      *+\subsubsection{The new specialiser}+*                                                                      *+************************************************************************++Our basic game plan is this.  For let(rec) bound function+        f :: (C a, D c) => (a,b,c,d) -> Bool++* Find any specialised calls of f, (f ts ds), where+  ts are the type arguments t1 .. t4, and+  ds are the dictionary arguments d1 .. d2.++* Add a new definition for f1 (say):++        f1 = /\ b d -> (..body of f..) t1 b t3 d d1 d2++  Note that we abstract over the unconstrained type arguments.++* Add the mapping++        [t1,b,t3,d]  |->  \d1 d2 -> f1 b d++  to the specialisations of f.  This will be used by the+  simplifier to replace calls+                (f t1 t2 t3 t4) da db+  by+                (\d1 d1 -> f1 t2 t4) da db++  All the stuff about how many dictionaries to discard, and what types+  to apply the specialised function to, are handled by the fact that the+  SpecEnv contains a template for the result of the specialisation.++We don't build *partial* specialisations for f.  For example:++  f :: Eq a => a -> a -> Bool+  {-# SPECIALISE f :: (Eq b, Eq c) => (b,c) -> (b,c) -> Bool #-}++Here, little is gained by making a specialised copy of f.+There's a distinct danger that the specialised version would+first build a dictionary for (Eq b, Eq c), and then select the (==)+method from it!  Even if it didn't, not a great deal is saved.++We do, however, generate polymorphic, but not overloaded, specialisations:++  f :: Eq a => [a] -> b -> b -> b+  ... SPECIALISE f :: [Int] -> b -> b -> b ...++Hence, the invariant is this:++        *** no specialised version is overloaded ***+++************************************************************************+*                                                                      *+\subsubsection{The exported function}+*                                                                      *+************************************************************************+-}++-- | Specialise calls to type-class overloaded functions occurring in a program.+specProgram :: ModGuts -> CoreM ModGuts+specProgram guts@(ModGuts { mg_module = this_mod+                          , mg_rules  = local_rules+                          , mg_binds  = binds })+  = do { dflags   <- getDynFlags+       ; rule_env <- initRuleEnv guts+                     -- See Note [Fire rules in the specialiser]++              -- We need to start with a Subst that knows all the things+              -- that are in scope, so that the substitution engine doesn't+              -- accidentally re-use a unique that's already in use+              -- Easiest thing is to do it all at once, as if all the top-level+              -- decls were mutually recursive+       ; let top_env = SE { se_subst = Core.mkEmptySubst $+                                        mkInScopeSetBndrs binds+                                      --    mkInScopeSetList $+                                      --  bindersOfBinds binds+                          , se_module = this_mod+                          , se_rules  = rule_env+                          , se_dflags = dflags }++             go []           = return ([], emptyUDs)+             go (bind:binds) = do (bind', binds', uds') <- specBind TopLevel top_env bind $ \_ ->+                                                           go binds+                                  return (bind' ++ binds', uds')++             -- Specialise the bindings of this module+       ; (binds', uds) <- runSpecM (go binds)++       ; (spec_rules, spec_binds) <- specImports top_env uds++       ; return (guts { mg_binds = spec_binds ++ binds'+                      , mg_rules = spec_rules ++ local_rules }) }++{-+Note [Wrap bindings returned by specImports]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+'specImports' returns a set of specialized bindings. However, these are lacking+necessary floated dictionary bindings, which are returned by+UsageDetails(ud_binds). These dictionaries need to be brought into scope with+'wrapDictBinds' before the bindings returned by 'specImports' can be used. See,+for instance, the 'specImports' call in 'specProgram'.+++Note [Disabling cross-module specialisation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Since GHC 7.10 we have performed specialisation of INLINABLE bindings living+in modules outside of the current module. This can sometimes uncover user code+which explodes in size when aggressively optimized. The+-fno-cross-module-specialise option was introduced to allow users to being+bitten by such instances to revert to the pre-7.10 behavior.++See #10491+-}+++{- *********************************************************************+*                                                                      *+                   Specialising imported functions+*                                                                      *+********************************************************************* -}++{- Note [Specialising imported functions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+specImports specialises imported functions, based on calls in this module.++When -fspecialise-aggressively is on, we specialise any imported+function for which we have an unfolding.  The+-fspecialise-aggressively flag is usually off, because we risk lots of+orphan modules from over-vigorous specialisation.  (See Note [Orphans]+in GHC.Core.) However it's not a big deal: anything non-recursive with+an unfolding-template will probably have been inlined already.++When -fspecialise-aggressively is off, we are more selective about+specialisation (see canSpecImport):++(1) Without -fspecialise-aggressively, do not specialise+    DFunUnfoldings. Note [Do not specialise imported DFuns].++(2) Without -fspecialise-aggressively, specialise only imported things+    that have a /user-supplied/ INLINE or INLINABLE pragma (hence+    isAnyInlinePragma rather than isStableSource).++    In particular, we don't want to specialise workers created by+    worker/wrapper (for functions with no pragma) because they won't+    specialise usefully, and they generate quite a bit of useless code+    bloat.++    Specialise even INLINE things; it hasn't inlined yet, so perhaps+    it never will.  Moreover it may have calls inside it that we want+    to specialise++Wrinkle (W1): If we specialise an imported Id M.foo, we make a /local/+binding $sfoo.  But specImports may further specialise $sfoo. So we end up+with RULES for both M.foo (imported) and $sfoo (local).  Rules for local+Ids should be attached to the Ids themselves (see GHC.HsToCore+Note [Attach rules to local ids]); so we must partition the rules and+attach the local rules.  That is done in specImports, via addRulesToId.++Note [Glom the bindings if imported functions are specialised]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have an imported, *recursive*, INLINABLE function+   f :: Eq a => a -> a+   f = /\a \d x. ...(f a d)...+In the module being compiled we have+   g x = f (x::Int)+Now we'll make a specialised function+   f_spec :: Int -> Int+   f_spec = \x -> ...(f Int dInt)...+   {-# RULE  f Int _ = f_spec #-}+   g = \x. f Int dInt x+Note that f_spec doesn't look recursive+After rewriting with the RULE, we get+   f_spec = \x -> ...(f_spec)...+BUT since f_spec was non-recursive before it'll *stay* non-recursive.+The occurrence analyser never turns a NonRec into a Rec.  So we must+make sure that f_spec is recursive.  Easiest thing is to make all+the specialisations for imported bindings recursive.+-}++specImports :: SpecEnv+            -> UsageDetails+            -> CoreM ([CoreRule], [CoreBind])+specImports top_env (MkUD { ud_binds = dict_binds, ud_calls = calls })+  | not $ gopt Opt_CrossModuleSpecialise (se_dflags top_env)+    -- See Note [Disabling cross-module specialisation]+  = return ([], wrapDictBinds dict_binds [])++  | otherwise+  = do { let env_w_dict_bndrs = top_env `bringFloatedDictsIntoScope` dict_binds+       ; (_env, spec_rules, spec_binds) <- spec_imports env_w_dict_bndrs [] dict_binds calls++             -- Make a Rec: see Note [Glom the bindings if imported functions are specialised]+             --+             -- wrapDictBinds: don't forget to wrap the specialized bindings with+             --   bindings for the needed dictionaries.+             --   See Note [Wrap bindings returned by specImports]+             --+             -- addRulesToId: see Wrinkle (W1) in Note [Specialising imported functions]+             --               c.f. GHC.HsToCore.addExportFlagsAndRules+       ; let (rules_for_locals, rules_for_imps) = partition isLocalRule spec_rules+             local_rule_base = extendRuleBaseList emptyRuleBase rules_for_locals+             final_binds+               | null spec_binds = wrapDictBinds dict_binds []+               | otherwise       = [Rec $ mapFst (addRulesToId local_rule_base) $+                                          flattenBinds                          $+                                          wrapDictBinds dict_binds              $+                                          spec_binds]++       ; return (rules_for_imps, final_binds)+    }++-- | Specialise a set of calls to imported bindings+spec_imports :: SpecEnv          -- Passed in so that all top-level Ids are in scope+                                 ---In-scope set includes the FloatedDictBinds+             -> [Id]             -- Stack of imported functions being specialised+                                 -- See Note [specImport call stack]+             -> FloatedDictBinds -- Dict bindings, used /only/ for filterCalls+                                 -- See Note [Avoiding loops in specImports]+             -> CallDetails      -- Calls for imported things+             -> CoreM ( SpecEnv      -- Env contains the new rules+                      , [CoreRule]   -- New rules+                      , [CoreBind] ) -- Specialised bindings+spec_imports env callers dict_binds calls+  = do { let import_calls = dVarEnvElts calls+--       ; debugTraceMsg (text "specImports {" <+>+--                         vcat [ text "calls:" <+> ppr import_calls+--                              , text "dict_binds:" <+> ppr dict_binds ])+       ; (env, rules, spec_binds) <- go env import_calls+--       ; debugTraceMsg (text "End specImports }" <+> ppr import_calls)++       ; return (env, rules, spec_binds) }+  where+    go :: SpecEnv -> [CallInfoSet] -> CoreM (SpecEnv, [CoreRule], [CoreBind])+    go env [] = return (env, [], [])+    go env (cis : other_calls)+      = do { -- debugTraceMsg (text "specImport {" <+> ppr cis)+           ; (env, rules1, spec_binds1) <- spec_import env callers dict_binds cis+           ; -- debugTraceMsg (text "specImport }" <+> ppr cis)++           ; (env, rules2, spec_binds2) <- go env other_calls+           ; return (env, rules1 ++ rules2, spec_binds1 ++ spec_binds2) }++spec_import :: SpecEnv               -- Passed in so that all top-level Ids are in scope+                                     ---In-scope set includes the FloatedDictBinds+            -> [Id]                  -- Stack of imported functions being specialised+                                     -- See Note [specImport call stack]+            -> FloatedDictBinds      -- Dict bindings, used /only/ for filterCalls+                                     -- See Note [Avoiding loops in specImports]+            -> CallInfoSet           -- Imported function and calls for it+            -> CoreM ( SpecEnv+                     , [CoreRule]    -- New rules+                     , [CoreBind] )  -- Specialised bindings+spec_import env callers dict_binds cis@(CIS fn _)+  | isIn "specImport" fn callers+  = return (env, [], [])  -- No warning.  This actually happens all the time+                          -- when specialising a recursive function, because+                          -- the RHS of the specialised function contains a recursive+                          -- call to the original function++  | null good_calls+  = return (env, [], [])++  | Just rhs <- canSpecImport dflags fn+  = do {     -- Get rules from the external package state+             -- We keep doing this in case we "page-fault in"+             -- more rules as we go along+       ; eps_rules <- getExternalRuleBase+       ; let rule_env = se_rules env `updExternalPackageRules` eps_rules++--       ; debugTraceMsg (text "specImport1" <+> vcat+--           [ text "function:" <+> ppr fn+--           , text "good calls:" <+> ppr good_calls+--           , text "existing rules:" <+> ppr (getRules rule_env fn)+--           , text "rhs:" <+> ppr rhs+--           , text "dict_binds:" <+> ppr dict_binds ])++       ; (rules1, spec_pairs, MkUD { ud_binds = dict_binds1, ud_calls = new_calls })+            <- runSpecM $ specCalls True env (getRules rule_env fn) good_calls fn rhs++       ; let spec_binds1 = [NonRec b r | (b,r) <- spec_pairs]+             -- After the rules kick in, via fireRewriteRules, we may get recursion,+             -- but we rely on a global GlomBinds to sort that out later+             -- See Note [Glom the bindings if imported functions are specialised]+             -- Meanwhile, though, bring the binders into scope++             new_subst = se_subst env `Core.extendSubstInScopeList` map fst spec_pairs+             new_env   = env { se_rules = rule_env `addLocalRules` rules1+                             , se_subst = new_subst }+                         `bringFloatedDictsIntoScope` dict_binds1++       -- Now specialise any cascaded calls+--       ; debugTraceMsg (text "specImport 2" <+> vcat+--           [ text "function:" <+> ppr fn+--           , text "rules1:" <+> ppr rules1+--           , text "spec_binds1" <+> ppr spec_binds1+--           , text "dict_binds1" <+> ppr dict_binds1+--           , text "new_calls" <+> ppr new_calls ])++       ; (env, rules2, spec_binds2)+            <- spec_imports new_env (fn:callers)+                                    (dict_binds `thenFDBs` dict_binds1)+                                    new_calls++       ; let final_binds = wrapDictBinds dict_binds1 $+                           spec_binds2 ++ spec_binds1++       ; return (env, rules2 ++ rules1, final_binds) }++  | otherwise+  = do { tryWarnMissingSpecs dflags callers fn good_calls+       ; return (env, [], [])}++  where+    dflags = se_dflags env+    good_calls = filterCalls cis dict_binds+       -- SUPER IMPORTANT!  Drop calls that (directly or indirectly) refer to fn+       -- See Note [Avoiding loops in specImports]++canSpecImport :: DynFlags -> Id -> Maybe CoreExpr+canSpecImport dflags fn+  | isDataConWrapId fn+  = Nothing   -- Don't specialise data-con wrappers, even if they+              -- have dict args; there is no benefit.++  | CoreUnfolding { uf_tmpl = rhs } <- unf+    -- CoreUnfolding: see Note [Specialising imported functions] point (1).+  , isAnyInlinePragma (idInlinePragma fn)+    -- See Note [Specialising imported functions] point (2).+  = Just rhs++  | gopt Opt_SpecialiseAggressively dflags+  = maybeUnfoldingTemplate unf+    -- With -fspecialise-aggressively, specialise anything+    -- with an unfolding, stable or not, DFun or not++  | otherwise = Nothing+  where+    unf = realIdUnfolding fn   -- We want to see the unfolding even for loop breakers++-- | Returns whether or not to show a missed-spec warning.+-- If -Wall-missed-specializations is on, show the warning.+-- Otherwise, if -Wmissed-specializations is on, only show a warning+-- if there is at least one imported function being specialized,+-- and if all imported functions are marked with an inline pragma+-- Use the most specific warning as the reason.+tryWarnMissingSpecs :: DynFlags -> [Id] -> Id -> [CallInfo] -> CoreM ()+-- See Note [Warning about missed specialisations]+tryWarnMissingSpecs dflags callers fn calls_for_fn+  | isClassOpId fn = return () -- See Note [Missed specialisation for ClassOps]+  | wopt Opt_WarnMissedSpecs dflags+    && not (null callers)+    && allCallersInlined                  = doWarn $ WarningWithFlag Opt_WarnMissedSpecs+  | wopt Opt_WarnAllMissedSpecs dflags    = doWarn $ WarningWithFlag Opt_WarnAllMissedSpecs+  | otherwise                             = return ()+  where+    allCallersInlined = all (isAnyInlinePragma . idInlinePragma) callers+    diag_opts = initDiagOpts dflags+    doWarn reason =+      msg (mkMCDiagnostic diag_opts reason Nothing)+        (vcat [ hang (text ("Could not specialise imported function") <+> quotes (ppr fn))+                2 (vcat [ text "when specialising" <+> quotes (ppr caller)+                        | caller <- callers])+          , whenPprDebug (text "calls:" <+> vcat (map (pprCallInfo fn) calls_for_fn))+          , text "Probable fix: add INLINABLE pragma on" <+> quotes (ppr fn) ])++{- Note [Missed specialisation for ClassOps]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In #19592 I saw a number of missed specialisation warnings+which were the result of things like:++    case isJumpishInstr @X86.Instr $dInstruction_s7f8 eta3_a78C of { ...++where isJumpishInstr is part of the Instruction class and defined like+this:++    class Instruction instr where+        ...+        isJumpishInstr :: instr -> Bool+        ...++isJumpishInstr is a ClassOp which will select the right method+from within the dictionary via our built in rules. See also+Note [ClassOp/DFun selection] in GHC.Tc.TyCl.Instance.++We don't give these unfoldings, and as a result the specialiser+complains. But usually this doesn't matter. The simplifier will+apply the rule and we end up with++    case isJumpishInstrImplX86 eta3_a78C of { ...++Since isJumpishInstrImplX86 is defined for a concrete instance (given+by the dictionary) it is usually already well specialised!+Theoretically the implementation of a method could still be overloaded+over a different type class than what it's a method of. But I wasn't able+to make this go wrong, and SPJ thinks this should be fine as well.++So I decided to remove the warnings for failed specialisations on ClassOps+alltogether as they do more harm than good.+-}++{- Note [Do not specialise imported DFuns]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Ticket #18223 shows that specialising calls of DFuns is can cause a huge+and entirely unnecessary blowup in program size.  Consider a call to+    f @[[[[[[[[T]]]]]]]] d1 x+where df :: C a => C [a]+      d1 :: C [[[[[[[[T]]]]]]]] = dfC[] @[[[[[[[T]]]]]]] d1+      d2 :: C [[[[[[[T]]]]]]]   = dfC[] @[[[[[[T]]]]]] d3+      ...+Now we'll specialise f's RHS, which may give rise to calls to 'g',+also overloaded, which we will specialise, and so on.  However, if+we specialise the calls to dfC[], we'll generate specialised copies of+all methods of C, at all types; and the same for C's superclasses.++And many of these specialised functions will never be called.  We are+going to call the specialised 'f', and the specialised 'g', but DFuns+group functions into a tuple, many of whose elements may never be used.++With deeply-nested types this can lead to a simply overwhelming number+of specialisations: see #18223 for a simple example (from the wild).+I measured the number of specialisations for various numbers of calls+of `flip evalStateT ()`, and got this++                       Size after one simplification+  #calls    #SPEC rules    Terms     Types+      5         56          3100     10600+      9        108         13660     77206++The real tests case has 60+ calls, which blew GHC out of the water.++Solution: don't specialise DFuns.  The downside is that if we end+up with (h (dfun d)), /and/ we don't specialise 'h', then we won't+pass to 'h' a tuple of specialised functions.++However, the flag -fspecialise-aggressively (experimental, off by default)+allows DFuns to specialise as well.++Note [Avoiding loops in specImports]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We must take great care when specialising instance declarations+(DFuns like $fOrdList) lest we accidentally build a recursive+dictionary. See Note [Avoiding loops (DFuns)].++The basic strategy of Note [Avoiding loops (DFuns)] is to use filterCalls+to discard loopy specialisations.  But to do that we must ensure+that the in-scope dict-binds (passed to filterCalls) contains+all the needed dictionary bindings.  In particular, in the recursive+call to spec_imports in spec_import, we must include the dict-binds+from the parent.  Lacking this caused #17151, a really nasty bug.++Here is what happened.+* Class structure:+    Source is a superclass of Mut+    Index is a superclass of Source++* We started with these dict binds+    dSource = $fSourcePix @Int $fIndexInt+    dIndex  = sc_sel dSource+    dMut    = $fMutPix @Int dIndex+  and these calls to specialise+    $fMutPix @Int dIndex+    $fSourcePix @Int $fIndexInt++* We specialised the call ($fMutPix @Int dIndex)+  ==> new call ($fSourcePix @Int dIndex)+      (because Source is a superclass of Mut)++* We specialised ($fSourcePix @Int dIndex)+  ==> produces specialised dict $s$fSourcePix,+      a record with dIndex as a field+      plus RULE forall d. ($fSourcePix @Int d) = $s$fSourcePix+  *** This is the bogus step ***++* Now we decide not to specialise the call+    $fSourcePix @Int $fIndexInt+  because we alredy have a RULE that matches it++* Finally the simplifer rewrites+    dSource = $fSourcePix @Int $fIndexInt+    ==>  dSource = $s$fSourcePix++Disaster. Now we have++Rewrite dSource's RHS to $s$fSourcePix   Disaster+    dSource = $s$fSourcePix+    dIndex  = sc_sel dSource+    $s$fSourcePix = MkSource dIndex ...++Solution: filterCalls should have stopped the bogus step,+by seeing that dIndex transitively uses $fSourcePix. But+it can only do that if it sees all the dict_binds.  Wow.++--------------+Here's another example (#13429).  Suppose we have+  class Monoid v => C v a where ...++We start with a call+   f @ [Integer] @ Integer $fC[]Integer++Specialising call to 'f' gives dict bindings+   $dMonoid_1 :: Monoid [Integer]+   $dMonoid_1 = M.$p1C @ [Integer] $fC[]Integer++   $dC_1 :: C [Integer] (Node [Integer] Integer)+   $dC_1 = M.$fCvNode @ [Integer] $dMonoid_1++...plus a recursive call to+   f @ [Integer] @ (Node [Integer] Integer) $dC_1++Specialising that call gives+   $dMonoid_2  :: Monoid [Integer]+   $dMonoid_2  = M.$p1C @ [Integer] $dC_1++   $dC_2 :: C [Integer] (Node [Integer] Integer)+   $dC_2 = M.$fCvNode @ [Integer] $dMonoid_2++Now we have two calls to the imported function+  M.$fCvNode :: Monoid v => C v a+  M.$fCvNode @v @a m = C m some_fun++But we must /not/ use the call (M.$fCvNode @ [Integer] $dMonoid_2)+for specialisation, else we get:++  $dC_1 = M.$fCvNode @ [Integer] $dMonoid_1+  $dMonoid_2 = M.$p1C @ [Integer] $dC_1+  $s$fCvNode = C $dMonoid_2 ...+    RULE M.$fCvNode [Integer] _ _ = $s$fCvNode++Now use the rule to rewrite the call in the RHS of $dC_1+and we get a loop!+++Note [specImport call stack]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When specialising an imports function 'f', we may get new calls+of an imported function 'g', which we want to specialise in turn,+and similarly specialising 'g' might expose a new call to 'h'.++We track the stack of enclosing functions. So when specialising 'h' we+have a specImport call stack of [g,f]. We do this for two reasons:+* Note [Warning about missed specialisations]+* Note [Avoiding recursive specialisation]++Note [Warning about missed specialisations]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose+ * In module Lib, you carefully mark a function 'foo' INLINABLE+ * Import Lib(foo) into another module M+ * Call 'foo' at some specialised type in M+Then you jolly well expect it to be specialised in M.  But what if+'foo' calls another function 'Lib.bar'.  Then you'd like 'bar' to be+specialised too.  But if 'bar' is not marked INLINABLE it may well+not be specialised.  The warning Opt_WarnMissedSpecs warns about this.++It's more noisy to warning about a missed specialisation opportunity+for /every/ overloaded imported function, but sometimes useful. That+is what Opt_WarnAllMissedSpecs does.++ToDo: warn about missed opportunities for local functions.++Note [Avoiding recursive specialisation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we specialise 'f' we may find new overloaded calls to 'g', 'h' in+'f's RHS.  So we want to specialise g,h.  But we don't want to+specialise f any more!  It's possible that f's RHS might have a+recursive yet-more-specialised call, so we'd diverge in that case.+And if the call is to the same type, one specialisation is enough.+Avoiding this recursive specialisation loop is one reason for the+'callers' stack passed to specImports and specImport.+++************************************************************************+*                                                                      *+\subsubsection{@specExpr@: the main function}+*                                                                      *+************************************************************************+-}++data SpecEnv+  = SE { se_subst :: Core.Subst+             -- We carry a substitution down:+             -- a) we must clone any binding that might float outwards,+             --    to avoid name clashes+             -- b) we carry a type substitution to use when analysing+             --    the RHS of specialised bindings (no type-let!)++       , se_module :: Module+       , se_rules  :: RuleEnv  -- From the home package and this module+       , se_dflags :: DynFlags+     }++instance Outputable SpecEnv where+  ppr (SE { se_subst = subst })+    = text "SE" <+> braces (text "subst =" <+> ppr subst)++specVar :: SpecEnv -> InId -> SpecM (OutExpr, UsageDetails)+specVar env@(SE { se_subst = Core.Subst in_scope ids _ _ }) v+  | not (isLocalId v)                   = return (Var v, emptyUDs)+  | Just e  <- lookupVarEnv ids       v = specExpr (zapSubst env) e  -- Note (1)+  | Just v' <- lookupInScope in_scope v = return (Var v', emptyUDs)+  | otherwise = pprPanic "specVar" (ppr v $$ ppr in_scope)+  -- c.f. GHC.Core.Subst.lookupIdSubst+  -- Note (1): we recurse so we do the lookupInScope thing on any Vars in e+  --           probably has little effect, but it's the right thing.+  --           We need zapSubst because `e` is an OutExpr++specExpr :: SpecEnv -> CoreExpr -> SpecM (CoreExpr, UsageDetails)++---------------- First the easy cases --------------------+specExpr env (Var v)       = specVar env v+specExpr env (Type ty)     = return (Type     (substTy env ty), emptyUDs)+specExpr env (Coercion co) = return (Coercion (substCo env co), emptyUDs)+specExpr _   (Lit lit)     = return (Lit lit,                   emptyUDs)+specExpr env (Cast e co)+  = do { (e', uds) <- specExpr env e+       ; return ((mkCast e' (substCo env co)), uds) }+specExpr env (Tick tickish body)+  = do { (body', uds) <- specExpr env body+       ; return (Tick (specTickish env tickish) body', uds) }++---------------- Applications might generate a call instance --------------------+specExpr env expr@(App {})+  = do { let (fun_in, args_in) = collectArgs expr+       ; (fun_out, uds_fun)   <- specExpr env fun_in+       ; (args_out, uds_args) <- mapAndCombineSM (specExpr env) args_in+       ; let uds_app  = uds_fun `thenUDs` uds_args+             env_args = zapSubst env `bringFloatedDictsIntoScope` ud_binds uds_app+                -- zapSubst: we have now fully applied the substitution+                -- bringFloatedDictsIntoScope: some dicts may have floated out of+                -- args_in; they should be in scope for fireRewriteRules (#21689)++       -- Try firing rewrite rules+       -- See Note [Fire rules in the specialiser]+       ; let (fun_out', args_out') = fireRewriteRules env_args fun_out args_out++       -- Make a call record, and return+       ; let uds_call = mkCallUDs env fun_out' args_out'+       ; return (fun_out' `mkApps` args_out', uds_app `thenUDs` uds_call) }++---------------- Lambda/case require dumping of usage details --------------------+specExpr env e@(Lam {})+  = specLam env' bndrs' body+  where+    (bndrs, body)  = collectBinders e+    (env', bndrs') = substBndrs env bndrs+        -- More efficient to collect a group of binders together all at once+        -- and we don't want to split a lambda group with dumped bindings++specExpr env (Case scrut case_bndr ty alts)+  = do { (scrut', scrut_uds) <- specExpr env scrut+       ; (scrut'', case_bndr', alts', alts_uds)+             <- specCase env scrut' case_bndr alts+--       ; pprTrace "specExpr:case" (vcat+--            [ text "scrut" <+> ppr scrut, text "scrut'" <+> ppr scrut'+--            , text "case_bndr'" <+> ppr case_bndr'+--            , text "alts_uds" <+> ppr alts_uds+--            ])+       ; return (Case scrut'' case_bndr' (substTy env ty) alts'+                , scrut_uds `thenUDs` alts_uds) }++---------------- Finally, let is the interesting case --------------------+specExpr env (Let bind body)+  = do { (binds', body', uds) <- specBind NotTopLevel env bind $ \body_env ->+                                 -- pprTrace "specExpr:let" (ppr (se_subst body_env) $$ ppr body) $+                                 specExpr body_env body+         -- All done+       ; return (foldr Let body' binds', uds) }++-- See Note [Specialisation modulo dictionary selectors]+--     Note [ClassOp/DFun selection]+--     Note [Fire rules in the specialiser]+fireRewriteRules :: SpecEnv   -- Substitution is already zapped+                 -> OutExpr -> [OutExpr] -> (OutExpr, [OutExpr])+fireRewriteRules env (Var f) args+  | let rules = getRules (se_rules env) f+  , Just (rule, expr) <- specLookupRule env f args activeInInitialPhase rules+  , let rest_args    = drop (ruleArity rule) args -- See Note [Extra args in the target]+        zapped_subst = se_subst env   -- Just needed for the InScopeSet+        expr'        = simpleOptExprWith defaultSimpleOpts zapped_subst (mkApps expr rest_args)+                       -- simplOptExpr needed because lookupRule returns+                       --   (\x y. rhs) arg1 arg2+  , (fun', args') <- collectArgs expr'+  = fireRewriteRules env fun' args'+fireRewriteRules _ fun args = (fun, args)++--------------+specLam :: SpecEnv -> [OutBndr] -> InExpr -> SpecM (OutExpr, UsageDetails)+-- The binders have been substituted, but the body has not+specLam env bndrs body+  | null bndrs+  = specExpr env body+  | otherwise+  = do { (body', uds) <- specExpr env body+       ; let (free_uds, dumped_dbs) = dumpUDs bndrs uds+       ; return (mkLams bndrs (wrapDictBindsE dumped_dbs body'), free_uds) }++--------------+specTickish :: SpecEnv -> CoreTickish -> CoreTickish+specTickish (SE { se_subst = subst }) bp = substTickish subst bp++--------------+specCase :: SpecEnv+         -> OutExpr             -- Scrutinee, already done+         -> InId -> [InAlt]+         -> SpecM ( OutExpr     -- New scrutinee+                  , OutId+                  , [OutAlt]+                  , UsageDetails)+specCase env scrut' case_bndr [Alt con args rhs]+  | -- See Note [Floating dictionaries out of cases]+    isDictTy (idType case_bndr)+  , interestingDict env scrut'+  , not (isDeadBinder case_bndr && null sc_args')+  = do { case_bndr_flt :| sc_args_flt <- mapM clone_me (case_bndr' :| sc_args')++       ; let case_bndr_flt' = case_bndr_flt `addDictUnfolding` scrut'+             scrut_bind     = mkDB (NonRec case_bndr_flt scrut')++             sc_args_flt' = zipWith addDictUnfolding sc_args_flt sc_rhss+             sc_rhss      = [ Case (Var case_bndr_flt') case_bndr' (idType sc_arg')+                                   [Alt con args' (Var sc_arg')]+                            | sc_arg' <- sc_args' ]+             cb_set       = unitVarSet case_bndr_flt'+             sc_binds     = [ DB { db_bind = NonRec sc_arg_flt sc_rhs, db_fvs  = cb_set }+                            | (sc_arg_flt, sc_rhs) <- sc_args_flt' `zip` sc_rhss ]++             flt_binds    = scrut_bind : sc_binds++             -- Extend the substitution for RHS to map the *original* binders+             -- to their floated versions.+             mb_sc_flts :: [Maybe DictId]+             mb_sc_flts = map (lookupVarEnv clone_env) args'+             clone_env  = zipVarEnv sc_args' sc_args_flt'++             subst_prs  = (case_bndr, Var case_bndr_flt)+                        : [ (arg, Var sc_flt)+                          | (arg, Just sc_flt) <- args `zip` mb_sc_flts ]+             subst'   = se_subst env_rhs+                        `Core.extendSubstInScopeList` (case_bndr_flt' : sc_args_flt')+                        `Core.extendIdSubstList`      subst_prs+             env_rhs' = env_rhs { se_subst = subst' }++       ; (rhs', rhs_uds)   <- specExpr env_rhs' rhs+       ; let (free_uds, dumped_dbs) = dumpUDs (case_bndr':args') rhs_uds+             all_uds = flt_binds `consDictBinds` free_uds+             alt'    = Alt con args' (wrapDictBindsE dumped_dbs rhs')+--       ; pprTrace "specCase" (ppr case_bndr $$ ppr scrut_bind) $+       ; return (Var case_bndr_flt, case_bndr', [alt'], all_uds) }+  where+    (env_rhs, (case_bndr':|args')) = substBndrs env (case_bndr:|args)+    sc_args' = filter is_flt_sc_arg args'++    clone_me bndr = do { uniq <- getUniqueM+                       ; return (mkUserLocalOrCoVar occ uniq wght ty loc) }+       where+         name = idName bndr+         wght = idMult bndr+         ty   = idType bndr+         occ  = nameOccName name+         loc  = getSrcSpan name++    arg_set = mkVarSet args'+    is_flt_sc_arg var =  isId var+                      && not (isDeadBinder var)+                      && isDictTy var_ty+                      && tyCoVarsOfType var_ty `disjointVarSet` arg_set+       where+         var_ty = idType var++specCase env scrut case_bndr alts+  = do { (alts', uds_alts) <- mapAndCombineSM spec_alt alts+       ; return (scrut, case_bndr', alts', uds_alts) }+  where+    (env_alt, case_bndr') = substBndr env case_bndr+    spec_alt (Alt con args rhs)+      = do { (rhs', uds) <- specExpr env_rhs rhs+           ; let (free_uds, dumped_dbs) = dumpUDs (case_bndr' : args') uds+--           ; unless (isNilOL dumped_dbs) $+--             pprTrace "specAlt" (vcat+--                 [text "case_bndr', args" <+> (ppr case_bndr' $$ ppr args)+--                 ,text "dumped" <+> ppr dumped_dbs ]) return ()+           ; return (Alt con args' (wrapDictBindsE dumped_dbs rhs'), free_uds) }+        where+          (env_rhs, args') = substBndrs env_alt args+++{- Note [Fire rules in the specialiser]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this (#21851)++    module A where+      f :: Num b => b -> (b, b)+      f x = (x + 1, snd (f x))+      {-# SPECIALIZE f :: Int -> (Int, Int) #-}++    module B (g') where+      import A++      g :: Num a => a -> a+      g x = fst (f x)+      {-# NOINLINE[99] g #-}++      h :: Int -> Int+      h = g++Note that `f` has the CPR property, and so will worker/wrapper.++The call to `g` in `h` will make us specialise `g @Int`. And the specialised+version of `g` will contain the call `f @Int`; but in the subsequent run of+the Simplifier, there will be a competition between:+  * The user-supplied SPECIALISE rule for `f`+  * The inlining of the wrapper for `f`+In fact, the latter wins -- see Note [tryRules: plan (BEFORE)]+GHC.Core.Opt.Simplify.Iteration.  However, it a bit fragile.++Moreover consider (test T21851_2):++    module A+      f :: (Ord a, Show b) => a -> b -> blah+      {-# RULE forall b. f @Int @b = wombat #-}++      wombat :: Show b => Int -> b -> blah+      wombat = blah++    module B+      import A+      g :: forall a. Ord a => blah+      g @a = ...g...f @a @Char....++      h = ....g @Int....++Now, in module B, GHC will specialise `g @Int`, which will lead to a+call `f @Int @Char`.  If we immediately (in the specialiser) rewrite+that to `womabat @Char`, we have a chance to specialise `wombat`.++Conclusion: it's treat if the Specialiser fires RULEs itself.+It's not hard to achieve: see `fireRewriteRules`. The only tricky bit is+making sure that we have a reasonably up to date EPS rule base. Currently+we load it up just once, in `initRuleEnv`, called at the beginning of+`specProgram`.++NB: you might wonder if running rules in the specialiser (this Note) renders+Note [tryRules: plan (BEFORE)] in the Simplifier (partly) redundant.  That is,+if we run rules in the specialiser, does it matter if we make rules "win" over+inlining in the Simplifier?  Yes, it does!  See the discussion in #21851.++Note [Floating dictionaries out of cases]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+   g = \d. case d of { MkD sc ... -> ...(f sc)... }+Naively we can't float d2's binding out of the case expression,+because 'sc' is bound by the case, and that in turn means we can't+specialise f, which seems a pity.++So we invert the case, by floating out a binding+for 'sc_flt' thus:+    sc_flt = case d of { MkD sc ... -> sc }+Now we can float the call instance for 'f'.  Indeed this is just+what'll happen if 'sc' was originally bound with a let binding,+but case is more efficient, and necessary with equalities. So it's+good to work with both.++You might think that this won't make any difference, because the+call instance will only get nuked by the \d.  BUT if 'g' itself is+specialised, then transitively we should be able to specialise f.++In general, given+   case e of cb { MkD sc ... -> ...(f sc)... }+we transform to+   let cb_flt = e+       sc_flt = case cb_flt of { MkD sc ... -> sc }+   in+   case cb_flt of bg { MkD sc ... -> ....(f sc_flt)... }++The "_flt" things are the floated binds; we use the current substitution+to substitute sc -> sc_flt in the RHS++************************************************************************+*                                                                      *+                     Dealing with a binding+*                                                                      *+************************************************************************+-}++bringFloatedDictsIntoScope :: SpecEnv -> FloatedDictBinds -> SpecEnv+bringFloatedDictsIntoScope env (FDB { fdb_bndrs = dx_bndrs })+  = -- pprTrace "brought into scope" (ppr dx_bndrs) $+    env {se_subst=subst'}+  where+   subst' = se_subst env `Core.extendSubstInScopeSet` dx_bndrs++specBind :: TopLevelFlag+         -> SpecEnv    -- At top-level only, this env already has the+                       -- top level binders in scope+         -> InBind+         -> (SpecEnv -> SpecM (body, UsageDetails))    -- Process the body+         -> SpecM ( [OutBind]           -- New bindings+                  , body                -- Body+                  , UsageDetails)       -- And info to pass upstream++-- Returned UsageDetails:+--    No calls for binders of this bind+specBind top_lvl env (NonRec fn rhs) do_body+  = do { (rhs', rhs_uds) <- specExpr env rhs++       ; (body_env1, fn1) <- case top_lvl of+                               TopLevel    -> return (env, fn)+                               NotTopLevel -> cloneBndrSM env fn++       ; let fn2 | isStableUnfolding (idUnfolding fn1) = fn1+                 | otherwise = fn1 `setIdUnfolding` mkSimpleUnfolding defaultUnfoldingOpts rhs'+             -- Update the unfolding with the perhaps-simpler or more specialised rhs'+             -- This is important: see Note [Update unfolding after specialisation]+             -- And in any case cloneBndrSM discards non-Stable unfoldings++             fn3 = floatifyIdDemandInfo fn2+             -- We zap the demand info because the binding may float,+             -- which would invalidate the demand info (see #17810 for example).+             -- Destroying demand info is not terrible; specialisation is+             -- always followed soon by demand analysis.+             -- See Note [Floatifying demand info when floating] in GHC.Core.Opt.SetLevels++             body_env2 = body_env1 `bringFloatedDictsIntoScope` ud_binds rhs_uds+                                   `extendInScope` fn3+                                   -- bringFloatedDictsIntoScope: see #23567++       ; (body', body_uds) <- do_body body_env2++       ; (fn4, spec_defns, body_uds1) <- specDefn env body_uds fn3 rhs++       ; let (free_uds, dump_dbs, float_all) = dumpBindUDs [fn4] body_uds1+             all_free_uds                    = free_uds `thenUDs` rhs_uds++             pairs = spec_defns ++ [(fn4, rhs')]+                        -- fn4 mentions the spec_defns in its rules,+                        -- so put the latter first++             final_binds :: [DictBind]+             -- See Note [From non-recursive to recursive]+             final_binds | not (isNilOL dump_dbs)+                         , not (null spec_defns)+                         = [recWithDumpedDicts pairs dump_dbs]+                         | otherwise+                         = [mkDB $ NonRec b r | (b,r) <- pairs]+                           ++ fromOL dump_dbs++             can_float_this_one = exprIsTopLevelBindable rhs (idType fn)+             -- exprIsTopLevelBindable: see Note [Care with unlifted bindings]++       ; if float_all && can_float_this_one then+             -- Rather than discard the calls mentioning the bound variables+             -- we float this (dictionary) binding along with the others+              return ([], body', all_free_uds `snocDictBinds` final_binds)+         else+             -- No call in final_uds mentions bound variables,+             -- so we can just leave the binding here+              return (map db_bind final_binds, body', all_free_uds) }+++specBind top_lvl env (Rec pairs) do_body+       -- Note [Specialising a recursive group]+  = do { let (bndrs,rhss) = unzip pairs++       ; (rec_env, bndrs1) <- case top_lvl of+                                 TopLevel    -> return (env, bndrs)+                                 NotTopLevel -> cloneRecBndrsSM env bndrs++       ; (rhss', rhs_uds)  <- mapAndCombineSM (specExpr rec_env) rhss+       ; (body', body_uds) <- do_body rec_env++       ; let scope_uds = body_uds `thenUDs` rhs_uds+                       -- Includes binds and calls arising from rhss++       ; (bndrs2, spec_defns2, uds2) <- specDefns rec_env scope_uds (bndrs1 `zip` rhss)+         -- bndrs2 is like bndrs1, but with RULES added++       ; (bndrs3, spec_defns3, uds3)+             <- if null spec_defns2  -- Common case: no specialisation+                then return (bndrs2, [], uds2)+                else do {            -- Specialisation occurred; do it again+                          (bndrs3, spec_defns3, uds3)+                              <- specDefns rec_env uds2 (bndrs2 `zip` rhss)+                        ; return (bndrs3, spec_defns3 ++ spec_defns2, uds3) }++       ; let (final_uds, dumped_dbs, float_all) = dumpBindUDs bndrs1 uds3+             final_bind = recWithDumpedDicts (spec_defns3 ++ zip bndrs3 rhss')+                                             dumped_dbs++       ; if float_all then+              return ([], body', final_uds `snocDictBind` final_bind)+         else+              return ([db_bind final_bind], body', final_uds) }+++---------------------------+specDefns :: SpecEnv+          -> UsageDetails               -- Info on how it is used in its scope+          -> [(OutId,InExpr)]           -- The things being bound and their un-processed RHS+          -> SpecM ([OutId],            -- Original Ids with RULES added+                    [(OutId,OutExpr)],  -- Extra, specialised bindings+                    UsageDetails)       -- Stuff to fling upwards from the specialised versions++-- Specialise a list of bindings (the contents of a Rec), but flowing usages+-- upwards binding by binding.  Example: { f = ...g ...; g = ...f .... }+-- Then if the input CallDetails has a specialised call for 'g', whose specialisation+-- in turn generates a specialised call for 'f', we catch that in this one sweep.+-- But not vice versa (it's a fixpoint problem).++specDefns _env uds []+  = return ([], [], uds)+specDefns env uds ((bndr,rhs):pairs)+  = do { (bndrs1, spec_defns1, uds1) <- specDefns env uds  pairs+       ; (bndr1, spec_defns2, uds2)  <- specDefn  env uds1 bndr rhs+       ; return (bndr1 : bndrs1, spec_defns1 ++ spec_defns2, uds2) }++---------------------------+specDefn :: SpecEnv+         -> UsageDetails                -- Info on how it is used in its scope+         -> OutId -> InExpr             -- The thing being bound and its un-processed RHS+         -> SpecM (Id,                  -- Original Id with added RULES+                   [(Id,CoreExpr)],     -- Extra, specialised bindings+                   UsageDetails)        -- Stuff to fling upwards from the specialised versions++specDefn env body_uds fn rhs+  = do { let (body_uds_without_me, calls_for_me) = callsForMe fn body_uds+             rules_for_me = idCoreRules fn+             -- Bring into scope the binders from the floated dicts+             env_w_dict_bndrs = bringFloatedDictsIntoScope env (ud_binds body_uds)++       ; (rules, spec_defns, spec_uds) <- specCalls False env_w_dict_bndrs+                                                    rules_for_me calls_for_me fn rhs++       ; return ( fn `addIdSpecialisations` rules+                , spec_defns+                , body_uds_without_me `thenUDs` spec_uds) }+                -- It's important that the `thenUDs` is this way+                -- round, because body_uds_without_me may bind+                -- dictionaries that are used in calls_for_me passed+                -- to specDefn.  So the dictionary bindings in+                -- spec_uds may mention dictionaries bound in+                -- body_uds_without_me++---------------------------+specCalls :: Bool              -- True  =>  specialising imported fn+                               -- False =>  specialising local fn+          -> SpecEnv+          -> [CoreRule]        -- Existing RULES for the fn+          -> [CallInfo]+          -> OutId -> InExpr+          -> SpecM SpecInfo    -- New rules, specialised bindings, and usage details++-- This function checks existing rules, and does not create+-- duplicate ones. So the caller does not need to do this filtering.+-- See `alreadyCovered`++type SpecInfo = ( [CoreRule]       -- Specialisation rules+                , [(Id,CoreExpr)]  -- Specialised definition+                , UsageDetails )   -- Usage details from specialised RHSs++specCalls spec_imp env existing_rules calls_for_me fn rhs+        -- The first case is the interesting one+  |  notNull calls_for_me               -- And there are some calls to specialise+  && not (isNeverActive (idInlineActivation fn))+        -- Don't specialise NOINLINE things+        -- See Note [Auto-specialisation and RULES]+        --+        -- Don't specialise OPAQUE things, see Note [OPAQUE pragma].+        -- Since OPAQUE things are always never-active (see+        -- GHC.Parser.PostProcess.mkOpaquePragma) this guard never fires for+        -- OPAQUE things.++--   && not (certainlyWillInline (idUnfolding fn))      -- And it's not small+--      See Note [Inline specialisations] for why we do not+--      switch off specialisation for inline functions++  = -- pprTrace "specCalls: some" (vcat+    --  [ text "function" <+> ppr fn+    --  , text "calls:" <+> ppr calls_for_me+    --  , text "subst" <+> ppr (se_subst env) ]) $+    foldlM spec_call ([], [], emptyUDs) calls_for_me++  | otherwise   -- No calls or RHS doesn't fit our preconceptions+  = warnPprTrace (not (exprIsTrivial rhs) && notNull calls_for_me)+          "Missed specialisation opportunity for" (ppr fn $$ trace_doc) $+          -- Note [Specialisation shape]+    -- pprTrace "specCalls: none" (ppr fn <+> ppr calls_for_me) $+    return ([], [], emptyUDs)+  where+    trace_doc = sep [ ppr rhs_bndrs, ppr (idInlineActivation fn) ]++    fn_type   = idType fn+    fn_arity  = idArity fn+    fn_unf    = realIdUnfolding fn  -- Ignore loop-breaker-ness here+    inl_prag  = idInlinePragma fn+    inl_act   = inlinePragmaActivation inl_prag+    is_active = isActive (beginPhase inl_act) :: Activation -> Bool+         -- is_active: inl_act is the activation we are going to put in the new+         --   SPEC rule; so we want to see if it is covered by another rule with+         --   that same activation.+    is_local  = isLocalId fn+    is_dfun   = isDFunId fn+    dflags    = se_dflags env+    this_mod  = se_module env+    subst     = se_subst env+    in_scope  = Core.substInScopeSet subst+        -- Figure out whether the function has an INLINE pragma+        -- See Note [Inline specialisations]++    (rhs_bndrs, rhs_body) = collectBindersPushingCo rhs+                            -- See Note [Account for casts in binding]++    -- Copy InlinePragma information from the parent Id.+    -- So if f has INLINE[1] so does spec_fn+    spec_inl_prag+      | not is_local     -- See Note [Specialising imported functions]+      , isStrongLoopBreaker (idOccInfo fn) -- in GHC.Core.Opt.OccurAnal+      = neverInlinePragma+      | otherwise+      = inl_prag++    not_in_scope :: InterestingVarFun+    not_in_scope v = isLocalVar v && not (v `elemInScopeSet` in_scope)++    ----------------------------------------------------------+        -- Specialise to one particular call pattern+    spec_call :: SpecInfo                         -- Accumulating parameter+              -> CallInfo                         -- Call instance+              -> SpecM SpecInfo+    spec_call spec_acc@(rules_acc, pairs_acc, uds_acc) _ci@(CI { ci_key = call_args })+      = -- See Note [Specialising Calls]+        do { let all_call_args | is_dfun   = saturating_call_args -- See Note [Specialising DFuns]+                               | otherwise = call_args+                 saturating_call_args = call_args ++ map mk_extra_dfun_arg (dropList call_args rhs_bndrs)+                 mk_extra_dfun_arg bndr | isTyVar bndr = UnspecType+                                        | otherwise    = UnspecArg++             -- Find qvars, the type variables to add to the binders for the rule+             -- Namely those free in `ty` that aren't in scope+             -- See (MP2) in Note [Specialising polymorphic dictionaries]+           ; let poly_qvars = scopedSort $ fvVarList $ specArgsFVs not_in_scope call_args+                 subst'     = subst `Core.extendSubstInScopeList` poly_qvars+                              -- Maybe we should clone the poly_qvars telescope?++             -- Any free Ids will have caused the call to be dropped+           ; massertPpr (all isTyCoVar poly_qvars)+                        (ppr fn $$ ppr all_call_args $$ ppr poly_qvars)++           ; (useful, subst'', rule_bndrs, rule_lhs_args, spec_bndrs, dx_binds, spec_args)+                 <- specHeader subst' rhs_bndrs all_call_args+           ; let all_rule_bndrs = poly_qvars ++ rule_bndrs+                 env' = env { se_subst = subst'' }++           -- Check for (a) usefulness and (b) not already covered+           -- See (SC1) in Note [Specialisations already covered]+           ; let all_rules = rules_acc ++ existing_rules+                 -- all_rules: we look both in the rules_acc (generated by this invocation+                 --   of specCalls), and in existing_rules (passed in to specCalls)+                 already_covered = alreadyCovered env' all_rule_bndrs fn+                                                  rule_lhs_args is_active all_rules++{-         ; pprTrace "spec_call" (vcat+                [ text "fun:       "  <+> ppr fn+                , text "call info: "  <+> ppr _ci+                , text "useful:    "  <+> ppr useful+                , text "already_covered:"  <+> ppr already_covered+                , text "poly_qvars: " <+> ppr poly_qvars+                , text "useful:    "  <+> ppr useful+                , text "all_rule_bndrs:"  <+> ppr all_rule_bndrs+                , text "rule_lhs_args:"  <+> ppr rule_lhs_args+                , text "spec_bndrs:" <+> ppr spec_bndrs+                , text "dx_binds:"   <+> ppr dx_binds+                , text "spec_args: "  <+> ppr spec_args+                , text "rhs_bndrs"    <+> ppr rhs_bndrs+                , text "rhs_body"     <+> ppr rhs_body+                , text "subst''" <+> ppr subst'' ]) $+             return ()+-}++           ; if not useful          -- No useful specialisation+                || already_covered  -- Useful, but done already+             then return spec_acc+             else++        -- Not useless, not already covered: make a specialised binding+        do { let inner_rhs_bndrs = dropList all_call_args rhs_bndrs+                 (env'', inner_rhs_bndrs') = substBndrs env' inner_rhs_bndrs++             -- Run the specialiser on the specialised RHS+           ; (rhs_body', rhs_uds) <- specExpr env'' rhs_body++{-         ; pprTrace "spec_call2" (vcat+                 [ text "fun:" <+> ppr fn+                 , text "rhs_body':" <+> ppr rhs_body' ]) $+             return ()+-}++           -- Make the RHS of the specialised function+           ; let spec_rhs_bndrs = spec_bndrs ++ inner_rhs_bndrs'+                 (rhs_uds1, inner_dumped_dbs) = dumpUDs spec_rhs_bndrs rhs_uds+                 (rhs_uds2, outer_dumped_dbs) = dumpUDs poly_qvars (dx_binds `consDictBinds` rhs_uds1)+                 -- dx_binds comes from the arguments to the call, and so can mention+                 -- poly_qvars but no other local binders+                 spec_rhs = mkLams poly_qvars               $+                            wrapDictBindsE outer_dumped_dbs $+                            mkLams spec_rhs_bndrs           $+                            wrapDictBindsE inner_dumped_dbs rhs_body'+                 rule_rhs_args = poly_qvars ++ spec_bndrs++                 -- Maybe add a void arg to the specialised function,+                 -- to avoid unlifted bindings+                 -- See Note [Specialisations Must Be Lifted]+                 -- C.f. GHC.Core.Opt.WorkWrap.Utils.needsVoidWorkerArg++                 spec_fn_ty = exprType spec_rhs+                 add_void_arg = isUnliftedType spec_fn_ty && not (isJoinId fn)+                 (rule_rhs_args1, spec_rhs1, spec_fn_ty1)+                   | add_void_arg = ( voidPrimId : rule_rhs_args+                                    , Lam voidArgId spec_rhs+                                    , mkVisFunTyMany unboxedUnitTy spec_fn_ty )+                   | otherwise    = (rule_rhs_args, spec_rhs, spec_fn_ty)++                 --------------------------------------+                 -- Add a suitable unfolding; see Note [Inline specialisations]+                 -- The wrap_unf_body applies the original unfolding to the specialised+                 -- arguments, not forgetting to wrap the dx_binds around the outside (#22358)+                 simpl_opts = initSimpleOpts dflags+                 wrap_unf_body body = foldr (Let . db_bind) (body `mkApps` spec_args) dx_binds+                 spec_unf = specUnfolding simpl_opts rule_rhs_args1 wrap_unf_body+                                          rule_lhs_args fn_unf++                 --------------------------------------+                 -- Adding arity information just propagates it a bit faster+                 --      See Note [Arity decrease] in GHC.Core.Opt.Simplify+                 join_arity_decr = length rule_lhs_args         - length rule_rhs_args1+                 arity_decr      = count isValArg rule_lhs_args - count isId rule_rhs_args1++                 spec_fn_info+                   = vanillaIdInfo `setArityInfo`      max 0 (fn_arity - arity_decr)+                                   `setInlinePragInfo` spec_inl_prag+                                   `setUnfoldingInfo`  spec_unf++                 -- Compute the IdDetails of the specialise Id+                 -- See Note [Transfer IdDetails during specialisation]+                 spec_fn_details+                   = case idDetails fn of+                       JoinId join_arity _ -> JoinId (join_arity - join_arity_decr) Nothing+                       DFunId unary        -> DFunId unary+                       _                   -> VanillaId++           ; spec_fn <- newSpecIdSM (idName fn) spec_fn_ty1 spec_fn_details spec_fn_info+           ; let+                -- The rule to put in the function's specialisation is:+                --      forall x @b d1' d2'.+                --          f x @T1 @b @T2 d1' d2' = f1 x @b+                -- See Note [Specialising Calls]+                herald | spec_imp  = -- Specialising imported fn+                                     text "SPEC/" <> ppr this_mod+                       | otherwise = -- Specialising local fn+                                     text "SPEC"++                spec_rule = mkSpecRule dflags this_mod True inl_act+                                    herald fn all_rule_bndrs rule_lhs_args+                                    (mkVarApps (Var spec_fn) rule_rhs_args1)++                _rule_trace_doc = vcat [ ppr fn <+> dcolon <+> ppr fn_type+                                       , ppr spec_fn  <+> dcolon <+> ppr spec_fn_ty1+                                       , ppr rhs_bndrs, ppr call_args+                                       , ppr spec_rule+                                       , text "acc" <+> ppr rules_acc+                                       , text "existing" <+> ppr existing_rules+                                       ]++           ; -- pprTrace "spec_call: rule" _rule_trace_doc+             return ( spec_rule            : rules_acc+                    , (spec_fn, spec_rhs1) : pairs_acc+                    , rhs_uds2 `thenUDs` uds_acc+                    ) } }++alreadyCovered :: SpecEnv+               -> [Var] -> Id -> [CoreExpr]   -- LHS of possible new rule+               -> (Activation -> Bool)        -- Which rules are active+               -> [CoreRule] -> Bool+-- Note [Specialisations already covered] esp (SC2)+alreadyCovered env bndrs fn args is_active rules+  = case specLookupRule env fn args is_active rules of+      Nothing             -> False+      Just (rule, _)+        | isAutoRule rule -> -- Discard identical rules+                             -- We know that (fn args) is an instance of RULE+                             -- Check if RULE is an instance of (fn args)+                             ruleLhsIsMoreSpecific in_scope bndrs args rule+        | otherwise       -> True  -- User rules dominate+  where+    in_scope = substInScopeSet (se_subst env)++-- Convenience function for invoking lookupRule from Specialise+-- The SpecEnv's InScopeSet should include all the Vars in the [CoreExpr]+specLookupRule :: HasDebugCallStack+               => SpecEnv -> Id -> [CoreExpr]+               -> (Activation -> Bool)  -- Which rules are active+               -> [CoreRule] -> Maybe (CoreRule, CoreExpr)+specLookupRule env fn args is_active rules+  | null rules+  = Nothing    -- Saves building a few thunks in the common case+  | otherwise+  = lookupRule ropts in_scope_env is_active fn args rules+  where+    dflags       = se_dflags env+    in_scope     = substInScopeSet (se_subst env)+    in_scope_env = ISE in_scope (whenActiveUnfoldingFun is_active)+    ropts        = initRuleOpts dflags++{- Note [Specialising DFuns]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+DFuns have a special sort of unfolding (DFunUnfolding), and it is+hard to specialise a DFunUnfolding to give another DFunUnfolding+unless the DFun is fully applied (#18120).  So, in the case of DFunIds+we simply extend the CallKey with trailing UnspecTypes/UnspecArgs,+so that we'll generate a rule that completely saturates the DFun.++There is an ASSERT that checks this, in the DFunUnfolding case of+GHC.Core.Unfold.Make.specUnfolding.++Note [Transfer IdDetails during specialisation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When specialising a function, `newSpecIdSM` comes up with a fresh Id the+specialised RHS will be bound to. It is critical that we get the `IdDetails` of+the specialised Id correct:++* JoinId: We want the specialised Id to be a join point, too.  But+  we have to carefully adjust the arity++* DFunId: It is crucial that we also make the new Id a DFunId.+  - First, because it obviously /is/ a DFun, having a DFunUnfolding and+    all that; see Note [Specialising DFuns]++  - Second, DFuns get very delicate special treatment in the demand analyser;+    see GHC.Core.Opt.DmdAnal.enterDFun.  If the specialised function isn't+    also a DFunId, this special treatment doesn't happen, so the demand+    analyser makes a too-strict DFun, and we get an infinite loop.  See Note+    [Do not strictify a DFun's parameter dictionaries] in GHC.Core.Opt.DmdAnal.+    #22549 describes the loop, and (lower down) a case where a /specialised/+    DFun caused a loop.++* WorkerLikeId: Introduced by WW, so after Specialise. Nevertheless, they come+  up when specialising imports. We must keep them as VanillaIds because WW+  will detect them as WorkerLikeIds again. That is, unless specialisation+  allows unboxing of all previous CBV args, in which case sticking to+  VanillaIds was the only correct choice to begin with.++* RecSelId, DataCon*Id, ClassOpId, PrimOpId, FCallId, CoVarId, TickBoxId:+  Never specialised.++Note [Specialisation Must Preserve Sharing]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider a function:++    f :: forall a. Eq a => a -> blah+    f =+      if expensive+         then f1+         else f2++As written, all calls to 'f' will share 'expensive'. But if we specialise 'f'+at 'Int', eg:++    $sfInt = SUBST[a->Int,dict->dEqInt] (if expensive then f1 else f2)++    RULE "SPEC f"+      forall (d :: Eq Int).+        f Int _ = $sfIntf++We've now lost sharing between 'f' and '$sfInt' for 'expensive'. Yikes!++To avoid this, we only generate specialisations for functions whose arity is+enough to bind all of the arguments we need to specialise.  This ensures our+specialised functions don't do any work before receiving all of their dicts,+and thus avoids the 'f' case above.++Note [Specialisations Must Be Lifted]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider a function 'f':++    f = forall a. Eq a => Array# a++used like++    case x of+      True -> ...f @Int dEqInt...+      False -> 0++Naively, we might generate an (expensive) specialisation++    $sfInt :: Array# Int++even in the case that @x = False@! Instead, we add a dummy 'Void#' argument to+the specialisation '$sfInt' ($sfInt :: Void# -> Array# Int) in order to+preserve laziness.++Note [Care with unlifted bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider (#22998)+    f x = let x::ByteArray# = <some literal>+              n::Natural    = NB x+          in wombat @192827 (n |> co)+where+  co :: Natural ~ KnownNat 192827+  wombat :: forall (n:Nat). KnownNat n => blah++Left to itself, the specialiser would float the bindings for `x` and `n` to top+level, so we can specialise `wombat`.  But we can't have a top-level ByteArray#+(see Note [Core letrec invariant] in GHC.Core).  Boo.++This is pretty exotic, so we take a simple way out: in specBind (the NonRec+case) do not float the binding itself unless it satisfies exprIsTopLevelBindable.+This is conservative: maybe the RHS of `x` has a free var that would stop it+floating to top level anyway; but that is hard to spot (since we don't know what+the non-top-level in-scope binders are) and rare (since the binding must satisfy+Note [Core let-can-float invariant] in GHC.Core).+++Note [Specialising Calls]+~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have a function with a complicated type:++    f :: forall a b c. Int -> Eq a => Show b => c -> Blah+    f @a @b @c i dEqA dShowA x = blah++and suppose it is called at:++    f @T1 @T2 @T3 7 dEqT1 ($dfShow dShowT2) t3++This call is described as a 'CallInfo' whose 'ci_key' is:++    [ SpecType T1, SpecType T2, UnspecType+    , UnspecArg+    , SpecDict dEqT1+    , SpecDict ($dfShow dShowT2)+    , UnspecArg ]++Why are 'a' and 'b' identified as 'SpecType', while 'c' is 'UnspecType'?+Because we must specialise the function on type variables that appear+free in its *dictionary* arguments; but not on type variables that do not+appear in any dictionaries, i.e. are fully polymorphic.++Because this call has dictionaries applied, we'd like to specialise+the call on any type argument that appears free in those dictionaries.+In this case, those are [a :-> T1, b :-> T2].++We also need to substitute the dictionary binders with their+specialised dictionaries. The simplest substitution would be+[dEqA :-> dEqT1, dShowA :-> $dfShow dShowT2], but this duplicates+work, since `$dfShow dShowT2` is a function application. Therefore, we+also want to *float the dictionary out* (via bindAuxiliaryDict),+creating a new dict binding++    dShow1 = $dfShow dShowT2++and the substitution [dEqA :-> dEqT1, dShowA :-> dShow1].++With the substitutions in hand, we can generate a specialised function:++    $sf :: forall c. Int -> c -> Blah+    $sf = SUBST[a :-> T1, b :-> T2, dEqA :-> dEqT1, dShowA :-> dShow1] (\@c i x -> blah)++Note that the substitution is applied to the whole thing.  This is+convenient, but just slightly fragile.  Notably:+  * There had better be no name clashes in a/b/c++We must construct a rewrite rule:++    RULE "SPEC f @T1 @T2 _"+      forall (@c :: Type) (i :: Int) (d1 :: Eq T1) (d2 :: Show T2).+        f @T1 @T2 @c i d1 d2 = $sf @c i++In the rule, d1 and d2 are just wildcards, not used in the RHS.  Note+additionally that 'x' isn't captured by this rule --- we bind only+enough etas in order to capture all of the *specialised* arguments.++Note [Drop dead args from specialisations]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When specialising a function, it’s possible some of the arguments may+actually be dead. For example, consider:++    f :: forall a. () -> Show a => a -> String+    f x y = show y ++ "!"++We might generate the following CallInfo for `f @Int`:++    [SpecType Int, UnspecArg, SpecDict $dShowInt, UnspecArg]++Normally we’d include both the x and y arguments in the+specialisation, since we’re not specialising on either of them. But+that’s silly, since x is actually unused! So we might as well drop it+in the specialisation:++    $sf :: Int -> String+    $sf y = show y ++ "!"++    {-# RULE "SPEC f @Int" forall x. f @Int x $dShow = $sf #-}++This doesn’t save us much, since the arg would be removed later by+worker/wrapper, anyway, but it’s easy to do.++Wrinkles++* Note that we only drop dead arguments if:+    1. We don’t specialise on them.+    2. They come before an argument we do specialise on.+  Doing the latter would require eta-expanding the RULE, which could+  make it match less often, so it’s not worth it. Doing the former could+  be more useful --- it would stop us from generating pointless+  specialisations --- but it’s more involved to implement and unclear if+  it actually provides much benefit in practice.++* If the function has a stable unfolding, specHeader has to come up with+  arguments to pass to that stable unfolding, when building the stable+  unfolding of the specialised function: this is the last field in specHeader's+  big result tuple.++  The right thing to do is to produce a LitRubbish; it should rapidly+  disappear.  Rather like GHC.Core.Opt.WorkWrap.Utils.mk_absent_let.++Note [Specialisation modulo dictionary selectors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In #19644, we discovered that the ClassOp/DFun rules from+Note [ClassOp/DFun selection] inhibit transitive specialisation.+Example, inspired by T17966:++  class C a where+    m :: Show b => a -> b -> String+    dummy :: a -> () -- Force a datatype dictionary representation++  instance C Int where+    m a b = show a ++ show b+    dummy _ = ()++  f :: (C a, Show b) => a -> b -> String+  f a b = m a b ++ "!"+  {-# INLINABLE[0] f #-}++  main = putStrLn (f (42::Int) (True::Bool))++Here, we specialise `f` at `Int` and `Bool`, giving++  $dC = $fCInt+  $dShow = GHC.Show.$fShowBool+  $sf (a::Int) (b::Bool) =+        ... (m @Int $dC @Bool $dShow a b) ...++Here `m` is just a DictSel, so there is (apparently) nothing to specialise!+However, the next Simplifier run will expose the rewritten instance method:++  ... $fCInt_$cm @Bool $fShowBool a b ...++where $fCInt_$cm is the instance method for `m` in `instance C Int`:++   $fCInt_$cm :: forall b. Show b => Int -> b -> String+   $fCInt_$cm b d x y = show @Int $dShowInt x ++ show @b d y++We want to specialise this! How? By doing the method-selection rewrite in+the Specialiser. Hence++1. In the App case of 'specExpr', try to apply the ClassOp/DFun rule on the+   head of the application, repeatedly, via 'fireRewriteRules'.+2. Attach an unfolding to freshly-bound dictionary ids such as `$dC` and+   `$dShow` in `bindAuxiliaryDict`, so that we can exploit the unfolding+   in 'fireRewriteRules' to do the ClassOp/DFun rewrite.++NB: Without (2), (1) would be pointless, because 'lookupRule' wouldn't be able+to look into the RHS of `$dC` to see the DFun.++Note [Zap occ info in rule binders]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we generate a specialisation RULE, we need to drop occurrence+info on the binders. If we don’t, things go wrong when we specialise a+function like++    f :: forall a. () -> Show a => a -> String+    f x y = show y ++ "!"++since we’ll generate a RULE like++    RULE "SPEC f @Int" forall x [Occ=Dead].+      f @Int x $dShow = $sf++and Core Lint complains, even though x only appears on the LHS (due to+Note [Drop dead args from specialisations]).++Why is that a Lint error? Because the arguments on the LHS of a rule+are syntactically expressions, not patterns, so Lint treats the+appearance of x as a use rather than a binding. Fortunately, the+solution is simple: we just make sure to zap the occ info before+using ids as wildcard binders in a rule.++Note [Account for casts in binding]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+   f :: Eq a => a -> IO ()+   {-# INLINABLE f+       StableUnf = (/\a \(d:Eq a) (x:a). blah) |> g+     #-}+   f = ...++In f's stable unfolding we have done some modest simplification which+has pushed the cast to the outside.  (I wonder if this is the Right+Thing, but it's what happens now; see GHC.Core.Opt.Simplify.Utils Note [Casts and+lambdas].)  Now that stable unfolding must be specialised, so we want+to push the cast back inside. It would be terrible if the cast+defeated specialisation!  Hence the use of collectBindersPushingCo.++Note [Evidence foralls]+~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose (#12212) that we are specialising+   f :: forall a b. (Num a, F a ~# F b) => blah+with a=b=Int. Then the RULE will be something like+   RULE forall (d:Num Int) (g :: F Int ~# F Int).+        f Int Int d g = f_spec+where that `g` is really (Coercion (CoVar g)), since `g` is a+coercion variable and can't appear as (Var g).++But both varToCoreExpr (when constructing the LHS args), and the+simplifier (when simplifying the LHS args), will transform to+   RULE forall (d:Num Int) (g :: F Int ~ F Int).+        f Int Int d <F Int> = f_spec+by replacing g with Refl.  So now 'g' is unbound, which results in a later+crash. So we use Refl right off the bat, and do not forall-quantify 'g':+ * varToCoreExpr generates a (Coercion Refl)+ * exprsFreeIdsList returns the Ids bound by the args,+   which won't include g++You might wonder if this will match as often, but the simplifier replaces+complicated Refl coercions with Refl pretty aggressively.++Note [Orphans and auto-generated rules]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we specialise an INLINABLE function, or when we have+-fspecialise-aggressively, we auto-generate RULES that are orphans.+We don't want to warn about these, or we'd generate a lot of warnings.+Thus, we only warn about user-specified orphan rules.++Indeed, we don't even treat the module as an orphan module if it has+auto-generated *rule* orphans.  Orphan modules are read every time we+compile, so they are pretty obtrusive and slow down every compilation,+even non-optimised ones.  (Reason: for type class instances it's a+type correctness issue.)  But specialisation rules are strictly for+*optimisation* only so it's fine not to read the interface.++What this means is that a SPEC rules from auto-specialisation in+module M will be used in other modules only if M.hi has been read for+some other reason, which is actually pretty likely.++Note [From non-recursive to recursive]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Even in the non-recursive case, if any dict-binds depend on 'fn' we might+have built a recursive knot++      f a d x = <blah>+      MkUD { ud_binds = NonRec d7  (MkD ..f..)+           , ud_calls = ...(f T d7)... }++The we generate++     Rec { fs x = <blah>[T/a, d7/d]+           f a d x = <blah>+               RULE f T _ = fs+           d7 = ...f... }++Here the recursion is only through the RULE.++However we definitely should /not/ make the Rec in this wildly common+case:+      d = ...+      MkUD { ud_binds = NonRec d7 (...d...)+           , ud_calls = ...(f T d7)... }++Here we want simply to add d to the floats, giving+      MkUD { ud_binds = NonRec d (...)+                        NonRec d7 (...d...)+           , ud_calls = ...(f T d7)... }++In general, we need only make this Rec if+  - there are some specialisations (spec_binds non-empty)+  - there are some dict_binds that depend on f (dump_dbs non-empty)++Note [Avoiding loops (DFuns)]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When specialising /dictionary functions/ we must be very careful to+avoid building loops. Here is an example that bit us badly, on+several distinct occasions.++Here is one: #3591+     class Eq a => C a+     instance Eq [a] => C [a]++This translates to+     dfun :: Eq [a] -> C [a]+     dfun a d = MkD a d (meth d)++     d4 :: Eq [T] = <blah>+     d2 ::  C [T] = dfun T d4+     d1 :: Eq [T] = $p1 d2+     d3 ::  C [T] = dfun T d1++None of these definitions is recursive. What happened was that we+generated a specialisation:+     RULE forall d. dfun T d = dT  :: C [T]+     dT = (MkD a d (meth d)) [T/a, d1/d]+        = MkD T d1 (meth d1)++But now we use the RULE on the RHS of d2, to get+    d2 = dT = MkD d1 (meth d1)+    d1 = $p1 d2++and now d1 is bottom!  The problem is that when specialising 'dfun' we+should first dump "below" the binding all floated dictionary bindings+that mention 'dfun' itself.  So d2 and d3 (and hence d1) must be+placed below 'dfun', and thus unavailable to it when specialising+'dfun'.  That in turn means that the call (dfun T d1) must be+discarded.  On the other hand, the call (dfun T d4) is fine, assuming+d4 doesn't mention dfun.++Solution:+  Discard all calls that mention dictionaries that depend+  (directly or indirectly) on the dfun we are specialising.+  This is done by 'filterCalls'++Note [Avoiding loops (non-DFuns)]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The whole Note [Avoiding loops (DFuns)] things applies only to DFuns.+It's important /not/ to apply filterCalls to non-DFuns. For example:++  class C a where { foo,bar :: [a] -> [a] }++  instance C Int where+     foo x = r_bar x+     bar xs = reverse xs++  r_bar :: C a => [a] -> [a]+  r_bar xs = bar (xs ++ xs)++That translates to:++    r_bar a (c::C a) (xs::[a]) = bar a d (xs ++ xs)++    Rec { $fCInt :: C Int = MkC foo_help reverse+          foo_help (xs::[Int]) = r_bar Int $fCInt xs }++The call (r_bar $fCInt) mentions $fCInt,+                        which mentions foo_help,+                        which mentions r_bar++But we DO want to specialise r_bar at Int:+    Rec { $fCInt :: C Int = MkC foo_help reverse+          foo_help (xs::[Int]) = r_bar Int $fCInt xs++          r_bar a (c::C a) (xs::[a]) = bar a d (xs ++ xs)+            RULE r_bar Int _ = r_bar_Int++          r_bar_Int xs = bar Int $fCInt (xs ++ xs)+           }++Note that, because of its RULE, r_bar joins the recursive+group.  (In this case it'll unravel a short moment later.)+See test simplCore/should_compile/T19599a.++Another example is #19599, which looked like this:++   class (Show a, Enum a) => MyShow a where+      myShow :: a -> String++   myShow_impl :: MyShow a => a -> String++   foo :: Int -> String+   foo = myShow_impl @Int $fMyShowInt++   Rec { $fMyShowInt = MkMyShowD $fEnumInt $fShowInt $cmyShow+       ; $cmyShow = myShow_impl @Int $fMyShowInt }++Here, we really do want to specialise `myShow_impl @Int $fMyShowInt`.+++Note [Specialising a recursive group]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+    let rec { f x = ...g x'...+            ; g y = ...f y'.... }+    in f 'a'+Here we specialise 'f' at Char; but that is very likely to lead to+a specialisation of 'g' at Char.  We must do the latter, else the+whole point of specialisation is lost.++But we do not want to keep iterating to a fixpoint, because in the+presence of polymorphic recursion we might generate an infinite number+of specialisations.++So we use the following heuristic:+  * Arrange the rec block in dependency order, so far as possible+    (the occurrence analyser already does this)++  * Specialise it much like a sequence of lets++  * Then go through the block a second time, feeding call-info from+    the RHSs back in the bottom, as it were++In effect, the ordering maxmimises the effectiveness of each sweep,+and we do just two sweeps.   This should catch almost every case of+monomorphic recursion -- the exception could be a very knotted-up+recursion with multiple cycles tied up together.++This plan is implemented in the Rec case of specBindItself.++Note [Specialisations already covered]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We obviously don't want to generate two specialisations for the same+argument pattern.  Wrinkles++(SC1) We do the already-covered test in specDefn, not when we generate+    the CallInfo in mkCallUDs.  We used to test in the latter place, but+    we now iterate the specialiser somewhat, and the Id at the call site+    might therefore not have all the RULES that we can see in specDefn++(SC2) What about two specialisations where the second is an *instance*+   of the first?  It's a bit arbitrary, but here's what we do:+   * If the existing one is user-specified, via a SPECIALISE pragma, we+     suppress the further specialisation.+   * If the existing one is auto-generated, we generate a second RULE+     for the more specialised version.+   The latter is important because we don't want the accidental order+   of calls to determine what specialisations we generate.++(SC3) Annoyingly, we /also/ eliminate duplicates in `filterCalls`.+   See (MP3) in Note [Specialising polymorphic dictionaries]++Note [Auto-specialisation and RULES]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider:+   g :: Num a => a -> a+   g = ...++   f :: (Int -> Int) -> Int+   f w = ...+   {-# RULE f g = 0 #-}++Suppose that auto-specialisation makes a specialised version of+g::Int->Int. That version won't appear in the LHS of the RULE for f.+So if the specialisation rule fires too early, the rule for f may+never fire.++It might be possible to add new rules, to "complete" the rewrite system.+Thus when adding+        RULE forall d. g Int d = g_spec+also add+        RULE f g_spec = 0++But that's a bit complicated.  For now we ask the programmer's help,+by *copying the INLINE activation pragma* to the auto-specialised+rule.  So if g says {-# NOINLINE[2] g #-}, then the auto-spec rule+will also not be active until phase 2.  And that's what programmers+should jolly well do anyway, even aside from specialisation, to ensure+that g doesn't inline too early.++This in turn means that the RULE would never fire for a NOINLINE+thing so not much point in generating a specialisation at all.++Note [Specialisation shape]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+We only specialise a function if it has visible top-level lambdas+corresponding to its overloading.  E.g. if+        f :: forall a. Eq a => ....+then its body must look like+        f = /\a. \d. ...++Reason: when specialising the body for a call (f ty dexp), we want to+substitute dexp for d, and pick up specialised calls in the body of f.++We do allow casts, however; see Note [Account for casts in binding].++This doesn't always work.  One example I came across was this:+        newtype Gen a = MkGen{ unGen :: Int -> a }++        choose :: Eq a => a -> Gen a+        choose n = MkGen (\r -> n)++        oneof = choose (1::Int)++It's a silly example, but we get+        choose = /\a. g `cast` co+where choose doesn't have any dict arguments.  Thus far I have not+tried to fix this (wait till there's a real example).++Mind you, then 'choose' will be inlined (since RHS is trivial) so+it doesn't matter.  This comes up with single-method classes++   class C a where { op :: a -> a }+   instance C a => C [a] where ....+==>+   $fCList :: C a => C [a]+   $fCList = $copList |> (...coercion>...)+   ....(uses of $fCList at particular types)...++So we suppress the WARN if the rhs is trivial.++Note [Inline specialisations]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Here is what we do with the InlinePragma of the original function++  * Activation/RuleMatchInfo: both inherited from the original function++  * InlineSpec: inherit from original function++  * Unfolding: transfer a StableUnfolding iff it is UnfWhen+               See GHC.Core.Unfold.Make.specUnfolding+               and its Note [Specialising unfoldings]++InlineSpec: you might wonder why we specialise INLINE functions at all.+After all they should be inlined, right?  Two reasons:++ * Even INLINE functions are sometimes not inlined, when they aren't+   applied to interesting arguments.  But perhaps the type arguments+   alone are enough to specialise (even though the args are too boring+   to trigger inlining), and it's certainly better to call the+   specialised version.++ * The RHS of an INLINE function might call another overloaded function,+   and we'd like to generate a specialised version of that function too.+   This actually happens a lot. Consider+      replicateM_ :: (Monad m) => Int -> m a -> m ()+      {-# INLINABLE replicateM_ #-}+      replicateM_ d x ma = ...+   The strictness analyser may transform to+      replicateM_ :: (Monad m) => Int -> m a -> m ()+      {-# INLINE replicateM_ #-}+      replicateM_ d x ma = case x of I# x' -> $wreplicateM_ d x' ma++      $wreplicateM_ :: (Monad m) => Int# -> m a -> m ()+      {-# INLINABLE $wreplicateM_ #-}+      $wreplicateM_ = ...+   Now an importing module has a specialised call to replicateM_, say+   (replicateM_ dMonadIO).  We certainly want to specialise $wreplicateM_!+   This particular example had a huge effect on the call to replicateM_+   in nofib/shootout/n-body.+-}++{- *********************************************************************+*                                                                      *+                   SpecArg, and specHeader+*                                                                      *+********************************************************************* -}++-- | An argument that we might want to specialise.+-- See Note [Specialising Calls] for the nitty gritty details.+data SpecArg+  =+    -- | Type arguments that should be specialised, due to appearing+    -- free in the type of a 'SpecDict'.+    SpecType Type++    -- | Type arguments that should remain polymorphic.+  | UnspecType++    -- | Dictionaries that should be specialised. mkCallUDs ensures+    -- that only "interesting" dictionary arguments get a SpecDict;+    -- see Note [Interesting dictionary arguments]+  | SpecDict DictExpr++    -- | Value arguments that should not be specialised.+  | UnspecArg++instance Outputable SpecArg where+  ppr (SpecType t)  = text "SpecType" <+> ppr t+  ppr (SpecDict d)  = text "SpecDict" <+> ppr d+  ppr UnspecType    = text "UnspecType"+  ppr UnspecArg     = text "UnspecArg"++specArgsFVs :: InterestingVarFun -> [SpecArg] -> FV+-- Find the free vars of the SpecArgs that are not already in scope+specArgsFVs interesting args+  = filterFV interesting $+    foldr (unionFV . get) emptyFV args+  where+    get :: SpecArg -> FV+    get (SpecType ty)   = tyCoFVsOfType ty+    get (SpecDict dx)   = exprFVs dx+    get UnspecType      = emptyFV+    get UnspecArg       = emptyFV++isSpecDict :: SpecArg -> Bool+isSpecDict (SpecDict {}) = True+isSpecDict _             = False++-- | Given binders from an original function 'f', and the 'SpecArg's+-- corresponding to its usage, compute everything necessary to build+-- a specialisation.+--+-- We will use the running example from Note [Specialising Calls]:+--+--     f :: forall a b c. Int -> Eq a => Show b => c -> Blah+--     f @a @b @c i dEqA dShowB x = blah+--+-- Suppose we decide to specialise it at the following pattern:+--+--     [ SpecType T1, SpecType T2, UnspecType, UnspecArg+--     , SpecDict dEqT1, SpecDict ($dfShow dShowT2), UnspecArg ]+--+-- We'd eventually like to build the RULE+--+--     RULE "SPEC f @T1 @T2 _"+--       forall (@c :: Type) (i :: Int) (d1 :: Eq T1) (d2 :: Show T2).+--         f @T1 @T2 @c i d1 d2 = $sf @c i+--+-- and the specialisation '$sf'+--+--     $sf :: forall c. Int -> c -> Blah+--     $sf = SUBST[a :-> T1, b :-> T2, dEqA :-> dEqT1, dShowB :-> dShow1] (\@c i x -> blah)+--+-- where dShow1 is a floated binding created by bindAuxiliaryDict.+--+-- The cases for 'specHeader' below are presented in the same order as this+-- running example. The result of 'specHeader' for this example is as follows:+--+--    ( -- Returned arguments+--      env + [a :-> T1, b :-> T2, dEqA :-> dEqT1, dShowB :-> dShow1]+--    , [x]+--+--      -- RULE helpers+--    , [c, i, d1, d2]+--    , [T1, T2, c, i, d1, d2]+--+--      -- Specialised function helpers+--    , [c, i, x]+--    , [dShow1 = $dfShow dShowT2]+--    , [T1, T2, c, i, dEqT1, dShow1]+--    )+specHeader+     :: Core.Subst  -- This substitution applies to the [InBndr]+     -> [InBndr]    -- Binders from the original function `f`+     -> [SpecArg]   -- From the CallInfo+     -> SpecM ( Bool     -- True <=> some useful specialisation happened+                         -- Not the same as any (isSpecDict args) because+                         -- the args might be longer than bndrs++              , Core.Subst   -- Apply this to the body++                -- RULE helpers+                -- `RULE forall rule_bndrs. f rule_es = $sf spec_bndrs`+              , [OutBndr]    -- rule_bndrs: Binders for the RULE+              , [OutExpr]    -- rule_es:    Args for the LHS of the rule++                -- Specialised function helpers+                -- `$sf = \spec_bndrs. let { dx_binds } in <orig-rhs> spec_arg`+              , [OutBndr]    -- spec_bndrs: Binders for $sf, and args for the RHS+                             --             of the RULE. Subset of rule_bndrs.+              , [DictBind]   -- dx_binds:   Auxiliary dictionary bindings+              , [OutExpr]    -- spec_args:  Specialised arguments for unfolding+                             --             Same length as "Args for LHS of rule"+              )++-- If we run out of binders, stop immediately+-- See Note [Specialisation Must Preserve Sharing]+specHeader subst [] _  = pure (False, subst, [], [], [], [], [])+specHeader subst _  [] = pure (False, subst, [], [], [], [], [])++-- We want to specialise on type 'T1', and so we must construct a substitution+-- 'a->T1', as well as a LHS argument for the resulting RULE and unfolding+-- details.+specHeader subst (bndr:bndrs) (SpecType ty : args)+  = do { let subst1 = Core.extendTvSubst subst bndr ty+       ; (useful, subst2, rule_bs, rule_args, spec_bs, dx, spec_args)+             <- specHeader subst1 bndrs args+       ; pure ( useful, subst2+              , rule_bs,     Type ty : rule_args+              , spec_bs, dx, Type ty : spec_args ) }++-- Next we have a type that we don't want to specialise. We need to perform+-- a substitution on it (in case the type refers to 'a'). Additionally, we need+-- to produce a binder, LHS argument and RHS argument for the resulting rule,+-- /and/ a binder for the specialised body.+specHeader subst (bndr:bndrs) (UnspecType : args)+  = do { let (subst1, bndr') = Core.substBndr subst bndr+       ; (useful, subst2, rule_bs, rule_es, spec_bs, dx, spec_args)+             <- specHeader subst1 bndrs args+       ; let ty_e' = Type (mkTyVarTy bndr')+       ; pure ( useful, subst2+              , bndr' : rule_bs,     ty_e' : rule_es+              , bndr' : spec_bs, dx, ty_e' : spec_args ) }++specHeader subst (bndr:bndrs) (_ : args)+  | isDeadBinder bndr+  , let (subst1, bndr') = Core.substBndr subst (zapIdOccInfo bndr)+  , Just rubbish_lit <- mkLitRubbish (idType bndr')+  = -- See Note [Drop dead args from specialisations]+    do { (useful, subst2, rule_bs, rule_es, spec_bs, dx, spec_args) <- specHeader subst1 bndrs args+       ; pure ( useful, subst2+              , bndr' : rule_bs, Var bndr'   : rule_es+              , spec_bs,     dx, rubbish_lit : spec_args ) }++-- Next we want to specialise the 'Eq a' dict away. We need to construct+-- a wildcard binder to match the dictionary (See Note [Specialising Calls] for+-- the nitty-gritty), as a LHS rule and unfolding details.+specHeader subst (bndr:bndrs) (SpecDict dict_arg : args)+  = do { -- Make up a fresh binder to use in the RULE+         -- It might turn into a dict binding (via bindAuxiliaryDict) which we+         -- then float, so we use cloneIdBndr to get a completely fresh binder+         us <- getUniqueSupplyM+       ; let (subst1, bndr') = Core.cloneIdBndr subst us (zapIdOccInfo bndr)+                 -- zapIdOccInfo: see Note [Zap occ info in rule binders]++         -- Extend the substitution to map bndr :-> dict_arg, for use in the RHS+       ; let (subst2, dx_bind, spec_dict) = bindAuxiliaryDict subst1 bndr bndr' dict_arg++       ; (_, subst3, rule_bs, rule_es, spec_bs, dx, spec_args) <- specHeader subst2 bndrs args++       ; let dx' = case dx_bind of { Nothing -> dx; Just d -> d : dx }+       ; pure ( True, subst3      -- Ha!  A useful specialisation!+              , bndr' : rule_bs, Var bndr' : rule_es+              , spec_bs,    dx', spec_dict : spec_args ) }++-- Finally, we don't want to specialise on this argument 'i':+-- We need to produce a binder, LHS and RHS argument for the RULE, and+-- a binder for the specialised body.+--+-- NB: Calls to 'specHeader' will trim off any trailing 'UnspecArg's, which is+-- why 'i' doesn't appear in our RULE above. But we have no guarantee that+-- there aren't 'UnspecArg's which come /before/ all of the dictionaries, so+-- this case must be here.+specHeader subst (bndr:bndrs) (UnspecArg : args)+  = do { let (subst1, bndr') = Core.substBndr subst (zapIdOccInfo bndr)+                 -- zapIdOccInfo: see Note [Zap occ info in rule binders]+       ; (useful, subst2, rule_bs, rule_es, spec_bs, dx, spec_args) <- specHeader subst1 bndrs args++       ; let dummy_arg = varToCoreExpr bndr'+               -- dummy_arg is usually just (Var bndr),+               -- but if bndr :: t1 ~# t2, it'll be (Coercion (CoVar bndr))+               --     or even Coercion Refl (if t1=t2)+               -- See Note [Evidence foralls]+             bndrs = exprFreeIdsList dummy_arg++       ; pure ( useful, subst2+              , bndrs ++ rule_bs,     dummy_arg : rule_es+              , bndrs ++ spec_bs, dx, dummy_arg : spec_args ) }+++-- | Binds a dictionary argument to a fresh name, to preserve sharing+bindAuxiliaryDict+  :: Subst+  -> InId -> OutId -> OutExpr -- Original dict binder, and the witnessing expression+  -> ( Subst          -- Substitutes for orig_dict_id+     , Maybe DictBind -- Auxiliary dict binding, if any+     , OutExpr)       -- Witnessing expression (always trivial)+bindAuxiliaryDict subst orig_dict_id fresh_dict_id dict_arg++  -- If the dictionary argument is trivial,+  -- don’t bother creating a new dict binding; just substitute+  | exprIsTrivial dict_arg+  , let subst' = Core.extendSubst subst orig_dict_id dict_arg+  = -- pprTrace "bindAuxiliaryDict:trivial" (ppr orig_dict_id <+> ppr dict_id) $+    (subst', Nothing, dict_arg)++  | otherwise  -- Non-trivial dictionary arg; make an auxiliary binding+  , let fresh_dict_id' = fresh_dict_id `addDictUnfolding` dict_arg++        dict_bind = mkDB (NonRec fresh_dict_id' dict_arg)+        subst'    = Core.extendSubst subst orig_dict_id (Var fresh_dict_id')+                    `Core.extendSubstInScope` fresh_dict_id'+                    -- Ensure the new unfolding is in the in-scope set+  = -- pprTrace "bindAuxiliaryDict:non-trivial" (ppr orig_dict_id <+> ppr fresh_dict_id') $+    (subst', Just dict_bind, Var fresh_dict_id')++addDictUnfolding :: Id -> CoreExpr -> Id+-- Add unfolding for freshly-bound Ids: see Note [Make the new dictionaries interesting]+-- and Note [Specialisation modulo dictionary selectors]+addDictUnfolding id rhs+  = id `setIdUnfolding` mkSimpleUnfolding defaultUnfoldingOpts rhs++{-+Note [Make the new dictionaries interesting]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Important!  We're going to substitute dx_id1 for d+and we want it to look "interesting", else we won't gather *any*+consequential calls. E.g.+    f d = ...g d....+If we specialise f for a call (f (dfun dNumInt)), we'll get+a consequent call (g d') with an auxiliary definition+    d' = df dNumInt+We want that consequent call to look interesting; so we add an unfolding+in the dictionary Id.+-}+++{- *********************************************************************+*                                                                      *+            UsageDetails and suchlike+*                                                                      *+********************************************************************* -}++data UsageDetails+  = MkUD { ud_binds :: !FloatedDictBinds+         , ud_calls :: !CallDetails }+    -- INVARIANT: suppose bs = fdb_bndrs ud_binds+    -- Then 'calls' may *mention* 'bs',+    -- but there should be no calls *for* bs++data FloatedDictBinds  -- See Note [Floated dictionary bindings]+  = FDB { fdb_binds :: !(OrdList DictBind)+               -- The order is important;+               -- in ds1 `appOL` ds2, bindings in ds2 can depend on those in ds1++        , fdb_bndrs :: !IdSet+    }          -- ^ The binders of 'fdb_binds'.+               -- Caches a superset of the expression+               --   `mkVarSet (bindersOfDictBinds fdb_binds))`+               -- for later addition to an InScopeSet++-- | A 'DictBind' is a binding along with a cached set containing its free+-- variables (both type variables and dictionaries). We need this set+-- in splitDictBinds, when filtering bindings to decide which are+-- captured by a binder+data DictBind = DB { db_bind :: CoreBind, db_fvs :: VarSet }++bindersOfDictBind :: DictBind -> [Id]+bindersOfDictBind = bindersOf . db_bind++bindersOfDictBinds :: Foldable f => f DictBind -> [Id]+bindersOfDictBinds = bindersOfBinds . foldr ((:) . db_bind) []++{- Note [Floated dictionary bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We float out dictionary bindings for the reasons described under+"Dictionary floating" above.  But not /just/ dictionary bindings.+Consider++   f :: Eq a => blah+   f a d = rhs++   $c== :: T -> T -> Bool+   $c== x y = ...++   $df :: Eq T+   $df = Eq $c== ...++   gurgle = ...(f @T $df)...++We gather the call info for (f @T $df), and we don't want to drop it+when we come across the binding for $df.  So we add $df to the floats+and continue.  But then we have to add $c== to the floats, and so on.+These all float above the binding for 'f', and now we can+successfully specialise 'f'.++So the DictBinds in (ud_binds :: OrdList DictBind) may contain+non-dictionary bindings too.++Note [Specialising polymorphic dictionaries]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Note June 2023: This has proved to be quite a tricky optimisation to get right+see (#23469, #23109, #21229, #23445) so it is now guarded by a flag+`-fpolymorphic-specialisation`.++Consider+    class M a where { foo :: a -> Int }++    instance M (ST s) where ...+    -- dMST :: forall s. M (ST s)++    wimwam :: forall a. M a => a -> Int+    wimwam = /\a \(d::M a). body++    f :: ST s -> Int+    f = /\s \(x::ST s). wimwam @(ST s) (dMST @s) dx + 1++We'd like to specialise wimwam at (ST s), thus+    $swimwam :: forall s. ST s -> Int+    $swimwam = /\s. body[ST s/a, (dMST @s)/d]++    RULE forall s (d :: M (ST s)).+         wimwam @(ST s) d = $swimwam @s++Here are the moving parts:++(MP1) We must /not/ dump the CallInfo+        CIS wimwam (CI { ci_key = [@(ST s), dMST @s]+                       , ci_fvs = {dMST} })+      when we come to the /\s.  Instead, we simply let it continue to float+      upwards. Hence ci_fvs is an IdSet, listing the /Ids/ that+      are free in the call, but not the /TyVars/.  Hence using specArgFreeIds+      in singleCall.++  NB to be fully kosher we should explicitly quantifying the CallInfo+  over 's', but we don't bother.  This would matter if there was an+  enclosing binding of the same 's', which I don't expect to happen.++(MP2) When we come to specialise the call, we must remember to quantify+      over 's'.  That is done in the SpecType case of specHeader, where+      we add 's' (called qvars) to the binders of the RULE and the specialised+      function.++(MP3) If we have f :: forall m. Monoid m => blah, and two calls+        (f @(Endo b)      (d1 :: Monoid (Endo b))+        (f @(Endo (c->c)) (d2 :: Monoid (Endo (c->c)))+      we want to generate a specialisation only for the first.  The second+      is just a substitution instance of the first, with no greater specialisation.+      Hence the use of `removeDupCalls` in `filterCalls`.++      You might wonder if `d2` might be more specialised than `d1`; but no.+      This `removeDupCalls` thing is at the definition site of `f`, and both `d1`+      and `d2` are in scope. So `d1` is simply more polymorphic than `d2`, but+      is just as specialised.++      This distinction is sadly lost once we build a RULE, so `alreadyCovered`+      can't be so clever.  E.g if we have an existing RULE+            forall @a (d1:Ord Int) (d2: Eq a). f @a @Int d1 d2 = ...+      and a putative new rule+            forall (d1:Ord Int) (d2: Eq Int). f @Int @Int d1 d2 = ...+      we /don't/ want the existing rule to subsume the new one.++      So we sadly put up with having two rather different places where we+      eliminate duplicates: `alreadyCovered` and `removeDupCalls`.++All this arose in #13873, in the unexpected form that a SPECIALISE+pragma made the program slower!  The reason was that the specialised+function $sinsertWith arising from the pragma looked rather like `f`+above, and failed to specialise a call in its body like wimwam.+Without the pragma, the original call to `insertWith` was completely+monomorpic, and specialised in one go.++Wrinkles.++* See Note [Weird special case for SpecDict]++* With -XOverlappingInstances you might worry about this:+    class C a where ...+    instance C (Maybe Int) where ...   -- $df1 :: C (Maybe Int)+    instance C (Maybe a)   where ...   -- $df2 :: forall a. C (Maybe a)++    f :: C a => blah+    f = rhs++    g = /\a.  ...(f @(Maybe a) ($df2 a))...+    h = ...f @(Maybe Int) $df1++  There are two calls to f, but with different evidence.  This patch will+  combine them into one.  But it's OK: this code will never arise unless you+  use -XIncoherentInstances.  Even with -XOverlappingInstances, GHC tries hard+  to keep dictionaries as singleton types.  But that goes out of the window+  with -XIncoherentInstances -- and that is true even with ordianry type-class+  specialisation (at least if any inlining has taken place).++  GHC makes very few guarantees when you use -XIncoherentInstances, and its+  not worth crippling the normal case for the incoherent corner.  (The best+  thing might be to switch off specialisation altogether if incoherence is+  involved... but incoherence is a property of an instance, not a class, so+  it's a hard test to make.)++  But see Note [Specialisation and overlapping instances].++Note [Weird special case for SpecDict]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we are trying to specialise for this this call:+   $wsplit @T (mkD @k @(a::k) :: C T)+where+   mkD :: forall k (a::k). C T+is a top-level dictionary-former.  This actually happened in #22459,+because of (MP1) of Note [Specialising polymorphic dictionaries].++How can we specialise $wsplit?  We might try++   RULE "SPEC" forall (d :: C T). $wsplit @T d = $s$wsplit++but then in the body of $s$wsplit what will we use for the dictionary+evidence?  We can't use (mkD @k @(a::k)) because k and a aren't in scope.+We could zap `k` to (Any @Type) and `a` to (Any @(Any @Type)), but that+is a lot of hard work for a very strange case.++So we simply refrain from specialising in this case; hence the guard+   allVarSet (`elemInScopeSet` in_scope) (exprFreeVars d)+in the SpecDict cased of specHeader.++How did this strange polymorphic mkD arise in the first place?+From GHC.Core.Opt.Utils.abstractFloats, which was abstracting+over too many type variables. But that too is now fixed;+see Note [Which type variables to abstract over] in that module.+-}++instance Outputable DictBind where+  ppr (DB { db_bind = bind, db_fvs = fvs })+    = text "DB" <+> braces (sep [ text "fvs: " <+> ppr fvs+                                , text "bind:" <+> ppr bind ])++instance Outputable UsageDetails where+  ppr (MkUD { ud_binds = dbs, ud_calls = calls })+        = text "MkUD" <+> braces (sep (punctuate comma+                [text "binds" <+> equals <+> ppr dbs,+                 text "calls" <+> equals <+> ppr calls]))++instance Outputable FloatedDictBinds where+  ppr (FDB { fdb_binds = binds }) = ppr binds++emptyUDs :: UsageDetails+emptyUDs = MkUD { ud_binds = emptyFDBs, ud_calls = emptyDVarEnv }+++emptyFDBs :: FloatedDictBinds+emptyFDBs = FDB { fdb_binds = nilOL, fdb_bndrs = emptyVarSet }++------------------------------------------------------------+type CallDetails  = DIdEnv CallInfoSet+  -- The order of specialized binds and rules depends on how we linearize+  -- CallDetails, so to get determinism we must use a deterministic set here.+  -- See Note [Deterministic UniqFM] in GHC.Types.Unique.DFM++data CallInfoSet = CIS Id (Bag CallInfo)+  -- The list of types and dictionaries is guaranteed to+  -- match the type of f+  -- The Bag may contain duplicate calls (i.e. f @T and another f @T)+  -- These dups are eliminated by alreadyCovered in specCalls++data CallInfo+  = CI { ci_key  :: [SpecArg]   -- Arguments of the call+                                -- See Note [The (CI-KEY) invariant]++       , ci_fvs  :: IdSet       -- Free Ids of the ci_key call+                                -- /not/ including the main id itself, of course+                                -- NB: excluding tyvars:+                                --     See Note [Specialising polymorphic dictionaries]+    }++{- Note [The (CI-KEY) invariant]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Invariant (CI-KEY):+   In the `ci_key :: [SpecArg]` field of `CallInfo`,+     * The list is non-empty+     * The least element is always a `SpecDict`++In this way the RULE has as few args as possible, which broadens its+applicability, since rules only fire when saturated.+-}++type DictExpr = CoreExpr++ciSetFilter :: (CallInfo -> Bool) -> CallInfoSet -> CallInfoSet+ciSetFilter p (CIS id a) = CIS id (filterBag p a)++instance Outputable CallInfoSet where+  ppr (CIS fn map) = hang (text "CIS" <+> ppr fn)+                        2 (ppr map)++pprCallInfo :: Id -> CallInfo -> SDoc+pprCallInfo fn (CI { ci_key = key })+  = ppr fn <+> ppr key++instance Outputable CallInfo where+  ppr (CI { ci_key = key, ci_fvs = _fvs })+    = text "CI" <> braces (sep (map ppr key))++unionCalls :: CallDetails -> CallDetails -> CallDetails+unionCalls c1 c2 = plusDVarEnv_C unionCallInfoSet c1 c2++unionCallInfoSet :: CallInfoSet -> CallInfoSet -> CallInfoSet+unionCallInfoSet (CIS f calls1) (CIS _ calls2) =+  CIS f (calls1 `unionBags` calls2)++callDetailsFVs :: CallDetails -> VarSet+callDetailsFVs calls =+  nonDetStrictFoldUDFM (unionVarSet . callInfoFVs) emptyVarSet calls+  -- It's OK to use nonDetStrictFoldUDFM here because we forget the ordering+  -- immediately by converting to a nondeterministic set.++callInfoFVs :: CallInfoSet -> VarSet+callInfoFVs (CIS _ call_info) =+  foldr (\(CI { ci_fvs = fv }) vs -> unionVarSet fv vs) emptyVarSet call_info++getTheta :: [PiTyBinder] -> [PredType]+getTheta = fmap piTyBinderType . filter isInvisiblePiTyBinder . filter isAnonPiTyBinder+++------------------------------------------------------------+singleCall :: SpecEnv -> Id -> [SpecArg] -> UsageDetails+singleCall spec_env id args+  = MkUD {ud_binds = emptyFDBs,+          ud_calls = unitDVarEnv id $ CIS id $+                     unitBag (CI { ci_key  = args+                                 , ci_fvs  = fvVarSet call_fvs }) }+  where+    poly_spec = gopt Opt_PolymorphicSpecialisation (se_dflags spec_env)++    -- With -fpolymorphic-specialisation, keep just local /Ids/+    -- Otherwise, keep /all/ free vars including TyVars+    -- See (MP1) in Note [Specialising polymorphic dictionaries]+    -- But NB: we don't include the 'id' itself.+    call_fvs | poly_spec = specArgsFVs isLocalId args+             | otherwise = specArgsFVs isLocalVar args++mkCallUDs :: SpecEnv -> OutExpr -> [OutExpr] -> UsageDetails+mkCallUDs env fun args+  | (_, Var f) <- stripTicksTop tickishFloatable fun -- See Note [Ticks on applications]+  = -- pprTraceWith "mkCallUDs" (\res -> vcat [ ppr f, ppr args, ppr res ]) $+    mkCallUDs' env f args+  | otherwise+  = emptyUDs++mkCallUDs' :: SpecEnv -> Id -> [OutExpr] -> UsageDetails+mkCallUDs' env f args+  | wantCallsFor env f    -- We want it, and...+  , not (null ci_key)     -- this call site has a useful specialisation+  = -- pprTrace "mkCallUDs: keeping" _trace_doc+    singleCall env f ci_key++  | otherwise  -- See also Note [Specialisations already covered]+  = -- pprTrace "mkCallUDs: discarding" _trace_doc+    emptyUDs++  where+    _trace_doc = vcat [ppr f, ppr args, ppr ci_key]+    pis                = fst $ splitPiTys $ idType f+    constrained_tyvars = tyCoVarsOfTypes $ getTheta pis++    ci_key :: [SpecArg]+    ci_key = dropWhileEndLE (not . isSpecDict) $+             zipWith mk_spec_arg args pis+             -- Establish (CI-KEY): drop trailing args until we get to a SpecDict++    mk_spec_arg :: OutExpr -> PiTyBinder -> SpecArg+    mk_spec_arg (Type ty) (Named bndr)+      |  binderVar bndr `elemVarSet` constrained_tyvars+      = SpecType ty+      | otherwise+      = UnspecType+    mk_spec_arg non_type_arg (Named bndr)+      = pprPanic "ci_key" $ (ppr non_type_arg $$ ppr bndr)++    -- For "invisibleFunArg", which are the type-class dictionaries,+    -- we decide on a case by case basis if we want to specialise+    -- on this argument; if so, SpecDict, if not UnspecArg+    mk_spec_arg arg (Anon _pred af)+      | isInvisibleFunArg af+      , interestingDict env arg+              -- See Note [Interesting dictionary arguments]+      = SpecDict arg++      | otherwise = UnspecArg++wantCallsFor :: SpecEnv -> Id -> Bool+-- See Note [wantCallsFor]+wantCallsFor _env f+  = case idDetails f of+      RecSelId {}      -> False+      DataConWorkId {} -> False+      DataConWrapId {} -> False+      ClassOpId {}     -> False+      PrimOpId {}      -> False+      FCallId {}       -> False+      TickBoxOpId {}   -> False+      CoVarId {}       -> False++      DFunId {}        -> True+      VanillaId {}     -> True+      JoinId {}        -> True+      WorkerLikeId {}  -> True+      RepPolyId {}     -> True++interestingDict :: SpecEnv -> CoreExpr -> Bool+-- This is a subtle and important function+-- See Note [Interesting dictionary arguments]+interestingDict env (Var v)  -- See (ID3) and (ID5)+  | Just rhs <- maybeUnfoldingTemplate (idUnfolding v)+  -- Might fail for loop breaker dicts but that seems fine.+  = interestingDict env rhs++interestingDict env arg  -- Main Plan: use exprIsConApp_maybe+  | Cast inner_arg _ <- arg  -- See (ID5)+  = if | isConstraintKind $ typeKind $ exprType inner_arg+       -- If coercions were always homo-kinded, we'd know+       -- that this would be the only case+       -> interestingDict env inner_arg++       -- Check for an implicit parameter at the top+       | Just (cls,_) <- getClassPredTys_maybe arg_ty+       , isIPClass cls      -- See (ID5)+       -> False++       -- Otherwise we are unwrapping a unary type class+       | otherwise+       -> exprIsHNF arg   -- See (ID7)++  | Just (_, _, data_con, _tys, args) <- exprIsConApp_maybe in_scope_env arg+  , Just cls <- tyConClass_maybe (dataConTyCon data_con)+  , definitely_not_ip_like       -- See (ID4)+  = if null (classMethods cls)   -- See (ID6)+    then any (interestingDict env) args+    else True++  | otherwise+  = not (exprIsTrivial arg) && definitely_not_ip_like  -- See (ID8)+  where+    arg_ty                  = exprType arg+    definitely_not_ip_like  = not (couldBeIPLike arg_ty)+    in_scope_env = ISE (substInScopeSet $ se_subst env) realIdUnfolding++{- Note [Ticks on applications]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Ticks such as source location annotations can sometimes make their way+onto applications (see e.g. #21697). So if we see something like++    App (Tick _ f) e++we need to descend below the tick to find what the real function being+applied is.++The resulting RULE also has to be able to match this annotated use+site, so we only look through ticks that RULE matching looks through+(see Note [Tick annotations in RULE matching] in GHC.Core.Rules).++Note [wantCallsFor]+~~~~~~~~~~~~~~~~~~~+`wantCallsFor env f` says whether the Specialiser should collect calls for+function `f`; other thing being equal, the fewer calls we collect the better. It+is False for things we can't specialise:++* ClassOpId: never inline and we don't have a defn to specialise; we specialise+  them through fireRewriteRules.+* PrimOpId: are never overloaded+* Data constructors: we never specialise them++We could reduce the size of the UsageDetails by being less eager about+collecting calls for some LocalIds: there is no point for ones that are+lambda-bound.  We can't decide this by looking at the (absence of an) unfolding,+because unfoldings for local functions are discarded by cloneBindSM, so no local+binder will have an unfolding at this stage.  We'd have to keep a candidate set+of let-binders.++Not many lambda-bound variables have dictionary arguments, so this would make+little difference anyway.++For imported Ids we could check for an unfolding, but we have to do so anyway in+canSpecImport, and it seems better to have it all in one place.  So we simply+collect usage info for imported overloaded functions.++Note [Interesting dictionary arguments]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this+         \a.\d:Eq a.  let f = ... in ...(f d)...+There really is not much point in specialising f wrt the dictionary d,+because the code for the specialised f is not improved at all, because+d is lambda-bound.  We simply get junk specialisations.++What is "interesting"?  Our Main Plan is to use `exprIsConApp_maybe` to see+if the argument is a dictionary constructor applied to some arguments, in which+case we can clearly specialise. But there are wrinkles:++(ID1) Note that we look at the argument /term/, not its /type/.  Suppose the+  argument is+         (% d1, d2 %) |> co+  where co :: (% Eq [a], Show [a] %) ~ F Int a, and `F` is a type family.+  Then its type (F Int a) looks very un-informative, but the term is super+  helpful.  See #19747 (where missing this point caused a 70x slow down)+  and #7785.++(ID2) Note that the Main Plan works fine for an argument that is a DFun call,+   e.g.    $fOrdList $dOrdInt+   because `exprIsConApp_maybe` cleverly deals with DFunId applications.  Good!++(ID3) For variables, we look in the variable's /unfolding/.  And that means+   that we must be careful to ensure that dictionaries /have/ unfoldings:+   * cloneBndrSM discards non-Stable unfoldings+   * specBind updates the unfolding after specialisation+     See Note [Update unfolding after specialisation]+   * bindAuxiliaryDict adds an unfolding for an aux dict+     see Note [Specialisation modulo dictionary selectors]+   * specCase adds unfoldings for the new bindings it creates++   We accidentally lost accurate tracking of local variables for a long+   time, because cloned variables didn't have unfoldings. But makes a+   massive difference in a few cases, eg #5113. For nofib as a+   whole it's only a small win: 2.2% improvement in allocation for ansi,+   1.2% for bspt, but mostly 0.0!  Average 0.1% increase in binary size.++(ID4) We must be very careful not to specialise on a "dictionary" that is, or contains+   an implicit parameter, because implicit parameters are emphatically not singleton+   types.  See #25999:+     useImplicit :: (?i :: Int) => Int+     useImplicit = ?i + 1++     foo = let ?i = 1 in (useImplicit, let ?i = 2 in useImplicit)+   Both calls to `useImplicit` are at type `?i::Int`, but they pass different values.+   We must not specialise on implicit parameters!  Hence the call to `couldBeIPLike`+   in `definitely_not_ip_like`.++(ID5) Suppose the argument is (e |> co).  Can we rely on `exprIsConApp_maybe` to deal+   with the coercion.  No!  That only works if (co :: C t1 ~ C t2) with the same type+   constructor at the top of both sides.  But see the example in (ID1), where that+   is not true.  For the same reason, we can't rely on `exprIsConApp_maybe` to look+   through unfoldings (because there might be a cast inside), hence dealing with+   expandable unfoldings in `interestingDict` directly.++   For the same reasons as in (ID4), we must take care to not allow an implicit+   parameter to sneak through, so we must not unwrap the newtype cast for the+   unary IP class; hence the `isIPClass` call.  (We don't need to call+   `couldBeIPLike`, as implicit parameters hidden behind a type family are+   detected by the recursive call to `interestingDict` on the argument inside the+   cast.)++(ID6) The Main Plan says that it's worth specialising if the argument is an application+   of a dictionary contructor.  But what if the dictionary has no methods?  Then we+   gain nothing by specialising, unless the /superclasses/ are interesting.   A case+   in point is constraint tuples (% d1, .., dn %); a constraint N-tuple is a class+   with N superclasses and no methods.++(ID7) A unary (single-method) class is currently represented by (meth |> co).  We+   will unwrap the cast (see (ID5)) and then want to reply "yes" if the method+   has any struture.  We rather arbitrarily use `exprIsHNF` for this.  (We plan a+   new story for unary classes, see #23109, and this special case will become+   irrelevant.)++(ID8) Sadly, if `exprIsConApp_maybe` says Nothing, we still want to treat a+   non-trivial argument as interesting. In T19695 we have this:+      askParams :: Monad m => blah+      mhelper   :: MonadIO m => blah+      mhelper (d:MonadIO m) = ...(askParams @m ($p1 d))....+   where `$p1` is the superclass selector for `MonadIO`.  Now, if `mhelper` is+   specialised at `Handler` we'll get this call in the specialised `$smhelper`:+            askParams @Handler ($p1 $fMonadIOHandler)+   and we /definitely/ want to specialise that, even though the argument isn't+   visibly a dictionary application.  In fact the specialiser fires the superclass+   selector rule (see Note [Fire rules in the specialiser]), so we get+            askParams @Handler ($cp1MonadIO $fMonadIOIO)+   but it /still/ doesn't look like a dictionary application.++   Conclusion: we optimistically assume that any non-trivial argument is worth+   specialising on.++   So why do the `exprIsConApp_maybe` and `Cast` stuff? Because we want to look+   under type-family casts (ID1) and constraint tuples (ID6).++Note [Update unfolding after specialisation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider (#21848)++  wombat :: Show b => Int -> b -> String+  wombat a b | a>0       = wombat (a-1) b+             | otherwise = show a ++ wombat a b++  class C a where+    meth :: Show b => a -> b -> String+    dummy :: a -> () -- Force a datatype dictionary representation++  instance C Int where+    meth = wombat+    dummy _ = ()++  class C a => D a   -- D has C as a superclass+  instance D Int++  f :: (D a, Show b) => a -> b -> String+  {-# INLINABLE[0] f #-}+  f a b = meth a b ++ "!" ++ meth a b++Now `f` turns into:++  f @a @b (dd :: D a) (ds :: Show b) a b++     = let dc :: D a = %p1 dd  -- Superclass selection+       in meth @a dc ....+          meth @a dc ....++When we specialise `f`, at a=Int say, that superclass selection can+fire (via rewiteClassOps), but that info (that 'dc' is now a+particular dictionary `C`, of type `C Int`) must be available to+the call `meth @a dc`, so that we can fire the `meth` class-op, and+thence specialise `wombat`.++We deliver on this idea by updating the unfolding for the binder+in the NonRec case of specBind.  (This is too exotic to trouble with+the Rec case.)+-}++thenUDs :: UsageDetails -> UsageDetails -> UsageDetails+thenUDs (MkUD {ud_binds = db1, ud_calls = calls1})+        (MkUD {ud_binds = db2, ud_calls = calls2})+  = MkUD { ud_binds       = db1    `thenFDBs`   db2+         , ud_calls       = calls1 `unionCalls`  calls2 }++thenFDBs :: FloatedDictBinds -> FloatedDictBinds -> FloatedDictBinds+-- Combine FloatedDictBinds+-- In (dbs1 `thenFDBs` dbs2), dbs2 may mention dbs1 but not vice versa+thenFDBs (FDB { fdb_binds = dbs1, fdb_bndrs = bs1 })+         (FDB { fdb_binds = dbs2, fdb_bndrs = bs2 })+  = FDB { fdb_binds = dbs1 `appOL` dbs2+        , fdb_bndrs = bs1  `unionVarSet` bs2 }++-----------------------------+_dictBindBndrs :: OrdList DictBind -> [Id]+_dictBindBndrs dbs = foldr ((++) . bindersOf . db_bind) [] dbs++-- | Construct a 'DictBind' from a 'CoreBind'+mkDB :: CoreBind -> DictBind+mkDB bind = DB { db_bind = bind, db_fvs = bind_fvs bind }++-- | Identify the free variables of a 'CoreBind'+bind_fvs :: CoreBind -> VarSet+bind_fvs (NonRec bndr rhs) = pair_fvs (bndr,rhs)+bind_fvs (Rec prs)         = rhs_fvs `delVarSetList` (map fst prs)+                           where+                             rhs_fvs = unionVarSets (map pair_fvs prs)++pair_fvs :: (Id, CoreExpr) -> VarSet+pair_fvs (bndr, rhs) = exprSomeFreeVars interesting rhs+                       `unionVarSet` idFreeVars bndr+        -- idFreeVars: don't forget variables mentioned in+        -- the rules of the bndr.  C.f. OccAnal.addRuleUsage+        -- Also tyvars mentioned in its type; they may not appear+        -- in the RHS+        --      type T a = Int+        --      x :: T a = 3+  where+    interesting :: InterestingVarFun+    interesting v = isLocalVar v || (isId v && isDFunId v)+        -- Very important: include DFunIds /even/ if it is imported+        -- Reason: See Note [Avoiding loops in specImports], the #13429+        --         example involving an imported dfun.  We must know+        --         whether a dictionary binding depends on an imported+        --         DFun in case we try to specialise that imported DFun++-- | Flatten a set of "dumped" 'DictBind's, and some other binding+-- pairs, into a single recursive binding.+recWithDumpedDicts :: [(Id,CoreExpr)] -> OrdList DictBind -> DictBind+recWithDumpedDicts pairs dbs+  = DB { db_bind = Rec bindings+       , db_fvs = fvs `delVarSetList` map fst bindings }+  where+    (bindings, fvs) = foldr add ([], emptyVarSet)+                                (dbs `snocOL` mkDB (Rec pairs))+    add (DB { db_bind = bind, db_fvs = fvs }) (prs_acc, fvs_acc)+      = case bind of+          NonRec b r -> ((b,r) : prs_acc, fvs')+          Rec prs1   -> (prs1 ++ prs_acc, fvs')+      where+        fvs' = fvs_acc `unionVarSet` fvs++snocDictBind :: UsageDetails -> DictBind -> UsageDetails+snocDictBind uds@MkUD{ud_binds= FDB { fdb_binds = dbs, fdb_bndrs = bs }} db+  = uds { ud_binds = FDB { fdb_binds = dbs `snocOL` db+                         , fdb_bndrs = bs `extendVarSetList` bindersOfDictBind db } }++snocDictBinds :: UsageDetails -> [DictBind] -> UsageDetails+-- Add ud_binds to the tail end of the bindings in uds+snocDictBinds uds@MkUD{ud_binds=FDB{ fdb_binds = binds, fdb_bndrs = bs }} dbs+  = uds { ud_binds = FDB { fdb_binds = binds `appOL`        (toOL dbs)+                         , fdb_bndrs = bs    `extendVarSetList` bindersOfDictBinds dbs } }++consDictBinds :: [DictBind] -> UsageDetails -> UsageDetails+consDictBinds dbs uds@MkUD{ud_binds=FDB{fdb_binds = binds, fdb_bndrs = bs}}+  = uds { ud_binds = FDB{ fdb_binds = toOL dbs `appOL` binds+                        , fdb_bndrs = bs `extendVarSetList` bindersOfDictBinds dbs } }++wrapDictBinds :: FloatedDictBinds -> [CoreBind] -> [CoreBind]+wrapDictBinds (FDB { fdb_binds = dbs }) binds+  = foldr add binds dbs+  where+    add (DB { db_bind = bind }) binds = bind : binds++wrapDictBindsE :: OrdList DictBind -> CoreExpr -> CoreExpr+wrapDictBindsE dbs expr+  = foldr add expr dbs+  where+    add (DB { db_bind = bind }) expr = Let bind expr++----------------------+dumpUDs :: [CoreBndr] -> UsageDetails -> (UsageDetails, OrdList DictBind)+-- Used at a lambda or case binder; just dump anything mentioning the binder+dumpUDs bndrs uds@(MkUD { ud_binds = orig_dbs, ud_calls = orig_calls })+  | null bndrs = (uds, nilOL)  -- Common in case alternatives+  | otherwise  = -- pprTrace "dumpUDs" (vcat+                 --    [ text "bndrs" <+> ppr bndrs+                 --    , text "uds" <+> ppr uds+                 --    , text "free_uds" <+> ppr free_uds+                 --    , text "dump-dbs" <+> ppr dump_dbs ]) $+                 (free_uds, dump_dbs)+  where+    free_uds = uds { ud_binds = free_dbs, ud_calls = free_calls }+    bndr_set = mkVarSet bndrs+    (free_dbs, dump_dbs, dump_set) = splitDictBinds orig_dbs bndr_set+    free_calls = deleteCallsMentioning dump_set $   -- Drop calls mentioning bndr_set on the floor+                 deleteCallsFor bndrs orig_calls    -- Discard calls for bndr_set; there should be+                                                    -- no calls for any of the dicts in dump_dbs++dumpBindUDs :: [CoreBndr] -> UsageDetails -> (UsageDetails, OrdList DictBind, Bool)+-- Used at a let(rec) binding.+-- We return a boolean indicating whether the binding itself is mentioned,+-- directly or indirectly, by any of the ud_calls; in that case we want to+-- float the binding itself;+-- See Note [Floated dictionary bindings]+dumpBindUDs bndrs (MkUD { ud_binds = orig_dbs, ud_calls = orig_calls })+  = -- pprTrace "dumpBindUDs" (ppr bndrs $$ ppr free_uds $$ ppr dump_dbs $$ ppr float_all) $+    (free_uds, dump_dbs, float_all)+  where+    free_uds = MkUD { ud_binds = free_dbs, ud_calls = free_calls }+    bndr_set = mkVarSet bndrs+    (free_dbs, dump_dbs, dump_set) = splitDictBinds orig_dbs bndr_set+    free_calls = deleteCallsFor bndrs orig_calls+    float_all = dump_set `intersectsVarSet` callDetailsFVs free_calls++callsForMe :: Id -> UsageDetails -> (UsageDetails, [CallInfo])+callsForMe fn uds@MkUD { ud_binds = orig_dbs, ud_calls = orig_calls }+  = -- pprTrace ("callsForMe")+    --          (vcat [ppr fn,+    --                 text "Orig dbs ="     <+> ppr (_dictBindBndrs orig_dbs),+    --                 text "Orig calls ="   <+> ppr orig_calls,+    --                 text "Calls for me =" <+> ppr calls_for_me]) $+    (uds_without_me, calls_for_me)+  where+    uds_without_me = uds { ud_calls = delDVarEnv orig_calls fn }+    calls_for_me = case lookupDVarEnv orig_calls fn of+                        Nothing -> []+                        Just cis -> filterCalls cis orig_dbs++----------------------+filterCalls :: CallInfoSet -> FloatedDictBinds -> [CallInfo]+-- Remove+--   (a) dominated calls: (MP3) in Note [Specialising polymorphic dictionaries]+--   (b) loopy DFuns: Note [Avoiding loops (DFuns)]+filterCalls (CIS fn call_bag) (FDB { fdb_binds = dbs })+  | isDFunId fn  = filter ok_call de_dupd_calls  -- Deals with (b)+  | otherwise    = de_dupd_calls+  where+    de_dupd_calls = removeDupCalls call_bag -- Deals with (a)++    dump_set = foldl' go (unitVarSet fn) dbs+      -- This dump-set could also be computed by splitDictBinds+      --   (_,_,dump_set) = splitDictBinds dbs {fn}+      -- But this variant is shorter++    go so_far (DB { db_bind = bind, db_fvs = fvs })+       | fvs `intersectsVarSet` so_far+       = extendVarSetList so_far (bindersOf bind)+       | otherwise = so_far++    ok_call (CI { ci_fvs = fvs }) = fvs `disjointVarSet` dump_set++removeDupCalls :: Bag CallInfo -> [CallInfo]+-- Calls involving more generic instances beat more specific ones.+-- See (MP3) in Note [Specialising polymorphic dictionaries]+removeDupCalls calls = foldr add [] calls+  where+    add :: CallInfo -> [CallInfo] -> [CallInfo]+    add ci [] = [ci]+    add ci1 (ci2:cis) | ci2 `beats_or_same` ci1 = ci2:cis+                      | ci1 `beats_or_same` ci2 = ci1:cis+                      | otherwise               = ci2 : add ci1 cis++beats_or_same :: CallInfo -> CallInfo -> Bool+-- (beats_or_same ci1 ci2) is True if specialising on ci1 subsumes ci2+-- That is: ci1's types are less specialised than ci2+--          ci1   specialises on the same dict args as ci2+beats_or_same (CI { ci_key = args1 }) (CI { ci_key = args2 })+  = go args1 args2+  where+    go []           []           = True+    go (arg1:args1) (arg2:args2) = go_arg arg1 arg2 && go args1 args2++    -- If one or the other runs dry, the other must still have a SpecDict+    -- because of the (CI-KEY) invariant.  So neither subsumes the other;+    -- one is more specialised (faster code) but the other is more generally+    -- applicable.+    go  _ _ = False++    go_arg (SpecType ty1) (SpecType ty2) = isJust (tcMatchTy ty1 ty2)+    go_arg (SpecDict {})  (SpecDict {})  = True+    go_arg UnspecType     UnspecType     = True+    go_arg UnspecArg      UnspecArg      = True+    go_arg _              _              = False++----------------------+splitDictBinds :: FloatedDictBinds -> IdSet -> (FloatedDictBinds, OrdList DictBind, IdSet)+-- splitDictBinds dbs bndrs returns+--   (free_dbs, dump_dbs, dump_set)+-- where+--   * dump_dbs depends, transitively on bndrs+--   * free_dbs does not depend on bndrs+--   * dump_set = bndrs `union` bndrs(dump_dbs)+splitDictBinds (FDB { fdb_binds = dbs, fdb_bndrs = bs }) bndr_set+   = (FDB { fdb_binds = free_dbs+          , fdb_bndrs = bs `minusVarSet` dump_set }+     , dump_dbs, dump_set)+   where+    (free_dbs, dump_dbs, dump_set)+      = foldl' split_db (nilOL, nilOL, bndr_set) dbs+                -- Important that it's foldl' not foldr;+                -- we're accumulating the set of dumped ids in dump_set++    split_db (free_dbs, dump_dbs, dump_idset) db+        | DB { db_bind = bind, db_fvs = fvs } <- db+        , dump_idset `intersectsVarSet` fvs     -- Dump it+        = (free_dbs, dump_dbs `snocOL` db,+           extendVarSetList dump_idset (bindersOf bind))++        | otherwise     -- Don't dump it+        = (free_dbs `snocOL` db, dump_dbs, dump_idset)+++----------------------+deleteCallsMentioning :: VarSet -> CallDetails -> CallDetails+-- Remove calls mentioning any Id in bndrs+-- NB: The call is allowed to mention TyVars in bndrs+--     Note [Specialising polymorphic dictionaries]+--     ci_fvs are just the free /Ids/+deleteCallsMentioning bndrs calls+  = mapDVarEnv (ciSetFilter keep_call) calls+  where+    keep_call (CI { ci_fvs = fvs }) = fvs `disjointVarSet` bndrs++deleteCallsFor :: [Id] -> CallDetails -> CallDetails+-- Remove calls *for* bndrs+deleteCallsFor bndrs calls = delDVarEnvList calls bndrs++{-+************************************************************************+*                                                                      *+\subsubsection{Boring helper functions}+*                                                                      *+************************************************************************+-}++type SpecM a = UniqSM a++runSpecM :: SpecM a -> CoreM a+runSpecM thing_inside+  = do { us <- getUniqueSupplyM+       ; return (initUs_ us thing_inside) }++mapAndCombineSM :: (a -> SpecM (b, UsageDetails)) -> [a] -> SpecM ([b], UsageDetails)+mapAndCombineSM _ []     = return ([], emptyUDs)+mapAndCombineSM f (x:xs) = do (y, uds1) <- f x+                              (ys, uds2) <- mapAndCombineSM f xs+                              return (y:ys, uds1 `thenUDs` uds2)++-- extendTvSubst :: SpecEnv -> TyVar -> Type -> SpecEnv+-- extendTvSubst env tv ty+--   = env { se_subst = Core.extendTvSubst (se_subst env) tv ty }++extendInScope :: SpecEnv -> OutId -> SpecEnv+extendInScope env@(SE { se_subst = subst }) bndr+  = env { se_subst = subst `Core.extendSubstInScope` bndr }++zapSubst :: SpecEnv -> SpecEnv+zapSubst env@(SE { se_subst = subst })+  = env { se_subst = Core.zapSubst subst }++substTy :: SpecEnv -> Type -> Type+substTy env ty = substTyUnchecked (se_subst env) ty++substCo :: SpecEnv -> Coercion -> Coercion+substCo env co = Core.substCo (se_subst env) co++substBndr :: SpecEnv -> CoreBndr -> (SpecEnv, CoreBndr)+substBndr env bs = case Core.substBndr (se_subst env) bs of+                      (subst', bs') -> (env { se_subst = subst' }, bs')++substBndrs :: Traversable f => SpecEnv -> f CoreBndr -> (SpecEnv, f CoreBndr)+substBndrs env bs = case Core.substBndrs (se_subst env) bs of+                      (subst', bs') -> (env { se_subst = subst' }, bs')++cloneBndrSM :: SpecEnv -> Id -> SpecM (SpecEnv, Id)+-- Clone the binders of the bind; return new bind with the cloned binders+-- Return the substitution to use for RHSs, and the one to use for the body+-- Discards non-Stable unfoldings+cloneBndrSM env@(SE { se_subst = subst }) bndr+  = do { us <- getUniqueSupplyM+       ; let (subst', bndr') = Core.cloneIdBndr subst us bndr+       ; return (env { se_subst = subst' }, bndr') }++cloneRecBndrsSM :: SpecEnv -> [Id] -> SpecM (SpecEnv, [Id])+cloneRecBndrsSM env@(SE { se_subst = subst }) bndrs+  = do { (subst', bndrs') <- Core.cloneRecIdBndrsM subst bndrs+       ; let env' = env { se_subst = subst' }+       ; return (env', bndrs') }++newSpecIdSM :: Name -> Type -> IdDetails -> IdInfo -> SpecM Id+    -- Give the new Id a similar occurrence name to the old one+newSpecIdSM old_name new_ty details info+  = do  { uniq <- getUniqueM+        ; let new_occ  = mkSpecOcc (nameOccName old_name)+              new_name = mkInternalName uniq new_occ  (getSrcSpan old_name)+        ; return (assert (not (isCoVarType new_ty)) $+                  mkLocalVar details new_name ManyTy new_ty info) }  {-                 Old (but interesting) stuff about unboxed bindings
GHC/Core/Opt/StaticArgs.hs view
@@ -54,20 +54,23 @@  import GHC.Prelude -import GHC.Types.Var 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.Utils.Misc 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 @@ -108,7 +111,7 @@     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')+    return (Rec (zipEqual binders rhss'), mergeIdSATInfos sat_info_rhss')  data App = VarApp Id | TypeApp Type | CoApp Coercion data Staticness a = Static a | NotStatic@@ -420,13 +423,13 @@           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 Many (exprType rec_body)+          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)-                                   Many+                                   ManyTy                                    (exprType shadow_rhs)  isStaticValue :: Staticness App -> Bool
+ GHC/Core/Opt/Stats.hs view
@@ -0,0 +1,337 @@+{-+(c) The AQUA Project, Glasgow University, 1993-1998++-}++{-# LANGUAGE DerivingVia #-}++{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}++module GHC.Core.Opt.Stats (+    SimplCount, doSimplTick, doFreeSimplTick, simplCountN,+    pprSimplCount, plusSimplCount, zeroSimplCount,+    isZeroSimplCount, hasDetailedCounts, Tick(..)+  ) where++import GHC.Prelude++import GHC.Types.Var+import GHC.Types.Error++import GHC.Utils.Outputable as Outputable++import GHC.Data.FastString++import Data.List (sortOn)+import Data.List.NonEmpty (NonEmpty(..))+import qualified Data.List.NonEmpty as NE+import Data.Ord+import Data.Map (Map)+import qualified Data.Map as Map+import qualified Data.Map.Strict as MapStrict+import GHC.Utils.Panic (throwGhcException, GhcException(..))++getVerboseSimplStats :: (Bool -> SDoc) -> SDoc+getVerboseSimplStats = getPprDebug          -- For now, anyway++zeroSimplCount     :: Bool -- ^ -ddump-simpl-stats+                   -> SimplCount+isZeroSimplCount   :: SimplCount -> Bool+hasDetailedCounts  :: SimplCount -> Bool+pprSimplCount      :: SimplCount -> SDoc+doSimplTick        :: Int -- ^ History size of the elaborate counter+                   -> Tick -> SimplCount -> SimplCount+doFreeSimplTick    ::             Tick -> SimplCount -> SimplCount+plusSimplCount     :: SimplCount -> SimplCount -> SimplCount++data SimplCount+   = VerySimplCount !Int        -- Used when don't want detailed stats++   | SimplCount {+        ticks   :: !Int,        -- Total ticks+        details :: !TickCounts, -- How many of each type++        n_log   :: !Int,        -- N+        log1    :: [Tick],      -- Last N events; <= opt_HistorySize,+                                --   most recent first+        log2    :: [Tick]       -- Last opt_HistorySize events before that+                                -- Having log1, log2 lets us accumulate the+                                -- recent history reasonably efficiently+     }++type TickCounts = Map Tick Int++simplCountN :: SimplCount -> Int+simplCountN (VerySimplCount n)         = n+simplCountN (SimplCount { ticks = n }) = n++zeroSimplCount dump_simpl_stats+                -- This is where we decide whether to do+                -- the VerySimpl version or the full-stats version+  | dump_simpl_stats+  = SimplCount {ticks = 0, details = Map.empty,+                n_log = 0, log1 = [], log2 = []}+  | otherwise+  = VerySimplCount 0++isZeroSimplCount (VerySimplCount n)         = n==0+isZeroSimplCount (SimplCount { ticks = n }) = n==0++hasDetailedCounts (VerySimplCount {}) = False+hasDetailedCounts (SimplCount {})     = True++doFreeSimplTick tick sc@SimplCount { details = dts }+  = sc { details = dts `addTick` tick }+doFreeSimplTick _ sc = sc++doSimplTick history_size tick+    sc@(SimplCount { ticks = tks, details = dts, n_log = nl, log1 = l1 })+  | nl >= history_size = sc1 { n_log = 1, log1 = [tick], log2 = l1 }+  | otherwise          = sc1 { n_log = nl+1, log1 = tick : l1 }+  where+    sc1 = sc { ticks = tks+1, details = dts `addTick` tick }++doSimplTick _ _ (VerySimplCount n) = VerySimplCount (n+1)+++addTick :: TickCounts -> Tick -> TickCounts+addTick fm tick = MapStrict.insertWith (+) tick 1 fm++plusSimplCount sc1@(SimplCount { ticks = tks1, details = dts1 })+               sc2@(SimplCount { ticks = tks2, details = dts2 })+  = log_base { ticks = tks1 + tks2+             , details = MapStrict.unionWith (+) dts1 dts2 }+  where+        -- A hackish way of getting recent log info+    log_base | null (log1 sc2) = sc1    -- Nothing at all in sc2+             | null (log2 sc2) = sc2 { log2 = log1 sc1 }+             | otherwise       = sc2++plusSimplCount (VerySimplCount n) (VerySimplCount m) = VerySimplCount (n+m)+plusSimplCount lhs                rhs                =+  throwGhcException . PprProgramError "plusSimplCount" $ vcat+    [ text "lhs"+    , pprSimplCount lhs+    , text "rhs"+    , pprSimplCount rhs+    ]+       -- We use one or the other consistently++pprSimplCount (VerySimplCount n) = text "Total ticks:" <+> int n+pprSimplCount (SimplCount { ticks = tks, details = dts, log1 = l1, log2 = l2 })+  = vcat [text "Total ticks:    " <+> int tks,+          blankLine,+          pprTickCounts dts,+          getVerboseSimplStats $ \dbg -> if dbg+          then+                vcat [blankLine,+                      text "Log (most recent first)",+                      nest 4 (vcat (map ppr l1) $$ vcat (map ppr l2))]+          else Outputable.empty+    ]++{- Note [Which transformations are innocuous]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+At one point (Jun 18) I wondered if some transformations (ticks)+might be  "innocuous", in the sense that they do not unlock a later+transformation that does not occur in the same pass.  If so, we could+refrain from bumping the overall tick-count for such innocuous+transformations, and perhaps terminate the simplifier one pass+earlier.++But alas I found that virtually nothing was innocuous!  This Note+just records what I learned, in case anyone wants to try again.++These transformations are not innocuous:++*** NB: I think these ones could be made innocuous+          EtaExpansion+          LetFloatFromLet++LetFloatFromLet+    x = K (let z = e2 in Just z)+  prepareRhs transforms to+    x2 = let z=e2 in Just z+    x  = K xs+  And now more let-floating can happen in the+  next pass, on x2++PreInlineUnconditionally+  Example in spectral/cichelli/Auxil+     hinsert = ...let lo = e in+                  let j = ...lo... in+                  case x of+                    False -> ()+                    True -> case lo of I# lo' ->+                              ...j...+  When we PreInlineUnconditionally j, lo's occ-info changes to once,+  so it can be PreInlineUnconditionally in the next pass, and a+  cascade of further things can happen.++PostInlineUnconditionally+  let x = e in+  let y = ...x.. in+  case .. of { A -> ...x...y...+               B -> ...x...y... }+  Current postinlineUnconditinaly will inline y, and then x; sigh.++  But PostInlineUnconditionally might also unlock subsequent+  transformations for the same reason as PreInlineUnconditionally,+  so it's probably not innocuous anyway.++  One annoying variant is this.  CaseMerge introduces auxiliary bindings+     let b = b' in ...+  This takes another full run of the simplifier to elimiante.  But if+  the PostInlineUnconditionally, replacing b with b', is the only thing+  that happens in a Simplifier run, that probably really is innocuous.+  Perhaps an opportunity here.++KnownBranch, BetaReduction:+  May drop chunks of code, and thereby enable PreInlineUnconditionally+  for some let-binding which now occurs once++EtaExpansion:+  Example in imaginary/digits-of-e1+    fail = \void. e          where e :: IO ()+  --> etaExpandRhs+    fail = \void. (\s. (e |> g) s) |> sym g      where g :: IO () ~ S -> (S,())+  --> Next iteration of simplify+    fail1 = \void. \s. (e |> g) s+    fail = fail1 |> Void# -> sym g+  And now inline 'fail'++CaseMerge:+  case x of y {+    DEFAULT -> case y of z { pi -> ei }+    alts2 }+  ---> CaseMerge+    case x of { pi -> let z = y in ei+              ; alts2 }+  The "let z=y" case-binder-swap gets dealt with in the next pass+-}++pprTickCounts :: Map Tick Int -> SDoc+pprTickCounts counts+  = vcat (map pprTickGroup groups)+  where+    groups :: [NonEmpty (Tick, Int)] -- Each group shares a common tag+                                     -- toList returns common tags adjacent+    groups = NE.groupWith (tickToTag . fst) (Map.toList counts)++pprTickGroup :: NonEmpty (Tick, Int) -> SDoc+pprTickGroup group@((tick1,_) :| _)+  = hang (int (sum (fmap snd group)) <+> pprTickType tick1)+       2 (vcat [ int n <+> pprTickCts tick+                                    -- flip as we want largest first+               | (tick,n) <- sortOn (Down . snd) (NE.toList group)])++data Tick  -- See Note [Which transformations are innocuous]+  = PreInlineUnconditionally    Id+  | PostInlineUnconditionally   Id++  | UnfoldingDone               Id+  | RuleFired                   FastString      -- Rule name++  | LetFloatFromLet+  | EtaExpansion                Id      -- LHS binder+  | EtaReduction                Id      -- Binder on outer lambda+  | BetaReduction               Id      -- Lambda binder+++  | CaseOfCase                  Id      -- Bndr on *inner* case+  | KnownBranch                 Id      -- Case binder+  | CaseMerge                   Id      -- Binder on outer case+  | AltMerge                    Id      -- Case binder+  | CaseElim                    Id      -- Case binder+  | CaseIdentity                Id      -- Case binder+  | FillInCaseDefault           Id      -- Case binder++  | SimplifierDone              -- Ticked at each iteration of the simplifier++instance Outputable Tick where+  ppr tick = pprTickType tick <+> pprTickCts tick++instance Eq Tick where+  a == b = case a `cmpTick` b of+           EQ -> True+           _ -> False++instance Ord Tick where+  compare = cmpTick++tickToTag :: Tick -> Int+tickToTag (PreInlineUnconditionally _)  = 0+tickToTag (PostInlineUnconditionally _) = 1+tickToTag (UnfoldingDone _)             = 2+tickToTag (RuleFired _)                 = 3+tickToTag LetFloatFromLet               = 4+tickToTag (EtaExpansion _)              = 5+tickToTag (EtaReduction _)              = 6+tickToTag (BetaReduction _)             = 7+tickToTag (CaseOfCase _)                = 8+tickToTag (KnownBranch _)               = 9+tickToTag (CaseMerge _)                 = 10+tickToTag (CaseElim _)                  = 11+tickToTag (CaseIdentity _)              = 12+tickToTag (FillInCaseDefault _)         = 13+tickToTag SimplifierDone                = 16+tickToTag (AltMerge _)                  = 17++pprTickType :: Tick -> SDoc+pprTickType (PreInlineUnconditionally _) = text "PreInlineUnconditionally"+pprTickType (PostInlineUnconditionally _)= text "PostInlineUnconditionally"+pprTickType (UnfoldingDone _)            = text "UnfoldingDone"+pprTickType (RuleFired _)                = text "RuleFired"+pprTickType LetFloatFromLet              = text "LetFloatFromLet"+pprTickType (EtaExpansion _)             = text "EtaExpansion"+pprTickType (EtaReduction _)             = text "EtaReduction"+pprTickType (BetaReduction _)            = text "BetaReduction"+pprTickType (CaseOfCase _)               = text "CaseOfCase"+pprTickType (KnownBranch _)              = text "KnownBranch"+pprTickType (CaseMerge _)                = text "CaseMerge"+pprTickType (AltMerge _)                 = text "AltMerge"+pprTickType (CaseElim _)                 = text "CaseElim"+pprTickType (CaseIdentity _)             = text "CaseIdentity"+pprTickType (FillInCaseDefault _)        = text "FillInCaseDefault"+pprTickType SimplifierDone               = text "SimplifierDone"++pprTickCts :: Tick -> SDoc+pprTickCts (PreInlineUnconditionally v) = ppr v+pprTickCts (PostInlineUnconditionally v)= ppr v+pprTickCts (UnfoldingDone v)            = ppr v+pprTickCts (RuleFired v)                = ppr v+pprTickCts LetFloatFromLet              = Outputable.empty+pprTickCts (EtaExpansion v)             = ppr v+pprTickCts (EtaReduction v)             = ppr v+pprTickCts (BetaReduction v)            = ppr v+pprTickCts (CaseOfCase v)               = ppr v+pprTickCts (KnownBranch v)              = ppr v+pprTickCts (CaseMerge v)                = ppr v+pprTickCts (AltMerge v)                 = ppr v+pprTickCts (CaseElim v)                 = ppr v+pprTickCts (CaseIdentity v)             = ppr v+pprTickCts (FillInCaseDefault v)        = ppr v+pprTickCts _                            = Outputable.empty++cmpTick :: Tick -> Tick -> Ordering+cmpTick a b = case (tickToTag a `compare` tickToTag b) of+                GT -> GT+                EQ -> cmpEqTick a b+                LT -> LT++cmpEqTick :: Tick -> Tick -> Ordering+cmpEqTick (PreInlineUnconditionally a)  (PreInlineUnconditionally b)    = a `compare` b+cmpEqTick (PostInlineUnconditionally a) (PostInlineUnconditionally b)   = a `compare` b+cmpEqTick (UnfoldingDone a)             (UnfoldingDone b)               = a `compare` b+cmpEqTick (RuleFired a)                 (RuleFired b)                   = a `uniqCompareFS` b+cmpEqTick (EtaExpansion a)              (EtaExpansion b)                = a `compare` b+cmpEqTick (EtaReduction a)              (EtaReduction b)                = a `compare` b+cmpEqTick (BetaReduction a)             (BetaReduction b)               = a `compare` b+cmpEqTick (CaseOfCase a)                (CaseOfCase b)                  = a `compare` b+cmpEqTick (KnownBranch a)               (KnownBranch b)                 = a `compare` b+cmpEqTick (CaseMerge a)                 (CaseMerge b)                   = a `compare` b+cmpEqTick (AltMerge a)                  (AltMerge b)                    = a `compare` b+cmpEqTick (CaseElim a)                  (CaseElim b)                    = a `compare` b+cmpEqTick (CaseIdentity a)              (CaseIdentity b)                = a `compare` b+cmpEqTick (FillInCaseDefault a)         (FillInCaseDefault b)           = a `compare` b+cmpEqTick _                             _                               = EQ
GHC/Core/Opt/WorkWrap.hs view
@@ -5,20 +5,23 @@ -}  -module GHC.Core.Opt.WorkWrap ( wwTopBinds ) where+module GHC.Core.Opt.WorkWrap+ ( WwOpts (..)+ , wwTopBinds+ )+where  import GHC.Prelude -import GHC.Driver.Session- 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.FamInstEnv import GHC.Core.SimpleOpt +import GHC.Data.FastString+ import GHC.Types.Var import GHC.Types.Id import GHC.Types.Id.Info@@ -32,10 +35,7 @@ import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Utils.Panic.Plain import GHC.Utils.Monad-import GHC.Utils.Trace-import GHC.Unit.Types import GHC.Core.DataCon  {-@@ -66,14 +66,10 @@ \end{enumerate} -} -wwTopBinds :: Module -> DynFlags -> FamInstEnvs -> UniqSupply -> CoreProgram -> CoreProgram+wwTopBinds :: WwOpts -> UniqSupply -> CoreProgram -> CoreProgram -wwTopBinds this_mod dflags fam_envs us top_binds-  = initUs_ us $ do-    top_binds' <- mapM (wwBind ww_opts) top_binds-    return (concat top_binds')-  where-    ww_opts = initWwOpts this_mod dflags fam_envs+wwTopBinds ww_opts us top_binds+  = initUs_ us $ concatMapM (wwBind ww_opts) top_binds  {- ************************************************************************@@ -197,20 +193,48 @@  This comes up in practice (#6056). -Solution: do the w/w for strictness analysis, but transfer the Stable-unfolding to the *worker*.  So we will get something like this:+Solution: -  {-# INLINE[2] f #-}+* 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' -  {-# INLINABLE[2] fw #-}+  {-# Has stable unfolding, plus InlineSpec = INLINEABLE #-}   fw :: Ord a => [a] -> Int# -> a   fw d x y' = let y = I# y' in ...f... -How do we "transfer the unfolding"? Easy: by using the old one, wrapped-in work_fn! See GHC.Core.Unfold.Make.mkWorkerUnfolding. +(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@@ -488,7 +512,7 @@           about INLINE things here.  -What if `foo` has no specialiations, is worker/wrappered (with the+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 : ... #-}? @@ -498,19 +522,6 @@ in which case we don't unpack dictionaries for the worker; see see Note [Do not unbox class dictionaries].) -Note [Wrapper NoUserInlinePrag]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We use NoUserInlinePrag on the wrapper, to say that there is no-user-specified inline pragma. (The worker inherits that; see Note-[Worker/wrapper for INLINABLE functions].)  The wrapper has no pragma-given by the user.--(Historical note: we used to 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).  We don't need a pragma, because-everything we needs is expressed by (a) the stable unfolding and (b)-the inl_act activation.)- Note [Drop absent bindings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider (#19824):@@ -647,7 +658,7 @@         in p `seq` (v,v)  I think we'll give `f` the strictness signature `<SP(M,A)>`, where the-`M` sayd that we'll evaluate the first component of the pair at most+`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. @@ -682,10 +693,11 @@  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 [exprArity invariant] in GHC.Core.Opt.Arity) and we probably have-a PAP, cast or trivial expression as RHS.+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@@ -746,25 +758,29 @@ --------------------- splitFun :: WwOpts -> Id -> CoreExpr -> UniqSM [(Id, CoreExpr)] splitFun ww_opts fn_id rhs-  | not (wrap_dmds `lengthIs` count isId arg_vars)-    -- See Note [Don't eta expand in w/w]-  = return [(fn_id, rhs)]--  | otherwise+  | 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 arg_vars (exprType body) wrap_dmds 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 = simpleOptExpr (wo_simple_opts ww_opts) rhs-                  -- We need to stabilise the WW'd (and optimised) RHS below+              | 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) ]@@ -773,10 +789,15 @@               -> 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-    (arg_vars, body) = collectBinders rhs+    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) @@ -809,7 +830,7 @@                    NoInline _  -> inl_act fn_inl_prag                    _           -> inl_act wrap_prag -    work_prag = InlinePragma { inl_src = SourceText "{-# INLINE"+    work_prag = InlinePragma { inl_src = SourceText $ fsLit "{-# INLINE"                              , inl_inline = fn_inline_spec                              , inl_sat    = Nothing                              , inl_act    = work_act@@ -818,8 +839,8 @@       -- inl_act:    see Note [Worker activation]       -- inl_rule:   it does not make sense for workers to be constructorlike. -    work_join_arity | isJoinId fn_id = Just join_arity-                    | otherwise      = Nothing+    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]) @@ -874,17 +895,23 @@     fn_rules        = ruleInfoRules (ruleInfo fn_info)  mkStrWrapperInlinePrag :: InlinePragma -> [CoreRule] -> InlinePragma--- See Note [Wrapper activation]-mkStrWrapperInlinePrag (InlinePragma { inl_act = act, inl_rule = rule_info }) rules-  = InlinePragma { inl_src    = SourceText "{-# INLINE"-                 , inl_inline = NoUserInlinePrag -- See Note [Wrapper NoUserInlinePrag]+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 act `laterPhase` nextPhase InitialPhase+    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@@ -906,15 +933,15 @@ Example:    -- Original function-  f [Demand=<L,1*C1(U)>] :: (a,a) -> a+  f [Demand=<L,1*C(1,U)>] :: (a,a) -> a   f = \p -> ...    -- Wrapper-  f [Demand=<L,1*C1(U)>] :: a -> a -> a+  f [Demand=<L,1*C(1,U)>] :: a -> a -> a   f = \p -> case p of (a,b) -> $wf a b    -- Worker-  $wf [Demand=<L,1*C1(C1(U))>] :: Int -> Int+  $wf [Demand=<L,1*C(1,C(1,U))>] :: Int -> Int   $wf = \a b -> ...  We need to check whether the original function is called once, with@@ -923,7 +950,7 @@ the original function.  The demand on the worker is then calculated using mkWorkerDemand, and always of-the form [Demand=<L,1*(C1(...(C1(U))))>]+the form [Demand=<L,1*(C(1,...(C(1,U))))>]  Note [Thunk splitting] ~~~~~~~~~~~~~~~~~~~~~~
GHC/Core/Opt/WorkWrap/Utils.hs view
@@ -8,22 +8,20 @@ {-# LANGUAGE ViewPatterns #-}  module GHC.Core.Opt.WorkWrap.Utils-   ( WwOpts(..), initWwOpts, mkWwBodies, mkWWstr, mkWWstr_one-   , needsVoidWorkerArg, addVoidWorkerArg+   ( WwOpts(..), mkWwBodies, mkWWstr, mkWWstr_one+   , needsVoidWorkerArg    , DataConPatContext(..)-   , UnboxingDecision(..), wantToUnboxArg+   , UnboxingDecision(..), canUnboxArg    , findTypeShape, IsRecDataConResult(..), isRecDataCon    , mkAbsentFiller    , isWorkerSmallEnough, dubiousDataConInstArgTys-   , isGoodWorker, badWorker , goodWorker+   , boringSplit, usefulSplit, workWrapArity+   , canUnboxType, canUnboxTyCon    ) where  import GHC.Prelude -import GHC.Driver.Session-import GHC.Driver.Config (initSimpleOpts)- import GHC.Core import GHC.Core.Utils import GHC.Core.DataCon@@ -32,8 +30,10 @@ 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@@ -58,8 +58,6 @@ import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Utils.Panic.Plain-import GHC.Utils.Trace  import Control.Applicative ( (<|>) ) import Control.Monad ( zipWithM )@@ -67,6 +65,7 @@  import GHC.Types.RepType import GHC.Unit.Types+import GHC.Core.TyCo.Rep  {- ************************************************************************@@ -139,25 +138,18 @@  data WwOpts   = MkWwOpts-  { wo_fam_envs          :: !FamInstEnvs-  , wo_simple_opts       :: !SimpleOpts-  , wo_cpr_anal          :: !Bool--  -- Used for absent argument error message-  , wo_module            :: !Module-  , wo_unlift_strict     :: !Bool -- Generate workers even if the only effect is some args-                                  -- get passed unlifted.-                                  -- See Note [WW for calling convention]-  }--initWwOpts :: Module -> DynFlags -> FamInstEnvs -> WwOpts-initWwOpts this_mod dflags fam_envs = MkWwOpts-  { wo_fam_envs          = fam_envs-  , wo_simple_opts       = initSimpleOpts dflags-  , wo_cpr_anal          = gopt Opt_CprAnal dflags-  , wo_module            = this_mod-  , wo_unlift_strict     = gopt Opt_WorkerWrapperUnlift dflags-  }+  { -- | 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@@ -171,6 +163,7 @@  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@@ -217,31 +210,31 @@ -- and beta-redexes]), which allows us to apply the same split to function body -- and its unfolding(s) alike. ---mkWwBodies opts fun_id arg_vars res_ty demands res_cpr-  = do  { massertPpr (filter isId arg_vars `equalLength` demands)+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]-        ; uniq_supply <- getUniqueSupplyM         ; let args_free_tcvs = tyCoVarsOfTypes (res_ty : map varType arg_vars)               empty_subst = mkEmptySubst (mkInScopeSet args_free_tcvs)               zapped_arg_vars = map zap_var arg_vars-              (subst, cloned_arg_vars) = cloneBndrs empty_subst uniq_supply zapped_arg_vars-              res_ty' = GHC.Core.Subst.substTy subst res_ty-              init_cbv_marks = map (const NotMarkedStrict) cloned_arg_vars+        ; (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_cbv, wrap_fn_str, fn_args)-             <- mkWWstr opts cloned_arg_vars init_cbv_marks+        ; (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_cbv+        ; 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_cbv)+        ; let (work_lam_args, work_call_args, work_call_str)                 | needsVoidWorkerArg fun_id arg_vars work_args                 = addVoidWorkerArg work_args work_marks                 | otherwise@@ -252,9 +245,9 @@                                   -- See Note [Join points and beta-redexes]               wrapper_body = mkLams cloned_arg_vars . wrap_fn_cpr . wrap_fn_str . call_work                                   -- See Note [Call-by-value for worker args]-              work_seq_str_flds = mkStrictFieldSeqs (zip work_lam_args work_call_cbv)+              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]+              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,@@ -283,6 +276,10 @@       | 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@@ -300,6 +297,13 @@     -- 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] ~~~~~~~~~~~~~~~~~~~~~~~~@@ -387,25 +391,34 @@ -- Note [Preserving float barriers]. needsVoidWorkerArg :: Id -> [Var] -> [Var] -> Bool needsVoidWorkerArg fn_id wrap_args work_args-  =  not (isJoinId fn_id) && no_value_arg -- See Note [Protecting the last value argument]-  || needs_float_barrier                  -- See Note [Preserving float barriers]+  =  thunk_problem         -- See Note [Protecting the last value argument]+  || needs_float_barrier   -- See Note [Preserving float barriers]   where-    no_value_arg        = all (not . isId) work_args+    -- 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-    needs_float_barrier = wrap_had_barrier && not work_has_barrier --- | Inserts a `Void#` arg before the first argument.------ Why as the first argument? See Note [SpecConst needs to add void args first]--- in SpecConstr.+-- | 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]) -- cbv semantics for the worker args.-addVoidWorkerArg work_args cbv_marks-  = (voidArgId : work_args, voidPrimId:work_args, NotMarkedStrict:cbv_marks)+                 -> ( [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]@@ -413,8 +426,8 @@ If the user writes (\_ -> E), they might be intentionally disallowing the sharing of E. Since absence analysis and worker-wrapper are keen to remove such unused arguments, we add in a void argument to prevent-the function from becoming a thunk.  Three reasons why turning a function-into a thunk might be bad:+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]@@ -433,8 +446,20 @@        g = \x. 30#    Removing the \x would leave an unlifted binding. -NB: none of these apply to a join point.+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@@ -467,7 +492,7 @@    * \a{Abs}.\b{os}.\c{os}... ==> \b{os}.\c{os}.\(_::Void#)...     Wrapper arg `a` was the only float barrier and had been dropped. Hence Void#-  * \a{Abs,os}.\b{os}.\c... ==> \b{os}.\c...+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.@@ -479,6 +504,27 @@  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@@ -533,7 +579,7 @@ saw a type variable in the worker shadowing an outer term-variable binding.  We avoid the issue by freshening the argument variables from the original fun-RHS through 'cloneBndrs', which will also take care of subsitution in binder+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.@@ -563,125 +609,203 @@ -- --   * @dc @exs flds :: T tys@ --   * @co :: T tys ~ ty@-data DataConPatContext+--+-- 's' will be 'Demand' or 'Cpr'.+data DataConPatContext s   = DataConPatContext-  { dcpc_dc      :: !DataCon+  { 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 s-  = StopUnboxing-  -- ^ We ran out of strictness info. Leave untouched.-  | DropAbsent-  -- ^ The argument/field was absent. Drop it.-  | Unbox !DataConPatContext [s]-  -- ^ The argument is used strictly or the returned product was constructed, so-  -- unbox it.-  -- The 'DataConPatContext' carries the bits necessary for-  -- instantiation with 'dataConRepInstPat'.-  -- The @[s]@ carries the bits of information with which we can continue-  -- unboxing, e.g. @s@ will be 'Demand' or 'Cpr'.-  | Unlift-  -- ^ The argument can't be unboxed, but we want it to be passed evaluated to the worker.+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. --- Do we want to create workers just for unlifting?-wwForUnlifting :: WwOpts -> Bool-wwForUnlifting !opts+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 = goodWorker+    | wo_unlift_strict opts = usefulSplit     -- Don't unlift  it would cause additional W/W splits.-    | otherwise = badWorker--badWorker :: Bool-badWorker = False+    | otherwise             = boringSplit -goodWorker :: Bool-goodWorker = True+-- | Is the worker/wrapper split profitable?+type WwUse = Bool -isGoodWorker :: Bool -> Bool-isGoodWorker = id+-- | 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.-wantToUnboxArg-  :: Bool                -- ^ Consider unlifting-  -> FamInstEnvs-  -> Type                -- ^ Type of the argument-  -> Demand              -- ^ How the arg was used-  -> UnboxingDecision Demand+canUnboxArg+  :: FamInstEnvs+  -> Type        -- ^ Type of the argument+  -> Demand      -- ^ How the arg was used+  -> UnboxingDecision (DataConPatContext Demand) -- See Note [Which types are unboxed?]-wantToUnboxArg do_unlifting fam_envs ty dmd@(n :* sd)+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 <- tyConSingleAlgDataCon_maybe tc+  , Just [dc] <- canUnboxTyCon tc  -- tc is never a newtype   , let arity = dataConRepArity dc-  , Just (Unboxed, ds) <- viewProd arity sd -- See Note [Boxity analysis]-  -- NB: No strictness or evaluatedness checks for unboxing here.-  -- That is done by 'finaliseArgBoxities'!-  = Unbox (DataConPatContext dc tc_args co) ds--  -- See Note [CBV Function Ids]-  | do_unlifting-  , isStrUsedDmd dmd-  , not (isFunTy ty)-  , not (isUnliftedType ty) -- Already unlifted!-    -- NB: function arguments have a fixed RuntimeRep, so it's OK to call isUnliftedType here-  = Unlift+  , 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-  = StopUnboxing+  = DontUnbox   -- | Unboxing strategy for constructed results.-wantToUnboxResult :: FamInstEnvs -> Type -> Cpr -> UnboxingDecision Cpr+canUnboxResult :: FamInstEnvs -> Type -> Cpr+               -> UnboxingDecision (DataConPatContext Cpr) -- See Note [Which types are unboxed?]-wantToUnboxResult fam_envs ty cpr+canUnboxResult fam_envs ty cpr   | Just (con_tag, arg_cprs) <- asConCpr cpr   , Just (tc, tc_args, co) <- normSplitTyConApp_maybe fam_envs ty-  , Just dcs <- tyConAlgDataCons_maybe tc <|> open_body_ty_warning+  , 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 Note [Which types are unboxed?]+                                -- See (CPR1) in Note [Which types are unboxed?]                                 -- and GHC.Core.Opt.CprAnal.argCprType                                 -- where we also check this.-  , all isLinear (dataConInstArgTys dc tc_args)-  -- Deactivates CPR worker/wrapper splits on constructors with non-linear-  -- arguments, for the moment, because they require unboxed tuple with variable-  -- multiplicity fields.-  = Unbox (DataConPatContext dc tc_args co) arg_cprs+  , 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-  = StopUnboxing+  = DontUnbox    where     -- See Note [non-algebraic or open body type warning]-    open_body_ty_warning = warnPprTrace True "wantToUnboxResult: non-algebraic or open body type" (ppr ty) Nothing+    open_body_ty_warning = warnPprTrace True "canUnboxResult: non-algebraic or open body type" (ppr ty) Nothing -isLinear :: Scaled a -> Bool-isLinear (Scaled w _ ) =-  case w of-    One -> True-    _ -> False  -{- Note [Which types are unboxed?]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+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+       * that may bind existentials (#18982)      We can transform      > data D a = forall b. D a b      > f (D @ex a b) = e@@ -694,24 +818,27 @@        * 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'. -     NB: We don't allow existentials for CPR W/W, because we don't have unboxed-     dependent tuples (yet?). Otherwise, we could transform+     (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..) #) -The respective tests are in 'wantToUnboxArg' and-'wantToUnboxResult', respectively.+     (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. -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.+The respective tests are in 'canUnboxArg' and+'canUnboxResult', respectively.  Note [mkWWstr and unsafeCoerce] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -738,7 +865,7 @@ other cases where something went avoidably wrong.  This warning also triggers for the stream fusion library within `text`.-We can'easily W/W constructed results like `Stream` because we have no simple+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]@@ -762,17 +889,20 @@  Performing W/W might not always be a win. In particular it's easy to break (badly written, but common) rule frameworks by doing additional W/W splits.-See #20364 for a more detailed explaination.+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 oppertunity for unlifting.+  + 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.@@ -782,7 +912,7 @@   - Requires either:     ~ Eta-expansion at *all* call sites in order to generate       an impedance matcher function. Leading to massive code bloat.-      Essentially we end up creating a imprompto wrapper function+      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@@ -793,12 +923,61 @@  Currently we use the first approach A) by default, with a flag that allows users to fall back to the more aggressive approach B).+ I also tried the third approach C) using eta-expansion at call sites to avoid modifying the PAP-handling code which wasn't fruitful. See https://gitlab.haskell.org/ghc/ghc/-/merge_requests/5614#note_389903. We could still try to do C) in the future by having PAP calls which will evaluate the required arguments before calling the partially applied function. But this would be neither a small nor simple change so we stick with A) and a flag for B) for now.-See also Note [Tag Inference] and Note [CBV Function Ids]++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 -}  {-@@ -812,8 +991,8 @@ mkWWstr :: WwOpts         -> [Var]                         -- Wrapper args; have their demand info on them                                          --  *Includes type variables*-        -> [StrictnessMark]                     -- cbv info for arguments-        -> UniqSM (Bool,                 -- Will this result in a useful worker+        -> [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@@ -821,20 +1000,19 @@                    [CoreExpr])           -- Reboxed args for the call to the                                          -- original RHS. Corresponds one-to-one                                          -- with the wrapper arg vars-mkWWstr opts args cbv_info-  = go args cbv_info+mkWWstr opts args str_marks+  = -- pprTrace "mkWWstr" (ppr args) $+    go args str_marks   where-    go_one arg cbv = mkWWstr_one opts arg cbv--    go []           _ = return (badWorker, [], nop_fn, [])-    go (arg : args) (cbv:cbvs)-      =               do { (useful1, args1, wrap_fn1, wrap_arg)  <- go_one arg cbv-                         ; (useful2, args2, wrap_fn2, wrap_args) <- go args cbvs-                         ; return ( useful1 || useful2-                                  , args1 ++ args2-                                  , wrap_fn1 . wrap_fn2-                                  , wrap_arg:wrap_args ) }-    go _ _ = panic "mkWWstr: Impossible - cbv/arg length missmatch"+    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)@@ -846,65 +1024,78 @@ mkWWstr_one :: WwOpts             -> Var             -> StrictnessMark-            -> UniqSM (Bool, [(Var,StrictnessMark)], CoreExpr -> CoreExpr, CoreExpr)-mkWWstr_one opts arg banged =-  case wantToUnboxArg True fam_envs arg_ty arg_dmd of+            -> 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 banged-         -- Absent case.  Dropt the argument from the worker.+      | 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 (goodWorker, [], nop_fn, absent_filler)+      -> return (usefulSplit, [], nop_fn, absent_filler)+      | otherwise -> do_nothing -    Unbox dcpc ds -> unbox_one_arg opts arg ds dcpc banged+    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 -    Unlift -> return  ( wwForUnlifting opts-                      , [(arg, MarkedStrict)]-                      , nop_fn-                      , varToCoreExpr arg)+    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 ) -    _ -> do_nothing -- Other cases, like StopUnboxing+      | otherwise -> do_nothing    where     fam_envs   = wo_fam_envs opts     arg_ty     = idType arg     arg_dmd    = idDemandInfo arg-    -- Type args don't get cbv marks-    arg_cbv    = if isTyVar arg then NotMarkedStrict else banged--    do_nothing = return (badWorker, [(arg,arg_cbv)], nop_fn, varToCoreExpr arg)+    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-          -> [Demand]-          -> DataConPatContext-          -> StrictnessMark-          -> UniqSM (Bool, [(Var,StrictnessMark)], CoreExpr -> CoreExpr, CoreExpr)-unbox_one_arg opts arg_var ds-          DataConPatContext { dcpc_dc = dc, dcpc_tc_args = tc_args-                            , dcpc_co = co }-          _marked_cbv+              -> 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+             (ex_tvs', arg_ids) = dataConRepFSInstPat (ex_name_fss ++ repeat ww_prefix)+                                            pat_bndrs_uniqs (idMult arg_var) dc tc_args              con_str_marks = dataConRepStrictness dc-             -- Apply str info to new args. Also remove OtherCon unfoldings so they don't end up in lambda binders-             -- of the worker. See Note [Never put `OtherCon` unfoldings on lambda binders]-             arg_ids' = map zapIdUnfolding $ zipWithEqual "unbox_one_arg" setIdDemandInfo arg_ids ds++             -- 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 make the worker strict on those-             -- argumnets later. seq them later. See Note [Call-by-value for worker args]-             strict_marks = (map (const NotMarkedStrict) ex_tvs') ++ con_str_marks-       ; (_sub_args_quality, worker_args, wrap_fn, wrap_args) <- mkWWstr opts (ex_tvs' ++ arg_ids') strict_marks++             -- 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-       ; return (goodWorker, worker_args, unbox_fn . wrap_fn, wrap_arg) }-                          -- Don't pass the arg, rebox instead+       -- 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].@@ -913,21 +1104,25 @@ -- same type as @id@. Otherwise, no suitable filler could be found. mkAbsentFiller :: WwOpts -> Id -> StrictnessMark -> Maybe CoreExpr mkAbsentFiller opts arg str-  -- The lifted case: Bind 'absentError' for a nice panic message if we are-  -- wrong (like we were in #11126). See (1) in Note [Absent fillers]+  -- 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 is_strict-  , not (isMarkedStrict str) -- See (2) in Note [Absent fillers]+  , 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], the main part+  -- 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-    is_strict = isStrictDmd (idDemandInfo arg)+    arg_ty = idType arg      msg = renderWithContext             (defaultSDocContext { sdocSuppressUniques = True })@@ -946,7 +1141,7 @@ {- Note [Worker/wrapper for Strictness and Absence] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The worker/wrapper transformation, mkWWstr_one, takes concrete action-based on the 'UnboxingDescision' returned by 'wantToUnboxArg'.+based on the 'UnboxingDecision' returned by 'canUnboxArg'. The latter takes into account several possibilities to decide if the function is worthy for splitting: @@ -960,7 +1155,7 @@  2. If the argument is evaluated strictly (or known to be eval'd),    we can take a view into the product demand ('viewProd'). In accordance-   with Note [Boxity analysis], 'wantToUnboxArg' will say 'Unbox'.+   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 @@ -982,7 +1177,7 @@      $gw c a b = if c then a else b  2a But do /not/ unbox if Boxity Analysis said "Boxed".-   In this case, 'wantToUnboxArg' returns 'StopUnboxing'.+   In this case, 'canUnboxArg' returns 'DontUnbox'.    Otherwise we risk decomposing and reboxing a massive    tuple which is barely used. Example: @@ -1003,7 +1198,7 @@ 3. In all other cases (e.g., lazy, used demand and not eval'd),    'finaliseArgBoxities' will have cleared the Boxity flag to 'Boxed'    (see Note [Finalising boxity for demand signatures] in GHC.Core.Opt.DmdAnal)-   and 'wantToUnboxArg' returns 'StopUnboxing' so that 'mkWWstr_one'+   and 'canUnboxArg' returns 'DontUnbox' so that 'mkWWstr_one'    stops unboxing.  Note [Worker/wrapper for bottoming functions]@@ -1090,7 +1285,7 @@  Needless to say, there are some wrinkles: -  1. In case we have a absent, /lazy/, and /lifted/ arg, we use an error-thunk+(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]).@@ -1098,7 +1293,7 @@      Obviously, we can't use an error-thunk if the value is of unlifted rep      (like 'Int#' or 'MutVar#'), because we'd immediately evaluate the panic. -  2. We also mustn't put an error-thunk (that fills in for an absent value of+(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@@ -1119,12 +1314,12 @@      NB from Andreas: But I think using an error thunk there would be dodgy no matter what      for example if we decide to pass the argument to the bottoming function cbv.      As we might do if the function in question is a worker.-     See Note [CBV Function Ids] in GHC.CoreToStg.Prep. So I just left the strictness check+     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. -  3. We can only emit a LitRubbish if the arg's type @arg_ty@ is mono-rep, e.g.-     of the form @TYPE rep@ where @rep@ is not (and doesn't contain) a variable.+(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@@ -1134,9 +1329,31 @@      have to be representation monomorphic. But in the future, we might allow      levity polymorphism, e.g. a polymorphic levity variable in 'BoxedRep'. -While (1) and (2) are simply an optimisation in terms of compiler debugging-experience, (3) should be irrelevant in most programs, if not all.+(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@@ -1154,6 +1371,26 @@    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@@ -1162,16 +1399,25 @@ -}  -- | Exactly 'dataConInstArgTys', but lacks the (ASSERT'ed) precondition that--- the 'DataCon' may not have existentials. The lack of cloning the existentials--- compared to 'dataConInstExAndArgVars' makes this function \"dubious\";--- only use it where type variables aren't substituted for!+-- 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-    subst    = extendTCvInScopeList (zipTvSubst univ_tvs tc_args) ex_tvs-    arg_tys  = map (GHC.Core.Type.substTy subst . scaledThing) (dataConRepArgTys dc)+    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@@ -1185,7 +1431,7 @@        -- to look deep into such products -- see #18034   where     go rec_tc ty-       | Just (_, _, res) <- splitFunTy_maybe ty+       | Just (_, _, _, res) <- splitFunTy_maybe ty        = TsFun (go rec_tc res)         | Just (tc, tc_args)  <- splitTyConApp_maybe ty@@ -1201,7 +1447,8 @@        | Just (HetReduction (Reduction _ rhs) _) <- topReduceTyFamApp_maybe fam_envs tc tc_args        = go rec_tc rhs -       | Just con <- tyConSingleAlgDataCon_maybe tc+       | not (isNewTyCon tc)+       , Just con <- tyConSingleDataCon_maybe tc        , Just rec_tc <- if isTupleTyCon tc                         then Just rec_tc                         else checkRecTc rec_tc tc@@ -1249,7 +1496,7 @@ --     through one of @dc@'s fields (so surely non-recursive). --   * @NonRecursiveOrUnsure@ when @fuel /= Infinity@ --     and @fuel@ expansions of nested data TyCons were not enough to prove---     non-recursivenss, nor arrive at an occurrence of @tc@ thus proving+--     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.@@ -1276,23 +1523,29 @@                     | arg_ty <- map scaledThing (dataConRepArgTys dc) ]      go_arg_ty :: IntWithInf -> TyConSet -> Type -> IsRecDataConResult-    go_arg_ty fuel visited_tcs ty-      --- | pprTrace "arg_ty" (ppr ty) False = undefined+    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) -      | Just (_tcv, ty') <- splitForAllTyCoVar_maybe ty-      = go_arg_ty fuel visited_tcs ty'+        ForAllTy _ ty' -> go_arg_ty fuel visited_tcs ty'           -- See Note [Detecting recursive data constructors], point (A) -      | Just (tc, tc_args) <- splitTyConApp_maybe ty-      = go_tc_app fuel visited_tcs tc tc_args+        CastTy ty' _ -> go_arg_ty fuel visited_tcs ty' -      | otherwise-      = NonRecursiveOrUnsure+        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+        ---_ | 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)@@ -1335,12 +1588,12 @@   :: WwOpts   -> Type                              -- function body   -> Cpr                               -- CPR analysis results-  -> UniqSM (Bool,            -- Is w/w'ing useful?+  -> 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 (badWorker, nop_fn, nop_fn)+  | not (wo_cpr_anal opts) = return (boringSplit, nop_fn, nop_fn)   | otherwise = do     -- Part (1)     res_bndr <- mk_res_bndr body_ty@@ -1357,8 +1610,8 @@     let wrap_fn      = unbox_transit_tup rebuilt_result                 -- 3 2         work_fn body = bind_res_bndr body (work_unpack_res transit_tup) -- 1 2 3     return $ if not useful-                then (badWorker, nop_fn, nop_fn)-                else (goodWorker, wrap_fn, work_fn)+                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@@ -1370,20 +1623,20 @@  -- | What part (2) of Note [Worker/wrapper for CPR] collects. -----   1. A Bool capturing whether the transformation did anything useful.+--   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  = (Bool, OrdList Var,  CoreExpr , CoreExpr -> CoreExpr)-type CprWwResultMany = (Bool, OrdList Var, [CoreExpr], CoreExpr -> CoreExpr)+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 (badWorker, toOL vars, map varToCoreExpr vars, nop_fn)+  return (boringSplit, toOL vars, map varToCoreExpr vars, nop_fn) mkWWcpr opts  vars cprs = do-  -- No existentials in 'vars'. 'wantToUnboxResult' should have checked that.+  -- 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) <-@@ -1397,17 +1650,17 @@ -- ^ See if we want to unbox the result and hand off to 'unbox_one_result'. mkWWcpr_one opts res_bndr cpr   | assert (not (isTyVar res_bndr) ) True-  , Unbox dcpc arg_cprs <- wantToUnboxResult (wo_fam_envs opts) (idType res_bndr) cpr-  = unbox_one_result opts res_bndr arg_cprs dcpc+  , DoUnbox dcpc <- canUnboxResult (wo_fam_envs opts) (idType res_bndr) cpr+  = unbox_one_result opts res_bndr dcpc   | otherwise-  = return (badWorker, unitOL res_bndr, varToCoreExpr res_bndr, nop_fn)+  = return (boringSplit, unitOL res_bndr, varToCoreExpr res_bndr, nop_fn)  unbox_one_result-  :: WwOpts -> Id -> [Cpr] -> DataConPatContext -> UniqSM CprWwResultOne+  :: 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 arg_cprs+unbox_one_result opts res_bndr                  DataConPatContext { dcpc_dc = dc, dcpc_tc_args = tc_args-                                   , dcpc_co = co } = do+                                   , dcpc_co = co, dcpc_args = arg_cprs } = do   -- unboxer (free in `res_bndr`):       |   builder (where <i> builds what was   --   ( case res_bndr of (i, j) -> )    |            bound to i)   --   ( case i of I# a ->          )    |@@ -1416,7 +1669,7 @@   pat_bndrs_uniqs <- getUniquesM   let (_exs, arg_ids) =         dataConRepFSInstPat (repeat ww_prefix) pat_bndrs_uniqs cprCaseBndrMult dc tc_args-  massert (null _exs) -- Should have been caught by wantToUnboxResult+  massert (null _exs) -- Should have been caught by canUnboxResult    (nested_useful, transit_vars, con_args, work_unbox_res) <-     mkWWcpr opts arg_ids arg_cprs@@ -1426,11 +1679,10 @@       -- this_work_unbox_res alt = (case res_bndr |> co of C a b -> <alt>[a,b])       this_work_unbox_res = mkUnpackCase (Var res_bndr) co cprCaseBndrMult dc arg_ids -  -- Don't try to WW an unboxed tuple return type when there's nothing inside-  -- to unbox further.+  -- See Note [Unboxing through unboxed tuples]   return $ if isUnboxedTupleDataCon dc && not nested_useful-              then ( badWorker, unitOL res_bndr, Var res_bndr, nop_fn )-              else ( goodWorker+              then ( boringSplit, unitOL res_bndr, Var res_bndr, nop_fn )+              else ( usefulSplit                    , transit_vars                    , rebuilt_result                    , this_work_unbox_res . work_unbox_res@@ -1464,7 +1716,7 @@                                     (DataAlt tup_con) vars build_res     , ubx_tup_app )    where-    ubx_tup_app = mkCoreUbxTup (map idType vars) (map varToCoreExpr vars)+    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)@@ -1553,7 +1805,7 @@     We want  `$wh :: Int# -> [Int]`.     We'd get `$wh :: Int# -> (# [Int] #)`. -By considering vars as unlifted that satsify 'exprIsHNF', we catch (3).+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@@ -1565,7 +1817,7 @@ Remark on linearity: in both the case of the wrapper and the worker, we build a linear case to unpack constructed products. All the multiplicity information is kept in the constructors (both C and (#, #)).-In particular (#,#) is parametrised by the multiplicity of its fields.+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. @@ -1593,7 +1845,7 @@ -- | The multiplicity of a case binder unboxing a constructed result. -- See Note [Linear types and CPR] cprCaseBndrMult :: Mult-cprCaseBndrMult = One+cprCaseBndrMult = OneTy  ww_prefix :: FastString ww_prefix = fsLit "ww"
GHC/Core/PatSyn.hs view
@@ -12,7 +12,8 @@         PatSyn, PatSynMatcher, PatSynBuilder, mkPatSyn,          -- ** Type deconstruction-        patSynName, patSynArity, patSynIsInfix, patSynResultType,+        patSynName, patSynArity, patSynVisArity,+        patSynIsInfix, patSynResultType,         isVanillaPatSyn,         patSynArgs,         patSynMatcher, patSynBuilder,@@ -38,6 +39,8 @@ 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)@@ -376,7 +379,7 @@ -- | Build a new pattern synonym mkPatSyn :: Name          -> Bool                 -- ^ Is the pattern synonym declared infix?-         -> ([InvisTVBinder], ThetaType) -- ^ Universially-quantified type+         -> ([InvisTVBinder], ThetaType) -- ^ Universally-quantified type                                          -- variables and required dicts          -> ([InvisTVBinder], ThetaType) -- ^ Existentially-quantified type                                          -- variables and provided dicts@@ -387,7 +390,7 @@          -> [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+ -- 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)@@ -420,6 +423,13 @@ 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)@@ -506,6 +516,6 @@         , pprType sigma_ty ]   where     sigma_ty = mkInvisForAllTys ex_tvs $-               mkInvisFunTysMany prov_theta $+               mkInvisFunTys prov_theta $                mkVisFunTysMany orig_args orig_res_ty     insert_empty_ctxt = null req_theta && not (null prov_theta && null ex_tvs)
GHC/Core/Ppr.hs view
@@ -22,7 +22,7 @@         pprCoreExpr, pprParendExpr,         pprCoreBinding, pprCoreBindings, pprCoreAlt,         pprCoreBindingWithSize, pprCoreBindingsWithSize,-        pprCoreBinder, pprCoreBinders,+        pprCoreBinder, pprCoreBinders, pprId, pprIds,         pprRule, pprRules, pprOptCo,         pprOcc, pprOccWithTick     ) where@@ -44,7 +44,6 @@ import GHC.Core.TyCo.Ppr import GHC.Core.Coercion import GHC.Types.Basic-import GHC.Data.Maybe import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Types.SrcLoc ( pprUserRealSpan )@@ -140,8 +139,8 @@     pp_val_bdr = pprPrefixOcc val_bdr      pp_bind = case bndrIsJoin_maybe val_bdr of-                Nothing -> pp_normal_bind-                Just ar -> pp_join_bind ar+                NotJoinPoint -> pp_normal_bind+                JoinPoint ar -> pp_join_bind ar      pp_normal_bind = hang pp_val_bdr 2 (equals <+> pprCoreExpr expr) @@ -159,9 +158,9 @@                   -- So refer to printing  j = e       = pp_normal_bind       where-        (bndrs, body) = collectBinders expr-        lhs_bndrs = take join_arity bndrs-        rhs       = mkLams (drop join_arity bndrs) body+        (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@@ -172,8 +171,12 @@ 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 <+> ppr (coercionType co)-              False -> parens $ sep [ppr co, dcolon <+> ppr (coercionType co)]+              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@@ -236,7 +239,13 @@         _ -> parens (hang (pprParendExpr fun) 2 pp_args)     } -ppr_expr add_par (Case expr var ty [Alt con args rhs])+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! {"@@ -260,7 +269,7 @@   where     ppr_bndr = pprBndr CaseBind -ppr_expr add_par (Case expr var ty alts)+ppr_expr add_par (Case expr var ty alts) -- Multi alt Case   = add_par $     sep [sep [text "case"                 <+> pprCoreExpr expr@@ -302,17 +311,19 @@          pprCoreExpr expr]   where     keyword (NonRec b _)-     | isJust (bndrIsJoin_maybe b) = text "join"-     | otherwise                   = text "let"+     | isJoinPoint (bndrIsJoin_maybe b) = text "join"+     | otherwise                        = text "let"     keyword (Rec pairs)      | ((b,_):_) <- pairs-     , isJust (bndrIsJoin_maybe b) = text "joinrec"-     | otherwise                   = text "letrec"+     , isJoinPoint (bndrIsJoin_maybe b) = text "joinrec"+     | otherwise                        = text "letrec"  ppr_expr add_par (Tick tickish expr)   = sdocOption sdocSuppressTicks $ \case-      True  -> ppr_expr add_par expr-      False -> add_par (sep [ppr tickish, pprCoreExpr expr])+      -- 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)@@ -376,13 +387,13 @@   pprBndr = pprCoreBinder   pprInfixOcc  = pprInfixName  . varName   pprPrefixOcc = pprPrefixName . varName-  bndrIsJoin_maybe = isJoinId_maybe+  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 _) = isJoinId_maybe b+  bndrIsJoin_maybe (TB b _) = idJoinPointHood b  pprOcc :: OutputableBndr a => LexicalFixity -> a -> SDoc pprOcc Infix  = pprInfixOcc@@ -462,6 +473,13 @@ 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@@ -525,7 +543,7 @@       has_caf_info = not (mayHaveCafRefs caf_info)        str_info = dmdSigInfo info-      has_str_info = not (isTopSig str_info)+      has_str_info = not (isNopSig str_info)        unf_info = realUnfoldingInfo info       has_unf = hasSomeUnfolding unf_info@@ -569,7 +587,7 @@     has_caf_info = not (mayHaveCafRefs caf_info)      str_info = dmdSigInfo info-    has_str_info = not (isTopSig str_info)+    has_str_info = not (isNopSig str_info)      cpr_info = cprSigInfo info     has_cpr_info = cpr_info /= topCprSig@@ -605,11 +623,6 @@                int size,                int discount ] -instance Outputable UnfoldingSource where-  ppr InlineCompulsory  = text "Compulsory"-  ppr InlineStable      = text "InlineStable"-  ppr InlineRhs         = text "<vanilla>"- instance Outputable Unfolding where   ppr NoUnfolding                = text "No unfolding"   ppr BootUnfolding              = text "No unfolding (from boot)"@@ -619,18 +632,14 @@                 <+> 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 })+                     , 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-                , text "Value="      <> ppr hnf-                , text "ConLike="    <> ppr conlike-                , text "WorkFree="   <> ppr wf-                , text "Expandable=" <> ppr exp+                , ppr cache                 , text "Guidance="   <> ppr g ]       pp_tmpl = ppUnlessOption sdocSuppressUnfoldings                   (text "Tmpl=" <+> ppr rhs)@@ -639,6 +648,15 @@             -- 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@@ -676,9 +694,10 @@             ppr modl, comma,             ppr ix,             text ">"]-  ppr (Breakpoint _ext ix vars) =+  ppr (Breakpoint _ext bid vars) =       hcat [text "break<",-            ppr ix,+            ppr (bi_tick_mod bid), comma,+            ppr (bi_tick_index bid),             text ">",             parens (hcat (punctuate comma (map ppr vars)))]   ppr (ProfNote { profNoteCC = cc,
+ GHC/Core/Ppr.hs-boot view
@@ -0,0 +1,11 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++module GHC.Core.Ppr where++import {-# SOURCE #-} GHC.Core+import {-# SOURCE #-} GHC.Types.Var (Var)+import GHC.Utils.Outputable (OutputableBndr, Outputable)++instance OutputableBndr b => Outputable (Expr b)++instance OutputableBndr Var
GHC/Core/Predicate.hs view
@@ -8,51 +8,117 @@  module GHC.Core.Predicate (   Pred(..), classifyPredType,-  isPredTy, isEvVarType,+  isPredTy, isSimplePredTy,    -- Equality predicates   EqRel(..), eqRelRole,-  isEqPrimPred, isEqPred,+  isEqPred, isReprEqPred, isEqClassPred, isCoVarType,   getEqPredTys, getEqPredTys_maybe, getEqPredRole,-  predTypeEqRel,-  mkPrimEqPred, mkReprPrimEqPred, mkPrimEqPredRole,-  mkHeteroPrimEqPred, mkHeteroReprPrimEqPred,+  predTypeEqRel, pprPredType,+  mkNomEqPred, mkReprEqPred, mkEqPred, mkEqPredRole,    -- Class predicates-  mkClassPred, isDictTy,-  isClassPred, isEqPredClass, isCTupleClass,+  mkClassPred, isDictTy, typeDeterminesValue,+  isClassPred, isEqualityClass, isCTupleClass, isUnaryClass,   getClassPredTys, getClassPredTys_maybe,   classMethodTy, classMethodInstTy,    -- Implicit parameters-  isIPLikePred, hasIPSuperClasses, isIPTyCon, isIPClass,+  couldBeIPLike, mightMentionIP, isIPTyCon, isIPClass, decomposeIPPred,   isCallStackTy, isCallStackPred, isCallStackPredTy,+  isExceptionContextPred, isExceptionContextTy,   isIPPred_maybe,    -- Evidence variables-  DictId, isEvVar, isDictId+  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.Core.Coercion+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 -import Control.Monad ( guard ) +{- *********************************************************************+*                                                                      *+*                   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@@ -60,7 +126,7 @@   -- | A typeclass predicate.   = ClassPred Class [Type] -  -- | A type equality predicate.+  -- | A type equality predicate, (t1 ~#N t2) or (t1 ~#R t2)   | EqPred EqRel Type Type    -- | An irreducible predicate.@@ -68,40 +134,144 @@    -- | A quantified predicate.   ---  -- See Note [Quantified constraints] in GHC.Tc.Solver.Canonical+  -- 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) => (%,%) c1 c2+  --        class (c1, c2) => CTuple2 c1 c2 -classifyPredType :: PredType -> Pred-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+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+      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+      _ | (tvs, rho) <- splitForAllTyCoVars ev_ty+        , (theta, pred) <- splitFunTys rho+        , not (null tvs && null theta)+        -> ForAllPred tvs (map scaledThing theta) pred -      | otherwise-      -> IrredPred ev_ty+        | otherwise+        -> IrredPred ev_ty --- --------------------- Dictionary types ---------------------------------+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)@@ -132,6 +302,23 @@   = 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'@@ -147,6 +334,37 @@ 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@@ -165,67 +383,26 @@       _ -> 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.+-- | Get the equality relation relevant for a pred type+-- Returns NomEq for dictionary predicates, etc predTypeEqRel :: PredType -> EqRel predTypeEqRel ty-  | Just (tc, _) <- splitTyConApp_maybe ty-  , tc `hasKey` eqReprPrimTyConKey-  = ReprEq-  | otherwise-  = NomEq--{--------------------------------------------Predicates on PredType---------------------------------------------}--{--Note [Evidence for quantified constraints]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The superclass mechanism in GHC.Tc.Solver.Canonical.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.Canonical.--}--isEvVarType :: Type -> Bool--- True of (a) predicates, of kind Constraint, such as (Eq a), and (a ~ b)---         (b) coercion types, such as (t1 ~# t2) or (t1 ~R# t2)--- See Note [Types for coercions, predicates, and evidence] in GHC.Core.TyCo.Rep--- See Note [Evidence for quantified constraints]-isEvVarType ty = isCoVarType ty || isPredTy ty--isEqPredClass :: Class -> Bool--- True of (~) and (~~)-isEqPredClass cls =  cls `hasKey` eqTyConKey-                  || cls `hasKey` heqTyConKey--isClassPred, isEqPred, isEqPrimPred :: PredType -> Bool-isClassPred ty = case tyConAppTyCon_maybe ty of-    Just tyCon | isClassTyCon tyCon -> True-    _                               -> False--isEqPred ty  -- True of (a ~ b) and (a ~~ b)-             -- ToDo: should we check saturation?-  | Just tc <- tyConAppTyCon_maybe ty-  , Just cls <- tyConClass_maybe tc-  = isEqPredClass cls-  | otherwise-  = False--isEqPrimPred ty = isCoVarType ty-  -- True of (a ~# b) (a ~R# b)--isCTupleClass :: Class -> Bool-isCTupleClass cls = isTupleTyCon (classTyCon cls)+  | 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  {- ********************************************************************* *                                                                      *@@ -233,6 +410,8 @@ *                                                                      * ********************************************************************* -} +-- --------------------- Nomal implicit-parameter predicates ---------------+ isIPTyCon :: TyCon -> Bool isIPTyCon tc = tc `hasKey` ipClassKey   -- Class and its corresponding TyCon have the same Unique@@ -240,39 +419,49 @@ isIPClass :: Class -> Bool isIPClass cls = cls `hasKey` ipClassKey -isIPLikePred :: Type -> Bool--- See Note [Local implicit parameters]-isIPLikePred = is_ip_like_pred initIPRecTc+-- | 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) -is_ip_like_pred :: RecTcChecker -> Type -> Bool-is_ip_like_pred rec_clss ty-  | Just (tc, tys) <- splitTyConApp_maybe ty-  , Just rec_clss' <- if isTupleTyCon tc  -- Tuples never cause recursion-                      then Just rec_clss-                      else checkRecTc rec_clss tc-  , Just cls       <- tyConClass_maybe tc-  = isIPClass cls || has_ip_super_classes rec_clss' cls tys+-- --------------------- 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-  = False -- Includes things like (D []) where D is-          -- a Constraint-ranged family; #7785--hasIPSuperClasses :: Class -> [Type] -> Bool--- See Note [Local implicit parameters]-hasIPSuperClasses = has_ip_super_classes initIPRecTc--has_ip_super_classes :: RecTcChecker -> Class -> [Type] -> Bool-has_ip_super_classes rec_clss cls tys-  = any ip_ish (classSCSelIds cls)-  where-    -- Check that the type of a superclass determines its value-    -- sc_sel_id :: forall a b. C a b -> <superclass type>-    ip_ish sc_sel_id = is_ip_like_pred rec_clss $-                       classMethodInstTy sc_sel_id tys+  = Nothing -initIPRecTc :: RecTcChecker-initIPRecTc = setRecTcMaxBound 1 initRecTc+-- | Is a type an 'ExceptionContext'?+isExceptionContextTy :: Type -> Bool+isExceptionContextTy ty+  | Just tc <- tyConAppTyCon_maybe ty+  = tc `hasKey` exceptionContextTyConKey+  | otherwise+  = False  -- --------------------- CallStack predicates --------------------------------- @@ -306,19 +495,57 @@   | otherwise   = False +-- --------------------- couldBeIPLike and mightMentionIP  --------------------------+--                 See Note [Local implicit parameters] --- | Decomposes a predicate if it is an implicit parameter. Does not look in--- superclasses. See also [Local implicit parameters].-isIPPred_maybe :: Type -> Maybe (FastString, Type)-isIPPred_maybe ty =-  do (tc,[t1,t2]) <- splitTyConApp_maybe ty-     guard (isIPTyCon tc)-     x <- isStrLitTy t1-     return (x,t2)+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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The function isIPLikePred tells if this predicate, or any of its+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@@ -326,7 +553,7 @@    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 isIPLikePred checks whether this is an implicit parameter, or has+So couldBeIPLike checks whether this is an implicit parameter, or has a superclass that is an implicit parameter.  Several wrinkles@@ -367,21 +594,219 @@   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 isIPLikePred is used, and it's pretty+  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.  -}+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 *                                                                      * ********************************************************************* -} -isEvVar :: Var -> Bool-isEvVar var = isEvVarType (varType var)+isEvId :: Var -> Bool+isEvId var = isPredTy (varType var)  isDictId :: Id -> Bool isDictId id = isDictTy (varType id)+++{- *********************************************************************+*                                                                      *+                 scopedSort++       This function lives here becuase it uses isEvId+*                                                                      *+********************************************************************* -}++{- Note [ScopedSort]+~~~~~~~~~~~~~~~~~~~~+Consider++  foo :: Proxy a -> Proxy (b :: k) -> Proxy (a :: k2) -> ()++This function type is implicitly generalised over [a, b, k, k2]. These+variables will be Specified; that is, they will be available for visible+type application. This is because they are written in the type signature+by the user.++However, we must ask: what order will they appear in? In cases without+dependency, this is easy: we just use the lexical left-to-right ordering+of first occurrence. With dependency, we cannot get off the hook so+easily.++We thus state:++ * These variables appear in the order as given by ScopedSort, where+   the input to ScopedSort is the left-to-right order of first occurrence.++Note that this applies only to *implicit* quantification, without a+`forall`. If the user writes a `forall`, then we just use the order given.++ScopedSort is defined thusly (as proposed in #15743):+  * Work left-to-right through the input list, with a cursor.+  * If variable v at the cursor is depended on by any earlier variable w,+    move v immediately before the leftmost such w.++INVARIANT: The prefix of variables before the cursor form a valid telescope.++Note that ScopedSort makes sense only after type inference is done and all+types/kinds are fully settled and zonked.++-}++-- | Do a topological sort on a list of tyvars,+--   so that binders occur before occurrences+-- E.g. given  @[ a::k, k::Type, b::k ]@+-- it'll return a well-scoped list @[ k::Type, a::k, b::k ]@.+--+-- This is a deterministic sorting operation+-- (that is, doesn't depend on Uniques).+--+-- It is also meant to be stable: that is, variables should not+-- be reordered unnecessarily. This is specified in Note [ScopedSort]+-- See also Note [Ordering of implicit variables] in "GHC.Rename.HsType"++scopedSort :: [Var] -> [Var]+scopedSort = go [] []+  where+    go :: [Var] -- already sorted, in reverse order+       -> [TyCoVarSet] -- each set contains all the variables which must be placed+                       -- before the tv corresponding to the set; they are accumulations+                       -- of the fvs in the sorted Var's types++                       -- This list is in 1-to-1 correspondence with the sorted Vars+                       -- INVARIANT:+                       --   all (\tl -> all (`subVarSet` head tl) (tail tl)) (tails fv_list)+                       -- That is, each set in the list is a superset of all later sets.++       -> [Var] -- yet to be sorted+       -> [Var]+    go acc _fv_list [] = reverse acc+    go acc  fv_list (tv:tvs)+      = go acc' fv_list' tvs+      where+        (acc', fv_list') = insert tv acc fv_list++    insert :: Var           -- var to insert+           -> [Var]         -- sorted list, in reverse order+           -> [TyCoVarSet]  -- list of fvs, as above+           -> ([Var], [TyCoVarSet])   -- augmented lists+    -- Generally we put the new Var at the front of the accumulating list+    -- (leading to a stable sort) unless there is are reason to put it later.+    insert v []     []         = ([v], [tyCoVarsOfType (varType v)])+    insert v (a:as) (fvs:fvss)+      | (isTyVar v && isId a) ||          -- TyVars precede Ids+        (isEvId v && isId a && not (isEvId a)) || -- DictIds precede non-DictIds+        (v `elemVarSet` fvs)+          -- (a) put Ids after TyVars, and (b) respect dependencies+      , (as', fvss') <- insert v as fvss+      = (a:as', fvs `unionVarSet` fv_v : fvss')++      | otherwise  -- Put `v` at the front+      = (v:a:as, fvs `unionVarSet` fv_v : fvs : fvss)+      where+        fv_v = tyCoVarsOfType (varType v)++       -- lists not in correspondence+    insert _ _ _ = panic "scopedSort"++-- | Get the free vars of a type in scoped order+tyCoVarsOfTypeWellScoped :: Type -> [TyVar]+tyCoVarsOfTypeWellScoped = scopedSort . tyCoVarsOfTypeList++-- | Get the free vars of types in scoped order+tyCoVarsOfTypesWellScoped :: [Type] -> [TyVar]+tyCoVarsOfTypesWellScoped = scopedSort . tyCoVarsOfTypesList+++{- *********************************************************************+*                                                                      *+*                   Equality left-hand sides+*                                                                      *+********************************************************************* -}++-- | A 'CanEqLHS' is a type that can appear on the left of a canonical+-- equality: a type variable or /exactly-saturated/ type family application.+data CanEqLHS+  = TyVarLHS TyVar+  | TyFamLHS TyCon  -- ^ TyCon of the family+             [Type]   -- ^ Arguments, /exactly saturating/ the family++instance Outputable CanEqLHS where+  ppr (TyVarLHS tv)              = ppr tv+  ppr (TyFamLHS fam_tc fam_args) = ppr (mkTyConApp fam_tc fam_args)++-----------------------------------+-- | Is a type a canonical LHS? That is, is it a tyvar or an exactly-saturated+-- type family application?+-- Does not look through type synonyms.+canEqLHS_maybe :: Type -> Maybe CanEqLHS+canEqLHS_maybe xi+  | Just tv <- getTyVar_maybe xi+  = Just $ TyVarLHS tv++  | otherwise+  = canTyFamEqLHS_maybe xi++canTyFamEqLHS_maybe :: Type -> Maybe CanEqLHS+canTyFamEqLHS_maybe xi+  | Just (tc, args) <- tcSplitTyConApp_maybe xi+  , isTypeFamilyTyCon tc+  , args `lengthIs` tyConArity tc+  = Just $ TyFamLHS tc args++  | otherwise+  = Nothing++-- | Convert a 'CanEqLHS' back into a 'Type'+canEqLHSType :: CanEqLHS -> Type+canEqLHSType (TyVarLHS tv) = mkTyVarTy tv+canEqLHSType (TyFamLHS fam_tc fam_args) = mkTyConApp fam_tc fam_args++-- | Retrieve the kind of a 'CanEqLHS'+canEqLHSKind :: CanEqLHS -> Kind+canEqLHSKind (TyVarLHS tv) = tyVarKind tv+canEqLHSKind (TyFamLHS fam_tc fam_args) = piResultTys (tyConKind fam_tc) fam_args++-- | Are two 'CanEqLHS's equal?+eqCanEqLHS :: CanEqLHS -> CanEqLHS -> Bool+eqCanEqLHS (TyVarLHS tv1) (TyVarLHS tv2) = tv1 == tv2+eqCanEqLHS (TyFamLHS fam_tc1 fam_args1) (TyFamLHS fam_tc2 fam_args2)+  = tcEqTyConApps fam_tc1 fam_args1 fam_tc2 fam_args2+eqCanEqLHS _ _ = False+
GHC/Core/Reduction.hs view
@@ -1,6 +1,3 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE FlexibleContexts #-}  module GHC.Core.Reduction   (@@ -35,14 +32,16 @@ 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       ( setTyVarKind )+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, panic )+import GHC.Utils.Panic     ( assertPpr )  {- %************************************************************************@@ -349,33 +348,33 @@ -- -- Combines 'mkFunCo' and 'mkFunTy'. mkFunRedn :: Role-          -> AnonArgFlag+          -> FunTyFlag           -> ReductionN -- ^ multiplicity reduction           -> Reduction  -- ^ argument reduction           -> Reduction  -- ^ result reduction           -> Reduction-mkFunRedn r vis+mkFunRedn r af   (Reduction w_co w_ty)   (Reduction arg_co arg_ty)   (Reduction res_co res_ty)     = mkReduction-        (mkFunCo r w_co arg_co res_co)-        (mkFunTy vis w_ty arg_ty res_ty)+        (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 :: ArgFlag+mkForAllRedn :: ForAllTyFlag              -> TyVar              -> ReductionN -- ^ kind reduction              -> Reduction  -- ^ body reduction              -> Reduction mkForAllRedn vis tv1 (Reduction h ki') (Reduction co ty)   = mkReduction-      (mkForAllCo tv1 h co)-      (mkForAllTy tv2 vis ty)+      (mkForAllCo tv1 vis vis h co)+      (mkForAllTy (Bndr tv2 vis) ty)   where     tv2 = setTyVarKind tv1 ki' {-# INLINE mkForAllRedn #-}@@ -387,7 +386,7 @@ mkHomoForAllRedn :: [TyVarBinder] -> Reduction -> Reduction mkHomoForAllRedn bndrs (Reduction co ty)   = mkReduction-      (mkHomoForAllCos (binderVars bndrs) co)+      (mkHomoForAllCos bndrs co)       (mkForAllTys bndrs ty) {-# INLINE mkHomoForAllRedn #-} @@ -784,11 +783,11 @@ -- This function is only called in two locations, so the amount of code duplication -- should be rather reasonable despite the size of the function. simplifyArgsWorker :: HasDebugCallStack-                   => [TyCoBinder] -> Kind+                   => [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-                   -> [Role]       -- list of roles, r+                   -> 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@@ -810,10 +809,10 @@     orig_lc = emptyLiftingContext $ mkInScopeSet orig_fvs      go :: LiftingContext  -- mapping from tyvars to rewriting coercions-       -> [TyCoBinder]    -- Unsubsted binders of function's kind-       -> Kind        -- Unsubsted result kind of function (not a Pi-type)-       -> [Role]      -- Roles at which to rewrite these ...-       -> [Reduction] -- rewritten arguments, with their rewriting coercions+       -> [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@@ -826,10 +825,10 @@         kind_co | noFreeVarsOfType final_kind = MRefl                 | otherwise                   = MCo $ liftCoSubst Nominal lc final_kind -    go lc (binder:binders) inner_ki (role:roles) (arg_redn:arg_redns)+    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),-         -- tcTypeKind(ty) = tcTypeKind(arg).+         -- 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@@ -837,11 +836,11 @@          --          -- The bangs here have been observed to improve performance          -- significantly in optimized builds; see #18502-         let !kind_co = liftCoSubst Nominal lc (tyCoBinderType binder)+         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 <- tyCoBinderVar_maybe binder+             !new_lc | Just tv <- namedPiTyBinder_maybe binder                      = extendLiftingContextAndInScope lc tv casted_co                      | otherwise                      = lc@@ -859,7 +858,7 @@             (arg_cos, res_co)     = decomposePiCos co1 co1_kind unrewritten_tys             casted_args           = assertPpr (equalLength arg_redns arg_cos)                                               (ppr arg_redns $$ ppr arg_cos)-                                  $ zipWith3 mkCoherenceRightRedn roles arg_redns arg_cos+                                  $ 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@@ -874,19 +873,3 @@               = go zapped_lc bndrs new_inner roles casted_args         in           ArgsReductions redns_out (res_co `mkTransMCoR` res_co_out)--    go _ _ _ _ _ = panic-        "simplifyArgsWorker wandered into deeper water than usual"-           -- This debug information is commented out because leaving it in-           -- causes a ~2% increase in allocations in T9872d.-           -- That's independent of the analogous case in rewrite_args_fast-           -- in GHC.Tc.Solver.Rewrite:-           -- each of these causes a 2% increase on its own, so commenting them-           -- both out gives a 4% decrease in T9872d.-           {---             (vcat [ppr orig_binders,-                    ppr orig_inner_ki,-                    ppr (take 10 orig_roles), -- often infinite!-                    ppr orig_tys])-           -}
GHC/Core/RoughMap.hs view
@@ -1,7 +1,3 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE BangPatterns #-}- -- | 'RoughMap' is an approximate finite map data structure keyed on -- @['RoughMatchTc']@. This is useful when keying maps on lists of 'Type's -- (e.g. an instance head).@@ -13,6 +9,9 @@   , RoughMatchLookupTc(..)   , typeToRoughMatchLookupTc   , roughMatchTcToLookup+  , roughMatchTcs+  , roughMatchTcsLookup+  , instanceCantMatch      -- * RoughMap   , RoughMap@@ -37,11 +36,10 @@ 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.Misc-import Data.Bifunctor import GHC.Utils.Panic  {-@@ -106,8 +104,12 @@ KnownTc Int, KnownTc Char]`.  This explains the third clause of the mightMatch specification in Note [Simple Matching Semantics].-As soon as the the lookup key runs out, the remaining instances might match.+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@@ -135,6 +137,7 @@    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@@ -149,7 +152,7 @@ The potential matches is likely to be much smaller than the bag of potential unifiers due to the reasoning about rigid type variables described in Note [Matching a RoughMap]. On the other hand, the instances captured by the RML_NoKnownTC case can still potentially unify-with any instance (depending on the substituion of said rigid variable) so they can't be discounted+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. @@ -180,7 +183,7 @@   mightMatch []  []    = True   -- A perfectly sized match might match   mightMatch key []    = True   -- A shorter lookup key matches everything   mightMatch []  (_:_) = True   -- If the lookup key is longer, then still might match-                                -- Note [RoughMatch and beta reduction]+                                -- Note [RoughMap and beta reduction]   mightMatch (k:ks) (lk:lks) =     = case (k,lk) of          -- Standard case, matching on a specific known TyCon.@@ -222,20 +225,59 @@  -} +{- *********************************************************************+*                                                                      *+                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+  = 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+  | RML_NoKnownTc    -- ^ The position definitely doesn't match any KnownTc+  | RML_WildCard     -- ^ The position can match anything   deriving ( Data )  instance Outputable RoughMatchLookupTc where@@ -243,31 +285,55 @@     ppr RML_NoKnownTc = text "RML_NoKnownTC"     ppr RML_WildCard = text "_" -roughMatchTcToLookup :: RoughMatchTc -> RoughMatchLookupTc-roughMatchTcToLookup (RM_KnownTc n) = RML_KnownTc n-roughMatchTcToLookup RM_WildCard = RML_WildCard- instance Outputable RoughMatchTc where     ppr (RM_KnownTc nm) = text "KnownTc" <+> ppr nm     ppr RM_WildCard = text "OtherTc" +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-  | Just (ty', _) <- splitCastTy_maybe ty   = typeToRoughMatchLookupTc ty'-  | otherwise =-      case splitAppTys ty of+  -- 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 $! tyConName tc+          | 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 @@ -275,11 +341,23 @@ typeToRoughMatchTc ty   | Just (ty', _) <- splitCastTy_maybe ty   = typeToRoughMatchTc ty'   | Just (tc,_)   <- splitTyConApp_maybe ty-  , not (isTypeFamilyTyCon tc)              = assertPpr (isGenerativeTyCon tc Nominal) (ppr tc)-                                              RM_KnownTc $! tyConName tc+  , 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*@@ -288,15 +366,21 @@ -- insert [OtherTc] 2 -- lookup [OtherTc] == [1,2] -- @-data RoughMap a = RM { rm_empty   :: Bag a-                     , rm_known   :: DNameEnv (RoughMap a)-                        -- See Note [InstEnv determinism] in GHC.Core.InstEnv-                     , rm_unknown :: RoughMap a }-                | RMEmpty -- an optimised (finite) form of emptyRM-                          -- invariant: Empty RoughMaps are always represented with RMEmpty+data RoughMap a+  = RMEmpty -- An optimised (finite) form of emptyRM+            -- Invariant: Empty RoughMaps are always represented with RMEmpty -                deriving (Functor)+  | 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"@@ -315,7 +399,7 @@  -- | N.B. Returns a 'Bag' for matches, which allows us to avoid rebuilding all of the lists -- we find in 'rm_empty', which would otherwise be necessary due to '++' if we--- returned a list. We use a list for unifiers becuase the tail is computed lazily and+-- 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. --@@ -323,28 +407,37 @@ -- See Note [Matches vs Unifiers] lookupRM' :: [RoughMatchLookupTc] -> RoughMap a -> (Bag a -- Potential matches                                                    , [a]) -- Potential unifiers-lookupRM' _                  RMEmpty = (emptyBag, [])--- See Note [Simple Matching Semantics] about why we return everything when the lookup--- key runs out.-lookupRM' []                 rm      = let m = elemsRM rm-                                       in (listToBag m, m)+lookupRM' _ 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_unknown 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+  in ( rm_empty rm `unionBags` common_m `unionBags` m      , bagToList (rm_empty rm) ++ common_u ++ u)--- A RML_NoKnownTC does **not** match any KnownTC but can unify-lookupRM' (RML_NoKnownTc : tcs)  rm      = -  let (u_m, _u_u) = lookupRM' tcs (rm_unknown rm)-  in (rm_empty rm `unionBags` u_m -- Definitely don't match+-- 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  =-  let (m, u) = bimap unionManyBags concat (mapAndUnzip (lookupRM' tcs) (eltsDNameEnv $ rm_known rm))-      (u_m, u_u) = lookupRM' tcs (rm_unknown rm)-  in (rm_empty rm `unionBags` u_m `unionBags` m-     , bagToList (rm_empty rm) ++ u_u ++ u)+--  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@@ -352,7 +445,7 @@ unionRM a b =   RM { rm_empty = rm_empty a `unionBags` rm_empty b      , rm_known = plusDNameEnv_C unionRM (rm_known a) (rm_known b)-     , rm_unknown = rm_unknown a `unionRM` rm_unknown b+     , rm_wild = rm_wild a `unionRM` rm_wild b      }  @@ -360,17 +453,19 @@ insertRM k v RMEmpty =     insertRM k v $ RM { rm_empty = emptyBag                       , rm_known = emptyDNameEnv-                      , rm_unknown = emptyRM }+                      , 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_unknown = insertRM ks v (rm_unknown rm) }+    rm { rm_wild = insertRM ks v (rm_wild rm) }  filterRM :: (a -> Bool) -> RoughMap a -> RoughMap a filterRM _ RMEmpty = RMEmpty@@ -378,7 +473,7 @@     normalise $ RM {       rm_empty = filterBag pred (rm_empty rm),       rm_known = mapDNameEnv (filterRM pred) (rm_known rm),-      rm_unknown = filterRM pred (rm_unknown rm)+      rm_wild = filterRM pred (rm_wild rm)     }  -- | Place a 'RoughMap' in normal form, turning all empty 'RM's into@@ -399,13 +494,13 @@     normalise $ RM {       rm_empty = filterBag pred (rm_empty rm),       rm_known = alterDNameEnv (join . fmap (dropEmpty . filterMatchingRM pred tcs)) (rm_known rm) tc,-      rm_unknown = filterMatchingRM pred tcs (rm_unknown rm)+      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_unknown = filterMatchingRM pred tcs (rm_unknown rm)+      rm_wild = filterMatchingRM pred tcs (rm_wild rm)     }  dropEmpty :: RoughMap a -> Maybe (RoughMap a)@@ -421,7 +516,7 @@     -- N.B. local worker ensures that the loop can be specialised to the fold     -- function.     go z RMEmpty = z-    go z (RM{ rm_unknown = unk, rm_known = known, rm_empty = empty}) =+    go z (RM{ rm_wild = unk, rm_known = known, rm_empty = empty}) =       foldr         f         (foldDNameEnv@@ -442,7 +537,7 @@         f         (nonDetStrictFoldDNameEnv            (flip go)-           (go z (rm_unknown rm))+           (go z (rm_wild rm))            (rm_known rm)         )         (rm_empty rm)
GHC/Core/Rules.hs view
@@ -8,48 +8,63 @@ -- | Functions for collecting together and applying rewrite rules to a module. -- The 'CoreRule' datatype itself is declared elsewhere. module GHC.Core.Rules (-        -- ** Constructing+        -- ** Looking up rules+        lookupRule, matchExprs, ruleLhsIsMoreSpecific,++        -- ** RuleBase, RuleEnv+        RuleBase, RuleEnv(..), mkRuleEnv, emptyRuleEnv,+        updExternalPackageRules, addLocalRules, updLocalRules,         emptyRuleBase, mkRuleBase, extendRuleBaseList,-        pprRuleBase, extendRuleEnv,+        pprRuleBase,          -- ** Checking rule applications         ruleCheckProgram,          -- ** Manipulating 'RuleInfo' rules         extendRuleInfo, addRuleInfo,-        addIdSpecialisations,+        addIdSpecialisations, addRulesToId, +        -- ** RuleBase and RuleEnv+         -- * Misc. CoreRule helpers         rulesOfBinds, getRules, pprRulesForUser, -        lookupRule, mkRule, roughTopNames, initRuleOpts+        -- * Making rules+        mkRule, mkSpecRule, roughTopNames,+        ruleIsOrphan+     ) where  import GHC.Prelude -import GHC.Driver.Session      ( DynFlags, gopt, targetPlatform, homeUnitId_ )-import GHC.Driver.Flags--import GHC.Unit.Types    ( primUnitId, bignumUnitId ) import GHC.Unit.Module   ( Module ) import GHC.Unit.Module.Env+import GHC.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, exprsFreeVars, bindFreeVars-                          , rulesFreeVarsDSet, exprsOrphNames, exprFreeVarsList )+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, TCvSubst, extendTvSubst, extendCvSubst-   , mkEmptyTCvSubst, substTy, getTyVar_maybe )+   ( 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 )@@ -62,6 +77,7 @@ 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@@ -69,9 +85,10 @@ 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.Trace import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Constants (debugIsOn)@@ -129,7 +146,7 @@ * At the moment (c) is carried in a reader-monad way by the GHC.Core.Opt.Monad.   The HomePackageTable doesn't have a single RuleBase because technically   we should only be able to "see" rules "below" this module; so we-  generate a RuleBase for (c) by combing rules from all the modules+  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. @@ -146,7 +163,7 @@    In a single simplifier run new rules can be added into the EPS so it matters   to keep an up-to-date view of which rules have been loaded. For examples of-  where this went wrong and caused cryptic performance regressions seee+  where this went wrong and caused cryptic performance regressions   see T19790 and !6735.  @@ -156,33 +173,18 @@ *                                                                      * ************************************************************************ -A @CoreRule@ holds details of one rule for an @Id@, which+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}+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:-\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@@ -190,18 +192,23 @@ -- ^ Used to make 'CoreRule' for an 'Id' defined in the module being -- compiled. See also 'GHC.Core.CoreRule' mkRule this_mod is_auto is_local name act fn bndrs args rhs-  = Rule { ru_name = name, ru_fn = fn, ru_act = act,-           ru_bndrs = bndrs, ru_args = args,-           ru_rhs = rhs,-           ru_rough = roughTopNames args,-           ru_origin = this_mod,-           ru_orphan = orph,-           ru_auto = is_auto, ru_local = is_local }+  = 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 (exprsOrphNames args) fn+    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@@ -211,6 +218,40 @@     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:@@ -310,22 +351,144 @@   = 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]-getRules (RuleEnv { re_base = rule_base, re_visible_orphs = orphs }) fn-  = idCoreRules fn ++ concatMap imp_rules rule_base+--+-- 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-    imp_rules rb = filter (ruleIsVisible orphs) (lookupNameEnv rb (idName fn) `orElse` [])+    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:@@ -345,37 +508,28 @@        in the module defining the Id (when it's a LocalId), but        the rules are kept in the global RuleBase --************************************************************************-*                                                                      *-                RuleBase-*                                                                      *-************************************************************************--}---- RuleBase itself is defined in GHC.Core, along with CoreRule--emptyRuleBase :: RuleBase-emptyRuleBase = emptyNameEnv+ 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. -mkRuleBase :: [CoreRule] -> RuleBase-mkRuleBase rules = extendRuleBaseList emptyRuleBase rules+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. -extendRuleBaseList :: RuleBase -> [CoreRule] -> RuleBase-extendRuleBaseList rule_base new_guys-  = foldl' extendRuleBase rule_base new_guys+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. -extendRuleBase :: RuleBase -> CoreRule -> RuleBase-extendRuleBase rule_base rule-  = extendNameEnv_Acc (:) Utils.singleton rule_base (ruleIdName rule) rule+Essentially we use the identity: -extendRuleEnv :: RuleEnv -> RuleBase -> RuleEnv-extendRuleEnv (RuleEnv rules orphs) rb = (RuleEnv (rb:rules) orphs)+> lookupNameEnv n (plusNameEnv_C (++) rb1 rb2)+>   = lookupNameEnv n rb1 ++ lookupNameEnv n rb2 -pprRuleBase :: RuleBase -> SDoc-pprRuleBase rules = pprUFM rules $ \rss ->-  vcat [ pprRules (tidyRules emptyTidyEnv rs)-       | rs <- rss ]+The latter being more efficient as we don't construct an intermediate+map.+-}  {- ************************************************************************@@ -389,7 +543,8 @@ -- supplied rules to this instance of an application in a given -- context, returning the rule applied and the resulting expression if -- successful.-lookupRule :: RuleOpts -> InScopeEnv+lookupRule :: HasDebugCallStack+           => RuleOpts -> InScopeEnv            -> (Activation -> Bool)      -- When rule is active            -> Id -- Function head            -> [CoreExpr] -- Args@@ -398,8 +553,8 @@  -- See Note [Extra args in the target] -- See comments on matchRule-lookupRule opts rule_env@(in_scope,_) is_active fn args rules-  = -- pprTrace "matchRules" (ppr fn <+> ppr args $$ ppr rules ) $+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)@@ -419,7 +574,7 @@       = go ((r,mkTicks ticks e):ms) rs       | otherwise       = -- pprTrace "match failed" (ppr r $$ ppr args $$-        --   ppr [ (arg_id, unfoldingTemplate unf)+        --   ppr [ (arg_id, maybeUnfoldingTemplate unf)         --       | Var arg_id <- args         --       , let unf = idUnfolding arg_id         --       , isCheapUnfolding unf] )@@ -433,8 +588,8 @@  findBest _        _      (rule,ans)   [] = (rule,ans) findBest in_scope target (rule1,ans1) ((rule2,ans2):prs)-  | isMoreSpecific in_scope rule1 rule2 = findBest in_scope target (rule1,ans1) prs-  | isMoreSpecific in_scope rule2 rule1 = findBest in_scope target (rule2,ans2) prs+  | 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)))@@ -449,32 +604,51 @@   where     (fn,args) = target -isMoreSpecific :: InScopeSet -> CoreRule -> CoreRule -> Bool--- This tests if one rule is more specific than another--- We take the view that a BuiltinRule is less specific than--- anything else, because we want user-define rules to "win"--- In particular, class ops have a built-in rule, but we--- any user-specific rules to win---   eg (#4397)---      truncate :: (RealFrac a, Integral b) => a -> b---      {-# RULES "truncate/Double->Int" truncate = double2Int #-}---      double2Int :: Double -> Int---   We want the specific RULE to beat the built-in class-op rule-isMoreSpecific _        (BuiltinRule {}) _                = False-isMoreSpecific _        (Rule {})        (BuiltinRule {}) = True-isMoreSpecific in_scope (Rule { ru_bndrs = bndrs1, ru_args = args1 })-                        (Rule { ru_bndrs = bndrs2, ru_args = args2-                              , ru_name = rule_name2, ru_rhs = rhs2 })-  = isJust (matchN (full_in_scope, id_unfolding_fun)-                   rule_name2 bndrs2 args2 args1 rhs2)+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-   id_unfolding_fun _ = NoUnfolding     -- Don't expand in templates    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 [Extra args in the target]+{- 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@@ -502,7 +676,8 @@ -}  -------------------------------------matchRule :: RuleOpts -> InScopeEnv -> (Activation -> Bool)+matchRule :: HasDebugCallStack+          => RuleOpts -> InScopeEnv -> (Activation -> Bool)           -> Id -> [CoreExpr] -> [Maybe Name]           -> CoreRule -> Maybe CoreExpr @@ -522,11 +697,14 @@ --               [f,map g x]            -- tpl_args --               map (f.g) x)           -- rhs ----- Then the call: matchRule the_rule [e1,map e2 e3]+-- 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) ----- Any 'surplus' arguments in the input are simply put on the end--- of the output.+-- 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 })@@ -543,20 +721,9 @@   | otherwise = matchN rule_env rule_name tpl_vars tpl_args args rhs  --- | Initialize RuleOpts from DynFlags-initRuleOpts :: DynFlags -> RuleOpts-initRuleOpts dflags = RuleOpts-  { roPlatform                = targetPlatform dflags-  , roNumConstantFolding      = gopt Opt_NumConstantFolding dflags-  , roExcessRationalPrecision = gopt Opt_ExcessPrecision dflags-    -- disable bignum rules in ghc-prim and ghc-bignum itself-  , roBignumRules             = homeUnitId_ dflags /= primUnitId-                                && homeUnitId_ dflags /= bignumUnitId-  }-- ----------------------------------------matchN  :: InScopeEnv+matchN  :: HasDebugCallStack+        => InScopeEnv         -> RuleName -> [Var] -> [CoreExpr]         -> [CoreExpr] -> CoreExpr           -- ^ Target; can have more elements than the template         -> Maybe CoreExpr@@ -570,15 +737,24 @@ -- trailing ones, returning the result of applying the rule to a prefix -- of the actual arguments. -matchN (in_scope, id_unf) rule_name tmpl_vars tmpl_es target_es rhs+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)-                                          (mkEmptyTCvSubst in_scope) $+                                          (mkEmptySubst in_scope) $                                 tmpl_vars `zip` tmpl_vars1-              bind_wrapper = rs_binds rule_subst++        ; let bind_wrapper = rs_binds rule_subst                              -- Floated bindings; see Note [Matching lets]-       ; return (bind_wrapper $-                 mkLams tmpl_vars rhs `mkApps` matched_es) }++        ; return (bind_wrapper, matched_es) }   where     (init_rn_env, tmpl_vars1) = mapAccumL rnBndrL (mkRnEnv2 in_scope) tmpl_vars                   -- See Note [Cloning the template binders]@@ -588,8 +764,8 @@                    , rv_fltR  = mkEmptySubst (rnInScopeSet init_rn_env)                    , rv_unf   = id_unf } -    lookup_tmpl :: RuleSubst -> TCvSubst -> (InVar,OutVar) -> (TCvSubst, CoreExpr)-                   -- Need to return a RuleSubst solely for the benefit of mk_fake_ty+    lookup_tmpl :: 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@@ -618,12 +794,33 @@     unbound tmpl_var        = pprPanic "Template variable unbound in rewrite rule" $          vcat [ text "Variable:" <+> ppr tmpl_var <+> dcolon <+> ppr (varType tmpl_var)-              , text "Rule" <+> pprRuleName rule_name               , text "Rule bndrs:" <+> ppr tmpl_vars               , text "LHS args:" <+> ppr tmpl_es               , text "Actual args:" <+> ppr target_es ] +----------------------+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@@ -643,7 +840,7 @@    The rule looks like     forall (a::*) (d::Eq Char) (x :: Foo a Char).-         f (Foo a Char) d x = True+         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 :: *).@@ -733,17 +930,19 @@ see `init_menv` in `matchN`. -} -rvInScopeEnv :: RuleMatchEnv -> InScopeEnv-rvInScopeEnv renv = (rnInScopeSet (rv_lcl renv), rv_unf renv)- -- * The domain of the TvSubstEnv and IdSubstEnv are the template --   variables passed into the match. -- -- * The BindWrapper in a RuleSubst are the bindings floated out --   from nested matches; see the Let case of match, below ---data RuleSubst = RS { rs_tv_subst :: TvSubstEnv   -- Range is the-                    , rs_id_subst :: IdSubstEnv   --   template variables+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                     }@@ -756,28 +955,7 @@ emptyRuleSubst = RS { rs_tv_subst = emptyVarEnv, rs_id_subst = emptyVarEnv                     , rs_binds = \e -> e, rs_bndrs = [] } ------------------------match_exprs :: RuleMatchEnv -> RuleSubst-            -> [CoreExpr]       -- Templates-            -> [CoreExpr]       -- Targets-            -> Maybe RuleSubst--- If the targets are longer than templates, succeed, simply ignoring--- the leftover targets. This matters in the call in matchN.------ Precondition: corresponding elements of es1 and es2 have the same---               type, assumuing earlier elements match--- Example:  f :: forall v. v -> blah---   match_exprs [Type a, y::a] [Type Int, 3]--- Then, after matching Type a against Type Int,--- the type of (y::a) matches that of (3::Int)-match_exprs _ subst [] _-  = Just subst-match_exprs renv subst (e1:es1) (e2:es2)-  = do { subst' <- match renv subst e1 e2 MRefl-       ; match_exprs renv subst' es1 es2 }-match_exprs _ _ _ _ = Nothing - {- Note [Casts in the target] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ As far as possible we don't want casts in the target to get in the way of@@ -808,49 +986,83 @@ but the Simplifer pushes the casts in an application to to the right, if it can, so this doesn't really arise. -Note [Coercion arguments]-~~~~~~~~~~~~~~~~~~~~~~~~~-What if we have (f co) in the template, where the 'co' is a coercion-argument to f?  Right now we have nothing in place to ensure that a-coercion /argument/ in the template is a variable.  We really should,-perhaps by abstracting over that variable.--C.f. the treatment of dictionaries in GHC.HsToCore.Binds.decompseRuleLhs.--For now, though, we simply behave badly, by failing in match_co.-We really should never rely on matching the structure of a coercion-(which is just a proof).- Note [Casts in the template] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider the definition+This Note concerns `matchTemplateCast`.  Consider the definition   f x = e, and SpecConstr on call pattern   f ((e1,e2) |> co) -We'll make a RULE+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 ] -So here is the invariant:+This requires the rule-matcher to bind the coercion variable `g`.+That is Very Deeply Suspicious: -  In the template, in a cast (e |> co),-  the cast `co` is always a /variable/.+* 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. -Matching should bind that variable to an actual coercion, so that we-can use it in $sf.  So a Cast on the LHS (the template) calls-match_co, which succeeds when the template cast is a variable -- which-it always is.  That is why match_co has so few cases.+* 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 :: RuleMatchEnv+match :: HasDebugCallStack+      => RuleMatchEnv       -> RuleSubst              -- Substitution applies to template only       -> CoreExpr               -- Template       -> CoreExpr               -- Target@@ -908,14 +1120,7 @@     -- This is important: see Note [Cancel reflexive casts]  match renv subst (Cast e1 co1) e2 mco-  = -- See Note [Casts in the template]-    do { let co2 = case mco of-                     MRefl   -> mkRepReflCo (exprType e2)-                     MCo co2 -> co2-       ; subst1 <- match_co renv subst co1 co2-         -- If match_co succeeds, then (exprType e1) = (exprType e2)-         -- Hence the MRefl in the next line-       ; match renv subst1 e1 e2 MRefl }+  = matchTemplateCast renv subst e1 co1 e2 mco  ------------------------ Literals --------------------- match _ subst (Lit lit1) (Lit lit2) mco@@ -941,10 +1146,169 @@         -- 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 agressively ensure that if MCo is reflective, it really is MRefl.+-- 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 }@@ -973,7 +1337,16 @@  ------------------------  Lambdas --------------------- match renv subst (Lam x1 e1) e2 mco-  | Just (x2, e2', ts) <- exprIsLambda_maybe (rvInScopeEnv renv) (mkCastMCo 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 }@@ -1123,12 +1496,47 @@ and we really want to spot that the co/sym-co cancels out. Hence   * We keep an invariant that the MCoercion is always MRefl-    if the MCoercion is reflextve+    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@@ -1191,7 +1599,8 @@     not_captured fv = not (inRnEnvR rn_env fv)  -------------------------------------------match_var :: RuleMatchEnv+match_var :: HasDebugCallStack+          => RuleMatchEnv           -> RuleSubst           -> Var        -- Template           -> CoreExpr   -- Target@@ -1227,7 +1636,8 @@         -- template x, so we must rename first!  -------------------------------------------match_tmpl_var :: RuleMatchEnv+match_tmpl_var :: HasDebugCallStack+               => RuleMatchEnv                -> RuleSubst                -> Var                -- Template                -> CoreExpr           -- Target@@ -1236,9 +1646,11 @@ 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)+  -- 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 x) against (\y. y y)+                -- e.g. match forall a. (\x -> a) against (\y -> y)    | Just e1' <- lookupVarEnv id_subst v1'   = if eqCoreExpr e1' e2'@@ -1258,6 +1670,7 @@          -- because no free var of e2' is in the rnEnvR of the envt  ------------------------------------------+ match_ty :: RuleMatchEnv          -> RuleSubst          -> Type                -- Template@@ -1269,12 +1682,13 @@ --      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+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' }) }-  where-    tv_subst = rs_tv_subst subst  {- Note [Matching variable types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1497,41 +1911,59 @@           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-                       }-    results = unionManyBags (map (ruleCheckBind env) binds)-    line = text (replicate 20 '-')+                       , rc_in_scope  = emptyInScopeSet } -data RuleCheckEnv = RuleCheckEnv {-    rc_is_active :: Activation -> Bool,-    rc_id_unf  :: IdUnfoldingFun,-    rc_pattern :: String,-    rc_rules :: Id -> [CoreRule],-    rc_ropts :: RuleOpts-}+    results = go env binds -ruleCheckBind :: RuleCheckEnv -> CoreBind -> Bag SDoc+    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 _ r) = ruleCheck env r-ruleCheckBind env (Rec prs)    = unionManyBags [ruleCheck env r | (_,r) <- prs]+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)    = ruleCheckBind env bd `unionBags` ruleCheck env e-ruleCheck env (Lam _ e)     = ruleCheck env e-ruleCheck env (Case e _ _ as) = ruleCheck env e `unionBags`-                                unionManyBags [ruleCheck env r | Alt _ _ r <- as]+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)@@ -1547,7 +1979,7 @@   | 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)+    match rule = rc_pattern env `isPrefixOf` unpackFS (ruleName rule)  ruleAppCheck_help :: RuleCheckEnv -> Id -> [CoreExpr] -> [CoreRule] -> SDoc ruleAppCheck_help env fn args rules@@ -1555,8 +1987,9 @@     vcat [text "Expression:" <+> ppr (mkApps (Var fn) args),           vcat (map check_rule rules)]   where-    n_args = length args-    i_args = args `zip` [1::Int ..]+    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@@ -1567,7 +2000,7 @@         = text "Rule" <+> doubleQuotes (ftext name)      rule_info opts rule-        | Just _ <- matchRule opts (emptyInScopeSet, rc_id_unf env)+        | Just _ <- matchRule opts (ISE emptyInScopeSet (rc_id_unf env))                               noBlackList fn args rough_args rule         = text "matches (which is very peculiar!)" @@ -1586,10 +2019,8 @@           mismatches   = [i | (rule_arg, (arg,i)) <- rule_args `zip` i_args,                               not (isJust (match_fn rule_arg arg))] -          lhs_fvs = exprsFreeVars rule_args     -- Includes template tyvars           match_fn rule_arg arg = match renv emptyRuleSubst rule_arg arg MRefl                 where-                  in_scope = mkInScopeSet (lhs_fvs `unionVarSet` exprFreeVars arg)                   renv = RV { rv_lcl   = mkRnEnv2 in_scope                             , rv_tmpls = mkVarSet rule_bndrs                             , rv_fltR  = mkEmptySubst in_scope
+ GHC/Core/Rules/Config.hs view
@@ -0,0 +1,19 @@+module GHC.Core.Rules.Config where++import GHC.Prelude+import GHC.Platform++-- | Rule options+data RuleOpts = RuleOpts+   { roPlatform                :: !Platform+     -- ^ Target platform+   , roNumConstantFolding      :: !Bool+     -- ^ Enable constant folding through nested expressions.+     --+     -- See Note [Constant folding through nested expressions] in GHC.Core.Opt.ConstantFold+   , roExcessRationalPrecision :: !Bool+     -- ^ Cut down precision of Rational values to that of Float/Double if disabled+   , roBignumRules             :: !Bool+     -- ^ Enable rules for bignums+   }+
GHC/Core/Seq.hs view
@@ -104,10 +104,11 @@  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+                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 _ = ()
GHC/Core/SimpleOpt.hs view
@@ -8,7 +8,7 @@         SimpleOpts (..), defaultSimpleOpts,          -- ** Simple expression optimiser-        simpleOptPgm, simpleOptExpr, simpleOptExprWith,+        simpleOptPgm, simpleOptExpr, simpleOptExprNoInline, simpleOptExprWith,          -- ** Join points         joinPointBinding_maybe, joinPointBindings_maybe,@@ -27,31 +27,36 @@ import GHC.Core.FVs import GHC.Core.Unfold import GHC.Core.Unfold.Make-import GHC.Core.Make ( FloatBind(..) )+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.Core.DataCon-import GHC.Types.Demand( etaConvertDmdSig )+import GHC.Types.Demand( etaConvertDmdSig, topSubDmd ) import GHC.Types.Tickish-import GHC.Core.Coercion.Opt ( optCoercion, OptCoercionOpts (..) )-import GHC.Core.Type hiding ( substTy, extendTvSubst, extendCvSubst, extendTvSubstList-                            , isInScope, substTyVarBndr, cloneTyVarBndr )-import GHC.Core.Coercion hiding ( substCo, substCoVarBndr )+import GHC.Types.Basic+ import GHC.Builtin.Types import GHC.Builtin.Names-import GHC.Types.Basic+ import GHC.Unit.Module ( Module ) import GHC.Utils.Encoding import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Utils.Panic.Plain import GHC.Utils.Misc+ import GHC.Data.Maybe       ( orElse )+import GHC.Data.Graph.UnVar import Data.List (mapAccumL) import qualified Data.ByteString as BS @@ -84,20 +89,42 @@ 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_co_opts = OptCoercionOpts { optCoercionEnabled = False }+   , so_eta_red = False+   , so_inline  = True    }  simpleOptExpr :: HasDebugCallStack => SimpleOpts -> CoreExpr -> CoreExpr@@ -129,17 +156,23 @@   = -- pprTrace "simpleOptExpr" (ppr init_subst $$ ppr expr)     simpleOptExprWith opts 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.-        --+    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@@ -180,19 +213,20 @@ type SimpleClo = (SimpleOptEnv, InExpr)  data SimpleOptEnv-  = SOE { soe_co_opt_opts :: !OptCoercionOpts-             -- ^ Options for the coercion optimiser--        , soe_uf_opts :: !UnfoldingOpts-             -- ^ Unfolding options+  = SOE { soe_opts :: {-# UNPACK #-} !SimpleOpts+             -- ^ Simplifier options -        , soe_inl   :: IdEnv SimpleClo+        , 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@@ -202,45 +236,55 @@                    <+> text "}"  emptyEnv :: SimpleOpts -> SimpleOptEnv-emptyEnv opts = SOE-   { soe_inl         = emptyVarEnv-   , soe_subst       = emptySubst-   , soe_co_opt_opts = so_co_opts opts-   , soe_uf_opts     = so_uf_opts opts-   }+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 = zapSubstEnv subst }+  = env { soe_inl = emptyVarEnv, soe_subst = zapSubst 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) }+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 :: SimpleOptEnv -> SimpleClo -> OutExpr-simple_opt_clo env (e_env, e)-  = simple_opt_expr (soeSetInScope env e_env) e+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 :: HasCallStack => SimpleOptEnv -> InExpr -> OutExpr+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     = substInScope subst-    in_scope_env = (in_scope, simpleUnfoldingFun)+    in_scope     = substInScopeSet subst+    in_scope_env = ISE in_scope alwaysActiveUnfoldingFun      ---------------     go (Var v)        | Just clo <- lookupVarEnv (soe_inl env) v-       = simple_opt_clo env clo+       = 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     (substTy subst ty)+    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)@@ -251,7 +295,6 @@      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'         -- We don't need to be concerned about floats when looking for coerce.@@ -261,9 +304,9 @@           _       -> foldr wrapLet (simple_opt_expr env' rhs) mb_prs             where               (env', mb_prs) = mapAccumL (simple_out_bind NotTopLevel) env $-                               zipEqual "simpleOptExpr" bs es+                               zipEqual bs es -         -- Note [Getting the map/coerce RULE to work]+         -- See Note [Getting the map/coerce RULE to work]       | isDeadBinder b       , [Alt DEFAULT _ rhs] <- as       , isCoVarType (varType b)@@ -273,14 +316,14 @@       = go rhs        | otherwise-      = Case e' b' (substTy subst ty)+      = 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 (soe_co_opt_opts env) (getTCvSubst subst) co+    go_co co = optCoercion (so_co_opts (soe_opts env)) subst co      ----------------------     go_alt env (Alt con bndrs rhs)@@ -290,13 +333,17 @@      ----------------------     -- 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-       | Just etad_e <- tryEtaReduce bs e' = etad_e-       | otherwise                         = mkLams 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@@ -316,13 +363,15 @@  simple_app env (Var v) as   | Just (env', e) <- lookupVarEnv (soe_inl env) v-  = simple_app (soeSetInScope env env') e as+  = simple_app (soeSetInScope (soeInScope env) env') e as    | let unf = idUnfolding v-  , isCompulsoryUnfolding (idUnfolding v)+  , isCompulsoryUnfolding unf   , isAlwaysActive (idInlineActivation v)-    -- See Note [Unfold compulsory unfoldings in LHSs]-  = simple_app (soeZapSubst env) (unfoldingTemplate unf) as+    -- 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@@ -343,8 +392,19 @@     n_args = length as      do_beta env (Lam b body) (a:as)-      | (env', mb_pr) <- simple_bind_pair env b Nothing a NotTopLevel-      = wrapLet mb_pr $ do_beta env' body 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 @@ -372,12 +432,21 @@ 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+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)@@ -390,12 +459,13 @@     (env', mb_pr) = simple_bind_pair env b' Nothing (env,r') top_level  simple_opt_bind env (Rec prs) top_level-  = (env'', res_bind)+  = (env2, 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')+    (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@@ -412,16 +482,16 @@     -- (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 })+simple_bind_pair env@(SOE { soe_inl = inl_env, soe_subst = subst, soe_opts = opts })                  in_bndr mb_out_bndr clo@(rhs_env, in_rhs)                  top_level   | Type ty <- in_rhs        -- let a::* = TYPE ty in <body>-  , let out_ty = substTy (soe_subst rhs_env) ty+  , 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 (soe_co_opt_opts env) (getTCvSubst (soe_subst rhs_env)) co+  , 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) @@ -438,21 +508,23 @@     stable_unf = isStableUnfolding (idUnfolding in_bndr)     active     = isAlwaysActive (idInlineActivation in_bndr)     occ        = idOccInfo in_bndr+    in_scope   = substInScopeSet subst -    out_rhs | Just join_arity <- isJoinId_maybe in_bndr+    out_rhs | JoinPoint join_arity <- idJoinPointHood in_bndr             = simple_join_rhs join_arity             | otherwise-            = simple_opt_clo env clo+            = 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 env rhs_env+        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]@@ -460,14 +532,27 @@        | 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+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@@ -491,13 +576,14 @@                      -> InId -> Maybe OutId -> OutExpr                      -> OccInfo -> Bool -> Bool -> TopLevelFlag                      -> (SimpleOptEnv, Maybe (OutVar, OutExpr))-simple_out_bind_pair env in_bndr mb_out_bndr out_rhs+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 (soe_subst env) in_bndr out_rhs }+  = ( env' { soe_subst = extendIdSubst subst in_bndr out_rhs }     , Nothing)    | otherwise@@ -510,6 +596,7 @@      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@@ -543,6 +630,53 @@ 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@@ -628,7 +762,7 @@     Subst in_scope id_subst tv_subst cv_subst = subst      id1    = uniqAway in_scope old_id-    id2    = updateIdTypeAndMult (substTy subst) id1+    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@@ -653,7 +787,7 @@  | otherwise        = lazySetIdInfo new_bndr new_info  where    subst    = soe_subst env-   uf_opts  = soe_uf_opts env+   uf_opts  = so_uf_opts (soe_opts env)    old_info = idInfo old_bndr     -- Add back in the rules and unfolding which were@@ -672,15 +806,11 @@                  | otherwise                  = unfolding_from_rhs -   unfolding_from_rhs = mkUnfolding uf_opts InlineRhs+   unfolding_from_rhs = mkUnfolding uf_opts VanillaSrc                                     (isTopLevel top_level)                                     False -- may be bottom or not-                                    new_rhs--simpleUnfoldingFun :: IdUnfoldingFun-simpleUnfoldingFun id-  | isAlwaysActive (idInlineActivation id) = idUnfolding id-  | otherwise                              = noUnfolding+                                    False -- Not a join point+                                    new_rhs Nothing  wrapLet :: Maybe (Id,CoreExpr) -> CoreExpr -> CoreExpr wrapLet Nothing      body = body@@ -706,8 +836,8 @@ When inlining 'foo' in 'bar' we want the let-binding for 'inner' to remain visible until Phase 1 -Note [Unfold compulsory unfoldings in LHSs]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+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@@ -734,35 +864,39 @@  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+too.  Achieving all this is surprisingly tricky: -  forall a b (dict :: Coercible * a b).-    map @a @b (\(x :: a) -> case dict of-      MkCoercible (co :: a ~R# b) -> x |> co) = ...+(MC1) We must compulsorily unfold MkAge to a cast.+      See Note [Compulsory newtype unfolding] in GHC.Types.Id.Make -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:+(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) = ... -  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) = ...+  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: -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 (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) = ... -  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 ...+  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 -Now, we need simpleOptExpr to fix this up. It does so by taking three-separate actions:+    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.@@ -774,6 +908,10 @@      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. @@ -988,7 +1126,7 @@    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 -> ...+   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'.)@@ -999,6 +1137,45 @@  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@@ -1079,7 +1256,7 @@ This Note exists solely to document the problem. -} -data ConCont = CC [CoreExpr] Coercion+data ConCont = CC [CoreExpr] MCoercion                   -- Substitution already applied  -- | Returns @Just ([b1..bp], dc, [t1..tk], [x1..xn])@ if the argument@@ -1100,8 +1277,8 @@ exprIsConApp_maybe :: HasDebugCallStack                    => InScopeEnv -> CoreExpr                    -> Maybe (InScopeSet, [FloatBind], DataCon, [Type], [CoreExpr])-exprIsConApp_maybe (in_scope, id_unf) expr-  = go (Left in_scope) [] expr (CC [] (mkRepReflCo (exprType expr)))+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"@@ -1114,23 +1291,42 @@     go subst floats (Tick t expr) cont        | not (tickishIsCode t) = go subst floats expr cont -    go subst floats (Cast expr co1) (CC args co2)+    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]-       = case m_co1' of-           MCo co1' -> go subst floats expr (CC args' (co1' `mkTransCo` co2))-           MRefl    -> go subst floats expr (CC args' co2)+       = go subst floats expr (CC args' (m_co1' `mkTransMCo` m_co2)) -    go subst floats (App fun arg) (CC args co)-       = go subst floats fun (CC (subst_expr subst arg : args) co)+    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) co)-       | exprIsTrivial arg          -- Don't duplicate stuff!-       = go (extend subst bndr arg) floats body (CC args co)+    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 co)+         in go subst' (float:floats) body (CC args mco)      go subst floats (Let (NonRec bndr rhs) expr) cont        | not (isJoinId bndr)@@ -1141,33 +1337,38 @@          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-          scrut'           = subst_expr subst scrut           (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 (substInScope sub))+       = go (Left (substInScopeSet sub))             floats             (lookupIdSubst sub v)             cont -    go (Left in_scope) floats (Var fun) cont@(CC args co)+    go (Left in_scope) floats (Var fun) cont@(CC args mco)          | Just con <- isDataConWorkId_maybe fun         , count isValArg args == idArity fun-        = succeedWith in_scope floats $-          pushCoDataCon con args co+        , (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]).-        | isDataConWrapId fun-        , let rhs = uf_tmpl (realIdUnfolding fun)+        | Just rhs <- dataConWrapUnfolding_maybe fun         = go (Left in_scope) floats rhs cont          -- Look through dictionary functions; see Note [Unfolding DFuns]@@ -1180,7 +1381,7 @@               -- 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) co+          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,@@ -1196,9 +1397,9 @@         | (fun `hasKey` unpackCStringIdKey) ||           (fun `hasKey` unpackCStringUtf8IdKey)         , [arg]              <- args-        , Just (LitString str) <- exprIsLiteral_maybe (in_scope, id_unf) arg+        , Just (LitString str) <- exprIsLiteral_maybe ise arg         = succeedWith in_scope floats $-          dealWithStringLiteral fun str co+          dealWithStringLiteral fun str mco         where           unfolding = id_unf fun           extend_in_scope unf_fvs@@ -1220,6 +1421,13 @@     ----------------------------     -- 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 @@ -1239,17 +1447,49 @@     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 -> Coercion+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 co =+dealWithStringLiteral fun str mco =   case utf8UnconsByteString str of-    Nothing -> pushCoDataCon nilDataCon [Type charTy] co+    Nothing -> pushCoDataCon nilDataCon [Type charTy] mco     Just (char, charTail) ->       let char_expr = mkConApp charDataCon [mkCharLit char]           -- In singleton strings, just add [] instead of unpackCstring# ""#.@@ -1258,9 +1498,30 @@                    else App (Var fun)                             (Lit (LitString charTail)) -      in pushCoDataCon consDataCon [Type charTy, char_expr, rest] co+      in pushCoDataCon consDataCon [Type charTy, char_expr, rest] mco  {-+Note [Case elim in exprIsConApp_maybe]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have+   data K a = MkK !a++   $WMkK x = case x of y -> K y   -- Wrapper for MkK++   ...case $WMkK v of K w -> <rhs>++We call `exprIsConApp_maybe` on ($WMkK v); we inline the wrapper+and beta-reduce, so we get to+   exprIsConApp_maybe (case v of y -> K y)++So we may float the case, and end up with+   case v of y -> <rhs>[y/w]++But if `v` is already evaluated, the next run of the Simplifier will+eliminate the case, and we may then make more progress with <rhs>.+Better to do it in one iteration.  Hence the `do_case_elim`+check in `exprIsConApp_maybe`.+ Note [Unfolding DFuns] ~~~~~~~~~~~~~~~~~~~~~~ DFuns look like@@ -1285,7 +1546,7 @@ -- 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@(_, id_unf) e+exprIsLiteral_maybe env@(ISE _ id_unf) e   = case e of       Lit l     -> Just l       Tick _ e' -> exprIsLiteral_maybe env e' -- dubious?@@ -1315,14 +1576,14 @@     = Just (x, e, [])  -- Still straightforward: Ticks that we can float out of the way-exprIsLambda_maybe (in_scope_set, id_unf) (Tick t e)+exprIsLambda_maybe ise (Tick t e)     | tickishFloatable t-    , Just (x, e, ts) <- exprIsLambda_maybe (in_scope_set, id_unf) e+    , Just (x, e, ts) <- exprIsLambda_maybe ise 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+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)@@ -1333,7 +1594,7 @@       res  -- Another attempt: See if we find a partial unfolding-exprIsLambda_maybe (in_scope_set, id_unf) e+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@@ -1341,7 +1602,7 @@     -- 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 (in_scope_set, id_unf) e'+    , 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
GHC/Core/Stats.hs view
@@ -98,7 +98,7 @@ coStats co = zeroCS { cs_co = coercionSize co }  coreBindsSize :: [CoreBind] -> Int--- We use coreBindStats for user printout+-- 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)
GHC/Core/Subst.hs view
@@ -6,8 +6,6 @@ Utility functions on @Core@ syntax -} --{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} module GHC.Core.Subst (         -- * Main data types         Subst(..), -- Implementation exported for supercompiler's Renaming.hs only@@ -15,22 +13,25 @@          -- ** Substituting into expressions and related types         deShadowBinds, substRuleInfo, substRulesForImportedIds,-        substTy, substCo, substExpr, substExprSC, substBind, substBindSC,+        substTyUnchecked, substCo, substExpr, substExprSC, substBind, substBindSC,         substUnfolding, substUnfoldingSC,-        lookupIdSubst, substIdType, substIdOcc,+        lookupIdSubst, lookupIdSubst_maybe, substIdType, substIdOcc,         substTickish, substDVarSet, substIdInfo,          -- ** Operations on substitutions-        emptySubst, mkEmptySubst, mkSubst, mkOpenSubst, substInScope, isEmptySubst,+        emptySubst, mkEmptySubst, mkTCvSubst, mkOpenSubst, isEmptySubst,         extendIdSubst, extendIdSubstList, extendTCvSubst, extendTvSubstList,-        extendSubst, extendSubstList, extendSubstWithVar, zapSubstEnv,-        extendInScope, extendInScopeList, extendInScopeIds,-        isInScope, setInScope, getTCvSubst, extendTvSubst, extendCvSubst,-        delBndr, delBndrs,+        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 @@ -40,17 +41,14 @@ import GHC.Core.FVs import GHC.Core.Seq import GHC.Core.Utils-import qualified GHC.Core.Type as Type-import qualified GHC.Core.Coercion as Coercion          -- We are defining local versions-import GHC.Core.Type hiding-   ( substTy, extendTvSubst, extendCvSubst, extendTvSubstList-   , isInScope, substTyVarBndr, cloneTyVarBndr )-import GHC.Core.Coercion hiding ( substCo, substCoVarBndr )+import GHC.Core.Type hiding ( substTy )+import GHC.Core.Coercion+    ( tyCoFVsOfCo, mkCoVarCo, substCoVarBndr )  import GHC.Types.Var.Set-import GHC.Types.Var.Env+import GHC.Types.Var.Env as InScopeSet import GHC.Types.Id import GHC.Types.Name     ( Name ) import GHC.Types.Var@@ -64,12 +62,10 @@ import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Utils.Panic.Plain +import Data.Functor.Identity (Identity (..)) import Data.List (mapAccumL) -- {- ************************************************************************ *                                                                      *@@ -78,37 +74,12 @@ ************************************************************************ -} --- | A substitution environment, containing 'Id', 'TyVar', and 'CoVar'--- substitutions.------ Some invariants apply to how you use the substitution:------ 1. Note [The substitution invariant] in "GHC.Core.TyCo.Subst"------ 2. Note [Substitutions apply only once] in "GHC.Core.TyCo.Subst"-data Subst-  = Subst InScopeSet  -- Variables 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 TyCoSubst Note [The substitution 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]+Note [Extending the IdSubstEnv] ~~~~~~~~~~~~~~~~~~~~~~~~~~-For a core Subst, which binds Ids as well, we make a different choice for Ids-than we do for TyVars.+We make a different choice for Ids than we do for TyVars. -For TyVars, see Note [Extending the TCvSubst] in GHC.Core.TyCo.Subst.+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@@ -158,31 +129,13 @@   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 "GHC.Core.TyCo.Subst" Note [The substitution 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+-- 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]@@ -193,47 +146,31 @@   = 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 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--- "GHC.Core.TyCo.Subst" 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---- | 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 satisfies--- "GHC.Core.TyCo.Subst" 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)- -- | 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 :: HasDebugCallStack => Subst -> Var -> CoreArg -> Subst extendSubst subst var arg   = case arg of-      Type ty     -> assert (isTyVar var) $ extendTvSubst subst var ty-      Coercion co -> assert (isCoVar var) $ extendCvSubst subst var co-      _           -> assert (isId    var) $ extendIdSubst subst var arg+      Type ty     -> 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@@ -249,16 +186,24 @@ 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-  | not (isLocalId v) = Var 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 Subst]+        -- Vital! See Note [Extending the IdSubstEnv]         -- If v isn't in the InScopeSet, we panic, because-        -- it's a bad bug and we reallly want to know+        -- 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)@@ -281,44 +226,7 @@                                    (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: 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 "<InScope =" <+> in_scope_doc-        $$ text " IdSubst   =" <+> ppr ids-        $$ text " TvSubst   =" <+> ppr tvs-        $$ text " CvSubst   =" <+> ppr cvs-         <> char '>'-    where-    in_scope_doc = pprVarSet (getInScopeVars in_scope) (braces . fsep . map ppr)- {- ************************************************************************ *                                                                      *@@ -333,22 +241,21 @@ -- their canonical representatives in the in-scope set substExprSC subst orig_expr   | isEmptySubst subst = orig_expr-  | otherwise          = -- pprTrace "enter subst-expr" (doc $$ ppr orig_expr) $-                         substExpr 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 Subst]+-- 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 (substTy subst ty)+    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)@@ -368,7 +275,7 @@                        where                          (subst', bind') = substBind subst bind -    go (Case scrut bndr ty alts) = Case (go scrut) bndr' (substTy subst ty) (map (go_alt subst') alts)+    go (Case scrut bndr ty alts) = Case (go scrut) bndr' (substTyUnchecked subst ty) (map (go_alt subst') alts)                                  where                                  (subst', bndr') = substBndr subst bndr @@ -444,15 +351,18 @@   | 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+substBndrs :: Traversable f => Subst -> f Var -> (Subst, f Var)+substBndrs = mapAccumL substBndr+{-# INLINE substBndrs #-}  -- | Substitute in a mutually recursive group of 'Id's-substRecBndrs :: Subst -> [Id] -> (Subst, [Id])+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@@ -462,11 +372,11 @@  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)+    (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 (substTy subst) id1+        | otherwise      = updateIdTypeAndMult (substTyUnchecked subst) id1      old_ty = idType old_id     old_w = idMult old_id@@ -476,17 +386,19 @@         -- 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+    !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)+    !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 Subst]+        -- See Note [Extending the IdSubstEnv]         -- it's /not/ necessary to check mb_new_info and no_type_change  {-@@ -496,12 +408,14 @@  -- | 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)@@ -512,6 +426,11 @@ 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@@ -519,26 +438,31 @@  -- | 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)+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 (in_scope `extendInScopeSet` new_id) new_idvs tvs new_cvs, new_id)+  = (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_idvs, new_cvs) | isCoVar old_id = (idvs, extendVarEnv cvs old_id (mkCoVarCo new_id))-                        | otherwise      = (extendVarEnv idvs old_id (Var new_id), cvs)+    !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)  {- ************************************************************************@@ -546,41 +470,8 @@                 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 -> CoVar -> (Subst, CoVar)-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 'GHC.Core.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 :: HasCallStack => Subst -> Coercion -> Coercion-substCo subst co = Coercion.substCo (getTCvSubst subst) co- {- ************************************************************************ *                                                                      *@@ -594,16 +485,17 @@   | (isEmptyVarEnv tv_env && isEmptyVarEnv cv_env)     || (noFreeVarsOfType old_ty && noFreeVarsOfType old_w) = id   | otherwise   =-      updateIdTypeAndMult (substTy subst) id+      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  = varMult 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@@ -634,7 +526,7 @@     args'           = map (substExpr subst') args  substUnfolding subst unf@(CoreUnfolding { uf_tmpl = tmpl, uf_src = src })-        -- Retain an InlineRule!+  -- Retain stable unfoldings   | not (isStableSource src)  -- Zap an unstable unfolding, to save substitution work   = NoUnfolding   | otherwise                 -- But keep a stable one!@@ -707,14 +599,16 @@      = tyCoFVsOfCo fv_co (const True) emptyVarSet $! acc      | otherwise      , let fv_expr = lookupIdSubst subst fv-     = expr_fvs fv_expr isLocalVar emptyVarSet $! acc+     = 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 n ids)-   = Breakpoint ext n (map do_one ids)+substTickish subst (Breakpoint ext bid ids)+   = Breakpoint ext bid (mapMaybe do_one ids)  where-    do_one = getIdFromTrivialExpr . lookupIdSubst subst+    do_one = getIdFromTrivialExpr_maybe . lookupIdSubst subst+ substTickish _subst other = other  {- Note [Substitute lazily]@@ -767,8 +661,15 @@  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.Coverage.mkTickish.+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. -}  {-
GHC/Core/Tidy.hs view
@@ -8,21 +8,20 @@ -}  -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} module GHC.Core.Tidy (-        tidyExpr, tidyRules, tidyUnfolding, tidyCbvInfoTop+        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.Core.Coercion ( tidyCo ) import GHC.Types.Var import GHC.Types.Var.Env import GHC.Types.Unique (getUnique)@@ -31,10 +30,10 @@ import GHC.Types.Name.Set import GHC.Types.SrcLoc import GHC.Types.Tickish+ import GHC.Data.Maybe import GHC.Utils.Misc import Data.List (mapAccumL)--- import GHC.Utils.Trace import GHC.Utils.Outputable import GHC.Types.RepType (typePrimRep) import GHC.Utils.Panic@@ -84,7 +83,7 @@ -- This means the code generator can get the full calling convention by only looking at the function -- itself without having to inspect the RHS. ----- The actual logic is in tidyCbvInfo and takes:+-- The actual logic is in computeCbvInfo and takes: -- * The function id -- * The functions rhs -- And gives us back the function annotated with the marks.@@ -117,8 +116,7 @@  -- See Note [CBV Function Ids] tidyCbvInfoLocal :: HasDebugCallStack => Id -> CoreExpr -> Id-tidyCbvInfoLocal id rhs-  | otherwise = computeCbvInfo id rhs+tidyCbvInfoLocal id rhs = computeCbvInfo id rhs  -- | For a binding we: -- * Look at the args@@ -135,9 +133,9 @@                -> Id -- computeCbvInfo fun_id rhs = fun_id computeCbvInfo fun_id rhs-  | (isWorkerLike || isJoinId fun_id) &&  (valid_unlifted_worker val_args)-  =-    -- pprTrace "computeCbvInfo"+  | 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) $$ @@ -146,31 +144,48 @@     --     text "cbv_marks" <+> ppr cbv_marks $$     --     text "out_id" <+> ppr cbv_bndr $$     --     ppr rhs)-      cbv_bndr+    cbv_bndr+   | otherwise = fun_id   where-    val_args = filter isId . fst $ collectBinders rhs-    cbv_marks =-      -- CBV marks are only set during tidy so none should be present already.-      assertPpr (maybe True null $ idCbvMarks_maybe fun_id) (ppr fun_id <+> (ppr $ idCbvMarks_maybe fun_id) $$ ppr rhs) $-      map mkMark val_args-    cbv_bndr-        | valid_unlifted_worker val_args-        , any isMarkedCbv cbv_marks-        -- seqList to avoid retaining the original rhs-        = cbv_marks `seqList` setIdCbvMarks fun_id cbv_marks-        | otherwise =-          -- pprTraceDebug "tidyCbvInfo: Worker seems to take unboxed tuple/sum types!" (ppr fun_id <+> ppr rhs)-          asNonWorkerLikeId fun_id-    -- We don't set CBV marks on functions which take unboxed tuples or sums as arguments.-    -- Doing so would require us to compute the result of unarise here in order to properly determine-    -- argument positions at runtime.-    -- In practice this doesn't matter much. Most "interesting" functions will get a W/W split which will eliminate-    -- unboxed tuple arguments, and unboxed sums are rarely used. But we could change this in the future and support+    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)@@ -188,7 +203,6 @@       , not (isDeadEndId fun_id) = MarkedCbv       | otherwise = NotMarkedCbv -    isWorkerLike = isWorkerLikeId fun_id  ------------  Expressions  -------------- tidyExpr :: TidyEnv -> CoreExpr -> CoreExpr@@ -221,8 +235,8 @@  ------------  Tickish  -------------- tidyTickish :: TidyEnv -> CoreTickish -> CoreTickish-tidyTickish env (Breakpoint ext ix ids)-  = Breakpoint ext ix (map (tidyVarOcc env) ids)+tidyTickish env (Breakpoint ext bid ids)+  = Breakpoint ext bid (map (tidyVarOcc env) ids) tidyTickish _   other_tickish       = other_tickish  ------------  Rules  --------------@@ -339,40 +353,44 @@         new_info = vanillaIdInfo                     `setOccInfo`        occInfo old_info                     `setArityInfo`      arityInfo old_info-                    `setDmdSigInfo` zapDmdEnvSig (dmdSigInfo old_info)+                    `setDmdSigInfo`     zapDmdEnvSig (dmdSigInfo old_info)                     `setDemandInfo`     demandInfo old_info                     `setInlinePragInfo` inlinePragInfo old_info                     `setUnfoldingInfo`  new_unf          old_unf = realUnfoldingInfo old_info-        new_unf | isStableUnfolding old_unf = tidyUnfolding rec_tidy_env old_unf old_unf-                | otherwise                 = trimUnfolding old_unf-                                              -- See Note [Preserve evaluatedness]+        new_unf = tidyNestedUnfolding rec_tidy_env old_unf      in     ((tidy_env', var_env'), id') }  ------------ Unfolding  ---------------tidyUnfolding :: TidyEnv -> Unfolding -> Unfolding -> Unfolding-tidyUnfolding tidy_env df@(DFunUnfolding { df_bndrs = bndrs, df_args = args }) _+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 -tidyUnfolding tidy_env-              unf@(CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src })-              unf_from_rhs+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_is_value,-    -- uf_is_conlike, ... fields may retain a reference to the-    -- pre-tidied expression forever (GHC.CoreToIface doesn't look at them)+            -- 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) -  | otherwise-  = unf_from_rhs-  where seqIt unf = seqUnfolding unf `seq` unf-tidyUnfolding _ unf _ = unf     -- NoUnfolding or OtherCon+  -- 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] ~~~~~~~~~~~~~~~~~~@@ -382,7 +400,7 @@    (a) To make printing tidy core nicer -  (b) Because we tidy RULES and InlineRules, which may then propagate+  (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@@ -413,7 +431,7 @@ Not all OneShotInfo is determined by a compiler analysis; some is added by a call of GHC.Exts.oneShot, which is then discarded before the end of the optimisation pipeline, leaving only the OneShotInfo on the lambda. Hence we-must preserve this info in inlinings. See Note [The oneShot function] in GHC.Types.Id.Make.+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. -}
+ GHC/Core/TyCo/Compare.hs view
@@ -0,0 +1,853 @@+-- (c) The University of Glasgow 2006+-- (c) The GRASP/AQUA Project, Glasgow University, 1998++{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MagicHash #-}++-- | Type equality and comparison+module GHC.Core.TyCo.Compare (++    -- * Type equality+    eqType, eqTypeIgnoringMultiplicity, eqTypeX, eqTypes,+    eqVarBndrs,++    pickyEqType, tcEqType, tcEqKind, tcEqTypeNoKindCheck,+    tcEqTyConApps, tcEqTyConAppArgs,+    mayLookIdentical,++    -- * Type comparison+    nonDetCmpType,++   -- * Visiblity comparision+   eqForAllVis, cmpForAllVis++   ) where++import GHC.Prelude++import GHC.Core.Type( typeKind, coreView, tcSplitAppTyNoView_maybe, splitAppTyNoView_maybe+                    , isLevityTy, isRuntimeRepTy, isMultiplicityTy )++import GHC.Core.TyCo.Rep+import GHC.Core.TyCo.FVs+import GHC.Core.TyCon+import GHC.Core.Multiplicity( MultiplicityFlag(..) )++import GHC.Types.Var+import GHC.Types.Unique+import GHC.Types.Var.Env+import GHC.Types.Var.Set++import GHC.Utils.Outputable+import GHC.Utils.Misc+import GHC.Utils.Panic++import GHC.Base (reallyUnsafePtrEquality#)++import qualified Data.Semigroup as S++{- GHC.Core.TyCo.Compare overview+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+This module implements type equality and comparison++It uses a few functions from GHC.Core.Type, notably `typeKind`,+so it currently sits "on top of" GHC.Core.Type.+-}++{- *********************************************************************+*                                                                      *+                       Type equality++     We don't use (==) from class Eq, partly so that we know where+     type equality is called, and partly because there are multiple+     variants.+*                                                                      *+********************************************************************* -}++{- Note [Computing equality on types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+This module implements type equality, notably `eqType`. This is+"definitional equality" or just "equality" for short.++There are several places within GHC that depend on the precise choice of+definitional equality used. If we change that definition, all these places+must be updated. This Note merely serves as a place for all these places+to refer to, so searching for references to this Note will find every place+that needs to be updated.++* See Note [Non-trivial definitional equality] in GHC.Core.TyCo.Rep.++* See Historical Note [Typechecker equality vs definitional equality]+  below++Note [Casts and coercions in type comparision]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+As (EQTYPE) in Note [Non-trivial definitional equality] says, our+general plan, implemented by `fullEq`, is:+ (1) ignore both casts and coercions when comparing types,+ (2) instead, compare the /kinds/ of the two types,+     as well as the types themselves++If possible we want to avoid step (2), comparing the kinds; doing so involves+calling `typeKind` and doing another comparision.++When can we avoid doing so?  Answer: we can certainly avoid doing so if the+types we are comparing have no casts or coercions.  But we can do better.+Consider+    eqType (TyConApp T [s1, ..., sn]) (TyConApp T [t1, .., tn])+We are going to call (eqType s1 t1), (eqType s2 t2) etc.++The kinds of `s1` and `t1` must be equal, because these TyConApps are well-kinded,+and both TyConApps are headed by the same T. So the first recursive call to `eqType`+certainly doesn't need to check kinds. If that call returns False, we stop. Otherwise,+we know that `s1` and `t1` are themselves equal (not just their kinds). This+makes the kinds of `s2` and `t2` to be equal, because those kinds come from the+kind of T instantiated with `s1` and `t1` -- which are the same. Thus we do not+need to check the kinds of `s2` and `t2`. By induction, we don't need to check+the kinds of *any* of the types in a TyConApp, and we also do not need to check+the kinds of the TyConApps themselves.++Conclusion:++* casts and coercions under a TyConApp don't matter -- even including type synonyms++* In step (2), use `hasCasts` to tell if there are any casts to worry about. It+  does not look very deep, because TyConApps and FunTys are so common, and it+  doesn't allocate.  The only recursive cases are AppTy and ForAllTy.++Alternative implementation.  Instead of `hasCasts`, we could make the+generic_eq_type function return+  data EqResult = NotEq | EqWithNoCasts | EqWithCasts+Practically free; but stylistically I prefer useing `hasCasts`:+  * `generic_eq_type` can just uses familiar booleans+  * There is a lot more branching with the three-value variant.+  * It separates concerns.  No need to think about cast-tracking when doing the+    equality comparison.+  * Indeed sometimes we omit the kind check unconditionally, so tracking it is just wasted+    work.+I did try both; there was no perceptible perf difference so I chose `hasCasts` version.++Note [Equality on AppTys]+~~~~~~~~~~~~~~~~~~~~~~~~~+In our cast-ignoring equality, we want to say that the following two+are equal:++  (Maybe |> co) (Int |> co')   ~?       Maybe Int++But the left is an AppTy while the right is a TyConApp. The solution is+to use splitAppTyNoView_maybe to break up the TyConApp into its pieces and+then continue. Easy to do, but also easy to forget to do.++Note [Comparing type synonyms]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider the task of testing equality between two 'Type's of the form++  TyConApp tc tys1  =  TyConApp tc tys2++where `tc` is a type synonym. A naive way to perform this comparison these+would first expand the synonym and then compare the resulting expansions.++However, this is obviously wasteful and the RHS of `tc` may be large. We'd+prefer to compare `tys1 = tys2`.  When is that sound?  Precisely when the+synonym is not /forgetful/; that is, all its type variables appear in its+RHS -- see `GHC.Core.TyCon.isForgetfulSynTyCon`.++Of course, if we find that the TyCons are *not* equal then we still need to+perform the expansion as their RHSs may still be equal.++This works fine for /equality/, but not for /comparison/.  Consider+   type S a b = (b, a)+Now consider+   S Int Bool `compare` S Char Char+The ordering may depend on whether we expand the synonym or not, and we+don't want the result to depend on that. So for comparison we stick to+/nullary/ synonyms only, which is still useful.++We perform this optimisation in a number of places:++ * GHC.Core.TyCo.Compare.eqType      (works for non-nullary synonyms)+ * GHC.Core.Map.TYpe.eqDeBruijnType  (works for non-nullary synonyms)+ * GHC.Core.Types.nonDetCmpType      (nullary only)++This optimisation is especially helpful for the ubiquitous GHC.Types.Type,+since GHC prefers to use the type synonym over @TYPE 'LiftedRep@ applications+whenever possible. See Note [Using synonyms to compress types] in+GHC.Core.Type for details.++Currently-missed opportunity (#25009):+* In the case of forgetful synonyms, we could still compare the args, pairwise,+  and then compare the RHS's with a suitably extended RnEnv2.  That would avoid+  comparing the same arg repeatedly.  e.g.+      type S a b = (a,a)+  Compare   S <big> y ~ S <big> y+  If we expand, we end up compare <big> with itself twice.++  But since forgetful synonyms are rare, we have not tried this.++Note [Type comparisons using object pointer comparisons]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Quite often we substitute the type from a definition site into+occurrences without a change. This means for code like:+    \x -> (x,x,x)+The type of every `x` will often be represented by a single object+in the heap. We can take advantage of this by shortcutting the equality+check if two types are represented by the same pointer under the hood.+In some cases this reduces compiler allocations by ~2%.++See Note [Pointer comparison operations] in GHC.Builtin.primops.txt.pp++Note [Respecting multiplicity when comparing types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Generally speaking, we respect multiplicities (i.e. the linear part of the type+system) when comparing types.  Doing so is of course crucial during typechecking.++But for reasons described in Note [Linting linearity] in GHC.Core.Lint, it is hard+to ensure that Core is always type-correct when it comes to linearity.  So+* `eqTypeIgnoringMultiplicity` provides a way to compare types that /ignores/ multiplicities+* We use this multiplicity-blind comparison very occasionally, notably+    - in Core Lint: see Note [Linting linearity] in GHC.Core.Lint+    - in rule matching: see Note [Rewrite rules ignore multiplicities in FunTy]+      in GHC.Core.Unify+-}+++tcEqKind :: HasDebugCallStack => Kind -> Kind -> Bool+tcEqKind = tcEqType++tcEqType :: HasDebugCallStack => Type -> Type -> Bool+tcEqType = eqType++-- | Just like 'tcEqType', but will return True for types of different kinds+-- as long as their non-coercion structure is identical.+tcEqTypeNoKindCheck :: Type -> Type -> Bool+tcEqTypeNoKindCheck = eqTypeNoKindCheck++-- | Check whether two TyConApps are the same; if the number of arguments+-- are different, just checks the common prefix of arguments.+tcEqTyConApps :: TyCon -> [Type] -> TyCon -> [Type] -> Bool+tcEqTyConApps tc1 args1 tc2 args2+  = tc1 == tc2 && tcEqTyConAppArgs args1 args2++tcEqTyConAppArgs :: [Type] -> [Type] -> Bool+-- Args do not have to have equal length;+-- we discard the excess of the longer one+tcEqTyConAppArgs args1 args2+  = and (zipWith tcEqTypeNoKindCheck args1 args2)+    -- No kind check necessary: if both arguments are well typed, then+    -- any difference in the kinds of later arguments would show up+    -- as differences in earlier (dependent) arguments++-- | Type equality on lists of types, looking through type synonyms+eqTypes :: [Type] -> [Type] -> Bool+eqTypes []       []       = True+eqTypes (t1:ts1) (t2:ts2) = eqType t1 t2 && eqTypes ts1 ts2+eqTypes _        _        = False++eqVarBndrs :: HasCallStack => RnEnv2 -> [Var] -> [Var] -> Maybe RnEnv2+-- Check that the var lists are the same length+-- and have matching kinds; if so, extend the RnEnv2+-- Returns Nothing if they don't match+eqVarBndrs env [] []+ = Just env+eqVarBndrs env (tv1:tvs1) (tv2:tvs2)+ | eqTypeX env (varType tv1) (varType tv2)+ = eqVarBndrs (rnBndr2 env tv1 tv2) tvs1 tvs2+eqVarBndrs _ _ _= Nothing++initRnEnv :: Type -> Type -> RnEnv2+initRnEnv ta tb = mkRnEnv2 $ mkInScopeSet $+                  tyCoVarsOfType ta `unionVarSet` tyCoVarsOfType tb++eqTypeNoKindCheck :: Type -> Type -> Bool+eqTypeNoKindCheck ty1 ty2 = eq_type_expand_respect ty1 ty2++-- | Type equality comparing both visible and invisible arguments,+-- expanding synonyms and respecting multiplicities.+eqType :: HasCallStack => Type -> Type -> Bool+eqType ta tb = fullEq eq_type_expand_respect ta tb++-- | Compare types with respect to a (presumably) non-empty 'RnEnv2'.+eqTypeX :: HasCallStack => RnEnv2 -> Type -> Type -> Bool+eqTypeX env ta tb = fullEq (eq_type_expand_respect_x env) ta tb++eqTypeIgnoringMultiplicity :: Type -> Type -> Bool+-- See Note [Respecting multiplicity when comparing types]+eqTypeIgnoringMultiplicity ta tb = fullEq eq_type_expand_ignore ta tb++-- | Like 'pickyEqTypeVis', but returns a Bool for convenience+pickyEqType :: Type -> Type -> Bool+-- Check when two types _look_ the same, _including_ synonyms.+-- So (pickyEqType String [Char]) returns False+-- This ignores kinds and coercions, because this is used only for printing.+pickyEqType ta tb = eq_type_keep_respect ta tb++{- Note [Specialising type equality]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The type equality predicates in Type are hit pretty hard by GHC.  Consequently+we take pains to ensure that these paths are compiled to efficient,+minimally-allocating code.  Plan:++* The main workhorse is `inline_generic_eq_type_x`.  It is /non-recursive/+  and is marked INLINE.++* `inline_generic_eq_type_x` has various parameters that control what it does:+  * syn_flag::SynFlag            whether type synonyms are expanded or kept.+  * mult_flag::MultiplicityFlag  whether multiplicities are ignored or respected+  * mb_env::Maybe RnEnv2         an optional RnEnv2.++* `inline_generic_eq_type_x` has a handful of call sites, namely the ones+  in `eq_type_expand_respect`, `eq_type_expand_repect_x` etc.  It inlines+  at all these sites, specialising to the data values passed for the+  control parameters.++* All /other/ calls to `inline_generic_eq_type_x` go via+     generic_eq_type_x = inline_generic_eq_type_x+     {-# NOINLNE generic_eq_type_x #-}+  The idea is that all calls to `generic_eq_type_x` are specialised by the+  RULES, so this NOINLINE version is seldom, if ever, actually called.++* For each of specialised copy of `inline_generic_eq_type_x, there is a+  corresponding rewrite RULE that rewrites a call to (generic_eq_type_x args)+  into the appropriate specialied version.++See #19226.+-}++-- | This flag controls whether we expand synonyms during comparison+data SynFlag = ExpandSynonyms | KeepSynonyms++eq_type_expand_respect, eq_type_expand_ignore, eq_type_keep_respect+  :: Type -> Type -> Bool+eq_type_expand_respect_x, eq_type_expand_ignore_x, eq_type_keep_respect_x+   :: RnEnv2 -> Type -> Type -> Bool++eq_type_expand_respect       = inline_generic_eq_type_x ExpandSynonyms RespectMultiplicities Nothing+eq_type_expand_respect_x env = inline_generic_eq_type_x ExpandSynonyms RespectMultiplicities (Just env)+eq_type_expand_ignore        = inline_generic_eq_type_x ExpandSynonyms IgnoreMultiplicities  Nothing+eq_type_expand_ignore_x env  = inline_generic_eq_type_x ExpandSynonyms IgnoreMultiplicities  (Just env)+eq_type_keep_respect         = inline_generic_eq_type_x KeepSynonyms   RespectMultiplicities Nothing+eq_type_keep_respect_x env   = inline_generic_eq_type_x KeepSynonyms   RespectMultiplicities (Just env)++{-# RULES+"eqType1" generic_eq_type_x ExpandSynonyms RespectMultiplicities Nothing+             = eq_type_expand_respect+"eqType2" forall env. generic_eq_type_x ExpandSynonyms RespectMultiplicities (Just env)+             = eq_type_expand_respect_x env+"eqType3" generic_eq_type_x ExpandSynonyms IgnoreMultiplicities Nothing+             = eq_type_expand_ignore+"eqType4" forall env. generic_eq_type_x ExpandSynonyms IgnoreMultiplicities (Just env)+             = eq_type_expand_ignore_x env+"eqType5" generic_eq_type_x KeepSynonyms RespectMultiplicities Nothing+             = eq_type_keep_respect+"eqType6" forall env. generic_eq_type_x KeepSynonyms RespectMultiplicities (Just env)+             = eq_type_keep_respect_x env+ #-}++-- ---------------------------------------------------------------+-- | Real worker for 'eqType'. No kind check!+-- Inline it at the (handful of local) call sites+-- The "generic" bit refers to the flag paramerisation+-- See Note [Specialising type equality].+generic_eq_type_x, inline_generic_eq_type_x+  :: SynFlag -> MultiplicityFlag -> Maybe RnEnv2 -> Type -> Type -> Bool++{-# NOINLINE generic_eq_type_x #-}+generic_eq_type_x = inline_generic_eq_type_x+-- See Note [Computing equality on types] in Type++{-# INLINE inline_generic_eq_type_x #-}+-- This non-recursive function can inline at its (few) call sites.  The+-- recursion goes via generic_eq_type_x, which is the loop-breaker.+inline_generic_eq_type_x syn_flag mult_flag mb_env+  = \ t1 t2 -> t1 `seq` t2 `seq`+    let go = generic_eq_type_x syn_flag mult_flag mb_env+             -- Abbreviation for recursive calls++        gos []       []       = True+        gos (t1:ts1) (t2:ts2) = go t1 t2 && gos ts1 ts2+        gos _ _               = False++    in case (t1,t2) of+      _ | 1# <- reallyUnsafePtrEquality# t1 t2 -> True+      -- See Note [Type comparisons using object pointer comparisons]++      (TyConApp tc1 tys1, TyConApp tc2 tys2)+        | tc1 == tc2, not (isForgetfulSynTyCon tc1)   -- See Note [Comparing type synonyms]+        -> gos tys1 tys2++      _ | ExpandSynonyms <- syn_flag, Just t1' <- coreView t1 -> go t1' t2+        | ExpandSynonyms <- syn_flag, Just t2' <- coreView t2 -> go t1 t2'++      (TyConApp tc1 ts1, TyConApp tc2 ts2)+        | tc1 == tc2 -> gos ts1 ts2+        | otherwise  -> False++      (TyVarTy tv1, TyVarTy tv2)+        -> case mb_env of+              Nothing  -> tv1 == tv2+              Just env -> rnOccL env tv1 == rnOccR env tv2++      (LitTy lit1,    LitTy lit2)    -> lit1 == lit2+      (CastTy t1' _,   _)            -> go t1' t2 -- Ignore casts+      (_,             CastTy t2' _)  -> go t1 t2' -- Ignore casts+      (CoercionTy {}, CoercionTy {}) -> True      -- Ignore coercions++    -- Make sure we handle all FunTy cases since falling through to the+    -- AppTy case means that tcSplitAppTyNoView_maybe may see an unzonked+    -- kind variable, which causes things to blow up.+    -- See Note [Equality on FunTys] in GHC.Core.TyCo.Rep: we must check+    -- kinds here+      (FunTy _ w1 arg1 res1, FunTy _ w2 arg2 res2)+        ->   fullEq go arg1 arg2+          && fullEq go res1 res2+          && (case mult_flag of+                  RespectMultiplicities -> go w1 w2+                  IgnoreMultiplicities  -> True)++      -- See Note [Equality on AppTys] in GHC.Core.Type+      (AppTy s1 t1', _)+        | Just (s2, t2') <- tcSplitAppTyNoView_maybe t2+        -> go s1 s2 && go t1' t2'+      (_,  AppTy s2 t2')+        | Just (s1, t1') <- tcSplitAppTyNoView_maybe t1+        -> go s1 s2 && go t1' t2'++      (ForAllTy (Bndr tv1 vis1) body1, ForAllTy (Bndr tv2 vis2) body2)+        -> case mb_env of+              Nothing -> generic_eq_type_x syn_flag mult_flag+                            (Just (initRnEnv t1 t2)) t1 t2+              Just env+                | vis1 `eqForAllVis` vis2         -- See Note [ForAllTy and type equality]+                -> go (varType tv1) (varType tv2)  -- Always do kind-check+                   && generic_eq_type_x syn_flag mult_flag+                             (Just (rnBndr2 env tv1 tv2)) body1 body2+                | otherwise+                -> False++      _ -> False++fullEq :: (Type -> Type -> Bool) -> Type -> Type -> Bool+-- Do "full equality" including the kind check+-- See Note [Casts and coercions in type comparision]+{-# INLINE fullEq #-}+fullEq eq ty1 ty2+  = case eq ty1 ty2 of+          False    -> False+          True | hasCasts ty1 || hasCasts ty2+               -> eq (typeKind ty1) (typeKind ty2)+               | otherwise+               -> True++hasCasts :: Type -> Bool+-- Fast, does not look deep, does not allocate+hasCasts (CastTy {})     = True+hasCasts (CoercionTy {}) = True+hasCasts (AppTy t1 t2)   = hasCasts t1 || hasCasts t2+hasCasts (ForAllTy _ ty) = hasCasts ty+hasCasts _               = False   -- TyVarTy, TyConApp, FunTy, LitTy+++{- *********************************************************************+*                                                                      *+                Comparing ForAllTyFlags+*                                                                      *+********************************************************************* -}++-- | Do these denote the same level of visibility? 'Required'+-- arguments are visible, others are not. So this function+-- equates 'Specified' and 'Inferred'. Used for printing.+eqForAllVis :: ForAllTyFlag -> ForAllTyFlag -> Bool+-- See Note [ForAllTy and type equality]+eqForAllVis Required      Required      = True+eqForAllVis (Invisible _) (Invisible _) = True+eqForAllVis _             _             = False++-- | Do these denote the same level of visibility? 'Required'+-- arguments are visible, others are not. So this function+-- equates 'Specified' and 'Inferred'. Used for printing.+cmpForAllVis :: ForAllTyFlag -> ForAllTyFlag -> Ordering+-- See Note [ForAllTy and type equality]+cmpForAllVis Required      Required       = EQ+cmpForAllVis Required      (Invisible {}) = LT+cmpForAllVis (Invisible _) Required       = GT+cmpForAllVis (Invisible _) (Invisible _)  = EQ+++{- Note [ForAllTy and type equality]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we compare (ForAllTy (Bndr tv1 vis1) ty1)+         and    (ForAllTy (Bndr tv2 vis2) ty2)+what should we do about `vis1` vs `vis2`?++We had a long debate about this: see #22762 and GHC Proposal 558.+Here is the conclusion.++* In Haskell, we really do want (forall a. ty) and (forall a -> ty) to be+  distinct types, not interchangeable.  The latter requires a type argument,+  but the former does not.  See GHC Proposal 558.++* We /really/ do not want the typechecker and Core to have different notions of+  equality.  That is, we don't want `tcEqType` and `eqType` to differ.  Why not?+  Not so much because of code duplication but because it is virtually impossible+  to cleave the two apart. Here is one particularly awkward code path:+     The type checker calls `substTy`, which calls `mkAppTy`,+     which calls `mkCastTy`, which calls `isReflexiveCo`, which calls `eqType`.++* Moreover the resolution of the TYPE vs CONSTRAINT story was to make the+  typechecker and Core have a single notion of equality.++* So in GHC:+  - `tcEqType` and `eqType` implement the same equality+  - (forall a. ty) and (forall a -> ty) are distinct types in both Core and typechecker+  - That is, both `eqType` and `tcEqType` distinguish them.++* But /at representational role/ we can relate the types. That is,+    (forall a. ty) ~R (forall a -> ty)+  After all, since types are erased, they are represented the same way.+  See Note [ForAllCo] and the typing rule for ForAllCo given there++* What about (forall a. ty) and (forall {a}. ty)?  See Note [Comparing visibility].++Note [Comparing visibility]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+We are sure that we want to distinguish (forall a. ty) and (forall a -> ty); see+Note [ForAllTy and type equality].  But we have /three/ settings for the ForAllTyFlag:+  * Specified: forall a. ty+  * Inferred:  forall {a}. ty+  * Required:  forall a -> ty++We could (and perhaps should) distinguish all three. But for now we distinguish+Required from Specified/Inferred, and ignore the distinction between Specified+and Inferred.++The answer doesn't matter too much, provided we are consistent. And we are consistent+because we always compare ForAllTyFlags with+  * `eqForAllVis`+  * `cmpForAllVis`.+(You can only really check this by inspecting all pattern matches on ForAllTyFlags.)+So if we change the decision, we just need to change those functions.++Why don't we distinguish all three? Should GHC type-check the following program+(adapted from #15740)?++  {-# LANGUAGE PolyKinds, ... #-}+  data D a+  type family F :: forall k. k -> Type+  type instance F = D++Due to the way F is declared, any instance of F must have a right-hand side+whose kind is equal to `forall k. k -> Type`. The kind of D is+`forall {k}. k -> Type`, which is very close, but technically uses distinct+Core:++  -----------------------------------------------------------+  | Source Haskell    | Core                                |+  -----------------------------------------------------------+  | forall  k.  <...> | ForAllTy (Bndr k Specified) (<...>) |+  | forall {k}. <...> | ForAllTy (Bndr k Inferred)  (<...>) |+  -----------------------------------------------------------++We could deem these kinds to be unequal, but that would imply rejecting+programs like the one above. Whether a kind variable binder ends up being+specified or inferred can be somewhat subtle, however, especially for kinds+that aren't explicitly written out in the source code (like in D above).++For now, we decide++    the specified/inferred status of an invisible type variable binder+    does not affect GHC's notion of equality.++That is, we have the following:++  --------------------------------------------------+  | Type 1            | Type 2            | Equal? |+  --------------------|-----------------------------+  | forall k. <...>   | forall k. <...>   | Yes    |+  |                   | forall {k}. <...> | Yes    |+  |                   | forall k -> <...> | No     |+  --------------------------------------------------+  | forall {k}. <...> | forall k. <...>   | Yes    |+  |                   | forall {k}. <...> | Yes    |+  |                   | forall k -> <...> | No     |+  --------------------------------------------------+  | forall k -> <...> | forall k. <...>   | No     |+  |                   | forall {k}. <...> | No     |+  |                   | forall k -> <...> | Yes    |+  --------------------------------------------------++Examples: T16946, T15079.++Historical Note [Typechecker equality vs definitional equality]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+This Note describes some history, in case there are vestiges of this+history lying around in the code.++Summary: prior to summer 2022, GHC had have two notions of equality+over Core types.  But now there is only one: definitional equality,+or just equality for short.++The old setup was:++* Definitional equality, as implemented by GHC.Core.Type.eqType.+  See Note [Non-trivial definitional equality] in GHC.Core.TyCo.Rep.++* Typechecker equality, as implemented by tcEqType.+  GHC.Tc.Solver.Equality.canonicaliseEquality also respects typechecker equality.++Typechecker equality implied definitional equality: if two types are equal+according to typechecker equality, then they are also equal according to+definitional equality. The converse is not always true, as typechecker equality+is more finer-grained than definitional equality in two places:++* Constraint vs Type.  Definitional equality equated Type and+  Constraint, but typechecker treats them as distinct types.++* Unlike definitional equality, which does not care about the ForAllTyFlag of a+  ForAllTy, typechecker equality treats Required type variable binders as+  distinct from Invisible type variable binders.+  See Note [ForAllTy and type equality]+++************************************************************************+*                                                                      *+                Comparison for types++      Not so heavily used, less carefully optimised+*                                                                      *+************************************************************************++-- Now here comes the real worker++Note [nonDetCmpType nondeterminism]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+nonDetCmpType is implemented in terms of nonDetCmpTypeX. nonDetCmpTypeX+uses nonDetCmpTc which compares TyCons by their Unique value. Using Uniques for+ordering leads to nondeterminism. We hit the same problem in the TyVarTy case,+comparing type variables is nondeterministic, note the call to nonDetCmpVar in+nonDetCmpTypeX.+See Note [Unique Determinism] for more details.+-}++nonDetCmpType :: Type -> Type -> Ordering+{-# INLINE nonDetCmpType #-}+nonDetCmpType !t1 !t2+  -- See Note [Type comparisons using object pointer comparisons]+  | 1# <- reallyUnsafePtrEquality# t1 t2+  = EQ+nonDetCmpType (TyConApp tc1 []) (TyConApp tc2 []) | tc1 == tc2+  = EQ+nonDetCmpType t1 t2+  -- we know k1 and k2 have the same kind, because they both have kind *.+  = nonDetCmpTypeX rn_env t1 t2+  where+    rn_env = mkRnEnv2 (mkInScopeSet (tyCoVarsOfTypes [t1, t2]))++-- | An ordering relation between two 'Type's (known below as @t1 :: k1@+-- and @t2 :: k2@)+data TypeOrdering = TLT  -- ^ @t1 < t2@+                  | TEQ  -- ^ @t1 ~ t2@ and there are no casts in either,+                         -- therefore we can conclude @k1 ~ k2@+                  | TEQX -- ^ @t1 ~ t2@ yet one of the types contains a cast so+                         -- they may differ in kind.+                  | TGT  -- ^ @t1 > t2@+                  deriving (Eq, Ord, Enum, Bounded)++nonDetCmpTypeX :: RnEnv2 -> Type -> Type -> Ordering  -- Main workhorse+    -- See Note [Non-trivial definitional equality] in GHC.Core.TyCo.Rep+    -- See Note [Computing equality on types]+    -- Always respects multiplicities, unlike eqType+nonDetCmpTypeX env orig_t1 orig_t2 =+    case go env orig_t1 orig_t2 of+      -- If there are casts then we also need to do a comparison of+      -- the kinds of the types being compared+      TEQX          -> toOrdering $ go env k1 k2+      ty_ordering   -> toOrdering ty_ordering+  where+    k1 = typeKind orig_t1+    k2 = typeKind orig_t2++    toOrdering :: TypeOrdering -> Ordering+    toOrdering TLT  = LT+    toOrdering TEQ  = EQ+    toOrdering TEQX = EQ+    toOrdering TGT  = GT++    liftOrdering :: Ordering -> TypeOrdering+    liftOrdering LT = TLT+    liftOrdering EQ = TEQ+    liftOrdering GT = TGT++    thenCmpTy :: TypeOrdering -> TypeOrdering -> TypeOrdering+    thenCmpTy TEQ  rel  = rel+    thenCmpTy TEQX rel  = hasCast rel+    thenCmpTy rel  _    = rel++    hasCast :: TypeOrdering -> TypeOrdering+    hasCast TEQ = TEQX+    hasCast rel = rel++    -- Returns both the resulting ordering relation between+    -- the two types and whether either contains a cast.+    go :: RnEnv2 -> Type -> Type -> TypeOrdering++    go _   (TyConApp tc1 []) (TyConApp tc2 [])+      | tc1 == tc2+      = TEQ    -- See Note [Comparing type synonyms]++    go env t1 t2+      | Just t1' <- coreView t1 = go env t1' t2+      | Just t2' <- coreView t2 = go env t1 t2'++    go env (TyVarTy tv1)       (TyVarTy tv2)+      = liftOrdering $ rnOccL env tv1 `nonDetCmpVar` rnOccR env tv2+    go env (ForAllTy (Bndr tv1 vis1) t1) (ForAllTy (Bndr tv2 vis2) t2)+      = liftOrdering (vis1 `cmpForAllVis` vis2)   -- See Note [ForAllTy and type equality]+        `thenCmpTy` go env (varType tv1) (varType tv2)+        `thenCmpTy` go (rnBndr2 env tv1 tv2) t1 t2++        -- See Note [Equality on AppTys]+    go env (AppTy s1 t1) ty2+      | Just (s2, t2) <- splitAppTyNoView_maybe ty2+      = go env s1 s2 `thenCmpTy` go env t1 t2+    go env ty1 (AppTy s2 t2)+      | Just (s1, t1) <- splitAppTyNoView_maybe ty1+      = go env s1 s2 `thenCmpTy` go env t1 t2++    go env (FunTy _ w1 s1 t1) (FunTy _ w2 s2 t2)+        -- NB: nonDepCmpTypeX does the kind check requested by+        -- Note [Equality on FunTys] in GHC.Core.TyCo.Rep+      = liftOrdering (nonDetCmpTypeX env s1 s2 S.<> nonDetCmpTypeX env t1 t2)+          `thenCmpTy` go env w1 w2+        -- Comparing multiplicities last because the test is usually true++    go env (TyConApp tc1 tys1) (TyConApp tc2 tys2)+      = liftOrdering (tc1 `nonDetCmpTc` tc2) `thenCmpTy` gos env tys1 tys2++    go _   (LitTy l1)          (LitTy l2)          = liftOrdering (nonDetCmpTyLit l1 l2)+    go env (CastTy t1 _)       t2                  = hasCast $ go env t1 t2+    go env t1                  (CastTy t2 _)       = hasCast $ go env t1 t2++    go _   (CoercionTy {})     (CoercionTy {})     = TEQ++        -- Deal with the rest: TyVarTy < CoercionTy < AppTy < LitTy < TyConApp < ForAllTy+    go _ ty1 ty2+      = liftOrdering $ (get_rank ty1) `compare` (get_rank ty2)+      where get_rank :: Type -> Int+            get_rank (CastTy {})+              = pprPanic "nonDetCmpTypeX.get_rank" (ppr [ty1,ty2])+            get_rank (TyVarTy {})    = 0+            get_rank (CoercionTy {}) = 1+            get_rank (AppTy {})      = 3+            get_rank (LitTy {})      = 4+            get_rank (TyConApp {})   = 5+            get_rank (FunTy {})      = 6+            get_rank (ForAllTy {})   = 7++    gos :: RnEnv2 -> [Type] -> [Type] -> TypeOrdering+    gos _   []         []         = TEQ+    gos _   []         _          = TLT+    gos _   _          []         = TGT+    gos env (ty1:tys1) (ty2:tys2) = go env ty1 ty2 `thenCmpTy` gos env tys1 tys2+++-------------+-- | Compare two 'TyCon's.+-- See Note [nonDetCmpType nondeterminism]+nonDetCmpTc :: TyCon -> TyCon -> Ordering+nonDetCmpTc tc1 tc2+  = u1 `nonDetCmpUnique` u2+  where+    u1  = tyConUnique tc1+    u2  = tyConUnique tc2+++{- *********************************************************************+*                                                                      *+                  mayLookIdentical+*                                                                      *+********************************************************************* -}++mayLookIdentical :: Type -> Type -> Bool+-- | Returns True if the /visible/ part of the types+-- might look equal, even if they are really unequal (in the invisible bits)+--+-- This function is very similar to tc_eq_type but it is much more+-- heuristic.  Notably, it is always safe to return True, even with types+-- that might (in truth) be unequal  -- this affects error messages only+-- (Originally this test was done by eqType with an extra flag, but the result+--  was hard to understand.)+mayLookIdentical orig_ty1 orig_ty2+  = go orig_env orig_ty1 orig_ty2+  where+    orig_env = mkRnEnv2 $ mkInScopeSet $ tyCoVarsOfTypes [orig_ty1, orig_ty2]++    go :: RnEnv2 -> Type -> Type -> Bool++    go env (TyConApp tc1 ts1) (TyConApp tc2 ts2)+      | tc1 == tc2, not (isForgetfulSynTyCon tc1) -- See Note [Comparing type synonyms]+      = gos env (tyConBinders tc1) ts1 ts2++    go env t1 t2 | Just t1' <- coreView t1 = go env t1' t2+    go env t1 t2 | Just t2' <- coreView t2 = go env t1 t2'++    go env (TyVarTy tv1)   (TyVarTy tv2)   = rnOccL env tv1 == rnOccR env tv2+    go _   (LitTy lit1)    (LitTy lit2)    = lit1 == lit2+    go env (CastTy t1 _)   t2              = go env t1 t2+    go env t1              (CastTy t2 _)   = go env t1 t2+    go _   (CoercionTy {}) (CoercionTy {}) = True++    go env (ForAllTy (Bndr tv1 vis1) ty1)+           (ForAllTy (Bndr tv2 vis2) ty2)+      =  vis1 `eqForAllVis` vis2  -- See Note [ForAllTy and type equality]+      && go (rnBndr2 env tv1 tv2) ty1 ty2+         -- Visible stuff only: ignore kinds of binders++    -- If we have (forall (r::RunTimeRep). ty1  ~   blah) then respond+    -- with True.  Reason: the type pretty-printer defaults RuntimeRep+    -- foralls (see Ghc.Iface.Type.hideNonStandardTypes).  That can make,+    -- say (forall r. TYPE r -> Type) into (Type -> Type), so it looks the+    -- same as a very different type (#24553).  By responding True, we+    -- tell GHC (see calls of mayLookIdentical) to display without defaulting.+    -- See Note [Showing invisible bits of types in error messages]+    -- in GHC.Tc.Errors.Ppr+    go _ (ForAllTy b _) _ | isDefaultableBndr b = True+    go _ _ (ForAllTy b _) | isDefaultableBndr b = True++    go env (FunTy _ w1 arg1 res1) (FunTy _ w2 arg2 res2)+      = go env arg1 arg2 && go env res1 res2 && go env w1 w2+        -- Visible stuff only: ignore agg kinds++      -- See Note [Equality on AppTys] in GHC.Core.Type+    go env (AppTy s1 t1) ty2+      | Just (s2, t2) <- tcSplitAppTyNoView_maybe ty2+      = go env s1 s2 && go env t1 t2+    go env ty1 (AppTy s2 t2)+      | Just (s1, t1) <- tcSplitAppTyNoView_maybe ty1+      = go env s1 s2 && go env t1 t2++    go env (TyConApp tc1 ts1)   (TyConApp tc2 ts2)+      = tc1 == tc2 && gos env (tyConBinders tc1) ts1 ts2++    go _ _ _ = False++    gos :: RnEnv2 -> [TyConBinder] -> [Type] -> [Type] -> Bool+    gos _   _         []       []      = True+    gos env bs (t1:ts1) (t2:ts2)+      | (invisible, bs') <- case bs of+                               []     -> (False,                    [])+                               (b:bs) -> (isInvisibleTyConBinder b, bs)+      = (invisible || go env t1 t2) && gos env bs' ts1 ts2++    gos _ _ _ _ = False+++isDefaultableBndr :: ForAllTyBinder -> Bool+-- This function should line up with the defaulting done+--   by GHC.Iface.Type.defaultIfaceTyVarsOfKind+-- See Note [Showing invisible bits of types in error messages]+--   in GHC.Tc.Errors.Ppr+isDefaultableBndr (Bndr tv vis)+  = isInvisibleForAllTyFlag vis && is_defaultable (tyVarKind tv)+  where+    is_defaultable ki = isLevityTy ki || isRuntimeRepTy ki  || isMultiplicityTy ki+
GHC/Core/TyCo/FVs.hs view
@@ -1,4 +1,4 @@-+{-# LANGUAGE MultiWayIf #-}  module GHC.Core.TyCo.FVs   (     shallowTyCoVarsOfType, shallowTyCoVarsOfTypes,@@ -19,21 +19,27 @@         tyCoVarsOfCoDSet,         tyCoFVsOfCo, tyCoFVsOfCos,         tyCoVarsOfCoList,+        coVarsOfCoDSet, coVarsOfCosDSet,          almostDevoidCoVarOfCo,          -- Injective free vars-        injectiveVarsOfType, injectiveVarsOfTypes,+        injectiveVarsOfType, injectiveVarsOfTypes, isInjectiveInType,         invisibleVarsOfType, invisibleVarsOfTypes,          -- Any and No Free vars         anyFreeVarsOfType, anyFreeVarsOfTypes, anyFreeVarsOfCo,         noFreeVarsOfType, noFreeVarsOfTypes, noFreeVarsOfCo, -        -- * Well-scoped free variables-        scopedSort, tyCoVarsOfTypeWellScoped,-        tyCoVarsOfTypesWellScoped,+        -- * Free type constructors+        tyConsOfType, tyConsOfTypes, +        -- * Free vars with visible/invisible separate+        visVarsOfTypes, visVarsOfType,++        -- * Occurrence-check expansion+        occCheckExpand,+         -- * Closing over kinds         closeOverKindsDSet, closeOverKindsList,         closeOverKinds,@@ -44,20 +50,28 @@  import GHC.Prelude -import {-# SOURCE #-} GHC.Core.Type (coreView, partitionInvisibleTypes)+import {-# SOURCE #-} GHC.Core.Type( partitionInvisibleTypes, coreView, rewriterView )+import {-# SOURCE #-} GHC.Core.Coercion( coercionLKind ) -import Data.Monoid as DM ( Endo(..), Any(..) )+import GHC.Builtin.Types.Prim( funTyFlagTyCon )++import Data.Monoid as DM ( Any(..) ) import GHC.Core.TyCo.Rep import GHC.Core.TyCon-import GHC.Types.Var+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.Utils.Panic+import GHC.Data.Pair +import Data.Semigroup+ {- %************************************************************************ %*                                                                      *@@ -211,6 +225,17 @@ 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. -}  {- *********************************************************************@@ -219,7 +244,7 @@ *                                                                      * ********************************************************************* -} -{- Note [Acumulating parameter free variables]+{- Note [Accumulating parameter free variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We can use foldType to build an accumulating-parameter version of a free-var finder, thus:@@ -254,7 +279,7 @@ 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-critially on the basic arity-2 function not being exported, so that+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. @@ -273,17 +298,20 @@ ********************************************************************* -}  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--- See Note [Free variables of Coercions]+-- The "deep" TyCoVars of the the coercion+-- See Note [Free variables of types] tyCoVarsOfCo co = runTyCoVars (deep_co co)  tyCoVarsOfMCo :: MCoercion -> TyCoVarSet@@ -300,7 +328,7 @@ (deep_ty, deep_tys, deep_co, deep_cos) = foldTyCo deepTcvFolder emptyVarSet  deepTcvFolder :: TyCoFolder TyCoVarSet (Endo TyCoVarSet)-deepTcvFolder = TyCoFolder { tcf_view = noView+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@@ -358,7 +386,7 @@ (shallow_ty, shallow_tys, shallow_co, shallow_cos) = foldTyCo shallowTcvFolder emptyVarSet  shallowTcvFolder :: TyCoFolder TyCoVarSet (Endo TyCoVarSet)-shallowTcvFolder = TyCoFolder { tcf_view = noView+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@@ -430,6 +458,16 @@                        -- 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@@ -568,6 +606,7 @@                                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@@ -575,7 +614,7 @@ 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 :: TyCoVarBinder -> FV -> FV+tyCoFVsBndr :: ForAllTyBinder -> FV -> FV -- Free vars of (forall b. <thing with fvs>) tyCoFVsBndr (Bndr tv _) fvs = tyCoFVsVarBndr tv fvs @@ -615,38 +654,31 @@ 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+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 _ w co1 co2)    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 (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 (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 (NthCo _ _ co)      fv_cand in_scope acc = tyCoFVsOfCo co 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-tyCoFVsOfCo (AxiomRuleCo _ cs)  fv_cand in_scope acc = tyCoFVsOfCos cs 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 -tyCoFVsOfProv :: UnivCoProvenance -> FV-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 (CorePrepProv _)    fv_cand in_scope acc = emptyFV 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@@ -656,7 +688,7 @@  -- | 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 last wrinkle in Note [Unused coercion variable in ForAllCo] in "GHC.Core.Coercion"+-- 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@@ -670,19 +702,19 @@ 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 v kind_co co) 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 _ w co1 co2) cv-  = almost_devoid_co_var_of_co w 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 (AxiomInstCo _ _ cos) cv-  = almost_devoid_co_var_of_cos cos cv-almost_devoid_co_var_of_co (UnivCo p _ t1 t2) cv-  = almost_devoid_co_var_of_prov p 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@@ -690,7 +722,7 @@ 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 (NthCo _ _ co) 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@@ -701,8 +733,6 @@   = 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_co (AxiomRuleCo _ cs) cv-  = almost_devoid_co_var_of_cos cs cv  almost_devoid_co_var_of_cos :: [Coercion] -> CoVar -> Bool almost_devoid_co_var_of_cos [] _ = True@@ -710,14 +740,6 @@   = almost_devoid_co_var_of_co co cv   && almost_devoid_co_var_of_cos cos cv -almost_devoid_co_var_of_prov :: UnivCoProvenance -> CoVar -> Bool-almost_devoid_co_var_of_prov (PhantomProv co) cv-  = almost_devoid_co_var_of_co co cv-almost_devoid_co_var_of_prov (ProofIrrelProv co) cv-  = almost_devoid_co_var_of_co co cv-almost_devoid_co_var_of_prov (PluginProv _)   _ = True-almost_devoid_co_var_of_prov (CorePrepProv _) _ = True- 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@@ -747,12 +769,71 @@   +{-+%************************************************************************+%*                                                                      *+        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: --@@ -783,25 +864,30 @@                     -> Type -> FV injectiveVarsOfType look_under_tfs = go   where-    go ty                  | Just ty' <- coreView 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)   =-      case tyConInjectivityInfo tc of-        Injective inj-          |  look_under_tfs || not (isTypeFamilyTyCon tc)-          -> mapUnionFV go $-             filterByList (inj ++ repeat True) tys+    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-        _ -> emptyFV-    go (ForAllTy (Bndr tv _) ty) = go (tyVarKind tv) `unionFV` delFV tv (go ty)-    go LitTy{}                   = emptyFV-    go (CastTy ty _)             = go ty-    go CoercionTy{}              = emptyFV+           | 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: --@@ -833,7 +919,7 @@ --   * 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, TyCoVarBinders, TyConBinders, and visibility] in "GHC.Core.TyCo.Rep"+-- See Note [VarBndrs, ForAllTyBinders, TyConBinders, and visibility] in "GHC.Core.TyCo.Rep" invisibleVarsOfType :: Type -> FV invisibleVarsOfType = go   where@@ -863,7 +949,9 @@  {-# INLINE afvFolder #-}   -- so that specialization to (const True) works afvFolder :: (TyCoVar -> Bool) -> TyCoFolder TyCoVarSet DM.Any-afvFolder check_fv = TyCoFolder { tcf_view = noView+-- '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@@ -896,103 +984,281 @@   where (_, _, f, _) = foldTyCo (afvFolder (const True)) emptyVarSet  -{- *********************************************************************+{-+************************************************************************ *                                                                      *-                 scopedSort+            Free type constructors *                                                                      *-********************************************************************* -}+************************************************************************+-} -{- Note [ScopedSort]-~~~~~~~~~~~~~~~~~~~~-Consider+{- 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. -  foo :: Proxy a -> Proxy (b :: k) -> Proxy (a :: k2) -> ()+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. -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.+None seem critical. Currently tyConsOfType looks inside coercions, but perhaps+it doesn't even need to do that.+-} -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.+-- | 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 -We thus state:+     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 - * These variables appear in the order as given by ScopedSort, where-   the input to ScopedSort is the left-to-right order of first occurrence.+     go_mco MRefl    = emptyUniqSet+     go_mco (MCo co) = go_co co -Note that this applies only to *implicit* quantification, without a-`forall`. If the user writes a `forall`, then we just use the order given.+     go_cos cos   = foldr (unionUniqSets . go_co)  emptyUniqSet cos -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.+     go_tc tc = unitUniqSet tc -INVARIANT: The prefix of variables before the cursor form a valid telescope.+     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 -Note that ScopedSort makes sense only after type inference is done and all-types/kinds are fully settled and zonked.+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. -} --- | 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).------ 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"+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 -scopedSort :: [TyCoVar] -> [TyCoVar]-scopedSort = go [] []+  | otherwise+  = go (mkVarSet vs_to_avoid, emptyVarEnv) ty   where-    go :: [TyCoVar] -- 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 tvs' kinds+    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 -                       -- This list is in 1-to-1 correspondence with the sorted tyvars-                       -- 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.+    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') } -       -> [TyCoVar] -- yet to be sorted-       -> [TyCoVar]-    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+    -- 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 -    insert :: TyCoVar       -- var to insert-           -> [TyCoVar]     -- sorted list, in reverse order-           -> [TyCoVarSet]  -- list of fvs, as above-           -> ([TyCoVar], [TyCoVarSet])   -- augmented lists-    insert tv []     []         = ([tv], [tyCoVarsOfType (tyVarKind tv)])-    insert tv (a:as) (fvs:fvss)-      | tv `elemVarSet` fvs-      , (as', fvss') <- insert tv as fvss-      = (a:as', fvs `unionVarSet` fv_tv : fvss')+    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') } -      | otherwise-      = (tv:a:as, fvs `unionVarSet` fv_tv : fvs : fvss)-      where-        fv_tv = tyCoVarsOfType (tyVarKind tv)+    ------------------+    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 -       -- lists not in correspondence-    insert _ _ _ = panic "scopedSort"+    ------------------+    go_mco _   MRefl = return MRefl+    go_mco ctx (MCo co) = MCo <$> go_co ctx co --- | Get the free vars of a type in scoped order-tyCoVarsOfTypeWellScoped :: Type -> [TyVar]-tyCoVarsOfTypeWellScoped = scopedSort . tyCoVarsOfTypeList+    ------------------+    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') } --- | Get the free vars of types in scoped order-tyCoVarsOfTypesWellScoped :: [Type] -> [TyVar]-tyCoVarsOfTypesWellScoped = scopedSort . tyCoVarsOfTypesList+    go_co cxt@(as, env) co@(ForAllCo { fco_tcv = tv, fco_kind = kind_co, fco_body = body_co })+      = do { kind_co' <- go_co cxt kind_co+           ; let tv' = setVarType tv $+                       coercionLKind kind_co'+                 env' = extendVarEnv env tv tv'+                 as'  = as `delVarSet` tv+           ; body' <- go_co (as', env') body_co+           ; return (co { fco_tcv = tv', fco_kind = kind_co', fco_body = body' }) }++    go_co cxt co@(FunCo { fco_mult = w, fco_arg = co1 ,fco_res = co2 })+      = do { co1' <- go_co cxt co1+           ; co2' <- go_co cxt co2+           ; w' <- go_co cxt w+           ; return (co { fco_mult = w', fco_arg = co1', fco_res = co2' })}++    go_co (as,env) co@(CoVarCo c)+      | Just c' <- lookupVarEnv env c   = return (CoVarCo c')+      | bad_var_occ as c                = Nothing+      | otherwise                       = return co++    go_co (as,_) co@(HoleCo h)+      | bad_var_occ as (ch_co_var h)    = Nothing+      | otherwise                       = return co++    go_co cxt (AxiomCo ax cs)           = do { cs' <- mapM (go_co cxt) cs+                                             ; return (AxiomCo ax cs') }+    go_co cxt co@(UnivCo { uco_lty = ty1, uco_rty = ty2, uco_deps = cos })+      = do { ty1' <- go cxt ty1+           ; ty2' <- go cxt ty2+           ; cos' <- mapM (go_co cxt) cos+           ; return (co { uco_lty = ty1', uco_rty = ty2', uco_deps = cos' }) }+
+ GHC/Core/TyCo/FVs.hs-boot view
@@ -0,0 +1,8 @@+module GHC.Core.TyCo.FVs where++import GHC.Prelude ( Bool )+import GHC.Types.Var.Set( TyCoVarSet )+import {-# SOURCE #-} GHC.Core.TyCo.Rep ( Type )++noFreeVarsOfType :: Type -> Bool+tyCoVarsOfType   :: Type -> TyCoVarSet
GHC/Core/TyCo/Ppr.hs view
@@ -14,7 +14,7 @@         pprTyVar, pprTyVars,         pprThetaArrowTy, pprClassPred,         pprKind, pprParendKind, pprTyLit,-        pprDataCons, pprWithExplicitKindsWhen,+        pprDataCons, pprWithInvisibleBitsWhen,         pprWithTYPE, pprSourceTyCon,  @@ -27,20 +27,23 @@ import GHC.Prelude  import {-# SOURCE #-} GHC.CoreToIface-   ( toIfaceTypeX, toIfaceTyLit, toIfaceForAllBndr+   ( toIfaceTypeX, toIfaceTyLit, toIfaceForAllBndrs    , toIfaceTyCon, toIfaceTcArgs, toIfaceCoercionX )  import {-# SOURCE #-} GHC.Core.DataCon    ( dataConFullSig , dataConUserTyVarBinders, DataCon ) -import GHC.Core.Type ( pickyIsLiftedTypeKind, pattern One, pattern Many,-                       splitForAllReqTVBinders, splitForAllInvisTVBinders )+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@@ -68,17 +71,11 @@ 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 [IfaceType and pretty-printing] in GHC.Iface.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. -} ------------------------------------------------------------ When pretty-printing types, we convert to IfaceType,---   and pretty-print that.--- See Note [Pretty printing via Iface syntax] in GHC.Types.TyThing.Ppr---------------------------------------------------------- pprType, pprParendType, pprTidiedType :: Type -> SDoc pprType       = pprPrecType topPrec pprParendType = pprPrecType appPrec@@ -99,6 +96,13 @@     -- 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 @@ -106,12 +110,6 @@ pprKind       = pprType pprParendKind = pprParendType -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.- tidyToIfaceType :: Type -> IfaceType tidyToIfaceType = tidyToIfaceTypeX emptyTidyEnv @@ -123,9 +121,12 @@ -- 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 = tyCoVarsOfTypeWellScoped ty+    free_tcvs = tyCoVarsOfTypeList ty  ------------ pprCo, pprParendCo :: Coercion -> SDoc@@ -167,18 +168,18 @@ pprSigmaType :: Type -> SDoc pprSigmaType = pprIfaceSigmaType ShowForAllWhen . tidyToIfaceType -pprForAll :: [TyCoVarBinder] -> SDoc-pprForAll tvs = pprIfaceForAll (map toIfaceForAllBndr tvs)+pprForAll :: [ForAllTyBinder] -> SDoc+pprForAll tvs = pprIfaceForAll (toIfaceForAllBndrs tvs)  -- | Print a user-level forall; see @Note [When to print foralls]@ in -- "GHC.Iface.Type".-pprUserForAll :: [TyCoVarBinder] -> SDoc-pprUserForAll = pprUserIfaceForAll . map toIfaceForAllBndr+pprUserForAll :: [ForAllTyBinder] -> SDoc+pprUserForAll = pprUserIfaceForAll . toIfaceForAllBndrs -pprTCvBndrs :: [TyCoVarBinder] -> SDoc+pprTCvBndrs :: [ForAllTyBinder] -> SDoc pprTCvBndrs tvs = sep (map pprTCvBndr tvs) -pprTCvBndr :: TyCoVarBinder -> SDoc+pprTCvBndr :: ForAllTyBinder -> SDoc pprTCvBndr = pprTyVar . binderVar  pprTyVars :: [TyVar] -> SDoc@@ -236,18 +237,15 @@ debug_ppr_ty _ (TyVarTy tv)   = ppr tv  -- With -dppr-debug we get (tv :: kind) -debug_ppr_ty prec ty@(FunTy { ft_af = af, ft_mult = mult, ft_arg = arg, ft_res = res })+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 = case af of-            VisArg   -> case mult of-                          One -> lollipop-                          Many -> arrow-                          w -> mulArrow (ppr w)-            InvisArg -> case mult of-                          Many -> darrow-                          _ -> pprPanic "unexpected multiplicity" (ppr ty)+    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@@ -269,7 +267,7 @@  -- Invisible forall:  forall {k} (a :: k). t debug_ppr_ty prec t-  | (bndrs, body) <- splitForAllInvisTVBinders t+  | (bndrs, body) <- splitForAllInvisTyBinders t   , not (null bndrs)   = maybeParen prec funPrec $     sep [ text "forall" <+> fsep (map ppr_bndr bndrs) <> dot,@@ -282,7 +280,7 @@  -- Visible forall:  forall x y -> t debug_ppr_ty prec t-  | (bndrs, body) <- splitForAllReqTVBinders t+  | (bndrs, body) <- splitForAllReqTyBinders t   , not (null bndrs)   = maybeParen prec funPrec $     sep [ text "forall" <+> fsep (map ppr_bndr bndrs) <+> arrow,@@ -294,7 +292,7 @@  -- Impossible case: neither visible nor invisible forall. debug_ppr_ty _ ForAllTy{}-  = panic "debug_ppr_ty: neither splitForAllInvisTVBinders nor splitForAllReqTVBinders returned any binders"+  = panic "debug_ppr_ty: neither splitForAllInvisTyBinders nor splitForAllReqTyBinders returned any binders"  {- Note [Infix type variables]@@ -326,7 +324,7 @@ pprDataConWithArgs dc = sep [forAllDoc, thetaDoc, ppr dc <+> argsDoc]   where     (_univ_tvs, _ex_tvs, _eq_spec, theta, arg_tys, _res_ty) = dataConFullSig dc-    user_bndrs = tyVarSpecToBinders $ dataConUserTyVarBinders dc+    user_bndrs = dataConUserTyVarBinders dc     forAllDoc  = pprUserForAll user_bndrs     thetaDoc   = pprThetaArrowTy theta     argsDoc    = hsep (fmap pprParendType (map scaledThing arg_tys))@@ -339,13 +337,14 @@     -- TODO: toIfaceTcArgs seems rather wasteful here  --------------------- | Display all kind information (with @-fprint-explicit-kinds@) when the--- provided 'Bool' argument is 'True'.--- See @Note [Kind arguments in error messages]@ in "GHC.Tc.Errors".-pprWithExplicitKindsWhen :: Bool -> SDoc -> SDoc-pprWithExplicitKindsWhen b+-- | 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 }+      if b then ctx { sdocPrintExplicitKinds   = True+                    , sdocPrintExplicitRuntimeReps = True }            else ctx  -- | This variant preserves any use of TYPE in a type, effectively
GHC/Core/TyCo/Ppr.hs-boot view
@@ -5,6 +5,7 @@ import GHC.Utils.Outputable ( SDoc )  pprType :: Type -> SDoc+debugPprType :: Type -> SDoc pprKind :: Kind -> SDoc pprCo :: Coercion -> SDoc pprTyLit :: TyLit -> SDoc
GHC/Core/TyCo/Rep.hs view
@@ -1,2018 +1,2007 @@--{-# 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,-        KnotTied,-        PredType, ThetaType, FRRType,     -- Synonyms-        ArgFlag(..), AnonArgFlag(..),--        -- * Coercions-        Coercion(..),-        UnivCoProvenance(..),-        CoercionHole(..), coHoleCoVar, setCoHoleCoVar,-        CoercionN, CoercionR, CoercionP, KindCoercion,-        MCoercion(..), MCoercionR, MCoercionN,--        -- * Functions over types-        mkNakedTyConTy, mkTyVarTy, mkTyVarTys,-        mkTyCoVarTy, mkTyCoVarTys,-        mkFunTy, mkVisFunTy, mkInvisFunTy, mkVisFunTys,-        mkForAllTy, mkForAllTys, mkInvisForAllTys,-        mkPiTy, mkPiTys,-        mkFunTyMany,-        mkScaledFunTy,-        mkVisFunTyMany, mkVisFunTysMany,-        mkInvisFunTyMany, mkInvisFunTysMany,-        nonDetCmpTyLit, cmpTyLit,--        -- * Functions over binders-        TyCoBinder(..), TyCoVarBinder, TyBinder,-        binderVar, binderVars, binderType, binderArgFlag,-        delBinderVar,-        isInvisibleArgFlag, isVisibleArgFlag,-        isInvisibleBinder, isVisibleBinder,-        isTyBinder, isNamedBinder,--        -- * Functions over coercions-        pickLR,--        -- ** Analyzing types-        TyCoFolder(..), foldTyCo, noView,--        -- * Sizes-        typeSize, coercionSize, provSize,--        -- * Multiplicities-        Scaled(..), scaledMult, scaledThing, mapScaledType, Mult-    ) where--import GHC.Prelude--import {-# SOURCE #-} GHC.Core.TyCo.Ppr ( pprType, pprCo, pprTyLit )--   -- Transitively pulls in a LOT of stuff, better to break the loop---- friends:-import GHC.Types.Var-import GHC.Types.Var.Set-import GHC.Core.TyCon-import GHC.Core.Coercion.Axiom---- others-import {-# SOURCE #-} GHC.Builtin.Types ( manyDataConTy )-import GHC.Types.Basic ( LeftOrRight(..), pickLR )-import GHC.Types.Unique ( Uniquable(..) )-import GHC.Utils.Outputable-import GHC.Data.FastString-import GHC.Utils.Misc-import GHC.Utils.Panic---- libraries-import qualified Data.Data as Data hiding ( TyCon )-import Data.IORef ( IORef )   -- for CoercionHole--{- **********************************************************************-*                                                                       *-                        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---- 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-        {-# UNPACK #-} !TyCoVarBinder-        Type            -- ^ A Π type.-             -- Note [When we quantify over a coercion variable]-             -- INVARIANT: If the binder is a coercion variable, it must-             -- be mentioned in the Type. See-             -- Note [Unused coercion variable in ForAllTy]--  | FunTy      -- ^ FUN m t1 t2   Very common, so an important special case-                -- See Note [Function types]-     { ft_af  :: AnonArgFlag    -- Is this (->) or (=>)?-     , ft_mult :: Mult          -- Multiplicity-     , 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 VisArg m t1 t2-  dropping the 'r1' and 'r2' arguments; they are easily recovered-  from 't1' and 't2'. The visibility is always VisArg, because-  we build constraint arrows (=>) with e.g. mkPhiTy and friends,-  never `mkTyConApp funTyCon args`.--* For the time being its RuntimeRep quantifiers are left-  inferred. This is to allow for it to evolve.--* Because the RuntimeRep args came first historically (that is,-  the arrow type constructor gained these arguments before gaining-  the Multiplicity argument), we wanted to be able to say-    type (->) = FUN Many-  which we do in library module GHC.Types. This means that the-  Multiplicity argument must precede the RuntimeRep arguments ---  and it means changing the name of the primitive constructor from-  (->) to FUN.--* The multiplicity argument is dependent, because Typeable does not-  support a type such as `Multiplicity -> forall {r1 r2 :: RuntimeRep}. ...`.-  There is a plan to change the argument order and make the-  multiplicity argument nondependent in #20164.--* The ft_af field says whether or not this is an invisible argument-     VisArg:   t1 -> t2    Ordinary function type-     InvisArg: t1 => t2    t1 is guaranteed to be a predicate type,-                           i.e. t1 :: Constraint-  See Note [Types for coercions, predicates, and evidence]--  This visibility info makes no difference in Core; it matters-  only when we regard the type as a Haskell source type.--Note [Types for coercions, predicates, and evidence]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We treat differently:--  (a) Predicate types-        Test: isPredTy-        Binders: DictIds-        Kind: Constraint-        Examples: (Eq a), and (a ~ b)--  (b) Coercion types are primitive, unboxed equalities-        Test: isCoVarTy-        Binders: CoVars (can appear in coercions)-        Kind: TYPE (TupleRep [])-        Examples: (t1 ~# t2) or (t1 ~R# t2)--  (c) Evidence types is the type of evidence manipulated by-      the type constraint solver.-        Test: isEvVarType-        Binders: EvVars-        Kind: Constraint or TYPE (TupleRep [])-        Examples: all coercion types and predicate types--Coercion types and predicate types are mutually exclusive,-but evidence types are a superset of both.--When treated as a user type,--  - Predicates (of kind Constraint) are invisible and are-    implicitly instantiated--  - Coercion types, and non-pred evidence types (i.e. not-    of kind Constrain), are just regular old types, are-    visible, and are not implicitly instantiated.--In a FunTy { ft_af = InvisArg }, the argument type is always-a Predicate 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 [Constraints in kinds]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-Do we allow a type constructor to have a kind like-   S :: Eq a => a -> Type--No, we do not.  Doing so would mean would need a TyConApp like-   S @k @(d :: Eq k) (ty :: k)- and we have no way to build, or decompose, evidence like- (d :: Eq k) at the type level.--But we admit one exception: equality.  We /do/ allow, say,-   MkT :: (a ~ b) => a -> b -> Type a b--Why?  Because we can, without much difficulty.  Moreover-we can promote a GADT data constructor (see TyCon-Note [Promoted data constructors]), like-  data GT a b where-    MkGT : a -> a -> GT a a-so programmers might reasonably expect to be able to-promote MkT as well.--How does this work?--* In GHC.Tc.Validity.checkConstraintsOK we reject kinds that-  have constraints other than (a~b) and (a~~b).--* In Inst.tcInstInvisibleTyBinder we instantiate a call-  of MkT by emitting-     [W] co :: alpha ~# beta-  and producing the elaborated term-     MkT @alpha @beta (Eq# alpha beta co)-  We don't generate a boxed "Wanted"; we generate only a-  regular old /unboxed/ primitive-equality Wanted, and build-  the box on the spot.--* How can we get such a MkT?  By promoting a GADT-style data-  constructor-     data T a b where-       MkT :: (a~b) => a -> b -> T a b-  See DataCon.mkPromotedDataCon-  and Note [Promoted data constructors] in GHC.Core.TyCon--* We support both homogeneous (~) and heterogeneous (~~)-  equality.  (See Note [The equality types story]-  in GHC.Builtin.Types.Prim for a primer on these equality types.)--* How do we prevent a MkT having an illegal constraint like-  Eq a?  We check for this at use-sites; see GHC.Tc.Gen.HsType.tcTyVar,-  specifically dc_theta_illegal_constraint.--* Notice that nothing special happens if-    K :: (a ~# b) => blah-  because (a ~# b) is not a predicate type, and is never-  implicitly instantiated. (Mind you, it's not clear how you-  could creates a type constructor with such a kind.) See-  Note [Types for coercions, predicates, and evidence]--* The existence of promoted MkT with an equality-constraint-  argument is the (only) reason that the AnonTCB constructor-  of TyConBndrVis carries an AnonArgFlag (VisArg/InvisArg).-  For example, when we promote the data constructor-     MkT :: forall a b. (a~b) => a -> b -> T a b-  we get a PromotedDataCon with tyConBinders-      Bndr (a :: Type)  (NamedTCB Inferred)-      Bndr (b :: Type)  (NamedTCB Inferred)-      Bndr (_ :: a ~ b) (AnonTCB InvisArg)-      Bndr (_ :: a)     (AnonTCB VisArg))-      Bndr (_ :: b)     (AnonTCB VisArg))--* One might reasonably wonder who *unpacks* these boxes once they are-  made. After all, there is no type-level `case` construct. The-  surprising answer is that no one ever does. Instead, if a GADT-  constructor is used on the left-hand side of a type family equation,-  that occurrence forces GHC to unify the types in question. For-  example:--  data G a where-    MkG :: G Bool--  type family F (x :: G a) :: a where-    F MkG = False--  When checking the LHS `F MkG`, GHC sees the MkG constructor and then must-  unify F's implicit parameter `a` with Bool. This succeeds, making the equation--    F Bool (MkG @Bool <Bool>) = False--  Note that we never need unpack the coercion. This is because type-  family equations are *not* parametric in their kind variables. That-  is, we could have just said--  type family H (x :: G a) :: a where-    H _ = False--  The presence of False on the RHS also forces `a` to become Bool,-  giving us--    H Bool _ = False--  The fact that any of this works stems from the lack of phase-  separation between types and kinds (unlike the very present phase-  separation between terms and types).--  Once we have the ability to pattern-match on types below top-level,-  this will no longer cut it, but it seems fine for now.---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 Int |> <*> the same as Int? YES! In order to reduce headaches,-we decide that any reflexive casts in types are just ignored.-(Indeed they must be. See Note [Respecting definitional equality].)-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 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.--Besides eqType, another equality relation that upholds the (EQ) property above-is /typechecker equality/, which is implemented as-GHC.Tc.Utils.TcType.tcEqType. See-Note [Typechecker equality vs definitional equality] in GHC.Tc.Utils.TcType for-what the difference between eqType and tcEqType is.--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 (EQ1) below.--Unforunately, that's not the end of the story. Consider comparing-  (T a b c)      =?       (T a b |> (co -> <Type>)) (c |> co)-These two types have the same kind (Type), but the left type is a TyConApp-while the right type is not. To handle this case, we say that the right-hand-type is ill-formed, requiring an AppTy never to have a casted TyConApp-on its left. It is easy enough to pull around the coercions to maintain-this invariant, as done in Type.mkAppTy. In the example above, trying to-form the right-hand type will instead yield (T a b (c |> co |> sym co) |> <Type>).-Both the casts there are reflexive and will be dropped. Huzzah.--This idea of pulling coercions to the right works for splitAppTy as well.--However, there is one hiccup: it's possible that a coercion doesn't relate two-Pi-types. For example, if we have @type family Fun a b where Fun a b = a -> b@,-then we might have (T :: Fun Type Type) and (T |> axFun) Int. That axFun can't-be pulled to the right. But we don't need to pull it: (T |> axFun) Int is not-`eqType` to any proper TyConApp -- thus, leaving it where it is doesn't violate-our (EQ) property.--In order to detect reflexive casts reliably, we must make sure not-to have nested casts: we update (t |> co1 |> co2) to (t |> (co1 `TransCo` co2)).-This is (EQ2) 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 [When we quantify over a coercion variable]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The TyCoVarBinder in a ForAllTy can be (most often) a TyVar or (rarely)-a CoVar. We support quantifying over a CoVar here in order to support-a homogeneous (~#) relation (someday -- not yet implemented). Here is-the example:--  type (:~~:) :: forall k1 k2. k1 -> k2 -> Type-  data a :~~: b where-    HRefl :: a :~~: a--Assuming homogeneous equality (that is, with-  (~#) :: forall k. k -> k -> TYPE (TupleRep '[])-) after rejigging to make equalities explicit, we get a constructor that-looks like--  HRefl :: forall k1 k2 (a :: k1) (b :: k2).-           forall (cv :: k1 ~# k2). (a |> cv) ~# b-        => (:~~:) k1 k2 a b--Note that we must cast `a` by a cv bound in the same type in order to-make this work out.--See also https://gitlab.haskell.org/ghc/ghc/-/wikis/dependent-haskell/phase2-which gives a general road map that covers this space.--Having this feature in Core does *not* mean we have it in source Haskell.-See #15710 about that.--Note [Unused coercion variable in ForAllTy]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose we have-  \(co:t1 ~ t2). e--What type should we give to this 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--{- **********************************************************************-*                                                                       *-                  TyCoBinder and ArgFlag-*                                                                       *-********************************************************************** -}---- | A 'TyCoBinder' represents an argument to a function. TyCoBinders can be--- dependent ('Named') or nondependent ('Anon'). They may also be visible or--- not. See Note [TyCoBinders]-data TyCoBinder-  = Named TyCoVarBinder    -- A type-lambda binder-  | Anon AnonArgFlag (Scaled Type)  -- A term-lambda binder. Type here can be CoercionTy.-                                    -- Visibility is determined by the AnonArgFlag-  deriving Data.Data--instance Outputable TyCoBinder where-  ppr (Anon af ty) = 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)----- | 'TyBinder' is like 'TyCoBinder', but there can only be 'TyVarBinder'--- in the 'Named' field.-type TyBinder = TyCoBinder---- | Remove the binder's variable from the set, if the binder has--- a variable.-delBinderVar :: VarSet -> TyCoVarBinder -> VarSet-delBinderVar vars (Bndr tv _) = vars `delVarSet` tv---- | Does this binder bind an invisible argument?-isInvisibleBinder :: TyCoBinder -> Bool-isInvisibleBinder (Named (Bndr _ vis)) = isInvisibleArgFlag vis-isInvisibleBinder (Anon InvisArg _)    = True-isInvisibleBinder (Anon VisArg   _)    = False---- | Does this binder bind a visible argument?-isVisibleBinder :: TyCoBinder -> Bool-isVisibleBinder = not . isInvisibleBinder--isNamedBinder :: TyCoBinder -> Bool-isNamedBinder (Named {}) = True-isNamedBinder (Anon {})  = False---- | 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 :: TyCoBinder -> Bool-isTyBinder (Named bnd) = isTyVarBinder bnd-isTyBinder _ = True--{- Note [TyCoBinders]-~~~~~~~~~~~~~~~~~~~-A ForAllTy contains a TyCoVarBinder.  But a type can be decomposed-to a telescope consisting of a [TyCoBinder]--A TyCoBinder 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 (Bndr 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 [VarBndrs, TyCoVarBinders, TyConBinders, and visibility]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-* A ForAllTy (used for both types and kinds) contains a TyCoVarBinder.-  Each TyCoVarBinder-      Bndr a tvis-  is equipped with tvis::ArgFlag, 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 :: TyCoVarBinder, in the binder of ForAllTy for a term-|  tvis :: ArgFlag-|  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:            T :: forall k -> type    Arg required:     T *-|    This last form is illegal in terms: See Note [No Required TyCoBinder in terms]-|-| 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--* Inferred.  Function defn, with signature (explicit forall), marked as inferred:-     f4 :: forall {a}. a -> a; f4 x = x-  So f4 gets the type f4 :: 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 f4--* Inferred/Specified.  Function signature with inferred kind polymorphism.-     f5 :: a b -> Int-  So 'f5' gets the type f5 :: 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-     f6 :: a (b :: k) -> Int-  This time 'k' is Specified, because it is mentioned explicitly,-  so we get f6 :: 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/ TyCoBinders 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).--Note [No Required TyCoBinder 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 TyCoBinders are rare-anyway.  (Most are Anons.)--However the type of a term can (just about) have a required quantifier;-see Note [Required quantifiers in the type of a term] in GHC.Tc.Gen.Expr.--}---{- **********************************************************************-*                                                                       *-                        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`, `mkVisFunTy`, `mkInvisFunTy`, `mkVisFunTyMany`,-         `mkInvisFunTyMany`      -- Associates to the right--mkFunTy :: AnonArgFlag -> Mult -> Type -> Type -> Type-mkFunTy af mult arg res = FunTy { ft_af = af-                                , ft_mult = mult-                                , ft_arg = arg-                                , ft_res = res }--mkScaledFunTy :: AnonArgFlag -> Scaled Type -> Type -> Type-mkScaledFunTy af (Scaled mult arg) res = mkFunTy af mult arg res--mkVisFunTy, mkInvisFunTy :: Mult -> Type -> Type -> Type-mkVisFunTy   = mkFunTy VisArg-mkInvisFunTy = mkFunTy InvisArg--mkFunTyMany :: AnonArgFlag -> Type -> Type -> Type-mkFunTyMany af = mkFunTy af manyDataConTy---- | Special, common, case: Arrow type with mult Many-mkVisFunTyMany :: Type -> Type -> Type-mkVisFunTyMany = mkVisFunTy manyDataConTy--mkInvisFunTyMany :: Type -> Type -> Type-mkInvisFunTyMany = mkInvisFunTy manyDataConTy---- | Make nested arrow types-mkVisFunTys :: [Scaled Type] -> Type -> Type-mkVisFunTys tys ty = foldr (mkScaledFunTy VisArg) ty tys--mkVisFunTysMany :: [Type] -> Type -> Type-mkVisFunTysMany tys ty = foldr mkVisFunTyMany ty tys--mkInvisFunTysMany :: [Type] -> Type -> Type-mkInvisFunTysMany tys ty = foldr mkInvisFunTyMany ty tys---- | Like 'mkTyCoForAllTy', but does not check the occurrence of the binder--- See Note [Unused coercion variable in ForAllTy]-mkForAllTy :: TyCoVar -> ArgFlag -> Type -> Type-mkForAllTy tv vis ty = ForAllTy (Bndr tv vis) ty---- | Wraps foralls over the type using the provided 'TyCoVar's from left to right-mkForAllTys :: [TyCoVarBinder] -> 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 :: TyCoBinder -> Type -> Type-mkPiTy (Anon af ty1) ty2        = mkScaledFunTy af ty1 ty2-mkPiTy (Named (Bndr tv vis)) ty = mkForAllTy tv vis ty--mkPiTys :: [TyCoBinder] -> 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 []--{--%************************************************************************-%*                                                                      *-            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 [Forall coercions]-  | ForAllCo TyCoVar KindCoercion Coercion-         -- ForAllCo :: _ -> N -> e -> e--  | FunCo Role CoercionN Coercion Coercion         -- lift FunTy-         -- FunCo :: "e" -> N -> e -> e -> e-         -- Note: why doesn't FunCo have a AnonArgFlag, like FunTy?-         -- Because the AnonArgFlag has no impact on Core; it is only-         -- there to guide implicit instantiation of Haskell source-         -- types, and that is irrelevant for coercions, which are-         -- Core-only.--  -- These are special-  | CoVarCo CoVar      -- :: _ -> (N or R)-                       -- result role depends on the tycon of the variable's type--    -- AxiomInstCo :: e -> _ -> ?? -> 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]-     -- The roles of the argument coercions are determined-     -- by the cab_roles field of the relevant branch of the CoAxiom--  | AxiomRuleCo CoAxiomRule [Coercion]-    -- AxiomRuleCo is very like AxiomInstCo, but for a CoAxiomRule-    -- The number coercions should match exactly the expectations-    -- of the CoAxiomRule (i.e., the rule is fully saturated).--  | UnivCo UnivCoProvenance Role Type Type-      -- :: _ -> "e" -> _ -> _ -> e--  | SymCo Coercion             -- :: e -> e-  | TransCo Coercion Coercion  -- :: e -> e -> e--  | NthCo  Role Int Coercion     -- Zero-indexed; decomposes (T t0 ... tn)-    -- :: "e" -> _ -> e0 -> e (inverse of TyConAppCo, see Note [TyConAppCo roles])-    -- Using NthCo on a ForAllCo gives an N coercion always-    -- See Note [NthCo and newtypes]-    ---    -- Invariant:  (NthCo r i co), it is always the case that r = role of (Nth i co)-    -- That is: the role of the entire coercion is redundantly cached here.-    -- See Note [NthCo Cached Roles]--  | 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--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---- | 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 [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 TyCoVar 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 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,-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 [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 #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 [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 r 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 [NthCo Cached Roles]-~~~~~~~~~~~~~~~~~~~~~~~~~-Why do we cache the role of NthCo in the NthCo 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 NthCo. 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.---%************************************************************************-%*                                                                      *-                UnivCoProvenance-%*                                                                      *-%************************************************************************--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 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-  = 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.--  | CorePrepProv       -- See Note [Unsafe coercions] in GHC.Core.CoreToStg.Prep-      Bool   -- True  <=> the UnivCo must be homogeneously kinded-             -- False <=> allow hetero-kinded, e.g. Int ~ Int#--  deriving Data.Data--instance Outputable UnivCoProvenance where-  ppr (PhantomProv _)    = text "(phantom)"-  ppr (ProofIrrelProv _) = text "(proof irrel.)"-  ppr (PluginProv str)   = parens (text "plugin" <+> brackets (text str))-  ppr (CorePrepProv _)   = text "(CorePrep)"---- | 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 [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 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 recomoputing 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.---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 co5) Nominal (CoercionTy co1) (CoercionTy co2)-  where-    co5 :: (a1 ~ Bool) ~ (a2 ~ Bool)-    co5 = TyConAppCo Nominal (~#) [<*>, <*>, co4, <Bool>]--}---{- *********************************************************************-*                                                                      *-                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.--}--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 -> ArgFlag -> 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--    -- Explicit recursion because using foldr builds a local-    -- loop (with env free) and I'm not confident it'll be-    -- lambda lifted in the end-    go_tys _   []     = mempty-    go_tys env (t:ts) = go_ty env t `mappend` go_tys env ts--    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 (FunCo _ cw c1 c2)      = go_co env cw `mappend`-                                        go_co env c1 `mappend`-                                        go_co env c2-    go_co env (CoVarCo cv)            = covar env cv-    go_co env (AxiomInstCo _ _ args)  = go_cos env args-    go_co env (HoleCo hole)           = cohole env hole-    go_co env (UnivCo p _ t1 t2)      = go_prov env p `mappend` go_ty env t1-                                                      `mappend` go_ty env t2-    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 (AxiomRuleCo _ cos)     = go_cos env cos-    go_co env (NthCo _ _ 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 (ForAllCo tv 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--    go_prov env (PhantomProv co)    = go_co env co-    go_prov env (ProofIrrelProv co) = go_co env co-    go_prov _   (PluginProv _)      = mempty-    go_prov _   (CorePrepProv _)    = mempty---- | A view function that looks through nothing.-noView :: Type -> Maybe Type-noView _ = Nothing--{- *********************************************************************-*                                                                      *-                   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 (Bndr tv _) t)   = typeSize (varType 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 (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 _ h co)   = 1 + coercionSize co + coercionSize h-coercionSize (FunCo _ w co1 co2) = 1 + coercionSize co1 + coercionSize co2-                                                        + coercionSize w-coercionSize (CoVarCo _)         = 1-coercionSize (HoleCo _)          = 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 (KindCo co)         = 1 + coercionSize co-coercionSize (SubCo co)          = 1 + coercionSize co-coercionSize (AxiomRuleCo _ cs)  = 1 + sum (map coercionSize cs)--provSize :: UnivCoProvenance -> Int-provSize (PhantomProv co)    = 1 + coercionSize co-provSize (ProofIrrelProv co) = 1 + coercionSize co-provSize (PluginProv _)      = 1-provSize (CorePrepProv _)    = 1+{-# LANGUAGE DeriveDataTypeable #-}++{-# OPTIONS_HADDOCK not-home #-}++{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1998+\section[GHC.Core.TyCo.Rep]{Type and Coercion - friends' interface}++Note [The Type-related module hierarchy]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+  GHC.Core.Class+  GHC.Core.Coercion.Axiom+  GHC.Core.TyCon           imports GHC.Core.{Class, Coercion.Axiom}+  GHC.Core.TyCo.Rep        imports GHC.Core.{Class, Coercion.Axiom, TyCon}+  GHC.Core.TyCo.Ppr        imports GHC.Core.TyCo.Rep+  GHC.Core.TyCo.FVs        imports GHC.Core.TyCo.Rep+  GHC.Core.TyCo.Subst      imports GHC.Core.TyCo.{Rep, FVs, Ppr}+  GHC.Core.TyCo.Tidy       imports GHC.Core.TyCo.{Rep, FVs}+  GHC.Builtin.Types.Prim   imports GHC.Core.TyCo.Rep ( including mkTyConTy )+  GHC.Core.Coercion        imports GHC.Core.Type+-}++-- We expose the relevant stuff from this module via the Type module+module GHC.Core.TyCo.Rep (++        -- * Types+        Type(..),++        TyLit(..),+        KindOrType, Kind,+        RuntimeRepType, LevityType,+        KnotTied,+        PredType, ThetaType, FRRType,     -- Synonyms+        ForAllTyFlag(..), FunTyFlag(..),++        -- * Coercions+        Coercion(..), CoSel(..), FunSel(..),+        UnivCoProvenance(..),+        CoercionHole(..), coHoleCoVar, setCoHoleCoVar,+        CoercionN, CoercionR, CoercionP, KindCoercion,+        MCoercion(..), MCoercionR, MCoercionN,++        -- * Functions over types+        mkNakedTyConTy, mkTyVarTy, mkTyVarTys,+        mkTyCoVarTy, mkTyCoVarTys,+        mkFunTy, mkNakedFunTy,+        mkVisFunTy, mkScaledFunTys,+        mkInvisFunTy, mkInvisFunTys,+        tcMkVisFunTy, tcMkInvisFunTy, tcMkScaledFunTy, tcMkScaledFunTys,+        mkForAllTy, mkForAllTys, mkInvisForAllTys,+        mkPiTy, mkPiTys,+        mkVisFunTyMany, mkVisFunTysMany,+        nonDetCmpTyLit, cmpTyLit,++        -- * Functions over coercions+        pickLR,++        -- ** Analyzing types+        TyCoFolder(..), foldTyCo, noView,++        -- * Sizes+        typeSize, typesSize, coercionSize,++        -- * Multiplicities+        Scaled(..), scaledMult, scaledThing, mapScaledType, Mult+    ) where++import GHC.Prelude++import {-# SOURCE #-} GHC.Core.TyCo.Ppr ( pprType, pprCo, pprTyLit )+import {-# SOURCE #-} GHC.Builtin.Types+import {-# SOURCE #-} GHC.Core.TyCo.FVs( tyCoVarsOfType ) -- Use in assertions+import {-# SOURCE #-} GHC.Core.Type( chooseFunTyFlag, typeKind, typeTypeOrConstraint )++   -- Transitively pulls in a LOT of stuff, better to break the loop++-- friends:+import GHC.Types.Var+import GHC.Types.Var.Set( elemVarSet )+import GHC.Core.TyCon+import GHC.Core.Coercion.Axiom++-- others+import GHC.Builtin.Names++import GHC.Types.Basic ( LeftOrRight(..), pickLR )+import GHC.Utils.Outputable+import GHC.Data.FastString+import GHC.Utils.Misc+import GHC.Utils.Panic+import GHC.Utils.Binary++-- libraries+import qualified Data.Data as Data hiding ( TyCon )+import Data.IORef ( IORef )   -- for CoercionHole+import Control.DeepSeq++{- **********************************************************************+*                                                                       *+                        Type+*                                                                       *+********************************************************************** -}++-- | The key representation of types within the compiler++type KindOrType = Type -- See Note [Arguments to type constructors]++-- | The key type representing kinds in the compiler.+type Kind = Type++-- | Type synonym used for types of kind RuntimeRep.+type RuntimeRepType = Type++-- | Type synonym used for types of kind Levity.+type LevityType = Type++-- A type with a syntactically fixed RuntimeRep, in the sense+-- of Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete.+type FRRType = Type++-- If you edit this type, you may need to update the GHC formalism+-- See Note [GHC Formalism] in GHC.Core.Lint+data Type+  -- See Note [Non-trivial definitional equality]+  = TyVarTy Var -- ^ Vanilla type or kind variable (*never* a coercion variable)++  | AppTy+        Type+        Type            -- ^ Type application to something other than a 'TyCon'. Parameters:+                        --+                        --  1) Function: must /not/ be a 'TyConApp' or 'CastTy',+                        --     must be another 'AppTy', or 'TyVarTy'+                        --     See Note [Respecting definitional equality] \(EQ1) about the+                        --     no 'CastTy' requirement+                        --+                        --  2) Argument type++  | TyConApp+        TyCon+        [KindOrType]    -- ^ Application of a 'TyCon', including newtypes /and/ synonyms.+                        -- Invariant: saturated applications of 'FunTyCon' must+                        -- use 'FunTy' and saturated synonyms must use their own+                        -- constructors. However, /unsaturated/ 'FunTyCon's+                        -- do appear as 'TyConApp's.+                        -- Parameters:+                        --+                        -- 1) Type constructor being applied to.+                        --+                        -- 2) Type arguments. Might not have enough type arguments+                        --    here to saturate the constructor.+                        --    Even type synonyms are not necessarily saturated;+                        --    for example unsaturated type synonyms+                        --    can appear as the right hand side of a type synonym.++  | ForAllTy  -- See Note [ForAllTy]+        {-# UNPACK #-} !ForAllTyBinder+           -- ForAllTyBinder: see GHC.Types.Var+           --    Note [VarBndrs, ForAllTyBinders, TyConBinders, and visibility]+        Type+           -- INVARIANT: If the binder is a coercion variable, it must+           --            be mentioned in the Type.+           --            See Note [Unused coercion variable in ForAllTy]+           -- See Note [Why ForAllTy can quantify over a coercion variable]++  | FunTy      -- ^ FUN m t1 t2   Very common, so an important special case+                -- See Note [Function types]+     { ft_af   :: FunTyFlag    -- Is this (->/FUN) or (=>) or (==>)?+                                 -- This info is fully specified by the kinds in+                                 --      ft_arg and ft_res+                                 -- Note [FunTyFlag] in GHC.Types.Var++     , ft_mult :: Mult           -- Multiplicity; always Many for (=>) and (==>)+     , ft_arg  :: Type           -- Argument type+     , ft_res  :: Type }         -- Result type++  | LitTy TyLit     -- ^ Type literals are similar to type constructors.++  | CastTy+        Type+        KindCoercion  -- ^ A kind cast. The coercion is always nominal.+                      -- INVARIANT: The cast is never reflexive \(EQ2)+                      -- INVARIANT: The Type is not a CastTy (use TransCo instead) \(EQ3)+                      -- INVARIANT: The Type is not a ForAllTy over a tyvar \(EQ4)+                      -- See Note [Respecting definitional equality]++  | CoercionTy+        Coercion    -- ^ Injection of a Coercion into a type+                    -- This should only ever be used in the RHS of an AppTy,+                    -- in the list of a TyConApp, when applying a promoted+                    -- GADT data constructor++  deriving Data.Data++instance Outputable Type where+  ppr = pprType++-- NOTE:  Other parts of the code assume that type literals do not contain+-- types or type variables.+data TyLit+  = NumTyLit Integer+  | StrTyLit FastString+  | CharTyLit Char+  deriving (Eq, Data.Data)++-- Non-determinism arises due to uniqCompareFS+nonDetCmpTyLit :: TyLit -> TyLit -> Ordering+nonDetCmpTyLit = cmpTyLitWith NonDetFastString++-- Slower than nonDetCmpTyLit but deterministic+cmpTyLit :: TyLit -> TyLit -> Ordering+cmpTyLit = cmpTyLitWith LexicalFastString++{-# INLINE cmpTyLitWith #-}+cmpTyLitWith :: Ord r => (FastString -> r) -> TyLit -> TyLit -> Ordering+cmpTyLitWith _ (NumTyLit  x) (NumTyLit  y) = compare x y+cmpTyLitWith w (StrTyLit  x) (StrTyLit  y) = compare (w x) (w y)+cmpTyLitWith _ (CharTyLit x) (CharTyLit y) = compare x y+cmpTyLitWith _ a b = compare (tag a) (tag b)+  where+    tag :: TyLit -> Int+    tag NumTyLit{}  = 0+    tag StrTyLit{}  = 1+    tag CharTyLit{} = 2++instance Outputable TyLit where+   ppr = pprTyLit++{- Note [Function types]+~~~~~~~~~~~~~~~~~~~~~~~~+FunTy is the constructor for a function type.  Here are the details:++* The primitive function type constructor FUN has kind+     FUN :: forall (m :: Multiplicity) ->+            forall {r1 :: RuntimeRep} {r2 :: RuntimeRep}.+            TYPE r1 ->+            TYPE r2 ->+            Type+  mkTyConApp ensures that we convert a saturated application+    TyConApp FUN [m,r1,r2,t1,t2] into FunTy FTF_T_T m t1 t2+  dropping the 'r1' and 'r2' arguments; they are easily recovered+  from 't1' and 't2'. The FunTyFlag is always FTF_T_T, because+  we build constraint arrows (=>) with e.g. mkPhiTy and friends,+  never `mkTyConApp funTyCon args`.++* For the time being its RuntimeRep quantifiers are left+  inferred. This is to allow for it to evolve.++* Because the RuntimeRep args came first historically (that is,+  the arrow type constructor gained these arguments before gaining+  the Multiplicity argument), we wanted to be able to say+    type (->) = FUN Many+  which we do in library module GHC.Types. This means that the+  Multiplicity argument must precede the RuntimeRep arguments --+  and it means changing the name of the primitive constructor from+  (->) to FUN.++* The multiplicity argument is dependent, because Typeable does not+  support a type such as `Multiplicity -> forall {r1 r2 :: RuntimeRep}. ...`.+  There is a plan to change the argument order and make the+  multiplicity argument nondependent in #20164.++* Re the ft_af field: see Note [FunTyFlag] in GHC.Types.Var+  See Note [Types for coercions, predicates, and evidence] in+  GHC.Core.Predicate.  This visibility info makes no difference in Core;+  it matter only when we regard the type as a Haskell source type.++Note [Weird typing rule for ForAllTy]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Here are the typing rules for ForAllTy:++tyvar : Type+inner : TYPE r+tyvar does not occur in r+------------------------------------+ForAllTy (Bndr tyvar vis) inner : TYPE r++inner : TYPE r+------------------------------------+ForAllTy (Bndr covar vis) inner : Type++Note that the kind of the result depends on whether the binder is a+tyvar or a covar. The kind of a forall-over-tyvar is the same as+the kind of the inner type. This is because quantification over types+is erased before runtime. By contrast, the kind of a forall-over-covar+is always Type, because a forall-over-covar is compiled into a function+taking a 0-bit-wide erased coercion argument.++Because the tyvar form above includes r in its result, we must+be careful not to let any variables escape -- thus the last premise+of the rule above.++Note [Arguments to type constructors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Because of kind polymorphism, in addition to type application we now+have kind instantiation. We reuse the same notations to do so.++For example:++  Just (* -> *) Maybe+  Right * Nat Zero++are represented by:++  TyConApp (PromotedDataCon Just) [* -> *, Maybe]+  TyConApp (PromotedDataCon Right) [*, Nat, (PromotedDataCon Zero)]++Important note: Nat is used as a *kind* and not as a type. This can be+confusing, since type-level Nat and kind-level Nat are identical. We+use the kind of (PromotedDataCon Right) to know if its arguments are+kinds or types.++This kind instantiation only happens in TyConApp currently.++Note [Non-trivial definitional equality]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Is ((IO |> co1) Int |> co2) equal to (IO Int)?+Assume+   co1 :: (Type->Type) ~ (Type->Wombat)+   co2 :: Wombat ~ Type+Well, yes.  The casts are just getting in the way.+See also Note [Respecting definitional equality].++So we do this:++(EQTYPE)+  The `eqType` function, which defines Core's type equality relation,+  - /ignores/ casts, and+  - /ignores/ coercion arguments+  - /provided/ two types have the same kind++This allows us to be a little sloppier in keeping track of coercions, which is a+good thing. It also means that eqType does not depend on eqCoercion, which is+also a good thing.++Why is this sensible? That is, why is something different than α-equivalence+appropriate for the implementation of eqType?++Anything smaller than ~ and homogeneous is an appropriate definition for+equality. The type safety of FC depends only on ~. Let's say η : τ ~ σ. Any+expression of type τ can be transmuted to one of type σ at any point by+casting. The same is true of expressions of type σ. So in some sense, τ and σ+are interchangeable.++But let's be more precise. If we examine the typing rules of FC (say, those in+https://richarde.dev/papers/2015/equalities/equalities.pdf)+there are several places where the same metavariable is used in two different+premises to a rule. (For example, see Ty_App.) There is an implicit equality+check here. What definition of equality should we use? By convention, we use+α-equivalence. Take any rule with one (or more) of these implicit equality+checks. Then there is an admissible rule that uses ~ instead of the implicit+check, adding in casts as appropriate.++The only problem here is that ~ is heterogeneous. To make the kinds work out+in the admissible rule that uses ~, it is necessary to homogenize the+coercions. That is, if we have η : (τ : κ1) ~ (σ : κ2), then we don't use η;+we use η |> kind η, which is homogeneous.++The effect of this all is that eqType, the implementation of the implicit+equality check, can use any homogeneous relation that is smaller than ~, as+those rules must also be admissible.++A more drawn out argument around all of this is presented in Section 7.2 of+Richard E's thesis (http://richarde.dev/papers/2016/thesis/eisenberg-thesis.pdf).++What would go wrong if we insisted on the casts matching? See the beginning of+Section 8 in the unpublished paper above. Theoretically, nothing at all goes+wrong. But in practical terms, getting the coercions right proved to be+nightmarish. And types would explode: during kind-checking, we often produce+reflexive kind coercions. When we try to cast by these, mkCastTy just discards+them. But if we used an eqType that distinguished between Int and Int |> <*>,+then we couldn't discard -- the output of kind-checking would be enormous,+and we would need enormous casts with lots of CoherenceCo's to straighten+them out.++Would anything go wrong if eqType looked through type families? No, not at+all. But that makes eqType rather hard to implement.++Thus, the guideline for eqType is that it should be the largest+easy-to-implement relation that is still smaller than ~ and homogeneous. The+precise choice of relation is somewhat incidental, as long as the smart+constructors and destructors in Type respect whatever relation is chosen.++Another helpful principle with eqType is this:++ (EQ) If (t1 `eqType` t2) then I can replace t1 by t2 anywhere.++This principle also tells us that eqType must relate only types with the+same kinds.++Interestingly, it must be the case that the free variables of t1 and t2+might be different, even if t1 `eqType` t2. A simple example of this is+if we have both cv1 :: k1 ~ k2 and cv2 :: k1 ~ k2 in the environment.+Then t1 = t |> cv1 and t2 = t |> cv2 are eqType; yet cv1 is in the free+vars of t1 and cv2 is in the free vars of t2. Unless we choose to implement+eqType to be just α-equivalence, this wrinkle around free variables+remains.++Yet not all is lost: we can say that any two equal types share the same+*relevant* free variables. Here, a relevant variable is a shallow+free variable (see Note [Shallow and deep free variables] in GHC.Core.TyCo.FVs)+that does not appear within a coercion. Note that type variables can+appear within coercions (in, say, a Refl node), but that coercion variables+cannot appear outside a coercion. We do not (yet) have a function to+extract relevant free variables, but it would not be hard to write if+the need arises.++Note [Respecting definitional equality]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Note [Non-trivial definitional equality] introduces the property (EQ).+How is this upheld?++Any function that pattern matches on all the constructors will have to+consider the possibility of CastTy. Presumably, those functions will handle+CastTy appropriately and we'll be OK.++More dangerous are the splitXXX functions. Let's focus on splitTyConApp.+We don't want it to fail on (T a b c |> co). Happily, if we have+  (T a b c |> co) `eqType` (T d e f)+then co must be reflexive. Why? eqType checks that the kinds are equal, as+well as checking that (a `eqType` d), (b `eqType` e), and (c `eqType` f).+By the kind check, we know that (T a b c |> co) and (T d e f) have the same+kind. So the only way that co could be non-reflexive is for (T a b c) to have+a different kind than (T d e f). But because T's kind is closed (all tycon kinds+are closed), the only way for this to happen is that one of the arguments has+to differ, leading to a contradiction. Thus, co is reflexive.++Accordingly, by eliminating reflexive casts, splitTyConApp need not worry+about outermost casts to uphold (EQ). Eliminating reflexive casts is done+in mkCastTy. This is (EQ2) below.++Unfortunately, that's not the end of the story. Consider comparing+  (T a b c)      =?       (T a b |> (co -> <Type>)) (c |> co)+These two types have the same kind (Type), but the left type is a TyConApp+while the right type is not. To handle this case, we say that the right-hand+type is ill-formed, requiring an AppTy never to have a casted TyConApp+on its left. It is easy enough to pull around the coercions to maintain+this invariant, as done in Type.mkAppTy. In the example above, trying to+form the right-hand type will instead yield (T a b (c |> co |> sym co) |> <Type>).+Both the casts there are reflexive and will be dropped. Huzzah.++This idea of pulling coercions to the right works for splitAppTy as well.++However, there is one hiccup: it's possible that a coercion doesn't relate two+Pi-types. For example, if we have @type family Fun a b where Fun a b = a -> b@,+then we might have (T :: Fun Type Type) and (T |> axFun) Int. That axFun can't+be pulled to the right. But we don't need to pull it: (T |> axFun) Int is not+`eqType` to any proper TyConApp -- thus, leaving it where it is doesn't violate+our (EQ) property.++In order to detect reflexive casts reliably, we must make sure not+to have nested casts: we update (t |> co1 |> co2) to (t |> (co1 `TransCo` co2)).+This is (EQ3) below.++One other troublesome case is ForAllTy. See Note [Weird typing rule for ForAllTy].+The kind of the body is the same as the kind of the ForAllTy. Accordingly,++  ForAllTy tv (ty |> co)     and     (ForAllTy tv ty) |> co++are `eqType`. But only the first can be split by splitForAllTy. So we forbid+the second form, instead pushing the coercion inside to get the first form.+This is done in mkCastTy.++In sum, in order to uphold (EQ), we need the following invariants:++  (EQ1) No decomposable CastTy to the left of an AppTy,+        where a "decomposable cast" is one that relates+        either a FunTy to a FunTy, or a ForAllTy to a ForAllTy.+  (EQ2) No reflexive casts in CastTy.+  (EQ3) No nested CastTys.+  (EQ4) No CastTy over (ForAllTy (Bndr tyvar vis) body).+        See Note [Weird typing rule for ForAllTy]++These invariants are all documented above, in the declaration for Type.++Note [Equality on FunTys]+~~~~~~~~~~~~~~~~~~~~~~~~~+A (FunTy vis mult arg res) is just an abbreviation for a+  TyConApp funTyCon [mult, arg_rep, res_rep, arg, res]+where+  arg :: TYPE arg_rep+  res :: TYPE res_rep+Note that the vis field of a FunTy appears nowhere in the+equivalent TyConApp. In Core, this is OK, because we no longer+care about the visibility of the argument in a FunTy+(the vis distinguishes between arg -> res and arg => res).+In the type-checker, we are careful not to decompose FunTys+with an invisible argument. See also Note [Decomposing fat arrow c=>t]+in GHC.Core.Type.++In order to compare FunTys while respecting how they could+expand into TyConApps, we must check+the kinds of the arg and the res.++Note [ForAllTy]+~~~~~~~~~~~~~~~+A (ForAllTy (Bndr tcv vis) ty) can quantify over a TyVar or, less commonly, a CoVar.+See Note [Why ForAllTy can quantify over a coercion variable] for why we need the latter.++(FT1) Invariant: See Note [Weird typing rule for ForAllTy]++(FT2) Invariant: in (ForAllTy (Bndr tcv vis) ty),+      if tcv is a CoVar, then vis = coreTyLamForAllTyFlag.+   Visibility is not important for coercion abstractions,+   because they are not user-visible.++(FT3) Invariant: see Note [Unused coercion variable in ForAllTy]++Note [Why ForAllTy can quantify over a coercion variable]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The ForAllTyBinder in a ForAllTy can be (most often) a TyVar or (rarely)+a CoVar. We support quantifying over a CoVar here in order to support+a homogeneous (~#) relation (someday -- not yet implemented). Here is+the example:++  type (:~~:) :: forall k1 k2. k1 -> k2 -> Type+  data a :~~: b where+    HRefl :: a :~~: a++Assuming homogeneous equality (that is, with+  (~#) :: forall k. k -> k -> TYPE (TupleRep '[])+) after rejigging to make equalities explicit, we get a constructor that+looks like++  HRefl :: forall k1 k2 (a :: k1) (b :: k2).+           forall (cv :: k1 ~# k2). (a |> cv) ~# b+        => (:~~:) k1 k2 a b++Note that we must cast `a` by a cv bound in the same type in order to+make this work out.++See also https://gitlab.haskell.org/ghc/ghc/-/wikis/dependent-haskell/phase2+which gives a general road map that covers this space.  Having this feature in+Core does *not* mean we have it in source Haskell.  See #15710 about that.++Note [Unused coercion variable in ForAllTy]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have+  \(co:t1 ~# t2). e++What type should we give to the above expression?+  (1) forall (co:t1 ~# t2) -> t+  (2) (t1 ~# t2) -> t++If co is used in t, (1) should be the right choice.+if co is not used in t, we would like to have (1) and (2) equivalent.++However, we want to keep eqType simple and don't want eqType (1) (2) to return+True in any case.++We decide to always construct (2) if co is not used in t.++Thus in mkLamType, we check whether the variable is a coercion+variable (of type (t1 ~# t2), and whether it is un-used in the+body. If so, it returns a FunTy instead of a ForAllTy.++There are cases we want to skip the check. For example, the check is+unnecessary when it is known from the context that the input variable+is a type variable.  In those cases, we use mkForAllTy.++Note [Weird typing rule for ForAllTy]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Here is the (truncated) typing rule for the dependent ForAllTy:++  inner : TYPE r+  tyvar is not free in r+  ----------------------------------------+  ForAllTy (Bndr tyvar vis) inner : TYPE r++Note that the kind of `inner` is the kind of the overall ForAllTy. This is+necessary because every ForAllTy over a type variable is erased at runtime.+Thus the runtime representation of a ForAllTy (as encoded, via TYPE rep, in+the kind) must be the same as the representation of the body. We must check+for skolem-escape, though. The skolem-escape would prevent a definition like++  undefined :: forall (r :: RuntimeRep) (a :: TYPE r). a++because the type's kind (TYPE r) mentions the out-of-scope r. Luckily, the real+type of undefined is++  undefined :: forall (r :: RuntimeRep) (a :: TYPE r). HasCallStack => a++and that HasCallStack constraint neatly sidesteps the potential skolem-escape+problem.++If the bound variable is a coercion variable:++  inner : TYPE r+  covar is free in inner+  ------------------------------------+  ForAllTy (Bndr covar vis) inner : Type++Here, the kind of the ForAllTy is just Type, because coercion abstractions+are *not* erased. The "covar is free in inner" premise is solely to maintain+the representation invariant documented in+Note [Unused coercion variable in ForAllTy]. Though there is surface similarity+between this free-var check and the one in the tyvar rule, these two restrictions+are truly unrelated.++-}++-- | A type labeled 'KnotTied' might have knot-tied tycons in it. See+-- Note [Type checking recursive type and class declarations] in+-- "GHC.Tc.TyCl"+type KnotTied ty = ty++{- **********************************************************************+*                                                                       *+                        PredType+*                                                                       *+********************************************************************** -}+++-- | A type of the form @p@ of constraint kind represents a value whose type is+-- the Haskell predicate @p@, where a predicate is what occurs before+-- the @=>@ in a Haskell type.+--+-- We use 'PredType' as documentation to mark those types that we guarantee to+-- have this kind.+--+-- It can be expanded into its representation, but:+--+-- * The type checker must treat it as opaque+--+-- * The rest of the compiler treats it as transparent+--+-- Consider these examples:+--+-- > f :: (Eq a) => a -> Int+-- > g :: (?x :: Int -> Int) => a -> Int+-- > h :: (r\l) => {r} => {l::Int | r}+--+-- Here the @Eq a@ and @?x :: Int -> Int@ and @r\l@ are all called \"predicates\"+type PredType = Type++-- | A collection of 'PredType's+type ThetaType = [PredType]++{-+(We don't support TREX records yet, but the setup is designed+to expand to allow them.)++A Haskell qualified type, such as that for f,g,h above, is+represented using+        * a FunTy for the double arrow+        * with a type of kind Constraint as the function argument++The predicate really does turn into a real extra argument to the+function.  If the argument has type (p :: Constraint) then the predicate p is+represented by evidence of type p.+++%************************************************************************+%*                                                                      *+            Simple constructors+%*                                                                      *+%************************************************************************++These functions are here so that they can be used by GHC.Builtin.Types.Prim,+which in turn is imported by Type+-}++mkTyVarTy  :: TyVar   -> Type+mkTyVarTy v = assertPpr (isTyVar v) (ppr v <+> dcolon <+> ppr (tyVarKind v)) $+              TyVarTy v++mkTyVarTys :: [TyVar] -> [Type]+mkTyVarTys = map mkTyVarTy -- a common use of mkTyVarTy++mkTyCoVarTy :: TyCoVar -> Type+mkTyCoVarTy v+  | isTyVar v+  = TyVarTy v+  | otherwise+  = CoercionTy (CoVarCo v)++mkTyCoVarTys :: [TyCoVar] -> [Type]+mkTyCoVarTys = map mkTyCoVarTy++infixr 3 `mkFunTy`, `mkInvisFunTy`, `mkVisFunTyMany`++mkNakedFunTy :: FunTyFlag -> Kind -> Kind -> Kind+-- See Note [Naked FunTy] in GHC.Builtin.Types+-- Always Many multiplicity; kinds have no linearity+mkNakedFunTy af arg res+ =  FunTy { ft_af   = af, ft_mult = manyDataConTy+          , ft_arg  = arg, ft_res  = res }++mkFunTy :: HasDebugCallStack => FunTyFlag -> Mult -> Type -> Type -> Type+mkFunTy af mult arg res+  = assertPpr (af == chooseFunTyFlag arg res) (vcat+      [ text "af" <+> ppr af+      , text "chooseAAF" <+> ppr (chooseFunTyFlag arg res)+      , text "arg" <+> ppr arg <+> dcolon <+> ppr (typeKind arg)+      , text "res" <+> ppr res <+> dcolon <+> ppr (typeKind res) ]) $+    FunTy { ft_af   = af+          , ft_mult = mult+          , ft_arg  = arg+          , ft_res  = res }++mkInvisFunTy :: HasDebugCallStack => Type -> Type -> Type+mkInvisFunTy arg res+  = mkFunTy (invisArg (typeTypeOrConstraint res)) manyDataConTy arg res++mkInvisFunTys :: HasDebugCallStack => [Type] -> Type -> Type+mkInvisFunTys args res+  = foldr (mkFunTy af manyDataConTy) res args+  where+    af = invisArg (typeTypeOrConstraint res)++mkVisFunTy :: HasDebugCallStack => Mult -> Type -> Type -> Type+-- Always TypeLike, user-specified multiplicity.+mkVisFunTy = mkFunTy visArgTypeLike++-- | Make nested arrow types+-- | Special, common, case: Arrow type with mult Many+mkVisFunTyMany :: HasDebugCallStack => Type -> Type -> Type+-- Always TypeLike, multiplicity Many+mkVisFunTyMany = mkVisFunTy manyDataConTy++mkVisFunTysMany :: [Type] -> Type -> Type+-- Always TypeLike, multiplicity Many+mkVisFunTysMany tys ty = foldr mkVisFunTyMany ty tys++---------------+mkScaledFunTy :: HasDebugCallStack => FunTyFlag -> Scaled Type -> Type -> Type+mkScaledFunTy af (Scaled mult arg) res = mkFunTy af mult arg res++mkScaledFunTys :: HasDebugCallStack => [Scaled Type] -> Type -> Type+-- All visible args+-- Result type can be TypeLike or ConstraintLike+-- Example of the latter: dataConWrapperType for the data con of a class+mkScaledFunTys tys ty = foldr (mkScaledFunTy af) ty tys+  where+    af = visArg (typeTypeOrConstraint ty)++---------------+-- | Like 'mkTyCoForAllTy', but does not check the occurrence of the binder+-- See Note [Unused coercion variable in ForAllTy]+mkForAllTy :: ForAllTyBinder -> Type -> Type+mkForAllTy bndr body+  = assertPpr (good_bndr bndr) (ppr bndr <+> ppr body) $+    ForAllTy bndr body+  where+    -- Check ForAllTy invariants+    good_bndr (Bndr cv vis)+      | isCoVar cv = vis == coreTyLamForAllTyFlag+                     -- See (FT2) in Note [ForAllTy]+                  && (cv `elemVarSet` tyCoVarsOfType body)+                     -- See (FT3) in Note [ForAllTy]+      | otherwise = True++-- | Wraps foralls over the type using the provided 'TyCoVar's from left to right+mkForAllTys :: [ForAllTyBinder] -> Type -> Type+mkForAllTys tyvars ty = foldr ForAllTy ty tyvars++-- | Wraps foralls over the type using the provided 'InvisTVBinder's from left to right+mkInvisForAllTys :: [InvisTVBinder] -> Type -> Type+mkInvisForAllTys tyvars = mkForAllTys (tyVarSpecToBinders tyvars)++mkPiTy :: HasDebugCallStack => PiTyBinder -> Type -> Type+mkPiTy (Anon ty1 af) ty2  = mkScaledFunTy af ty1 ty2+mkPiTy (Named bndr) ty    = mkForAllTy bndr ty++mkPiTys :: HasDebugCallStack => [PiTyBinder] -> Type -> Type+mkPiTys tbs ty = foldr mkPiTy ty tbs++-- | 'mkNakedTyConTy' creates a nullary 'TyConApp'. In general you+-- should rather use 'GHC.Core.Type.mkTyConTy', which picks the shared+-- nullary TyConApp from inside the TyCon (via tyConNullaryTy.  But+-- we have to build the TyConApp tc [] in that TyCon field; that's+-- what 'mkNakedTyConTy' is for.+mkNakedTyConTy :: TyCon -> Type+mkNakedTyConTy tycon = TyConApp tycon []++tcMkVisFunTy :: Mult -> Type -> Type -> Type+-- Always TypeLike result, user-specified multiplicity.+-- Does not have the assert-checking in mkFunTy: used by the typechecker+-- to avoid looking at the result kind, which may not be zonked+tcMkVisFunTy mult arg res+  = FunTy { ft_af = visArgTypeLike, ft_mult = mult+          , ft_arg = arg, ft_res = res }++tcMkInvisFunTy :: TypeOrConstraint -> Type -> Type -> Type+-- Always invisible (constraint) argument, result specified by res_torc+-- Does not have the assert-checking in mkFunTy: used by the typechecker+-- to avoid looking at the result kind, which may not be zonked+tcMkInvisFunTy res_torc arg res+  = FunTy { ft_af = invisArg res_torc, ft_mult = manyDataConTy+          , ft_arg = arg, ft_res = res }++tcMkScaledFunTys :: [Scaled Type] -> Type -> Type+-- All visible args+-- Result type must be TypeLike+-- No mkFunTy assert checking; result kind may not be zonked+tcMkScaledFunTys tys ty = foldr tcMkScaledFunTy ty tys++tcMkScaledFunTy :: Scaled Type -> Type -> Type+tcMkScaledFunTy (Scaled mult arg) res = tcMkVisFunTy mult arg res++{-+%************************************************************************+%*                                                                      *+            Coercions+%*                                                                      *+%************************************************************************+-}++-- | A 'Coercion' is concrete evidence of the equality/convertibility+-- of two types.++-- If you edit this type, you may need to update the GHC formalism+-- See Note [GHC Formalism] in GHC.Core.Lint+data Coercion+  -- Each constructor has a "role signature", indicating the way roles are+  -- propagated through coercions.+  --    -  P, N, and R stand for coercions of the given role+  --    -  e stands for a coercion of a specific unknown role+  --           (think "role polymorphism")+  --    -  "e" stands for an explicit role parameter indicating role e.+  --    -   _ stands for a parameter that is not a Role or Coercion.++  -- These ones mirror the shape of types+  = -- Refl :: _ -> N+    -- A special case reflexivity for a very common case: Nominal reflexivity+    -- If you need Representational, use (GRefl Representational ty MRefl)+    --                               not (SubCo (Refl ty))+    Refl Type  -- See Note [Refl invariant]++  -- GRefl :: "e" -> _ -> Maybe N -> e+  -- See Note [Generalized reflexive coercion]+  | GRefl Role Type MCoercionN  -- See Note [Refl invariant]+          -- Use (Refl ty), not (GRefl Nominal ty MRefl)+          -- Use (GRefl Representational _ _), not (SubCo (GRefl Nominal _ _))++  -- These ones simply lift the correspondingly-named+  -- Type constructors into Coercions++  -- TyConAppCo :: "e" -> _ -> ?? -> e+  -- See Note [TyConAppCo roles]+  | TyConAppCo Role TyCon [Coercion]    -- lift TyConApp+               -- The TyCon is never a synonym;+               -- we expand synonyms eagerly+               -- But it can be a type function+               -- TyCon is never a saturated (->); use FunCo instead++  | AppCo Coercion CoercionN             -- lift AppTy+          -- AppCo :: e -> N -> e++  -- See Note [ForAllCo]+  | ForAllCo+      { fco_tcv  :: TyCoVar+      , fco_visL :: !ForAllTyFlag -- Visibility of coercionLKind+      , fco_visR :: !ForAllTyFlag -- Visibility of coercionRKind+                                  -- See (FC7) of Note [ForAllCo]+      , fco_kind :: KindCoercion+      , fco_body :: Coercion }+         -- ForAllCo :: _ -> N -> e -> e++  | FunCo  -- FunCo :: "e" -> N/P -> e -> e -> e+           -- See Note [FunCo] for fco_afl, fco_afr+        { fco_role         :: Role+        , fco_afl          :: FunTyFlag   -- Arrow for coercionLKind+        , fco_afr          :: FunTyFlag   -- Arrow for coercionRKind+        , fco_mult         :: CoercionN+        , fco_arg, fco_res :: Coercion }+       -- (if the role "e" is Phantom, the first coercion is, too)+       -- the first coercion is for the multiplicity++  -- These are special+  | CoVarCo CoVar      -- :: _ -> (N or R)+                       -- result role depends on the tycon of the variable's type++  | AxiomCo CoAxiomRule [Coercion]+     -- The coercion arguments always *precisely* saturate+     -- arity of (that branch of) the CoAxiom. If there are+     -- any left over, we use AppCo.+     -- See [Coercion axioms applied to coercions]+     -- The roles of the argument coercions are determined+     -- by the cab_roles field of the relevant branch of the CoAxiom++  | UnivCo  -- See Note [UnivCo]+            -- Of kind (lty ~role rty)+      { uco_prov         :: UnivCoProvenance+      , uco_role         :: Role+      , uco_lty, uco_rty :: Type+      , uco_deps         :: [Coercion]  -- Coercions on which it depends+               --   See Note [The importance of tracking UnivCo dependencies]+      }++  | SymCo Coercion             -- :: e -> e+  | TransCo Coercion Coercion  -- :: e -> e -> e++  | SelCo CoSel Coercion  -- See Note [SelCo]++  | LRCo   LeftOrRight CoercionN     -- Decomposes (t_left t_right)+    -- :: _ -> N -> N+  | InstCo Coercion CoercionN+    -- :: e -> N -> e+    -- See Note [InstCo roles]++  -- Extract a kind coercion from a (heterogeneous) type coercion+  -- NB: all kind coercions are Nominal+  | KindCo Coercion+     -- :: e -> N++  | SubCo CoercionN                  -- Turns a ~N into a ~R+    -- :: N -> R++  | HoleCo CoercionHole              -- ^ See Note [Coercion holes]+                                     -- Only present during typechecking+  deriving Data.Data++data CoSel  -- See Note [SelCo]+  = SelTyCon Int Role  -- Decomposes (T co1 ... con); zero-indexed+                       -- Invariant: Given: SelCo (SelTyCon i r) co+                       --            we have r == tyConRole (coercionRole co) tc+                       --                and tc1 == tc2+                       --            where T tc1 _ = coercionLKind co+                       --                  T tc2 _ = coercionRKind co+                       -- See Note [SelCo]++  | SelFun FunSel      -- Decomposes (co1 -> co2)++  | SelForAll          -- Decomposes (forall a. co)++  deriving( Eq, Data.Data, Ord )++data FunSel  -- See Note [SelCo]+  = SelMult  -- Multiplicity+  | SelArg   -- Argument of function+  | SelRes   -- Result of function+  deriving( Eq, Data.Data, Ord )++type CoercionN = Coercion       -- always nominal+type CoercionR = Coercion       -- always representational+type CoercionP = Coercion       -- always phantom+type KindCoercion = CoercionN   -- always nominal++instance Outputable Coercion where+  ppr = pprCo++instance Outputable CoSel where+  ppr (SelTyCon n r) = text "Tc" <> parens (int n <> comma <> pprOneCharRole r)+  ppr SelForAll      = text "All"+  ppr (SelFun fs)    = text "Fun" <> parens (ppr fs)++pprOneCharRole :: Role -> SDoc+pprOneCharRole Nominal          = char 'N'+pprOneCharRole Representational = char 'R'+pprOneCharRole Phantom          = char 'P'++instance Outputable FunSel where+  ppr SelMult = text "mult"+  ppr SelArg  = text "arg"+  ppr SelRes  = text "res"++instance NFData FunSel where+  rnf SelMult = ()+  rnf SelArg  = ()+  rnf SelRes  = ()++instance Binary CoSel where+   put_ bh (SelTyCon n r)   = do { putByte bh 0; put_ bh n; put_ bh r }+   put_ bh SelForAll        = putByte bh 1+   put_ bh (SelFun SelMult) = putByte bh 2+   put_ bh (SelFun SelArg)  = putByte bh 3+   put_ bh (SelFun SelRes)  = putByte bh 4++   get bh = do { h <- getByte bh+               ; case h of+                   0 -> do { n <- get bh; r <- get bh; return (SelTyCon n r) }+                   1 -> return SelForAll+                   2 -> return (SelFun SelMult)+                   3 -> return (SelFun SelArg)+                   _ -> return (SelFun SelRes) }++instance NFData CoSel where+  rnf (SelTyCon n r) = rnf n `seq` rnf r `seq` ()+  rnf SelForAll      = ()+  rnf (SelFun fs)    = rnf fs `seq` ()++-- | A semantically more meaningful type to represent what may or may not be a+-- useful 'Coercion'.+data MCoercion+  = MRefl+    -- A trivial Reflexivity coercion+  | MCo Coercion+    -- Other coercions+  deriving Data.Data+type MCoercionR = MCoercion+type MCoercionN = MCoercion++instance Outputable MCoercion where+  ppr MRefl    = text "MRefl"+  ppr (MCo co) = text "MCo" <+> ppr co++{- Note [Refl invariant]+~~~~~~~~~~~~~~~~~~~~~~~~+Invariant 1: Refl lifting+        Refl (similar for GRefl r ty MRefl) is always lifted as far as possible.+    For example+        (Refl T) (Refl a) (Refl b) is normalised (by mkAppCo) to  (Refl (T a b)).++    You might think that a consequences is:+         Every identity coercion has Refl at the root++    But that's not quite true because of coercion variables.  Consider+         g         where g :: Int~Int+         Left h    where h :: Maybe Int ~ Maybe Int+    etc.  So the consequence is only true of coercions that+    have no coercion variables.++Invariant 2: TyConAppCo+   An application of (Refl T) to some coercions, at least one of which is+   NOT the identity, is normalised to TyConAppCo.  (They may not be+   fully saturated however.)  TyConAppCo coercions (like all coercions+   other than Refl) are NEVER the identity.++Note [Generalized reflexive coercion]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+GRefl is a generalized reflexive coercion (see #15192). It wraps a kind+coercion, which might be reflexive (MRefl) or any coercion (MCo co). The typing+rules for GRefl:++  ty : k1+  ------------------------------------+  GRefl r ty MRefl: ty ~r ty++  ty : k1       co :: k1 ~ k2+  ------------------------------------+  GRefl r ty (MCo co) : ty ~r ty |> co++Consider we have++   g1 :: s ~r t+   s  :: k1+   g2 :: k1 ~ k2++and we want to construct a coercions co which has type++   (s |> g2) ~r t++We can define++   co = Sym (GRefl r s g2) ; g1++It is easy to see that++   Refl == GRefl Nominal ty MRefl :: ty ~n ty++A nominal reflexive coercion is quite common, so we keep the special form Refl to+save allocation.++Note [SelCo]+~~~~~~~~~~~~+The Coercion form SelCo allows us to decompose a structural coercion, one+between ForallTys, or TyConApps, or FunTys.++There are three forms, split by the CoSel field inside the SelCo:+SelTyCon, SelForAll, and SelFun.  The typing rules below are directly+checked by the SelCo case of GHC.Core.Lint.lintCoercion.++* SelTyCon:++      co : (T s1..sn) ~r (T t1..tn)+      T is not a saturated FunTyCon (use SelFun for that)+      T is injective at role r+      ri = tyConRole tc r i+      i < n    (i is zero-indexed)+      ----------------------------------+      SelCo (SelTyCon i ri) co : si ~ri ti++  "Injective at role r": see Note [SelCo and newtypes]+  "Not saturated FunTyCon": see SelFun below++   See Note [SelCo Cached Roles]++* SelForAll:+      co : forall (a:k1).t1 ~r0 forall (a:k2).t2+      ----------------------------------+      SelCo SelForAll co : k1 ~N k2++  NB: SelForAll always gives a Nominal coercion.++* The SelFun form, for functions, has three sub-forms for the three+  components of the function type (multiplicity, argument, result).++      co : (s1 %{m1}-> t1) ~r0 (s2 %{m2}-> t2)+      r = funRole r0 SelMult+      ----------------------------------+      SelCo (SelFun SelMult) co : m1 ~r m2++      co : (s1 %{m1}-> t1) ~r0 (s2 %{m2}-> t2)+      r = funRole r0 SelArg+      ----------------------------------+      SelCo (SelFun SelArg) co : s1 ~r s2++      co : (s1 %{m1}-> t1) ~r0 (s2 %{m2}-> t2)+      r = funRole r0 SelRes+      ----------------------------------+      SelCo (SelFun SelRes) co : t1 ~r t2++Note [FunCo]+~~~~~~~~~~~~+Just as FunTy has a ft_af :: FunTyFlag field, FunCo (which connects+two function types) has two FunTyFlag fields:+     funco_afl, funco_afr :: FunTyFlag+In all cases, the FunTyFlag is recoverable from the kinds of the argument+and result types/coercions; but experiments show that it's better to+cache it.++Why does FunCo need /two/ flags? If we have a single method class,+implemented as a newtype+   class C a where { op :: [a] -> a }+then we can have a coercion+   co :: C Int ~R ([Int]->Int)+So now we can define+   FunCo co <Bool> : (C Int => Bool) ~R (([Int]->Int) -> Bool)+Notice that the left and right arrows are different!  Hence two flags,+one for coercionLKind and one for coercionRKind.++Note [Coercion axioms applied to coercions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The reason coercion axioms can be applied to coercions and not just+types is to allow for better optimization.  There are some cases where+we need to be able to "push transitivity inside" an axiom in order to+expose further opportunities for optimization.++For example, suppose we have++  C a : t[a] ~ F a+  g   : b ~ c++and we want to optimize++  sym (C b) ; t[g] ; C c++which has the kind++  F b ~ F c++(stopping through t[b] and t[c] along the way).++We'd like to optimize this to just F g -- but how?  The key is+that we need to allow axioms to be instantiated by *coercions*,+not just by types.  Then we can (in certain cases) push+transitivity inside the axiom instantiations, and then react+opposite-polarity instantiations of the same axiom.  In this+case, e.g., we match t[g] against the LHS of (C c)'s kind, to+obtain the substitution  a |-> g  (note this operation is sort+of the dual of lifting!) and hence end up with++  C g : t[b] ~ F c++which indeed has the same kind as  t[g] ; C c.++Now we have++  sym (C b) ; C g++which can be optimized to F g.++Note [Required foralls in Core]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider the CoreExpr (Lam a e) where `a` is a TyVar, and (e::e_ty).+It has type+   forall a. e_ty+Note the Specified visibility of (forall a. e_ty); the Core type just isn't able+to express more than one visiblity, and we pick `Specified`.  See `exprType` and+`mkLamType` in GHC.Core.Utils, and `GHC.Type.Var.coreTyLamForAllTyFlag`.++So how can we ever get a term of type (forall a -> e_ty)?  Answer: /only/ via a+cast built with ForAllCo.  See `GHC.Core.Coercion.mkForAllVisCos`,+`GHC.Tc.Types.Evidence.mkWpForAllCast` and `GHC.Core.Make.mkCoreTyLams`.+This does not seem very satisfying, but it does the job.++An alternative would be to put a visibility flag into `Lam` (a huge change),+or into a `TyVar` (a more plausible change), but we leave that for the future.++See also Note [ForAllTy and type equality] in GHC.Core.TyCo.Compare.++Note [ForAllCo]+~~~~~~~~~~~~~~~+See also Note [ForAllTy and type equality] in GHC.Core.TyCo.Compare.++Constructing coercions between forall-types can be a bit tricky,+because the kinds of the bound tyvars can be different.++The typing rule is:++  G |- kind_co : k1 ~N k2+  tv1 \not\in fv(typeKind(t1),typeKind(t2))  -- Skolem escape+  G, tv1:k1 |- co : t1 ~r t2+  if r=N, then vis1=vis2+  ------------------------------------+  G |- ForAllCo (tv1:k1) vis1 vis2 kind_co co+         : forall (tv1:k1) <vis1>. t1+              ~r+           forall (tv1:k2) <vis2>. (t2[tv1 |-> (tv1:k2) |> sym kind_co])++Several things to note here++(FC1) First, the TyCoVar stored in a ForAllCo is really just a convenience: this+  field should be a Name, as its kind is redundant. Thinking of the field as a+  Name is helpful in understanding what a ForAllCo means.  The kind of TyCoVar+  always matches the left-hand kind of the coercion.++  * The idea is that kind_co gives the two kinds of the tyvar. See how, in the+    conclusion, tv1 is assigned kind k1 on the left but kind k2 on the right.++  * Of course, a type variable can't have different kinds at the same time.+    So, in `co` itself we use (tv1 : k1); hence the premise+          tv1:k1 |- co : t1 ~r t2++  * The last wrinkle is that we need to fix the kinds in the conclusion. In+    t2, tv1 is assumed to have kind k1, but it has kind k2 in the conclusion of+     the rule. So we do a kind-fixing substitution, replacing (tv1:k1) with+     (tv1:k2) |> sym kind_co. This substitution is slightly bizarre, because it+    mentions the same name with different kinds, but it *is* well-kinded, noting+     that `(tv1:k2) |> sym kind_co` has kind k1.++  We could instead store just a Name in the ForAllCo, and it might even be+  more efficient to do so. But we can't add Names to, e.g., VarSets, and+  there generally is just an impedance mismatch in a bunch of places. So we+  use tv1. When we need tv2, we can use setTyVarKind.++(FC2) Note that the kind coercion must be Nominal; and that the role `r` of+  the final coercion is the same as that of the body coercion.++(FC3) A ForAllCo allows casting between visibilities.  For example:+         ForAllCo a Required Specified (SubCo (Refl ty))+           : (forall a -> ty) ~R (forall a. ty)+  But you can only cast between visiblities at Representational role;+  Hence the premise+      if r=N, then vis1=vis2+  in the typing rule.  See also Note [ForAllTy and type equality] in+  GHC.Core.TyCo.Compare.++(FC4) See Note [Required foralls in Core].++(FC5) In a /type/, in (ForAllTy cv ty) where cv is a CoVar, we insist that+  `cv` must appear free in `ty`; see Note [Unused coercion variable in ForAllTy]+  in GHC.Core.TyCo.Rep for the motivation.  If it does not appear free,+  use FunTy.++  However we do /not/ impose the same restriction on ForAllCo in /coercions/.+  Instead, in coercionLKind and coercionRKind, we use mkTyCoForAllTy to perform+  the check and construct a FunTy when necessary.  Why?+    * For a coercion, all that matters is its kind, So ForAllCo vs FunCo does not+       make a difference.+    * Even if cv occurs in body_co, it is possible that cv does not occur in the kind+      of body_co. Therefore the check in coercionKind is inevitable.++(FC6) Invariant: in a ForAllCo where fco_tcv is a coercion variable, `cv`,+  we insist that `cv` appears only in positions that are erased. In fact we use+  a conservative approximation of this: we require that+       (almostDevoidCoVarOfCo cv fco_body)+  holds.  This function checks that `cv` appers only within the type in a Refl+  node and under a GRefl node (including in the Coercion stored in a GRefl).+  It's possible other places are OK, too, but this is a safe approximation.++  Why all this fuss?  See Section 5.8.5.2 of Richard's thesis. The idea is that+  we cannot prove that the type system is consistent with unrestricted use of this+  cv; the consistency proof uses an untyped rewrite relation that works over types+  with all coercions and casts removed. So, we can allow the cv to appear only in+  positions that are erased.++  Sadly, with heterogeneous equality, this restriction might be able to be+  violated; Richard's thesis is unable to prove that it isn't. Specifically, the+  liftCoSubst function might create an invalid coercion. Because a violation of+  the restriction might lead to a program that "goes wrong", it is checked all+  the time, even in a production compiler and without -dcore-lint. We *have*+  proved that the problem does not occur with homogeneous equality, so this+  check can be dropped once ~# is made to be homogeneous.++(FC7) Invariant: in a ForAllCo, if fco_tcv is a CoVar, then+         fco_visL = fco_visR = coreTyLamForAllTyFlag+  c.f. (FT2) in Note [ForAllTy]++Note [Predicate coercions]+~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have+   g :: a~b+How can we coerce between types+   ([c]~a) => [a] -> c+and+   ([c]~b) => [b] -> c+where the equality predicate *itself* differs?++Answer: we simply treat (~) as an ordinary type constructor, so these+types really look like++   ((~) [c] a) -> [a] -> c+   ((~) [c] b) -> [b] -> c++So the coercion between the two is obviously++   ((~) [c] g) -> [g] -> c++Another way to see this to say that we simply collapse predicates to+their representation type (see Type.coreView and Type.predTypeRep).++This collapse is done by mkPredCo; there is no PredCo constructor+in Coercion.  This is important because we need Nth to work on+predicates too:+    SelCo (SelTyCon 1) ((~) [c] g) = g+See Simplify.simplCoercionF, which generates such selections.++Note [Roles]+~~~~~~~~~~~~+Roles are a solution to the GeneralizedNewtypeDeriving problem, articulated+in #1496. The full story is in docs/core-spec/core-spec.pdf. Also, see+https://gitlab.haskell.org/ghc/ghc/wikis/roles-implementation++Here is one way to phrase the problem:++Given:+newtype Age = MkAge Int+type family F x+type instance F Age = Bool+type instance F Int = Char++This compiles down to:+axAge :: Age ~ Int+axF1 :: F Age ~ Bool+axF2 :: F Int ~ Char++Then, we can make:+(sym (axF1) ; F axAge ; axF2) :: Bool ~ Char++Yikes!++The solution is _roles_, as articulated in "Generative Type Abstraction and+Type-level Computation" (POPL 2010), available at+http://www.seas.upenn.edu/~sweirich/papers/popl163af-weirich.pdf++The specification for roles has evolved somewhat since that paper. For the+current full details, see the documentation in docs/core-spec. Here are some+highlights.++We label every equality with a notion of type equivalence, of which there are+three options: Nominal, Representational, and Phantom. A ground type is+nominally equivalent only with itself. A newtype (which is considered a ground+type in Haskell) is representationally equivalent to its representation.+Anything is "phantomly" equivalent to anything else. We use "N", "R", and "P"+to denote the equivalences.++The axioms above would be:+axAge :: Age ~R Int+axF1 :: F Age ~N Bool+axF2 :: F Age ~N Char++Then, because transitivity applies only to coercions proving the same notion+of equivalence, the above construction is impossible.++However, there is still an escape hatch: we know that any two types that are+nominally equivalent are representationally equivalent as well. This is what+the form SubCo proves -- it "demotes" a nominal equivalence into a+representational equivalence. So, it would seem the following is possible:++sub (sym axF1) ; F axAge ; sub axF2 :: Bool ~R Char   -- WRONG++What saves us here is that the arguments to a type function F, lifted into a+coercion, *must* prove nominal equivalence. So, (F axAge) is ill-formed, and+we are safe.++Roles are attached to parameters to TyCons. When lifting a TyCon into a+coercion (through TyConAppCo), we need to ensure that the arguments to the+TyCon respect their roles. For example:++data T a b = MkT a (F b)++If we know that a1 ~R a2, then we know (T a1 b) ~R (T a2 b). But, if we know+that b1 ~R b2, we know nothing about (T a b1) and (T a b2)! This is because+the type function F branches on b's *name*, not representation. So, we say+that 'a' has role Representational and 'b' has role Nominal. The third role,+Phantom, is for parameters not used in the type's definition. Given the+following definition++data Q a = MkQ Int++the Phantom role allows us to say that (Q Bool) ~R (Q Char), because we+can construct the coercion Bool ~P Char (using UnivCo).++See the paper cited above for more examples and information.++Note [TyConAppCo roles]+~~~~~~~~~~~~~~~~~~~~~~~+The TyConAppCo constructor has a role parameter, indicating the role at+which the coercion proves equality. The choice of this parameter affects+the required roles of the arguments of the TyConAppCo. To help explain+it, assume the following definition:++  type instance F Int = Bool   -- Axiom axF : F Int ~N Bool+  newtype Age = MkAge Int      -- Axiom axAge : Age ~R Int+  data Foo a = MkFoo a         -- Role on Foo's parameter is Representational++TyConAppCo Nominal Foo axF : Foo (F Int) ~N Foo Bool+  For (TyConAppCo Nominal) all arguments must have role Nominal. Why?+  So that Foo Age ~N Foo Int does *not* hold.++TyConAppCo Representational Foo (SubCo axF) : Foo (F Int) ~R Foo Bool+TyConAppCo Representational Foo axAge       : Foo Age     ~R Foo Int+  For (TyConAppCo Representational), all arguments must have the roles+  corresponding to the result of tyConRoles on the TyCon. This is the+  whole point of having roles on the TyCon to begin with. So, we can+  have Foo Age ~R Foo Int, if Foo's parameter has role R.++  If a Representational TyConAppCo is over-saturated (which is otherwise fine),+  the spill-over arguments must all be at Nominal. This corresponds to the+  behavior for AppCo.++TyConAppCo Phantom Foo (UnivCo Phantom Int Bool) : Foo Int ~P Foo Bool+  All arguments must have role Phantom. This one isn't strictly+  necessary for soundness, but this choice removes ambiguity.++The rules here dictate the roles of the parameters to mkTyConAppCo+(should be checked by Lint).++Note [SelCo and newtypes]+~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have++  newtype N a = MkN Int+  type role N representational++This yields axiom++  NTCo:N :: forall a. N a ~R Int++We can then build++  co :: forall a b. N a ~R N b+  co = NTCo:N a ; sym (NTCo:N b)++for any `a` and `b`. Because of the role annotation on N, if we use+SelCo, we'll get out a representational coercion. That is:++  SelCo (SelTyCon 0 r) co :: forall a b. a ~r b++Yikes! Clearly, this is terrible. The solution is simple: forbid+SelCo to be used on newtypes if the internal coercion is representational.+More specifically, we use isInjectiveTyCon to determine whether+T is injective at role r:+* Newtypes and datatypes are both injective at Nominal role, but+* Newtypes are not injective at Representational role+See the SelCo equation for GHC.Core.Lint.lintCoercion.++This is not just some corner case discovered by a segfault somewhere;+it was discovered in the proof of soundness of roles and described+in the "Safe Coercions" paper (ICFP '14).++Note [SelCo Cached Roles]+~~~~~~~~~~~~~~~~~~~~~~~~~+Why do we cache the role of SelCo in the SelCo constructor?+Because computing role(Nth i co) involves figuring out that++  co :: T tys1 ~ T tys2++using coercionKind, and finding (coercionRole co), and then looking+at the tyConRoles of T. Avoiding bad asymptotic behaviour here means+we have to compute the kind and role of a coercion simultaneously,+which makes the code complicated and inefficient.++This only happens for SelCo. Caching the role solves the problem, and+allows coercionKind and coercionRole to be simple.++See #11735++Note [InstCo roles]+~~~~~~~~~~~~~~~~~~~+Here is (essentially) the typing rule for InstCo:++g :: (forall a. t1) ~r (forall a. t2)+w :: s1 ~N s2+------------------------------- InstCo+InstCo g w :: (t1 [a |-> s1]) ~r (t2 [a |-> s2])++Note that the Coercion w *must* be nominal. This is necessary+because the variable a might be used in a "nominal position"+(that is, a place where role inference would require a nominal+role) in t1 or t2. If we allowed w to be representational, we+could get bogus equalities.++A more nuanced treatment might be able to relax this condition+somewhat, by checking if t1 and/or t2 use their bound variables+in nominal ways. If not, having w be representational is OK.+++%************************************************************************+%*                                                                      *+                UnivCo+%*                                                                      *+%************************************************************************++Note [UnivCo]+~~~~~~~~~~~~~+A UnivCo is a coercion whose proof does not directly express its role+and kind (indeed for some UnivCos, like PluginProv, there /is/ no proof).++The different kinds of UnivCo are described by UnivCoProvenance.  Really each+is entirely separate, but they all share the need to represent these fields:++  UnivCo+      { uco_prov         :: UnivCoProvenance+      , uco_role         :: Role+      , uco_lty, uco_rty :: Type+      , uco_deps         :: [Coercion]  -- Coercions on which it depends++Here,+ * uco_role, uco_lty, uco_rty express the type of the coercion+ * uco_prov says where it came from+ * uco_deps specifies the coercions on which this proof (which is not+   explicity given) depends. See+   Note [The importance of tracking UnivCo dependencies]+-}++-- | For simplicity, we have just one UnivCo that represents a coercion from+-- some type to some other type, with (in general) no restrictions on the+-- type. The UnivCoProvenance specifies more exactly what the coercion really+-- is and why a program should (or shouldn't!) trust the coercion.+-- It is reasonable to consider each constructor of 'UnivCoProvenance'+-- as a totally independent coercion form; their only commonality is+-- that they don't tell you what types they coercion between. (That info+-- is in the 'UnivCo' constructor of 'Coercion'.+data UnivCoProvenance+  = PhantomProv    -- ^ See Note [Phantom coercions]. Only in Phantom+                   -- roled coercions++  | ProofIrrelProv -- ^ From the fact that any two coercions are+                   --   considered equivalent. See Note [ProofIrrelProv].+                   -- Can be used in Nominal or Representational coercions++  | PluginProv String+      -- ^ From a plugin, which asserts that this coercion is sound.+      --   The string and the variable set are for the use by the plugin.++  deriving (Eq, Ord, Data.Data)+  -- Why Ord?  See Note [Ord instance of IfaceType] in GHC.Iface.Type++instance Outputable UnivCoProvenance where+  ppr PhantomProv          = text "(phantom)"+  ppr (ProofIrrelProv {})  = text "(proof irrel)"+  ppr (PluginProv str)     = parens (text "plugin" <+> brackets (text str))++instance NFData UnivCoProvenance where+  rnf p = p `seq` ()++instance Binary UnivCoProvenance where+  put_ bh PhantomProv    = putByte bh 1+  put_ bh ProofIrrelProv = putByte bh 2+  put_ bh (PluginProv a) = putByte bh 3 >> put_ bh a+  get bh = do+      tag <- getByte bh+      case tag of+           1 -> return PhantomProv+           2 -> return ProofIrrelProv+           3 -> do a <- get bh+                   return $ PluginProv a+           _ -> panic ("get UnivCoProvenance " ++ show tag)+++{- Note [Phantom coercions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+     data T a = T1 | T2+Then we have+     T s ~R T t+for any old s,t. The witness for this is (TyConAppCo T Rep co),+where (co :: s ~P t) is a phantom coercion built with PhantomProv.+The role of the UnivCo is always Phantom.  The Coercion stored is the+(nominal) kind coercion between the types+   kind(s) ~N kind (t)++Note [ProofIrrelProv]+~~~~~~~~~~~~~~~~~~~~~+A ProofIrrelProv is a coercion between coercions. For example:++  data G a where+    MkG :: G Bool++In core, we get++  G :: * -> *+  MkG :: forall (a :: *). (a ~# Bool) -> G a++Now, consider 'MkG -- that is, MkG used in a type -- and suppose we want+a proof that ('MkG a1 co1) ~ ('MkG a2 co2). This will have to be++  TyConAppCo Nominal MkG [co3, co4]+  where+    co3 :: co1 ~ co2+    co4 :: a1 ~ a2++Note that+  co1 :: a1 ~ Bool+  co2 :: a2 ~ Bool++Here,+  co3 = UnivCo ProofIrrelProv Nominal (CoercionTy co1) (CoercionTy co2) [co5]+  where+    co5 :: (a1 ~# Bool) ~# (a2 ~# Bool)+    co5 = TyConAppCo Nominal (~#) [<Consraint#>, <Constraint#>, co4, <Bool>]+++Note [The importance of tracking UnivCo dependencies]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It is vital that `UnivCo` (a coercion that lacks a proper proof)+tracks the coercions on which it depends. To see why, consider this program:++    type S :: Nat -> Nat++    data T (a::Nat) where+      T1 :: T 0+      T2 :: ...++    f :: T a -> S (a+1) -> S 1+    f = /\a (x:T a) (y:a).+        case x of+          T1 (gco : a ~# 0) -> y |> wco++For this to typecheck we need `wco :: S (a+1) ~# S 1`, given that `gco : a ~# 0`.+To prove that we need to know that `a+1 = 1` if `a=0`, which a plugin might know.+So it solves `wco` by providing a `UnivCo (PluginProv "my-plugin") (a+1) 1 [gco]`.++    But the `uco_deps` in `PluginProv` must mention `gco`!++Why? Otherwise we might float the entire expression (y |> wco) out of the+the case alternative for `T1` which brings `gco` into scope. If this+happens then we aren't far from a segmentation fault or much worse.+See #23923 for a real-world example of this happening.++So it is /crucial/ for the `UnivCo` to mention, in `uco_deps`, the coercion+variables used by the plugin to justify the `UnivCo` that it builds.  You+should think of it like `TyConAppCo`: the `UnivCo` proof constructor is+applied to a list of coercions, just as `TyConAppCo` is++It's very convenient to record a full coercion, not just a set of free coercion+variables, because during typechecking those coercions might contain coercion+holes `HoleCo`, which get filled in later.+-}++{- **********************************************************************+%*                                                                      *+                Coercion holes+%*                                                                      *+%********************************************************************* -}++-- | A coercion to be filled in by the type-checker. See Note [Coercion holes]+data CoercionHole+  = CoercionHole { ch_co_var  :: CoVar+                       -- See Note [CoercionHoles and coercion free variables]++                 , ch_ref :: IORef (Maybe Coercion)+                 }++coHoleCoVar :: CoercionHole -> CoVar+coHoleCoVar = ch_co_var++setCoHoleCoVar :: CoercionHole -> CoVar -> CoercionHole+setCoHoleCoVar h cv = h { ch_co_var = cv }++instance Data.Data CoercionHole where+  -- don't traverse?+  toConstr _   = abstractConstr "CoercionHole"+  gunfold _ _  = error "gunfold"+  dataTypeOf _ = mkNoRepType "CoercionHole"++instance Outputable CoercionHole where+  ppr (CoercionHole { ch_co_var = cv }) = braces (ppr cv)++instance Uniquable CoercionHole where+  getUnique (CoercionHole { ch_co_var = cv }) = getUnique cv++{- Note [Coercion holes]+~~~~~~~~~~~~~~~~~~~~~~~~+During typechecking, constraint solving for type classes works by+  - Generate an evidence Id,  d7 :: Num a+  - Wrap it in a Wanted constraint, [W] d7 :: Num a+  - Use the evidence Id where the evidence is needed+  - Solve the constraint later+  - When solved, add an enclosing let-binding  let d7 = .... in ....+    which actually binds d7 to the (Num a) evidence++For equality constraints we use a different strategy.  See Note [The+equality types story] in GHC.Builtin.Types.Prim for background on equality constraints.+  - For /boxed/ equality constraints, (t1 ~N t2) and (t1 ~R t2), it's just+    like type classes above. (Indeed, boxed equality constraints *are* classes.)+  - But for /unboxed/ equality constraints (t1 ~R# t2) and (t1 ~N# t2)+    we use a different plan++For unboxed equalities:+  - Generate a CoercionHole, a mutable variable just like a unification+    variable+  - Wrap the CoercionHole in a Wanted constraint; see GHC.Tc.Utils.TcEvDest+  - Use the CoercionHole in a Coercion, via HoleCo+  - Solve the constraint later+  - When solved, fill in the CoercionHole by side effect, instead of+    doing the let-binding thing++The main reason for all this is that there may be no good place to let-bind+the evidence for unboxed equalities:++  - We emit constraints for kind coercions, to be used to cast a+    type's kind. These coercions then must be used in types. Because+    they might appear in a top-level type, there is no place to bind+    these (unlifted) coercions in the usual way.++  - A coercion for (forall a. t1) ~ (forall a. t2) will look like+       forall a. (coercion for t1~t2)+    But the coercion for (t1~t2) may mention 'a', and we don't have+    let-bindings within coercions.  We could add them, but coercion+    holes are easier.++  - Moreover, nothing is lost from the lack of let-bindings. For+    dictionaries want to achieve sharing to avoid recomputing the+    dictionary.  But coercions are entirely erased, so there's little+    benefit to sharing. Indeed, even if we had a let-binding, we+    always inline types and coercions at every use site and drop the+    binding.++Other notes about HoleCo:++ * INVARIANT: CoercionHole and HoleCo are used only during type checking,+   and should never appear in Core. Just like unification variables; a Type+   can contain a TcTyVar, but only during type checking. If, one day, we+   use type-level information to separate out forms that can appear during+   type-checking vs forms that can appear in core proper, holes in Core will+   be ruled out.++ * See Note [CoercionHoles and coercion free variables]++ * Coercion holes can be compared for equality like other coercions:+   by looking at the types coerced.+++Note [CoercionHoles and coercion free variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Why does a CoercionHole contain a CoVar, as well as reference to+fill in?  Because we want to treat that CoVar as a free variable of+the coercion.  See #14584, and Note [What prevents a+constraint from floating] in GHC.Tc.Solver, item (4):++        forall k. [W] co1 :: t1 ~# t2 |> co2+                  [W] co2 :: k ~# *++Here co2 is a CoercionHole. But we /must/ know that it is free in+co1, because that's all that stops it floating outside the+implication.+-}++++{- *********************************************************************+*                                                                      *+                foldType  and   foldCoercion+*                                                                      *+********************************************************************* -}++{- Note [foldType]+~~~~~~~~~~~~~~~~~~+foldType is a bit more powerful than perhaps it looks:++* You can fold with an accumulating parameter, via+     TyCoFolder env (Endo a)+  Recall newtype Endo a = Endo (a->a)++* You can fold monadically with a monad M, via+     TyCoFolder env (M a)+  provided you have+     instance ..  => Monoid (M a)++Note [mapType vs foldType]+~~~~~~~~~~~~~~~~~~~~~~~~~~+We define foldType here, but mapType in module Type. Why?++* foldType is used in GHC.Core.TyCo.FVs for finding free variables.+  It's a very simple function that analyses a type,+  but does not construct one.++* mapType constructs new types, and so it needs to call+  the "smart constructors", mkAppTy, mkCastTy, and so on.+  These are sophisticated functions, and can't be defined+  here in GHC.Core.TyCo.Rep.++Note [Specialising foldType]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We inline foldType at every call site (there are not many), so that it+becomes specialised for the particular monoid *and* TyCoFolder at+that site.  This is just for efficiency, but walking over types is+done a *lot* in GHC, so worth optimising.++We were worried that+    TyCoFolder env (Endo a)+might not eta-expand.  Recall newtype Endo a = Endo (a->a).++In particular, given+   fvs :: Type -> TyCoVarSet+   fvs ty = appEndo (foldType tcf emptyVarSet ty) emptyVarSet++   tcf :: TyCoFolder enf (Endo a)+   tcf = TyCoFolder { tcf_tyvar = do_tv, ... }+      where+        do_tvs is tv = Endo do_it+           where+             do_it acc | tv `elemVarSet` is  = acc+                       | tv `elemVarSet` acc = acc+                       | otherwise = acc `extendVarSet` tv++we want to end up with+   fvs ty = go emptyVarSet ty emptyVarSet+     where+       go env (TyVarTy tv) acc = acc `extendVarSet` tv+       ..etc..++And indeed this happens.+  - Selections from 'tcf' are done at compile time+  - 'go' is nicely eta-expanded.++We were also worried about+   deep_fvs :: Type -> TyCoVarSet+   deep_fvs ty = appEndo (foldType deep_tcf emptyVarSet ty) emptyVarSet++   deep_tcf :: TyCoFolder enf (Endo a)+   deep_tcf = TyCoFolder { tcf_tyvar = do_tv, ... }+      where+        do_tvs is tv = Endo do_it+           where+             do_it acc | tv `elemVarSet` is  = acc+                       | tv `elemVarSet` acc = acc+                       | otherwise = deep_fvs (varType tv)+                                     `unionVarSet` acc+                                     `extendVarSet` tv++Here deep_fvs and deep_tcf are mutually recursive, unlike fvs and tcf.+But, amazingly, we get good code here too. GHC is careful not to mark+TyCoFolder data constructor for deep_tcf as a loop breaker, so the+record selections still cancel.  And eta expansion still happens too.++Note [Use explicit recursion in foldTyCo]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In foldTyCo you'll see things like:+    go_tys _   []     = mempty+    go_tys env (t:ts) = go_ty env t `mappend` go_tys env ts+where we use /explicit recursion/.  You might wonder about using foldl instead:+    go_tys env = foldl (\t acc -> go_ty env t `mappend` acc) mempty+Or maybe foldl', or foldr.++But don't do that for two reasons (see #24591)++* We sometimes instantiate `a` to (Endo VarSet). Remembering+     newtype Endo a = Endo (a->a)+  after inlining `foldTyCo` bodily, the explicit recursion looks like+    go_tys _   []     = \acc -> acc+    go_tys env (t:ts) = \acc -> go_ty env t (go_tys env ts acc)+  The strictness analyser has no problem spotting that this function is+  strict in `acc`, provided `go_ty` is.++  But in the foldl form that is /much/ less obvious, and the strictness+  analyser fails utterly.  Result: lots and lots of thunks get built.  In+  !12037, Mikolaj found that GHC allocated /six times/ as much heap+  on test perf/compiler/T9198 as a result of this single problem!++* Second, while I think that using `foldr` would be fine (simple experiments in+  #24591 suggest as much), it builds a local loop (with env free) and I'm not 100%+  confident it'll be lambda lifted in the end. It seems more direct just to write+  the code we want.++  On the other hand in `go_cvs` we might hope that the `foldr` will fuse with the+  `dVarSetElems` so I have used `foldr`.+-}++data TyCoFolder env a+  = TyCoFolder+      { tcf_view  :: Type -> Maybe Type   -- Optional "view" function+                                          -- E.g. expand synonyms+      , tcf_tyvar :: env -> TyVar -> a    -- Does not automatically recur+      , tcf_covar :: env -> CoVar -> a    -- into kinds of variables+      , tcf_hole  :: env -> CoercionHole -> a+          -- ^ What to do with coercion holes.+          -- See Note [Coercion holes] in "GHC.Core.TyCo.Rep".++      , tcf_tycobinder :: env -> TyCoVar -> ForAllTyFlag -> env+          -- ^ The returned env is used in the extended scope+      }++{-# INLINE foldTyCo  #-}  -- See Note [Specialising foldType]+foldTyCo :: Monoid a => TyCoFolder env a -> env+         -> (Type -> a, [Type] -> a, Coercion -> a, [Coercion] -> a)+foldTyCo (TyCoFolder { tcf_view       = view+                     , tcf_tyvar      = tyvar+                     , tcf_tycobinder = tycobinder+                     , tcf_covar      = covar+                     , tcf_hole       = cohole }) env+  = (go_ty env, go_tys env, go_co env, go_cos env)+  where+    go_ty env ty | Just ty' <- view ty = go_ty env ty'+    go_ty env (TyVarTy tv)      = tyvar env tv+    go_ty env (AppTy t1 t2)     = go_ty env t1 `mappend` go_ty env t2+    go_ty _   (LitTy {})        = mempty+    go_ty env (CastTy ty co)    = go_ty env ty `mappend` go_co env co+    go_ty env (CoercionTy co)   = go_co env co+    go_ty env (FunTy _ w arg res) = go_ty env w `mappend` go_ty env arg `mappend` go_ty env res+    go_ty env (TyConApp _ tys)  = go_tys env tys+    go_ty env (ForAllTy (Bndr tv vis) inner)+      = let !env' = tycobinder env tv vis  -- Avoid building a thunk here+        in go_ty env (varType tv) `mappend` go_ty env' inner++    -- See Note [Use explicit recursion in foldTyCo]+    go_tys _   []     = mempty+    go_tys env (t:ts) = go_ty env t `mappend` go_tys env ts++    -- See Note [Use explicit recursion in foldTyCo]+    go_cos _   []     = mempty+    go_cos env (c:cs) = go_co env c `mappend` go_cos env cs++    go_co env (Refl ty)                = go_ty env ty+    go_co env (GRefl _ ty MRefl)       = go_ty env ty+    go_co env (GRefl _ ty (MCo co))    = go_ty env ty `mappend` go_co env co+    go_co env (TyConAppCo _ _ args)    = go_cos env args+    go_co env (AppCo c1 c2)            = go_co env c1 `mappend` go_co env c2+    go_co env (CoVarCo cv)             = covar env cv+    go_co env (AxiomCo _ cos)          = go_cos env cos+    go_co env (HoleCo hole)            = cohole env hole+    go_co env (UnivCo { uco_lty = t1, uco_rty = t2, uco_deps = deps })+                                       = go_ty env t1 `mappend` go_ty env t2+                                         `mappend` go_cos env deps+    go_co env (SymCo co)               = go_co env co+    go_co env (TransCo c1 c2)          = go_co env c1 `mappend` go_co env c2+    go_co env (SelCo _ co)             = go_co env co+    go_co env (LRCo _ co)              = go_co env co+    go_co env (InstCo co arg)          = go_co env co `mappend` go_co env arg+    go_co env (KindCo co)              = go_co env co+    go_co env (SubCo co)               = go_co env co++    go_co env (FunCo { fco_mult = cw, fco_arg = c1, fco_res = c2 })+       = go_co env cw `mappend` go_co env c1 `mappend` go_co env c2++    go_co env (ForAllCo tv _vis1 _vis2 kind_co co)+      = go_co env kind_co `mappend` go_ty env (varType tv)+                          `mappend` go_co env' co+      where+        env' = tycobinder env tv Inferred++-- | A view function that looks through nothing.+noView :: Type -> Maybe Type+noView _ = Nothing++{- *********************************************************************+*                                                                      *+                   typeSize, coercionSize+*                                                                      *+********************************************************************* -}++-- NB: We put typeSize/coercionSize here because they are mutually+--     recursive, and have the CPR property.  If we have mutual+--     recursion across a hi-boot file, we don't get the CPR property+--     and these functions allocate a tremendous amount of rubbish.+--     It's not critical (because typeSize is really only used in+--     debug mode, but I tripped over an example (T5642) in which+--     typeSize was one of the biggest single allocators in all of GHC.+--     And it's easy to fix, so I did.++-- NB: typeSize does not respect `eqType`, in that two types that+--     are `eqType` may return different sizes. This is OK, because this+--     function is used only in reporting, not decision-making.++typeSize :: Type -> Int+-- The size of the syntax tree of a type.  No special treatment+-- for type synonyms or type families.+typeSize (LitTy {})                 = 1+typeSize (TyVarTy {})               = 1+typeSize (AppTy t1 t2)              = typeSize t1 + typeSize t2+typeSize (FunTy _ _ t1 t2)          = typeSize t1 + typeSize t2+typeSize (ForAllTy (Bndr tv _) t)   = typeSize (varType tv) + typeSize t+typeSize (TyConApp _ ts)            = 1 + typesSize ts+typeSize (CastTy ty co)             = typeSize ty + coercionSize co+typeSize (CoercionTy co)            = coercionSize co++typesSize :: [Type] -> Int+typesSize tys = foldr ((+) . typeSize) 0 tys++coercionSize :: Coercion -> Int+coercionSize (Refl ty)             = typeSize ty+coercionSize (GRefl _ ty MRefl)    = typeSize ty+coercionSize (GRefl _ ty (MCo co)) = 1 + typeSize ty + coercionSize co+coercionSize (TyConAppCo _ _ args) = 1 + sum (map coercionSize args)+coercionSize (AppCo co arg)        = coercionSize co + coercionSize arg+coercionSize (ForAllCo { fco_kind = h, fco_body = co })+                                   = 1 + coercionSize co + coercionSize h+coercionSize (FunCo _ _ _ w c1 c2) = 1 + coercionSize c1 + coercionSize c2+                                                         + coercionSize w+coercionSize (CoVarCo _)         = 1+coercionSize (HoleCo _)          = 1+coercionSize (AxiomCo _ cs)      = 1 + sum (map coercionSize cs)+coercionSize (UnivCo { uco_lty = t1, uco_rty = t2 })  = 1 + typeSize t1 + typeSize t2+coercionSize (SymCo co)          = 1 + coercionSize co+coercionSize (TransCo co1 co2)   = 1 + coercionSize co1 + coercionSize co2+coercionSize (SelCo _ co)        = 1 + coercionSize co+coercionSize (LRCo  _ co)        = 1 + coercionSize co+coercionSize (InstCo co arg)     = 1 + coercionSize co + coercionSize arg+coercionSize (KindCo co)         = 1 + coercionSize co+coercionSize (SubCo co)          = 1 + coercionSize co  {- ************************************************************************
GHC/Core/TyCo/Rep.hs-boot view
@@ -3,28 +3,41 @@  import GHC.Utils.Outputable ( Outputable ) import Data.Data  ( Data )-import {-# SOURCE #-} GHC.Types.Var( Var, ArgFlag, AnonArgFlag )+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 TyCoBinder 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 -mkFunTyMany :: AnonArgFlag -> Type -> Type -> Type-mkForAllTy :: Var -> ArgFlag -> Type -> Type-mkNakedTyConTy :: TyCon -> Type+mkForAllTy       :: VarBndr Var ForAllTyFlag -> Type -> Type+mkNakedTyConTy   :: TyCon -> Type+mkNakedFunTy     :: FunTyFlag -> Type -> Type -> Type -instance Data Type  -- To support Data instances in GHC.Core.Coercion.Axiom++-- To support Data instances in GHC.Core.Coercion.Axiom+instance Data Type++-- To support instances PiTyBinder in Var+instance Data a => Data (Scaled a)++-- To support debug pretty-printing instance Outputable Type+instance Outputable a => Outputable (Scaled a)
GHC/Core/TyCo/Subst.hs view
@@ -5,28 +5,25 @@ -}  -{-# LANGUAGE BangPatterns #-}-{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}  -- | Substitution into types and coercions. module GHC.Core.TyCo.Subst   (         -- * Substitutions-        TCvSubst(..), TvSubstEnv, CvSubstEnv,-        emptyTvSubstEnv, emptyCvSubstEnv, composeTCvSubstEnv, composeTCvSubst,-        emptyTCvSubst, mkEmptyTCvSubst, isEmptyTCvSubst,-        mkTCvSubst, mkTvSubst, mkCvSubst,-        getTvSubstEnv,-        getCvSubstEnv, getTCvInScope, getTCvSubstRangeFVs,-        isInScope, elemTCvSubst, notElemTCvSubst,-        setTvSubstEnv, setCvSubstEnv, zapTCvSubst,-        extendTCvInScope, extendTCvInScopeList, extendTCvInScopeSet,+        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, extendTvSubstBinderAndInScope, extendTvSubstWithClone,+        extendTvSubst, extendTvSubstWithClone,         extendTvSubstList, extendTvSubstAndInScope,         extendTCvSubstList,-        unionTCvSubst, zipTyEnv, zipCoEnv,+        unionSubst, zipTyEnv, zipCoEnv,         zipTvSubst, zipCvSubst,         zipTCvSubst,         mkTvSubstPrs,@@ -44,10 +41,10 @@         cloneTyVarBndr, cloneTyVarBndrs,         substVarBndr, substVarBndrs,         substTyVarBndr, substTyVarBndrs,-        substCoVarBndr,-        substTyVar, substTyVars, substTyCoVars,-        substTyCoBndr,-        substForAllCoBndr,+        substCoVarBndr, substDCoVarSet,+        substTyVar, substTyVars, substTyVarToTyVar,+        substTyCoVars,+        substTyCoBndr, substForAllCoBndr,         substVarBndrUsing, substForAllCoBndrUsing,         checkValidSubst, isValidTCvSubst,   ) where@@ -55,16 +52,18 @@ import GHC.Prelude  import {-# SOURCE #-} GHC.Core.Type-   ( mkCastTy, mkAppTy, isCoercionTy, mkTyConApp )+   ( mkCastTy, mkAppTy, isCoercionTy, mkTyConApp, getTyVar_maybe ) import {-# SOURCE #-} GHC.Core.Coercion-   ( mkCoVarCo, mkKindCo, mkNthCo, mkTransCo+   ( mkCoVarCo, mkKindCo, mkSelCo, mkTransCo    , mkNomReflCo, mkSubCo, mkSymCo-   , mkFunCo, mkForAllCo, mkUnivCo-   , mkAxiomInstCo, mkAppCo, mkGReflCo+   , mkFunCo2, mkForAllCo, mkUnivCo+   , mkAxiomCo, mkAppCo, mkGReflCo    , mkInstCo, mkLRCo, mkTyConAppCo    , mkCoercionType-   , coercionKind, coercionLKind, coVarKindsTypesRole )+   , 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@@ -73,7 +72,6 @@ import GHC.Types.Var.Set import GHC.Types.Var.Env -import GHC.Data.Pair import GHC.Utils.Constants (debugIsOn) import GHC.Utils.Misc import GHC.Types.Unique.Supply@@ -82,7 +80,6 @@ import GHC.Types.Unique.Set import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Utils.Panic.Plain  import Data.List (mapAccumL) @@ -95,28 +92,34 @@ %************************************************************************ -} --- | 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+-- | Type & coercion & id substitution ----- 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 [Substitutions apply only once]-        -- and Note [Extending the TCvSubstEnv]-        -- and Note [Substituting types and coercions]-        -- and Note [The substitution invariant]+-- 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@@ -139,8 +142,6 @@   (SIa) The free vars of the range of the substitution   (SIb) The free vars of ty minus the domain of the substitution -The same rules apply to other substitutions (notably GHC.Core.Subst.Subst)- * Reason for (SIa). Consider       substTy [a :-> Maybe b] (forall b. b->a)   we must rename the forall b, to get@@ -179,9 +180,11 @@ A TCvSubst is not idempotent, but, unlike the non-idempotent substitution we use during unifications, it must not be repeatedly applied. -Note [Extending the TCvSubstEnv]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-See #tcvsubst_invariant# for the invariants that must hold.+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)@@ -203,128 +206,153 @@  * In substTy, substTheta, we can short-circuit when the TvSubstEnv is empty -Note [Substituting types and coercions]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+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.-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.+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 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+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 -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+-- 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, cenv3) = composeTCvSubstEnv is3 (tenv1, cenv1) (tenv2, cenv2)+    tenv3 = tenv1 `plusVarEnv` mapVarEnv (substTy extended_subst1) tenv2+    cenv3 = cenv1 `plusVarEnv` mapVarEnv (substCo extended_subst1) cenv2 -emptyTCvSubst :: TCvSubst-emptyTCvSubst = TCvSubst emptyInScopeSet emptyTvSubstEnv emptyCvSubstEnv+    -- 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 -mkEmptyTCvSubst :: InScopeSet -> TCvSubst-mkEmptyTCvSubst is = TCvSubst is emptyTvSubstEnv emptyCvSubstEnv+emptySubst :: Subst+emptySubst = Subst emptyInScopeSet emptyVarEnv emptyVarEnv emptyVarEnv -isEmptyTCvSubst :: TCvSubst -> Bool-         -- See Note [Extending the TCvSubstEnv]-isEmptyTCvSubst (TCvSubst _ tenv cenv) = isEmptyVarEnv tenv && isEmptyVarEnv cenv+mkEmptySubst :: InScopeSet -> Subst+mkEmptySubst in_scope = Subst in_scope emptyVarEnv emptyVarEnv emptyVarEnv -mkTCvSubst :: InScopeSet -> (TvSubstEnv, CvSubstEnv) -> TCvSubst-mkTCvSubst in_scope (tenv, cenv) = TCvSubst in_scope tenv cenv+isEmptySubst :: Subst -> Bool+isEmptySubst (Subst _ id_env tv_env cv_env)+  = isEmptyVarEnv id_env && isEmptyVarEnv tv_env && isEmptyVarEnv cv_env -mkTvSubst :: InScopeSet -> TvSubstEnv -> TCvSubst+-- | 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 = TCvSubst in_scope tenv emptyCvSubstEnv+mkTvSubst in_scope tenv = Subst in_scope emptyIdSubstEnv tenv emptyCvSubstEnv -mkCvSubst :: InScopeSet -> CvSubstEnv -> TCvSubst+mkCvSubst :: InScopeSet -> CvSubstEnv -> Subst -- ^ Make a TCvSubst with specified covar subst and empty tyvar subst-mkCvSubst in_scope cenv = TCvSubst in_scope emptyTvSubstEnv cenv+mkCvSubst in_scope cenv = Subst in_scope emptyIdSubstEnv emptyTvSubstEnv cenv -getTvSubstEnv :: TCvSubst -> TvSubstEnv-getTvSubstEnv (TCvSubst _ env _) = env+getIdSubstEnv :: Subst -> IdSubstEnv+getIdSubstEnv (Subst _ ids _ _) = ids -getCvSubstEnv :: TCvSubst -> CvSubstEnv-getCvSubstEnv (TCvSubst _ _ env) = env+getTvSubstEnv :: Subst -> TvSubstEnv+getTvSubstEnv (Subst _ _ tenv _) = tenv -getTCvInScope :: TCvSubst -> InScopeSet-getTCvInScope (TCvSubst in_scope _ _) = in_scope+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.-getTCvSubstRangeFVs :: TCvSubst -> VarSet-getTCvSubstRangeFVs (TCvSubst _ tenv cenv)-    = unionVarSet tenvFVs cenvFVs+getSubstRangeTyCoFVs :: Subst -> VarSet+getSubstRangeTyCoFVs (Subst _ _ tenv cenv)+  = tenvFVs `unionVarSet` cenvFVs   where     tenvFVs = shallowTyCoVarsOfTyVarEnv tenv     cenvFVs = shallowTyCoVarsOfCoVarEnv cenv -isInScope :: Var -> TCvSubst -> Bool-isInScope v (TCvSubst in_scope _ _) = v `elemInScopeSet` in_scope+isInScope :: Var -> Subst -> Bool+isInScope v (Subst in_scope _ _ _) = v `elemInScopeSet` in_scope -elemTCvSubst :: Var -> TCvSubst -> Bool-elemTCvSubst v (TCvSubst _ tenv cenv)+elemSubst :: Var -> Subst -> Bool+elemSubst v (Subst _ ids tenv cenv)   | isTyVar v   = v `elemVarEnv` tenv-  | otherwise+  | isCoVar v   = v `elemVarEnv` cenv--notElemTCvSubst :: Var -> TCvSubst -> Bool-notElemTCvSubst v = not . elemTCvSubst v--setTvSubstEnv :: TCvSubst -> TvSubstEnv -> TCvSubst-setTvSubstEnv (TCvSubst in_scope _ cenv) tenv = TCvSubst in_scope tenv cenv+  | otherwise+  = v `elemVarEnv` ids -setCvSubstEnv :: TCvSubst -> CvSubstEnv -> TCvSubst-setCvSubstEnv (TCvSubst in_scope tenv _) cenv = TCvSubst in_scope tenv cenv+notElemSubst :: Var -> Subst -> Bool+notElemSubst v = not . elemSubst v -zapTCvSubst :: TCvSubst -> TCvSubst-zapTCvSubst (TCvSubst in_scope _ _) = TCvSubst in_scope emptyVarEnv emptyVarEnv+-- | 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 -extendTCvInScope :: TCvSubst -> Var -> TCvSubst-extendTCvInScope (TCvSubst in_scope tenv cenv) var-  = TCvSubst (extendInScopeSet in_scope var) tenv cenv+-- | 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 -extendTCvInScopeList :: TCvSubst -> [Var] -> TCvSubst-extendTCvInScopeList (TCvSubst in_scope tenv cenv) vars-  = TCvSubst (extendInScopeSetList in_scope vars) tenv cenv+-- | 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 -extendTCvInScopeSet :: TCvSubst -> VarSet -> TCvSubst-extendTCvInScopeSet (TCvSubst in_scope tenv cenv) vars-  = TCvSubst (extendInScopeSetSet in_scope vars) tenv cenv+-- | 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 :: TCvSubst -> TyCoVar -> Type -> TCvSubst+extendTCvSubst :: Subst -> TyCoVar -> Type -> Subst extendTCvSubst subst v ty   | isTyVar v   = extendTvSubst subst v ty@@ -333,102 +361,112 @@   | otherwise   = pprPanic "extendTCvSubst" (ppr v <+> text "|->" <+> ppr ty) -extendTCvSubstWithClone :: TCvSubst -> TyCoVar -> TyCoVar -> TCvSubst+extendTCvSubstWithClone :: Subst -> TyCoVar -> TyCoVar -> Subst extendTCvSubstWithClone subst tcv   | isTyVar tcv = extendTvSubstWithClone subst tcv   | otherwise   = extendCvSubstWithClone subst tcv -extendTvSubst :: TCvSubst -> TyVar -> Type -> TCvSubst-extendTvSubst (TCvSubst in_scope tenv cenv) tv ty-  = TCvSubst in_scope (extendVarEnv tenv tv ty) cenv--extendTvSubstBinderAndInScope :: TCvSubst -> TyCoBinder -> Type -> TCvSubst-extendTvSubstBinderAndInScope subst (Named (Bndr v _)) ty-  = assert (isTyVar v )-    extendTvSubstAndInScope subst v ty-extendTvSubstBinderAndInScope subst (Anon {}) _-  = subst+-- | 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 :: 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'+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 -extendCvSubst :: TCvSubst -> CoVar -> Coercion -> TCvSubst-extendCvSubst (TCvSubst in_scope tenv cenv) v co-  = TCvSubst in_scope tenv (extendVarEnv cenv v co)+-- | 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 :: TCvSubst -> CoVar -> CoVar -> TCvSubst-extendCvSubstWithClone (TCvSubst in_scope tenv cenv) cv cv'-  = TCvSubst (extendInScopeSetSet in_scope new_in_scope)+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 :: TCvSubst -> TyVar -> Type -> TCvSubst+extendTvSubstAndInScope :: Subst -> TyVar -> Type -> Subst -- Also extends the in-scope set-extendTvSubstAndInScope (TCvSubst in_scope tenv cenv) tv ty-  = TCvSubst (in_scope `extendInScopeSetSet` tyCoVarsOfType ty)+extendTvSubstAndInScope (Subst in_scope ids tenv cenv) tv ty+  = Subst (in_scope `extendInScopeSetSet` tyCoVarsOfType ty)+             ids              (extendVarEnv tenv tv ty)              cenv -extendTvSubstList :: TCvSubst -> [Var] -> [Type] -> TCvSubst-extendTvSubstList subst tvs tys-  = foldl2 extendTvSubst subst tvs tys+-- | 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 :: TCvSubst -> [Var] -> [Type] -> TCvSubst+extendTCvSubstList :: Subst -> [Var] -> [Type] -> Subst extendTCvSubstList subst tvs tys   = foldl2 extendTCvSubst subst tvs tys -unionTCvSubst :: TCvSubst -> TCvSubst -> TCvSubst+unionSubst :: Subst -> Subst -> Subst -- Works when the ranges are disjoint-unionTCvSubst (TCvSubst in_scope1 tenv1 cenv1) (TCvSubst in_scope2 tenv2 cenv2)-  = assert (tenv1 `disjointVarEnv` tenv2+unionSubst (Subst in_scope1 ids1 tenv1 cenv1) (Subst in_scope2 ids2 tenv2 cenv2)+  = assert (ids1  `disjointVarEnv` ids2+         && tenv1 `disjointVarEnv` tenv2          && cenv1 `disjointVarEnv` 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+    Subst (in_scope1 `unionInScope` in_scope2)+           (ids1      `plusVarEnv`   ids2)+           (tenv1     `plusVarEnv`   tenv2)+           (cenv1     `plusVarEnv`   cenv2) --- | Generates the in-scope set for the 'TCvSubst' from the types in the incoming--- environment. No CoVars, please!-zipTvSubst :: HasDebugCallStack => [TyVar] -> [Type] -> TCvSubst+-- | 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 'TCvSubst' from the types in the incoming+-- | Generates the in-scope set for the 'Subst' from the types in the incoming -- environment.  No TyVars, please!-zipCvSubst :: HasDebugCallStack => [CoVar] -> [Coercion] -> TCvSubst+zipCvSubst :: HasDebugCallStack => [CoVar] -> [Coercion] -> Subst zipCvSubst cvs cos-  = TCvSubst (mkInScopeSet (shallowTyCoVarsOfCos cos)) emptyTvSubstEnv cenv+  = mkCvSubst (mkInScopeSet (shallowTyCoVarsOfCos cos)) cenv   where     cenv = zipCoEnv cvs cos -zipTCvSubst :: HasDebugCallStack => [TyCoVar] -> [Type] -> TCvSubst++zipTCvSubst :: HasDebugCallStack => [TyCoVar] -> [Type] -> Subst zipTCvSubst tcvs tys   = zip_tcvsubst tcvs tys $-    mkEmptyTCvSubst $ mkInScopeSet $ shallowTyCoVarsOfTypes tys-  where zip_tcvsubst :: [TyCoVar] -> [Type] -> TCvSubst -> TCvSubst+    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)+                                   (ppr tcvs <+> ppr tys)  -- | Generates the in-scope set for the 'TCvSubst' from the types in the--- incoming environment. No CoVars, please!-mkTvSubstPrs :: [(TyVar, Type)] -> TCvSubst-mkTvSubstPrs []  = emptyTCvSubst+-- 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@@ -438,6 +476,7 @@           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@@ -465,15 +504,20 @@   , not (all isCoVar cvs)   = pprPanic "zipCoEnv" (ppr cvs <+> ppr cos)   | otherwise-  = mkVarEnv (zipEqual "zipCoEnv" cvs cos)+  = mkVarEnv (zipEqual 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) ]+-- Pretty printing, for debugging only +instance Outputable Subst where+  ppr (Subst in_scope ids tvs cvs)+        =  text "<InScope =" <+> in_scope_doc+        $$ text " IdSubst   =" <+> ppr ids+        $$ text " TvSubst   =" <+> ppr tvs+        $$ text " CvSubst   =" <+> ppr cvs+         <> char '>'+    where+    in_scope_doc = pprVarSet (getInScopeVars in_scope) (braces . fsep . map ppr)+ {- %************************************************************************ %*                                                                      *@@ -486,7 +530,8 @@ 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:+Ignoring visibility, here is the typing rule+(see Note [ForAllCo] in GHC.Core.TyCo.Rep).  h : k1 ~# k2 (tv : k1) |- g : ty1 ~# ty2@@ -573,7 +618,7 @@ -- 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 :: HasDebugCallStack => InScopeSet -> [TyVar] -> [Type] -> Type -> Type substTyWithInScope in_scope tvs tys ty =   assert (tvs `equalLength` tys )   substTy (mkTvSubst in_scope tenv) ty@@ -601,12 +646,12 @@ substTyWithCoVars cvs cos = substTy (zipCvSubst cvs cos)  -- | Type substitution, see 'zipTvSubst'-substTysWith :: [TyVar] -> [Type] -> [Type] -> [Type]+substTysWith :: HasDebugCallStack => [TyVar] -> [Type] -> [Type] -> [Type] substTysWith tvs tys = assert (tvs `equalLength` tys )                        substTys (zipTvSubst tvs tys)  -- | Type substitution, see 'zipTvSubst'-substTysWithCoVars :: [CoVar] -> [Coercion] -> [Type] -> [Type]+substTysWithCoVars :: HasDebugCallStack => [CoVar] -> [Coercion] -> [Type] -> [Type] substTysWithCoVars cvs cos = assert (cvs `equalLength` cos )                              substTys (zipCvSubst cvs cos) @@ -614,16 +659,17 @@ -- 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 :: HasDebugCallStack => Subst -> Type -> Type substTyAddInScope subst ty =-  substTy (extendTCvInScopeSet subst $ tyCoVarsOfType ty) 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].-isValidTCvSubst :: TCvSubst -> Bool-isValidTCvSubst (TCvSubst in_scope tenv cenv) =+-- 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@@ -632,8 +678,8 @@  -- | This checks if the substitution satisfies the invariant from -- Note [The substitution invariant].-checkValidSubst :: HasDebugCallStack => TCvSubst -> [Type] -> [Coercion] -> a -> a-checkValidSubst subst@(TCvSubst in_scope tenv cenv) tys cos a+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 $$@@ -663,7 +709,7 @@ -- | Substitute within a 'Type' -- The substitution has to satisfy the invariants described in -- Note [The substitution invariant].-substTy :: HasDebugCallStack => TCvSubst -> Type  -> Type+substTy :: HasDebugCallStack => Subst -> Type  -> Type substTy subst ty   | isEmptyTCvSubst subst = ty   | otherwise             = checkValidSubst subst [ty] [] $@@ -674,26 +720,26 @@ -- 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 -> Type -> Type substTyUnchecked subst ty-                 | isEmptyTCvSubst subst = ty-                 | otherwise             = subst_ty subst ty+  | isEmptyTCvSubst subst = ty+  | otherwise             = subst_ty subst ty -substScaledTy :: HasDebugCallStack => TCvSubst -> Scaled Type -> Scaled Type+substScaledTy :: HasDebugCallStack => Subst -> Scaled Type -> Scaled Type substScaledTy subst scaled_ty = mapScaledType (substTy subst) scaled_ty -substScaledTyUnchecked :: HasDebugCallStack => TCvSubst -> Scaled Type -> Scaled Type+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 => TCvSubst -> [Type] -> [Type]+substTys :: HasDebugCallStack => Subst -> [Type] -> [Type] substTys subst tys   | isEmptyTCvSubst subst = tys   | otherwise = checkValidSubst subst tys [] $ map (subst_ty subst) tys -substScaledTys :: HasDebugCallStack => TCvSubst -> [Scaled Type] -> [Scaled Type]+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) [] $@@ -704,12 +750,12 @@ -- 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 -> [Type] -> [Type] substTysUnchecked subst tys                  | isEmptyTCvSubst subst = tys                  | otherwise             = map (subst_ty subst) tys -substScaledTysUnchecked :: TCvSubst -> [Scaled Type] -> [Scaled Type]+substScaledTysUnchecked :: Subst -> [Scaled Type] -> [Scaled Type] substScaledTysUnchecked subst tys                  | isEmptyTCvSubst subst = tys                  | otherwise             = map (mapScaledType (subst_ty subst)) tys@@ -717,7 +763,7 @@ -- | Substitute within a 'ThetaType' -- The substitution has to satisfy the invariants described in -- Note [The substitution invariant].-substTheta :: HasDebugCallStack => TCvSubst -> ThetaType -> ThetaType+substTheta :: HasDebugCallStack => Subst -> ThetaType -> ThetaType substTheta = substTys  -- | Substitute within a 'ThetaType' disabling the sanity checks.@@ -725,11 +771,11 @@ -- 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 :: Subst -> ThetaType -> ThetaType substThetaUnchecked = substTysUnchecked  -subst_ty :: TCvSubst -> Type -> Type+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@@ -762,34 +808,44 @@     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+substTyVar :: Subst -> TyVar -> Type+substTyVar (Subst _ _ tenv _) tv   = assert (isTyVar tv) $     case lookupVarEnv tenv tv of       Just ty -> ty       Nothing -> TyVarTy tv -substTyVars :: TCvSubst -> [TyVar] -> [Type]+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 :: TCvSubst -> [TyCoVar] -> [Type]+substTyCoVars :: Subst -> [TyCoVar] -> [Type] substTyCoVars subst = map $ substTyCoVar subst -substTyCoVar :: TCvSubst -> TyCoVar -> Type+substTyCoVar :: Subst -> TyCoVar -> Type substTyCoVar subst tv   | isTyVar tv = substTyVar subst tv   | otherwise = CoercionTy $ substCoVar subst tv -lookupTyVar :: TCvSubst -> TyVar  -> Maybe Type-        -- See Note [Extending the TCvSubst]-lookupTyVar (TCvSubst _ tenv _) 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 => TCvSubst -> Coercion -> Coercion+substCo :: HasDebugCallStack => Subst -> Coercion -> Coercion substCo subst co   | isEmptyTCvSubst subst = co   | otherwise = checkValidSubst subst [] [co] $ subst_co subst co@@ -799,7 +855,7 @@ -- 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 -> Coercion -> Coercion substCoUnchecked subst co   | isEmptyTCvSubst subst = co   | otherwise = subst_co subst co@@ -807,12 +863,12 @@ -- | Substitute within several 'Coercion's -- The substitution has to satisfy the invariants described in -- Note [The substitution invariant].-substCos :: HasDebugCallStack => TCvSubst -> [Coercion] -> [Coercion]+substCos :: HasDebugCallStack => Subst -> [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 -> Coercion -> Coercion subst_co subst co   = go co   where@@ -826,74 +882,73 @@     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)= let args' = map go args-                               in  args' `seqList` mkTyConAppCo r tc args'+    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 kind_co co)+    go (ForAllCo tv visL visR 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 w co1 co2)   = ((mkFunCo r $! go w) $! go co1) $! go co2+          ((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 (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 (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 (NthCo r d co)        = mkNthCo r d $! (go co)+    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 (AxiomRuleCo c cs)    = let cs1 = map go cs-                                in cs1 `seqList` AxiomRuleCo c cs1     go (HoleCo h)            = HoleCo $! go_hole h -    go_prov (PhantomProv kco)    = PhantomProv (go kco)-    go_prov (ProofIrrelProv kco) = ProofIrrelProv (go kco)-    go_prov p@(PluginProv _)     = p-    go_prov p@(CorePrepProv _)   = p+    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 } -substForAllCoBndr :: TCvSubst -> TyCoVar -> KindCoercion-                  -> (TCvSubst, TyCoVar, Coercion)+-- | 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 False (substCo subst) 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 :: TCvSubst -> TyCoVar -> KindCoercion-                           -> (TCvSubst, TyCoVar, Coercion)+substForAllCoBndrUnchecked :: Subst -> TyCoVar -> KindCoercion+                           -> (Subst, TyCoVar, Coercion) substForAllCoBndrUnchecked subst-  = substForAllCoBndrUsing False (substCoUnchecked subst) subst+  = substForAllCoBndrUsing (substCoUnchecked subst) subst  -- See Note [Sym and ForAllCo]-substForAllCoBndrUsing :: Bool  -- apply sym to binder?-                       -> (Coercion -> Coercion)  -- transformation to kind co-                       -> TCvSubst -> TyCoVar -> KindCoercion-                       -> (TCvSubst, TyCoVar, KindCoercion)-substForAllCoBndrUsing sym sco subst old_var-  | isTyVar old_var = substForAllCoTyVarBndrUsing sym sco subst old_var-  | otherwise       = substForAllCoCoVarBndrUsing sym sco subst old_var+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 :: Bool  -- apply sym to binder?-                            -> (Coercion -> Coercion)  -- transformation to kind co-                            -> TCvSubst -> TyVar -> KindCoercion-                            -> (TCvSubst, TyVar, KindCoercion)-substForAllCoTyVarBndrUsing sym sco (TCvSubst in_scope tenv cenv) old_var old_kind_co+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 )-    ( TCvSubst (in_scope `extendInScopeSet` new_var) new_env cenv+    ( Subst (in_scope `extendInScopeSet` new_var) idenv 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+    new_env | no_change = delVarEnv tenv old_var             | otherwise = extendVarEnv tenv old_var (TyVarTy new_var)      no_kind_change = noFreeVarsOfCo old_kind_co@@ -910,17 +965,16 @@      new_var  = uniqAway in_scope (setTyVarKind old_var new_ki1) -substForAllCoCoVarBndrUsing :: Bool  -- apply sym to binder?-                            -> (Coercion -> Coercion)  -- transformation to kind co-                            -> TCvSubst -> CoVar -> KindCoercion-                            -> (TCvSubst, CoVar, KindCoercion)-substForAllCoCoVarBndrUsing sym sco (TCvSubst in_scope tenv cenv)+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 )-    ( TCvSubst (in_scope `extendInScopeSet` new_var) tenv new_cenv+    ( Subst (in_scope `extendInScopeSet` new_var) idenv tenv new_cenv     , new_var, new_kind_co )   where-    new_cenv | no_change && not sym = delVarEnv cenv old_var+    new_cenv | no_change = delVarEnv cenv old_var              | otherwise = extendVarEnv cenv old_var (mkCoVarCo new_var)      no_kind_change = noFreeVarsOfCo old_kind_co@@ -929,37 +983,34 @@     new_kind_co | no_kind_change = old_kind_co                 | otherwise      = sco old_kind_co -    Pair h1 h2 = coercionKind new_kind_co--    new_var       = uniqAway in_scope $ mkCoVar (varName old_var) new_var_type-    new_var_type  | sym       = h2-                  | otherwise = h1+    new_ki1       = coercionLKind new_kind_co+    new_var       = uniqAway in_scope $ mkCoVar (varName old_var) new_ki1 -substCoVar :: TCvSubst -> CoVar -> Coercion-substCoVar (TCvSubst _ _ cenv) cv+substCoVar :: Subst -> CoVar -> Coercion+substCoVar (Subst _ _ _ cenv) cv   = case lookupVarEnv cenv cv of       Just co -> co       Nothing -> CoVarCo cv -substCoVars :: TCvSubst -> [CoVar] -> [Coercion]+substCoVars :: Subst -> [CoVar] -> [Coercion] substCoVars subst cvs = map (substCoVar subst) cvs -lookupCoVar :: TCvSubst -> Var -> Maybe Coercion-lookupCoVar (TCvSubst _ _ cenv) v = lookupVarEnv cenv v+lookupCoVar :: Subst -> Var -> Maybe Coercion+lookupCoVar (Subst _ _ _ cenv) v = lookupVarEnv cenv v -substTyVarBndr :: HasDebugCallStack => TCvSubst -> TyVar -> (TCvSubst, TyVar)+substTyVarBndr :: HasDebugCallStack => Subst -> TyVar -> (Subst, TyVar) substTyVarBndr = substTyVarBndrUsing substTy -substTyVarBndrs :: HasDebugCallStack => TCvSubst -> [TyVar] -> (TCvSubst, [TyVar])+substTyVarBndrs :: HasDebugCallStack => Subst -> [TyVar] -> (Subst, [TyVar]) substTyVarBndrs = mapAccumL substTyVarBndr -substVarBndr :: HasDebugCallStack => TCvSubst -> TyCoVar -> (TCvSubst, TyCoVar)+substVarBndr :: HasDebugCallStack => Subst -> TyCoVar -> (Subst, TyCoVar) substVarBndr = substVarBndrUsing substTy -substVarBndrs :: HasDebugCallStack => TCvSubst -> [TyCoVar] -> (TCvSubst, [TyCoVar])+substVarBndrs :: HasDebugCallStack => Subst -> [TyCoVar] -> (Subst, [TyCoVar]) substVarBndrs = mapAccumL substVarBndr -substCoVarBndr :: HasDebugCallStack => TCvSubst -> CoVar -> (TCvSubst, CoVar)+substCoVarBndr :: HasDebugCallStack => Subst -> CoVar -> (Subst, CoVar) substCoVarBndr = substCoVarBndrUsing substTy  -- | Like 'substVarBndr', but disables sanity checks.@@ -967,11 +1018,11 @@ -- 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 :: TCvSubst -> TyCoVar -> (TCvSubst, TyCoVar)+substVarBndrUnchecked :: Subst -> TyCoVar -> (Subst, TyCoVar) substVarBndrUnchecked = substVarBndrUsing substTyUnchecked -substVarBndrUsing :: (TCvSubst -> Type -> Type)-                  -> TCvSubst -> TyCoVar -> (TCvSubst, TyCoVar)+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@@ -980,12 +1031,12 @@ -- extended subst and a new tyvar. -- Use the supplied function to substitute in the kind substTyVarBndrUsing-  :: (TCvSubst -> Type -> Type)  -- ^ Use this to substitute in the kind-  -> TCvSubst -> TyVar -> (TCvSubst, TyVar)-substTyVarBndrUsing subst_fn subst@(TCvSubst in_scope tenv cenv) old_var+  :: (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 )-    (TCvSubst (in_scope `extendInScopeSet` new_var) new_env cenv, new_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)@@ -998,7 +1049,7 @@     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]+        -- 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@@ -1015,11 +1066,11 @@ -- extended subst and a new covar. -- Use the supplied function to substitute in the kind substCoVarBndrUsing-  :: (TCvSubst -> Type -> Type)-  -> TCvSubst -> CoVar -> (TCvSubst, CoVar)-substCoVarBndrUsing subst_fn subst@(TCvSubst in_scope tenv cenv) old_var+  :: (Subst -> Type -> Type)+  -> Subst -> CoVar -> (Subst, CoVar)+substCoVarBndrUsing subst_fn subst@(Subst in_scope idenv tenv cenv) old_var   = assert (isCoVar old_var)-    (TCvSubst (in_scope `extendInScopeSet` new_var) tenv new_cenv, new_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]@@ -1031,18 +1082,21 @@     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, 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 :: TCvSubst -> TyVar -> Unique -> (TCvSubst, TyVar)-cloneTyVarBndr subst@(TCvSubst in_scope tv_env cv_env) tv uniq+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-    (TCvSubst (extendInScopeSet in_scope tv')-              (extendVarEnv tv_env tv (mkTyVarTy tv')) cv_env, tv')+    ( 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@@ -1052,7 +1106,7 @@      tv' = setVarUnique tv1 uniq -cloneTyVarBndrs :: TCvSubst -> [TyVar] -> UniqSupply -> (TCvSubst, [TyVar])+cloneTyVarBndrs :: Subst -> [TyVar] -> UniqSupply -> (Subst, [TyVar]) cloneTyVarBndrs subst []     _usupply = (subst, []) cloneTyVarBndrs subst (t:ts)  usupply = (subst'', tv:tvs)   where@@ -1060,9 +1114,8 @@     (subst' , tv )   = cloneTyVarBndr subst t uniq     (subst'', tvs)   = cloneTyVarBndrs subst' ts usupply' -substTyCoBndr :: TCvSubst -> TyCoBinder -> (TCvSubst, TyCoBinder)-substTyCoBndr subst (Anon af ty)          = (subst, Anon af (substScaledTy subst ty))+substTyCoBndr :: Subst -> PiTyBinder -> (Subst, PiTyBinder)+substTyCoBndr subst (Anon ty af)          = (subst, Anon (substScaledTy subst ty) af) substTyCoBndr subst (Named (Bndr tv vis)) = (subst', Named (Bndr tv' vis))                                           where                                             (subst', tv') = substVarBndr subst tv-
GHC/Core/TyCo/Tidy.hs view
@@ -1,26 +1,27 @@-{-# LANGUAGE BangPatterns #-}-{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}- -- | Tidying types and coercions for printing in error messages. module GHC.Core.TyCo.Tidy   (         -- * Tidying type related things up for printing-        tidyType,      tidyTypes,-        tidyOpenType,  tidyOpenTypes,-        tidyVarBndr, tidyVarBndrs, tidyFreeTyCoVars, avoidNameClashes,-        tidyOpenTyCoVar, tidyOpenTyCoVars,-        tidyTyCoVarOcc,+        tidyType, tidyTypes,+        tidyCo,   tidyCos,         tidyTopType,-        tidyCo, tidyCos,-        tidyTyCoVarBinder, tidyTyCoVarBinders++        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 (tyCoVarsOfTypesWellScoped, tyCoVarsOfTypeList)-+import GHC.Core.TyCo.FVs import GHC.Types.Name hiding (varName) import GHC.Types.Var import GHC.Types.Var.Env@@ -28,12 +29,76 @@  import Data.List (mapAccumL) -{--%************************************************************************-%*                                                                      *-\subsection{TidyType}-%*                                                                      *-%************************************************************************+{- **********************************************************************++                  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@@ -70,55 +135,62 @@ -- this way is a helpful clue for users getHelpfulOccName tv   | isSystemName name, isTcTyVar tv-  = mkTyVarOcc (occNameString occ ++ "0")+  = mkTyVarOccFS (occNameFS occ `appendFS` fsLit "0")   | otherwise   = occ   where    name = varName tv    occ  = getOccName name -tidyTyCoVarBinder :: TidyEnv -> VarBndr TyCoVar vis+tidyForAllTyBinder :: TidyEnv -> VarBndr TyCoVar vis                   -> (TidyEnv, VarBndr TyCoVar vis)-tidyTyCoVarBinder tidy_env (Bndr tv vis)+tidyForAllTyBinder tidy_env (Bndr tv vis)   = (tidy_env', Bndr tv' vis)   where     (tidy_env', tv') = tidyVarBndr tidy_env tv -tidyTyCoVarBinders :: TidyEnv -> [VarBndr TyCoVar vis]+tidyForAllTyBinders :: TidyEnv -> [VarBndr TyCoVar vis]                    -> (TidyEnv, [VarBndr TyCoVar vis])-tidyTyCoVarBinders tidy_env tvbs-  = mapAccumL tidyTyCoVarBinder+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-tidyFreeTyCoVars tidy_env tyvars-  = fst (tidyOpenTyCoVars tidy_env tyvars)+-- 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)  ----------------tidyOpenTyCoVars :: TidyEnv -> [TyCoVar] -> (TidyEnv, [TyCoVar])-tidyOpenTyCoVars env tyvars = mapAccumL tidyOpenTyCoVar 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  ----------------tidyOpenTyCoVar :: TidyEnv -> TyCoVar -> (TidyEnv, TyCoVar)+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'-tidyOpenTyCoVar env@(_, subst) tyvar+-- See Note [Tidying is idempotent]+tidyFreeTyCoVarX env@(_, subst) tyvar   = case lookupVarEnv subst tyvar of-        Just tyvar' -> (env, tyvar')              -- Already substituted-        Nothing     ->-          let env' = tidyFreeTyCoVars env (tyCoVarsOfTypeList (tyVarKind tyvar))-          in tidyVarBndr env' tyvar  -- Treat it as a binder+        Just tyvar' -> (env, tyvar')           -- Already substituted+        Nothing     -> tidyVarBndr env tyvar  -- Treat it as a binder  --------------- tidyTyCoVarOcc :: TidyEnv -> TyCoVar -> TyCoVar-tidyTyCoVarOcc env@(_, subst) tv-  = case lookupVarEnv subst tv of-        Nothing  -> updateVarType (tidyType env) tv-        Just tv' -> tv'+tidyTyCoVarOcc env@(_, subst) tcv+  = case lookupVarEnv subst tcv of+        Nothing   -> updateVarType (tidyType env) tcv+        Just tcv' -> tcv'  --------------- @@ -156,32 +228,36 @@ -- -- 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 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{}))     = (mkForAllTys' $! (zip tvs' vis)) $! tidyType env' body_ty-  where-    (tvs, vis, body_ty) = splitForAllTyCoVars' ty-    (env', tvs') = tidyVarBndrs env tvs-tidyType env (CastTy ty co)       = (CastTy $! tidyType env ty) $! (tidyCo env co)-tidyType env (CoercionTy co)      = CoercionTy $! (tidyCo env co)+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 ArgFlag argument. These belong to "GHC.Core.Type", but+-- they expect/preserve the ForAllTyFlag argument. These belong to "GHC.Core.Type", but -- how should they be named?-mkForAllTys' :: [(TyCoVar, ArgFlag)] -> Type -> Type+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], [ArgFlag], Type)+splitForAllTyCoVars' :: Type -> ([TyCoVar], [ForAllTyFlag], Type) splitForAllTyCoVars' ty = go ty [] []   where     go (ForAllTy (Bndr tv vis) ty) tvs viss = go ty (tv:tvs) (vis:viss)@@ -189,25 +265,54 @@   ---------------+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-tidyOpenTypes :: TidyEnv -> [Type] -> (TidyEnv, [Type])-tidyOpenTypes env tys-  = (env', tidyTypes (trimmed_occ_env, var_env) tys)+tidyOpenTypesX :: TidyEnv -> [Type] -> (TidyEnv, [Type])+-- See Note [Tidying open types]+tidyOpenTypesX env tys+  = (env1, tidyTypes inner_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.+    free_tcvs :: [TyCoVar] -- Closed over kinds+    free_tcvs          = tyCoVarsOfTypesList tys+    (env1, free_tcvs') = tidyFreeTyCoVarsX env free_tcvs+    inner_env          = trimTidyEnv env1 free_tcvs'  ----------------tidyOpenType :: TidyEnv -> Type -> (TidyEnv, Type)-tidyOpenType env ty = let (env', [ty']) = tidyOpenTypes env [ty] in-                      (env', ty')+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@@ -218,7 +323,7 @@ -- -- See Note [Strictness in tidyType and friends] tidyCo :: TidyEnv -> Coercion -> Coercion-tidyCo env@(_, subst) co+tidyCo env co   = go co   where     go_mco MRefl    = MRefl@@ -228,31 +333,32 @@     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 h co)    = ((ForAllCo $! tvp) $! (go h)) $! (tidyCo envp co)-                               where (envp, tvp) = tidyVarBndr env tv+    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 w co1 co2)   = ((FunCo r $! go w) $! go co1) $! go co2-    go (CoVarCo cv)          = case lookupVarEnv subst cv of-                                 Nothing  -> CoVarCo cv-                                 Just cv' -> CoVarCo cv'-    go (HoleCo h)            = HoleCo h-    go (AxiomInstCo con ind cos) = AxiomInstCo con ind $! strictMap go cos-    go (UnivCo p r t1 t2)    = (((UnivCo $! (go_prov p)) $! r) $!-                                tidyType env t1) $! tidyType env t2+    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 (NthCo r d co)        = NthCo r d $! go co+    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 (AxiomRuleCo ax cos)  = AxiomRuleCo ax $ strictMap go cos -    go_prov (PhantomProv co)    = PhantomProv $! go co-    go_prov (ProofIrrelProv co) = ProofIrrelProv $! go co-    go_prov p@(PluginProv _)    = p-    go_prov p@(CorePrepProv _)  = p+    go_cv cv = tidyTyCoVarOcc env cv++    go_hole (CoercionHole cv r) = (CoercionHole $! go_cv cv) r+    -- Tidy even the holes; tidied types should have tidied kinds  tidyCos :: TidyEnv -> [Coercion] -> [Coercion] tidyCos env = strictMap (tidyCo env)
GHC/Core/TyCon.hs view
@@ -1,2943 +1,3141 @@--{-# 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(..),-        RuntimeRepInfo(..), TyConFlavour(..),--        -- * TyConBinder-        TyConBinder, TyConBndrVis(..), TyConTyCoBinder,-        mkNamedTyConBinder, mkNamedTyConBinders,-        mkRequiredTyConBinder,-        mkAnonTyConBinder, mkAnonTyConBinders,-        tyConBinderArgFlag, tyConBndrVisArgFlag, isNamedTyConBinder,-        isVisibleTyConBinder, isInvisibleTyConBinder, isVisibleTcbVis,--        -- ** Field labels-        tyConFieldLabels, lookupTyConFieldLabel,--        -- ** Constructing TyCons-        mkAlgTyCon,-        mkClassTyCon,-        mkFunTyCon,-        mkPrimTyCon,-        mkTupleTyCon,-        mkSumTyCon,-        mkDataTyConRhs,-        mkLevPolyDataTyConRhs,-        mkSynonymTyCon,-        mkFamilyTyCon,-        mkPromotedDataCon,-        mkTcTyCon,-        noTcTyConScopedTyVars,--        -- ** Predicates on TyCons-        isAlgTyCon, isVanillaAlgTyCon, isConstraintKindCon,-        isClassTyCon, isFamInstTyCon,-        isFunTyCon,-        isPrimTyCon,-        isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon,-        isUnboxedSumTyCon, isPromotedTupleTyCon,-        isLiftedAlgTyCon,-        isTypeSynonymTyCon,-        mustBeSaturated,-        isPromotedDataCon, isPromotedDataCon_maybe,-        isKindTyCon, isLiftedTypeKindTyConName,-        isTauTyCon, isFamFreeTyCon, isForgetfulSynTyCon,--        isDataTyCon,-        isEnumerationTyCon,-        isNewTyCon, isAbstractTyCon,-        isFamilyTyCon, isOpenFamilyTyCon,-        isTypeFamilyTyCon, isDataFamilyTyCon,-        isOpenTypeFamilyTyCon, isClosedSynFamilyTyConWithAxiom_maybe,-        tyConInjectivityInfo,-        isBuiltInSynFamTyCon_maybe,-        isGadtSyntaxTyCon, isInjectiveTyCon, isGenerativeTyCon, isGenInjAlgRhs,-        isTyConAssoc, tyConAssoc_maybe, tyConFlavourAssoc_maybe,-        isImplicitTyCon,-        isTyConWithSrcDataCons,-        isTcTyCon, setTcTyConKind,-        tcHasFixedRuntimeRep,-        isConcreteTyCon,--        -- ** Extracting information out of TyCons-        tyConName,-        tyConSkolem,-        tyConKind,-        tyConUnique,-        tyConTyVars, tyConVisibleTyVars,-        tyConCType, tyConCType_maybe,-        tyConDataCons, tyConDataCons_maybe,-        tyConSingleDataCon_maybe, tyConSingleDataCon,-        tyConAlgDataCons_maybe,-        tyConSingleAlgDataCon_maybe,-        tyConFamilySize,-        tyConStupidTheta,-        tyConArity,-        tyConNullaryTy,-        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, tyConInvisTVBinders,-        tcTyConScopedTyVars, tcTyConIsPoly,-        mkTyConTagMap,--        -- ** Manipulating TyCons-        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(..),-        primElemRepToPrimRep,-        isVoidRep, isGcPtrRep,-        primRepSizeB,-        primElemRepSizeB,-        primRepIsFloat,-        primRepsCompatible,-        primRepCompatible,--) where--import GHC.Prelude-import GHC.Platform--import {-# SOURCE #-} GHC.Core.TyCo.Rep-   ( Kind, Type, PredType, mkForAllTy, mkFunTyMany, mkNakedTyConTy )-import {-# SOURCE #-} GHC.Core.TyCo.Ppr-   ( pprType )-import {-# SOURCE #-} GHC.Builtin.Types-   ( runtimeRepTyCon, constraintKind, levityTyCon-   , multiplicityTyCon-   , vecCountTyCon, vecElemTyCon, liftedTypeKind )-import {-# SOURCE #-} GHC.Core.DataCon-   ( DataCon, dataConFieldLabels-   , dataConTyCon, dataConFullSig-   , isUnboxedSumDataCon )-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.Utils.Panic.Plain-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 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 GHC.Types.Id.Make--* 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 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 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.Interact--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, TyConTyCoBinder-*                                                                      *-************************************************************************--}--type TyConBinder     = VarBndr TyVar   TyConBndrVis-type TyConTyCoBinder = VarBndr TyCoVar TyConBndrVis-     -- Only PromotedDataCon has TyConTyCoBinders-     -- See Note [Promoted GADT data constructors]--data TyConBndrVis-  = NamedTCB ArgFlag-  | AnonTCB  AnonArgFlag--instance Outputable TyConBndrVis where-  ppr (NamedTCB flag) = text "NamedTCB" <> ppr flag-  ppr (AnonTCB af)    = text "AnonTCB"  <> ppr af--mkAnonTyConBinder :: AnonArgFlag -> TyVar -> TyConBinder-mkAnonTyConBinder af tv = assert (isTyVar tv) $-                          Bndr tv (AnonTCB af)--mkAnonTyConBinders :: AnonArgFlag -> [TyVar] -> [TyConBinder]-mkAnonTyConBinders af tvs = map (mkAnonTyConBinder af) tvs--mkNamedTyConBinder :: ArgFlag -> TyVar -> TyConBinder--- The odd argument order supports currying-mkNamedTyConBinder vis tv = assert (isTyVar tv) $-                            Bndr tv (NamedTCB vis)--mkNamedTyConBinders :: ArgFlag -> [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  VisArg   tv--tyConBinderArgFlag :: TyConBinder -> ArgFlag-tyConBinderArgFlag (Bndr _ vis) = tyConBndrVisArgFlag vis--tyConBndrVisArgFlag :: TyConBndrVis -> ArgFlag-tyConBndrVisArgFlag (NamedTCB vis)     = vis-tyConBndrVisArgFlag (AnonTCB VisArg)   = Required-tyConBndrVisArgFlag (AnonTCB InvisArg) = Inferred    -- See Note [AnonTCB InvisArg]--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)     = isVisibleArgFlag vis-isVisibleTcbVis (AnonTCB VisArg)   = True-isVisibleTcbVis (AnonTCB InvisArg) = False--isInvisibleTyConBinder :: VarBndr tv TyConBndrVis -> Bool--- Works for IfaceTyConBinder too-isInvisibleTyConBinder tcb = not (isVisibleTyConBinder tcb)---- 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 (AnonTCB af))   k = mkFunTyMany af (varType tv) k-    mk (Bndr tv (NamedTCB vis)) k = mkForAllTy tv vis k--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 VisArg           -> SpecifiedSpec-                AnonTCB InvisArg         -> InferredSpec   -- See Note [AnonTCB InvisArg]-                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 [AnonTCB InvisArg]-~~~~~~~~~~~~~~~~~~~~~~~~~~-It's pretty rare to have an (AnonTCB InvisArg) binder.  The-only way it can occur is through equality constraints in kinds. These-can arise in one of two ways:--* In a PromotedDataCon whose kind has an equality constraint:--    'MkT :: forall a b. (a~b) => blah--  See Note [Constraints in kinds] in GHC.Core.TyCo.Rep, and-  Note [Promoted data constructors] in this module.-* In a data type whose kind has an equality constraint, as in the-  following example from #12102:--    data T :: forall a. (IsTypeLit a ~ 'True) => a -> Type--When mapping an (AnonTCB InvisArg) to an ArgFlag, in-tyConBndrVisArgFlag, we use "Inferred" to mean "the user cannot-specify this arguments, even with visible type/kind application;-instead the type checker must fill it in.--We map (AnonTCB VisArg) to Required, of course: the user must-provide it. It would be utterly wrong to do this for constraint-arguments, which is why AnonTCB must have the AnonArgFlag in-the first place.--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 TyCoVarBinders 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 TyCoVarBinders 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->*) -> k -> *--The TyCon has--  tyConTyBinders = [ Named (Bndr (k :: *) Inferred), Anon (k->*), 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->*) (b:k). a b -> App k a b--That is, its TyCoVarBinders should be--  dataConUnivTyVarBinders = [ Bndr (k:*)    Inferred-                            , Bndr (a:k->*) 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 don't have Required binders in-the TyCoBinders for a term (see Note [No Required TyCoBinder in terms]-in GHC.Core.TyCo.Rep), so we change it to Specified when making MkT's TyCoBinders--}---{- Note [The binders/kind/arity fields of a TyCon]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-All TyCons have this group of fields-  tyConBinders   :: [TyConBinder/TyConTyCoBinder]-  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/coercion variables on the LHS of the-  type declaration.  For example:--    type App a (b :: k) = a b--  tyConBinders = [ Bndr (k::*)   (NamedTCB Inferred)-                 , Bndr (a:k->*) 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, TyCoVarBinders, TyConBinders, and visibility] in GHC.Core.TyCo.Rep-  for what the visibility flag means.--* Each TyConBinder tyConBinders has a TyVar (sometimes it is TyCoVar), 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:*) 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--* 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.  Eample (#19738):--    type P :: k -> Type-    data P a = MkP--    type T :: k -> Constraint-    class T (a :: j) where-      f :: P a-      f = MkP @j @a  -- 'j' must be in scope when we typecheck 'f'--* When typechecking `deriving` clauses for top-level data declarations, the-  tcTyConScopedTyVars are brought into scope in through the `di_scoped_tvs`-  field of GHC.Tc.Deriv.DerivInfo. Example (#16731):--    class C x1 x2--    type T :: a -> Type-    data T (x :: z) deriving (C z)--  When typechecking `C z`, we want `z` to map to `a`, which is exactly what the-  tcTyConScopedTyVars for T give us.--}--instance OutputableBndr tv => Outputable (VarBndr tv TyConBndrVis) where-  ppr (Bndr v bi) = ppr_bi bi <+> parens (pprBndr LetBind v)-    where-      ppr_bi (AnonTCB VisArg)     = text "anon-vis"-      ppr_bi (AnonTCB InvisArg)   = text "anon-invis"-      ppr_bi (NamedTCB Required)  = text "req"-      ppr_bi (NamedTCB Specified) = text "spec"-      ppr_bi (NamedTCB Inferred)  = text "inf"--instance Binary TyConBndrVis where-  put_ bh (AnonTCB af)   = do { putByte bh 0; put_ bh af }-  put_ bh (NamedTCB vis) = do { putByte bh 1; put_ bh vis }--  get bh = do { h <- getByte bh-              ; case h of-                  0 -> do { af  <- get bh; return (AnonTCB af) }-                  _ -> 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 GHC.Core.Lint-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-        tyConNullaryTy :: Type,--        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-  --     - unboxed sums-  -- 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-        tyConNullaryTy :: Type,           -- ^ A pre-allocated @TyConApp tycon []@--              -- 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 ...@.-                                        -- 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 {-        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-        tyConNullaryTy :: Type,           -- ^ A pre-allocated @TyConApp tycon []@-             -- 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-        synIsForgetful :: Bool   -- 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.-    }--  -- | 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-        tyConNullaryTy :: Type,           -- ^ A pre-allocated @TyConApp tycon []@-            -- 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 {-        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-        tyConNullaryTy :: Type,           -- ^ A pre-allocated @TyConApp tycon []@--        tcRoles       :: [Role], -- ^ The role for each type variable-                                 -- This list has length = tyConArity-                                 -- See also Note [TyCon Role signatures]--        primRepName :: TyConRepName   -- ^ The 'Typeable' representation.-                                      -- A cached version of-                                      -- @'mkPrelTyConRepName' ('tyConName' tc)@.-    }--  -- | 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 :: [TyConTyCoBinder], -- ^ Full binders-           -- TyConTyCoBinder: see Note [Promoted GADT data construtors]-        tyConResKind :: Kind,             -- ^ Result kind-        tyConKind    :: Kind,             -- ^ Kind of this TyCon-        tyConArity   :: Arity,            -- ^ Arity-        tyConNullaryTy :: Type,           -- ^ A pre-allocated @TyConApp tycon []@--        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 type-checking. See Note [How TcTyCons work]-  -- in "GHC.Tc.TyCl"-  | TcTyCon {-        tyConUnique :: Unique,-        tyConName   :: Name,--        -- 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-        tyConNullaryTy :: Type,           -- ^ A pre-allocated @TyConApp tycon []@--          -- 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--        tcTyConScopedTyVars :: [(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]--        tcTyConIsPoly     :: Bool, -- ^ Is this TcTyCon already generalized?-                                   -- Used only to make zonking more efficient--        tcTyConFlavour :: TyConFlavour-                           -- ^ What sort of 'TyCon' this represents.-      }--{- Note [Scoped tyvars in a TcTyCon]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The tcTyConScopedTyVars field records the lexicial-binding connection-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.Utils.TcType.--Note [Promoted GADT data constructors]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Any promoted GADT data constructor will have a type with equality-constraints in its type; e.g.-    K :: forall a b. (a ~# [b]) => a -> b -> T a--So, when promoted to become a type constructor, the tyConBinders-will include CoVars.  That is why we use [TyConTyCoBinder] for the-tyconBinders field.  TyConTyCoBinder is a synonym for TyConBinder,-but with the clue that the binder can be a CoVar not just a TyVar.--Note [Representation-polymorphic TyCons]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-To check for representation-polymorphism directly in the typechecker,-e.g. when using GHC.Tc.Utils.TcMType.checkTypeHasFixedRuntimeRep,-we need to compute whether a type has a syntactically fixed RuntimeRep,-as per Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete.--It's useful to have a quick way to check whether a saturated application-of a type constructor has a fixed RuntimeRep. That is, we want-to know, given a TyCon 'T' of arity 'n', does--  T a_1 ... a_n--always have a fixed RuntimeRep? That is, is it always the case-that this application has a kind of the form--  T a_1 ... a_n :: TYPE rep--in which 'rep' is a concrete 'RuntimeRep'?-('Concrete' in the sense of Note [The Concrete mechanism] in GHC.Tc.Utils.Concrete:-it contains no type-family applications or type variables.)--To answer this question, we have 'tcHasFixedRuntimeRep'.-If 'tcHasFixedRuntimeRep' returns 'True', it means we're sure that-every saturated application of `T` has a fixed RuntimeRep.-However, if it returns 'False', we don't know: perhaps some application might not-have a fixed RuntimeRep.--Examples:--  - For type families, we won't know in general whether an application-    will have a fixed RuntimeRep:--      type F :: k -> k-      type family F a where {..}--    `tcHasFixedRuntimeRep F = False'--  - For newtypes, we're usually OK:--      newtype N a b c = MkN Int--    No matter what arguments we apply `N` to, we always get something of-    kind `Type`, which has a fixed RuntimeRep.-    Thus `tcHasFixedRuntimeRep N = True`.--    However, with `-XUnliftedNewtypes`, we can have representation-polymorphic-    newtypes:--      type UN :: TYPE rep -> TYPE rep-      newtype UN a = MkUN a--    `tcHasFixedRuntimeRep UN = False`--    For example, `UN @Int8Rep Int8#` is represented by an 8-bit value,-    while `UN @LiftedRep Int` is represented by a heap pointer.--    To distinguish whether we are dealing with a representation-polymorphic newtype,-    we keep track of which situation we are in using the 'nt_fixed_rep'-    field of the 'NewTyCon' constructor of 'AlgTyConRhs', and read this field-    to compute 'tcHasFixedRuntimeRep'.--  - A similar story can be told for datatypes: we're usually OK,-    except with `-XUnliftedDatatypes` which allows for levity polymorphism,-    e.g.:--      type UC :: TYPE (BoxedRep l) -> TYPE (BoxedRep l)-      type UC a = MkUC a--    `tcHasFixedRuntimeRep UC = False`--    Here, we keep track of whether we are dealing with a levity-polymorphic-    unlifted datatype using the 'data_fixed_lev' field of the 'DataTyCon'-    constructor of 'AlgTyConRhs'.--    N.B.: technically, the representation of a datatype is fixed,-    as it is always a pointer. However, we currently require that we-    know the specific `RuntimeRep`: knowing that it's `BoxedRep l`-    for a type-variable `l` isn't enough. See #15532.--}---- | Represents right-hand-sides of 'TyCon's for algebraic types-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]-        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.-    }--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-                      -> [DataCon]-                      -> AlgTyConRhs-mkLevPolyDataTyConRhs fixed_lev cons-  = DataTyCon {-        data_cons = cons,-        data_cons_size = length cons,-        is_enum = not (null cons) && all is_enum_con cons,-                  -- See Note [Enumeration types] in GHC.Core.TyCon-        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.-mkDataTyConRhs :: [DataCon] -> AlgTyConRhs-mkDataTyConRhs = mkLevPolyDataTyConRhs False---- | Some promoted datacons signify extra info relevant to GHC. For example,--- the @IntRep@ constructor of @RuntimeRep@ corresponds to the 'IntRep'--- constructor of 'PrimRep'. This data structure allows us to store this--- 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 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@-  | LiftedInfo           -- ^ A constructor of @Levity@-  | UnliftedInfo         -- ^ 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 (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.Core.TyCo.Rep"-  | 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 :: *-    ---    -- 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 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,-  say) 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 trac #2578,  Otherwise we-end up generating an empty table for-  <mod>_<type>_closure_tbl-which is used by tagToEnum# to map Int# to constructors-in an enumeration. The empty table apparently upset-the linker.--Moreover, all the data constructor must be enumerations, meaning-they have type  (forall abc. T a b c).  GADTs are not enumerations.-For example consider-    data T a where-      T1 :: T Int-      T2 :: T Bool-      T3 :: T a-What would [T1 ..] be?  [T1,T3] :: T Int? Easiest thing is to exclude them.-See #4528.--Note [Newtype coercions]-~~~~~~~~~~~~~~~~~~~~~~~~-The NewTyCon field nt_co is a CoAxiom which is used for coercing from-the representation type of the newtype, to the newtype itself. For-example,--   newtype T a = MkT (a -> a)--the NewTyCon for T will contain nt_co = CoT where CoT :: forall a. T a ~ a -> a.--We might also eta-contract the axiom: see Note [Newtype eta].--Note [Newtype eta]-~~~~~~~~~~~~~~~~~~-Consider-        newtype Parser a = MkParser (IO a) deriving Monad-Are these two types equal? That is, does a coercion exist between them?-        Monad Parser-        Monad IO-(We need this coercion to make the derived instance for Monad Parser.)--Well, yes.  But to see that easily we eta-reduce the RHS type of-Parser, in this case to IO, so that even unsaturated applications of-Parser will work right.  So instead of-   axParser :: forall a. Parser a ~ IO a-we generate an eta-reduced axiom-   axParser :: Parser ~ IO--This eta reduction is done when the type constructor is built, in-GHC.Tc.TyCl.Build.mkNewTyConRhs, and cached in NewTyCon.--Here's an example that I think showed up in practice.-Source code:-        newtype T a = MkT [a]-        newtype Foo m = MkFoo (forall a. m a -> Int)--        w1 :: Foo []-        w1 = ...--        w2 :: Foo T-        w2 = MkFoo (\(MkT x) -> case w1 of MkFoo f -> f x)--After desugaring, and discarding the data constructors for the newtypes,-we would like to get:-        w2 = w1 `cast` Foo axT--so that w2 and w1 share the same code. To do this, the coercion axiom-axT must have-        kind:    axT :: T ~ []- and    arity:   0--See also Note [Newtype eta and homogeneous axioms] in GHC.Tc.TyCl.Build.--************************************************************************-*                                                                      *-                 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 (FunTyCon   { tcRepName = rep_nm })-  = Just rep_nm-tyConRepName_maybe (PrimTyCon  { primRepName = rep_nm })-  = Just rep_nm-tyConRepName_maybe (AlgTyCon { algTcFlavour = parent }) = case parent of-  VanillaAlgTyCon rep_nm -> Just rep_nm-  UnboxedSumTyCon        -> Nothing-  ClassTyCon _ rep_nm    -> Just rep_nm-  DataFamInstTyCon {}    -> Nothing-tyConRepName_maybe (FamilyTyCon { famTcFlav = DataFamilyTyCon rep_nm })-  = Just rep_nm-tyConRepName_maybe (PromotedDataCon { dataCon = dc, tcRepName = rep_nm })-  | isUnboxedSumDataCon dc   -- see #13276-  = Nothing-  | otherwise-  = 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 "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 type.  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-  = VoidRep-  | LiftedRep-  | UnliftedRep   -- ^ Unlifted pointer-  | 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 '(Un)liftedRep')-  | FloatRep-  | DoubleRep-  | VecRep Int PrimElemRep  -- ^ A vector-  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 VoidRep        = putByte bh 0-  put_ bh LiftedRep      = putByte bh 1-  put_ bh UnliftedRep    = 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 VoidRep-      1  -> pure LiftedRep-      2  -> pure UnliftedRep-      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--isVoidRep :: PrimRep -> Bool-isVoidRep VoidRep = True-isVoidRep _other  = False--isGcPtrRep :: PrimRep -> Bool-isGcPtrRep LiftedRep   = True-isGcPtrRep UnliftedRep = 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-   LiftedRep        -> platformWordSizeInBytes platform-   UnliftedRep      -> platformWordSizeInBytes platform-   VoidRep          -> 0-   (VecRep len rep) -> len * primElemRepSizeB platform rep--primElemRepSizeB :: Platform -> PrimElemRep -> Int-primElemRepSizeB platform = primRepSizeB platform . 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--{--************************************************************************-*                                                                      *-                             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 recommended to use 'GHC.Builtin.Types.funTyCon' if you want--- this functionality-mkFunTyCon :: Name -> [TyConBinder] -> Name -> TyCon-mkFunTyCon name binders rep_nm-  = let tc =-          FunTyCon {-              tyConUnique  = nameUnique name,-              tyConName    = name,-              tyConBinders = binders,-              tyConResKind = liftedTypeKind,-              tyConKind    = mkTyConKind binders liftedTypeKind,-              tyConArity   = length binders,-              tyConNullaryTy = mkNakedTyConTy tc,-              tcRepName    = rep_nm-          }-    in tc---- | 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-  = let tc =-          AlgTyCon {-              tyConName        = name,-              tyConUnique      = nameUnique name,-              tyConBinders     = binders,-              tyConResKind     = res_kind,-              tyConKind        = mkTyConKind binders res_kind,-              tyConArity       = length binders,-              tyConNullaryTy   = mkNakedTyConTy tc,-              tyConTyVars      = binderVars binders,-              tcRoles          = roles,-              tyConCType       = cType,-              algTcStupidTheta = stupid,-              algTcRhs         = rhs,-              algTcFields      = fieldsOfAlgTcRhs rhs,-              algTcFlavour     = assertPpr (okParent name parent) (ppr name $$ ppr parent) parent,-              algTcGadtSyntax  = gadt_syn-          }-    in tc---- | 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-  = let tc =-          AlgTyCon {-              tyConUnique      = nameUnique name,-              tyConName        = name,-              tyConBinders     = binders,-              tyConTyVars      = binderVars binders,-              tyConResKind     = res_kind,-              tyConKind        = mkTyConKind binders res_kind,-              tyConArity       = arity,-              tyConNullaryTy   = mkNakedTyConTy tc,-              tcRoles          = replicate arity Representational,-              tyConCType       = Nothing,-              algTcGadtSyntax  = False,-              algTcStupidTheta = [],-              algTcRhs         = TupleTyCon { data_con = con,-                                              tup_sort = sort },-              algTcFields      = emptyDFsEnv,-              algTcFlavour     = parent-          }-    in tc--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-  = let tc =-          AlgTyCon {-              tyConUnique      = nameUnique name,-              tyConName        = name,-              tyConBinders     = binders,-              tyConTyVars      = tyvars,-              tyConResKind     = res_kind,-              tyConKind        = mkTyConKind binders res_kind,-              tyConArity       = arity,-              tyConNullaryTy   = mkNakedTyConTy tc,-              tcRoles          = replicate arity Representational,-              tyConCType       = Nothing,-              algTcGadtSyntax  = False,-              algTcStupidTheta = [],-              algTcRhs         = mkSumTyConRhs cons,-              algTcFields      = emptyDFsEnv,-              algTcFlavour     = parent-          }-    in tc---- | 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 also Note [Kind checking recursive type and class declarations]--- in "GHC.Tc.TyCl".-mkTcTyCon :: Name-          -> [TyConBinder]-          -> Kind                -- ^ /result/ kind only-          -> [(Name,TcTyVar)]    -- ^ Scoped type variables;-                                 -- see Note [How TcTyCons work] in GHC.Tc.TyCl-          -> Bool                -- ^ Is this TcTyCon generalised already?-          -> TyConFlavour        -- ^ What sort of 'TyCon' this represents-          -> TyCon-mkTcTyCon name binders res_kind scoped_tvs poly flav-  = let tc =-          TcTyCon { tyConUnique  = getUnique name-                  , tyConName    = name-                  , tyConTyVars  = binderVars binders-                  , tyConBinders = binders-                  , tyConResKind = res_kind-                  , tyConKind    = mkTyConKind binders res_kind-                  , tyConArity   = length binders-                  , tyConNullaryTy = mkNakedTyConTy tc-                  , tcTyConScopedTyVars = scoped_tvs-                  , tcTyConIsPoly       = poly-                  , tcTyConFlavour      = flav }-    in tc---- | 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-  = let tc =-          PrimTyCon {-              tyConName    = name,-              tyConUnique  = nameUnique name,-              tyConBinders = binders,-              tyConResKind = res_kind,-              tyConKind    = mkTyConKind binders res_kind,-              tyConArity   = length roles,-              tyConNullaryTy = mkNakedTyConTy tc,-              tcRoles      = roles,-              primRepName  = mkPrelTyConRepName name-          }-    in tc---- | Create a type synonym 'TyCon'-mkSynonymTyCon :: Name -> [TyConBinder] -> Kind   -- ^ /result/ kind-               -> [Role] -> Type -> Bool -> Bool -> Bool -> TyCon-mkSynonymTyCon name binders res_kind roles rhs is_tau is_fam_free is_forgetful-  = let tc =-          SynonymTyCon {-              tyConName      = name,-              tyConUnique    = nameUnique name,-              tyConBinders   = binders,-              tyConResKind   = res_kind,-              tyConKind      = mkTyConKind binders res_kind,-              tyConArity     = length binders,-              tyConNullaryTy = mkNakedTyConTy tc,-              tyConTyVars    = binderVars binders,-              tcRoles        = roles,-              synTcRhs       = rhs,-              synIsTau       = is_tau,-              synIsFamFree   = is_fam_free,-              synIsForgetful = is_forgetful-          }-    in tc---- | 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-  = let tc =-          FamilyTyCon-            { tyConUnique  = nameUnique name-            , tyConName    = name-            , tyConBinders = binders-            , tyConResKind = res_kind-            , tyConKind    = mkTyConKind binders res_kind-            , tyConArity   = length binders-            , tyConNullaryTy = mkNakedTyConTy tc-            , tyConTyVars  = binderVars binders-            , famTcResVar  = resVar-            , famTcFlav    = flav-            , famTcParent  = classTyCon <$> parent-            , famTcInj     = inj-            }-    in tc----- | 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-                  -> [TyConTyCoBinder] -> Kind -> [Role]-                  -> RuntimeRepInfo -> TyCon-mkPromotedDataCon con name rep_name binders res_kind roles rep_info-  = let tc =-          PromotedDataCon {-            tyConUnique   = nameUnique name,-            tyConName     = name,-            tyConArity    = length roles,-            tyConNullaryTy = mkNakedTyConTy tc,-            tcRoles       = roles,-            tyConBinders  = binders,-            tyConResKind  = res_kind,-            tyConKind     = mkTyConKind binders res_kind,-            dataCon       = con,-            tcRepName     = rep_name,-            promDcRepInfo = rep_info-          }-    in tc--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---- | Does this 'TyCon' represent something that cannot be defined in Haskell?-isPrimTyCon :: TyCon -> Bool-isPrimTyCon (PrimTyCon {}) = True-isPrimTyCon _              = 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 { algTcFlavour = VanillaAlgTyCon _ }) = True-isVanillaAlgTyCon _                                              = False---- | Returns @True@ for the 'TyCon' of the 'Constraint' kind.-{-# INLINE isConstraintKindCon #-} -- See Note [Inlining coreView] in GHC.Core.Type-isConstraintKindCon :: TyCon -> Bool--- NB: We intentionally match on AlgTyCon, because 'constraintKindTyCon' is--- always an AlgTyCon (see 'pcTyCon' in TysWiredIn) and the record selector--- for 'tyConUnique' would generate unreachable code for every other data--- constructor of TyCon (see #18026).-isConstraintKindCon AlgTyCon { tyConUnique = u } = u == constraintKindTyConKey-isConstraintKindCon _                            = 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 "GHC.Tc.Solver.Canonical"-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 [How TcTyCons work] item (1) in GHC.Tc.TyCl---- | '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 "GHC.Tc.Solver.Canonical"-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---- | 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 (SynonymTyCon {}) = True-isTypeSynonymTyCon _                 = False--isTauTyCon :: TyCon -> Bool-isTauTyCon (SynonymTyCon { synIsTau = is_tau }) = is_tau-isTauTyCon _                                    = True---- | Is this tycon neither a type family nor a synonym that expands--- to a type family?-isFamFreeTyCon :: TyCon -> Bool-isFamFreeTyCon (SynonymTyCon { synIsFamFree = fam_free }) = fam_free-isFamFreeTyCon (FamilyTyCon { famTcFlav = flav })         = isDataFamFlav flav-isFamFreeTyCon _                                          = 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.-isForgetfulSynTyCon :: TyCon -> Bool-isForgetfulSynTyCon (SynonymTyCon { synIsForgetful = forget }) = forget-isForgetfulSynTyCon _                                          = False---- 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 mustBeSaturated on a regular H98--- type synonym, because you should probably have expanded it first--- But regardless, it's not decomposable-mustBeSaturated :: TyCon -> Bool-mustBeSaturated = tcFlavourMustBeSaturated . tyConFlavour---- | 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 GHC.Core.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---- | @'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-  | FamilyTyCon { famTcInj = inj } <- tc-  = inj-  | isInjectiveTyCon tc Nominal-  = Injective (replicate (tyConArity tc) True)-  | otherwise-  = NotInjective--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---- | 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---- | Get the enclosing class TyCon (if there is one) for the given TyConFlavour-tyConFlavourAssoc_maybe :: TyConFlavour -> Maybe TyCon-tyConFlavourAssoc_maybe (DataFamilyFlavour mb_parent)     = mb_parent-tyConFlavourAssoc_maybe (OpenTypeFamilyFlavour mb_parent) = mb_parent-tyConFlavourAssoc_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--isLiftedAlgTyCon :: TyCon -> Bool-isLiftedAlgTyCon (AlgTyCon { tyConResKind = res_kind })-  = isLiftedTypeKind res_kind-isLiftedAlgTyCon _ = 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, liftedRepTyConKey, constraintKindTyConKey, tYPETyConKey ]-  : map (mkUniqSet . 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 (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--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@(TcTyCon {}) kind = let tc' = tc { tyConKind = kind-                                                   , tyConNullaryTy = mkNakedTyConTy tc'-                                                       -- see Note [Sharing nullary TyCons]-                                                   }-                                      in tc'-setTcTyConKind tc              _    = pprPanic "setTcTyConKind" (ppr tc)---- | Does this 'TyCon' have a syntactically fixed RuntimeRep when fully applied,--- as per Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete?------ False is safe. True means we're sure.--- Does only a quick check, based on the TyCon's category.------ See Note [Representation-polymorphic TyCons]-tcHasFixedRuntimeRep :: TyCon -> Bool-tcHasFixedRuntimeRep FunTyCon{}           = True-tcHasFixedRuntimeRep (AlgTyCon { algTcRhs = rhs }) = case rhs of-  AbstractTyCon {} -> False-          -- An abstract TyCon might not have a fixed runtime representation.-          -- Note that this is an entirely different matter from the concreteness-          -- of the 'TyCon', in the sense of 'isConcreteTyCon'.--  DataTyCon { data_fixed_lev = fixed_lev } -> fixed_lev-          -- A datatype might not have a fixed levity with UnliftedDatatypes (#20423).-          -- NB: the current representation-polymorphism checks require that-          -- the representation be fully-known, including levity variables.-          -- This might be relaxed in the future (#15532).--  TupleTyCon { tup_sort = tuple_sort } -> isBoxed (tupleSortBoxity tuple_sort)--  SumTyCon {} -> False   -- only unboxed sums here--  NewTyCon { nt_fixed_rep = fixed_rep } -> fixed_rep-         -- A newtype might not have a fixed runtime representation-         -- with UnliftedNewtypes (#17360)--tcHasFixedRuntimeRep SynonymTyCon{}       = False   -- conservative choice-tcHasFixedRuntimeRep FamilyTyCon{}        = False-tcHasFixedRuntimeRep PrimTyCon{}          = True-tcHasFixedRuntimeRep TcTyCon{}            = False-tcHasFixedRuntimeRep tc@PromotedDataCon{} = pprPanic "tcHasFixedRuntimeRep datacon" (ppr tc)---- | Is this 'TyCon' concrete (i.e. not a synonym/type family)?------ Used for representation polymorphism checks.-isConcreteTyCon :: TyCon -> Bool-isConcreteTyCon = isConcreteTyConFlavour . tyConFlavour---- | Is this 'TyConFlavour' concrete (i.e. not a synonym/type family)?------ Used for representation polymorphism checks.-isConcreteTyConFlavour :: TyConFlavour -> Bool-isConcreteTyConFlavour = \case-  ClassFlavour             -> True-  TupleFlavour {}          -> True-  SumFlavour               -> True-  DataTypeFlavour          -> True-  NewtypeFlavour           -> True-  AbstractTypeFlavour      -> True  -- See Note [Concrete types] in GHC.Tc.Utils.Concrete-  DataFamilyFlavour {}     -> False-  OpenTypeFamilyFlavour {} -> False-  ClosedTypeFamilyFlavour  -> False-  TypeSynonymFlavour       -> False-  BuiltInTypeFlavour       -> True-  PromotedDataConFlavour   -> True--{----------------------------------------------------      Expand type-constructor applications--------------------------------------------------}--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--- Return Nothing if the TyCon is not a synonym,--- or if not enough arguments are supplied-expandSynTyCon_maybe tc tys-  | SynonymTyCon { tyConTyVars = tvs, synTcRhs = rhs, tyConArity = arity } <- tc-  = if arity == 0-    then Just ([], rhs, tys)  -- Avoid a bit of work in the case of nullary synonyms-    else case tys `listLengthCmp` arity of-              GT -> Just (tvs `zip` tys, rhs, drop arity tys)-              EQ -> Just (tvs `zip` tys, rhs, [])-              LT -> 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.---- 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 (AlgTyCon { algTcRhs = rhs, algTcFlavour = parent }) =-  case rhs of-    DataTyCon {}  -> isSrcParent-    NewTyCon {}   -> isSrcParent-    TupleTyCon {} -> isSrcParent-    _ -> False-  where-    isSrcParent = isNoParent parent-isTyConWithSrcDataCons (FamilyTyCon { famTcFlav = DataFamilyTyCon {} })-                         = True -- #14058-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.-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---- | 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)---- | Like 'tyConSingleDataCon_maybe', but returns 'Nothing' for newtypes.-tyConSingleAlgDataCon_maybe :: TyCon -> Maybe DataCon-tyConSingleAlgDataCon_maybe tycon-  | isNewTyCon tycon = Nothing-  | otherwise        = tyConSingleDataCon_maybe tycon---- | Returns @Just dcs@ if the given 'TyCon' is a @data@ type, a tuple type--- or a sum type with data constructors dcs. If the 'TyCon' has more than one--- constructor, or represents a primitive or function type constructor then--- @Nothing@ is returned.------ Like 'tyConDataCons_maybe', but returns 'Nothing' for newtypes.-tyConAlgDataCons_maybe :: TyCon -> Maybe [DataCon]-tyConAlgDataCons_maybe tycon-  | isNewTyCon tycon = Nothing-  | otherwise        = tyConDataCons_maybe tycon---- | 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_size = size } -> size-      NewTyCon {}                    -> 1-      TupleTyCon {}                  -> 1-      SumTyCon { data_cons_size = size }  -> size-      _                              -> 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 {}                         -> [Nominal, Nominal, Nominal, Representational, 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 ...@. See @Note [The stupid context]@ in "GHC.Core.DataCon".-tyConStupidTheta :: TyCon -> [PredType]-tyConStupidTheta (AlgTyCon {algTcStupidTheta = stupid}) = stupid-tyConStupidTheta (FunTyCon {}) = []-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 {algTcFlavour = ClassTyCon {}}) = True-isClassTyCon _                                        = False---- | If this 'TyCon' is that for a class instance, return the class it is for.--- Otherwise returns @Nothing@-tyConClass_maybe :: TyCon -> Maybe Class-tyConClass_maybe (AlgTyCon {algTcFlavour = ClassTyCon clas _}) = Just clas-tyConClass_maybe _                                            = Nothing---- | Return the associated types of the 'TyCon', if any-tyConATs :: TyCon -> [TyCon]-tyConATs (AlgTyCon {algTcFlavour = ClassTyCon clas _}) = classATs clas-tyConATs _                                            = []--------------------------------------------------------------------------------- | Is this 'TyCon' that for a data family instance?-isFamInstTyCon :: TyCon -> Bool-isFamInstTyCon (AlgTyCon {algTcFlavour = DataFamInstTyCon {} })-  = True-isFamInstTyCon _ = False--tyConFamInstSig_maybe :: TyCon -> Maybe (TyCon, [Type], CoAxiom Unbranched)-tyConFamInstSig_maybe (AlgTyCon {algTcFlavour = DataFamInstTyCon ax f ts })-  = Just (f, ts, ax)-tyConFamInstSig_maybe _ = Nothing---- | If this 'TyCon' is that of a data family instance, return the family in question--- and the instance types. Otherwise, return @Nothing@-tyConFamInst_maybe :: TyCon -> Maybe (TyCon, [Type])-tyConFamInst_maybe (AlgTyCon {algTcFlavour = 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 {algTcFlavour = 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.--{--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---- | Paints a picture of what a 'TyCon' represents, in broad strokes.--- This is used towards more informative error messages.-data TyConFlavour-  = ClassFlavour-  | TupleFlavour Boxity-  | SumFlavour-  | DataTypeFlavour-  | NewtypeFlavour-  | AbstractTypeFlavour-  | DataFamilyFlavour (Maybe TyCon)     -- Just tc <=> (tc == associated class)-  | OpenTypeFamilyFlavour (Maybe TyCon) -- Just tc <=> (tc == associated class)-  | ClosedTypeFamilyFlavour-  | TypeSynonymFlavour-  | BuiltInTypeFlavour -- ^ e.g., the @(->)@ 'TyCon'.-  | PromotedDataConFlavour-  deriving Eq--instance Outputable TyConFlavour 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 (DataFamilyFlavour (Just _))  = "associated data family"-      go (DataFamilyFlavour Nothing)   = "data family"-      go (OpenTypeFamilyFlavour (Just _)) = "associated type family"-      go (OpenTypeFamilyFlavour Nothing)  = "type family"-      go ClosedTypeFamilyFlavour = "type family"-      go TypeSynonymFlavour      = "type synonym"-      go BuiltInTypeFlavour      = "built-in type"-      go PromotedDataConFlavour  = "promoted data constructor"--tyConFlavour :: TyCon -> TyConFlavour-tyConFlavour (AlgTyCon { algTcFlavour = parent, algTcRhs = rhs })-  | ClassTyCon _ _ <- parent = ClassFlavour-  | otherwise = case rhs of-                  TupleTyCon { tup_sort = sort }-                                     -> TupleFlavour (tupleSortBoxity sort)-                  SumTyCon {}        -> SumFlavour-                  DataTyCon {}       -> DataTypeFlavour-                  NewTyCon {}        -> NewtypeFlavour-                  AbstractTyCon {}   -> AbstractTypeFlavour-tyConFlavour (FamilyTyCon { famTcFlav = flav, famTcParent = parent })-  = case flav of-      DataFamilyTyCon{}            -> DataFamilyFlavour parent-      OpenSynFamilyTyCon           -> OpenTypeFamilyFlavour parent-      ClosedSynFamilyTyCon{}       -> ClosedTypeFamilyFlavour-      AbstractClosedSynFamilyTyCon -> ClosedTypeFamilyFlavour-      BuiltInSynFamTyCon{}         -> ClosedTypeFamilyFlavour-tyConFlavour (SynonymTyCon {})    = TypeSynonymFlavour-tyConFlavour (FunTyCon {})        = BuiltInTypeFlavour-tyConFlavour (PrimTyCon {})       = BuiltInTypeFlavour-tyConFlavour (PromotedDataCon {}) = PromotedDataConFlavour-tyConFlavour (TcTyCon { tcTyConFlavour = flav }) = flav---- | Can this flavour of 'TyCon' appear unsaturated?-tcFlavourMustBeSaturated :: TyConFlavour -> Bool-tcFlavourMustBeSaturated ClassFlavour            = False-tcFlavourMustBeSaturated DataTypeFlavour         = False-tcFlavourMustBeSaturated NewtypeFlavour          = False-tcFlavourMustBeSaturated DataFamilyFlavour{}     = False-tcFlavourMustBeSaturated TupleFlavour{}          = False-tcFlavourMustBeSaturated SumFlavour              = False-tcFlavourMustBeSaturated AbstractTypeFlavour {}  = False-tcFlavourMustBeSaturated BuiltInTypeFlavour      = False-tcFlavourMustBeSaturated PromotedDataConFlavour  = False-tcFlavourMustBeSaturated TypeSynonymFlavour      = True-tcFlavourMustBeSaturated OpenTypeFamilyFlavour{} = True-tcFlavourMustBeSaturated ClosedTypeFamilyFlavour = True---- | Is this flavour of 'TyCon' an open type family or a data family?-tcFlavourIsOpen :: TyConFlavour -> Bool-tcFlavourIsOpen DataFamilyFlavour{}     = True-tcFlavourIsOpen OpenTypeFamilyFlavour{} = 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-  = 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) } }+{-# LANGUAGE FlexibleInstances  #-}+{-# LANGUAGE LambdaCase         #-}+{-# LANGUAGE DeriveDataTypeable #-}++{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+++The @TyCon@ datatype+-}++module GHC.Core.TyCon(+        -- * Main TyCon data types+        TyCon,+        AlgTyConRhs(..), visibleDataCons,+        AlgTyConFlav(..), isNoParent,+        FamTyConFlav(..), Role(..), Injectivity(..),+        PromDataConInfo(..), TyConFlavour(..),++        -- * TyConBinder+        TyConBinder, TyConBndrVis(..),+        mkNamedTyConBinder, mkNamedTyConBinders,+        mkRequiredTyConBinder,+        mkAnonTyConBinder, mkAnonTyConBinders,+        tyConBinderForAllTyFlag, tyConBndrVisForAllTyFlag, isNamedTyConBinder,+        isVisibleTyConBinder, isInvisSpecTyConBinder, isInvisibleTyConBinder,+        isInferredTyConBinder,+        isVisibleTcbVis, isInvisSpecTcbVis,++        -- ** Field labels+        tyConFieldLabels, lookupTyConFieldLabel,++        -- ** Constructing TyCons+        mkAlgTyCon,+        mkClassTyCon,+        mkPrimTyCon,+        mkTupleTyCon,+        mkSumTyCon,+        mkDataTyConRhs,+        mkLevPolyDataTyConRhs,+        mkSynonymTyCon,+        mkFamilyTyCon,+        mkPromotedDataCon,+        mkTcTyCon,+        noTcTyConScopedTyVars,++        -- ** Predicates on TyCons+        isAlgTyCon, isVanillaAlgTyCon, isClassTyCon,+        isUnaryClassTyCon, isUnaryClassTyCon_maybe,+        isFamInstTyCon,+        isPrimTyCon,+        isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon,+        isUnboxedSumTyCon, isPromotedTupleTyCon,+        isLiftedAlgTyCon,+        isTypeSynonymTyCon,+        tyConMustBeSaturated,+        isPromotedDataCon, isPromotedDataCon_maybe,+        isDataKindsPromotedDataCon,+        isKindTyCon, isKindName, isLiftedTypeKindTyConName,+        isTauTyCon, isFamFreeTyCon, isForgetfulSynTyCon,++        isBoxedDataTyCon,+        isTypeDataTyCon,+        isEnumerationTyCon,+        isNewTyCon, isAbstractTyCon,+        isFamilyTyCon, isOpenFamilyTyCon,+        isTypeFamilyTyCon, isDataFamilyTyCon,+        isOpenTypeFamilyTyCon, isClosedSynFamilyTyConWithAxiom_maybe,+        tyConInjectivityInfo,+        isBuiltInSynFamTyCon_maybe,+        isGadtSyntaxTyCon, isInjectiveTyCon, isGenerativeTyCon,+        isTyConAssoc, tyConAssoc_maybe, tyConFlavourAssoc_maybe,+        isImplicitTyCon,+        isTyConWithSrcDataCons,+        isTcTyCon, setTcTyConKind,+        tcHasFixedRuntimeRep,+        isConcreteTyCon,+        isValidDTT2TyCon,++        -- ** Extracting information out of TyCons+        tyConName,+        tyConSkolem,+        tyConKind,+        tyConUnique,+        tyConTyVars, tyConVisibleTyVars,+        tyConCType_maybe,+        tyConDataCons, tyConDataCons_maybe,+        tyConSingleDataCon_maybe, tyConSingleDataCon,+        tyConFamilySize,+        tyConStupidTheta,+        tyConArity,+        tyConNullaryTy, mkTyConTy,+        tyConRoles,+        tyConFlavour,+        tyConTuple_maybe, tyConClass_maybe, tyConATs,+        tyConFamInst_maybe, tyConFamInstSig_maybe, tyConFamilyCoercion_maybe,+        tyConFamilyResVar_maybe,+        synTyConDefn_maybe, synTyConRhs_maybe,+        famTyConFlav_maybe,+        algTyConRhs,+        newTyConRhs, newTyConEtadArity, newTyConEtadRhs,+        unwrapNewTyCon_maybe, unwrapNewTyConEtad_maybe,+        newTyConDataCon_maybe,+        algTcFields,+        tyConPromDataConInfo,+        tyConBinders, tyConResKind, tyConInvisTVBinders,+        tcTyConScopedTyVars, isMonoTcTyCon,+        tyConHasClosedResKind,+        mkTyConTagMap,++        -- ** Manipulating TyCons+        ExpandSynResult(..),+        expandSynTyCon_maybe,+        newTyConCo, newTyConCo_maybe,+        pprPromotionQuote, mkTyConKind,++        -- ** Predicated on TyConFlavours+        tcFlavourIsOpen,++        -- * Runtime type representation+        TyConRepName, tyConRepName_maybe,+        mkPrelTyConRepName,+        tyConRepModOcc,++        -- * Primitive representations of Types+        PrimRep(..), PrimElemRep(..), Levity(..),+        PrimOrVoidRep(..),+        primElemRepToPrimRep,+        isGcPtrRep,+        primRepSizeB, primRepSizeW64_B,+        primElemRepSizeB, primElemRepSizeW64_B,+        primRepIsFloat,+        primRepsCompatible,+        primRepCompatible,+        primRepIsWord,+        primRepIsInt,++) where++import GHC.Prelude+import GHC.Platform++import {-# SOURCE #-} GHC.Core.TyCo.Rep+   ( Kind, Type, PredType, mkForAllTy, mkNakedFunTy, mkNakedTyConTy )+import {-# SOURCE #-} GHC.Core.TyCo.FVs+   ( noFreeVarsOfType )+import {-# SOURCE #-} GHC.Core.TyCo.Ppr+   ( pprType )+import {-# SOURCE #-} GHC.Builtin.Types+   ( runtimeRepTyCon, constraintKind, levityTyCon+   , multiplicityTyCon+   , vecCountTyCon, vecElemTyCon )+import {-# SOURCE #-} GHC.Core.DataCon+   ( DataCon, dataConFieldLabels+   , dataConTyCon, dataConFullSig+   , isUnboxedSumDataCon, isTypeDataCon )+import {-# SOURCE #-} GHC.Core.Type+   ( isLiftedTypeKind )+import GHC.Builtin.Uniques+  ( tyConRepNameUnique+  , dataConTyRepNameUnique )++import GHC.Utils.Binary+import GHC.Types.Var+import GHC.Types.Var.Set+import GHC.Core.Class+import GHC.Types.Basic+import GHC.Types.ForeignCall+import GHC.Types.Name+import GHC.Types.Name.Env+import GHC.Core.Coercion.Axiom+import GHC.Builtin.Names+import GHC.Data.Maybe+import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Data.FastString.Env+import GHC.Types.FieldLabel+import GHC.Settings.Constants+import GHC.Utils.Misc+import GHC.Types.Unique.Set+import GHC.Unit.Module+import Control.DeepSeq++import Language.Haskell.Syntax.Basic (FieldLabelString(..))++import qualified Data.Data as Data++{-+-----------------------------------------------+        Notes about type families+-----------------------------------------------++Note [Type synonym families]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+* Type synonym families, also known as "type functions", map directly+  onto the type functions in FC:++        type family F a :: Type+        type instance F Int = Bool+        ..etc...++* Reply "yes" to isTypeFamilyTyCon, and isFamilyTyCon++* From the user's point of view (F Int) and Bool are simply+  equivalent types.++* A Haskell 98 type synonym is a degenerate form of a type synonym+  family.++* Type functions can't appear in the LHS of a type function:+        type instance F (F Int) = ...   -- BAD!++* Translation of type family decl:+        type family F a :: Type+  translates to+    a FamilyTyCon 'F', whose FamTyConFlav is OpenSynFamilyTyCon++        type family G a :: Type where+          G Int = Bool+          G Bool = Char+          G a = ()+  translates to+    a FamilyTyCon 'G', whose FamTyConFlav is ClosedSynFamilyTyCon, with the+    appropriate CoAxiom representing the equations++We also support injective type families -- see Note [Injective type families]++Note [Data type families]+~~~~~~~~~~~~~~~~~~~~~~~~~+See also Note [Wrappers for data instance tycons] in GHC.Types.Id.Make++* Data type families are declared thus+        data family T a :: Type+        data instance T Int = T1 | T2 Bool++  Here T is the "family TyCon".++* Reply "yes" to isDataFamilyTyCon, and isFamilyTyCon++* The user does not see any "equivalent types" as they did with type+  synonym families.  They just see constructors with types+        T1 :: T Int+        T2 :: Bool -> T Int++* Here's the FC version of the above declarations:++        data T a+        data R:TInt = T1 | T2 Bool+        axiom ax_ti : T Int ~R R:TInt++  Note that this is a *representational* coercion+  The R:TInt is the "representation TyCons".+  It has an AlgTyConFlav of+        DataFamInstTyCon T [Int] ax_ti++* The axiom ax_ti may be eta-reduced; see+  Note [Eta reduction for data families] in GHC.Core.Coercion.Axiom++* Data family instances may have a different arity than the data family.+  See Note [Arity of data families] in GHC.Core.FamInstEnv++* The data constructor T2 has a wrapper (which is what the+  source-level "T2" invokes):++        $WT2 :: Bool -> T Int+        $WT2 b = T2 b `cast` sym ax_ti++* A data instance can declare a fully-fledged GADT:++        data instance T (a,b) where+          X1 :: T (Int,Bool)+          X2 :: a -> b -> T (a,b)++  Here's the FC version of the above declaration:++        data R:TPair a b where+          X1 :: R:TPair Int Bool+          X2 :: a -> b -> R:TPair a b+        axiom ax_pr :: T (a,b)  ~R  R:TPair a b++        $WX1 :: forall a b. a -> b -> T (a,b)+        $WX1 a b (x::a) (y::b) = X2 a b x y `cast` sym (ax_pr a b)++  The R:TPair are the "representation TyCons".+  We have a bit of work to do, to unpick the result types of the+  data instance declaration for T (a,b), to get the result type in the+  representation; e.g.  T (a,b) --> R:TPair a b++  The representation TyCon R:TList, has an AlgTyConFlav of++        DataFamInstTyCon T [(a,b)] ax_pr++* Notice that T is NOT translated to a FC type function; it just+  becomes a "data type" with no constructors, which can be coerced+  into R:TInt, R:TPair by the axioms.  These axioms+  axioms come into play when (and *only* when) you+        - use a data constructor+        - do pattern matching+  Rather like newtype, in fact++  As a result++  - T behaves just like a data type so far as decomposition is concerned++  - (T Int) is not implicitly converted to R:TInt during type inference.+    Indeed the latter type is unknown to the programmer.++  - There *is* an instance for (T Int) in the type-family instance+    environment, but it is looked up (via tcLookupDataFamilyInst)+    in can_eq_nc (via tcTopNormaliseNewTypeTF_maybe) when trying to+    solve representational equalities like+         T Int ~R# Bool+    Here we look up (T Int), convert it to R:TInt, and then unwrap the+    newtype R:TInt.++    It is also looked up in reduceTyFamApp_maybe.++  - It's fine to have T in the LHS of a type function:+    type instance F (T a) = [a]++  It was this last point that confused me!  The big thing is that you+  should not think of a data family T as a *type function* at all, not+  even an injective one!  We can't allow even injective type functions+  on the LHS of a type function:+        type family injective G a :: Type+        type instance F (G Int) = Bool+  is no good, even if G is injective, because consider+        type instance G Int = Bool+        type instance F Bool = Char++  So a data type family is not an injective type function. It's just a+  data type with some axioms that connect it to other data types.++* The tyConTyVars of the representation tycon are the tyvars that the+  user wrote in the patterns. This is important in GHC.Tc.Deriv, where we+  bring these tyvars into scope before type-checking the deriving+  clause. This fact is arranged for in TcInstDecls.tcDataFamInstDecl.++Note [Associated families and their parent class]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+*Associated* families are just like *non-associated* families, except+that they have a famTcParent field of (Just cls_tc), which identifies the+parent class.++However there is an important sharing relationship between+  * the tyConTyVars of the parent Class+  * the tyConTyVars of the associated TyCon++   class C a b where+     data T p a+     type F a q b++Here the 'a' and 'b' are shared with the 'Class'; that is, they have+the same Unique.++This is important. In an instance declaration we expect+  * all the shared variables to be instantiated the same way+  * the non-shared variables of the associated type should not+    be instantiated at all++  instance C [x] (Tree y) where+     data T p [x] = T1 x | T2 p+     type F [x] q (Tree y) = (x,y,q)++Note [TyCon Role signatures]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Every tycon has a role signature, assigning a role to each of the tyConTyVars+(or of equal length to the tyConArity, if there are no tyConTyVars). An+example demonstrates these best: say we have a tycon T, with parameters a at+nominal, b at representational, and c at phantom. Then, to prove+representational equality between T a1 b1 c1 and T a2 b2 c2, we need to have+nominal equality between a1 and a2, representational equality between b1 and+b2, and nothing in particular (i.e., phantom equality) between c1 and c2. This+might happen, say, with the following declaration:++  data T a b c where+    MkT :: b -> T Int b c++Data and class tycons have their roles inferred (see inferRoles in GHC.Tc.TyCl.Utils),+as do vanilla synonym tycons. Family tycons have all parameters at role N,+though it is conceivable that we could relax this restriction. (->)'s and+tuples' parameters are at role R. Each primitive tycon declares its roles;+it's worth noting that (~#)'s parameters are at role N. Promoted data+constructors' type arguments are at role R. All kind arguments are at role+N.++Note [Unboxed tuple RuntimeRep vars]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The contents of an unboxed tuple may have any representation. Accordingly,+the kind of the unboxed tuple constructor is runtime-representation+polymorphic.++Type constructor (2 kind arguments)+   (#,#) :: forall (q :: RuntimeRep) (r :: RuntimeRep).+                   TYPE q -> TYPE r -> TYPE (TupleRep [q, r])+Data constructor (4 type arguments)+   (#,#) :: forall (q :: RuntimeRep) (r :: RuntimeRep)+                   (a :: TYPE q) (b :: TYPE r). a -> b -> (# a, b #)++These extra tyvars (q and r) cause some delicate processing around tuples,+where we need to manually insert RuntimeRep arguments.+The same situation happens with unboxed sums: each alternative+has its own RuntimeRep.+For boxed tuples, there is no representation polymorphism, and therefore+we add RuntimeReps only for the unboxed version.++Type constructor (no kind arguments)+   (,) :: Type -> Type -> Type+Data constructor (2 type arguments)+   (,) :: forall a b. a -> b -> (a, b)+++Note [Injective type families]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We allow injectivity annotations for type families (both open and closed):++  type family F (a :: k) (b :: k) = r | r -> a+  type family G a b = res | res -> a b where ...++Injectivity information is stored in the `famTcInj` field of `FamilyTyCon`.+`famTcInj` maybe stores a list of Bools, where each entry corresponds to a+single element of `tyConTyVars` (both lists should have identical length). If no+injectivity annotation was provided `famTcInj` is Nothing. From this follows an+invariant that if `famTcInj` is a Just then at least one element in the list+must be True.++See also:+ * [Injectivity annotation] in GHC.Hs.Decls+ * [Renaming injectivity annotation] in GHC.Rename.Module+ * [Verifying injectivity annotation] in GHC.Core.FamInstEnv+ * [Type inference for type families with injectivity] in GHC.Tc.Solver.Equality++Note [Sharing nullary TyConApps]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Nullary type constructor applications are extremely common. For this reason+each TyCon carries with it a @TyConApp tycon []@. This ensures that+'mkTyConTy' does not need to allocate and eliminates quite a bit of heap+residency. Furthermore, we use 'mkTyConTy' in the nullary case of 'mkTyConApp',+ensuring that this function also benefits from sharing.++This optimisation improves allocations in the Cabal test by around 0.3% and+decreased cache misses measurably.++See #19367.+++************************************************************************+*                                                                      *+                    TyConBinder+*                                                                      *+************************************************************************+-}++type TyConBinder     = VarBndr TyVar   TyConBndrVis++data TyConBndrVis+  = NamedTCB ForAllTyFlag  -- ^ A named, forall-bound variable (invisible or not)+  | AnonTCB                -- ^ an ordinary, visible type argument++instance Outputable TyConBndrVis where+  ppr (NamedTCB flag) = ppr flag+  ppr AnonTCB         = text "AnonTCB"++mkAnonTyConBinder :: TyVar -> TyConBinder+-- Make a visible anonymous TyCon binder+mkAnonTyConBinder tv = assert (isTyVar tv) $+                       Bndr tv AnonTCB++mkAnonTyConBinders :: [TyVar] -> [TyConBinder]+mkAnonTyConBinders tvs = map mkAnonTyConBinder tvs++mkNamedTyConBinder :: ForAllTyFlag -> TyVar -> TyConBinder+-- The odd argument order supports currying+mkNamedTyConBinder vis tv = assert (isTyVar tv) $+                            Bndr tv (NamedTCB vis)++mkNamedTyConBinders :: ForAllTyFlag -> [TyVar] -> [TyConBinder]+-- The odd argument order supports currying+mkNamedTyConBinders vis tvs = map (mkNamedTyConBinder vis) tvs++-- | Make a Required TyConBinder. It chooses between NamedTCB and+-- AnonTCB based on whether the tv is mentioned in the dependent set+mkRequiredTyConBinder :: TyCoVarSet  -- these are used dependently+                      -> TyVar+                      -> TyConBinder+mkRequiredTyConBinder dep_set tv+  | tv `elemVarSet` dep_set = mkNamedTyConBinder Required tv+  | otherwise               = mkAnonTyConBinder tv++tyConBinderForAllTyFlag :: VarBndr a TyConBndrVis -> ForAllTyFlag+tyConBinderForAllTyFlag (Bndr _ vis) = tyConBndrVisForAllTyFlag vis++tyConBndrVisForAllTyFlag :: TyConBndrVis -> ForAllTyFlag+tyConBndrVisForAllTyFlag (NamedTCB vis) = vis+tyConBndrVisForAllTyFlag AnonTCB        = Required++isNamedTyConBinder :: TyConBinder -> Bool+-- Identifies kind variables+-- E.g. data T k (a:k) = blah+-- Here 'k' is a NamedTCB, a variable used in the kind of other binders+isNamedTyConBinder (Bndr _ (NamedTCB {})) = True+isNamedTyConBinder _                      = False++isVisibleTyConBinder :: VarBndr tv TyConBndrVis -> Bool+-- Works for IfaceTyConBinder too+isVisibleTyConBinder (Bndr _ tcb_vis) = isVisibleTcbVis tcb_vis++isVisibleTcbVis :: TyConBndrVis -> Bool+isVisibleTcbVis (NamedTCB vis) = isVisibleForAllTyFlag vis+isVisibleTcbVis AnonTCB        = True++isInvisSpecTcbVis :: TyConBndrVis -> Bool+isInvisSpecTcbVis (NamedTCB Specified) = True+isInvisSpecTcbVis _                    = False++isInvisInferTcbVis :: TyConBndrVis -> Bool+isInvisInferTcbVis (NamedTCB Inferred) = True+isInvisInferTcbVis _                   = False++isInvisSpecTyConBinder :: VarBndr tv TyConBndrVis -> Bool+-- Works for IfaceTyConBinder too+isInvisSpecTyConBinder (Bndr _ tcb_vis) = isInvisSpecTcbVis tcb_vis++isInvisibleTyConBinder :: VarBndr tv TyConBndrVis -> Bool+-- Works for IfaceTyConBinder too+isInvisibleTyConBinder tcb = not (isVisibleTyConBinder tcb)++isInferredTyConBinder :: VarBndr var TyConBndrVis -> Bool+-- Works for IfaceTyConBinder too+isInferredTyConBinder (Bndr _ tcb_vis) = isInvisInferTcbVis tcb_vis++-- Build the 'tyConKind' from the binders and the result kind.+-- Keep in sync with 'mkTyConKind' in GHC.Iface.Type.+mkTyConKind :: [TyConBinder] -> Kind -> Kind+mkTyConKind bndrs res_kind = foldr mk res_kind bndrs+  where+    mk :: TyConBinder -> Kind -> Kind+    mk (Bndr tv (NamedTCB vis)) k = mkForAllTy (Bndr tv vis) k+    mk (Bndr tv AnonTCB)        k = mkNakedFunTy FTF_T_T (varType tv) k+    -- mkNakedFunTy: see Note [Naked FunTy] in GHC.Builtin.Types++-- | (mkTyConTy tc) returns (TyConApp tc [])+-- but arranges to share that TyConApp among all calls+-- See Note [Sharing nullary TyConApps]+-- So it's just an alias for tyConNullaryTy!+mkTyConTy :: TyCon -> Type+mkTyConTy tycon = tyConNullaryTy tycon++tyConInvisTVBinders :: [TyConBinder]   -- From the TyCon+                    -> [InvisTVBinder] -- Suitable for the foralls of a term function+-- See Note [Building TyVarBinders from TyConBinders]+tyConInvisTVBinders tc_bndrs+ = map mk_binder tc_bndrs+ where+   mk_binder (Bndr tv tc_vis) = mkTyVarBinder vis tv+      where+        vis = case tc_vis of+                AnonTCB                  -> SpecifiedSpec+                NamedTCB Required        -> SpecifiedSpec+                NamedTCB (Invisible vis) -> vis++-- Returns only tyvars, as covars are always inferred+tyConVisibleTyVars :: TyCon -> [TyVar]+tyConVisibleTyVars tc+  = [ tv | Bndr tv vis <- tyConBinders tc+         , isVisibleTcbVis vis ]++{- Note [Building TyVarBinders from TyConBinders]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We sometimes need to build the quantified type of a value from+the TyConBinders of a type or class.  For that we need not+TyConBinders but TyVarBinders (used in forall-type)  E.g:++ *  From   data T a = MkT (Maybe a)+    we are going to make a data constructor with type+           MkT :: forall a. Maybe a -> T a+    See the ForAllTyBinders passed to buildDataCon++ * From    class C a where { op :: a -> Maybe a }+   we are going to make a default method+           $dmop :: forall a. C a => a -> Maybe a+   See the ForAllTyBinders passed to mkSigmaTy in mkDefaultMethodType++Both of these are user-callable.  (NB: default methods are not callable+directly by the user but rather via the code generated by 'deriving',+which uses visible type application; see mkDefMethBind.)++Since they are user-callable we must get their type-argument visibility+information right; and that info is in the TyConBinders.+Here is an example:++  data App a b = MkApp (a b) -- App :: forall {k}. (k->Type) -> k -> Type++The TyCon has++  tyConTyBinders = [ Named (Bndr (k :: Type) Inferred), Anon (k->Type), Anon k ]++The TyConBinders for App line up with App's kind, given above.++But the DataCon MkApp has the type+  MkApp :: forall {k} (a:k->Type) (b:k). a b -> App k a b++That is, its ForAllTyBinders should be++  dataConUnivTyVarBinders = [ Bndr (k:Type)    Inferred+                            , Bndr (a:k->Type) Specified+                            , Bndr (b:k)    Specified ]++So tyConTyVarBinders converts TyCon's TyConBinders into TyVarBinders:+  - variable names from the TyConBinders+  - but changing Anon/Required to Specified++The last part about Required->Specified comes from this:+  data T k (a :: k) b = MkT (a b)+Here k is Required in T's kind, but we didn't have Required binders in+types of terms before the advent of the new, experimental RequiredTypeArguments+extension. So we historically changed Required to Specified when making MkT's PiTyBinders+and now continue to do so to avoid a breaking change.+-}+++{- Note [The binders/kind/arity fields of a TyCon]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+All TyCons have this group of fields+  tyConBinders   :: [TyConBinder]+  tyConResKind   :: Kind+  tyConTyVars    :: [TyVar]   -- Cached = binderVars tyConBinders+                              --   NB: Currently (Aug 2018), TyCons that own this+                              --   field really only contain TyVars. So it is+                              --   [TyVar] instead of [TyCoVar].+  tyConKind      :: Kind      -- Cached = mkTyConKind tyConBinders tyConResKind+  tyConArity     :: Arity     -- Cached = length tyConBinders++They fit together like so:++* tyConBinders gives the telescope of type variables on the LHS of the+  type declaration.  For example:++    type App a (b :: k) = a b++  tyConBinders = [ Bndr (k::Type)   (NamedTCB Inferred)+                 , Bndr (a:k->Type) AnonTCB+                 , Bndr (b:k)    AnonTCB ]++  Note that there are three binders here, including the+  kind variable k.++  See Note [tyConBinders and lexical scoping]++* See Note [VarBndrs, ForAllTyBinders, TyConBinders, and visibility] in GHC.Core.TyCo.Rep+  for what the visibility flag means.++* Each TyConBinder in tyConBinders has a TyVar, and+  that TyVar may scope over some other part of the TyCon's definition. Eg+      type T a = a -> a+  we have+      tyConBinders = [ Bndr (a:Type) AnonTCB ]+      synTcRhs     = a -> a+  So the 'a' scopes over the synTcRhs++* From the tyConBinders and tyConResKind we can get the tyConKind+  E.g for our App example:+      App :: forall k. (k->Type) -> k -> Type++  We get a 'forall' in the kind for each NamedTCB, and an arrow+  for each AnonTCB++  tyConKind is the full kind of the TyCon, not just the result kind++* For type families, tyConArity is the arguments this TyCon must be+  applied to, to be considered saturated.  Here we mean "applied to in+  the actual Type", not surface syntax; i.e. including implicit kind+  variables.  So it's just (length tyConBinders)++* For an algebraic data type, or data instance, the tyConResKind is+  always (TYPE r); that is, the tyConBinders are enough to saturate+  the type constructor.  I'm not quite sure why we have this invariant,+  but it's enforced by splitTyConKind++Note [tyConBinders and lexical scoping]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In a TyCon, and a PolyTcTyCon, we obey the following rule:++   The Name of the TyConBinder is precisely+       the lexically scoped Name from the original declaration+       (precisely = both OccName and Unique)++For example,+   data T a (b :: wombat) = MkT+We will get tyConBinders of [k, wombat, a::k, b::wombat]+The 'k' is made up; the user didn't specify it.  But for the kind of 'b'+we must use 'wombat'.++Why do we have this invariant?++* Similarly, when typechecking default definitions for class methods, in+  GHC.Tc.TyCl.Class.tcClassDecl2, we only have the (final) Class available;+  but the variables bound in that class must be in scope.  Example (#19738):++    type P :: k -> Type+    data P a = MkP++    type T :: k -> Constraint+    class T (a :: j) where+      f :: P a+      f = MkP @j @a  -- 'j' must be in scope when we typecheck 'f'++* When typechecking `deriving` clauses for top-level data declarations, the+  tcTyConScopedTyVars are brought into scope in through the `di_scoped_tvs`+  field of GHC.Tc.Deriv.DerivInfo. Example (#16731):++    class C x1 x2++    type T :: a -> Type+    data T (x :: z) deriving (C z)++  When typechecking `C z`, we want `z` to map to `a`, which is exactly what the+  tcTyConScopedTyVars for T give us.+-}++instance OutputableBndr tv => Outputable (VarBndr tv TyConBndrVis) where+  ppr (Bndr v bi) = ppr bi <+> parens (pprBndr LetBind v)++instance Binary TyConBndrVis where+  put_ bh AnonTCB        = do { putByte bh 0 }+  put_ bh (NamedTCB vis) = do { putByte bh 1; put_ bh vis }++  get bh = do { h <- getByte bh+              ; case h of+                  0 -> return AnonTCB+                  _ -> do { vis <- get bh; return (NamedTCB vis) } }++instance NFData TyConBndrVis where+  rnf AnonTCB        = ()+  rnf (NamedTCB vis) = rnf vis++++{- *********************************************************************+*                                                                      *+               The TyCon type+*                                                                      *+************************************************************************+-}+++-- | TyCons represent type constructors. Type constructors are introduced by+-- things such as:+--+-- 1) Data declarations: @data Foo = ...@ creates the @Foo@ type constructor of+--    kind @Type@+--+-- 2) Type synonyms: @type Foo = ...@ creates the @Foo@ type constructor+--+-- 3) Newtypes: @newtype Foo a = MkFoo ...@ creates the @Foo@ type constructor+--    of kind @Type -> Type@+--+-- 4) Class declarations: @class Foo where@ creates the @Foo@ type constructor+--    of kind @Constraint@+--+-- This data type also encodes a number of primitive, built in type constructors+-- such as those for function and tuple types.+--+-- If you edit this type, you may need to update the GHC formalism+-- See Note [GHC Formalism] in GHC.Core.Lint+data TyCon = TyCon {+        tyConUnique  :: !Unique,  -- ^ A Unique of this TyCon. Invariant:+                                  -- identical to Unique of Name stored in+                                  -- tyConName field.++        tyConName    :: !Name,    -- ^ Name of the constructor++        -- See Note [The binders/kind/arity fields of a TyCon]+        tyConBinders          :: [TyConBinder],   -- ^ Full binders+        tyConResKind          :: Kind,             -- ^ Result kind+        tyConHasClosedResKind :: Bool,++        -- Cached values+        tyConTyVars    :: [TyVar],       -- ^ TyVar binders+        tyConKind      :: Kind,          -- ^ Kind of this TyCon+        tyConArity     :: Arity,         -- ^ Arity+        tyConNullaryTy :: Type,          -- ^ A pre-allocated @TyConApp tycon []@++        tyConRoles :: [Role],  -- ^ The role for each type variable+                               -- This list has length = tyConArity+                               -- See also Note [TyCon Role signatures]++        tyConDetails :: !TyConDetails }++data TyConDetails =+  -- | Algebraic data types, from+  --     - @data@ declarations+  --     - @newtype@ declarations+  --     - data instance declarations+  --     - type instance declarations+  --     - the TyCon generated by a class declaration+  --     - boxed tuples+  --     - unboxed tuples+  --     - constraint tuples+  --     - unboxed sums+  -- Data/newtype/type /families/ are handled by 'FamilyTyCon'.+  -- See 'AlgTyConRhs' for more information.+    AlgTyCon {+              -- The tyConTyVars scope over:+              --+              -- 1. The 'algTcStupidTheta'+              -- 2. The cached types in algTyConRhs.NewTyCon+              -- 3. The family instance types if present+              --+              -- Note that it does /not/ scope over the data+              -- constructors.++        tyConCType   :: Maybe CType,-- ^ The C type that should be used+                                    -- for this type when using the FFI+                                    -- and CAPI++        algTcGadtSyntax  :: Bool,   -- ^ Was the data type declared with GADT+                                    -- syntax?  If so, that doesn't mean it's a+                                    -- true GADT; only that the "where" form+                                    -- was used.  This field is used only to+                                    -- guide pretty-printing++        algTcStupidTheta :: [PredType], -- ^ The \"stupid theta\" for the data+                                        -- type (always empty for GADTs).  A+                                        -- \"stupid theta\" is the context to+                                        -- the left of an algebraic type+                                        -- declaration, e.g. @Eq a@ in the+                                        -- declaration @data Eq a => T a ...@.+                                        -- See @Note [The stupid context]@ in+                                        -- "GHC.Core.DataCon".++        algTcRhs    :: AlgTyConRhs, -- ^ Contains information about the+                                    -- data constructors of the algebraic type++        algTcFields :: FieldLabelEnv, -- ^ Maps a label to information+                                      -- about the field++        algTcFlavour :: AlgTyConFlav   -- ^ The flavour of this algebraic tycon.+                                       -- Gives the class or family declaration+                                       -- 'TyCon' for derived 'TyCon's representing+                                       -- class or family instances, respectively.++    }++  -- | Represents type synonyms+  | SynonymTyCon {+             -- tyConTyVars scope over: synTcRhs++        synTcRhs     :: Type,    -- ^ Contains information about the expansion+                                 -- of the synonym++        synIsTau     :: Bool,   -- True <=> the RHS of this synonym does not+                                 --          have any foralls, after expanding any+                                 --          nested synonyms+        synIsFamFree  :: Bool,   -- True <=> the RHS of this synonym does not mention+                                 --          any type synonym families (data families+                                 --          are fine), again after expanding any+                                 --          nested synonyms++        synIsForgetful :: Bool,  -- See Note [Forgetful type synonyms]+                                 -- True <=  at least one argument is not mentioned+                                 --          in the RHS (or is mentioned only under+                                 --          forgetful synonyms)+                                 -- Test is conservative, so True does not guarantee+                                 -- forgetfulness. False conveys definite information+                                 -- (definitely not forgetful); True is always safe.++        synIsConcrete :: Bool    -- True <= If 'tys' are concrete then the expansion+                                 --         of (S tys) is definitely concrete+                                 -- But False is always safe+    }++  -- | Represents families (both type and data)+  -- Argument roles are all Nominal+  | FamilyTyCon {+            -- tyConTyVars connect an associated family TyCon+            -- with its parent class; see GHC.Tc.Validity.checkConsistentFamInst++        famTcResVar  :: Maybe Name,   -- ^ Name of result type variable, used+                                      -- for pretty-printing with --show-iface+                                      -- and for reifying TyCon in Template+                                      -- Haskell++        famTcFlav    :: FamTyConFlav, -- ^ Type family flavour: open, closed,+                                      -- abstract, built-in. See comments for+                                      -- FamTyConFlav++        famTcParent  :: Maybe TyCon,  -- ^ For *associated* type/data families+                                      -- The class tycon in which the family is declared+                                      -- See Note [Associated families and their parent class]++        famTcInj     :: Injectivity   -- ^ is this a type family injective in+                                      -- its type variables? Nothing if no+                                      -- injectivity annotation was given+    }++  -- | Primitive types; cannot be defined in Haskell. This includes+  -- the usual suspects (such as @Int#@) as well as foreign-imported+  -- types and kinds (@*@, @#@, and @?@)+  | PrimTyCon {+        primRepName :: TyConRepName   -- ^ The 'Typeable' representation.+                                      -- A cached version of+                                      -- @'mkPrelTyConRepName' ('tyConName' tc)@.+    }++  -- | Represents promoted data constructor.+  -- The kind of a promoted data constructor is the *wrapper* type of+  -- the original data constructor. This type must not have constraints+  -- (as checked in GHC.Tc.Gen.HsType.tcTyVar).+  | PromotedDataCon {          -- See Note [Promoted data constructors]+        dataCon       :: DataCon,   -- ^ Corresponding data constructor+        tcRepName     :: TyConRepName,+        promDcInfo    :: PromDataConInfo  -- ^ See comments with 'PromDataConInfo'+    }++  -- | These exist only during type-checking.+  -- See Note [TcTyCon, MonoTcTyCon, and PolyTcTyCon] in "GHC.Tc.TyCl"+  | TcTyCon {+          -- NB: the tyConArity of a TcTyCon must match+          -- the number of Required (positional, user-specified)+          -- arguments to the type constructor; see the use+          -- of tyConArity in generaliseTcTyCon++        tctc_scoped_tvs :: [(Name,TcTyVar)],+          -- ^ Scoped tyvars over the tycon's body+          -- The range is always a skolem or TcTyVar, be+          -- MonoTcTyCon only: see Note [Scoped tyvars in a TcTyCon]++        tctc_is_poly :: Bool, -- ^ Is this TcTyCon already generalized?+                              -- Used only to make zonking more efficient++        tctc_flavour :: TyConFlavour TyCon+                           -- ^ What sort of 'TyCon' this represents.+      }++{- Note [Scoped tyvars in a TcTyCon]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The tcTyConScopedTyVars field records the lexicial-binding connection+between the original, user-specified Name (i.e. thing in scope) and+the TcTyVar that the Name is bound to.++Order *does* matter; the tcTyConScopedTyVars list consists of+     specified_tvs ++ required_tvs++where+   * specified ones first+   * required_tvs the same as tyConTyVars+   * tyConArity = length required_tvs++tcTyConScopedTyVars are used only for MonoTcTyCons, not PolyTcTyCons.+See Note [TcTyCon, MonoTcTyCon, and PolyTcTyCon] in GHC.Tc.TyCl++Note [Representation-polymorphic TyCons]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+To check for representation-polymorphism directly in the typechecker,+e.g. when using GHC.Tc.Utils.TcMType.checkTypeHasFixedRuntimeRep,+we need to compute whether a type has a syntactically fixed RuntimeRep,+as per Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete.++It's useful to have a quick way to check whether a saturated application+of a type constructor has a fixed RuntimeRep. That is, we want+to know, given a TyCon 'T' of arity 'n', does++  T a_1 ... a_n++always have a fixed RuntimeRep? That is, is it always the case+that this application has a kind of the form++  T a_1 ... a_n :: TYPE rep++in which 'rep' is a concrete 'RuntimeRep'?+('Concrete' in the sense of Note [The Concrete mechanism] in GHC.Tc.Utils.Concrete:+it contains no type-family applications or type variables.)++To answer this question, we have 'tcHasFixedRuntimeRep'.+If 'tcHasFixedRuntimeRep' returns 'True', it means we're sure that+every saturated application of `T` has a fixed RuntimeRep.+However, if it returns 'False', we don't know: perhaps some application might not+have a fixed RuntimeRep.++Examples:++  - For type families, we won't know in general whether an application+    will have a fixed RuntimeRep:++      type F :: k -> k+      type family F a where {..}++    `tcHasFixedRuntimeRep F = False'++  - For newtypes, we're usually OK:++      newtype N a b c = MkN Int++    No matter what arguments we apply `N` to, we always get something of+    kind `Type`, which has a fixed RuntimeRep.+    Thus `tcHasFixedRuntimeRep N = True`.++    However, with `-XUnliftedNewtypes`, we can have representation-polymorphic+    newtypes:++      type UN :: TYPE rep -> TYPE rep+      newtype UN a = MkUN a++    `tcHasFixedRuntimeRep UN = False`++    For example, `UN @Int8Rep Int8#` is represented by an 8-bit value,+    while `UN @LiftedRep Int` is represented by a heap pointer.++    To distinguish whether we are dealing with a representation-polymorphic newtype,+    we keep track of which situation we are in using the 'nt_fixed_rep'+    field of the 'NewTyCon' constructor of 'AlgTyConRhs', and read this field+    to compute 'tcHasFixedRuntimeRep'.++  - A similar story can be told for datatypes: we're usually OK,+    except with `-XUnliftedDatatypes` which allows for levity polymorphism,+    e.g.:++      type UC :: TYPE (BoxedRep l) -> TYPE (BoxedRep l)+      type UC a = MkUC a++    `tcHasFixedRuntimeRep UC = False`++    Here, we keep track of whether we are dealing with a levity-polymorphic+    unlifted datatype using the 'data_fixed_lev' field of the 'DataTyCon'+    constructor of 'AlgTyConRhs'.++    N.B.: technically, the representation of a datatype is fixed,+    as it is always a pointer. However, we currently require that we+    know the specific `RuntimeRep`: knowing that it's `BoxedRep l`+    for a type-variable `l` isn't enough. See #15532.+-}++-- | Represents right-hand-sides of 'TyCon's for algebraic types+data AlgTyConRhs++    -- | Says that we know nothing about this data type, except that+    -- it's represented by a pointer.  Used when we export a data type+    -- abstractly into an .hi file.+  = AbstractTyCon++    -- | Information about those 'TyCon's derived from a @data@+    -- declaration. This includes data types with no constructors at+    -- all.+  | DataTyCon {+        data_cons :: [DataCon],+                          -- ^ The data type constructors; can be empty if the+                          --   user declares the type to have no constructors+                          --+                          -- INVARIANT: Kept in order of increasing 'DataCon'+                          -- tag (see the tag assignment in mkTyConTagMap)+        data_cons_size :: Int,+                          -- ^ Cached value: length data_cons+        is_enum :: Bool,  -- ^ Cached value: is this an enumeration type?+                          --   See Note [Enumeration types]+        is_type_data :: Bool,+                        -- from a "type data" declaration+                        -- See Note [Type data declarations] in GHC.Rename.Module+        data_fixed_lev :: Bool+                        -- ^ 'True' if the data type constructor has+                        -- a known, fixed levity when fully applied+                        -- to its arguments, False otherwise.+                        --+                        -- This can only be 'False' with UnliftedDatatypes,+                        -- e.g.+                        --+                        -- > data A :: TYPE (BoxedRep l) where { MkA :: Int -> A }+                        --+                        -- This boolean is cached to make it cheaper to check+                        -- for levity and representation-polymorphism in+                        -- tcHasFixedRuntimeRep.+    }++  | TupleTyCon {                   -- A boxed, unboxed, or constraint tuple+        data_con :: DataCon,       -- NB: it can be an *unboxed* tuple+        tup_sort :: TupleSort      -- ^ Is this a boxed, unboxed or constraint+                                   -- tuple?+    }++  -- | An unboxed sum type.+  | SumTyCon {+        data_cons :: [DataCon],+        data_cons_size :: Int  -- ^ Cached value: length data_cons+    }++  -- | Information about those 'TyCon's derived from a @newtype@ declaration+  | NewTyCon {+        data_con :: DataCon,    -- ^ The unique constructor for the @newtype@.+                                --   It has no existentials++        nt_rhs :: Type,         -- ^ Cached value: the argument type of the+                                -- constructor, which is just the representation+                                -- type of the 'TyCon' (remember that @newtype@s+                                -- do not exist at runtime so need a different+                                -- representation type).+                                --+                                -- The free 'TyVar's of this type are the+                                -- 'tyConTyVars' from the corresponding 'TyCon'++        nt_etad_rhs :: ([TyVar], Type),+                        -- ^ Same as the 'nt_rhs', but this time eta-reduced.+                        -- Hence the list of 'TyVar's in this field may be+                        -- shorter than the declared arity of the 'TyCon'.++                        -- See Note [Newtype eta]+        nt_co :: CoAxiom Unbranched,+                             -- The axiom coercion that creates the @newtype@+                             -- from the representation 'Type'.  The axiom witnesses+                             -- a representational coercion:+                             --   nt_co :: N ty1 ~R# rep_tys++                             -- See Note [Newtype coercions]+                             -- Invariant: arity = #tvs in nt_etad_rhs;+                             -- See Note [Newtype eta]+                             -- Watch out!  If any newtypes become transparent+                             -- again check #1072.+        nt_fixed_rep :: Bool+                        -- ^ 'True' if the newtype has a known, fixed representation+                        -- when fully applied to its arguments, 'False' otherwise.+                        -- This can only ever be 'False' with UnliftedNewtypes.+                        --+                        -- Example:+                        --+                        -- > newtype N (a :: TYPE r) = MkN a+                        --+                        -- Invariant: nt_fixed_rep nt = tcHasFixedRuntimeRep (nt_rhs nt)+                        --+                        -- This boolean is cached to make it cheaper to check if a+                        -- variable binding is representation-polymorphic+                        -- in tcHasFixedRuntimeRep.+    }++  | UnaryClassTyCon {  -- See Note [Unary class magic], esp (UCM2)+                       -- INVARIANT: the algTcFlavour of this TyCon is ClassTyCon+      data_con :: DataCon+      }++mkSumTyConRhs :: [DataCon] -> AlgTyConRhs+mkSumTyConRhs data_cons = SumTyCon data_cons (length data_cons)++-- | Create an 'AlgTyConRhs' from the data constructors,+-- for a potentially levity-polymorphic datatype (with `UnliftedDatatypes`).+mkLevPolyDataTyConRhs :: Bool -- ^ whether the 'DataCon' has a fixed levity+                      -> Bool -- ^ True if this is a "type data" declaration+                              -- See Note [Type data declarations]+                              -- in GHC.Rename.Module+                      -> [DataCon]+                      -> AlgTyConRhs+mkLevPolyDataTyConRhs fixed_lev type_data cons+  = DataTyCon {+        data_cons = cons,+        data_cons_size = length cons,+        is_enum = not (null cons) && all is_enum_con cons,+                  -- See Note [Enumeration types] in GHC.Core.TyCon+        is_type_data = type_data,+        data_fixed_lev = fixed_lev+    }+  where+    is_enum_con con+       | (_univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res)+           <- dataConFullSig con+       = null ex_tvs && null eq_spec && null theta && null arg_tys++-- | Create an 'AlgTyConRhs' from the data constructors.+--+-- Use 'mkLevPolyDataConRhs' if the datatype can be levity-polymorphic+-- or if it comes from a "data type" declaration+mkDataTyConRhs :: [DataCon] -> AlgTyConRhs+mkDataTyConRhs = mkLevPolyDataTyConRhs True False++-- | Some promoted datacons signify extra info relevant to GHC. For example,+-- the `IntRep` constructor of `RuntimeRep` corresponds to the 'IntRep'+-- constructor of 'PrimRep'. This data structure allows us to store this+-- information right in the 'TyCon'. The other approach would be to look+-- up things like `RuntimeRep`'s `PrimRep` by known-key every time.+-- See also Note [Getting from RuntimeRep to PrimRep] in "GHC.Types.RepType"+data PromDataConInfo+  = NoPromInfo       -- ^ an ordinary promoted data con+  | RuntimeRep ([Type] -> [PrimRep])+      -- ^ A constructor of `RuntimeRep`. The argument to the function should+      -- be the list of arguments to the promoted datacon.++  | VecCount Int         -- ^ A constructor of `VecCount`++  | VecElem PrimElemRep  -- ^ A constructor of `VecElem`++  | Levity Levity        -- ^ A constructor of `Levity`++-- | Extract those 'DataCon's that we are able to learn about.  Note+-- that visibility in this sense does not correspond to visibility in+-- the context of any particular user program!+visibleDataCons :: AlgTyConRhs -> [DataCon]+visibleDataCons (AbstractTyCon {})                = []+visibleDataCons (DataTyCon{ data_cons = cs })     = cs+visibleDataCons (NewTyCon{ data_con = c })        = [c]+visibleDataCons (UnaryClassTyCon{ data_con = c }) = [c]+visibleDataCons (TupleTyCon{ data_con = c })      = [c]+visibleDataCons (SumTyCon{ data_cons = cs })      = cs++-- | Describes the flavour of an algebraic type constructor. For+-- classes and data families, this flavour includes a reference to+-- the parent 'TyCon'.+data AlgTyConFlav+  = -- | An ordinary algebraic type constructor. This includes unlifted and+    -- representation-polymorphic datatypes and newtypes and unboxed tuples,+    -- but NOT unboxed sums; see UnboxedSumTyCon.+    VanillaAlgTyCon+       TyConRepName   -- For Typeable++    -- | An unboxed sum type constructor. This is distinct from VanillaAlgTyCon+    -- because we currently don't allow unboxed sums to be Typeable since+    -- there are too many of them. See #13276.+  | UnboxedSumTyCon++  -- | Type constructors representing a class dictionary.+  -- See Note [ATyCon for classes] in "GHC.Types.TyThing"+  -- INVARIANT: the algTcRhs is never NewTyCon; it could be+  --            TupleTyCon, DataTyCon, UnaryClassTyCon+  | ClassTyCon+        Class           -- INVARIANT: the classTyCon of this Class is the+                        -- current tycon+        TyConRepName++  -- | Type constructors representing an *instance* of a *data* family.+  -- Parameters:+  --+  --  1) The type family in question+  --+  --  2) Instance types; free variables are the 'tyConTyVars'+  --  of the current 'TyCon' (not the family one). INVARIANT:+  --  the number of types matches the arity of the family 'TyCon'+  --+  --  3) A 'CoTyCon' identifying the representation+  --  type with the type instance family+  | DataFamInstTyCon          -- See Note [Data type families]+        (CoAxiom Unbranched)  -- The coercion axiom.+               -- A *Representational* coercion,+               -- of kind   T ty1 ty2   ~R   R:T a b c+               -- where T is the family TyCon,+               -- and R:T is the representation TyCon (ie this one)+               -- and a,b,c are the tyConTyVars of this TyCon+               --+               -- BUT may be eta-reduced; see+               --     Note [Eta reduction for data families] in+               --     GHC.Core.Coercion.Axiom++          -- Cached fields of the CoAxiom, but adjusted to+          -- use the tyConTyVars of this TyCon+        TyCon   -- The family TyCon+        [Type]  -- Argument types (mentions the tyConTyVars of this TyCon)+                -- No shorter in length than the tyConTyVars of the family TyCon+                -- How could it be longer? See [Arity of data families] in GHC.Core.FamInstEnv++        -- E.g.  data instance T [a] = ...+        -- gives a representation tycon:+        --      data R:TList a = ...+        --      axiom co a :: T [a] ~ R:TList a+        -- with R:TList's algTcFlavour = DataFamInstTyCon T [a] co++instance Outputable AlgTyConFlav where+    ppr (VanillaAlgTyCon {})        = text "Vanilla ADT"+    ppr (UnboxedSumTyCon {})        = text "Unboxed sum"+    ppr (ClassTyCon cls _)          = text "Class parent" <+> ppr cls+    ppr (DataFamInstTyCon _ tc tys) = text "Family parent (family instance)"+                                      <+> ppr tc <+> sep (map pprType tys)++-- | Checks the invariants of a 'AlgTyConFlav' given the appropriate type class+-- name, if any+okParent :: Name -> AlgTyConFlav -> Bool+okParent _       (VanillaAlgTyCon {})            = True+okParent _       (UnboxedSumTyCon {})            = True+okParent tc_name (ClassTyCon cls _)              = tc_name == tyConName (classTyCon cls)+okParent _       (DataFamInstTyCon _ fam_tc tys) = tys `lengthAtLeast` tyConArity fam_tc++isNoParent :: AlgTyConFlav -> Bool+isNoParent (VanillaAlgTyCon {}) = True+isNoParent _                   = False++--------------------++data Injectivity+  = NotInjective+  | Injective [Bool]   -- 1-1 with tyConTyVars (incl kind vars)+  deriving( Eq )++-- | Information pertaining to the expansion of a type synonym (@type@)+data FamTyConFlav+  = -- | Represents an open type family without a fixed right hand+    -- side.  Additional instances can appear at any time.+    --+    -- These are introduced by either a top level declaration:+    --+    -- > data family T a :: Type+    --+    -- Or an associated data type declaration, within a class declaration:+    --+    -- > class C a b where+    -- >   data T b :: Type+     DataFamilyTyCon+       TyConRepName++     -- | An open type synonym family  e.g. @type family F x y :: Type -> Type@+   | OpenSynFamilyTyCon++   -- | A closed type synonym family  e.g.+   -- @type family F x where { F Int = Bool }@+   | ClosedSynFamilyTyCon (Maybe (CoAxiom Branched))+     -- See Note [Closed type families]++   -- | A closed type synonym family declared in an hs-boot file with+   -- type family F a where ..+   | AbstractClosedSynFamilyTyCon++   -- | Built-in type family used by the TypeNats solver+   | BuiltInSynFamTyCon BuiltInSynFamily++instance Outputable FamTyConFlav where+    ppr (DataFamilyTyCon n) = text "data family" <+> ppr n+    ppr OpenSynFamilyTyCon = text "open type family"+    ppr (ClosedSynFamilyTyCon Nothing) = text "closed type family"+    ppr (ClosedSynFamilyTyCon (Just coax)) = text "closed type family" <+> ppr coax+    ppr AbstractClosedSynFamilyTyCon = text "abstract closed type family"+    ppr (BuiltInSynFamTyCon _) = text "built-in type family"++{- Note [Closed type families]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+* In an open type family you can add new instances later.  This is the+  usual case.++* In a closed type family you can only put equations where the family+  is defined.++A non-empty closed type family has a single axiom with multiple+branches, stored in the 'ClosedSynFamilyTyCon' constructor.  A closed+type family with no equations does not have an axiom, because there is+nothing for the axiom to prove!+++Note [Promoted data constructors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+All data constructors can be promoted to become a type constructor,+via the PromotedDataCon alternative in GHC.Core.TyCon.++* The TyCon promoted from a DataCon has the *same* Name and Unique as+  the DataCon.  Eg. If the data constructor Data.Maybe.Just(unique 78)+  is promoted to a TyCon whose name is      Data.Maybe.Just(unique 78)++* We promote the *user* type of the DataCon.  Eg+     data T = MkT {-# UNPACK #-} !(Bool, Bool)+  The promoted kind is+     'MkT :: (Bool,Bool) -> T+  *not*+     'MkT :: Bool -> Bool -> T++* Similarly for GADTs:+     data G a where+       MkG :: forall b. b -> G [b]+  The promoted data constructor has kind+       'MkG :: forall b. b -> G [b]+  *not*+       'MkG :: forall a b. (a ~# [b]) => b -> G a++Note [Enumeration types]+~~~~~~~~~~~~~~~~~~~~~~~~+We define datatypes with no constructors to *not* be+enumerations; this fixes #2578,  Otherwise we+end up generating an empty table for+  <mod>_<type>_closure_tbl+which is used by tagToEnum# to map Int# to constructors+in an enumeration. The empty table apparently upset+the linker.++Moreover, all the data constructor must be enumerations, meaning+they have type  (forall abc. T a b c).  GADTs are not enumerations.+For example consider+    data T a where+      T1 :: T Int+      T2 :: T Bool+      T3 :: T a+What would [T1 ..] be?  [T1,T3] :: T Int? Easiest thing is to exclude them.+See #4528.++Note [Newtype coercions]+~~~~~~~~~~~~~~~~~~~~~~~~+The NewTyCon field nt_co is a CoAxiom which is used for coercing from+the representation type of the newtype, to the newtype itself. For+example,++   newtype T a = MkT (a -> a)++the NewTyCon for T will contain nt_co = CoT where CoT :: forall a. T a ~ a -> a.++We might also eta-contract the axiom: see Note [Newtype eta].++Note [Newtype eta]+~~~~~~~~~~~~~~~~~~+Consider+        newtype Parser a = MkParser (IO a) deriving Monad+Are these two types equal? That is, does a coercion exist between them?+        Monad Parser+        Monad IO+(We need this coercion to make the derived instance for Monad Parser.)++Well, yes.  But to see that easily we eta-reduce the RHS type of+Parser, in this case to IO, so that even unsaturated applications of+Parser will work right.  So instead of+   axParser :: forall a. Parser a ~ IO a+we generate an eta-reduced axiom+   axParser :: Parser ~ IO++This eta reduction is done when the type constructor is built, in+GHC.Tc.TyCl.Build.mkNewTyConRhs, and cached in NewTyCon.++Here's an example that I think showed up in practice.+Source code:+        newtype T a = MkT [a]+        newtype Foo m = MkFoo (forall a. m a -> Int)++        w1 :: Foo []+        w1 = ...++        w2 :: Foo T+        w2 = MkFoo (\(MkT x) -> case w1 of MkFoo f -> f x)++After desugaring, and discarding the data constructors for the newtypes,+we would like to get:+        w2 = w1 `cast` Foo axT++so that w2 and w1 share the same code. To do this, the coercion axiom+axT must have+        kind:    axT :: T ~ []+ and    arity:   0++See also Note [Newtype eta and homogeneous axioms] in GHC.Tc.TyCl.Build.++Note [Unary class magic]+~~~~~~~~~~~~~~~~~~~~~~~~+Consider a class with just one method, or with no methods and one+superclass:+  class UC a where { op :: a -> a }+  class Eq a => UD a where {}+Such a class is called a /unary class/.++We could represent the dictionary for a unary class with a data type:+  data UC a where { MkUC :: (a->a) -> UC a }+  data UD a where { MkUD :: Eq a =>  UD a }+But it would be more efficent to use a newtype; and for decades GHC did+exactly that, because:++  * Unary classes are surprisingly common, so it's a useful optimisation.++  * The `reflection` library uses `unsafeCoerce` to /rely/ on the fact that+    a unary class is ultimately represented by its payload.  We may not like+    it, and I hope to ultimately eliminate the necessity for this by using+    `withDict` (see Note [withDict] in GHC.Tc.Instance.Class).  But meanwhile+    we'd prefer not to break this usage.++But alas, using a newtype representation (surprisingly) led multiple, subtle,+Bad Things: see Note [Representing unary classes with newtypes: bad, bad, bad].++This Note explains what GHC now does for unary classes.++(UCM0) Throughout the compiler, right up to the code generator, GHC thinks that a+  unary class is just like a non-unary class:+    - Represented by a data type,+    - with one constructor,+    - which has one field++(UCM1) Then when converting from Core to STG, in GHC.CoreToStg, we effectively+  transform+    - op   ta tb tc dict_arg  -->  dict_arg+    - MkUC ta tb tc meth_arg  -->  meth_arg++  Note that we do this transformation well /after/ generating an interface file,+  so importing modules only see the data constructor.++  This late transformation has a lot in common with the treatment of+  `unsafeEqualityProof`; see (U2) in Note [Implementing unsafeCoerce]+  in GHC.Internal.Unsafe.Coerce.++In this way we get the efficiency of a newtype without the bugs that we get+by exposing the newtype representation too early.++There are a number of wrinkles++(UCM2) The TyCon for a unary class is /not/ identified as a newtype.+   Rather, it has its own AlgTyConRhs, namely `UnaryClassTyCon`++(UCM3) Unlike non-unary classes, a value of type (C ty), where `C` is a unary+   class, might be bottom, because it is represented by the method type alone.+   See GHC.Core.Type.isTerminatingType.++   Similarly in exprOkForSpeculation/exprOkToDiscard/exprOkForSpecEval,+   in GHC.Core.Utils.  In the utility funcion `app_ok` we need a special+   case for the DFunIds; they generally terminate, but not for unary classes.++(UMC4) To avoid regressions, in Core we want to remember that+             (MkUC x) is really just  x+             (op d)   is really just  d+    We account for this in several places:++    - `GHC.Core.Utils.exprIsTrivial` treats the above two forms as trivial++    - `GHC.Core.Unfold.sizeExpr` (which computes the size of an expression to+      guide inlining) treats (MkUC e) as the same size as `e`, and similarly+      (op d).++    - `GHC.Core.Unfold.inlineBoringOK` where we want to ensure that we+      always-inline (MkUC op), even into a boring context. See (IB6)+      in Note [inlineBoringOk]++(UCM5) `GHC.Core.Unfold.Make.mkDFunUnfolding` builds a `DFunUnfolding` for+   non-unary classes, but just an /ordinary/ unfolding for unary classes.+       instance Num a => Num [a] where { .. }       -- (I1)+       instance UC a => UC [a] where { op = $cop }  -- (I2)+   From (I1) we get+       $fNumList = /\a \(d:Num a). MkNum (..) (..) (..)+         -- $fNumList has a DFunUnfolding+    But from (I2) we get+       $fUCList = /\a (d:UC a). MkUC ($cop a d)+       -- $fUCList has a regular CoreUnfolding++    Why?  Because we can safely inline $fUCList without code-size blow-up.+    Just one less indirection. It'd probably work ok with a DFunUnfolding;+    and it'd add another case for (UCM4) to spot.++(UCM6) In the constraint solver, when constructing evidence for a unary class+    (e.g. implicit parameters, withDict) be careful to use+    - the data constructor to build it: see `evDictApp`, `evUnaryDictAppE`+    - the class op to take it apart: see `evUnwrapIP`++(UCM7) You might worry about+           class UC1 a where { op :: Int# }    -- Single unboxed field+           class (a ~# b) => UC2 a b where {}  -- Unboxed equality superclass+  But these are illegal: predicates are always boxed, and all classes must have+  lifted fields.++(UCM8) The data constructor for a unary class has no wrapper, just a worker.+  (And the worker is turned into a cast by GHC.CoreToStg.Prep.isUnaryClassApp,+  as described above.)++(UCM9) Unary classes are treated as injective by `isInjectiveTyCon`, just like+  non-unary classes (which are TupleTyCons or DataTyCons).  This matters,+  because of the injectivity check done by lintCoercion (SelCo cs co)+  in GHC.Core.Lint.  There is a similar injectivity check in+  GHC.Core.Opt.Arity.pushCoDataCon.++  Generally, we want unary classes to behave like ordinary non-unary ones.++(UCM10) When, precisely, is a class unary?  It is unary iff+                  it has one field (superclass or method)+                  of boxed type+  The boxed-ness important. Consider+          class (a ~# b) => a ~ b where {}+  which is `eqClass` in GHC.Builtin.Types.  This has only one field, but it is+  definitely not a unary class: it is definitely represented by an ordinary+  algebraic data type with a single field of type (a ~# b).++  See `unary_class` in `GHC.Tc.TyCl.tcClassDecl1`++(UCM11) When building evidence for classes (unary or not) and implicit parameters,+  the constraint solver is careful to use functions that hide the precise+  evidence construction method.  Eg.g `evWrapIPE`.++(UCM12) In an interface-file description of a Class, we record whether or not+  the class is unary.  In theory this field is redundant, but because its value+  depends on the superclass and method fields, it's very easy to end up with+  a black hole when rehydrating interface the interface file. Easiest just to+  store the bit!  See `ifUnary` in GHC.Iface.Synatax.IfaceClassBody.+++Note [Representing unary classes with newtypes: bad, bad, bad]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In the past we represented a unary class with a newtype, but that led to+some at least three really subtle bad consequences.++* Problem 1: When we represented unary classes via a newtype, the+    newtype axiom looked like+           t1::CONSTRAINT r ~ t2::TYPE r+    If TYPE and CONSTRAINT are apart, this can create unsoundness, via KindCo;+    see #21623.  Now we never make such a coercion, so that worry about TYPE+    being apart from CONSTRAINT has gone away entirely.  Hooray.++* Problem 2: a horrible hack in GHC.Core.Opt.OccurAnal.scrutOkForBinderSwap;+  see Historical Note [Care with binder-swap on dictionaries].+  Now the hack is gone.++* Problem 3: bogus specialisation.  The gory details are explained+  at https://gitlab.haskell.org/ghc/ghc/-/issues/23109#note_499130++  We had (using newtype classes)+     newtype SNat a = MKSNat Natural           -- axiom  snCo a :: SNat a ~ Natural+     class KNat a where { natSing :: SNat a }  -- axiom  knCo a :: KNat a ~ SNat a+  and a pattern match+    K @a (g : 32 ~ a+1) -> ...(foo @a (d :: KNat a))...+  where K is a data constructor binding `a` as an existential.++  In the code I was looking at, after lots of inlining an simplification, we find+  that (d::KNat a) is built like this:+    (d1 :: KNat 32)    = 32 |> sym (snCo 32) |> sym (knCo 32)+    (d2 :: SNat (a+1)) = d1 |> knCo g+    (d3 :: Natural)    = d2 |> snCo (a+1)+    (d4 :: Natural)    = d3 - 1+    (d  :: KNat a)     = d4 |> sym (snCo a) |> sym (knCo a)++  But d3 :: Natural = 32 |> (co's involving g) :: Natural ~ Natural+  and that is just Refl.  So we drop all the co's, including the crucial `g`,+  and just say d3 = 32; and+        d :: KNat a = (32-1) |> sym (snCo a) |> sym (knCo a)+  Now, we can float `d` outwards, crucially aided by polymorphic specialisation,+  (Note [Specialising polymorphic dictionaries] in GHC.Core.Opt.Specialise)+  and use that evidence to get an utterly bogus specialisation for the function+      foo :: forall b. KNat b => blah++  Solution: don't use newtype classes.  Then we get+    (d1 :: KNat 32)    = MkKN @32 (32 |> sym (snCo 32))+    (d2 :: SNat (a+1)) = natSing d1 |> SN g+    (d3 :: Natural)    = d2 |> snCo (a+1)+    (d4 :: Natural)    = d3 -1+    (d  :: KNat a)     = MkKN @a (d4 |> sym (snCo a))+  Now we don't get cancelling-out coercions.+++************************************************************************+*                                                                      *+                 TyConRepName+*                                                                      *+********************************************************************* -}++type TyConRepName = Name+   -- The Name of the top-level declaration for the Typeable world+   --    $tcMaybe :: Data.Typeable.Internal.TyCon+   --    $tcMaybe = TyCon { tyConName = "Maybe", ... }++tyConRepName_maybe :: TyCon -> Maybe TyConRepName+tyConRepName_maybe (TyCon { tyConDetails = details }) = get_rep_nm details+  where+    get_rep_nm (PrimTyCon  { primRepName = rep_nm })+      = Just rep_nm+    get_rep_nm (AlgTyCon { algTcFlavour = parent })+      = case parent of+           VanillaAlgTyCon rep_nm -> Just rep_nm+           UnboxedSumTyCon        -> Nothing+           ClassTyCon _ rep_nm    -> Just rep_nm+           DataFamInstTyCon {}    -> Nothing+    get_rep_nm (FamilyTyCon { famTcFlav = DataFamilyTyCon rep_nm })+      = Just rep_nm+    get_rep_nm (PromotedDataCon { dataCon = dc, tcRepName = rep_nm })+      | isUnboxedSumDataCon dc   -- see #13276+      = Nothing+      | otherwise+      = Just rep_nm+    get_rep_nm _ = Nothing++-- | Make a 'Name' for the 'Typeable' representation of the given wired-in type+mkPrelTyConRepName :: Name -> TyConRepName+-- See Note [Grand plan for Typeable] in "GHC.Tc.Instance.Typeable".+mkPrelTyConRepName tc_name  -- Prelude tc_name is always External,+                            -- so nameModule will work+  = mkExternalName rep_uniq rep_mod rep_occ (nameSrcSpan tc_name)+  where+    name_occ  = nameOccName tc_name+    name_mod  = nameModule  tc_name+    name_uniq = nameUnique  tc_name+    rep_uniq | isTcOcc name_occ = tyConRepNameUnique   name_uniq+             | otherwise        = dataConTyRepNameUnique name_uniq+    (rep_mod, rep_occ) = tyConRepModOcc name_mod name_occ++-- | The name (and defining module) for the Typeable representation (TyCon) of a+-- type constructor.+--+-- See Note [Grand plan for Typeable] in "GHC.Tc.Instance.Typeable".+tyConRepModOcc :: Module -> OccName -> (Module, OccName)+tyConRepModOcc tc_module tc_occ = (rep_module, mkTyConRepOcc tc_occ)+  where+    rep_module+      | tc_module == gHC_PRIM = gHC_TYPES+      | otherwise             = tc_module+++{- *********************************************************************+*                                                                      *+                 PrimRep+*                                                                      *+************************************************************************++Note [rep swamp]+~~~~~~~~~~~~~~~~+GHC has a rich selection of types that represent "primitive types" of+one kind or another.  Each of them makes a different set of+distinctions, and mostly the differences are for good reasons,+although it's probably true that we could merge some of these.++Roughly in order of "includes more information":++ - A Width ("GHC.Cmm.Type") is simply a binary value with the specified+   number of bits.  It may represent a signed or unsigned integer, a+   floating-point value, or an address.++    data Width = W8 | W16 | W32 | W64  | W128++ - Size, which is used in the native code generator, is Width ++   floating point information.++   data Size = II8 | II16 | II32 | II64 | FF32 | FF64++   it is necessary because e.g. the instruction to move a 64-bit float+   on x86 (movsd) is different from the instruction to move a 64-bit+   integer (movq), so the mov instruction is parameterised by Size.++ - CmmType wraps Width with more information: GC ptr, float, or+   other value.++    data CmmType = CmmType CmmCat Width++    data CmmCat     -- "Category" (not exported)+       = GcPtrCat   -- GC pointer+       | BitsCat    -- Non-pointer+       | FloatCat   -- Float++   It is important to have GcPtr information in Cmm, since we generate+   info tables containing pointerhood for the GC from this.  As for+   why we have float (and not signed/unsigned) here, see Note [Signed+   vs unsigned].++ - ArgRep makes only the distinctions necessary for the call and+   return conventions of the STG machine.  It is essentially CmmType+   + void.++ - PrimRep makes a few more distinctions than ArgRep: it divides+   non-GC-pointers into signed/unsigned and addresses, information+   that is necessary for passing these values to foreign functions.++There's another tension here: whether the type encodes its size in+bytes, or whether its size depends on the machine word size.  Width+and CmmType have the size built-in, whereas ArgRep and PrimRep do not.++This means to turn an ArgRep/PrimRep into a CmmType requires DynFlags.++On the other hand, CmmType includes some "nonsense" values, such as+CmmType GcPtrCat W32 on a 64-bit machine.++The PrimRep type is closely related to the user-visible RuntimeRep type.+See Note [RuntimeRep and PrimRep] in GHC.Types.RepType.++-}+++-- | A 'PrimRep' is an abstraction of a /non-void/ type.+-- (Use 'PrimRepOrVoidRep' if you want void types too.)+-- It contains information that the code generator needs+-- in order to pass arguments, return results,+-- and store values of this type. See also Note [RuntimeRep and PrimRep] in+-- "GHC.Types.RepType" and Note [VoidRep] in "GHC.Types.RepType".+data PrimRep+-- Unpacking of sum types is only supported since 9.6.1+  = BoxedRep {-# UNPACK #-} !(Maybe Levity) -- ^ Boxed, heap value+  | Int8Rep       -- ^ Signed, 8-bit value+  | Int16Rep      -- ^ Signed, 16-bit value+  | Int32Rep      -- ^ Signed, 32-bit value+  | Int64Rep      -- ^ Signed, 64 bit value+  | IntRep        -- ^ Signed, word-sized value+  | Word8Rep      -- ^ Unsigned, 8 bit value+  | Word16Rep     -- ^ Unsigned, 16 bit value+  | Word32Rep     -- ^ Unsigned, 32 bit value+  | Word64Rep     -- ^ Unsigned, 64 bit value+  | WordRep       -- ^ Unsigned, word-sized value+  | AddrRep       -- ^ A pointer, but /not/ to a Haskell value (use 'BoxedRep')+  | FloatRep+  | DoubleRep+  | VecRep Int PrimElemRep  -- ^ A vector+  deriving( Data.Data, Eq, Ord, Show )++data PrimOrVoidRep = VoidRep | NVRep PrimRep+  -- See Note [VoidRep] in GHC.Types.RepType+  deriving (Data.Data, Eq, Ord, Show)++data PrimElemRep+  = Int8ElemRep+  | Int16ElemRep+  | Int32ElemRep+  | Int64ElemRep+  | Word8ElemRep+  | Word16ElemRep+  | Word32ElemRep+  | Word64ElemRep+  | FloatElemRep+  | DoubleElemRep+   deriving( Data.Data, Eq, Ord, Show, Enum )++instance Outputable PrimRep where+  ppr r = text (show r)++instance Outputable PrimElemRep where+  ppr r = text (show r)++instance Binary PrimRep where+  put_ bh (BoxedRep ml)  = case ml of+    -- cheaper storage of the levity than using+    -- the Binary (Maybe Levity) instance+    Nothing       -> putByte bh 0+    Just Lifted   -> putByte bh 1+    Just Unlifted -> putByte bh 2+  put_ bh Int8Rep        = putByte bh 3+  put_ bh Int16Rep       = putByte bh 4+  put_ bh Int32Rep       = putByte bh 5+  put_ bh Int64Rep       = putByte bh 6+  put_ bh IntRep         = putByte bh 7+  put_ bh Word8Rep       = putByte bh 8+  put_ bh Word16Rep      = putByte bh 9+  put_ bh Word32Rep      = putByte bh 10+  put_ bh Word64Rep      = putByte bh 11+  put_ bh WordRep        = putByte bh 12+  put_ bh AddrRep        = putByte bh 13+  put_ bh FloatRep       = putByte bh 14+  put_ bh DoubleRep      = putByte bh 15+  put_ bh (VecRep n per) = putByte bh 16 *> put_ bh n *> put_ bh per+  get  bh = do+    h <- getByte bh+    case h of+      0  -> pure $ BoxedRep Nothing+      1  -> pure $ BoxedRep (Just Lifted)+      2  -> pure $ BoxedRep (Just Unlifted)+      3  -> pure Int8Rep+      4  -> pure Int16Rep+      5  -> pure Int32Rep+      6  -> pure Int64Rep+      7  -> pure IntRep+      8  -> pure Word8Rep+      9  -> pure Word16Rep+      10 -> pure Word32Rep+      11 -> pure Word64Rep+      12 -> pure WordRep+      13 -> pure AddrRep+      14 -> pure FloatRep+      15 -> pure DoubleRep+      16 -> VecRep <$> get bh <*> get bh+      _  -> pprPanic "Binary:PrimRep" (int (fromIntegral h))++instance Binary PrimElemRep where+  put_ bh per = putByte bh (fromIntegral (fromEnum per))+  get  bh = toEnum . fromIntegral <$> getByte bh++isGcPtrRep :: PrimRep -> Bool+isGcPtrRep (BoxedRep _) = True+isGcPtrRep _            = False++-- A PrimRep is compatible with another iff one can be coerced to the other.+-- See Note [Bad unsafe coercion] in GHC.Core.Lint for when are two types coercible.+primRepCompatible :: Platform -> PrimRep -> PrimRep -> Bool+primRepCompatible platform rep1 rep2 =+    (isUnboxed rep1 == isUnboxed rep2) &&+    (primRepSizeB platform rep1 == primRepSizeB platform rep2) &&+    (primRepIsFloat rep1 == primRepIsFloat rep2)+  where+    isUnboxed = not . isGcPtrRep++-- More general version of `primRepCompatible` for types represented by zero or+-- more than one PrimReps.+primRepsCompatible :: Platform -> [PrimRep] -> [PrimRep] -> Bool+primRepsCompatible platform reps1 reps2 =+    length reps1 == length reps2 &&+    and (zipWith (primRepCompatible platform) reps1 reps2)++-- | The size of a 'PrimRep' in bytes.+--+-- This applies also when used in a constructor, where we allow packing the+-- fields. For instance, in @data Foo = Foo Float# Float#@ the two fields will+-- take only 8 bytes, which for 64-bit arch will be equal to 1 word.+-- See also mkVirtHeapOffsetsWithPadding for details of how data fields are+-- laid out.+primRepSizeB :: Platform -> PrimRep -> Int+primRepSizeB platform = \case+   IntRep           -> platformWordSizeInBytes platform+   WordRep          -> platformWordSizeInBytes platform+   Int8Rep          -> 1+   Int16Rep         -> 2+   Int32Rep         -> 4+   Int64Rep         -> 8+   Word8Rep         -> 1+   Word16Rep        -> 2+   Word32Rep        -> 4+   Word64Rep        -> 8+   FloatRep         -> fLOAT_SIZE+   DoubleRep        -> dOUBLE_SIZE+   AddrRep          -> platformWordSizeInBytes platform+   BoxedRep _       -> platformWordSizeInBytes platform+   (VecRep len rep) -> len * primElemRepSizeB platform rep++-- | Like primRepSizeB but assumes pointers/words are 8 words wide.+--+-- This can be useful to compute the size of a rep as if we were compiling+-- for a 64bit platform.+primRepSizeW64_B :: PrimRep -> Int+primRepSizeW64_B = \case+   IntRep           -> 8+   WordRep          -> 8+   Int8Rep          -> 1+   Int16Rep         -> 2+   Int32Rep         -> 4+   Int64Rep         -> 8+   Word8Rep         -> 1+   Word16Rep        -> 2+   Word32Rep        -> 4+   Word64Rep        -> 8+   FloatRep         -> fLOAT_SIZE+   DoubleRep        -> dOUBLE_SIZE+   AddrRep          -> 8+   BoxedRep{}       -> 8+   (VecRep len rep) -> len * primElemRepSizeW64_B rep++primElemRepSizeB :: Platform -> PrimElemRep -> Int+primElemRepSizeB platform = primRepSizeB platform . primElemRepToPrimRep++-- | Like primElemRepSizeB but assumes pointers/words are 8 words wide.+--+-- This can be useful to compute the size of a rep as if we were compiling+-- for a 64bit platform.+primElemRepSizeW64_B :: PrimElemRep -> Int+primElemRepSizeW64_B = primRepSizeW64_B . primElemRepToPrimRep++primElemRepToPrimRep :: PrimElemRep -> PrimRep+primElemRepToPrimRep Int8ElemRep   = Int8Rep+primElemRepToPrimRep Int16ElemRep  = Int16Rep+primElemRepToPrimRep Int32ElemRep  = Int32Rep+primElemRepToPrimRep Int64ElemRep  = Int64Rep+primElemRepToPrimRep Word8ElemRep  = Word8Rep+primElemRepToPrimRep Word16ElemRep = Word16Rep+primElemRepToPrimRep Word32ElemRep = Word32Rep+primElemRepToPrimRep Word64ElemRep = Word64Rep+primElemRepToPrimRep FloatElemRep  = FloatRep+primElemRepToPrimRep DoubleElemRep = DoubleRep++-- | Return if Rep stands for floating type,+-- returns Nothing for vector types.+primRepIsFloat :: PrimRep -> Maybe Bool+primRepIsFloat  FloatRep     = Just True+primRepIsFloat  DoubleRep    = Just True+primRepIsFloat  (VecRep _ _) = Nothing+primRepIsFloat  _            = Just False++-- Rep is one of the word reps.+primRepIsWord :: PrimRep -> Bool+primRepIsWord WordRep = True+primRepIsWord (Word8Rep) = True+primRepIsWord (Word16Rep) = True+primRepIsWord (Word32Rep) = True+primRepIsWord (Word64Rep) = True+primRepIsWord _ = False++-- Rep is one of the int reps.+primRepIsInt :: PrimRep -> Bool+primRepIsInt (IntRep) = True+primRepIsInt (Int8Rep) = True+primRepIsInt (Int16Rep) = True+primRepIsInt (Int32Rep) = True+primRepIsInt (Int64Rep) = True+primRepIsInt _ = False++{-+************************************************************************+*                                                                      *+                             Field labels+*                                                                      *+************************************************************************+-}++-- | The labels for the fields of this particular 'TyCon'+tyConFieldLabels :: TyCon -> [FieldLabel]+tyConFieldLabels tc = dFsEnvElts $ tyConFieldLabelEnv tc++-- | The labels for the fields of this particular 'TyCon'+tyConFieldLabelEnv :: TyCon -> FieldLabelEnv+tyConFieldLabelEnv (TyCon { tyConDetails = details })+  | AlgTyCon { algTcFields = fields } <- details = fields+  | otherwise                                    = emptyDFsEnv++-- | Look up a field label belonging to this 'TyCon'+lookupTyConFieldLabel :: FieldLabelString -> TyCon -> Maybe FieldLabel+lookupTyConFieldLabel lbl tc = lookupDFsEnv (tyConFieldLabelEnv tc) (field_label lbl)++-- | Make a map from strings to FieldLabels from all the data+-- constructors of this algebraic tycon+fieldsOfAlgTcRhs :: AlgTyConRhs -> FieldLabelEnv+fieldsOfAlgTcRhs rhs = mkDFsEnv [ (field_label $ flLabel fl, fl)+                                | fl <- dataConsFields (visibleDataCons rhs) ]+  where+    -- Duplicates in this list will be removed by 'mkFsEnv'+    dataConsFields dcs = concatMap dataConFieldLabels dcs+++{-+************************************************************************+*                                                                      *+\subsection{TyCon Construction}+*                                                                      *+************************************************************************++Note: the TyCon constructors all take a Kind as one argument, even though+they could, in principle, work out their Kind from their other arguments.+But to do so they need functions from Types, and that makes a nasty+module mutual-recursion.  And they aren't called from many places.+So we compromise, and move their Kind calculation to the call site.+-}++mkTyCon :: Name -> [TyConBinder] -> Kind -> [Role] -> TyConDetails -> TyCon+mkTyCon name binders res_kind roles details+  = tc+  where+    -- Recurisve binding because of tcNullaryTy+    tc = TyCon { tyConName             = name+               , tyConUnique           = nameUnique name+               , tyConBinders          = binders+               , tyConResKind          = res_kind+               , tyConRoles            = roles+               , tyConDetails          = details++                 -- Cached things+               , tyConKind             = mkTyConKind binders res_kind+               , tyConArity            = length binders+               , tyConNullaryTy        = mkNakedTyConTy tc+               , tyConHasClosedResKind = noFreeVarsOfType res_kind+               , tyConTyVars           = binderVars binders }++-- | This is the making of an algebraic 'TyCon'.+mkAlgTyCon :: Name+           -> [TyConBinder]  -- ^ Binders of the 'TyCon'+           -> Kind              -- ^ Result kind+           -> [Role]            -- ^ The roles for each TyVar+           -> Maybe CType       -- ^ The C type this type corresponds to+                                --   when using the CAPI FFI+           -> [PredType]        -- ^ Stupid theta: see 'algTcStupidTheta'+           -> AlgTyConRhs       -- ^ Information about data constructors+           -> AlgTyConFlav      -- ^ What flavour is it?+                                -- (e.g. vanilla, type family)+           -> Bool              -- ^ Was the 'TyCon' declared with GADT syntax?+           -> TyCon+mkAlgTyCon name binders res_kind roles cType stupid rhs parent gadt_syn+  = mkTyCon name binders res_kind roles $+    AlgTyCon { tyConCType       = cType+             , algTcStupidTheta = stupid+             , algTcRhs         = rhs+             , algTcFields      = fieldsOfAlgTcRhs rhs+             , algTcFlavour     = assertPpr (okParent name parent)+                                            (ppr name $$ ppr parent) parent+             , algTcGadtSyntax  = gadt_syn }++-- | Simpler specialization of 'mkAlgTyCon' for classes+mkClassTyCon :: Name -> [TyConBinder]+             -> [Role] -> AlgTyConRhs -> Class+             -> Name -> TyCon+mkClassTyCon name binders roles rhs clas tc_rep_name+  = mkAlgTyCon name binders constraintKind roles Nothing [] rhs+               (ClassTyCon clas tc_rep_name)+               False++mkTupleTyCon :: Name+             -> [TyConBinder]+             -> Kind    -- ^ Result kind of the 'TyCon'+             -> DataCon+             -> TupleSort    -- ^ Whether the tuple is boxed or unboxed+             -> AlgTyConFlav+             -> TyCon+mkTupleTyCon name binders res_kind con sort parent+  = mkTyCon name binders res_kind (constRoles binders Representational) $+    AlgTyCon { tyConCType       = Nothing+             , algTcGadtSyntax  = False+             , algTcStupidTheta = []+             , algTcRhs         = TupleTyCon { data_con = con+                                             , tup_sort = sort }+             , algTcFields      = emptyDFsEnv+             , algTcFlavour     = parent }++constRoles :: [TyConBinder] -> Role -> [Role]+constRoles bndrs role = [role | _ <- bndrs]++mkSumTyCon :: Name+           -> [TyConBinder]+           -> Kind    -- ^ Kind of the resulting 'TyCon'+           -> [DataCon]+           -> AlgTyConFlav+           -> TyCon+mkSumTyCon name binders res_kind cons parent+  = mkTyCon name binders res_kind (constRoles binders Representational) $+    AlgTyCon { tyConCType       = Nothing+             , algTcGadtSyntax  = False+             , algTcStupidTheta = []+             , algTcRhs         = mkSumTyConRhs cons+             , algTcFields      = emptyDFsEnv+             , algTcFlavour     = parent }++-- | Makes a tycon suitable for use during type-checking. It stores+-- a variety of details about the definition of the TyCon, but no+-- right-hand side. It lives only during the type-checking of a+-- mutually-recursive group of tycons; it is then zonked to a proper+-- TyCon in zonkTcTyCon.+-- See Note [TcTyCon, MonoTcTyCon, and PolyTcTyCon] in "GHC.Tc.TyCl"+mkTcTyCon :: Name+          -> [TyConBinder]+          -> Kind                -- ^ /result/ kind only+          -> [(Name,TcTyVar)]    -- ^ Scoped type variables;+          -> Bool                -- ^ Is this TcTyCon generalised already?+          -> TyConFlavour TyCon  -- ^ What sort of 'TyCon' this represents+          -> TyCon+mkTcTyCon name binders res_kind scoped_tvs poly flav+  = mkTyCon name binders res_kind (constRoles binders Nominal) $+    TcTyCon { tctc_scoped_tvs = scoped_tvs+            , tctc_is_poly    = poly+            , tctc_flavour    = flav }++-- | No scoped type variables (to be used with mkTcTyCon).+noTcTyConScopedTyVars :: [(Name, TcTyVar)]+noTcTyConScopedTyVars = []++-- | Create an primitive 'TyCon', such as @Int#@, @Type@ or @RealWorld@+-- Primitive TyCons are marshalable iff not lifted.+-- If you'd like to change this, modify marshalablePrimTyCon.+mkPrimTyCon :: Name -> [TyConBinder]+            -> Kind    -- ^ /result/ kind+                       -- Must answer 'True' to 'isFixedRuntimeRepKind' (i.e., no representation polymorphism).+                       -- (If you need a representation-polymorphic PrimTyCon,+                       -- change tcHasFixedRuntimeRep, marshalablePrimTyCon, reifyTyCon for PrimTyCons.)+            -> [Role]+            -> TyCon+mkPrimTyCon name binders res_kind roles+  = mkTyCon name binders res_kind roles $+    PrimTyCon { primRepName  = mkPrelTyConRepName name }++-- | Create a type synonym 'TyCon'+mkSynonymTyCon :: Name -> [TyConBinder] -> Kind   -- ^ /result/ kind+               -> [Role] -> Type+               -> Bool -> Bool -> Bool -> Bool+               -> TyCon+mkSynonymTyCon name binders res_kind roles rhs is_tau+               is_fam_free is_forgetful is_concrete+  = mkTyCon name binders res_kind roles $+    SynonymTyCon { synTcRhs       = rhs+                 , synIsTau       = is_tau+                 , synIsFamFree   = is_fam_free+                 , synIsForgetful = is_forgetful+                 , synIsConcrete  = is_concrete }++-- | Create a type family 'TyCon'+mkFamilyTyCon :: Name -> [TyConBinder] -> Kind  -- ^ /result/ kind+              -> Maybe Name -> FamTyConFlav+              -> Maybe Class -> Injectivity -> TyCon+mkFamilyTyCon name binders res_kind resVar flav parent inj+  = mkTyCon name binders res_kind (constRoles binders Nominal) $+    FamilyTyCon { famTcResVar  = resVar+                , famTcFlav    = flav+                , famTcParent  = classTyCon <$> parent+                , famTcInj     = inj }++-- | Create a promoted data constructor 'TyCon'+-- Somewhat dodgily, we give it the same Name+-- as the data constructor itself; when we pretty-print+-- the TyCon we add a quote; see the Outputable TyCon instance+mkPromotedDataCon :: DataCon -> Name -> TyConRepName+                  -> [TyConBinder] -> Kind -> [Role]+                  -> PromDataConInfo -> TyCon+mkPromotedDataCon con name rep_name binders res_kind roles rep_info+  = mkTyCon name binders res_kind roles $+    PromotedDataCon { dataCon    = con+                    , tcRepName  = rep_name+                    , promDcInfo = rep_info }++-- | Test if the 'TyCon' is algebraic but abstract (invisible data constructors)+isAbstractTyCon :: TyCon -> Bool+isAbstractTyCon (TyCon { tyConDetails = details })+  | AlgTyCon { algTcRhs = AbstractTyCon {} } <- details = True+  | otherwise           = False++-- | Does this 'TyCon' represent something that cannot be defined in Haskell?+isPrimTyCon :: TyCon -> Bool+isPrimTyCon (TyCon { tyConDetails = details })+  | PrimTyCon {} <- details = True+  | otherwise               = False++-- | Returns @True@ if the supplied 'TyCon' resulted from either a+-- @data@ or @newtype@ declaration+isAlgTyCon :: TyCon -> Bool+isAlgTyCon (TyCon { tyConDetails = details })+  | AlgTyCon {} <- details = True+  | otherwise              = False++-- | Returns @True@ for vanilla AlgTyCons -- that is, those created+-- with a @data@ or @newtype@ declaration.+isVanillaAlgTyCon :: TyCon -> Bool+isVanillaAlgTyCon (TyCon { tyConDetails = details })+  | AlgTyCon { algTcFlavour = VanillaAlgTyCon _ } <- details = True+  | otherwise                                                = False++-- | Returns @True@ if a boxed type headed by the given @TyCon@+-- satisfies condition DTT2 of Note [DataToTag overview] in+-- GHC.Tc.Instance.Class+isValidDTT2TyCon :: TyCon -> Bool+isValidDTT2TyCon = isBoxedDataTyCon++isBoxedDataTyCon :: TyCon -> Bool+-- ^ Returns @True@ for data types that are /definitely/ represented by+-- heap-allocated constructors.  These are scrutinised by Core-level+-- @case@ expressions, and they get info tables allocated for them.+--+-- Generally, the function will be+-- true for all `data` types and+-- false for  newtype+--            unboxed tuples+--            unboxed sums+--            type family+--            type data+-- 'TyCon's. But it is not guaranteed to return `True` in all cases+-- that it could.+--+-- NB: for a data type family, only the /instance/ 'TyCon's+--     get an info table.  The family declaration 'TyCon' does not+isBoxedDataTyCon (TyCon { tyConDetails = details })+  | AlgTyCon {algTcRhs = rhs} <- details+  = case rhs of+        TupleTyCon { tup_sort = sort }+                           -> isBoxed (tupleSortBoxity sort)+        SumTyCon {}        -> False+            -- Constructors from "type data" declarations exist only at+            -- the type level.+            -- See Note [Type data declarations] in GHC.Rename.Module.+        DataTyCon { is_type_data = type_data } -> not type_data+        NewTyCon {}        -> False+        UnaryClassTyCon {} -> False+        AbstractTyCon {}   -> False      -- We don't know, so return False+isBoxedDataTyCon _ = False++-- | Was this 'TyCon' declared as "type data"?+-- See Note [Type data declarations] in GHC.Rename.Module.+isTypeDataTyCon :: TyCon -> Bool+isTypeDataTyCon (TyCon { tyConDetails = details })+  | AlgTyCon {algTcRhs = DataTyCon {is_type_data = type_data }} <- details+              = type_data+  | otherwise = False++-- | 'isInjectiveTyCon' is true of 'TyCon's for which this property holds+-- (where r is the role passed in):+--   If (T a1 b1 c1) ~r (T a2 b2 c2), then (a1 ~r1 a2), (b1 ~r2 b2), and (c1 ~r3 c2)+-- (where r1, r2, and r3, are the roles given by tyConRolesX tc r)+-- See also Note [Decomposing TyConApp equalities] in "GHC.Tc.Solver.Equality"+isInjectiveTyCon :: TyCon -> Role -> Bool+isInjectiveTyCon (TyCon { tyConDetails = details }) role+  = go details+  where+    go _ | Phantom <- role = True -- Vacuously; (t1 ~P t2) holds for all t1, t2!++    go (AlgTyCon {algTcRhs = rhs})+       | Nominal <- role                                = True+       | Representational <- role                       = go_alg_rep rhs++    go (FamilyTyCon { famTcFlav = DataFamilyTyCon _ })+       | Nominal <- role                                = True+    go (FamilyTyCon { famTcInj = Injective inj })+       | Nominal <- role                                = and inj+    go (FamilyTyCon {})                                 = False++    go (SynonymTyCon {})    = False+    go (PrimTyCon {})       = True+    go (PromotedDataCon {}) = True+    go (TcTyCon {})         = True+       -- Reply True for TcTyCon to minimise knock on type errors+       -- See (W1) in Note [TcTyCon, MonoTcTyCon, and PolyTcTyCon] in GHC.Tc.TyCl++    -- go_alg_rep used only at Representational role+    go_alg_rep (TupleTyCon {})      = True+    go_alg_rep (SumTyCon {})        = True+    go_alg_rep (DataTyCon {})       = True+    go_alg_rep (UnaryClassTyCon {}) = True -- See (UCM9) in Note [Unary class magic]+    go_alg_rep (AbstractTyCon {})   = False+    go_alg_rep (NewTyCon {})        = False++-- | 'isGenerativeTyCon' is true of 'TyCon's for which this property holds+-- (where r is the role passed in):+--   If (T tys ~r t), then (t's head ~r T).+-- See also Note [Decomposing TyConApp equalities] in "GHC.Tc.Solver.Equality"+--+-- NB: at Nominal role, isGenerativeTyCon is simple:+--     isGenerativeTyCon tc Nominal+--       = not (isTypeFamilyTyCon tc || isSynonymTyCon tc)+isGenerativeTyCon :: TyCon -> Role -> Bool+isGenerativeTyCon tc@(TyCon { tyConDetails = details }) role+   = go role details+   where+    go Nominal (FamilyTyCon { famTcFlav = DataFamilyTyCon _ }) = True+    go _       (FamilyTyCon {})                                = False++    -- In all other cases, injectivity implies generativity+    go r _ = isInjectiveTyCon tc r++-- | Is this 'TyCon' that for a @newtype@+isNewTyCon :: TyCon -> Bool+isNewTyCon (TyCon { tyConDetails = details })+  | AlgTyCon {algTcRhs = NewTyCon {}} <- details = True+  | otherwise                                    = False++-- | Take a 'TyCon' apart into the 'TyVar's it scopes over, the 'Type' it+-- expands into, and (possibly) a coercion from the representation type to the+-- @newtype@.+-- Returns @Nothing@ if this is not possible.+unwrapNewTyCon_maybe :: TyCon -> Maybe ([TyVar], Type, CoAxiom Unbranched)+unwrapNewTyCon_maybe (TyCon { tyConTyVars = tvs, tyConDetails = details })+  | AlgTyCon { algTcRhs = NewTyCon { nt_co = co, nt_rhs = rhs }} <- details+              = Just (tvs, rhs, co)+  | otherwise = Nothing++unwrapNewTyConEtad_maybe :: TyCon -> Maybe ([TyVar], Type, CoAxiom Unbranched)+unwrapNewTyConEtad_maybe (TyCon { tyConDetails = details })+  | AlgTyCon { algTcRhs = NewTyCon { nt_co = co+                                    , nt_etad_rhs = (tvs,rhs) }} <- details+              = Just (tvs, rhs, co)+  | otherwise = Nothing++-- | Is this a 'TyCon' representing a regular H98 type synonym (@type@)?+{-# INLINE isTypeSynonymTyCon #-}  -- See Note [Inlining coreView] in GHC.Core.Type+isTypeSynonymTyCon :: TyCon -> Bool+isTypeSynonymTyCon (TyCon { tyConDetails = details })+  | SynonymTyCon {} <- details = True+  | otherwise                  = False++isTauTyCon :: TyCon -> Bool+isTauTyCon (TyCon { tyConDetails = details })+  | SynonymTyCon { synIsTau = is_tau } <- details = is_tau+  | otherwise                                     = True++-- | Is this tycon neither a type family nor a synonym that expands+-- to a type family?+isFamFreeTyCon :: TyCon -> Bool+isFamFreeTyCon (TyCon { tyConDetails = details })+  | SynonymTyCon { synIsFamFree = fam_free } <- details = fam_free+  | FamilyTyCon { famTcFlav = flav }         <- details = isDataFamFlav flav+  | otherwise                                           = True++-- | Is this a forgetful type synonym? If this is a type synonym whose+-- RHS does not mention one (or more) of its bound variables, returns+-- True. Thus, False means that all bound variables appear on the RHS;+-- True may not mean anything, as the test to set this flag is+-- conservative.+--+-- See Note [Forgetful type synonyms]+isForgetfulSynTyCon :: TyCon -> Bool+isForgetfulSynTyCon (TyCon { tyConDetails = details })+  | SynonymTyCon { synIsForgetful = forget } <- details = forget+  | otherwise                                           = False++{- Note [Forgetful type synonyms]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A type synonyms is /forgetful/ if its RHS fails to mention one (or more) of its bound variables.++Forgetfulness is conservative:+  * A non-forgetful synonym /guarantees/ to mention all its bound variables in its RHS.+  * It is always safe to classify a synonym as forgetful.++Examples:+    type R = Int             -- Not forgetful+    type S a = Int           -- Forgetful+    type T1 a = Int -> S a   -- Forgetful+    type T2 a = a -> S a     -- Not forgetful+    type T3 a = Int -> F a   -- Not forgetful+      where type family F a++* R shows that nullary synonyms are not forgetful.++* T2 shows that forgetfulness needs to account for uses of forgetful+  synonyms. `a` appears on the RHS, but only under a forgetful S++* T3 shows that non-forgetfulness is not the same as injectivity. T3 mentions its+  bound variable on its RHS, but under a type family.  So it is entirely possible+  that    T3 Int ~ T3 Bool++* Since type synonyms are non-recursive, we don't need a fixpoint analysis to+  determine forgetfulness.  It's rather easy -- see `GHC.Core.Type.buildSynTyCon`,+  which is a bit over-conservative for over-saturated synonyms.+-}++-- As for newtypes, it is in some contexts important to distinguish between+-- closed synonyms and synonym families, as synonym families have no unique+-- right hand side to which a synonym family application can expand.+--++-- | True iff we can decompose (T a b c) into ((T a b) c)+--   I.e. is it injective and generative w.r.t nominal equality?+--   That is, if (T a b) ~N d e f, is it always the case that+--            (T ~N d), (a ~N e) and (b ~N f)?+-- Specifically NOT true of synonyms (open and otherwise)+--+-- It'd be unusual to call tyConMustBeSaturated on a regular H98+-- type synonym, because you should probably have expanded it first+-- But regardless, it's not decomposable+tyConMustBeSaturated :: TyCon -> Bool+tyConMustBeSaturated = tcFlavourMustBeSaturated . tyConFlavour++-- | Is this an algebraic 'TyCon' declared with the GADT syntax?+isGadtSyntaxTyCon :: TyCon -> Bool+isGadtSyntaxTyCon (TyCon { tyConDetails = details })+  | AlgTyCon { algTcGadtSyntax = res } <- details = res+  | otherwise                                     = False++-- | Is this an algebraic 'TyCon' which is just an enumeration of values?+isEnumerationTyCon :: TyCon -> Bool+-- See Note [Enumeration types] in GHC.Core.TyCon+isEnumerationTyCon (TyCon { tyConArity = arity, tyConDetails = details })+  | AlgTyCon { algTcRhs = rhs } <- details+  = case rhs of+       DataTyCon { is_enum = res }     -> res+       TupleTyCon { tup_sort = tsort }+         | arity == 0                  -> isBoxed (tupleSortBoxity tsort)+                                          -- () is an enumeration, but (##) is not+       _                               -> False+  | otherwise = False++-- | Is this a 'TyCon', synonym or otherwise, that defines a family?+isFamilyTyCon :: TyCon -> Bool+isFamilyTyCon (TyCon { tyConDetails = details })+  | FamilyTyCon {} <- details = True+  | otherwise                 = False++-- | Is this a 'TyCon', synonym or otherwise, that defines a family with+-- instances?+isOpenFamilyTyCon :: TyCon -> Bool+isOpenFamilyTyCon (TyCon { tyConDetails = details })+  | FamilyTyCon {famTcFlav = flav } <- details+              = case flav of+                  OpenSynFamilyTyCon -> True+                  DataFamilyTyCon {} -> True+                  _                  -> False+  | otherwise = False++-- | Is this a type family 'TyCon' (whether open or closed)?+isTypeFamilyTyCon :: TyCon -> Bool+isTypeFamilyTyCon (TyCon { tyConDetails = details })+  | FamilyTyCon { famTcFlav = flav } <- details = not (isDataFamFlav flav)+  | otherwise                                   = False++-- | Is this a data family 'TyCon'?+isDataFamilyTyCon :: TyCon -> Bool+isDataFamilyTyCon (TyCon { tyConDetails = details })+  | FamilyTyCon { famTcFlav = flav } <- details = isDataFamFlav flav+  | otherwise                                    = False++-- | Is this an open type family TyCon?+isOpenTypeFamilyTyCon :: TyCon -> Bool+isOpenTypeFamilyTyCon (TyCon { tyConDetails = details })+  | FamilyTyCon {famTcFlav = OpenSynFamilyTyCon } <- details = True+  | otherwise                                                = False++-- | Is this a non-empty closed type family? Returns 'Nothing' for+-- abstract or empty closed families.+isClosedSynFamilyTyConWithAxiom_maybe :: TyCon -> Maybe (CoAxiom Branched)+isClosedSynFamilyTyConWithAxiom_maybe (TyCon { tyConDetails = details })+  | FamilyTyCon {famTcFlav = ClosedSynFamilyTyCon mb} <- details = mb+  | otherwise                                                    = Nothing++isBuiltInSynFamTyCon_maybe :: TyCon -> Maybe BuiltInSynFamily+isBuiltInSynFamTyCon_maybe (TyCon { tyConDetails = details })+  | FamilyTyCon {famTcFlav = BuiltInSynFamTyCon ops} <- details = Just ops+  | otherwise                                                   = Nothing++-- | Extract type variable naming the result of injective type family+tyConFamilyResVar_maybe :: TyCon -> Maybe Name+tyConFamilyResVar_maybe (TyCon { tyConDetails = details })+  | FamilyTyCon {famTcResVar = res} <- details = res+  | otherwise                                  = Nothing++-- | @'tyConInjectivityInfo' tc@ returns @'Injective' is@ if @tc@ is an+-- injective tycon (where @is@ states for which 'tyConBinders' @tc@ is+-- injective), or 'NotInjective' otherwise.+tyConInjectivityInfo :: TyCon -> Injectivity+tyConInjectivityInfo tc@(TyCon { tyConDetails = details })+  | FamilyTyCon { famTcInj = inj } <- details+  = inj+  | isInjectiveTyCon tc Nominal+  = Injective (replicate (tyConArity tc) True)+  | otherwise+  = NotInjective++isDataFamFlav :: FamTyConFlav -> Bool+isDataFamFlav (DataFamilyTyCon {}) = True   -- Data family+isDataFamFlav _                    = False  -- Type synonym family++-- | Is this TyCon for an associated type?+isTyConAssoc :: TyCon -> Bool+isTyConAssoc = isJust . tyConAssoc_maybe++-- | Get the enclosing class TyCon (if there is one) for the given TyCon.+tyConAssoc_maybe :: TyCon -> Maybe TyCon+tyConAssoc_maybe = tyConFlavourAssoc_maybe . tyConFlavour++-- The unit tycon didn't used to be classed as a tuple tycon+-- but I thought that was silly so I've undone it+-- If it can't be for some reason, it should be a AlgTyCon+isTupleTyCon :: TyCon -> Bool+-- ^ Does this 'TyCon' represent a tuple?+--+-- NB: when compiling @Data.Tuple@, the tycons won't reply @True@ to+-- 'isTupleTyCon', because they are built as 'AlgTyCons'.  However they+-- get spat into the interface file as tuple tycons, so I don't think+-- it matters.+isTupleTyCon (TyCon { tyConDetails = details })+  | AlgTyCon { algTcRhs = TupleTyCon {} } <- details = True+  | otherwise                                        = False++tyConTuple_maybe :: TyCon -> Maybe TupleSort+tyConTuple_maybe (TyCon { tyConDetails = details })+  | AlgTyCon { algTcRhs = rhs } <- details+  , TupleTyCon { tup_sort = sort} <- rhs = Just sort+  | otherwise                            = Nothing++-- | Is this the 'TyCon' for an unboxed tuple?+isUnboxedTupleTyCon :: TyCon -> Bool+isUnboxedTupleTyCon (TyCon { tyConDetails = details })+  | AlgTyCon { algTcRhs = rhs } <- details+  , TupleTyCon { tup_sort = sort } <- rhs+              = not (isBoxed (tupleSortBoxity sort))+  | otherwise = False++-- | Is this the 'TyCon' for a boxed tuple?+isBoxedTupleTyCon :: TyCon -> Bool+isBoxedTupleTyCon (TyCon { tyConDetails = details })+  | AlgTyCon { algTcRhs = rhs } <- details+  , TupleTyCon { tup_sort = sort } <- rhs+              = isBoxed (tupleSortBoxity sort)+  | otherwise = False++-- | Is this the 'TyCon' for an unboxed sum?+isUnboxedSumTyCon :: TyCon -> Bool+isUnboxedSumTyCon (TyCon { tyConDetails = details })+  | AlgTyCon { algTcRhs = rhs } <- details+  , SumTyCon {} <- rhs+              = True+  | otherwise = False++isLiftedAlgTyCon :: TyCon -> Bool+isLiftedAlgTyCon (TyCon { tyConResKind = res_kind, tyConDetails = details })+  | AlgTyCon {} <- details = isLiftedTypeKind res_kind+  | otherwise              = False++-- | Retrieves the promoted DataCon if this is a PromotedDataCon;+isPromotedDataCon_maybe :: TyCon -> Maybe DataCon+isPromotedDataCon_maybe (TyCon { tyConDetails = details })+  | PromotedDataCon { dataCon = dc } <- details = Just dc+  | otherwise                                   = Nothing++-- | Is this the 'TyCon' for a /promoted/ tuple?+isPromotedTupleTyCon :: TyCon -> Bool+isPromotedTupleTyCon tyCon+  | Just dataCon <- isPromotedDataCon_maybe tyCon+  , isTupleTyCon (dataConTyCon dataCon) = True+  | otherwise                           = False++-- | Is this a PromotedDataCon?+isPromotedDataCon :: TyCon -> Bool+isPromotedDataCon (TyCon { tyConDetails = details })+  | PromotedDataCon {} <- details = True+  | otherwise                     = False++-- | This function identifies PromotedDataCon's from data constructors in+-- `data T = K1 | K2`, promoted by -XDataKinds.  These type constructors+-- are printed with a tick mark 'K1 and 'K2, and similarly have a tick+-- mark added to their OccName's.+--+-- In contrast, constructors in `type data T = K1 | K2` are printed and+-- represented with their original undecorated names.+-- See Note [Type data declarations] in GHC.Rename.Module+isDataKindsPromotedDataCon :: TyCon -> Bool+isDataKindsPromotedDataCon (TyCon { tyConDetails = details })+  | PromotedDataCon { dataCon = dc } <- details+              = not (isTypeDataCon dc)+  | otherwise = False++-- | Is this 'TyCon' really meant for use at the kind level? That is,+-- should it be permitted without @DataKinds@?+isKindTyCon :: TyCon -> Bool+isKindTyCon = isKindUniquable++-- | This is 'Name' really meant for use at the kind level? That is,+-- should it be permitted wihout @DataKinds@?+isKindName :: Name -> Bool+isKindName = isKindUniquable++-- | The workhorse for 'isKindTyCon' and 'isKindName'.+isKindUniquable :: Uniquable a => a -> Bool+isKindUniquable thing = getUnique thing `memberUniqueSet` kindTyConKeys++-- | These TyCons should be allowed at the kind level, even without+-- -XDataKinds.+kindTyConKeys :: UniqueSet+kindTyConKeys = fromListUniqueSet $+  -- Make sure to keep this in sync with the following:+  --+  -- - The Overview section in docs/users_guide/exts/data_kinds.rst in the GHC+  --   User's Guide.+  --+  -- - The typecheck/should_compile/T22141f.hs test case, which ensures that all+  --   of these can successfully be used without DataKinds.+  [ liftedTypeKindTyConKey, liftedRepTyConKey, constraintKindTyConKey, tYPETyConKey, cONSTRAINTTyConKey ]+  ++ concatMap tycon_with_datacons [ runtimeRepTyCon, levityTyCon+                                   , multiplicityTyCon+                                   , vecCountTyCon, vecElemTyCon ]+  where+    tycon_with_datacons tc = getUnique tc : map getUnique (tyConDataCons tc)++isLiftedTypeKindTyConName :: Name -> Bool+isLiftedTypeKindTyConName = (`hasKey` liftedTypeKindTyConKey)++-- | Identifies implicit tycons that, in particular, do not go into interface+-- files (because they are implicitly reconstructed when the interface is+-- read).+--+-- Note that:+--+-- * Associated families are implicit, as they are re-constructed from+--   the class declaration in which they reside, and+--+-- * Family instances are /not/ implicit as they represent the instance body+--   (similar to a @dfun@ does that for a class instance).+--+-- * Tuples are implicit iff they have a wired-in name+--   (namely: boxed and unboxed tuples are wired-in and implicit,+--            but constraint tuples are not)+isImplicitTyCon :: TyCon -> Bool+isImplicitTyCon (TyCon { tyConName = name, tyConDetails = details }) = go details+  where+    go (PrimTyCon {})       = True+    go (PromotedDataCon {}) = True+    go (SynonymTyCon {})    = False+    go (TcTyCon {})         = False+    go (FamilyTyCon { famTcParent = parent }) = isJust parent+    go (AlgTyCon { algTcRhs = rhs })+       | TupleTyCon {} <- rhs = isWiredInName name+       | SumTyCon {} <- rhs   = True+       | otherwise            = False++tyConCType_maybe :: TyCon -> Maybe CType+tyConCType_maybe (TyCon { tyConDetails = details })+  | AlgTyCon { tyConCType = mb_ctype} <- details = mb_ctype+  | otherwise                                    = Nothing++-- | Does this 'TyCon' have a syntactically fixed RuntimeRep when fully applied,+-- as per Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete?+--+-- False is safe. True means we're sure.+-- Does only a quick check, based on the TyCon's category.+--+-- See Note [Representation-polymorphic TyCons]+tcHasFixedRuntimeRep :: TyCon -> Bool+tcHasFixedRuntimeRep tc@(TyCon { tyConDetails = details })+  | AlgTyCon { algTcRhs = rhs } <- details+  = case rhs of+       AbstractTyCon {} -> False+               -- An abstract TyCon might not have a fixed runtime representation.+               -- Note that this is an entirely different matter from the concreteness+               -- of the 'TyCon', in the sense of 'isConcreteTyCon'.++       DataTyCon { data_fixed_lev = fixed_lev } -> fixed_lev+               -- A datatype might not have a fixed levity with UnliftedDatatypes (#20423).+               -- NB: the current representation-polymorphism checks require that+               -- the representation be fully-known, including levity variables.+               -- This might be relaxed in the future (#15532).++       TupleTyCon { tup_sort = tuple_sort } -> isBoxed (tupleSortBoxity tuple_sort) ||+                                               -- (# #) also has fixed rep.+                                               tyConArity tc == 0++       SumTyCon {} -> False   -- only unboxed sums here++       UnaryClassTyCon {} -> True  -- Always boxed++       NewTyCon { nt_fixed_rep = fixed_rep } -> fixed_rep+              -- A newtype might not have a fixed runtime representation+              -- with UnliftedNewtypes (#17360)++  | SynonymTyCon {}   <- details = False   -- conservative choice+  | FamilyTyCon{}     <- details = False+  | PrimTyCon{}       <- details = True+  | TcTyCon{}         <- details = False+  | PromotedDataCon{} <- details = pprPanic "tcHasFixedRuntimeRep datacon" (ppr tc)++-- | Is this 'TyCon' concrete?+-- More specifically, if 'tys' are all concrete, is (T tys) concrete?+--      (for synonyms this requires us to look at the RHS)+-- Used for representation polymorphism checks.+-- See Note [Concrete types] in GHC.Tc.Utils.Concrete+isConcreteTyCon :: TyCon -> Bool+isConcreteTyCon tc@(TyCon { tyConDetails = details })+  = case details of+      AlgTyCon {}        -> True   -- Includes AbstractTyCon+      PrimTyCon {}       -> True+      PromotedDataCon {} -> True+      FamilyTyCon {}     -> False++      SynonymTyCon { synIsConcrete = is_conc } -> is_conc++      TcTyCon {} -> pprPanic "isConcreteTyCon" (ppr tc)+                    -- isConcreteTyCon is only used on "real" tycons++{-+-----------------------------------------------+--      TcTyCon+-----------------------------------------------+-}++-- | Is this a TcTyCon? (That is, one only used during type-checking?)+isTcTyCon :: TyCon -> Bool+isTcTyCon (TyCon { tyConDetails = details })+  | TcTyCon {} <- details = True+  | otherwise             = False++setTcTyConKind :: TyCon -> Kind -> TyCon+-- Update the Kind of a TcTyCon+-- The new kind is always a zonked version of its previous+-- kind, so we don't need to update any other fields.+-- See Note [The Purely Kinded Type Invariant (PKTI)] in GHC.Tc.Gen.HsType+setTcTyConKind tc kind+  = assert (isMonoTcTyCon tc) $+    let tc' = tc { tyConKind      = kind+                 , tyConNullaryTy = mkNakedTyConTy tc' }+                 -- See Note [Sharing nullary TyConApps]+    in tc'++isMonoTcTyCon :: TyCon -> Bool+isMonoTcTyCon (TyCon { tyConDetails = details })+  | TcTyCon { tctc_is_poly = is_poly } <- details = not is_poly+  | otherwise                                      = False++tcTyConScopedTyVars :: TyCon -> [(Name,TcTyVar)]+tcTyConScopedTyVars tc@(TyCon { tyConDetails = details })+  | TcTyCon { tctc_scoped_tvs = scoped_tvs } <- details = scoped_tvs+  | otherwise = pprPanic "tcTyConScopedTyVars" (ppr tc)++{-+-----------------------------------------------+--      Expand type-constructor applications+-----------------------------------------------+-}++data ExpandSynResult tyco+  = NoExpansion+  | ExpandsSyn [(TyVar,tyco)] Type [tyco]++expandSynTyCon_maybe+        :: TyCon+        -> [tyco]                 -- ^ Arguments to 'TyCon'+        -> ExpandSynResult tyco       -- ^ Returns a 'TyVar' substitution, the body+                                  -- type of the synonym (not yet substituted)+                                  -- and any arguments remaining from the+                                  -- application+-- ^ Expand a type synonym application+-- Return Nothing if the TyCon is not a synonym,+-- or if not enough arguments are supplied+expandSynTyCon_maybe (TyCon { tyConTyVars = tvs, tyConArity = arity+                            , tyConDetails = details }) tys+  | SynonymTyCon { synTcRhs = rhs } <- details+  = if arity == 0+    then ExpandsSyn [] rhs tys  -- Avoid a bit of work in the case of nullary synonyms+    else case tys `listLengthCmp` arity of+              GT -> ExpandsSyn (tvs `zip` tys) rhs (drop arity tys)+              EQ -> ExpandsSyn (tvs `zip` tys) rhs []+              LT -> NoExpansion+   | otherwise+   = NoExpansion++----------------++-- | Check if the tycon actually refers to a proper `data` or `newtype`+--  with user defined constructors rather than one from a class or other+--  construction.++-- NB: This is only used in GHC.Tc.Gen.Export.checkPatSynParent to determine if an+-- exported tycon can have a pattern synonym bundled with it, e.g.,+-- module Foo (TyCon(.., PatSyn)) where+isTyConWithSrcDataCons :: TyCon -> Bool+isTyConWithSrcDataCons (TyCon { tyConDetails = details })+  | AlgTyCon { algTcRhs = rhs, algTcFlavour = parent } <- details+  , let isSrcParent = isNoParent parent+              = case rhs of+                   DataTyCon {}  -> isSrcParent+                   NewTyCon {}   -> isSrcParent+                   TupleTyCon {} -> isSrcParent+                   _             -> False+  | FamilyTyCon { famTcFlav = DataFamilyTyCon {} } <- details+              = True -- #14058+  | otherwise = False+++-- | As 'tyConDataCons_maybe', but returns the empty list of constructors if no+-- constructors could be found+tyConDataCons :: TyCon -> [DataCon]+-- It's convenient for tyConDataCons to return the+-- empty list for type synonyms etc+tyConDataCons tycon = tyConDataCons_maybe tycon `orElse` []++-- | Determine the 'DataCon's originating from the given 'TyCon', if the 'TyCon'+-- is the sort that can have any constructors (note: this does not include+-- abstract algebraic types)+tyConDataCons_maybe :: TyCon -> Maybe [DataCon]+tyConDataCons_maybe (TyCon { tyConDetails = details })+  | AlgTyCon {algTcRhs = rhs} <- details+  = case rhs of+       DataTyCon { data_cons = cons }     -> Just cons+       NewTyCon { data_con = con }        -> Just [con]+       UnaryClassTyCon { data_con = con } -> Just [con]+       TupleTyCon { data_con = con }      -> Just [con]+       SumTyCon { data_cons = cons }      -> Just cons+       _                                  -> Nothing+tyConDataCons_maybe _ = Nothing++-- | If the given 'TyCon' has a /single/ data constructor, i.e. it is a @data@+-- type with one alternative, a tuple type or a @newtype@ then that constructor+-- is returned. If the 'TyCon' has more than one constructor, or represents a+-- primitive or function type constructor then @Nothing@ is returned.+tyConSingleDataCon_maybe :: TyCon -> Maybe DataCon+tyConSingleDataCon_maybe (TyCon { tyConDetails = details })+  | AlgTyCon { algTcRhs = rhs } <- details+  = case rhs of+      DataTyCon { data_cons = [c] }    -> Just c+      TupleTyCon { data_con = c }      -> Just c+      NewTyCon { data_con = c }        -> Just c+      UnaryClassTyCon { data_con = c } -> Just c+      _                                -> Nothing+  | otherwise = Nothing++-- | Like 'tyConSingleDataCon_maybe', but panics if 'Nothing'.+tyConSingleDataCon :: TyCon -> DataCon+tyConSingleDataCon tc+  = case tyConSingleDataCon_maybe tc of+      Just c  -> c+      Nothing -> pprPanic "tyConDataCon" (ppr tc)++-- | Determine the number of value constructors a 'TyCon' has. Panics if the+-- 'TyCon' is not algebraic or a tuple+tyConFamilySize  :: TyCon -> Int+tyConFamilySize tc@(TyCon { tyConDetails = details })+  | AlgTyCon { algTcRhs = rhs } <- details+  = case rhs of+      DataTyCon { data_cons_size = size } -> size+      NewTyCon {}                    -> 1+      UnaryClassTyCon {}             -> 1+      TupleTyCon {}                  -> 1+      SumTyCon { data_cons_size = size }  -> size+      _                              -> pprPanic "tyConFamilySize 1" (ppr tc)+  | otherwise = pprPanic "tyConFamilySize 2" (ppr tc)++-- | Extract an 'AlgTyConRhs' with information about data constructors from an+-- algebraic or tuple 'TyCon'. Panics for any other sort of 'TyCon'+algTyConRhs :: TyCon -> AlgTyConRhs+algTyConRhs tc@(TyCon { tyConDetails = details })+  | AlgTyCon {algTcRhs = rhs} <- details = rhs+  | otherwise                            = pprPanic "algTyConRhs" (ppr tc)++-- | Extract the bound type variables and type expansion of a type synonym+-- 'TyCon'. Panics if the 'TyCon' is not a synonym+newTyConRhs :: TyCon -> ([TyVar], Type)+newTyConRhs tc@(TyCon { tyConTyVars = tvs, tyConDetails = details })+  | AlgTyCon { algTcRhs = NewTyCon { nt_rhs = rhs }} <- details+  = (tvs, rhs)+  | otherwise+  = pprPanic "newTyConRhs" (ppr tc)++-- | The number of type parameters that need to be passed to a newtype to+-- resolve it. May be less than in the definition if it can be eta-contracted.+newTyConEtadArity :: TyCon -> Int+newTyConEtadArity tc@(TyCon { tyConDetails = details })+  | AlgTyCon {algTcRhs = NewTyCon { nt_etad_rhs = tvs_rhs }} <- details+  = length (fst tvs_rhs)+  | otherwise+  = pprPanic "newTyConEtadArity" (ppr tc)++-- | Extract the bound type variables and type expansion of an eta-contracted+-- type synonym 'TyCon'.  Panics if the 'TyCon' is not a synonym+newTyConEtadRhs :: TyCon -> ([TyVar], Type)+newTyConEtadRhs tc@(TyCon { tyConDetails = details })+  | AlgTyCon {algTcRhs = NewTyCon { nt_etad_rhs = tvs_rhs }} <- details = tvs_rhs+  | otherwise = pprPanic "newTyConEtadRhs" (ppr tc)++-- | Extracts the @newtype@ coercion from such a 'TyCon', which can be used to+-- construct something with the @newtype@s type from its representation type+-- (right hand side). If the supplied 'TyCon' is not a @newtype@, returns+-- @Nothing@+newTyConCo_maybe :: TyCon -> Maybe (CoAxiom Unbranched)+newTyConCo_maybe (TyCon { tyConDetails = details })+  | AlgTyCon {algTcRhs = NewTyCon { nt_co = co }} <- details = Just co+  | otherwise                                                = Nothing++newTyConCo :: TyCon -> CoAxiom Unbranched+newTyConCo tc = case newTyConCo_maybe tc of+                 Just co -> co+                 Nothing -> pprPanic "newTyConCo" (ppr tc)++newTyConDataCon_maybe :: TyCon -> Maybe DataCon+newTyConDataCon_maybe (TyCon { tyConDetails = details })+  | AlgTyCon {algTcRhs = NewTyCon { data_con = con }} <- details = Just con+  | otherwise                                                    = Nothing++-- | Find the \"stupid theta\" of the 'TyCon'. A \"stupid theta\" is the context+-- to the left of an algebraic type declaration, e.g. @Eq a@ in the declaration+-- @data Eq a => T a ...@. See @Note [The stupid context]@ in "GHC.Core.DataCon".+tyConStupidTheta :: TyCon -> [PredType]+tyConStupidTheta tc@(TyCon { tyConDetails = details })+  | AlgTyCon {algTcStupidTheta = stupid} <- details = stupid+  | PrimTyCon {} <- details                         = []+  | PromotedDataCon {} <- details                   = []+  | otherwise = pprPanic "tyConStupidTheta" (ppr tc)++-- | Extract the 'TyVar's bound by a vanilla type synonym+-- and the corresponding (unsubstituted) right hand side.+synTyConDefn_maybe :: TyCon -> Maybe ([TyVar], Type)+synTyConDefn_maybe (TyCon { tyConTyVars = tyvars, tyConDetails = details })+  | SynonymTyCon {synTcRhs = ty} <- details+  = Just (tyvars, ty)+  | otherwise+  = Nothing++-- | Extract the information pertaining to the right hand side of a type synonym+-- (@type@) declaration.+synTyConRhs_maybe :: TyCon -> Maybe Type+synTyConRhs_maybe (TyCon { tyConDetails = details })+  | SynonymTyCon {synTcRhs = rhs} <- details  = Just rhs+  | otherwise                                 = Nothing++-- | Extract the flavour of a type family (with all the extra information that+-- it carries)+famTyConFlav_maybe :: TyCon -> Maybe FamTyConFlav+famTyConFlav_maybe (TyCon { tyConDetails = details })+  | FamilyTyCon {famTcFlav = flav} <- details = Just flav+  | otherwise                                 = Nothing++isUnaryClassTyCon :: TyCon -> Bool+isUnaryClassTyCon tc@(TyCon { tyConDetails = details })+  | AlgTyCon { algTcFlavour = flav, algTcRhs = UnaryClassTyCon {} } <- details+  = assertPpr (case flav of { ClassTyCon {} -> True; _ -> False }) (ppr tc) $+    True+  | otherwise+  = False++isUnaryClassTyCon_maybe :: TyCon -> Maybe (Class, DataCon)+isUnaryClassTyCon_maybe (TyCon { tyConDetails = details })+  | AlgTyCon { algTcFlavour = ClassTyCon cls _+             , algTcRhs = UnaryClassTyCon { data_con = dc } } <- details+  = Just (cls, dc)+  | otherwise+  = Nothing++-- | Is this 'TyCon' that for a class instance?+isClassTyCon :: TyCon -> Bool+isClassTyCon (TyCon { tyConDetails = details })+  | AlgTyCon {algTcFlavour = ClassTyCon {}} <- details = True+  | otherwise                                          = False++-- | If this 'TyCon' is that for a class instance, return the class it is for.+-- Otherwise returns @Nothing@+tyConClass_maybe :: TyCon -> Maybe Class+tyConClass_maybe (TyCon { tyConDetails = details })+  | AlgTyCon {algTcFlavour = ClassTyCon clas _} <- details = Just clas+  | otherwise                                              = Nothing++-- | Return the associated types of the 'TyCon', if any+tyConATs :: TyCon -> [TyCon]+tyConATs (TyCon { tyConDetails = details })+  | AlgTyCon {algTcFlavour = ClassTyCon clas _} <- details = classATs clas+  | otherwise                                              = []++----------------------------------------------------------------------------+-- | Is this 'TyCon' that for a data family instance?+isFamInstTyCon :: TyCon -> Bool+isFamInstTyCon (TyCon { tyConDetails = details })+  | AlgTyCon {algTcFlavour = DataFamInstTyCon {} } <- details = True+  | otherwise                                                 = False++tyConFamInstSig_maybe :: TyCon -> Maybe (TyCon, [Type], CoAxiom Unbranched)+tyConFamInstSig_maybe (TyCon { tyConDetails = details })+  | AlgTyCon {algTcFlavour = DataFamInstTyCon ax f ts } <- details = Just (f, ts, ax)+  | otherwise                                                      = Nothing++-- | If this 'TyCon' is that of a data family instance, return the family in question+-- and the instance types. Otherwise, return @Nothing@+tyConFamInst_maybe :: TyCon -> Maybe (TyCon, [Type])+tyConFamInst_maybe (TyCon { tyConDetails = details })+  | AlgTyCon {algTcFlavour = DataFamInstTyCon _ f ts } <- details = Just (f, ts)+  | otherwise                                                     = Nothing++-- | If this 'TyCon' is that of a data family instance, return a 'TyCon' which+-- represents a coercion identifying the representation type with the type+-- instance family.  Otherwise, return @Nothing@+tyConFamilyCoercion_maybe :: TyCon -> Maybe (CoAxiom Unbranched)+tyConFamilyCoercion_maybe (TyCon { tyConDetails = details })+  | AlgTyCon {algTcFlavour = DataFamInstTyCon ax _ _ } <- details = Just ax+  | otherwise                                                     = Nothing++-- | Extract any 'RuntimeRepInfo' from this TyCon+tyConPromDataConInfo :: TyCon -> PromDataConInfo+tyConPromDataConInfo (TyCon { tyConDetails = details })+  | PromotedDataCon { promDcInfo = rri } <- details = rri+  | otherwise                                       = NoPromInfo+  -- could panic in that second case. But Douglas Adams told me not to.++{-+Note [Constructor tag allocation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When typechecking we need to allocate constructor tags to constructors.+They are allocated based on the position in the data_cons field of TyCon,+with the first constructor getting fIRST_TAG.++We used to pay linear cost per constructor, with each constructor looking up+its relative index in the constructor list. That was quadratic and prohibitive+for large data types with more than 10k constructors.++The current strategy is to build a NameEnv with a mapping from constructor's+Name to ConTag and pass it down to buildDataCon for efficient lookup.++Relevant ticket: #14657+-}++mkTyConTagMap :: TyCon -> NameEnv ConTag+mkTyConTagMap tycon =+  mkNameEnv $ map getName (tyConDataCons tycon) `zip` [fIRST_TAG..]+  -- See Note [Constructor tag allocation]++{-+************************************************************************+*                                                                      *+\subsection[TyCon-instances]{Instance declarations for @TyCon@}+*                                                                      *+************************************************************************++@TyCon@s are compared by comparing their @Unique@s.+-}++instance Eq TyCon where+    a == b = getUnique a == getUnique b+    a /= b = getUnique a /= getUnique b++instance Uniquable TyCon where+    getUnique tc = tyConUnique tc++instance Outputable TyCon where+  -- At the moment a promoted TyCon has the same Name as its+  -- corresponding TyCon, so we add the quote to distinguish it here+  ppr tc = pprPromotionQuote tc <> ppr (tyConName tc) <> pp_tc+    where+      pp_tc = getPprStyle $ \sty ->+              getPprDebug $ \debug ->+               if ((debug || dumpStyle sty) && isTcTyCon tc)+                  then text "[tc]"+                  else empty++tyConFlavour :: TyCon -> TyConFlavour TyCon+tyConFlavour (TyCon { tyConDetails = details })+  | AlgTyCon { algTcFlavour = parent, algTcRhs = rhs } <- details+  = case parent of+      ClassTyCon {} -> ClassFlavour+      _ -> case rhs of+                  TupleTyCon { tup_sort = sort }+                                     -> TupleFlavour (tupleSortBoxity sort)+                  SumTyCon {}        -> SumFlavour+                  DataTyCon {}       -> DataTypeFlavour+                  NewTyCon {}        -> NewtypeFlavour+                  UnaryClassTyCon {} -> ClassFlavour+                  AbstractTyCon {}   -> AbstractTypeFlavour++  | FamilyTyCon { famTcFlav = flav, famTcParent = parent } <- details+  = case flav of+      DataFamilyTyCon{}            -> OpenFamilyFlavour (IAmData DataType) parent+      OpenSynFamilyTyCon           -> OpenFamilyFlavour IAmType parent+      ClosedSynFamilyTyCon{}       -> ClosedTypeFamilyFlavour+      AbstractClosedSynFamilyTyCon -> ClosedTypeFamilyFlavour+      BuiltInSynFamTyCon{}         -> ClosedTypeFamilyFlavour++  | SynonymTyCon {} <- details                  = TypeSynonymFlavour+  | PrimTyCon {} <- details                     = BuiltInTypeFlavour+  | PromotedDataCon {} <- details               = PromotedDataConFlavour+  | TcTyCon { tctc_flavour = flav } <-details   = flav++-- | Can this flavour of 'TyCon' appear unsaturated?+tcFlavourMustBeSaturated :: TyConFlavour tc -> Bool+tcFlavourMustBeSaturated ClassFlavour            = False+tcFlavourMustBeSaturated DataTypeFlavour         = False+tcFlavourMustBeSaturated NewtypeFlavour          = False+tcFlavourMustBeSaturated TupleFlavour{}          = False+tcFlavourMustBeSaturated SumFlavour              = False+tcFlavourMustBeSaturated AbstractTypeFlavour {}  = False+tcFlavourMustBeSaturated BuiltInTypeFlavour      = False+tcFlavourMustBeSaturated PromotedDataConFlavour  = False+tcFlavourMustBeSaturated (OpenFamilyFlavour td _)= case td of { IAmData {} -> False; IAmType -> True }+tcFlavourMustBeSaturated TypeSynonymFlavour      = True+tcFlavourMustBeSaturated ClosedTypeFamilyFlavour = True++-- | Is this flavour of 'TyCon' an open type family or a data family?+tcFlavourIsOpen :: TyConFlavour tc -> Bool+tcFlavourIsOpen OpenFamilyFlavour{}     = True+tcFlavourIsOpen ClosedTypeFamilyFlavour = False+tcFlavourIsOpen ClassFlavour            = False+tcFlavourIsOpen DataTypeFlavour         = False+tcFlavourIsOpen NewtypeFlavour          = False+tcFlavourIsOpen TupleFlavour{}          = False+tcFlavourIsOpen SumFlavour              = False+tcFlavourIsOpen AbstractTypeFlavour {}  = False+tcFlavourIsOpen BuiltInTypeFlavour      = False+tcFlavourIsOpen PromotedDataConFlavour  = False+tcFlavourIsOpen TypeSynonymFlavour      = False++pprPromotionQuote :: TyCon -> SDoc+-- Promoted data constructors already have a tick in their OccName+pprPromotionQuote tc =+  getPprStyle $ \sty ->+    let+      name   = getOccName tc+      ticked = isDataKindsPromotedDataCon tc && promTick sty (PromotedItemDataCon name)+    in+      if ticked+      then char '\''+      else empty++instance NamedThing TyCon where+    getName = tyConName++instance Data.Data TyCon where+    -- don't traverse?+    toConstr _   = abstractConstr "TyCon"+    gunfold _ _  = error "gunfold"+    dataTypeOf _ = mkNoRepType "TyCon"++instance Binary Injectivity where+    put_ bh NotInjective   = putByte bh 0+    put_ bh (Injective xs) = putByte bh 1 >> put_ bh xs++    get bh = do { h <- getByte bh+                ; case h of+                    0 -> return NotInjective+                    _ -> do { xs <- get bh+                            ; return (Injective xs) } }++instance NFData Injectivity where+  rnf NotInjective = ()+  rnf (Injective xs) = rnf xs  -- | Returns whether or not this 'TyCon' is definite, or a hole -- that may be filled in at some later point.  See Note [Skolem abstract data]
GHC/Core/TyCon.hs-boot view
@@ -12,9 +12,9 @@  type TyConRepName = Name +isNewTyCon          :: TyCon -> Bool isTupleTyCon        :: TyCon -> Bool isUnboxedTupleTyCon :: TyCon -> Bool-isFunTyCon          :: TyCon -> Bool  tyConRepName_maybe  :: TyCon -> Maybe TyConRepName mkPrelTyConRepName  :: Name -> TyConRepName
GHC/Core/TyCon/Env.hs view
@@ -100,10 +100,10 @@ delFromTyConEnv x y      = delFromUFM x y delListFromTyConEnv x y  = delListFromUFM x y filterTyConEnv x y       = filterUFM x y-anyTyConEnv f x          = foldUFM ((||) . f) False x+anyTyConEnv f x          = nonDetFoldUFM ((||) . f) False x disjointTyConEnv x y     = disjointUFM x y -lookupTyConEnv_NF env n = expectJust "lookupTyConEnv_NF" (lookupTyConEnv env n)+lookupTyConEnv_NF env n = expectJust (lookupTyConEnv env n)  -- | Deterministic TyCon Environment --
GHC/Core/Type.hs view
@@ -3,3923 +3,3436 @@ -- -- Type - public interface -{-# LANGUAGE FlexibleContexts, PatternSynonyms, ViewPatterns #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}-{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}---- | 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, ArgFlag(..), AnonArgFlag(..),-        Specificity(..),-        KindOrType, PredType, ThetaType, FRRType,-        Var, TyVar, isTyVar, TyCoVar, TyCoBinder, TyCoVarBinder, TyVarBinder,-        Mult, Scaled,-        KnotTied,--        -- ** Constructing and deconstructing types-        mkTyVarTy, mkTyVarTys, getTyVar, getTyVar_maybe, repGetTyVar_maybe,-        getCastedTyVar_maybe, tyVarKind, varType,--        mkAppTy, mkAppTys, splitAppTy, splitAppTys, repSplitAppTys,-        splitAppTy_maybe, repSplitAppTy_maybe, tcRepSplitAppTy_maybe,--        mkFunTy, mkVisFunTy, mkInvisFunTy,-        mkVisFunTys,-        mkVisFunTyMany, mkInvisFunTyMany,-        mkVisFunTysMany, mkInvisFunTysMany,-        splitFunTy, splitFunTy_maybe,-        splitFunTys, funResultTy, funArgTy,--        mkTyConApp, mkTyConTy, mkTYPEapp,-        tyConAppTyCon_maybe, tyConAppTyConPicky_maybe,-        tyConAppArgs_maybe, tyConAppTyCon, tyConAppArgs,-        splitTyConApp_maybe, splitTyConApp, tyConAppArgN,-        tcSplitTyConApp_maybe,-        splitListTyConApp_maybe,-        repSplitTyConApp_maybe,-        tcRepSplitTyConApp_maybe,--        mkForAllTy, mkForAllTys, mkInvisForAllTys, mkTyCoInvForAllTys,-        mkSpecForAllTy, mkSpecForAllTys,-        mkVisForAllTys, mkTyCoInvForAllTy,-        mkInfForAllTy, mkInfForAllTys,-        splitForAllTyCoVars,-        splitForAllReqTVBinders, splitForAllInvisTVBinders,-        splitForAllTyCoVarBinders,-        splitForAllTyCoVar_maybe, splitForAllTyCoVar,-        splitForAllTyVar_maybe, splitForAllCoVar_maybe,-        splitPiTy_maybe, splitPiTy, splitPiTys,-        getRuntimeArgTys,-        mkTyConBindersPreferAnon,-        mkPiTy, mkPiTys,-        piResultTy, piResultTys,-        applyTysX, dropForAlls,-        mkFamilyTyConApp,-        buildSynTyCon,--        mkNumLitTy, isNumLitTy,-        mkStrLitTy, isStrLitTy,-        mkCharLitTy, isCharLitTy,-        isLitTy,--        isPredTy,--        getRuntimeRep_maybe, kindRep_maybe, kindRep,--        mkCastTy, mkCoercionTy, splitCastTy_maybe,--        userTypeError_maybe, pprUserTypeErrorTy,--        coAxNthLHS,-        stripCoercionTy,--        splitInvisPiTys, splitInvisPiTysN,-        invisibleTyBndrCount,-        filterOutInvisibleTypes, filterOutInferredTypes,-        partitionInvisibleTypes, partitionInvisibles,-        tyConArgFlags, appTyArgFlags,--        -- ** Analyzing types-        TyCoMapper(..), mapTyCo, mapTyCoX,-        TyCoFolder(..), foldTyCo, noView,--        -- (Newtypes)-        newTyConInstRhs,--        -- ** Binders-        sameVis,-        mkTyCoVarBinder, mkTyCoVarBinders,-        mkTyVarBinder, mkTyVarBinders,-        tyVarSpecToBinders,-        mkAnonBinder,-        isAnonTyCoBinder,-        binderVar, binderVars, binderType, binderArgFlag,-        tyCoBinderType, tyCoBinderVar_maybe,-        tyBinderType,-        binderRelevantType_maybe,-        isVisibleArgFlag, isInvisibleArgFlag, isVisibleBinder,-        isInvisibleBinder, isNamedBinder,-        tyConBindersTyCoBinders,--        -- ** Common type constructors-        funTyCon, unrestrictedFunTyCon,--        -- ** Predicates on types-        isTyVarTy, isFunTy, isCoercionTy,-        isCoercionTy_maybe, isForAllTy,-        isForAllTy_ty, isForAllTy_co,-        isPiTy, isTauTy, isFamFreeTy,-        isCoVarType, isAtomicTy,--        isValidJoinPointType,-        tyConAppNeedsKindSig,--        -- *** Levity and boxity-        typeLevity_maybe,-        isLiftedTypeKind, isUnliftedTypeKind, isBoxedTypeKind, pickyIsLiftedTypeKind,-        isLiftedRuntimeRep, isUnliftedRuntimeRep, runtimeRepLevity_maybe,-        isBoxedRuntimeRep,-        isLiftedLevity, isUnliftedLevity,-        isUnliftedType, isBoxedType, isUnboxedTupleType, isUnboxedSumType,-        mightBeLiftedType, mightBeUnliftedType,-        isStateType,-        isAlgType, isDataFamilyAppType,-        isPrimitiveType, isStrictType,-        isLevityTy, isLevityVar,-        isRuntimeRepTy, isRuntimeRepVar, isRuntimeRepKindedTy,-        dropRuntimeRepArgs,-        getRuntimeRep, getLevity, getLevity_maybe,--        -- * Multiplicity--        isMultiplicityTy, isMultiplicityVar,-        unrestricted, linear, tymult,-        mkScaled, irrelevantMult, scaledSet,-        pattern One, pattern Many,-        isOneDataConTy, isManyDataConTy,-        isLinearType,--        -- * Main data types representing Kinds-        Kind,--        -- ** Finding the kind of a type-        typeKind, tcTypeKind, typeHasFixedRuntimeRep, resultHasFixedRuntimeRep,-        tcIsLiftedTypeKind, tcIsConstraintKind, tcReturnsConstraintKind,-        tcIsBoxedTypeKind, tcIsRuntimeTypeKind,--        -- ** Common Kind-        liftedTypeKind, unliftedTypeKind,--        -- * Type free variables-        tyCoFVsOfType, tyCoFVsBndr, tyCoFVsVarBndr, tyCoFVsVarBndrs,-        tyCoVarsOfType, tyCoVarsOfTypes,-        tyCoVarsOfTypeDSet,-        coVarsOfType,-        coVarsOfTypes,--        anyFreeVarsOfType, anyFreeVarsOfTypes,-        noFreeVarsOfType,-        splitVisVarsOfType, splitVisVarsOfTypes,-        expandTypeSynonyms,-        typeSize, occCheckExpand,--        -- ** Closing over kinds-        closeOverKindsDSet, closeOverKindsList,-        closeOverKinds,--        -- * Well-scoped lists of variables-        scopedSort, 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,-        zipTCvSubst,-        notElemTCvSubst,-        getTvSubstEnv, setTvSubstEnv,-        zapTCvSubst, getTCvInScope, getTCvSubstRangeFVs,-        extendTCvInScope, extendTCvInScopeList, extendTCvInScopeSet,-        extendTCvSubst, extendCvSubst,-        extendTvSubst, extendTvSubstBinderAndInScope,-        extendTvSubstList, extendTvSubstAndInScope,-        extendTCvSubstList,-        extendTvSubstWithClone,-        extendTCvSubstWithClone,-        isInScope, composeTCvSubstEnv, composeTCvSubst, zipTyEnv, zipCoEnv,-        isEmptyTCvSubst, unionTCvSubst,--        -- ** Performing substitution on types and kinds-        substTy, substTys, substScaledTy, substScaledTys, substTyWith, substTysWith, substTheta,-        substTyAddInScope,-        substTyUnchecked, substTysUnchecked, substScaledTyUnchecked, substScaledTysUnchecked,-        substThetaUnchecked, substTyWithUnchecked,-        substCoUnchecked, substCoWithUnchecked,-        substTyVarBndr, substTyVarBndrs, substTyVar, substTyVars,-        substVarBndr, substVarBndrs,-        substTyCoBndr,-        cloneTyVarBndr, cloneTyVarBndrs, lookupTyVar,--        -- * Tidying type related things up for printing-        tidyType,      tidyTypes,-        tidyOpenType,  tidyOpenTypes,-        tidyVarBndr, tidyVarBndrs, tidyFreeTyCoVars,-        tidyOpenTyCoVar, tidyOpenTyCoVars,-        tidyTyCoVarOcc,-        tidyTopType,-        tidyTyCoVarBinder, tidyTyCoVarBinders,--        -- * Kinds-        isConstraintKindCon,-        classifiesTypeWithValues,-        isConcrete, 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.Tidy-import GHC.Core.TyCo.FVs---- friends:-import GHC.Types.Var-import GHC.Types.Var.Env-import GHC.Types.Var.Set-import GHC.Types.Unique.Set--import GHC.Core.TyCon-import GHC.Builtin.Types.Prim-import {-# SOURCE #-} GHC.Builtin.Types-                                 ( charTy, naturalTy, listTyCon-                                 , typeSymbolKind, liftedTypeKind, unliftedTypeKind-                                 , liftedRepTy, unliftedRepTy, zeroBitRepTy-                                 , boxedRepDataConTyCon-                                 , constraintKind, zeroBitTypeKind-                                 , unrestrictedFunTyCon-                                 , manyDataConTy, oneDataConTy )-import GHC.Types.Name( Name )-import GHC.Builtin.Names-import GHC.Core.Coercion.Axiom-import {-# SOURCE #-} GHC.Core.Coercion-   ( mkNomReflCo, mkGReflCo, mkReflCo-   , mkTyConAppCo, mkAppCo, mkCoVarCo, mkAxiomRuleCo-   , mkForAllCo, mkFunCo, mkAxiomInstCo, mkUnivCo-   , mkSymCo, mkTransCo, mkNthCo, mkLRCo, mkInstCo-   , mkKindCo, mkSubCo-   , decomposePiCos, coercionKind, coercionLKind-   , 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.Utils.Panic.Plain-import GHC.Data.FastString-import GHC.Data.Pair-import GHC.Data.List.SetOps-import GHC.Types.Unique ( nonDetCmpUnique )--import GHC.Data.Maybe   ( orElse, expectJust )-import Data.Maybe       ( isJust )-import Control.Monad    ( guard )--- import GHC.Utils.Trace---- $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-*                                                                      *-************************************************************************--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. Accordingly, tcView is used in type-checker-oriented-functions (including the pure unifier, used in instance resolution),-while coreView is used during e.g. optimisation passes.--See also #11715, which tracks removing this inconsistency.--In order to prevent users from discerning between Type and Constraint-(which could create inconsistent axioms -- see #21092), we say that-Type and Constraint are not SurelyApart in the pure unifier. See-GHC.Core.Unify.unify_ty, where this case produces MaybeApart.--One annoying consequence of this inconsistency is that we can get ill-kinded-updates to metavariables. #20356 is a case in point. Simplifying somewhat,-we end up with-  [W] (alpha :: Constraint)  ~  (Int :: Type)-This is heterogeneous, so we produce-  [W] co :: (Constraint ~ Type)-and transform our original wanted to become-  [W] alpha ~ Int |> sym co-in accordance with Note [Equalities with incompatible kinds] in GHC.Tc.Solver.Canonical.-Our transformed wanted is now homogeneous (both sides have kind Constraint)-and so we unify alpha := Int |> sym co.--However, it's not so easy: when we build the cast (Int |> sym co), we actually-just get Int back. This is because we forbid reflexive casts (invariant (EQ2) of-Note [Respecting definitional equality] in GHC.Core.TyCo.Rep), and co looks-reflexive: it relates Type and Constraint, even though these are considered-identical in Core. Above, when we tried to say alpha := Int |> sym co, we-really ended up doing alpha := Int -- even though alpha :: Constraint and-Int :: Type have different kinds. Nothing has really gone wrong, though:-we still emitted [W] co :: (Constraint ~ Type), which will be insoluble-and lead to a decent error message. We simply need not to fall over at the-moment of unification, because all will be OK in the end. We thus use the-Core eqType, not the Haskell tcEqType, in the kind check for a meta-tyvar-unification in GHC.Tc.Utils.TcMType.writeMetaTyVarRef.---}---- | Gives the typechecker view of a type. This unwraps synonyms but--- leaves 'Constraint' alone. c.f. 'coreView', which turns 'Constraint' into--- 'Type'. Returns 'Nothing' if no unwrapping happens.--- See also Note [coreView vs tcView]-tcView :: Type -> Maybe Type-tcView (TyConApp tc tys)-  | res@(Just _) <- expandSynTyConApp_maybe tc tys-  = res-tcView _ = Nothing--- See Note [Inlining coreView].-{-# INLINE tcView #-}--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@.------ This function does not look through type family applications.------ By being non-recursive and inlined, this case analysis gets efficiently--- joined onto the case analysis that the caller is already doing-coreView ty@(TyConApp tc tys)-  | res@(Just _) <- expandSynTyConApp_maybe tc tys-  = res--  -- At the Core level, Constraint = Type-  -- See Note [coreView vs tcView]-  | isConstraintKindCon tc-  = assertPpr (null tys) (ppr ty) $-    Just liftedTypeKind--coreView _ = Nothing--- See Note [Inlining coreView].-{-# INLINE coreView #-}----------------------------------------------------- | @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 allocat ion Just/Nothing in the result--- Don't be tempted to make `expand_syn` (which is NOINLIN) return the--- Just/Nothing, else you'll increase allocation-expandSynTyConApp_maybe tc arg_tys-  | Just (tvs, rhs) <- synTyConDefn_maybe tc-  , arg_tys `lengthAtLeast` (tyConArity tc)-  = Just (expand_syn tvs rhs arg_tys)-  | otherwise-  = Nothing---- | 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 = mkEmptyTCvSubst in_scope-    in_scope = mkInScopeSet $ shallowTyCoVarsOfTypes $ arg_tys-      -- The free vars of 'rhs' should all be bound by 'tenv',-      -- so we only need the free vars of tys-      -- See also Note [The substitution invariant] in GHC.Core.TyCo.Subst.--    go subst [] tys-      | null tys  = rhs'  -- Exactly Saturated-      | otherwise = mkAppTys rhs' tys-          -- Its important to use mkAppTys, rather than (foldl AppTy),-          -- because the function part might well return a-          -- partially-applied type constructor; indeed, usually will!-      where-        rhs' = substTy subst rhs--    go subst (tv:tvs) (ty:tys) = go (extendTvSubst subst tv ty) tvs tys--    go _ (_:_) [] = pprPanic "expand_syn" (ppr tvs $$ ppr rhs $$ ppr arg_tys)-                   -- Under-saturated, precondition failed----coreFullView :: Type -> Type--- ^ Iterates 'coreView' until there is no more to synonym to expand.--- See Note [Inlining coreView].-coreFullView ty@(TyConApp tc _)-  | isTypeSynonymTyCon tc || isConstraintKindCon tc = go ty-  where-    go ty-      | Just ty' <- coreView ty = go ty'-      | otherwise = ty--coreFullView ty = ty-{-# INLINE coreFullView #-}--{- 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 :: 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-            -- (#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 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 w co1 co2)-      = mkFunCo r (go_co subst w) (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 r n co)-      = mkNthCo r 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 subst (AxiomRuleCo ax cs)-      = AxiomRuleCo ax (map (go_co subst) cs)-    go_co _ (HoleCo h)-      = pprPanic "expandTypeSynonyms hit a hole" (ppr h)--    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 _     p@(CorePrepProv _)  = p--      -- the "False" and "const" are to accommodate the type of-      -- substForAllCoBndrUsing, which is general enough to-      -- handle coercion optimization (which sometimes swaps the-      -- order of a coercion)-    go_cobndr subst = substForAllCoBndrUsing False (go_co subst) subst---- | 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-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 -> Type-kindRep k = case kindRep_maybe k of-              Just r  -> r-              Nothing -> pprPanic "kindRep" (ppr k)---- | Given a kind (TYPE rr), extract its RuntimeRep classifier rr.--- For example, @kindRep_maybe * = Just LiftedRep@--- Returns 'Nothing' if the kind is not of form (TYPE rr)--- Treats * and Constraint as the same-kindRep_maybe :: HasDebugCallStack => Kind -> Maybe Type-kindRep_maybe kind-  | Just [arg] <- isTyConKeyApp_maybe tYPETyConKey kind = Just arg-  | otherwise                                           = Nothing---- | Returns True if the kind classifies types which are allocated on--- the GC'd heap and False otherwise. Note that this returns False for--- representation-polymorphic kinds, which may be specialized to a kind that--- classifies AddrRep or even unboxed kinds.-isBoxedTypeKind :: Kind -> Bool-isBoxedTypeKind kind-  = case kindRep_maybe kind of-      Just rep -> isBoxedRuntimeRep rep-      Nothing  -> False---- | This version considers Constraint to be the same as *. Returns True--- if the argument is equivalent to Type/Constraint and False otherwise.--- See Note [Kind Constraint and kind Type]-isLiftedTypeKind :: Kind -> Bool-isLiftedTypeKind kind-  = case kindRep_maybe kind of-      Just rep -> isLiftedRuntimeRep 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---- | 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---- | See 'isBoxedRuntimeRep_maybe'.-isBoxedRuntimeRep :: Type -> 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 :: Type -> Maybe Type-isBoxedRuntimeRep_maybe rep-  | Just [lev] <- isTyConKeyApp_maybe boxedRepDataConKey rep-  = Just lev-  | otherwise-  = Nothing---- | Check whether a type of kind 'RuntimeRep' is lifted, unlifted, or unknown.------ @isLiftedRuntimeRep rr@ returns:------   * @Just Lifted@ if @rr@ is @LiftedRep :: RuntimeRep@---   * @Just Unlifted@ if @rr@ is definitely unlifted, e.g. @IntRep@---   * @Nothing@ if not known (e.g. it's a type variable or a type family application).-runtimeRepLevity_maybe :: Type -> Maybe Levity-runtimeRepLevity_maybe rep-  | TyConApp rr_tc args <- coreFullView rep-  , isPromotedDataCon rr_tc =-      -- NB: args might be non-empty e.g. TupleRep [r1, .., rn]-      if (rr_tc `hasKey` boxedRepDataConKey)-        then case args of-          [lev] | isLiftedLevity   lev -> Just Lifted-                | isUnliftedLevity lev -> Just Unlifted-          _                            -> Nothing-        else Just Unlifted-        -- Avoid searching all the unlifted RuntimeRep type cons-        -- In the RuntimeRep data type, only LiftedRep is lifted-        -- But be careful of type families (F tys) :: RuntimeRep,-        -- hence the isPromotedDataCon rr_tc-runtimeRepLevity_maybe _ = 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 :: Type -> Bool-isLiftedRuntimeRep rep =-  runtimeRepLevity_maybe rep == Just Lifted---- | Check whether a type of kind 'RuntimeRep' is unlifted.------  * True of definitely unlifted 'RuntimeRep's such as---    'UnliftedRep', 'IntRep', 'FloatRep', ...---  * False of 'LiftedRep',---  * False for type variables and type family applications.-isUnliftedRuntimeRep :: Type -> Bool-isUnliftedRuntimeRep rep =-  runtimeRepLevity_maybe rep == Just Unlifted---- | An INLINE helper for functions such as 'isLiftedLevity' and 'isUnliftedLevity'.------ Checks whether the type is a nullary 'TyCon' application,--- for a 'TyCon' with the given 'Unique'.-isNullaryTyConKeyApp :: Unique -> Type -> Bool-isNullaryTyConKeyApp key ty-  | Just args <- isTyConKeyApp_maybe key ty-  = assert (null args) True-  | 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--{- *********************************************************************-*                                                                      *-               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 [Forall coercions] 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 :: env -> TyCoVar -> ArgFlag -> m (env, TyCoVar)-          -- ^ 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 :: 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-    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 { (env', tv') <- tycobinder env tv vis-           ; inner' <- go_ty env' inner-           ; return $ ForAllTy (Bndr tv' vis) inner' }--    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 (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 cw c1 c2)   = mkFunCo r <$> 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 p r t1 t2)  = mkUnivCo <$> go_prov env p <*> 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 (AxiomRuleCo r cos) = AxiomRuleCo r <$> go_cos env cos-    go_co env (NthCo r i co)      = mkNthCo r 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 (AxiomInstCo ax i cos) = mkAxiomInstCo ax i <$> go_cos env cos-    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 tv kind_co co)-      = do { kind_co' <- go_co env kind_co-           ; (env', tv') <- tycobinder env tv Inferred-           ; co' <- go_co env' co-           ; return $ mkForAllCo tv' kind_co' co' }-        -- See Note [Efficiency for ForAllCo case of mapTyCoX]--    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@(CorePrepProv _)  = return p---{--************************************************************************-*                                                                      *-\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 = repGetTyVar_maybe . coreFullView---- | 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---- | 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 (#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 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 = repSplitAppTy_maybe . coreFullView----------------repSplitAppTy_maybe :: HasDebugCallStack => 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 _ w ty1 ty2)-  = Just (TyConApp funTyCon [w, rep1, rep2, ty1], ty2)-  where-    rep1 = getRuntimeRep ty1-    rep2 = getRuntimeRep ty2--repSplitAppTy_maybe (AppTy ty1 ty2)-  = Just (ty1, ty2)--repSplitAppTy_maybe (TyConApp tc tys)-  | not (mustBeSaturated 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 break 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 { ft_af = af, ft_mult = w, ft_arg = ty1, ft_res = ty2 })-  | VisArg <- af   -- See Note [Decomposing fat arrow c=>t]--  -- See Note [The Purely Kinded Type Invariant (PKTI)] in GHC.Tc.Gen.HsType,-  -- Wrinkle around FunTy-  , Just rep1 <- getRuntimeRep_maybe ty1-  , Just rep2 <- getRuntimeRep_maybe ty2-  = Just (TyConApp funTyCon [w, rep1, rep2, ty1], ty2)--  | otherwise-  = Nothing--tcRepSplitAppTy_maybe (AppTy ty1 ty2)    = Just (ty1, ty2)-tcRepSplitAppTy_maybe (TyConApp tc tys)-  | not (mustBeSaturated 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----------------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 | mustBeSaturated tc = tyConArity tc-              | otherwise          = 0-            (tc_args1, tc_args2) = splitAt n tc_args-        in-        (TyConApp tc tc_args1, tc_args2 ++ args)-    split _   (FunTy _ w ty1 ty2) args-      = assert (null args )-        (TyConApp funTyCon [], [w, 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 :: HasDebugCallStack => 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 | mustBeSaturated tc = tyConArity tc-              | otherwise          = 0-            (tc_args1, tc_args2) = splitAt n tc_args-        in-        (TyConApp tc tc_args1, tc_args2 ++ args)-    split (FunTy _ w ty1 ty2) args-      = assert (null args )-        (TyConApp funTyCon [], [w, 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-  | 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---- | 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 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.--}--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 = expectJust "splitFunTy" . splitFunTy_maybe--{-# INLINE splitFunTy_maybe #-}-splitFunTy_maybe :: Type -> Maybe (Mult, Type, Type)--- ^ Attempts to extract the multiplicity, argument and result types from a type-splitFunTy_maybe ty-  | FunTy _ w arg res <- coreFullView ty = Just (w, 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 :: 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 :: 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 = mkEmptyTCvSubst $ 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 tv _) res <- ty-  = go (extendTCvSubst init_subst tv arg) res args--  | Just ty' <- coreView ty-  = piResultTys ty' orig_args--  | otherwise-  = pprPanic "piResultTys1" (ppr ty $$ ppr orig_args)-  where-    init_subst = mkEmptyTCvSubst $ mkInScopeSet (tyCoVarsOfTypes (ty:orig_args))--    go :: TCvSubst -> 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 :: [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-  = 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 {})      = Just funTyCon-tyConAppTyConPicky_maybe _               = Nothing----- | The same as @fst . splitTyConApp@-{-# INLINE tyConAppTyCon_maybe #-}-tyConAppTyCon_maybe :: Type -> Maybe TyCon-tyConAppTyCon_maybe ty = case coreFullView ty of-  TyConApp tc _ -> Just tc-  FunTy {}      -> Just funTyCon-  _             -> 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 coreFullView ty of-  TyConApp _ tys -> Just tys-  FunTy _ w arg res-    | Just rep1 <- getRuntimeRep_maybe arg-    , Just rep2 <- getRuntimeRep_maybe res-    -> Just [w, rep1, rep2, arg, res]-  _ -> Nothing--tyConAppArgs :: HasCallStack => 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 -> 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 = repSplitTyConApp_maybe . coreFullView---- | 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.------ This does *not* split types headed with (=>), as that's not a TyCon in the--- type-checker.------ 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'-                         | otherwise             = tcRepSplitTyConApp_maybe ty----------------------repSplitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type])--- ^ Like 'splitTyConApp_maybe', but doesn't look through synonyms. This--- assumes the synonyms have already been dealt with.-repSplitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys)-repSplitTyConApp_maybe (FunTy _ w arg res)-  -- NB: we're in Core, so no check for VisArg-  = Just (funTyCon, [w, arg_rep, res_rep, arg, res])-  where-    arg_rep = getRuntimeRep arg-    res_rep = getRuntimeRep res-repSplitTyConApp_maybe _ = Nothing--tcRepSplitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type])--- ^ Like 'tcSplitTyConApp_maybe', but doesn't look through synonyms. This--- assumes the synonyms have already been dealt with.------ Moreover, for a FunTy, it only succeeds if the argument types--- have enough info to extract the runtime-rep arguments that--- the funTyCon requires.  This will usually be true;--- but may be temporarily false during canonicalization:---     see Note [Decomposing FunTy] in GHC.Tc.Solver.Canonical---     and Note [The Purely Kinded Type Invariant (PKTI)] in GHC.Tc.Gen.HsType,---         Wrinkle around FunTy-tcRepSplitTyConApp_maybe (TyConApp tc tys) = Just (tc, tys)-tcRepSplitTyConApp_maybe (FunTy VisArg w arg res)-  -- NB: VisArg. See Note [Decomposing fat arrow c=>t]-  | Just arg_rep <- getRuntimeRep_maybe arg-  , Just res_rep <- getRuntimeRep_maybe res-  = Just (funTyCon, [w, arg_rep, res_rep, arg, res])-tcRepSplitTyConApp_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--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-                           ~~~~~~-A casted type has its *kind* casted into something new.--}--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 = mkEmptyTCvSubst (mkInScopeSet fvs)-                 (subst, tv') = substVarBndr empty_subst tv-             in ForAllTy (Bndr tv' vis) (substTy subst inner_ty `mk_cast_ty` co)-        else ForAllTy (Bndr tv vis) (inner_ty `mk_cast_ty` co)--    go _ = CastTy orig_ty co -- NB: orig_ty: preserve synonyms if possible--{--Note [Using coreView in mk_cast_ty]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Invariants (EQ3) and (EQ4) of Note [Respecting definitional equality] in-GHC.Core.TyCo.Rep must apply regardless of type synonyms. For instance,-consider this example (#19742):--   type EqSameNat = () |> co-   useNatEq :: EqSameNat |> sym co--(Those casts aren't visible in the user-source code, of course; see #19742 for-what the user might write.)--The type `EqSameNat |> sym co` looks as if it satisfies (EQ3), as it has no-nested casts, but if we expand EqSameNat, we see that it doesn't.-And then Bad Things happen.--The solution is easy: just use `coreView` when establishing (EQ3) and (EQ4) in-`mk_cast_ty`.--}--tyConBindersTyCoBinders :: [TyConBinder] -> [TyCoBinder]--- Return the tyConBinders in TyCoBinder form-tyConBindersTyCoBinders = map to_tyb-  where-    to_tyb (Bndr tv (NamedTCB vis)) = Named (Bndr tv vis)-    to_tyb (Bndr tv (AnonTCB af))   = Anon af (tymult (varType tv))---- | (mkTyConTy tc) returns (TyConApp tc [])--- but arranges to share that TyConApp among all calls--- See Note [Sharing nullary TyConApps] in GHC.Core.TyCon-mkTyConTy :: TyCon -> Type-mkTyConTy tycon = tyConNullaryTy tycon---- | 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)-  | key == funTyConKey-  = case tys of-      [w, _rep1,_rep2,arg,res] -> FunTy { ft_af = VisArg, ft_mult = w-                                        , ft_arg = arg, ft_res = res }-      _ -> bale_out--  -- See Note [Using synonyms to compress types]-  | key == tYPETyConKey-  = assert (null rest) $---    mkTYPEapp_maybe ty1 `orElse` bale_out-    case mkTYPEapp_maybe ty1 of-      Just ty -> ty -- pprTrace "mkTYPEapp:yes" (ppr ty) ty-      Nothing -> bale_out -- pprTrace "mkTYPEapp:no" (ppr bale_out) bale_out--  -- See Note [Using synonyms to compress types]-  | key == boxedRepDataConTyConKey-  = assert (null rest) $---     mkBoxedRepApp_maybe ty1 `orElse` bale_out-    case mkBoxedRepApp_maybe ty1 of-      Just ty -> ty -- pprTrace "mkBoxedRepApp:yes" (ppr ty) ty-      Nothing -> bale_out -- pprTrace "mkBoxedRepApp:no" (ppr bale_out) bale_out--  | key == tupleRepDataConTyConKey-  = case mkTupleRepApp_maybe ty1 of-      Just ty -> ty -- pprTrace "mkTupleRepApp:yes" (ppr ty) ty-      Nothing -> bale_out -- pprTrace "mkTupleRepApp:no" (ppr bale_out) bale_out--  -- The catch-all case-  | otherwise-  = bale_out-  where-    key = tyConUnique tycon-    bale_out = TyConApp tycon tys--mkTYPEapp :: Type -> Type-mkTYPEapp rr-  = case mkTYPEapp_maybe rr of-       Just ty -> ty-       Nothing -> TyConApp tYPETyCon [rr]--mkTYPEapp_maybe :: Type -> Maybe Type--- ^ Given a @RuntimeRep@, applies @TYPE@ to it.--- On the fly it rewrites---      TYPE LiftedRep      -->   liftedTypeKind    (a synonym)---      TYPE UnliftedRep    -->   unliftedTypeKind  (ditto)---      TYPE ZeroBitRep     -->   zeroBitTypeKind   (ditto)--- NB: no need to check for TYPE (BoxedRep Lifted), TYPE (BoxedRep Unlifted)---     because those inner types should already have been rewritten---     to LiftedRep and UnliftedRep respectively, by mkTyConApp------ see Note [TYPE and RuntimeRep] in GHC.Builtin.Types.Prim.--- See Note [Using synonyms to compress types] in GHC.Core.Type-{-# NOINLINE mkTYPEapp_maybe #-}-mkTYPEapp_maybe (TyConApp tc args)-  | key == liftedRepTyConKey    = assert (null args) $ Just liftedTypeKind   -- TYPE LiftedRep-  | key == unliftedRepTyConKey  = assert (null args) $ Just unliftedTypeKind -- TYPE UnliftedRep-  | key == zeroBitRepTyConKey   = assert (null args) $ Just zeroBitTypeKind  -- TYPE ZeroBitRep-  where-    key = tyConUnique tc-mkTYPEapp_maybe _ = Nothing--mkBoxedRepApp_maybe :: Type -> Maybe Type--- ^ Given a `Levity`, apply `BoxedRep` to it--- On the fly, rewrite---      BoxedRep Lifted     -->   liftedRepTy    (a synonym)---      BoxedRep Unlifted   -->   unliftedRepTy  (ditto)--- See Note [TYPE and RuntimeRep] in GHC.Builtin.Types.Prim.--- See Note [Using synonyms to compress types] in GHC.Core.Type-{-# NOINLINE mkBoxedRepApp_maybe #-}-mkBoxedRepApp_maybe (TyConApp tc args)-  | key == liftedDataConKey   = assert (null args) $ Just liftedRepTy    -- BoxedRep Lifted-  | key == unliftedDataConKey = assert (null args) $ Just unliftedRepTy  -- BoxedRep Unlifted-  where-    key = tyConUnique tc-mkBoxedRepApp_maybe _ = Nothing--mkTupleRepApp_maybe :: Type -> Maybe Type--- ^ Given a `[RuntimeRep]`, apply `TupleRep` to it--- On the fly, rewrite---      TupleRep [] -> zeroBitRepTy   (a synonym)--- See Note [TYPE and RuntimeRep] in GHC.Builtin.Types.Prim.--- See Note [Using synonyms to compress types] in GHC.Core.Type-{-# NOINLINE mkTupleRepApp_maybe #-}-mkTupleRepApp_maybe (TyConApp tc args)-  | key == nilDataConKey = assert (isSingleton args) $ Just zeroBitRepTy  -- ZeroBitRep-  where-    key = tyConUnique tc-mkTupleRepApp_maybe _ = Nothing--{- Note [Using synonyms to compress types]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Was: Prefer Type over TYPE (BoxedRep Lifted)]--The Core of nearly any program will have numerous occurrences of the Types--   TyConApp BoxedRep [TyConApp Lifted []]    -- Synonym LiftedRep-   TyConApp BoxedRep [TyConApp Unlifted []]  -- Synonym UnliftedREp-   TyConApp TYPE [TyConApp LiftedRep []]     -- Synonym Type-   TyConApp TYPE [TyConApp UnliftedRep []]   -- Synonym UnliftedType--While investigating #17292 we found that these constituted a majority-of all TyConApp constructors on the heap:--    (From a sample of 100000 TyConApp closures)-    0x45f3523    - 28732 - `Type`-    0x420b840702 - 9629  - generic type constructors-    0x42055b7e46 - 9596-    0x420559b582 - 9511-    0x420bb15a1e - 9509-    0x420b86c6ba - 9501-    0x42055bac1e - 9496-    0x45e68fd    - 538   - `TYPE ...`--Consequently, we try hard to ensure that operations on such types are-efficient. Specifically, we strive to-- a. Avoid heap allocation of such types; 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 []@), Note [Comparing-nullary type synonyms] in "GHC.Core.Type".--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--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.--}----{-----------------------------------------------------------------------                            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 GHC.Tc.Gen.Bind.-------------------------------------------------------------------------                                ForAllTy-                                ~~~~~~~~--}---- | Make a dependent forall over an 'Inferred' variable-mkTyCoInvForAllTy :: TyCoVar -> Type -> Type-mkTyCoInvForAllTy tv ty-  | isCoVar tv-  , not (tv `elemVarSet` tyCoVarsOfType ty)-  = mkVisFunTyMany (varType tv) ty-  | otherwise-  = ForAllTy (Bndr 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 TyCoBinders, 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 VisArg) : binders-                , fvs `unionVarSet` kind_vars )-      where-        (binders, fvs) = go vs-        kind_vars      = tyCoVarsOfType $ tyVarKind v---- | 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)---- | Splits the longest initial sequence of 'ForAllTy's that satisfy--- @argf_pred@, returning the binders transformed by @argf_pred@-splitSomeForAllTyCoVarBndrs :: (ArgFlag -> Maybe af) -> Type -> ([VarBndr TyCoVar af], Type)-splitSomeForAllTyCoVarBndrs argf_pred ty = split ty ty []-  where-    split _ (ForAllTy (Bndr tcv argf) ty) tvs-      | Just argf' <- argf_pred argf               = split ty ty (Bndr tcv argf' : 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 '()'.-splitForAllReqTVBinders :: Type -> ([ReqTVBinder], Type)-splitForAllReqTVBinders ty = splitSomeForAllTyCoVarBndrs argf_pred ty-  where-    argf_pred :: ArgFlag -> Maybe ()-    argf_pred Required       = Just ()-    argf_pred (Invisible {}) = Nothing---- | Like 'splitForAllTyCoVars', but only splits 'ForAllTy's with 'Invisible' type--- variable binders. Furthermore, each returned tyvar is annotated with its--- 'Specificity'.-splitForAllInvisTVBinders :: Type -> ([InvisTVBinder], Type)-splitForAllInvisTVBinders ty = splitSomeForAllTyCoVarBndrs argf_pred ty-  where-    argf_pred :: ArgFlag -> Maybe Specificity-    argf_pred Required         = Nothing-    argf_pred (Invisible spec) = Just spec---- | 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)---- | 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 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?-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 forall type apart, but only if it's a proper forall,--- with a named binder-splitForAllTyCoVar_maybe :: Type -> Maybe (TyCoVar, Type)-splitForAllTyCoVar_maybe ty-  | ForAllTy (Bndr tv _) inner_ty <- coreFullView ty = Just (tv, inner_ty)-  | otherwise                                        = Nothing---- | Like 'splitForAllTyCoVar_maybe', but only returns Just if it is a tyvar binder.-splitForAllTyVar_maybe :: Type -> Maybe (TyCoVar, 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 (TyCoVar, 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 (TyCoBinder, 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 af (mkScaled w arg), res)-  _                -> Nothing---- | Takes a forall type apart, or panics-splitPiTy :: Type -> (TyCoBinder, Type)-splitPiTy ty-  | Just answer <- splitPiTy_maybe ty = answer-  | otherwise                         = pprPanic "splitPiTy" (ppr ty)---- | Split off all TyCoBinders to a type, splitting both proper foralls--- and functions-splitPiTys :: Type -> ([TyCoBinder], 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 af (Scaled w arg) : bs)-    split orig_ty ty bs | Just ty' <- coreView ty = split orig_ty ty' bs-    split orig_ty _                bs = (reverse bs, orig_ty)---- | Extracts a list of run-time arguments from a function type,--- looking through newtypes to the right of arrows.------ Examples:------ @---    newtype Identity a = I a------    getRuntimeArgTys (Int -> Bool -> Double) == [(Int, VisArg), (Bool, VisArg)]---    getRuntimeArgTys (Identity Int -> Bool -> Double) == [(Identity Int, VisArg), (Bool, VisArg)]---    getRuntimeArgTys (Int -> Identity (Bool -> Identity Double)) == [(Int, VisArg), (Bool, VisArg)]---    getRuntimeArgTys (forall a. Show a => Identity a -> a -> Int -> Bool) == [(Show a, InvisArg), (Identity a, VisArg),(a, VisArg),(Int, VisArg)]--- @------ Note that, in the last case, the returned types might mention an out-of-scope--- type variable. This function is used only when we really care about the /kinds/--- of the returned types, so this is OK.------ **Warning**: this function can return an infinite list. For example:------ @---   newtype N a = MkN (a -> N a)---   getRuntimeArgTys (N a) == repeat (a, VisArg)--- @-getRuntimeArgTys :: Type -> [(Type, AnonArgFlag)]-getRuntimeArgTys = go-  where-    go :: Type -> [(Type, AnonArgFlag)]-    go (ForAllTy _ res)-      = go res-    go (FunTy { ft_arg = arg, ft_res = res, ft_af = af })-      = (arg, af) : go res-    go ty-      | Just ty' <- coreView ty-      = go ty'-      | Just (_,ty') <- topNormaliseNewType_maybe ty-      = go ty'-      | otherwise-      = []---- | Like 'splitPiTys' but split off only /named/ binders---   and returns 'TyCoVarBinder's rather than 'TyCoBinder's-splitForAllTyCoVarBinders :: Type -> ([TyCoVarBinder], Type)-splitForAllTyCoVarBinders 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)-{-# INLINE splitForAllTyCoVarBinders #-}--invisibleTyBndrCount :: 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-invisibleTyBndrCount ty = length (fst (splitInvisPiTys ty))---- | Like 'splitPiTys', but returns only *invisible* binders, including constraints.--- Stops at the first visible binder.-splitInvisPiTys :: Type -> ([TyCoBinder], Type)-splitInvisPiTys ty = split ty ty []-   where-    split _ (ForAllTy b res) bs-      | Bndr _ vis <- b-      , isInvisibleArgFlag vis   = split res res (Named b  : bs)-    split _ (FunTy { ft_af = InvisArg, ft_mult = mult, ft_arg = arg, ft_res = res })  bs-                                 = split res res (Anon InvisArg (mkScaled mult arg) : 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 -> ([TyCoBinder], Type)--- ^ Same as 'splitInvisPiTys', but stop when---   - you have found @n@ 'TyCoBinder'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-      , isInvisibleArgFlag vis  = split (n-1) res res (Named b  : bs)-      | FunTy { ft_af = InvisArg, ft_mult = mult, ft_arg = arg, ft_res = res } <- ty-                                = split (n-1) res res (Anon InvisArg (Scaled mult arg) : 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) $ tyConArgFlags 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 isInvisibleArgFlag $ tyConArgFlags tc tys) tys---- | Given a list of things paired with their visibilities, partition the--- things into (invisible things, visible things).-partitionInvisibles :: [(a, ArgFlag)] -> ([a], [a])-partitionInvisibles = partitionWith pick_invis-  where-    pick_invis :: (a, ArgFlag) -> Either a a-    pick_invis (thing, vis) | isInvisibleArgFlag 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--- > tyConArgFlags 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.-tyConArgFlags :: TyCon -> [Type] -> [ArgFlag]-tyConArgFlags 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 'appTyArgFlags' comes in handy,--- since @f Type Bool@ would be represented in Core using 'AppTy's.--- (See also #15792).-appTyArgFlags :: Type -> [Type] -> [ArgFlag]-appTyArgFlags 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] -> [ArgFlag]-fun_kind_arg_flags = go emptyTCvSubst-  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 ArgFlags:-    ---    -- [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 = case af of-                 VisArg   -> Required-                 InvisArg -> 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 af w a b)    = case af of-                                InvisArg -> False                               -- e.g., Eq a => b-                                VisArg   -> 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--{--%************************************************************************-%*                                                                      *-   TyCoBinders-%*                                                                      *-%************************************************************************--}---- | Make an anonymous binder-mkAnonBinder :: AnonArgFlag -> Scaled Type -> TyCoBinder-mkAnonBinder = Anon---- | Does this binder bind a variable that is /not/ erased? Returns--- 'True' for anonymous binders.-isAnonTyCoBinder :: TyCoBinder -> Bool-isAnonTyCoBinder (Named {}) = False-isAnonTyCoBinder (Anon {})  = True--tyCoBinderVar_maybe :: TyCoBinder -> Maybe TyCoVar-tyCoBinderVar_maybe (Named tv) = Just $ binderVar tv-tyCoBinderVar_maybe _          = Nothing--tyCoBinderType :: TyCoBinder -> Type-tyCoBinderType (Named tvb) = binderType tvb-tyCoBinderType (Anon _ ty)   = scaledThing ty--tyBinderType :: TyBinder -> Type-tyBinderType (Named (Bndr tv _))-  = assert (isTyVar tv )-    tyVarKind tv-tyBinderType (Anon _ ty)   = scaledThing ty---- | Extract a relevant type, if there is one.-binderRelevantType_maybe :: TyCoBinder -> Maybe Type-binderRelevantType_maybe (Named {}) = Nothing-binderRelevantType_maybe (Anon _ ty)  = Just (scaledThing ty)--{--************************************************************************-*                                                                      *-\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---- | 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"-isCoVarType :: Type -> Bool-  -- ToDo: should we check saturation?-isCoVarType ty-  | Just tc <- tyConAppTyCon_maybe ty-  = tc `hasKey` eqPrimTyConKey || tc `hasKey` eqReprPrimTyConKey-  | otherwise-  = False--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-  where-    is_tau       = isTauTy rhs-    is_fam_free  = isFamFreeTy rhs-    is_forgetful = any (not . (`elemVarSet` tyCoVarsOfType rhs) . binderVar) binders ||-                   uniqSetAny isForgetfulSynTyCon (tyConsOfType rhs)-         -- NB: This is allowed to be conservative, returning True more often-         -- than it should. See comments on GHC.Core.TyCon.isForgetfulSynTyCon--{--************************************************************************-*                                                                      *-\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)---- | 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.-        -- They are pretty bogus types, mind you.  It would be better never to-        -- construct them-isUnliftedType ty =-  case typeLevity_maybe ty of-    Just Lifted   -> False-    Just Unlifted -> True-    Nothing       ->-      pprPanic "isUnliftedType" (ppr ty <+> dcolon <+> ppr (typeKind ty))---- | State token type.-isStateType :: Type -> Bool-isStateType ty-  = case tyConAppTyCon_maybe ty of-        Just tycon -> tycon == statePrimTyCon-        _          -> False---- | Returns:------ * 'False' if the type is /guaranteed/ unlifted or--- * 'True' if it lifted, OR we aren't sure---    (e.g. in a representation-polymorphic case)-mightBeLiftedType :: Type -> Bool-mightBeLiftedType = mightBeLifted . typeLevity_maybe---- | Returns:------ * 'False' if the type is /guaranteed/ lifted or--- * 'True' if it is unlifted, OR we aren't sure---    (e.g. in a representation-polymorphic case)-mightBeUnliftedType :: Type -> Bool-mightBeUnliftedType = mightBeUnlifted . typeLevity_maybe---- | 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 Type-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 -> Type-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-  , Just (tc, [lev]) <- splitTyConApp_maybe rep-  , tc == boxedRepDataConTyCon-  = Just lev-  | otherwise-  = Nothing---- | Extract the 'Levity' of a type. For example, @getLevity Int = Lifted@,--- or @getLevity (Array# Int) = Unlifted@.------ Panics if this is not possible. Does not look through type family applications.-getLevity :: HasDebugCallStack => Type -> Type-getLevity ty-  | Just lev <- getLevity_maybe ty-  = lev-  | otherwise-  = pprPanic "getLevity" (ppr ty <+> dcolon <+> ppr (typeKind ty))--isUnboxedTupleType :: Type -> Bool-isUnboxedTupleType ty-  = tyConAppTyCon (getRuntimeRep ty) `hasKey` tupleRepDataConKey-  -- 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---- | 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 representation-polymorphic types.-isStrictType :: HasDebugCallStack => Type -> Bool-isStrictType = isUnliftedType--isPrimitiveType :: Type -> Bool--- ^ Returns true of types that are opaque to Haskell.-isPrimitiveType ty = case splitTyConApp_maybe ty of-                        Just (tc, ty_args) -> assert (ty_args `lengthIs` tyConArity tc )-                                              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--{--************************************************************************-*                                                                      *-                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.--Note [Comparing nullary type synonyms]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider the task of testing equality between two 'Type's of the form--  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 equal.--We perform this optimisation in a number of places:-- * GHC.Core.Types.eqType- * GHC.Core.Types.nonDetCmpType- * GHC.Core.Unify.unify_ty- * TcCanonical.can_eq_nc'- * TcUnify.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.---}--eqType :: Type -> Type -> Bool--- ^ Type equality on source types. Does not look through @newtypes@,--- 'PredType's or type families, but it does look through type synonyms.--- This first checks that the kinds of the types are equal and then--- checks whether the types are equal, ignoring casts and coercions.--- (The kind check is a recursive call, but since all kinds have type--- @Type@, there is no need to check the types of kinds.)--- See also Note [Non-trivial definitional equality] in "GHC.Core.TyCo.Rep".-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 (varType tv1) (varType 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.--Note [Computing equality on types]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-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 also Note [Non-trivial definitional equality] in GHC.Core.TyCo.Rep.---}--nonDetCmpType :: Type -> Type -> Ordering-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]))-{-# INLINE nonDetCmpType #-}--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 GHC.Core.TyCo.Rep-    -- See Note [Computing equality on types]-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-    -- See Note [Comparing nullary type synonyms].-    go _   (TyConApp tc1 []) (TyConApp tc2 [])-      | tc1 == tc2-      = TEQ-    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 _) t1) (ForAllTy (Bndr tv2 _) t2)-      = 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) <- 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 _ 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 `thenCmp` 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----------------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 'Constraint' (as--- recognized by Kind.isConstraintKindCon) which is considered a synonym for--- 'Type' in Core.--- See Note [Kind Constraint and kind Type] in "GHC.Core.Type".--- See Note [nonDetCmpType nondeterminism]-nonDetCmpTc :: TyCon -> TyCon -> Ordering-nonDetCmpTc tc1 tc2-  = assert (not (isConstraintKindCon tc1) && not (isConstraintKindCon tc2)) $-    u1 `nonDetCmpUnique` u2-  where-    u1  = tyConUnique tc1-    u2  = tyConUnique tc2--{--************************************************************************-*                                                                      *-        The kind of a type-*                                                                      *-************************************************************************--Note [typeKind vs tcTypeKind]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We have two functions to get the kind of a type--  * typeKind   ignores  the distinction between Constraint and *-  * tcTypeKind respects the distinction between Constraint and *--tcTypeKind is used by the type inference engine, for which Constraint-and * are different; after that we use typeKind.--See also Note [coreView vs tcView]--Note [Kinding rules for types]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In typeKind we consider Constraint and (TYPE LiftedRep) to be identical.-We then have--         t1 : TYPE rep1-         t2 : TYPE rep2-   (FUN) -----------------         t1 -> t2 : Type--         ty : TYPE rep-         `a` is not free in rep-(FORALL) ------------------------         forall a. ty : TYPE rep--In tcTypeKind we consider Constraint and (TYPE LiftedRep) to be distinct:--          t1 : TYPE rep1-          t2 : TYPE rep2-    (FUN) -----------------          t1 -> t2 : Type--          t1 : Constraint-          t2 : TYPE rep-  (PRED1) -----------------          t1 => t2 : Type--          t1 : Constraint-          t2 : Constraint-  (PRED2) ----------------------          t1 => t2 : Constraint--          ty : TYPE rep-          `a` is not free in rep-(FORALL1) ------------------------          forall a. ty : TYPE rep--          ty : Constraint-(FORALL2) --------------------------          forall a. ty : Constraint--Note that:-* The only way we distinguish '->' from '=>' is by the fact-  that the argument is a PredTy.  Both are FunTys--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) exapands-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 {})        = liftedTypeKind-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 {})-  = case occCheckExpand tvs body_kind of-      -- We must make sure tv does not occur in kind-      -- As it is already out of scope!-      -- See Note [Phantom type variables in kinds]-      Just k' -> k'-      Nothing -> pprPanic "typeKind"-                  (ppr ty $$ ppr tvs $$ ppr body <+> dcolon <+> ppr body_kind)-  where-    (tvs, body) = splitForAllTyVars ty-    body_kind   = typeKind body-------------------------------------------------- Utilities to be used in GHC.Core.Unify,--- which uses "tc" functions------------------------------------------------tcTypeKind :: HasDebugCallStack => Type -> Kind--- No need to expand synonyms-tcTypeKind (TyConApp tc tys) = piResultTys (tyConKind tc) tys-tcTypeKind (LitTy l)         = typeLiteralKind l-tcTypeKind (TyVarTy tyvar)   = tyVarKind tyvar-tcTypeKind (CastTy _ty co)   = coercionRKind co-tcTypeKind (CoercionTy co)   = coercionType co--tcTypeKind (FunTy { ft_af = af, ft_res = res })-  | InvisArg <- af-  , tcIsConstraintKind (tcTypeKind res)-  = constraintKind     -- Eq a => Ord a         :: Constraint-  | otherwise          -- Eq a => a -> a        :: TYPE LiftedRep-  = liftedTypeKind     -- Eq a => Array# Int    :: Type LiftedRep (not TYPE PtrRep)--tcTypeKind (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 (tcTypeKind fun) args--tcTypeKind ty@(ForAllTy {})-  | tcIsConstraintKind body_kind-  = constraintKind--  | otherwise-  = case occCheckExpand tvs body_kind of-      -- We must make sure tv does not occur in kind-      -- As it is already out of scope!-      -- See Note [Phantom type variables in kinds]-      Just k' -> k'-      Nothing -> pprPanic "tcTypeKind"-                  (ppr ty $$ ppr tvs $$ ppr body <+> dcolon <+> ppr body_kind)-  where-    (tvs, body) = splitForAllTyVars ty-    body_kind = tcTypeKind body---isPredTy :: HasDebugCallStack => Type -> Bool--- See Note [Types for coercions, predicates, and evidence] in GHC.Core.TyCo.Rep-isPredTy ty = tcIsConstraintKind (tcTypeKind ty)---- tcIsConstraintKind stuff only makes sense in the typechecker--- After that Constraint = Type--- See Note [coreView vs tcView]--- Defined here because it is used in isPredTy and tcRepSplitAppTy_maybe (sigh)-tcIsConstraintKind :: Kind -> Bool-tcIsConstraintKind ty-  | Just (tc, args) <- tcSplitTyConApp_maybe ty    -- Note: tcSplit here-  , isConstraintKindCon tc-  = assertPpr (null args) (ppr ty) True--  | otherwise-  = False---- | Like 'kindRep_maybe', but considers 'Constraint' to be distinct--- from 'Type'. For a version that treats them as the same type, see--- 'kindRep_maybe'.-tcKindRep_maybe :: HasDebugCallStack => Kind -> Maybe Type-tcKindRep_maybe kind-  | Just (tc, [arg]) <- tcSplitTyConApp_maybe kind    -- Note: tcSplit here-  , tc `hasKey` tYPETyConKey    = Just arg-  | otherwise                   = Nothing---- | Is this kind equivalent to 'Type'?------ This considers 'Constraint' to be distinct from 'Type'. For a version that--- treats them as the same type, see 'isLiftedTypeKind'.-tcIsLiftedTypeKind :: Kind -> Bool-tcIsLiftedTypeKind kind-  = case tcKindRep_maybe kind of-      Just rep -> isLiftedRuntimeRep rep-      Nothing  -> False---- | Is this kind equivalent to @TYPE (BoxedRep l)@ for some @l :: Levity@?------ This considers 'Constraint' to be distinct from 'Type'. For a version that--- treats them as the same type, see 'isLiftedTypeKind'.-tcIsBoxedTypeKind :: Kind -> Bool-tcIsBoxedTypeKind kind-  = case tcKindRep_maybe kind of-      Just rep -> isBoxedRuntimeRep rep-      Nothing  -> False---- | Is this kind equivalent to @TYPE r@ (for some unknown r)?------ This considers 'Constraint' to be distinct from @*@.-tcIsRuntimeTypeKind :: Kind -> Bool-tcIsRuntimeTypeKind kind = isJust (tcKindRep_maybe kind)--tcReturnsConstraintKind :: Kind -> Bool--- True <=> the Kind ultimately returns a Constraint---   E.g.  * -> Constraint---         forall k. k -> Constraint-tcReturnsConstraintKind kind-  | Just kind' <- tcView kind = tcReturnsConstraintKind kind'-tcReturnsConstraintKind (ForAllTy _ ty)         = tcReturnsConstraintKind ty-tcReturnsConstraintKind (FunTy { ft_res = ty }) = tcReturnsConstraintKind ty-tcReturnsConstraintKind (TyConApp tc _)         = isConstraintKindCon tc-tcReturnsConstraintKind _                       = False-----------------------------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 :: 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)---- | Looking past all pi-types, does the end result have a--- fixed runtime rep, as per Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete?------ Examples:------   * False for @(forall r (a :: TYPE r). String -> a)@---   * True for @(forall r1 r2 (a :: TYPE r1) (b :: TYPE r2). a -> b -> Type)@-resultHasFixedRuntimeRep :: Type -> Bool-resultHasFixedRuntimeRep = typeHasFixedRuntimeRep . snd . splitPiTys--{- **********************************************************************-*                                                                       *-           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 (mkAppTy 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 (mkTyConApp tc tys')-          Nothing | Just ty' <- tcView 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 (mkCastTy ty' co') }-    go cxt (CoercionTy co) = do { co' <- go_co cxt co-                                ; return (mkCoercionTy 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 (mkNomReflCo ty') }-    go_co cxt (GRefl r ty mco)          = do { mco' <- go_mco cxt mco-                                             ; ty' <- go cxt ty-                                             ; return (mkGReflCo 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 (mkTyConAppCo r tc args') }-    go_co cxt (AppCo co arg)            = do { co' <- go_co cxt co-                                             ; arg' <- go_co cxt arg-                                             ; return (mkAppCo co' arg') }-    go_co cxt@(as, env) (ForAllCo tv kind_co 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 (ForAllCo tv' kind_co' body') }-    go_co cxt (FunCo r w co1 co2)       = do { co1' <- go_co cxt co1-                                             ; co2' <- go_co cxt co2-                                             ; w' <- go_co cxt w-                                             ; return (mkFunCo r w' co1' co2') }-    go_co (as,env) co@(CoVarCo c)-      | Just c' <- lookupVarEnv env c   = return (mkCoVarCo 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 (AxiomInstCo ax ind args) = do { args' <- mapM (go_co cxt) args-                                             ; return (mkAxiomInstCo ax ind args') }-    go_co cxt (UnivCo p r ty1 ty2)      = do { p' <- go_prov cxt p-                                             ; ty1' <- go cxt ty1-                                             ; ty2' <- go cxt ty2-                                             ; return (mkUnivCo p' r ty1' ty2') }-    go_co cxt (SymCo co)                = do { co' <- go_co cxt co-                                             ; return (mkSymCo co') }-    go_co cxt (TransCo co1 co2)         = do { co1' <- go_co cxt co1-                                             ; co2' <- go_co cxt co2-                                             ; return (mkTransCo co1' co2') }-    go_co cxt (NthCo r n co)            = do { co' <- go_co cxt co-                                             ; return (mkNthCo r n co') }-    go_co cxt (LRCo lr co)              = do { co' <- go_co cxt co-                                             ; return (mkLRCo lr co') }-    go_co cxt (InstCo co arg)           = do { co' <- go_co cxt co-                                             ; arg' <- go_co cxt arg-                                             ; return (mkInstCo co' arg') }-    go_co cxt (KindCo co)               = do { co' <- go_co cxt co-                                             ; return (mkKindCo co') }-    go_co cxt (SubCo co)                = do { co' <- go_co cxt co-                                             ; return (mkSubCo co') }-    go_co cxt (AxiomRuleCo ax cs)       = do { cs' <- mapM (go_co cxt) cs-                                             ; return (mkAxiomRuleCo ax cs') }--    -------------------    go_prov cxt (PhantomProv co)    = PhantomProv <$> go_co cxt co-    go_prov cxt (ProofIrrelProv co) = ProofIrrelProv <$> go_co cxt co-    go_prov _   p@(PluginProv _)    = return p-    go_prov _   p@(CorePrepProv _)  = return p---{--%************************************************************************-%*                                                                      *-        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 _ w a b)             = go w `unionUniqSets`-                                      go a `unionUniqSets` go b `unionUniqSets` go_tc funTyCon-     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 _ kind_co co) = go_co kind_co `unionUniqSets` go_co co-     go_co (FunCo _ co_mult co1 co2) = go_co co_mult `unionUniqSets` 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 (HoleCo {})             = 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 (KindCo co)             = go_co co-     go_co (SubCo co)              = go_co co-     go_co (AxiomRuleCo _ cs)      = go_cos cs--     go_mco MRefl    = emptyUniqSet-     go_mco (MCo co) = go_co co--     go_prov (PhantomProv co)    = go_co co-     go_prov (ProofIrrelProv co) = go_co co-     go_prov (PluginProv _)      = emptyUniqSet-     go_prov (CorePrepProv _)    = 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---- | 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 _ 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--splitVisVarsOfTypes :: [Type] -> Pair TyCoVarSet-splitVisVarsOfTypes = foldMap splitVisVarsOfType--{--************************************************************************-*                                                                      *-        Functions over Kinds-*                                                                      *-************************************************************************--Note [Kind Constraint and kind Type]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-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 Type. 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 Type.-See #7451.--Because we treat Constraint/Type differently during and after type inference,-GHC has two notions of equality that differ in whether they equate-Constraint/Type or not:--* GHC.Tc.Utils.TcType.tcEqType implements typechecker equality (see-  Note [Typechecker equality vs definitional equality] in GHC.Tc.Utils.TcType),-  which treats Constraint and Type as distinct. This is used during type-  inference. See #11715 for issues that arise from this.-* GHC.Core.TyCo.Rep.eqType implements definitional equality (see-  Note [Non-trivial definitional equality] in GHC.Core.TyCo.Rep), which treats-  Constraint and Type as equal. This is used after type inference.--Bottom line: although 'Type' and 'Constraint' are distinct TyCons, with-distinct uniques, they are treated as equal at all times except-during type inference.--}---- | Checks that a kind of the form 'Type', 'Constraint'--- or @'TYPE r@ is concrete. See 'isConcrete'.------ __Precondition:__ The type has kind @('TYPE' blah)@.-isFixedRuntimeRepKind :: HasDebugCallStack => Kind -> Bool-isFixedRuntimeRepKind k-  = assertPpr (isLiftedTypeKind k || _is_type) (ppr k) $-    -- the isLiftedTypeKind check is necessary b/c of Constraint-    isConcrete k-  where-    _is_type = classifiesTypeWithValues 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.-isConcrete :: Type -> Bool-isConcrete = go-  where-    go ty | Just ty' <- coreView ty = go ty'-    go (TyVarTy tv)        = isConcreteTyVar tv-    go (AppTy ty1 ty2)     = go ty1 && go ty2-    go (TyConApp tc tys)-      | isConcreteTyCon tc = all go tys-      | otherwise          = False-    go ForAllTy{}          = False-    go (FunTy _ w t1 t2)   =  go w-                           && go (typeKind t1) && go t1-                           && go (typeKind t2) && go t2-    go LitTy{}             = True-    go CastTy{}            = False-    go CoercionTy{}        = False---------------------------------------------- | Does this classify a type allowed to have values? Responds True to things--- like *, TYPE Lifted, TYPE IntRep, TYPE v, Constraint.-classifiesTypeWithValues :: Kind -> Bool--- ^ True of any sub-kind of OpenTypeKind-classifiesTypeWithValues k = isJust (kindRep_maybe k)--{--%************************************************************************-%*                                                                      *-         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 VisArg -> 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-wavey, 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 parametrized 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 Many---- | Scale a payload by One-linear = Scaled One---- | Scale a payload by Many; used for type arguments in core-tymult = Scaled Many--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 One :: Mult-pattern One <- (isOneDataConTy -> True)-  where One = oneDataConTy--pattern Many :: Mult-pattern Many <- (isManyDataConTy -> True)-  where Many = manyDataConTy--isManyDataConTy :: Mult -> Bool-isManyDataConTy ty-  | Just tc <- tyConAppTyCon_maybe ty-  = tc `hasKey` manyDataConKey-isManyDataConTy _ = False--isOneDataConTy :: Mult -> Bool-isOneDataConTy ty-  | Just tc <- tyConAppTyCon_maybe ty-  = tc `hasKey` oneDataConKey-isOneDataConTy _ = 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 _ Many _ res -> isLinearType res-                      FunTy _ _ _ _ -> True-                      ForAllTy _ res -> isLinearType res-                      _ -> False+{-# LANGUAGE FlexibleContexts, PatternSynonyms, ViewPatterns, MultiWayIf, RankNTypes #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++-- | Main functions for manipulating types and type-related things+module GHC.Core.Type (+        -- Note some of this is just re-exports from TyCon..++        -- * Main data types representing Types+        -- $type_classification++        -- $representation_types+        Type, ForAllTyFlag(..), FunTyFlag(..),+        Specificity(..),+        KindOrType, PredType, ThetaType, FRRType,+        Var, TyVar, isTyVar, TyCoVar, PiTyBinder, ForAllTyBinder, TyVarBinder,+        Mult, Scaled,+        KnotTied, RuntimeRepType,++        -- ** Constructing and deconstructing types+        mkTyVarTy, mkTyVarTys, getTyVar, getTyVar_maybe, repGetTyVar_maybe,+        getCastedTyVar_maybe, tyVarKind, varType,++        mkAppTy, mkAppTys, splitAppTy, splitAppTys, splitAppTysNoView,+        splitAppTy_maybe, splitAppTyNoView_maybe, tcSplitAppTyNoView_maybe,++        mkFunTy, mkVisFunTy,+        mkVisFunTyMany, mkVisFunTysMany,+        mkScaledFunTys,+        mkInvisFunTy, mkInvisFunTys,+        tcMkVisFunTy, tcMkScaledFunTys, tcMkInvisFunTy,+        splitFunTy, splitFunTy_maybe, splitVisibleFunTy_maybe,+        splitFunTys, funResultTy, funArgTy,+        funTyConAppTy_maybe, funTyFlagTyCon,+        tyConAppFunTy_maybe, tyConAppFunCo_maybe,+        mkFunctionType, mkScaledFunctionTys, chooseFunTyFlag,++        mkTyConApp, mkTyConTy,+        tyConAppTyCon_maybe, tyConAppTyConPicky_maybe,+        tyConAppArgs_maybe, tyConAppTyCon, tyConAppArgs,++        splitTyConApp_maybe, splitTyConAppNoView_maybe, splitTyConApp,+        tcSplitTyConApp, tcSplitTyConApp_maybe,++        mkForAllTy, mkForAllTys, mkInvisForAllTys, mkTyCoInvForAllTys,+        mkSpecForAllTy, mkSpecForAllTys,+        mkVisForAllTys, mkTyCoForAllTy, mkTyCoForAllTys, mkTyCoInvForAllTy,+        mkInfForAllTy, mkInfForAllTys,+        splitForAllTyCoVars, splitForAllTyVars,+        splitForAllReqTyBinders, splitForAllInvisTyBinders,+        splitForAllForAllTyBinders, splitForAllForAllTyBinder_maybe,+        splitForAllTyCoVar_maybe, splitForAllTyCoVar,+        splitForAllTyVar_maybe, splitForAllCoVar_maybe,+        splitPiTy_maybe, splitPiTy, splitPiTys, collectPiTyBinders,+        getRuntimeArgTys,+        mkTyConBindersPreferAnon,+        mkPiTy, mkPiTys,+        piResultTy, piResultTys,+        applyTysX, dropForAlls,+        mkFamilyTyConApp,+        buildSynTyCon,++        mkNumLitTy, isNumLitTy,+        mkStrLitTy, isStrLitTy,+        mkCharLitTy, isCharLitTy,+        isLitTy,++        getRuntimeRep, splitRuntimeRep_maybe, kindRep_maybe, kindRep,+        getLevity, levityType_maybe,++        mkCastTy, mkCoercionTy, splitCastTy_maybe,++        ErrorMsgType,+        userTypeError_maybe, deepUserTypeError_maybe, pprUserTypeErrorTy,++        coAxNthLHS,+        stripCoercionTy,++        splitInvisPiTys, splitInvisPiTysN, invisibleBndrCount,+        filterOutInvisibleTypes, filterOutInferredTypes,+        partitionInvisibleTypes, partitionInvisibles,+        tyConForAllTyFlags, appTyForAllTyFlags,++        -- ** Analyzing types+        TyCoMapper(..), mapTyCo, mapTyCoX,+        TyCoFolder(..), foldTyCo, noView,++        -- (Newtypes)+        newTyConInstRhs,++        -- ** Binders+        mkForAllTyBinder, mkForAllTyBinders,+        mkTyVarBinder, mkTyVarBinders,+        tyVarSpecToBinders,+        isAnonPiTyBinder,+        binderVar, binderVars, binderType, binderFlag, binderFlags,+        piTyBinderType, namedPiTyBinder_maybe,+        anonPiTyBinderType_maybe,+        isVisibleForAllTyFlag, isInvisibleForAllTyFlag, isVisiblePiTyBinder,+        isInvisiblePiTyBinder, isNamedPiTyBinder,+        tyConBindersPiTyBinders,++        -- ** Predicates on types+        isTyVarTy, isFunTy, isCoercionTy,+        isCoercionTy_maybe, isForAllTy,+        isForAllTy_ty, isForAllTy_co,+        isForAllTy_invis_ty,+        isPiTy, isTauTy, isFamFreeTy,+        isAtomicTy,++        isValidJoinPointType,+        tyConAppNeedsKindSig,++        -- * Space-saving construction+        mkTYPEapp, mkTYPEapp_maybe,+        mkCONSTRAINTapp, mkCONSTRAINTapp_maybe,+        mkBoxedRepApp_maybe, mkTupleRepApp_maybe,+        typeOrConstraintKind, liftedTypeOrConstraintKind,++        -- *** Levity and boxity+        sORTKind_maybe, typeTypeOrConstraint,+        typeLevity, typeLevity_maybe, tyConIsTYPEorCONSTRAINT,+        isLiftedTypeKind, isUnliftedTypeKind, pickyIsLiftedTypeKind,+        isLiftedRuntimeRep, isUnliftedRuntimeRep, runtimeRepLevity_maybe,+        isBoxedRuntimeRep,+        isLiftedLevity, isUnliftedLevity,+        isUnliftedType, isBoxedType, isUnboxedTupleType, isUnboxedSumType,+        kindBoxedRepLevity_maybe,+        mightBeLiftedType, mightBeUnliftedType,+        definitelyLiftedType, definitelyUnliftedType,+        isAlgType, isDataFamilyApp, isSatTyFamApp,+        isPrimitiveType, isStrictType, isTerminatingType,+        isLevityTy, isLevityVar,+        isRuntimeRepTy, isRuntimeRepVar, isRuntimeRepKindedTy,+        dropRuntimeRepArgs,++        -- * Multiplicity++        isMultiplicityTy, isMultiplicityVar,+        unrestricted, linear, tymult,+        mkScaled, irrelevantMult, scaledSet,+        pattern OneTy, pattern ManyTy,+        isOneTy, isManyTy,+        isLinearType,++        -- * Main data types representing Kinds+        Kind,++        -- ** Finding the kind of a type+        typeKind, typeHasFixedRuntimeRep,+        tcIsLiftedTypeKind,+        isConstraintKind, isConstraintLikeKind, returnsConstraintKind,+        tcIsBoxedTypeKind, isTypeLikeKind,++        -- ** Common Kind+        liftedTypeKind, unliftedTypeKind,++        -- * Type free variables+        tyCoFVsOfType, tyCoFVsBndr, tyCoFVsVarBndr, tyCoFVsVarBndrs,+        tyCoVarsOfType, tyCoVarsOfTypes,+        tyCoVarsOfTypeDSet,+        coVarsOfType,+        coVarsOfTypes,++        anyFreeVarsOfType, anyFreeVarsOfTypes,+        noFreeVarsOfType,+        expandTypeSynonyms, expandSynTyConApp_maybe,+        typeSize, occCheckExpand,++        -- ** Closing over kinds+        closeOverKindsDSet, closeOverKindsList,+        closeOverKinds,++        -- * Forcing evaluation of types+        seqType, seqTypes,++        -- * Other views onto Types+        coreView, coreFullView, rewriterView,++        tyConsOfType,++        -- * Main type substitution data types+        TvSubstEnv,     -- Representation widely visible+        IdSubstEnv,+        Subst(..),    -- Representation visible to a few friends++        -- ** Manipulating type substitutions+        emptyTvSubstEnv, emptySubst, mkEmptySubst,++        mkTCvSubst, zipTvSubst, mkTvSubstPrs,+        zipTCvSubst,+        notElemSubst,+        getTvSubstEnv,+        zapSubst, substInScopeSet, setInScope, getSubstRangeTyCoFVs,+        extendSubstInScope, extendSubstInScopeList, extendSubstInScopeSet,+        extendTCvSubst, extendCvSubst,+        extendTvSubst, extendTvSubstList, extendTvSubstAndInScope,+        extendTCvSubstList,+        extendTvSubstWithClone,+        extendTCvSubstWithClone,+        isInScope, composeTCvSubst, zipTyEnv, zipCoEnv,+        isEmptySubst, unionSubst, isEmptyTCvSubst,++        -- ** Performing substitution on types and kinds+        substTy, substTys, substScaledTy, substScaledTys, substTyWith, substTysWith, substTheta,+        substTyAddInScope,+        substTyUnchecked, substTysUnchecked, substScaledTyUnchecked, substScaledTysUnchecked,+        substThetaUnchecked, substTyWithUnchecked,+        substCo, substCoUnchecked, substCoWithUnchecked,+        substTyVarBndr, substTyVarBndrs, substTyVar, substTyVars,+        substVarBndr, substVarBndrs,+        substTyCoBndr, substTyVarToTyVar,+        cloneTyVarBndr, cloneTyVarBndrs, lookupTyVar,++        -- * Kinds+        isTYPEorCONSTRAINT,+        isConcreteType,+        isFixedRuntimeRepKind+    ) where++import GHC.Prelude++import GHC.Types.Basic++-- We import the representation and primitive functions from GHC.Core.TyCo.Rep.+-- Many things are reexported, but not the representation!++import GHC.Core.TyCo.Rep+import GHC.Core.TyCo.Subst+import GHC.Core.TyCo.FVs++-- friends:+import GHC.Types.Var+import GHC.Types.Var.Env+import GHC.Types.Var.Set++import GHC.Core.TyCon+import GHC.Builtin.Types.Prim++import {-# SOURCE #-} GHC.Builtin.Types+   ( charTy, naturalTy+   , typeSymbolKind, liftedTypeKind, unliftedTypeKind+   , constraintKind, zeroBitTypeKind+   , manyDataConTy, oneDataConTy+   , liftedRepTy, unliftedRepTy, zeroBitRepTy )++import GHC.Types.Name( Name )+import GHC.Builtin.Names+import GHC.Core.Coercion.Axiom++import {-# SOURCE #-} GHC.Core.Coercion+   ( mkNomReflCo, mkGReflCo, mkReflCo+   , mkTyConAppCo, mkAppCo+   , mkForAllCo, mkFunCo2, mkAxiomCo, mkUnivCo+   , mkSymCo, mkTransCo, mkSelCo, mkLRCo, mkInstCo+   , mkKindCo, mkSubCo, mkFunCo, funRole+   , decomposePiCos, coercionKind+   , coercionRKind, coercionType+   , isReflexiveCo, seqCo+   , topNormaliseNewType_maybe+   )+import {-# SOURCE #-} GHC.Tc.Utils.TcType ( isConcreteTyVar )++-- others+import GHC.Utils.Misc+import GHC.Utils.FV+import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Data.FastString++import GHC.Data.Maybe   ( orElse, isJust, firstJust )+import GHC.List (build)++-- $type_classification+-- #type_classification#+--+-- Types are any, but at least one, of:+--+-- [Boxed]              Iff its representation is a pointer to an object on the+--                      GC'd heap. Operationally, heap objects can be entered as+--                      a means of evaluation.+--+-- [Lifted]             Iff it has bottom as an element: An instance of a+--                      lifted type might diverge when evaluated.+--                      GHC Haskell's unboxed types are unlifted.+--                      An unboxed, but lifted type is not very useful.+--                      (Example: A byte-represented type, where evaluating 0xff+--                      computes the 12345678th collatz number modulo 0xff.)+--                      Only lifted types may be unified with a type variable.+--+-- [Algebraic]          Iff it is a type with one or more constructors, whether+--                      declared with @data@ or @newtype@.+--                      An algebraic type is one that can be deconstructed+--                      with a case expression. There are algebraic types that+--                      are not lifted types, like unlifted data types or+--                      unboxed tuples.+--+-- [Data]               Iff it is a type declared with @data@, or a boxed tuple.+--                      There are also /unlifted/ data types.+--+-- [Primitive]          Iff it is a built-in type that can't be expressed in Haskell.+--+-- [Unlifted]           Anything that isn't lifted is considered unlifted.+--+-- Currently, all primitive types are unlifted, but that's not necessarily+-- the case: for example, @Int@ could be primitive.+--+-- Some primitive types are unboxed, such as @Int#@, whereas some are boxed+-- but unlifted (such as @ByteArray#@).  The only primitive types that we+-- classify as algebraic are the unboxed tuples.+--+-- Some examples of type classifications that may make this a bit clearer are:+--+-- @+-- Type          primitive       boxed           lifted          algebraic+-- -----------------------------------------------------------------------------+-- Int#          Yes             No              No              No+-- ByteArray#    Yes             Yes             No              No+-- (\# a, b \#)  Yes             No              No              Yes+-- (\# a | b \#) Yes             No              No              Yes+-- (  a, b  )    No              Yes             Yes             Yes+-- [a]           No              Yes             Yes             Yes+-- @++-- $representation_types+-- A /source type/ is a type that is a separate type as far as the type checker is+-- concerned, but which has a more low-level representation as far as Core-to-Core+-- passes and the rest of the back end is concerned.+--+-- You don't normally have to worry about this, as the utility functions in+-- this module will automatically convert a source into a representation type+-- if they are spotted, to the best of its abilities. If you don't want this+-- to happen, use the equivalent functions from the "TcType" module.++{-+************************************************************************+*                                                                      *+                Type representation+*                                                                      *+************************************************************************+-}++rewriterView :: Type -> Maybe Type+-- Unwrap a type synonym only when either:+--   The type synonym is forgetful, or+--   the type synonym mentions a type family in its expansion+-- See Note [Rewriting synonyms]+{-# INLINE rewriterView #-}+rewriterView (TyConApp tc tys)+  | isTypeSynonymTyCon tc+  , isForgetfulSynTyCon tc || not (isFamFreeTyCon tc)+  = expandSynTyConApp_maybe tc tys+rewriterView _other+  = Nothing++coreView :: Type -> Maybe Type+-- ^ This function strips off the /top layer only/ of a type synonym+-- application (if any) its underlying representation type.+-- Returns 'Nothing' if there is nothing to look through.+--+-- This function does not look through type family applications.+--+-- By being non-recursive and inlined, this case analysis gets efficiently+-- joined onto the case analysis that the caller is already doing+coreView (TyConApp tc tys) = expandSynTyConApp_maybe tc tys+coreView _                 = Nothing+-- See Note [Inlining coreView].+{-# INLINE coreView #-}++coreFullView, core_full_view :: Type -> Type+-- ^ Iterates 'coreView' until there is no more to synonym to expand.+-- NB: coreFullView is non-recursive and can be inlined;+--     core_full_view is the recursive one+-- See Note [Inlining coreView].+coreFullView ty@(TyConApp tc _)+  | isTypeSynonymTyCon tc = core_full_view ty+coreFullView ty = ty+{-# INLINE coreFullView #-}++core_full_view ty+  | Just ty' <- coreView ty = core_full_view ty'+  | otherwise               = ty++-----------------------------------------------+-- | @expandSynTyConApp_maybe tc tys@ expands the RHS of type synonym @tc@+-- instantiated at arguments @tys@, or returns 'Nothing' if @tc@ is not a+-- synonym.+expandSynTyConApp_maybe :: TyCon -> [Type] -> Maybe Type+{-# INLINE expandSynTyConApp_maybe #-}+-- This INLINE will inline the call to expandSynTyConApp_maybe in coreView,+-- which will eliminate the allocation Just/Nothing in the result+-- Don't be tempted to make `expand_syn` (which is NOINLINE) return the+-- Just/Nothing, else you'll increase allocation+expandSynTyConApp_maybe tc arg_tys+  | Just (tvs, rhs) <- synTyConDefn_maybe tc+  , arg_tys `saturates` tyConArity tc+  = Just $! (expand_syn tvs rhs arg_tys)+    -- Why strict application? Because every client of this function will evaluat+    -- that (expand_syn ...) thunk, so it's more efficient not to build a thunk.+    -- Mind you, this function is always INLINEd, so the client context is probably+    -- enough to avoid thunk construction and so the $! is just belt-and-braces.+  | otherwise+  = Nothing++saturates :: [Type] -> Arity -> Bool+saturates _       0 = True+saturates []      _ = False+saturates (_:tys) n = assert( n >= 0 ) $ saturates tys (n-1)+                       -- Arities are always positive; the assertion just checks+                       -- that, to avoid an infinite loop in the bad case++-- | A helper for 'expandSynTyConApp_maybe' to avoid inlining this cold path+-- into call-sites.+--+-- Precondition: the call is saturated or over-saturated;+--               i.e. length tvs <= length arg_tys+expand_syn :: [TyVar]  -- ^ the variables bound by the synonym+           -> Type     -- ^ the RHS of the synonym+           -> [Type]   -- ^ the type arguments the synonym is instantiated at.+           -> Type+{-# NOINLINE expand_syn #-} -- We never want to inline this cold-path.++expand_syn tvs rhs arg_tys+  -- No substitution necessary if either tvs or tys is empty+  -- This is both more efficient, and steers clear of an infinite+  -- loop; see Note [Care using synonyms to compress types]+  | null arg_tys  = assert (null tvs) rhs+  | null tvs      = mkAppTys rhs arg_tys+  | otherwise     = go empty_subst tvs arg_tys+  where+    empty_subst = mkEmptySubst in_scope+    in_scope = mkInScopeSet $ shallowTyCoVarsOfTypes $ arg_tys+      -- The free vars of 'rhs' should all be bound by 'tenv',+      -- so we only need the free vars of tys+      -- See also Note [The substitution invariant] in GHC.Core.TyCo.Subst.++    go subst [] tys+      | null tys  = rhs'  -- Exactly Saturated+      | otherwise = mkAppTys rhs' tys+          -- Its important to use mkAppTys, rather than (foldl AppTy),+          -- because the function part might well return a+          -- partially-applied type constructor; indeed, usually will!+      where+        rhs' = substTy subst rhs++    go subst (tv:tvs) (ty:tys) = go (extendTvSubst subst tv ty) tvs tys++    go _ (_:_) [] = pprPanic "expand_syn" (ppr tvs $$ ppr rhs $$ ppr arg_tys)+                   -- Under-saturated, precondition failed++{- Note [Inlining coreView]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+It is very common to have a function++  f :: Type -> ...+  f ty | Just ty' <- coreView ty = f ty'+  f (TyVarTy ...) = ...+  f ...           = ...++If f is not otherwise recursive, the initial call to coreView+causes f to become recursive, which kills the possibility of+inlining. Instead, for non-recursive functions, we prefer to+use coreFullView, which guarantees to unwrap top-level type+synonyms. It can be inlined and is efficient and non-allocating+in its fast path. For this to really be fast, all calls made+on its fast path must also be inlined, linked back to this Note.+-}+++{- *********************************************************************+*                                                                      *+                expandTypeSynonyms+*                                                                      *+********************************************************************* -}++expandTypeSynonyms :: Type -> Type+-- ^ Expand out all type synonyms.  Actually, it'd suffice to expand out+-- just the ones that discard type variables (e.g.  type Funny a = Int)+-- But we don't know which those are currently, so we just expand all.+--+-- 'expandTypeSynonyms' only expands out type synonyms mentioned in the type,+-- not in the kinds of any TyCon or TyVar mentioned in the type.+--+-- Keep this synchronized with 'synonymTyConsOfType'+expandTypeSynonyms ty+  = go (mkEmptySubst in_scope) ty+  where+    in_scope = mkInScopeSet (tyCoVarsOfType ty)++    go subst (TyConApp tc tys)+      | ExpandsSyn tenv rhs tys' <- expandSynTyCon_maybe tc expanded_tys+      = let subst' = mkTvSubst in_scope (mkVarEnv tenv)+            -- Make a fresh substitution; rhs has nothing to+            -- do with anything that has happened so far+            -- NB: if you make changes here, be sure to build an+            --     /idempotent/ substitution, even in the nested case+            --        type T a b = a -> b+            --        type S x y = T y x+            -- (#11665)+        in  mkAppTys (go subst' rhs) tys'+      | otherwise+      = TyConApp tc expanded_tys+      where+        expanded_tys = (map (go subst) tys)++    go _     (LitTy l)     = LitTy l+    go subst (TyVarTy tv)  = substTyVar subst tv+    go subst (AppTy t1 t2) = mkAppTy (go subst t1) (go subst t2)+    go subst ty@(FunTy _ mult arg res)+      = ty { ft_mult = go subst mult, ft_arg = go subst arg, ft_res = go subst res }+    go subst (ForAllTy (Bndr tv vis) t)+      = let (subst', tv') = substVarBndrUsing go subst tv in+        ForAllTy (Bndr tv' vis) (go subst' t)+    go subst (CastTy ty co)  = mkCastTy (go subst ty) (go_co subst co)+    go subst (CoercionTy co) = mkCoercionTy (go_co subst co)++    go_mco _     MRefl    = MRefl+    go_mco subst (MCo co) = MCo (go_co subst co)++    go_co subst (Refl ty)+      = mkNomReflCo (go subst ty)+    go_co subst (GRefl r ty mco)+      = mkGReflCo r (go subst ty) (go_mco subst mco)+       -- NB: coercions are always expanded upon creation+    go_co subst (TyConAppCo r tc args)+      = mkTyConAppCo r tc (map (go_co subst) args)+    go_co subst (AppCo co arg)+      = mkAppCo (go_co subst co) (go_co subst arg)+    go_co subst (ForAllCo { fco_tcv = tv, fco_visL = visL, fco_visR = visR+                          , fco_kind = kind_co, fco_body = co })+      = let (subst', tv', kind_co') = go_cobndr subst tv kind_co in+        mkForAllCo tv' visL visR kind_co' (go_co subst' co)+    go_co subst (FunCo r afl afr w co1 co2)+      = mkFunCo2 r afl afr (go_co subst w) (go_co subst co1) (go_co subst co2)+    go_co subst (CoVarCo cv)+      = substCoVar subst cv+    go_co subst (AxiomCo ax cs)+      = mkAxiomCo ax (map (go_co subst) cs)+    go_co subst co@(UnivCo { uco_lty = lty, uco_rty = rty })+      = co { uco_lty = go subst lty, uco_rty = go subst rty }+    go_co subst (SymCo co)+      = mkSymCo (go_co subst co)+    go_co subst (TransCo co1 co2)+      = mkTransCo (go_co subst co1) (go_co subst co2)+    go_co subst (SelCo n co)+      = mkSelCo n (go_co subst co)+    go_co subst (LRCo lr co)+      = mkLRCo lr (go_co subst co)+    go_co subst (InstCo co arg)+      = mkInstCo (go_co subst co) (go_co subst arg)+    go_co subst (KindCo co)+      = mkKindCo (go_co subst co)+    go_co subst (SubCo co)+      = mkSubCo (go_co subst co)+    go_co _ (HoleCo h)+      = pprPanic "expandTypeSynonyms hit a hole" (ppr h)++    go_cobndr subst = substForAllCoBndrUsing (go_co subst) subst++{- Notes on type synonyms+~~~~~~~~~~~~~~~~~~~~~~~~~+The various "split" functions (splitFunTy, splitRhoTy, splitForAllTy) try+to return type synonyms wherever possible. Thus++        type Foo a = a -> a++we want+        splitFunTys (a -> Foo a) = ([a], Foo a)+not                                ([a], a -> a)++The reason is that we then get better (shorter) type signatures in+interfaces.  Notably this plays a role in tcTySigs in GHC.Tc.Gen.Bind.+-}++{- *********************************************************************+*                                                                      *+                Random functions (todo: organise)+*                                                                      *+********************************************************************* -}++-- | An INLINE helper for function such as 'kindRep_maybe' below.+--+-- @isTyConKeyApp_maybe key ty@ returns @Just tys@ iff+-- the type @ty = T tys@, where T's unique = key+-- key must not be `fUNTyConKey`; to test for functions, use `splitFunTy_maybe`.+-- Thanks to this fact, we don't have to pattern match on `FunTy` here.+isTyConKeyApp_maybe :: Unique -> Type -> Maybe [Type]+isTyConKeyApp_maybe key ty+  | TyConApp tc args <- coreFullView ty+  , tc `hasKey` key+  = Just args+  | otherwise+  = Nothing+{-# INLINE isTyConKeyApp_maybe #-}++-- | Extract the RuntimeRep classifier of a type from its kind. For example,+-- @kindRep * = LiftedRep@; Panics if this is not possible.+-- Treats * and Constraint as the same+kindRep :: HasDebugCallStack => Kind -> RuntimeRepType+kindRep k = case kindRep_maybe k of+              Just r  -> r+              Nothing -> pprPanic "kindRep" (ppr k)++-- | Given a kind (TYPE rr) or (CONSTRAINT rr), extract its RuntimeRep classifier rr.+-- For example, @kindRep_maybe * = Just LiftedRep@+-- Returns 'Nothing' if the kind is not of form (TYPE rr)+kindRep_maybe :: HasDebugCallStack => Kind -> Maybe RuntimeRepType+kindRep_maybe kind+  | Just (_, rep) <- sORTKind_maybe kind = Just rep+  | otherwise                            = Nothing++-- | Returns True if the argument is (lifted) Type or Constraint+-- See Note [TYPE and CONSTRAINT] in GHC.Builtin.Types.Prim+isLiftedTypeKind :: Kind -> Bool+isLiftedTypeKind kind+  = case kindRep_maybe kind of+      Just rep -> isLiftedRuntimeRep rep+      Nothing  -> False++-- | Returns True if the kind classifies unlifted types (like 'Int#') and False+-- otherwise. Note that this returns False for representation-polymorphic+-- kinds, which may be specialized to a kind that classifies unlifted types.+isUnliftedTypeKind :: Kind -> Bool+isUnliftedTypeKind kind+  = case kindRep_maybe kind of+      Just rep -> isUnliftedRuntimeRep rep+      Nothing  -> False++pickyIsLiftedTypeKind :: Kind -> Bool+-- Checks whether the kind is literally+--      TYPE LiftedRep+-- or   TYPE ('BoxedRep 'Lifted)+-- or   Type+-- without expanding type synonyms or anything+-- Used only when deciding whether to suppress the ":: *" in+-- (a :: *) when printing kinded type variables+-- See Note [Suppressing * kinds] in GHC.Core.TyCo.Ppr+pickyIsLiftedTypeKind kind+  | TyConApp tc [arg] <- kind+  , tc `hasKey` tYPETyConKey+  , TyConApp rr_tc rr_args <- arg = case rr_args of+      [] -> rr_tc `hasKey` liftedRepTyConKey+      [rr_arg]+        | rr_tc `hasKey` boxedRepDataConKey+        , TyConApp lev [] <- rr_arg+        , lev `hasKey` liftedDataConKey -> True+      _ -> False+  | TyConApp tc [] <- kind+  , tc `hasKey` liftedTypeKindTyConKey = True+  | otherwise                          = False++-- | Check whether a kind is of the form `TYPE (BoxedRep Lifted)`+-- or `TYPE (BoxedRep Unlifted)`.+--+-- Returns:+--+--  - `Just Lifted` for `TYPE (BoxedRep Lifted)` and `Type`,+--  - `Just Unlifted` for `TYPE (BoxedRep Unlifted)` and `UnliftedType`,+--  - `Nothing` for anything else, e.g. `TYPE IntRep`, `TYPE (BoxedRep l)`, etc.+kindBoxedRepLevity_maybe :: Type -> Maybe Levity+kindBoxedRepLevity_maybe ty+  | Just rep <- kindRep_maybe ty+  , isBoxedRuntimeRep rep+  = runtimeRepLevity_maybe rep+  | otherwise+  = Nothing++-- | Check whether a type of kind 'RuntimeRep' is lifted.+--+-- 'isLiftedRuntimeRep' is:+--+--  * True of @LiftedRep :: RuntimeRep@+--  * False of type variables, type family applications,+--    and of other reps such as @IntRep :: RuntimeRep@.+isLiftedRuntimeRep :: RuntimeRepType -> Bool+isLiftedRuntimeRep rep+  = runtimeRepLevity_maybe rep == Just Lifted++-- | Check whether a type of kind 'RuntimeRep' is unlifted.+--+--  * True of definitely unlifted 'RuntimeRep's such as+--    'UnliftedRep', 'IntRep', 'FloatRep', ...+--  * False of 'LiftedRep',+--  * False for type variables and type family applications.+isUnliftedRuntimeRep :: RuntimeRepType -> Bool+isUnliftedRuntimeRep rep =+  runtimeRepLevity_maybe rep == Just Unlifted++-- | An INLINE helper for functions such as 'isLiftedLevity' and 'isUnliftedLevity'.+--+-- Checks whether the type is a nullary 'TyCon' application,+-- for a 'TyCon' with the given 'Unique'.+isNullaryTyConKeyApp :: Unique -> Type -> Bool+isNullaryTyConKeyApp key ty+  | Just args <- isTyConKeyApp_maybe key ty+  = assert (null args) True+  | otherwise+  = False+{-# INLINE isNullaryTyConKeyApp #-}++isLiftedLevity :: Type -> Bool+isLiftedLevity = isNullaryTyConKeyApp liftedDataConKey++isUnliftedLevity :: Type -> Bool+isUnliftedLevity = isNullaryTyConKeyApp unliftedDataConKey++-- | Is this the type 'Levity'?+isLevityTy :: Type -> Bool+isLevityTy = isNullaryTyConKeyApp levityTyConKey++-- | Is this the type 'RuntimeRep'?+isRuntimeRepTy :: Type -> Bool+isRuntimeRepTy = isNullaryTyConKeyApp runtimeRepTyConKey++-- | Is a tyvar of type 'RuntimeRep'?+isRuntimeRepVar :: TyVar -> Bool+isRuntimeRepVar = isRuntimeRepTy . tyVarKind++-- | Is a tyvar of type 'Levity'?+isLevityVar :: TyVar -> Bool+isLevityVar = isLevityTy . tyVarKind++-- | Is this the type 'Multiplicity'?+isMultiplicityTy :: Type -> Bool+isMultiplicityTy  = isNullaryTyConKeyApp multiplicityTyConKey++-- | Is a tyvar of type 'Multiplicity'?+isMultiplicityVar :: TyVar -> Bool+isMultiplicityVar = isMultiplicityTy . tyVarKind++--------------------------------------------+--  Splitting RuntimeRep+--------------------------------------------++-- | (splitRuntimeRep_maybe rr) takes a Type rr :: RuntimeRep, and+--   returns the (TyCon,[Type]) for the RuntimeRep, if possible, where+--   the TyCon is one of the promoted DataCons of RuntimeRep.+-- Remember: the unique on TyCon that is a a promoted DataCon is the+--           same as the unique on the DataCon+--           See Note [Promoted data constructors] in GHC.Core.TyCon+-- May not be possible if `rr` is a type variable or type+--   family application+splitRuntimeRep_maybe :: RuntimeRepType -> Maybe (TyCon, [Type])+splitRuntimeRep_maybe rep+  | TyConApp rr_tc args <- coreFullView rep+  , isPromotedDataCon rr_tc+    -- isPromotedDataCon: be careful of type families (F tys) :: RuntimeRep,+  = Just (rr_tc, args)+  | otherwise+  = Nothing++-- | See 'isBoxedRuntimeRep_maybe'.+isBoxedRuntimeRep :: RuntimeRepType -> Bool+isBoxedRuntimeRep rep = isJust (isBoxedRuntimeRep_maybe rep)++-- | `isBoxedRuntimeRep_maybe (rep :: RuntimeRep)` returns `Just lev` if `rep`+-- expands to `Boxed lev` and returns `Nothing` otherwise.+--+-- Types with this runtime rep are represented by pointers on the GC'd heap.+isBoxedRuntimeRep_maybe :: RuntimeRepType -> Maybe LevityType+isBoxedRuntimeRep_maybe rep+  | Just (rr_tc, args) <- splitRuntimeRep_maybe rep+  , rr_tc `hasKey` boxedRepDataConKey+  , [lev] <- args+  = Just lev+  | otherwise+  = Nothing++-- | Check whether a type (usually of kind 'RuntimeRep') is lifted, unlifted,+--   or unknown.  Returns Nothing if the type isn't of kind 'RuntimeRep'.+--+-- `runtimeRepLevity_maybe rr` returns:+--+--   * `Just Lifted` if `rr` is `LiftedRep :: RuntimeRep`+--   * `Just Unlifted` if `rr` is definitely unlifted, e.g. `IntRep`+--   * `Nothing` if not known (e.g. it's a type variable or a type family application).+runtimeRepLevity_maybe :: RuntimeRepType -> Maybe Levity+runtimeRepLevity_maybe rep+  | Just (rr_tc, args) <- splitRuntimeRep_maybe rep+  =       -- NB: args might be non-empty e.g. TupleRep [r1, .., rn]+    if (rr_tc `hasKey` boxedRepDataConKey)+    then case args of+            [lev] -> levityType_maybe lev+            _     -> Nothing  -- Type isn't of kind RuntimeRep+                     -- The latter case happens via the call to isLiftedRuntimeRep+                     -- in GHC.Tc.Errors.Ppr.pprMismatchMsg (#22742)+    else Just Unlifted+        -- Avoid searching all the unlifted RuntimeRep type cons+        -- In the RuntimeRep data type, only LiftedRep is lifted+  | otherwise+  = Nothing++--------------------------------------------+--  Splitting Levity+--------------------------------------------++-- | `levityType_maybe` takes a Type of kind Levity, and returns its levity+-- May not be possible for a type variable or type family application+levityType_maybe :: LevityType -> Maybe Levity+levityType_maybe lev+  | TyConApp lev_tc args <- coreFullView lev+  = if | lev_tc `hasKey` liftedDataConKey   -> assert( null args) $ Just Lifted+       | lev_tc `hasKey` unliftedDataConKey -> assert( null args) $ Just Unlifted+       | otherwise                          -> Nothing+  | otherwise+  = Nothing+++{- *********************************************************************+*                                                                      *+               mapType+*                                                                      *+************************************************************************++These functions do a map-like operation over types, performing some operation+on all variables and binding sites. Primarily used for zonking.++Note [Efficiency for ForAllCo case of mapTyCoX]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+As noted in Note [ForAllCo] in GHC.Core.TyCo.Rep, a ForAllCo is a bit redundant.+It stores a TyCoVar and a Coercion, where the kind of the TyCoVar always matches+the left-hand kind of the coercion. This is convenient lots of the time, but+not when mapping a function over a coercion.++The problem is that tcm_tybinder will affect the TyCoVar's kind and+mapCoercion will affect the Coercion, and we hope that the results will be+the same. Even if they are the same (which should generally happen with+correct algorithms), then there is an efficiency issue. In particular,+this problem seems to make what should be a linear algorithm into a potentially+exponential one. But it's only going to be bad in the case where there's+lots of foralls in the kinds of other foralls. Like this:++  forall a : (forall b : (forall c : ...). ...). ...++This construction seems unlikely. So we'll do the inefficient, easy way+for now.++Note [Specialising mappers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+These INLINE pragmas are indispensable. mapTyCo and mapTyCoX are used+to implement zonking, and it's vital that they get specialised to the TcM+monad and the particular mapper in use.++Even specialising to the monad alone made a 20% allocation difference+in perf/compiler/T5030.++See Note [Specialising foldType] in "GHC.Core.TyCo.Rep" for more details of this+idiom.+-}++-- | This describes how a "map" operation over a type/coercion should behave+data TyCoMapper env m+  = TyCoMapper+      { tcm_tyvar :: env -> TyVar -> m Type+      , tcm_covar :: env -> CoVar -> m Coercion+      , tcm_hole  :: env -> CoercionHole -> m Coercion+          -- ^ What to do with coercion holes.+          -- See Note [Coercion holes] in "GHC.Core.TyCo.Rep".++      , tcm_tycobinder :: forall r. env -> TyCoVar -> ForAllTyFlag+                       -> (env -> TyCoVar -> m r) -> m r+          -- ^ The returned env is used in the extended scope++      , tcm_tycon :: TyCon -> m TyCon+          -- ^ This is used only for TcTyCons+          -- a) To zonk TcTyCons+          -- b) To turn TcTyCons into TyCons.+          --    See Note [Type checking recursive type and class declarations]+          --    in "GHC.Tc.TyCl"+      }++{-# INLINE mapTyCo #-}  -- See Note [Specialising mappers]+mapTyCo :: Monad m => TyCoMapper () m+        -> ( Type       -> m  Type+           , [Type]     -> m  [Type]+           , Coercion   -> m  Coercion+           , [Coercion] -> m [Coercion] )+mapTyCo mapper+  = case mapTyCoX mapper of+     (go_ty, go_tys, go_co, go_cos)+        -> (go_ty (), go_tys (), go_co (), go_cos ())++{-# INLINE mapTyCoX #-}  -- See Note [Specialising mappers]+mapTyCoX :: forall m env. Monad m+         => TyCoMapper env m+         -> ( env -> Type       -> m Type+            , env -> [Type]     -> m [Type]+            , env -> Coercion   -> m Coercion+            , env -> [Coercion] -> m [Coercion] )+mapTyCoX (TyCoMapper { tcm_tyvar = tyvar+                     , tcm_tycobinder = tycobinder+                     , tcm_tycon = tycon+                     , tcm_covar = covar+                     , tcm_hole = cohole })+  = (go_ty, go_tys, go_co, go_cos)+  where+    -- See Note [Use explicit recursion in mapTyCo]+    go_tys !_   []       = return []+    go_tys !env (ty:tys) = (:) <$> go_ty env ty <*> go_tys env tys++    go_ty !env (TyVarTy tv)    = tyvar env tv+    go_ty !env (AppTy t1 t2)   = mkAppTy <$> go_ty env t1 <*> go_ty env t2+    go_ty !_   ty@(LitTy {})   = return ty+    go_ty !env (CastTy ty co)  = mkCastTy <$> go_ty env ty <*> go_co env co+    go_ty !env (CoercionTy co) = CoercionTy <$> go_co env co++    go_ty !env ty@(FunTy _ w arg res)+      = do { w' <- go_ty env w; arg' <- go_ty env arg; res' <- go_ty env res+           ; return (ty { ft_mult = w', ft_arg = arg', ft_res = res' }) }++    go_ty !env ty@(TyConApp tc tys)+      | isTcTyCon tc+      = do { tc' <- tycon tc+           ; mkTyConApp tc' <$> go_tys env tys }++      -- Not a TcTyCon+      | null tys    -- Avoid allocation in this very+      = return ty   -- common case (E.g. Int, LiftedRep etc)++      | otherwise+      = mkTyConApp tc <$> go_tys env tys++    go_ty !env (ForAllTy (Bndr tv vis) inner)+      = do { tycobinder env tv vis $ \env' tv' -> do+           ; inner' <- go_ty env' inner+           ; return $ ForAllTy (Bndr tv' vis) inner' }++    -- See Note [Use explicit recursion in mapTyCo]+    go_cos !_   []       = return []+    go_cos !env (co:cos) = (:) <$> go_co env co <*> go_cos env cos++    go_mco !_   MRefl    = return MRefl+    go_mco !env (MCo co) = MCo <$> (go_co env co)++    go_co :: env -> Coercion -> m Coercion+    go_co !env (Refl ty)                  = Refl <$> go_ty env ty+    go_co !env (GRefl r ty mco)           = mkGReflCo r <$> go_ty env ty <*> go_mco env mco+    go_co !env (AppCo c1 c2)              = mkAppCo <$> go_co env c1 <*> go_co env c2+    go_co !env (FunCo r afl afr cw c1 c2) = mkFunCo2 r afl afr <$> go_co env cw+                                           <*> go_co env c1 <*> go_co env c2+    go_co !env (CoVarCo cv)               = covar env cv+    go_co !env (HoleCo hole)              = cohole env hole+    go_co !env (UnivCo { uco_prov = p, uco_role = r+                       , uco_lty = t1, uco_rty = t2, uco_deps = deps })+                                          = mkUnivCo <$> pure p+                                                     <*> go_cos env deps+                                                     <*> pure r+                                                     <*> go_ty env t1 <*> go_ty env t2+    go_co !env (SymCo co)                 = mkSymCo <$> go_co env co+    go_co !env (TransCo c1 c2)            = mkTransCo <$> go_co env c1 <*> go_co env c2+    go_co !env (AxiomCo r cos)            = mkAxiomCo r <$> go_cos env cos+    go_co !env (SelCo i co)               = mkSelCo i <$> go_co env co+    go_co !env (LRCo lr co)               = mkLRCo lr <$> go_co env co+    go_co !env (InstCo co arg)            = mkInstCo <$> go_co env co <*> go_co env arg+    go_co !env (KindCo co)                = mkKindCo <$> go_co env co+    go_co !env (SubCo co)                 = mkSubCo <$> go_co env co+    go_co !env co@(TyConAppCo r tc cos)+      | isTcTyCon tc+      = do { tc' <- tycon tc+           ; mkTyConAppCo r tc' <$> go_cos env cos }++      -- Not a TcTyCon+      | null cos    -- Avoid allocation in this very+      = return co   -- common case (E.g. Int, LiftedRep etc)++      | otherwise+      = mkTyConAppCo r tc <$> go_cos env cos+    go_co !env (ForAllCo { fco_tcv = tv, fco_visL = visL, fco_visR = visR+                         , fco_kind = kind_co, fco_body = co })+      = do { kind_co' <- go_co env kind_co+           ; tycobinder env tv visL $ \env' tv' ->  do+           ; co' <- go_co env' co+           ; return $ mkForAllCo tv' visL visR kind_co' co' }+        -- See Note [Efficiency for ForAllCo case of mapTyCoX]+++{- Note [Use explicit recursion in mapTyCo]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We use explicit recursion in `mapTyCo`, rather than calling, say, `strictFoldDVarSet`,+for exactly the same reason as in Note [Use explicit recursion in foldTyCo] in+GHC.Core.TyCo.Rep. We are in a monadic context, and using too-clever higher order+functions makes the strictness analyser produce worse results.++We could probably use `foldr`, since it is inlined bodily, fairly early; but+I'm doing the simple thing and inlining it by hand.++See !12037 for performance glitches caused by using `strictFoldDVarSet` (which is+definitely not inlined bodily).+-}++{- *********************************************************************+*                                                                      *+                      TyVarTy+*                                                                      *+********************************************************************* -}++-- | Attempts to obtain the type variable underlying a 'Type', and panics with the+-- given message if this is not a type variable type. See also 'getTyVar_maybe'+getTyVar :: HasDebugCallStack => Type -> TyVar+getTyVar ty = case getTyVar_maybe ty of+                    Just tv -> tv+                    Nothing -> pprPanic "getTyVar" (ppr ty)++-- | Attempts to obtain the type variable underlying a 'Type'+getTyVar_maybe :: Type -> Maybe TyVar+getTyVar_maybe = repGetTyVar_maybe . coreFullView++-- | Attempts to obtain the type variable underlying a 'Type', without+-- any expansion+repGetTyVar_maybe :: Type -> Maybe TyVar+repGetTyVar_maybe (TyVarTy tv) = Just tv+repGetTyVar_maybe _            = Nothing++isTyVarTy :: Type -> Bool+isTyVarTy ty = isJust (getTyVar_maybe ty)++-- | If the type is a tyvar, possibly under a cast, returns it, along+-- with the coercion. Thus, the co is :: kind tv ~N kind ty+getCastedTyVar_maybe :: Type -> Maybe (TyVar, CoercionN)+getCastedTyVar_maybe ty = case coreFullView ty of+  CastTy (TyVarTy tv) co -> Just (tv, co)+  TyVarTy tv             -> Just (tv, mkReflCo Nominal (tyVarKind tv))+  _                      -> Nothing+++{- *********************************************************************+*                                                                      *+                      AppTy+*                                                                      *+********************************************************************* -}++{- We need to be pretty careful with AppTy to make sure we obey the+invariant that a TyConApp is always visibly so.  mkAppTy maintains the+invariant: use it.++Note [Decomposing fat arrow c=>t]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Can we unify (a b) with (Eq a => ty)?   If we do so, we end up with+a partial application like ((=>) (Eq a)) which doesn't make sense in+source Haskell.  In contrast, we *can* unify (a b) with (t1 -> t2).+Here's an example (#9858) of how you might do it:+   i :: (Typeable a, Typeable b) => Proxy (a b) -> TypeRep+   i p = typeRep p++   j = i (Proxy :: Proxy (Eq Int => Int))+The type (Proxy (Eq Int => Int)) is only accepted with -XImpredicativeTypes,+but suppose we want that.  But then in the call to 'i', we end+up decomposing (Eq Int => Int), and we definitely don't want that.++We are willing to split (t1 -=> t2) because the argument is still of+kind Type, not Constraint.  So the criterion is isVisibleFunArg.++In Core there is no real reason to avoid such decomposition.  But for now I've+put the test in splitAppTyNoView_maybe, which applies throughout, because the+other calls to splitAppTy are in GHC.Core.Unify, which is also used by the+type checker (e.g. when matching type-function equations).+-}++-- | Applies a type to another, as in e.g. @k a@+mkAppTy :: Type -> Type -> Type+  -- See Note [Respecting definitional equality], invariant (EQ1).+mkAppTy (CastTy fun_ty co) arg_ty+  | ([arg_co], res_co) <- decomposePiCos co (coercionKind co) [arg_ty]+  = (fun_ty `mkAppTy` (arg_ty `mkCastTy` arg_co)) `mkCastTy` res_co++mkAppTy (TyConApp tc tys) ty2 = mkTyConApp tc (tys ++ [ty2])+mkAppTy ty1               ty2 = AppTy ty1 ty2+        -- Note that the TyConApp could be an+        -- under-saturated type synonym.  GHC allows that; e.g.+        --      type Foo k = k a -> k a+        --      type Id x = x+        --      foo :: Foo Id -> Foo Id+        --+        -- Here Id is partially applied in the type sig for Foo,+        -- but once the type synonyms are expanded all is well+        --+        -- Moreover in GHC.Tc.Types.tcInferTyApps we build up a type+        --   (T t1 t2 t3) one argument at a type, thus forming+        --   (T t1), (T t1 t2), etc++mkAppTys :: Type -> [Type] -> Type+mkAppTys ty1                []   = ty1+mkAppTys (CastTy fun_ty co) arg_tys  -- much more efficient then nested mkAppTy+                                     -- Why do this? See (EQ1) of+                                     -- Note [Respecting definitional equality]+                                     -- in GHC.Core.TyCo.Rep+  = foldl' AppTy ((mkAppTys fun_ty casted_arg_tys) `mkCastTy` res_co) leftovers+  where+    (arg_cos, res_co) = decomposePiCos co (coercionKind co) arg_tys+    (args_to_cast, leftovers) = splitAtList arg_cos arg_tys+    casted_arg_tys = zipWith mkCastTy args_to_cast arg_cos+mkAppTys (TyConApp tc tys1) tys2 = mkTyConApp tc (tys1 ++ tys2)+mkAppTys ty1                tys2 = foldl' AppTy ty1 tys2++-------------+splitAppTy_maybe :: Type -> Maybe (Type, Type)+-- ^ Attempt to take a type application apart, whether it is a+-- function, type constructor, or plain type application. Note+-- that type family applications are NEVER unsaturated by this!+splitAppTy_maybe = splitAppTyNoView_maybe . coreFullView++splitAppTy :: Type -> (Type, Type)+-- ^ Attempts to take a type application apart, as in 'splitAppTy_maybe',+-- and panics if this is not possible+splitAppTy ty = splitAppTy_maybe ty `orElse` pprPanic "splitAppTy" (ppr ty)++-------------+splitAppTyNoView_maybe :: HasDebugCallStack => Type -> Maybe (Type,Type)+-- ^ Does the AppTy split as in 'splitAppTy_maybe', but assumes that+-- any coreView stuff is already done+splitAppTyNoView_maybe (AppTy ty1 ty2)+  = Just (ty1, ty2)++splitAppTyNoView_maybe (FunTy af w ty1 ty2)+  | Just (tc, tys)   <- funTyConAppTy_maybe af w ty1 ty2+  , Just (tys', ty') <- snocView tys+  = Just (TyConApp tc tys', ty')++splitAppTyNoView_maybe (TyConApp tc tys)+  | not (tyConMustBeSaturated tc) || tys `lengthExceeds` tyConArity tc+  , Just (tys', ty') <- snocView tys+  = Just (TyConApp tc tys', ty')    -- Never create unsaturated type family apps!++splitAppTyNoView_maybe _other = Nothing++tcSplitAppTyNoView_maybe :: Type -> Maybe (Type,Type)+-- ^ Just like splitAppTyNoView_maybe, but does not split (c => t)+-- See Note [Decomposing fat arrow c=>t]+tcSplitAppTyNoView_maybe ty+  | FunTy { ft_af = af } <- ty+  , not (isVisibleFunArg af)  -- See Note [Decomposing fat arrow c=>t]+  = Nothing+  | otherwise+  = splitAppTyNoView_maybe ty++-------------+splitAppTys :: HasDebugCallStack => Type -> (Type, [Type])+-- ^ Recursively splits a type as far as is possible, leaving a residual+-- type being applied to and the type arguments applied to it. Never fails,+-- even if that means returning an empty list of type applications.+splitAppTys ty = split ty ty []+  where+    split orig_ty ty args | Just ty' <- coreView ty = split orig_ty ty' args+    split _       (AppTy ty arg)        args = split ty ty (arg:args)+    split _       (TyConApp tc tc_args) args+      = let -- keep type families saturated+            n | tyConMustBeSaturated tc = tyConArity tc+              | otherwise               = 0+            (tc_args1, tc_args2) = splitAt n tc_args+        in+        (TyConApp tc tc_args1, tc_args2 ++ args)+    split _   (FunTy af w ty1 ty2) args+      | Just (tc,tys) <- funTyConAppTy_maybe af w ty1 ty2+      = assert (null args )+        (TyConApp tc [], tys)++    split orig_ty _ args  = (orig_ty, args)++-- | Like 'splitAppTys', but doesn't look through type synonyms+splitAppTysNoView :: HasDebugCallStack => Type -> (Type, [Type])+splitAppTysNoView ty = split ty []+  where+    split (AppTy ty arg) args = split ty (arg:args)+    split (TyConApp tc tc_args) args+      = let n | tyConMustBeSaturated tc = tyConArity tc+              | otherwise               = 0+            (tc_args1, tc_args2) = splitAt n tc_args+        in+        (TyConApp tc tc_args1, tc_args2 ++ args)+    split (FunTy af w ty1 ty2) args+      | Just (tc, tys) <- funTyConAppTy_maybe af w ty1 ty2+      = assert (null args )+        (TyConApp tc [], tys)++    split ty args = (ty, args)+++{- *********************************************************************+*                                                                      *+                      LitTy+*                                                                      *+********************************************************************* -}++mkNumLitTy :: Integer -> Type+mkNumLitTy n = LitTy (NumTyLit n)++-- | Is this a numeric literal. We also look through type synonyms.+isNumLitTy :: Type -> Maybe Integer+isNumLitTy ty+  | LitTy (NumTyLit n) <- coreFullView ty = Just n+  | otherwise                             = Nothing++mkStrLitTy :: FastString -> Type+mkStrLitTy s = LitTy (StrTyLit s)++-- | Is this a symbol literal. We also look through type synonyms.+isStrLitTy :: Type -> Maybe FastString+isStrLitTy ty+  | LitTy (StrTyLit s) <- coreFullView ty = Just s+  | otherwise                             = Nothing++mkCharLitTy :: Char -> Type+mkCharLitTy c = LitTy (CharTyLit c)++-- | Is this a char literal? We also look through type synonyms.+isCharLitTy :: Type -> Maybe Char+isCharLitTy ty+  | LitTy (CharTyLit s) <- coreFullView ty = Just s+  | otherwise                              = Nothing+++-- | Is this a type literal (symbol, numeric, or char)?+isLitTy :: Type -> Maybe TyLit+isLitTy ty+  | LitTy l <- coreFullView ty = Just l+  | otherwise                  = Nothing++-- | A type of kind 'ErrorMessage' (from the 'GHC.TypeError' module).+type ErrorMsgType = Type++-- | Is this type a custom user error?+-- If so, give us the error message.+userTypeError_maybe :: Type -> Maybe ErrorMsgType+userTypeError_maybe ty+  | Just ty' <- coreView ty = userTypeError_maybe ty'+userTypeError_maybe (TyConApp tc (_kind : msg : _))+  | tyConName tc == errorMessageTypeErrorFamName+          -- There may be more than 2 arguments, if the type error is+          -- used as a type constructor (e.g. at kind `Type -> Type`).+  = Just msg+userTypeError_maybe _+  = Nothing++deepUserTypeError_maybe :: Type -> Maybe ErrorMsgType+-- Look for custom user error, deeply inside the type+deepUserTypeError_maybe ty+  | Just ty' <- coreView ty = userTypeError_maybe ty'+deepUserTypeError_maybe (TyConApp tc tys)+  | tyConName tc == errorMessageTypeErrorFamName+  , _kind : msg : _ <- tys+          -- There may be more than 2 arguments, if the type error is+          -- used as a type constructor (e.g. at kind `Type -> Type`).+  = Just msg++  | tyConMustBeSaturated tc  -- Don't go looking for user type errors+                             -- inside type family arguments (see #20241).+  = foldr (firstJust . deepUserTypeError_maybe) Nothing (drop (tyConArity tc) tys)+  | otherwise+  = foldr (firstJust . deepUserTypeError_maybe) Nothing tys+deepUserTypeError_maybe (ForAllTy _ ty) = deepUserTypeError_maybe ty+deepUserTypeError_maybe (FunTy { ft_arg = arg, ft_res = res })+  = deepUserTypeError_maybe arg `firstJust` deepUserTypeError_maybe res+deepUserTypeError_maybe (AppTy t1 t2)+  = deepUserTypeError_maybe t1 `firstJust` deepUserTypeError_maybe t2+deepUserTypeError_maybe (CastTy ty _)+  = deepUserTypeError_maybe ty+deepUserTypeError_maybe _   -- TyVarTy, CoercionTy, LitTy+  = Nothing++-- | Render a type corresponding to a user type error into a SDoc.+pprUserTypeErrorTy :: ErrorMsgType -> SDoc+pprUserTypeErrorTy ty =+  case splitTyConApp_maybe ty of++    -- Text "Something"+    Just (tc,[txt])+      | tyConName tc == typeErrorTextDataConName+      , Just str <- isStrLitTy txt -> ftext str++    -- ShowType t+    Just (tc,[_k,t])+      | tyConName tc == typeErrorShowTypeDataConName -> ppr t++    -- t1 :<>: t2+    Just (tc,[t1,t2])+      | tyConName tc == typeErrorAppendDataConName ->+        pprUserTypeErrorTy t1 <> pprUserTypeErrorTy t2++    -- t1 :$$: t2+    Just (tc,[t1,t2])+      | tyConName tc == typeErrorVAppendDataConName ->+        pprUserTypeErrorTy t1 $$ pprUserTypeErrorTy t2++    -- An unevaluated type function+    _ -> ppr ty++{- *********************************************************************+*                                                                      *+                      FunTy+*                                                                      *+********************************************************************* -}++{- Note [Representation of function types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Functions (e.g. Int -> Char) can be thought of as being applications+of funTyCon (known in Haskell surface syntax as (->)), (note that+`RuntimeRep' quantifiers are left inferred)++    (->) :: forall {r1 :: RuntimeRep} {r2 :: RuntimeRep}+                   (a :: TYPE r1) (b :: TYPE r2).+            a -> b -> Type++However, for efficiency's sake we represent saturated applications of (->)+with FunTy. For instance, the type,++    (->) r1 r2 a b++is equivalent to,++    FunTy (Anon a) b++Note how the RuntimeReps are implied in the FunTy representation. For this+reason we must be careful when reconstructing the TyConApp representation (see,+for instance, splitTyConApp_maybe).++In the compiler we maintain the invariant that all saturated applications of+(->) are represented with FunTy.++See #11714.+-}++-----------------------------------------------+funTyConAppTy_maybe :: FunTyFlag -> Type -> Type -> Type+                    -> Maybe (TyCon, [Type])+-- ^ Given the components of a FunTy+-- figure out the corresponding TyConApp.+funTyConAppTy_maybe af mult arg res+  | Just arg_rep <- getRuntimeRep_maybe arg+  , Just res_rep <- getRuntimeRep_maybe res+  -- If you're changing the lines below, you'll probably want to adapt the+  -- `fUNTyCon` case of GHC.Core.Unify.unify_ty correspondingly.+  , let args | isFUNArg af = [mult, arg_rep, res_rep, arg, res]+             | otherwise   = [      arg_rep, res_rep, arg, res]+  = Just $ (funTyFlagTyCon af, args)+  | otherwise+  = Nothing++tyConAppFunTy_maybe :: HasDebugCallStack => TyCon -> [Type] -> Maybe Type+-- ^ Return Just if this TyConApp should be represented as a FunTy+tyConAppFunTy_maybe tc tys+  | Just (af, mult, arg, res) <- ty_con_app_fun_maybe manyDataConTy tc tys+            = Just (FunTy { ft_af = af, ft_mult = mult, ft_arg = arg, ft_res = res })+  | otherwise = Nothing++tyConAppFunCo_maybe :: HasDebugCallStack => Role -> TyCon -> [Coercion]+                    -> Maybe Coercion+-- ^ Return Just if this TyConAppCo should be represented as a FunCo+tyConAppFunCo_maybe r tc cos+  | Just (af, mult, arg, res) <- ty_con_app_fun_maybe mult_refl tc cos+  = Just (mkFunCo r af mult arg res)+  | otherwise+  = Nothing+  where+    mult_refl = mkReflCo (funRole r SelMult) manyDataConTy++ty_con_app_fun_maybe :: (HasDebugCallStack, Outputable a) => a -> TyCon -> [a]+                     -> Maybe (FunTyFlag, a, a, a)+{-# INLINE ty_con_app_fun_maybe #-}+-- Specialise this function for its two call sites+ty_con_app_fun_maybe many_ty_co tc args+  | tc_uniq == fUNTyConKey     = fUN_case+  | tc_uniq == tcArrowTyConKey = non_FUN_case FTF_T_C+  | tc_uniq == ctArrowTyConKey = non_FUN_case FTF_C_T+  | tc_uniq == ccArrowTyConKey = non_FUN_case FTF_C_C+  | otherwise                  = Nothing+  where+    tc_uniq = tyConUnique tc++    fUN_case+      | (w:_r1:_r2:a1:a2:rest) <- args+      = assertPpr (null rest) (ppr tc <+> ppr args) $+        Just (FTF_T_T, w, a1, a2)+      | otherwise = Nothing++    non_FUN_case ftf+      | (_r1:_r2:a1:a2:rest) <- args+      = assertPpr (null rest) (ppr tc <+> ppr args) $+        Just (ftf, many_ty_co, a1, a2)+      | otherwise+      = Nothing++mkFunctionType :: HasDebugCallStack => Mult -> Type -> Type -> Type+-- ^ This one works out the FunTyFlag from the argument type+-- See GHC.Types.Var Note [FunTyFlag]+mkFunctionType mult arg_ty res_ty+ = FunTy { ft_af = af, ft_arg = arg_ty, ft_res = res_ty+         , ft_mult = assertPpr mult_ok (ppr [mult, arg_ty, res_ty]) $+                     mult }+  where+    af = chooseFunTyFlag arg_ty res_ty+    mult_ok = isVisibleFunArg af || isManyTy mult++mkScaledFunctionTys :: [Scaled Type] -> Type -> Type+-- ^ Like mkFunctionType, compute the FunTyFlag from the arguments+mkScaledFunctionTys arg_tys res_ty+  = foldr mk res_ty arg_tys+  where+    mk (Scaled mult arg_ty) res_ty+      = mkFunTy (chooseFunTyFlag arg_ty res_ty)+                mult arg_ty res_ty++chooseFunTyFlag :: HasDebugCallStack => Type -> Type -> FunTyFlag+-- ^ See GHC.Types.Var Note [FunTyFlag]+chooseFunTyFlag arg_ty res_ty+  = mkFunTyFlag (typeTypeOrConstraint arg_ty) (typeTypeOrConstraint res_ty)++splitFunTy :: Type -> (Mult, Type, Type)+-- ^ Attempts to extract the multiplicity, argument and result types from a type,+-- and panics if that is not possible. See also 'splitFunTy_maybe'+splitFunTy ty = case splitFunTy_maybe ty of+                   Just (_af, mult, arg, res) -> (mult,arg,res)+                   Nothing                    -> pprPanic "splitFunTy" (ppr ty)++{-# INLINE splitFunTy_maybe #-}+splitFunTy_maybe :: Type -> Maybe (FunTyFlag, Mult, Type, Type)+-- ^ Attempts to extract the multiplicity, argument and result types from a type+splitFunTy_maybe ty+  | FunTy af w arg res <- coreFullView ty = Just (af, w, arg, res)+  | otherwise                             = Nothing++{-# INLINE splitVisibleFunTy_maybe #-}+splitVisibleFunTy_maybe :: Type -> Maybe (Type, Type)+-- ^ Works on visible function types only (t1 -> t2), and+--   returns t1 and t2, but not the multiplicity+splitVisibleFunTy_maybe ty+  | FunTy af _ arg res <- coreFullView ty+  , isVisibleFunArg af = Just (arg, res)+  | otherwise          = Nothing++splitFunTys :: Type -> ([Scaled Type], Type)+splitFunTys ty = split [] ty ty+  where+      -- common case first+    split args _       (FunTy _ w arg res) = split (Scaled w arg : args) res res+    split args orig_ty ty | Just ty' <- coreView ty = split args orig_ty ty'+    split args orig_ty _                   = (reverse args, orig_ty)++funResultTy :: HasDebugCallStack => Type -> Type+-- ^ Extract the function result type and panic if that is not possible+funResultTy ty+  | FunTy { ft_res = res } <- coreFullView ty = res+  | otherwise                                 = pprPanic "funResultTy" (ppr ty)++funArgTy :: HasDebugCallStack => Type -> Type+-- ^ Extract the function argument type and panic if that is not possible+funArgTy ty+  | FunTy { ft_arg = arg } <- coreFullView ty = arg+  | otherwise                                 = pprPanic "funArgTy" (ppr ty)++-- ^ Just like 'piResultTys' but for a single argument+-- Try not to iterate 'piResultTy', because it's inefficient to substitute+-- one variable at a time; instead use 'piResultTys"+piResultTy :: HasDebugCallStack => Type -> Type ->  Type+piResultTy ty arg = case piResultTy_maybe ty arg of+                      Just res -> res+                      Nothing  -> pprPanic "piResultTy" (ppr ty $$ ppr arg)++piResultTy_maybe :: Type -> Type -> Maybe Type+-- We don't need a 'tc' version, because+-- this function behaves the same for Type and Constraint+piResultTy_maybe ty arg = case coreFullView ty of+  FunTy { ft_res = res } -> Just res++  ForAllTy (Bndr tv _) res+    -> let empty_subst = mkEmptySubst $ mkInScopeSet $+                         tyCoVarsOfTypes [arg,res]+       in Just (substTy (extendTCvSubst empty_subst tv arg) res)++  _ -> Nothing++-- | (piResultTys f_ty [ty1, .., tyn]) gives the type of (f ty1 .. tyn)+--   where f :: f_ty+-- 'piResultTys' is interesting because:+--      1. 'f_ty' may have more for-alls than there are args+--      2. Less obviously, it may have fewer for-alls+-- For case 2. think of:+--   piResultTys (forall a.a) [forall b.b, Int]+-- This really can happen, but only (I think) in situations involving+-- undefined.  For example:+--       undefined :: forall a. a+-- Term: undefined @(forall b. b->b) @Int+-- This term should have type (Int -> Int), but notice that+-- there are more type args than foralls in 'undefined's type.++-- If you edit this function, you may need to update the GHC formalism+-- See Note [GHC Formalism] in GHC.Core.Lint++-- This is a heavily used function (e.g. from typeKind),+-- so we pay attention to efficiency, especially in the special case+-- where there are no for-alls so we are just dropping arrows from+-- a function type/kind.+piResultTys :: HasDebugCallStack => Type -> [Type] -> Type+piResultTys ty [] = ty+piResultTys ty orig_args@(arg:args)+  | FunTy { ft_res = res } <- ty+  = piResultTys res args++  | ForAllTy (Bndr tcv _) res <- ty+  = -- Both type and coercion variables+    go (extendTCvSubst init_subst tcv arg) res args++  | Just ty' <- coreView ty+  = piResultTys ty' orig_args++  | otherwise+  = pprPanic "piResultTys1" (ppr ty $$ ppr orig_args)+  where+    init_subst = mkEmptySubst $ mkInScopeSet (tyCoVarsOfTypes (ty:orig_args))++    go :: Subst -> Type -> [Type] -> Type+    go subst ty [] = substTyUnchecked subst ty++    go subst ty all_args@(arg:args)+      | FunTy { ft_res = res } <- ty+      = go subst res args++      | ForAllTy (Bndr tv _) res <- ty+      = go (extendTCvSubst subst tv arg) res args++      | Just ty' <- coreView ty+      = go subst ty' all_args++      | not (isEmptyTCvSubst subst)  -- See Note [Care with kind instantiation]+      = go init_subst+          (substTy subst ty)+          all_args++      | otherwise+      = -- We have not run out of arguments, but the function doesn't+        -- have the right kind to apply to them; so panic.+        -- Without the explicit isEmptyVarEnv test, an ill-kinded type+        -- would give an infinite loop, which is very unhelpful+        -- c.f. #15473+        pprPanic "piResultTys2" (ppr ty $$ ppr orig_args $$ ppr all_args)++applyTysX :: HasDebugCallStack => [TyVar] -> Type -> [Type] -> Type+-- applyTysX beta-reduces (/\tvs. body_ty) arg_tys+-- Assumes that (/\tvs. body_ty) is closed+applyTysX tvs body_ty arg_tys+  = assertPpr (tvs `leLength` arg_tys) pp_stuff $+    assertPpr (tyCoVarsOfType body_ty `subVarSet` mkVarSet tvs) pp_stuff $+    mkAppTys (substTyWith tvs arg_tys_prefix body_ty)+             arg_tys_rest+  where+    pp_stuff = vcat [ppr tvs, ppr body_ty, ppr arg_tys]+    (arg_tys_prefix, arg_tys_rest) = splitAtList tvs arg_tys+++{- Note [Care with kind instantiation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have+  T :: forall k. k+and we are finding the kind of+  T (forall b. b -> b) * Int+Then+  T (forall b. b->b) :: k[ k :-> forall b. b->b]+                     :: forall b. b -> b+So+  T (forall b. b->b) * :: (b -> b)[ b :-> *]+                       :: * -> *++In other words we must instantiate the forall!++Similarly (#15428)+   S :: forall k f. k -> f k+and we are finding the kind of+   S * (* ->) Int Bool+We have+   S * (* ->) :: (k -> f k)[ k :-> *, f :-> (* ->)]+              :: * -> * -> *+So again we must instantiate.++The same thing happens in GHC.CoreToIface.toIfaceAppArgsX.+-}+++{- *********************************************************************+*                                                                      *+                      TyConApp+*                                                                      *+********************************************************************* -}++-- splitTyConApp "looks through" synonyms, because they don't+-- mean a distinct type, but all other type-constructor applications+-- including functions are returned as Just ..++-- | Retrieve the tycon heading this type, if there is one. Does /not/+-- look through synonyms.+tyConAppTyConPicky_maybe :: Type -> Maybe TyCon+tyConAppTyConPicky_maybe (TyConApp tc _)        = Just tc+tyConAppTyConPicky_maybe (FunTy { ft_af = af }) = Just (funTyFlagTyCon af)+tyConAppTyConPicky_maybe _                      = Nothing+++-- | The same as @fst . splitTyConApp@+-- We can short-cut the FunTy case+{-# INLINE tyConAppTyCon_maybe #-}+tyConAppTyCon_maybe :: Type -> Maybe TyCon+tyConAppTyCon_maybe ty = case coreFullView ty of+  TyConApp tc _        -> Just tc+  FunTy { ft_af = af } -> Just (funTyFlagTyCon af)+  _                    -> Nothing++tyConAppTyCon :: HasDebugCallStack => Type -> TyCon+tyConAppTyCon ty = tyConAppTyCon_maybe ty `orElse` pprPanic "tyConAppTyCon" (ppr ty)++-- | The same as @snd . splitTyConApp@+tyConAppArgs_maybe :: Type -> Maybe [Type]+tyConAppArgs_maybe ty = case splitTyConApp_maybe ty of+                          Just (_, tys) -> Just tys+                          Nothing       -> Nothing++tyConAppArgs :: HasDebugCallStack => Type -> [Type]+tyConAppArgs ty = tyConAppArgs_maybe ty `orElse` pprPanic "tyConAppArgs" (ppr ty)++-- | Attempts to tease a type apart into a type constructor and the application+-- of a number of arguments to that constructor. Panics if that is not possible.+-- See also 'splitTyConApp_maybe'+splitTyConApp :: Type -> (TyCon, [Type])+splitTyConApp ty = splitTyConApp_maybe ty `orElse` pprPanic "splitTyConApp" (ppr ty)++-- | Attempts to tease a type apart into a type constructor and the application+-- of a number of arguments to that constructor+splitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type])+splitTyConApp_maybe ty = splitTyConAppNoView_maybe (coreFullView ty)++splitTyConAppNoView_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type])+-- Same as splitTyConApp_maybe but without looking through synonyms+splitTyConAppNoView_maybe ty+  = case ty of+      FunTy { ft_af = af, ft_mult = w, ft_arg = arg, ft_res = res}+                      -> funTyConAppTy_maybe af w arg res+      TyConApp tc tys -> Just (tc, tys)+      _               -> Nothing++-- | tcSplitTyConApp_maybe splits a type constructor application into+-- its type constructor and applied types.+--+-- Differs from splitTyConApp_maybe in that it does *not* split types+-- headed with (=>), as that's not a TyCon in the type-checker.+--+-- Note that this may fail (in funTyConAppTy_maybe) in the case+-- of a 'FunTy' with an argument of unknown kind 'FunTy'+-- (e.g. `FunTy (a :: k) Int`, since the kind of @a@ isn't of+-- the form `TYPE rep`.  This isn't usually a problem but may+-- be temporarily the case during canonicalization:+--     see Note [Decomposing FunTy] in GHC.Tc.Solver.Equality+--     and Note [The Purely Kinded Type Invariant (PKTI)] in GHC.Tc.Gen.HsType,+--         Wrinkle around FunTy+--+-- Consequently, you may need to zonk your type before+-- using this function.+tcSplitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type])+-- Defined here to avoid module loops between Unify and TcType.+tcSplitTyConApp_maybe ty+  = case coreFullView ty of+      FunTy { ft_af = af, ft_mult = w, ft_arg = arg, ft_res = res}+                      | isVisibleFunArg af    -- Visible args only+                        -- See Note [Decomposing fat arrow c=>t]+                      -> funTyConAppTy_maybe af w arg res+      TyConApp tc tys -> Just (tc, tys)+      _               -> Nothing++tcSplitTyConApp :: Type -> (TyCon, [Type])+tcSplitTyConApp ty+  = tcSplitTyConApp_maybe ty `orElse` pprPanic "tcSplitTyConApp" (ppr ty)++---------------------------+newTyConInstRhs :: TyCon -> [Type] -> Type+-- ^ Unwrap one 'layer' of newtype on a type constructor and its+-- arguments, using an eta-reduced version of the @newtype@ if possible.+-- This requires tys to have at least @newTyConInstArity tycon@ elements.+newTyConInstRhs tycon tys+    = assertPpr (tvs `leLength` tys) (ppr tycon $$ ppr tys $$ ppr tvs) $+      applyTysX tvs rhs tys+  where+    (tvs, rhs) = newTyConEtadRhs tycon+++{- *********************************************************************+*                                                                      *+                      CastTy+*                                                                      *+********************************************************************* -}++splitCastTy_maybe :: Type -> Maybe (Type, Coercion)+splitCastTy_maybe ty+  | CastTy ty' co <- coreFullView ty = Just (ty', co)+  | otherwise                        = Nothing++-- | Make a 'CastTy'. The Coercion must be nominal. Checks the+-- Coercion for reflexivity, dropping it if it's reflexive.+-- See @Note [Respecting definitional equality]@ in "GHC.Core.TyCo.Rep"+mkCastTy :: Type -> Coercion -> Type+mkCastTy orig_ty co | isReflexiveCo co = orig_ty  -- (EQ2) from the Note+-- NB: Do the slow check here. This is important to keep the splitXXX+-- functions working properly. Otherwise, we may end up with something+-- like (((->) |> something_reflexive_but_not_obviously_so) biz baz)+-- fails under splitFunTy_maybe. This happened with the cheaper check+-- in test dependent/should_compile/dynamic-paper.+mkCastTy orig_ty co = mk_cast_ty orig_ty co++-- | Like 'mkCastTy', but avoids checking the coercion for reflexivity,+-- as that can be expensive.+mk_cast_ty :: Type -> Coercion -> Type+mk_cast_ty orig_ty co = go orig_ty+  where+    go :: Type -> Type+    -- See Note [Using coreView in mk_cast_ty]+    go ty | Just ty' <- coreView ty = go ty'++    go (CastTy ty co1)+      -- (EQ3) from the Note+      = mkCastTy ty (co1 `mkTransCo` co)+          -- call mkCastTy again for the reflexivity check++    go (ForAllTy (Bndr tv vis) inner_ty)+      -- (EQ4) from the Note+      -- See Note [Weird typing rule for ForAllTy] in GHC.Core.TyCo.Rep.+      | isTyVar tv+      , let fvs = tyCoVarsOfCo co+      = -- have to make sure that pushing the co in doesn't capture the bound var!+        if tv `elemVarSet` fvs+        then let empty_subst = mkEmptySubst (mkInScopeSet fvs)+                 (subst, tv') = substVarBndr empty_subst tv+             in ForAllTy (Bndr tv' vis) (substTy subst inner_ty `mk_cast_ty` co)+        else ForAllTy (Bndr tv vis) (inner_ty `mk_cast_ty` co)++    go _ = CastTy orig_ty co -- NB: orig_ty: preserve synonyms if possible++{-+Note [Using coreView in mk_cast_ty]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Invariants (EQ3) and (EQ4) of Note [Respecting definitional equality] in+GHC.Core.TyCo.Rep must apply regardless of type synonyms. For instance,+consider this example (#19742):++   type EqSameNat = () |> co+   useNatEq :: EqSameNat |> sym co++(Those casts aren't visible in the user-source code, of course; see #19742 for+what the user might write.)++The type `EqSameNat |> sym co` looks as if it satisfies (EQ3), as it has no+nested casts, but if we expand EqSameNat, we see that it doesn't.+And then Bad Things happen.++The solution is easy: just use `coreView` when establishing (EQ3) and (EQ4) in+`mk_cast_ty`.+-}++{- *********************************************************************+*                                                                      *+                     CoercionTy+  CoercionTy allows us to inject coercions into types. A CoercionTy+  should appear only in the right-hand side of an application.+*                                                                      *+********************************************************************* -}++mkCoercionTy :: Coercion -> Type+mkCoercionTy = CoercionTy++isCoercionTy :: Type -> Bool+isCoercionTy (CoercionTy _) = True+isCoercionTy _              = False++isCoercionTy_maybe :: Type -> Maybe Coercion+isCoercionTy_maybe (CoercionTy co) = Just co+isCoercionTy_maybe _               = Nothing++stripCoercionTy :: Type -> Coercion+stripCoercionTy (CoercionTy co) = co+stripCoercionTy ty              = pprPanic "stripCoercionTy" (ppr ty)+++{- *********************************************************************+*                                                                      *+                      ForAllTy+*                                                                      *+********************************************************************* -}++tyConBindersPiTyBinders :: [TyConBinder] -> [PiTyBinder]+-- Return the tyConBinders in PiTyBinder form+tyConBindersPiTyBinders = map to_tyb+  where+    to_tyb (Bndr tv (NamedTCB vis)) = Named (Bndr tv vis)+    to_tyb (Bndr tv AnonTCB)        = Anon (tymult (varType tv)) FTF_T_T++-- | Make a dependent forall over a TyCoVar+mkTyCoForAllTy :: TyCoVar -> ForAllTyFlag -> Type -> Type+mkTyCoForAllTy tv vis ty+  | isCoVar tv+  , not (tv `elemVarSet` tyCoVarsOfType ty)+   -- Maintain ForAllTy's invariants+    -- See Note [Unused coercion variable in ForAllTy] in GHC.Core.TyCo.Rep+  = mkVisFunTyMany (varType tv) ty+  | otherwise+  = ForAllTy (mkForAllTyBinder vis tv) ty++-- | Make a dependent forall over a TyCoVar+mkTyCoForAllTys :: [ForAllTyBinder] -> Type -> Type+mkTyCoForAllTys bndrs ty+  = foldr (\(Bndr var vis) -> mkTyCoForAllTy var vis) ty bndrs++-- | Make a dependent forall over an 'Inferred' variable+mkTyCoInvForAllTy :: TyCoVar -> Type -> Type+mkTyCoInvForAllTy tv ty = mkTyCoForAllTy tv Inferred ty++-- | Like 'mkTyCoInvForAllTy', but tv should be a tyvar+mkInfForAllTy :: TyVar -> Type -> Type+mkInfForAllTy tv ty = assert (isTyVar tv )+                      ForAllTy (Bndr tv Inferred) ty++-- | Like 'mkForAllTys', but assumes all variables are dependent and+-- 'Inferred', a common case+mkTyCoInvForAllTys :: [TyCoVar] -> Type -> Type+mkTyCoInvForAllTys tvs ty = foldr mkTyCoInvForAllTy ty tvs++-- | Like 'mkTyCoInvForAllTys', but tvs should be a list of tyvar+mkInfForAllTys :: [TyVar] -> Type -> Type+mkInfForAllTys tvs ty = foldr mkInfForAllTy ty tvs++-- | Like 'mkForAllTy', but assumes the variable is dependent and 'Specified',+-- a common case+mkSpecForAllTy :: TyVar -> Type -> Type+mkSpecForAllTy tv ty = assert (isTyVar tv )+                       -- covar is always Inferred, so input should be tyvar+                       ForAllTy (Bndr tv Specified) ty++-- | Like 'mkForAllTys', but assumes all variables are dependent and+-- 'Specified', a common case+mkSpecForAllTys :: [TyVar] -> Type -> Type+mkSpecForAllTys tvs ty = foldr mkSpecForAllTy ty tvs++-- | Like mkForAllTys, but assumes all variables are dependent and visible+mkVisForAllTys :: [TyVar] -> Type -> Type+mkVisForAllTys tvs = assert (all isTyVar tvs )+                     -- covar is always Inferred, so all inputs should be tyvar+                     mkForAllTys [ Bndr tv Required | tv <- tvs ]++-- | Given a list of type-level vars and the free vars of a result kind,+-- makes PiTyBinders, preferring anonymous binders+-- if the variable is, in fact, not dependent.+-- e.g.    mkTyConBindersPreferAnon [(k:*),(b:k),(c:k)] (k->k)+-- We want (k:*) Named, (b:k) Anon, (c:k) Anon+--+-- All non-coercion binders are /visible/.+mkTyConBindersPreferAnon :: [TyVar]      -- ^ binders+                         -> TyCoVarSet   -- ^ free variables of result+                         -> [TyConBinder]+mkTyConBindersPreferAnon vars inner_tkvs = assert (all isTyVar vars)+                                           fst (go vars)+  where+    go :: [TyVar] -> ([TyConBinder], VarSet) -- also returns the free vars+    go [] = ([], inner_tkvs)+    go (v:vs) | v `elemVarSet` fvs+              = ( Bndr v (NamedTCB Required) : binders+                , fvs `delVarSet` v `unionVarSet` kind_vars )+              | otherwise+              = ( Bndr v AnonTCB : binders+                , fvs `unionVarSet` kind_vars )+      where+        (binders, fvs) = go vs+        kind_vars      = tyCoVarsOfType $ tyVarKind v++-- | Take a ForAllTy apart, returning the binders and result type+splitForAllForAllTyBinders :: Type -> ([ForAllTyBinder], Type)+splitForAllForAllTyBinders ty = split ty ty []+  where+    split _ (ForAllTy b res) bs                   = split res res (b:bs)+    split orig_ty ty bs | Just ty' <- coreView ty = split orig_ty ty' bs+    split orig_ty _                bs             = (reverse bs, orig_ty)+{-# INLINE splitForAllForAllTyBinders #-}++-- | Take a ForAllTy apart, returning the list of tycovars and the result type.+-- This always succeeds, even if it returns only an empty list. Note that the+-- result type returned may have free variables that were bound by a forall.+splitForAllTyCoVars :: Type -> ([TyCoVar], Type)+splitForAllTyCoVars ty = split ty ty []+  where+    split _       (ForAllTy (Bndr tv _) ty)    tvs = split ty ty (tv:tvs)+    split orig_ty ty tvs | Just ty' <- coreView ty = split orig_ty ty' tvs+    split orig_ty _                            tvs = (reverse tvs, orig_ty)++-- | Like 'splitForAllTyCoVars', but split only for tyvars.+-- This always succeeds, even if it returns only an empty list. Note that the+-- result type returned may have free variables that were bound by a forall.+splitForAllTyVars :: Type -> ([TyVar], Type)+splitForAllTyVars ty = split ty ty []+  where+    split _ (ForAllTy (Bndr tv _) ty) tvs | isTyVar tv = split ty ty (tv:tvs)+    split orig_ty ty tvs | Just ty' <- coreView ty     = split orig_ty ty' tvs+    split orig_ty _                   tvs              = (reverse tvs, orig_ty)++-- | Like 'splitForAllTyCoVars', but only splits 'ForAllTy's with 'Required' type+-- variable binders. Furthermore, each returned tyvar is annotated with '()'.+splitForAllReqTyBinders :: Type -> ([ReqTyBinder], Type)+splitForAllReqTyBinders ty = split ty ty []+  where+    split _ (ForAllTy (Bndr tv Required) ty) tvs   = split ty ty (Bndr tv ():tvs)+    split orig_ty ty tvs | Just ty' <- coreView ty = split orig_ty ty' tvs+    split orig_ty _                   tvs          = (reverse tvs, orig_ty)++-- | Like 'splitForAllTyCoVars', but only splits 'ForAllTy's with 'Invisible' type+-- variable binders. Furthermore, each returned tyvar is annotated with its+-- 'Specificity'.+splitForAllInvisTyBinders :: Type -> ([InvisTyBinder], Type)+splitForAllInvisTyBinders ty = split ty ty []+  where+    split _ (ForAllTy (Bndr tv (Invisible spec)) ty) tvs = split ty ty (Bndr tv spec:tvs)+    split orig_ty ty tvs | Just ty' <- coreView ty       = split orig_ty ty' tvs+    split orig_ty _                   tvs                = (reverse tvs, orig_ty)++-- | Checks whether this is a proper forall (with a named binder)+isForAllTy :: Type -> Bool+isForAllTy ty+  | ForAllTy {} <- coreFullView ty = True+  | otherwise                      = False++-- | Like `isForAllTy`, but returns True only if it is a tyvar binder+isForAllTy_ty :: Type -> Bool+isForAllTy_ty ty+  | ForAllTy (Bndr tv _) _ <- coreFullView ty+  , isTyVar tv+  = True++  | otherwise = False++-- | Like `isForAllTy`, but returns True only if it is an inferred tyvar binder+isForAllTy_invis_ty :: Type -> Bool+isForAllTy_invis_ty  ty+  | ForAllTy (Bndr tv (Invisible InferredSpec)) _ <- coreFullView ty+  , isTyVar tv+  = True++  | otherwise = False++-- | Like `isForAllTy`, but returns True only if it is a covar binder+isForAllTy_co :: Type -> Bool+isForAllTy_co ty+  | ForAllTy (Bndr tv _) _ <- coreFullView ty+  , isCoVar tv+  = True++  | otherwise = False++-- | Is this a function or forall?+isPiTy :: Type -> Bool+isPiTy ty = case coreFullView ty of+  ForAllTy {} -> True+  FunTy {}    -> True+  _           -> False++-- | Is this a function?+-- Note: `forall {b}. Show b => b -> IO b` will not be considered a function by this function.+--       It would merely be a forall wrapping a function type.+isFunTy :: Type -> Bool+isFunTy ty+  | FunTy {} <- coreFullView ty = True+  | otherwise                   = False++-- | Take a forall type apart, or panics if that is not possible.+splitForAllTyCoVar :: Type -> (TyCoVar, Type)+splitForAllTyCoVar ty+  | Just answer <- splitForAllTyCoVar_maybe ty = answer+  | otherwise                                  = pprPanic "splitForAllTyCoVar" (ppr ty)++-- | Drops all ForAllTys+dropForAlls :: Type -> Type+dropForAlls ty = go ty+  where+    go (ForAllTy _ res)            = go res+    go ty | Just ty' <- coreView ty = go ty'+    go res                         = res++-- | Attempts to take a ForAllTy apart, returning the full ForAllTyBinder+splitForAllForAllTyBinder_maybe :: Type -> Maybe (ForAllTyBinder, Type)+splitForAllForAllTyBinder_maybe ty+  | ForAllTy bndr inner_ty <- coreFullView ty = Just (bndr, inner_ty)+  | otherwise                                 = Nothing+++-- | Attempts to take a ForAllTy apart, returning the Var+splitForAllTyCoVar_maybe :: Type -> Maybe (TyCoVar, Type)+splitForAllTyCoVar_maybe ty+  | ForAllTy (Bndr tv _) inner_ty <- coreFullView ty = Just (tv, inner_ty)+  | otherwise                                        = Nothing++-- | Attempts to take a ForAllTy apart, but only if the binder is a TyVar+splitForAllTyVar_maybe :: Type -> Maybe (TyVar, Type)+splitForAllTyVar_maybe ty+  | ForAllTy (Bndr tv _) inner_ty <- coreFullView ty+  , isTyVar tv+  = Just (tv, inner_ty)++  | otherwise = Nothing++-- | Like 'splitForAllTyCoVar_maybe', but only returns Just if it is a covar binder.+splitForAllCoVar_maybe :: Type -> Maybe (CoVar, Type)+splitForAllCoVar_maybe ty+  | ForAllTy (Bndr tv _) inner_ty <- coreFullView ty+  , isCoVar tv+  = Just (tv, inner_ty)++  | otherwise = Nothing++-- | Attempts to take a forall type apart; works with proper foralls and+-- functions+{-# INLINE splitPiTy_maybe #-}  -- callers will immediately deconstruct+splitPiTy_maybe :: Type -> Maybe (PiTyBinder, Type)+splitPiTy_maybe ty = case coreFullView ty of+  ForAllTy bndr ty -> Just (Named bndr, ty)+  FunTy { ft_af = af, ft_mult = w, ft_arg = arg, ft_res = res}+                   -> Just (Anon (mkScaled w arg) af, res)+  _                -> Nothing++-- | Takes a forall type apart, or panics+splitPiTy :: Type -> (PiTyBinder, Type)+splitPiTy ty+  | Just answer <- splitPiTy_maybe ty = answer+  | otherwise                         = pprPanic "splitPiTy" (ppr ty)++-- | Split off all PiTyBinders to a type, splitting both proper foralls+-- and functions+splitPiTys :: Type -> ([PiTyBinder], Type)+splitPiTys ty = split ty ty []+  where+    split _       (ForAllTy b res) bs = split res res (Named b  : bs)+    split _       (FunTy { ft_af = af, ft_mult = w, ft_arg = arg, ft_res = res }) bs+                                      = split res res (Anon (Scaled w arg) af : bs)+    split orig_ty ty bs | Just ty' <- coreView ty = split orig_ty ty' bs+    split orig_ty _                bs = (reverse bs, orig_ty)++collectPiTyBinders :: Type -> [PiTyBinder]+collectPiTyBinders ty = build $ \c n ->+  let+    split (ForAllTy b res) = Named b `c` split res+    split (FunTy { ft_af = af, ft_mult = w, ft_arg = arg, ft_res = res })+                           = Anon (Scaled w arg) af `c` split res+    split ty | Just ty' <- coreView ty = split ty'+    split _                = n+  in+    split ty+{-# INLINE collectPiTyBinders #-}++-- | Extracts a list of run-time arguments from a function type,+-- looking through newtypes to the right of arrows.+--+-- Examples:+--+-- @+--    newtype Identity a = I a+--+--    getRuntimeArgTys (Int -> Bool -> Double) == [(Int, FTF_T_T), (Bool, FTF_T_T)]+--    getRuntimeArgTys (Identity Int -> Bool -> Double) == [(Identity Int, FTF_T_T), (Bool, FTF_T_T)]+--    getRuntimeArgTys (Int -> Identity (Bool -> Identity Double)) == [(Int, FTF_T_T), (Bool, FTF_T_T)]+--    getRuntimeArgTys (forall a. Show a => Identity a -> a -> Int -> Bool)+--             == [(Show a, FTF_C_T), (Identity a, FTF_T_T),(a, FTF_T_T),(Int, FTF_T_T)]+-- @+--+-- Note that, in the last case, the returned types might mention an out-of-scope+-- type variable. This function is used only when we really care about the /kinds/+-- of the returned types, so this is OK.+--+-- **Warning**: this function can return an infinite list. For example:+--+-- @+--   newtype N a = MkN (a -> N a)+--   getRuntimeArgTys (N a) == repeat (a, FTF_T_T)+-- @+getRuntimeArgTys :: Type -> [(Scaled Type, FunTyFlag)]+getRuntimeArgTys = go+  where+    go :: Type -> [(Scaled Type, FunTyFlag)]+    go (ForAllTy _ res)+      = go res+    go (FunTy { ft_mult = w, ft_arg = arg, ft_res = res, ft_af = af })+      = (Scaled w arg, af) : go res+    go ty+      | Just ty' <- coreView ty+      = go ty'+      | Just (_,ty') <- topNormaliseNewType_maybe ty+      = go ty'+      | otherwise+      = []++invisibleBndrCount :: Type -> Int+-- Returns the number of leading invisible forall'd binders in the type+-- Includes invisible predicate arguments; e.g. for+--    e.g.  forall {k}. (k ~ *) => k -> k+-- returns 2 not 1+invisibleBndrCount ty = length (fst (splitInvisPiTys ty))++-- | Like 'splitPiTys', but returns only *invisible* binders, including constraints.+-- Stops at the first visible binder.+splitInvisPiTys :: Type -> ([PiTyBinder], Type)+splitInvisPiTys ty = split ty ty []+   where+    split _ (ForAllTy b res) bs+      | Bndr _ vis <- b+      , isInvisibleForAllTyFlag vis   = split res res (Named b  : bs)+    split _ (FunTy { ft_af = af, ft_mult = mult, ft_arg = arg, ft_res = res })  bs+      | isInvisibleFunArg af     = split res res (Anon (mkScaled mult arg) af : bs)+    split orig_ty ty bs+      | Just ty' <- coreView ty  = split orig_ty ty' bs+    split orig_ty _          bs  = (reverse bs, orig_ty)++splitInvisPiTysN :: Int -> Type -> ([PiTyBinder], Type)+-- ^ Same as 'splitInvisPiTys', but stop when+--   - you have found @n@ 'PiTyBinder's,+--   - or you run out of invisible binders+splitInvisPiTysN n ty = split n ty ty []+   where+    split n orig_ty ty bs+      | n == 0                  = (reverse bs, orig_ty)+      | Just ty' <- coreView ty = split n orig_ty ty' bs+      | ForAllTy b res <- ty+      , Bndr _ vis <- b+      , isInvisibleForAllTyFlag vis  = split (n-1) res res (Named b  : bs)+      | FunTy { ft_af = af, ft_mult = mult, ft_arg = arg, ft_res = res } <- ty+      , isInvisibleFunArg af   = split (n-1) res res (Anon (Scaled mult arg) af : bs)+      | otherwise              = (reverse bs, orig_ty)++-- | Given a 'TyCon' and a list of argument types, filter out any invisible+-- (i.e., 'Inferred' or 'Specified') arguments.+filterOutInvisibleTypes :: TyCon -> [Type] -> [Type]+filterOutInvisibleTypes tc tys = snd $ partitionInvisibleTypes tc tys++-- | Given a 'TyCon' and a list of argument types, filter out any 'Inferred'+-- arguments.+filterOutInferredTypes :: TyCon -> [Type] -> [Type]+filterOutInferredTypes tc tys =+  filterByList (map (/= Inferred) $ tyConForAllTyFlags tc tys) tys++-- | Given a 'TyCon' and a list of argument types, partition the arguments+-- into:+--+-- 1. 'Inferred' or 'Specified' (i.e., invisible) arguments and+--+-- 2. 'Required' (i.e., visible) arguments+partitionInvisibleTypes :: TyCon -> [Type] -> ([Type], [Type])+partitionInvisibleTypes tc tys =+  partitionByList (map isInvisibleForAllTyFlag $ tyConForAllTyFlags tc tys) tys++-- | Given a list of things paired with their visibilities, partition the+-- things into (invisible things, visible things).+partitionInvisibles :: [(a, ForAllTyFlag)] -> ([a], [a])+partitionInvisibles = partitionWith pick_invis+  where+    pick_invis :: (a, ForAllTyFlag) -> Either a a+    pick_invis (thing, vis) | isInvisibleForAllTyFlag vis = Left thing+                            | otherwise              = Right thing++-- | Given a 'TyCon' and a list of argument types to which the 'TyCon' is+-- applied, determine each argument's visibility+-- ('Inferred', 'Specified', or 'Required').+--+-- Wrinkle: consider the following scenario:+--+-- > T :: forall k. k -> k+-- > tyConForAllTyFlags T [forall m. m -> m -> m, S, R, Q]+--+-- After substituting, we get+--+-- > T (forall m. m -> m -> m) :: (forall m. m -> m -> m) -> forall n. n -> n -> n+--+-- Thus, the first argument is invisible, @S@ is visible, @R@ is invisible again,+-- and @Q@ is visible.+tyConForAllTyFlags :: TyCon -> [Type] -> [ForAllTyFlag]+tyConForAllTyFlags tc = fun_kind_arg_flags (tyConKind tc)++-- | Given a 'Type' and a list of argument types to which the 'Type' is+-- applied, determine each argument's visibility+-- ('Inferred', 'Specified', or 'Required').+--+-- Most of the time, the arguments will be 'Required', but not always. Consider+-- @f :: forall a. a -> Type@. In @f Type Bool@, the first argument (@Type@) is+-- 'Specified' and the second argument (@Bool@) is 'Required'. It is precisely+-- this sort of higher-rank situation in which 'appTyForAllTyFlags' comes in handy,+-- since @f Type Bool@ would be represented in Core using 'AppTy's.+-- (See also #15792).+appTyForAllTyFlags :: Type -> [Type] -> [ForAllTyFlag]+appTyForAllTyFlags ty = fun_kind_arg_flags (typeKind ty)++-- | Given a function kind and a list of argument types (where each argument's+-- kind aligns with the corresponding position in the argument kind), determine+-- each argument's visibility ('Inferred', 'Specified', or 'Required').+fun_kind_arg_flags :: Kind -> [Type] -> [ForAllTyFlag]+fun_kind_arg_flags = go emptySubst+  where+    go subst ki arg_tys+      | Just ki' <- coreView ki = go subst ki' arg_tys+    go _ _ [] = []+    go subst (ForAllTy (Bndr tv argf) res_ki) (arg_ty:arg_tys)+      = argf : go subst' res_ki arg_tys+      where+        subst' = extendTvSubst subst tv arg_ty+    go subst (TyVarTy tv) arg_tys+      | Just ki <- lookupTyVar subst tv = go subst ki arg_tys+    -- This FunTy case is important to handle kinds with nested foralls, such+    -- as this kind (inspired by #16518):+    --+    --   forall {k1} k2. k1 -> k2 -> forall k3. k3 -> Type+    --+    -- Here, we want to get the following ForAllTyFlags:+    --+    -- [Inferred,   Specified, Required, Required, Specified, Required]+    -- forall {k1}. forall k2. k1 ->     k2 ->     forall k3. k3 ->     Type+    go subst (FunTy{ft_af = af, ft_res = res_ki}) (_:arg_tys)+      = argf : go subst res_ki arg_tys+      where+        argf | isVisibleFunArg af = Required+             | otherwise          = Inferred+    go _ _ arg_tys = map (const Required) arg_tys+                        -- something is ill-kinded. But this can happen+                        -- when printing errors. Assume everything is Required.++-- @isTauTy@ tests if a type has no foralls or (=>)+isTauTy :: Type -> Bool+isTauTy ty | Just ty' <- coreView ty = isTauTy ty'+isTauTy (TyVarTy _)       = True+isTauTy (LitTy {})        = True+isTauTy (TyConApp tc tys) = all isTauTy tys && isTauTyCon tc+isTauTy (AppTy a b)       = isTauTy a && isTauTy b+isTauTy (FunTy { ft_af = af, ft_mult = w, ft_arg = a, ft_res = b })+ | isInvisibleFunArg af   = False                               -- e.g., Eq a => b+ | otherwise              = isTauTy w && isTauTy a && isTauTy b -- e.g., a -> b+isTauTy (ForAllTy {})     = False+isTauTy (CastTy ty _)     = isTauTy ty+isTauTy (CoercionTy _)    = False  -- Not sure about this++isAtomicTy :: Type -> Bool+-- True if the type is just a single token, and can be printed compactly+-- Used when deciding how to lay out type error messages; see the+-- call in GHC.Tc.Errors+isAtomicTy (TyVarTy {})    = True+isAtomicTy (LitTy {})      = True+isAtomicTy (TyConApp _ []) = True++isAtomicTy ty | isLiftedTypeKind ty = True+   -- 'Type' prints compactly as *+   -- See GHC.Iface.Type.ppr_kind_type++isAtomicTy _ = False++{-+************************************************************************+*                                                                      *+\subsection{Type families}+*                                                                      *+************************************************************************+-}++mkFamilyTyConApp :: TyCon -> [Type] -> Type+-- ^ Given a family instance TyCon and its arg types, return the+-- corresponding family type.  E.g:+--+-- > data family T a+-- > data instance T (Maybe b) = MkT b+--+-- Where the instance tycon is :RTL, so:+--+-- > mkFamilyTyConApp :RTL Int  =  T (Maybe Int)+mkFamilyTyConApp tc tys+  | Just (fam_tc, fam_tys) <- tyConFamInst_maybe tc+  , let tvs = tyConTyVars tc+        fam_subst = assertPpr (tvs `equalLength` tys) (ppr tc <+> ppr tys) $+                    zipTvSubst tvs tys+  = mkTyConApp fam_tc (substTys fam_subst fam_tys)+  | otherwise+  = mkTyConApp tc tys++-- | Get the type on the LHS of a coercion induced by a type/data+-- family instance.+coAxNthLHS :: CoAxiom br -> Int -> Type+coAxNthLHS ax ind =+  mkTyConApp (coAxiomTyCon ax) (coAxBranchLHS (coAxiomNthBranch ax ind))++isFamFreeTy :: Type -> Bool+isFamFreeTy ty | Just ty' <- coreView ty = isFamFreeTy ty'+isFamFreeTy (TyVarTy _)       = True+isFamFreeTy (LitTy {})        = True+isFamFreeTy (TyConApp tc tys) = all isFamFreeTy tys && isFamFreeTyCon tc+isFamFreeTy (AppTy a b)       = isFamFreeTy a && isFamFreeTy b+isFamFreeTy (FunTy _ w a b)   = isFamFreeTy w && isFamFreeTy a && isFamFreeTy b+isFamFreeTy (ForAllTy _ ty)   = isFamFreeTy ty+isFamFreeTy (CastTy ty _)     = isFamFreeTy ty+isFamFreeTy (CoercionTy _)    = False  -- Not sure about this++-- | Check whether a type is a data family type+isDataFamilyApp :: Type -> Bool+isDataFamilyApp ty = case tyConAppTyCon_maybe ty of+                           Just tc -> isDataFamilyTyCon tc+                           _       -> False++isSatTyFamApp :: Type -> Maybe (TyCon, [Type])+-- Return the argument if we have a saturated type family application+-- Why saturated?  See (ATF4) in Note [Apartness and type families]+isSatTyFamApp (TyConApp tc tys)+  |  isTypeFamilyTyCon tc+  && not (tys `lengthExceeds` tyConArity tc)  -- Not over-saturated+  = Just (tc, tys)+isSatTyFamApp _ = Nothing++buildSynTyCon :: Name -> [KnotTied TyConBinder] -> Kind   -- ^ /result/ kind+              -> [Role] -> KnotTied Type -> TyCon+-- This function is here because here is where we have+--   isFamFree and isTauTy+buildSynTyCon name binders res_kind roles rhs+  = mkSynonymTyCon name binders res_kind roles rhs+                   is_tau is_fam_free is_forgetful is_concrete+  where+    qtvs         = mkVarSet (map binderVar binders)+    is_tau       = isTauTy rhs+    is_fam_free  = isFamFreeTy rhs+    is_concrete  = isConcreteTypeWith qtvs rhs+    is_forgetful = not (qtvs `subVarSet` expanded_rhs_tyvars)++    expanded_rhs_tyvars = tyCoVarsOfType (expandTypeSynonyms rhs)+       -- See Note [Forgetful type synonyms] in GHC.Core.TyCon+       -- To find out if this TyCon is forgetful, expand the synonyms in its RHS+       -- and check that all of the binders are free in the expanded type.+       -- We really only need to expand the /forgetful/ synonyms on the RHS,+       -- but we don't currently have a function to do that.+       -- Failing to expand the RHS led to #25094, e.g.+       --    type Bucket a b c = Key (a,b,c)+       --    type Key x = Any+       -- Here Bucket is definitely forgetful!++{-+************************************************************************+*                                                                      *+\subsection{Liftedness}+*                                                                      *+************************************************************************+-}++-- | Tries to compute the 'Levity' of the given type. Returns either+-- a definite 'Levity', or 'Nothing' if we aren't sure (e.g. the+-- type is representation-polymorphic).+--+-- Panics if the kind does not have the shape @TYPE r@.+typeLevity_maybe :: HasDebugCallStack => Type -> Maybe Levity+typeLevity_maybe ty = runtimeRepLevity_maybe (getRuntimeRep ty)++typeLevity :: HasDebugCallStack => Type -> Levity+typeLevity ty = case typeLevity_maybe ty of+                   Just lev -> lev+                   Nothing  -> pprPanic "typeLevity" (ppr ty)++-- | Is the given type definitely unlifted?+-- See "Type#type_classification" for what an unlifted type is.+--+-- Panics on representation-polymorphic types; See 'mightBeUnliftedType' for+-- a more approximate predicate that behaves better in the presence of+-- representation polymorphism.+isUnliftedType :: HasDebugCallStack => Type -> Bool+        -- isUnliftedType returns True for forall'd unlifted types:+        --      x :: forall a. Int#+        -- I found bindings like these were getting floated to the top level.+isUnliftedType ty =+  case typeLevity_maybe ty of+    Just Lifted   -> False+    Just Unlifted -> True+    Nothing       -> pprPanic "isUnliftedType" (ppr ty <+> dcolon <+> ppr (typeKind ty))++-- | Returns:+--+-- * 'False' if the type is /guaranteed/ unlifted or+-- * 'True' if it lifted, OR we aren't sure+--    (e.g. in a representation-polymorphic case)+mightBeLiftedType :: Type -> Bool+mightBeLiftedType = mightBeLifted . typeLevity_maybe++definitelyLiftedType :: Type -> Bool+definitelyLiftedType = not . mightBeUnliftedType++-- | Returns:+--+-- * 'False' if the type is /guaranteed/ lifted or+-- * 'True' if it is unlifted, OR we aren't sure+--    (e.g. in a representation-polymorphic case)+mightBeUnliftedType :: Type -> Bool+mightBeUnliftedType = mightBeUnlifted . typeLevity_maybe++definitelyUnliftedType :: Type -> Bool+definitelyUnliftedType = not . mightBeLiftedType++-- | See "Type#type_classification" for what a boxed type is.+-- Panics on representation-polymorphic types; See 'mightBeUnliftedType' for+-- a more approximate predicate that behaves better in the presence of+-- representation polymorphism.+isBoxedType :: Type -> Bool+isBoxedType ty = isBoxedRuntimeRep (getRuntimeRep ty)++-- | Is this a type of kind RuntimeRep? (e.g. LiftedRep)+isRuntimeRepKindedTy :: Type -> Bool+isRuntimeRepKindedTy = isRuntimeRepTy . typeKind++-- | Drops prefix of RuntimeRep constructors in 'TyConApp's. Useful for e.g.+-- dropping 'LiftedRep arguments of unboxed tuple TyCon applications:+--+--   dropRuntimeRepArgs [ 'LiftedRep, 'IntRep+--                      , String, Int# ] == [String, Int#]+--+dropRuntimeRepArgs :: [Type] -> [Type]+dropRuntimeRepArgs = dropWhile isRuntimeRepKindedTy++-- | Extract the RuntimeRep classifier of a type. For instance,+-- @getRuntimeRep_maybe Int = Just LiftedRep@. Returns 'Nothing' if this is not+-- possible.+getRuntimeRep_maybe :: HasDebugCallStack+                    => Type -> Maybe RuntimeRepType+getRuntimeRep_maybe = kindRep_maybe . typeKind++-- | Extract the RuntimeRep classifier of a type. For instance,+-- @getRuntimeRep_maybe Int = LiftedRep@. Panics if this is not possible.+getRuntimeRep :: HasDebugCallStack => Type -> RuntimeRepType+getRuntimeRep ty+  = case getRuntimeRep_maybe ty of+      Just r  -> r+      Nothing -> pprPanic "getRuntimeRep" (ppr ty <+> dcolon <+> ppr (typeKind ty))++-- | Extract the 'Levity' of a type. For example, @getLevity_maybe Int = Just Lifted@,+-- @getLevity (Array# Int) = Just Unlifted@, @getLevity Float# = Nothing@.+--+-- Returns 'Nothing' if this is not possible. Does not look through type family applications.+getLevity_maybe :: HasDebugCallStack => Type -> Maybe Type+getLevity_maybe ty+  | Just rep <- getRuntimeRep_maybe ty+  -- Directly matching on TyConApp after expanding type synonyms+  -- saves allocations compared to `splitTyConApp_maybe`. See #22254.+  -- Given that this is a pretty hot function we make use of the fact+  -- and use isTyConKeyApp_maybe instead.+  , Just [lev] <- isTyConKeyApp_maybe boxedRepDataConKey rep+  = Just lev+  | otherwise+  = Nothing++-- | Extract the 'Levity' of a type. For example, @getLevity Int = Lifted@,+-- or @getLevity (Array# Int) = Unlifted@.+--+-- Panics if this is not possible. Does not look through type family applications.+getLevity :: HasDebugCallStack => Type -> Type+getLevity ty+  | Just lev <- getLevity_maybe ty+  = lev+  | otherwise+  = pprPanic "getLevity" (ppr ty <+> dcolon <+> ppr (typeKind ty))++isUnboxedTupleType :: Type -> Bool+isUnboxedTupleType ty+  = tyConAppTyCon (getRuntimeRep ty) `hasKey` tupleRepDataConKey+  -- NB: Do not use typePrimRep, as that can't tell the difference between+  -- unboxed tuples and unboxed sums+++isUnboxedSumType :: Type -> Bool+isUnboxedSumType ty+  = tyConAppTyCon (getRuntimeRep ty) `hasKey` sumRepDataConKey++-- | See "Type#type_classification" for what an algebraic type is.+-- Should only be applied to /types/, as opposed to e.g. partially+-- saturated type constructors+isAlgType :: Type -> Bool+isAlgType ty+  = case splitTyConApp_maybe ty of+      Just (tc, ty_args) -> assert (ty_args `lengthIs` tyConArity tc )+                            isAlgTyCon tc+      _other             -> False++-- | Computes whether an argument (or let right hand side) should+-- be computed strictly or lazily, based only on its type.+-- Currently, it's just 'isUnliftedType'.+-- Panics on representation-polymorphic types.+isStrictType :: HasDebugCallStack => Type -> Bool+isStrictType = isUnliftedType++isTerminatingType :: HasDebugCallStack => Type -> Bool+-- ^ True <=> a term of this type cannot be bottom+-- This identifies the types described by+--    Note [NON-BOTTOM-DICTS invariant] in GHC.Core+-- NB: unlifted types are not terminating types!+--     e.g. you can write a term (loop 1)::Int# that diverges.+isTerminatingType ty = case tyConAppTyCon_maybe ty of+    Just tc -> isClassTyCon tc && not (isUnaryClassTyCon tc)+               -- A non-unary class TyCon is terminating+               -- See (UCM3) in Note [Unary class magic] in GHC.Core.TyCon+    _       -> False++isPrimitiveType :: Type -> Bool+-- ^ Returns true of types that are opaque to Haskell.+isPrimitiveType ty = case splitTyConApp_maybe ty of+                        Just (tc, ty_args) -> assert (ty_args `lengthIs` tyConArity tc )+                                              isPrimTyCon tc+                        _                  -> False++{-+************************************************************************+*                                                                      *+\subsection{Join points}+*                                                                      *+************************************************************************+-}++-- | Determine whether a type could be the type of a join point of given total+-- arity, according to the polymorphism rule. A join point cannot be polymorphic+-- in its return type, since given+--   join j @a @b x y z = e1 in e2,+-- the types of e1 and e2 must be the same, and a and b are not in scope for e2.+-- (See Note [The polymorphism rule of join points] in "GHC.Core".) Returns False+-- also if the type simply doesn't have enough arguments.+--+-- Note that we need to know how many arguments (type *and* value) the putative+-- join point takes; for instance, if+--   j :: forall a. a -> Int+-- then j could be a binary join point returning an Int, but it could *not* be a+-- unary join point returning a -> Int.+--+-- TODO: See Note [Excess polymorphism and join points]+isValidJoinPointType :: JoinArity -> Type -> Bool+isValidJoinPointType arity ty+  = valid_under emptyVarSet arity ty+  where+    valid_under tvs arity ty+      | arity == 0+      = tvs `disjointVarSet` tyCoVarsOfType ty+      | Just (t, ty') <- splitForAllTyCoVar_maybe ty+      = valid_under (tvs `extendVarSet` t) (arity-1) ty'+      | Just (_, _, _, res_ty) <- splitFunTy_maybe ty+      = valid_under tvs (arity-1) res_ty+      | otherwise+      = False++{- Note [Excess polymorphism and join points]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In principle, if a function would be a join point except that it fails+the polymorphism rule (see Note [The polymorphism rule of join points] in+GHC.Core), it can still be made a join point with some effort. This is because+all tail calls must return the same type (they return to the same context!), and+thus if the return type depends on an argument, that argument must always be the+same.++For instance, consider:++  let f :: forall a. a -> Char -> [a]+      f @a x c = ... f @a y 'a' ...+  in ... f @Int 1 'b' ... f @Int 2 'c' ...++(where the calls are tail calls). `f` fails the polymorphism rule because its+return type is [a], where [a] is bound. But since the type argument is always+'Int', we can rewrite it as:++  let f' :: Int -> Char -> [Int]+      f' x c = ... f' y 'a' ...+  in ... f' 1 'b' ... f 2 'c' ...++and now we can make f' a join point:++  join f' :: Int -> Char -> [Int]+       f' x c = ... jump f' y 'a' ...+  in ... jump f' 1 'b' ... jump f' 2 'c' ...++It's not clear that this comes up often, however. TODO: Measure how often and+add this analysis if necessary.  See #14620.+++************************************************************************+*                                                                      *+\subsection{Sequencing on types}+*                                                                      *+************************************************************************+-}++seqType :: Type -> ()+seqType (LitTy n)                   = n `seq` ()+seqType (TyVarTy tv)                = tv `seq` ()+seqType (AppTy t1 t2)               = seqType t1 `seq` seqType t2+seqType (FunTy _ w t1 t2)           = seqType w `seq` seqType t1 `seq` seqType t2+seqType (TyConApp tc tys)           = tc `seq` seqTypes tys+seqType (ForAllTy (Bndr tv _) ty)   = seqType (varType tv) `seq` seqType ty+seqType (CastTy ty co)              = seqType ty `seq` seqCo co+seqType (CoercionTy co)             = seqCo co++seqTypes :: [Type] -> ()+seqTypes []       = ()+seqTypes (ty:tys) = seqType ty `seq` seqTypes tys++{-+************************************************************************+*                                                                      *+        The kind of a type+*                                                                      *+************************************************************************++Note [Kinding rules for types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Here are the key kinding rules for types++          torc1 is TYPE or CONSTRAINT+          torc2 is TYPE or CONSTRAINT+          t1 : torc1 rep1+          t2 : torc2 rep2+   (FUN)  ----------------+          t1 -> t2 : torc2 LiftedRep+          -- In fact the arrow varies with torc1/torc2+          -- See Note [Function type constructors and FunTy]+          -- in GHC.Builtin.Types.Prim++          torc is TYPE or CONSTRAINT+          ty : body_torc rep+          ki : Type+          `a` is a type variable+          `a` is not free in rep+(FORALL1) -----------------------+          forall (a::ki). ty : body_torc rep++          torc is TYPE or CONSTRAINT+          ty : body_torc rep+          `c` is a coercion variable+          `c` is not free in rep+          `c` is free in ty       -- Surprise 1!+(FORALL2) -------------------------+          forall (cv::k1 ~#{N,R} k2). ty : body_torc LiftedRep+                                           -- Surprise 2!++Note that:+* (FORALL1) rejects (forall (a::Maybe). blah)++* (FORALL2) Surprise 1:+  See GHC.Core.TyCo.Rep Note [Unused coercion variable in ForAllTy]++* (FORALL2) Surprise 2: coercion abstractions are not erased, so+  this must be LiftedRep, just like (FUN).  (FORALL2) is just a+  dependent form of (FUN).+++Note [Phantom type variables in kinds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider++  type K (r :: RuntimeRep) = Type   -- Note 'r' is unused+  data T r :: K r                   -- T :: forall r -> K r+  foo :: forall r. T r++The body of the forall in foo's type has kind (K r), and+normally it would make no sense to have+   forall r. (ty :: K r)+because the kind of the forall would escape the binding+of 'r'.  But in this case it's fine because (K r) expands+to Type, so we explicitly /permit/ the type+   forall r. T r++To accommodate such a type, in typeKind (forall a.ty) we use+occCheckExpand to expand any type synonyms in the kind of 'ty'+to eliminate 'a'.  See kinding rule (FORALL) in+Note [Kinding rules for types]+++See also+ * GHC.Core.Type.occCheckExpand+ * GHC.Core.Utils.coreAltsType+ * GHC.Tc.Validity.checkEscapingKind+all of which grapple with the same problem.++See #14939.+-}++-----------------------------+typeKind :: HasDebugCallStack => Type -> Kind+-- No need to expand synonyms+typeKind (TyConApp tc tys)      = piResultTys (tyConKind tc) tys+typeKind (LitTy l)              = typeLiteralKind l+typeKind (FunTy { ft_af = af }) = liftedTypeOrConstraintKind (funTyFlagResultTypeOrConstraint af)+typeKind (TyVarTy tyvar)        = tyVarKind tyvar+typeKind (CastTy _ty co)        = coercionRKind co+typeKind (CoercionTy co)        = coercionType co++typeKind (AppTy fun arg)+  = go fun [arg]+  where+    -- Accumulate the type arguments, so we can call piResultTys,+    -- rather than a succession of calls to piResultTy (which is+    -- asymptotically costly as the number of arguments increases)+    go (AppTy fun arg) args = go fun (arg:args)+    go fun             args = piResultTys (typeKind fun) args++typeKind ty@(ForAllTy {})+  = assertPpr (not (null tcvs)) (ppr ty) $+       -- If tcvs is empty somehow we'll get an infinite loop!+    case occCheckExpand tcvs body_kind of+      -- We must make sure tvs do not occur in kind,+      -- as they would be out of scope!+      -- See Note [Phantom type variables in kinds]+      Nothing -> pprPanic "typeKind"+                  (ppr ty $$ ppr tcvs $$ ppr body <+> dcolon <+> ppr body_kind)++      Just k' | all isTyVar tcvs -> k'                     -- Rule (FORALL1)+              | otherwise        -> lifted_kind_from_body  -- Rule (FORALL2)+  where+    (tcvs, body) = splitForAllTyCoVars ty  -- Important: splits both TyVar and CoVar binders+    body_kind    = typeKind body++    lifted_kind_from_body  -- Implements (FORALL2)+      = case sORTKind_maybe body_kind of+          Just (torc, _) -> liftedTypeOrConstraintKind torc+          Nothing        -> pprPanic "typeKind" (ppr body_kind)+++---------------------------------------------++sORTKind_maybe :: Kind -> Maybe (TypeOrConstraint, Type)+-- Sees if the argument is of form (TYPE rep) or (CONSTRAINT rep)+-- and if so returns which, and the runtime rep+--+-- This is a "hot" function.  Do not call splitTyConApp_maybe here,+-- to avoid the faff with FunTy+sORTKind_maybe (TyConApp tc tys)+  -- First, short-cuts for Type and Constraint that do no allocation+  | tc_uniq == liftedTypeKindTyConKey = assert( null tys ) $ Just (TypeLike,       liftedRepTy)+  | tc_uniq == constraintKindTyConKey = assert( null tys ) $ Just (ConstraintLike, liftedRepTy)+  | tc_uniq == tYPETyConKey           = get_rep TypeLike+  | tc_uniq == cONSTRAINTTyConKey     = get_rep ConstraintLike+  | Just ty' <- expandSynTyConApp_maybe tc tys = sORTKind_maybe ty'+  where+    !tc_uniq = tyConUnique tc+     -- This bang on tc_uniq is important.  It means that sORTKind_maybe starts+     -- by evaluating tc_uniq, and then ends up with a single case with a 4-way branch++    get_rep torc = case tys of+                     (rep:_reps) -> assert (null _reps) $ Just (torc, rep)+                     []          -> Nothing++sORTKind_maybe _ = Nothing++typeTypeOrConstraint :: HasDebugCallStack => Type -> TypeOrConstraint+-- Precondition: expects a type that classifies values.+-- Returns whether it is TypeLike or ConstraintLike.+-- Equivalent to calling sORTKind_maybe, but faster in the FunTy case+typeTypeOrConstraint ty+   = case coreFullView ty of+       FunTy { ft_af = af } -> funTyFlagResultTypeOrConstraint af+       ty' | Just (torc, _) <- sORTKind_maybe (typeKind ty')+          -> torc+          | otherwise+          -> pprPanic "typeOrConstraint" (ppr ty <+> dcolon <+> ppr (typeKind ty))++-- | Does this classify a type allowed to have values? Responds True to things+-- like *, TYPE Lifted, TYPE IntRep, TYPE v, Constraint.+isTYPEorCONSTRAINT :: Kind -> Bool+-- ^ True of a kind `TYPE _` or `CONSTRAINT _`+isTYPEorCONSTRAINT k = isJust (sORTKind_maybe k)++tyConIsTYPEorCONSTRAINT :: TyCon -> Bool+tyConIsTYPEorCONSTRAINT tc+  = tc_uniq == tYPETyConKey || tc_uniq == cONSTRAINTTyConKey+  where+    !tc_uniq = tyConUnique tc++isConstraintLikeKind :: Kind -> Bool+-- True of (CONSTRAINT _)+isConstraintLikeKind kind+  = case sORTKind_maybe kind of+      Just (ConstraintLike, _) -> True+      _                        -> False++isConstraintKind :: Kind -> Bool+-- True of (CONSTRAINT LiftedRep)+isConstraintKind kind+  = case sORTKind_maybe kind of+      Just (ConstraintLike, rep) -> isLiftedRuntimeRep rep+      _                          -> False++tcIsLiftedTypeKind :: Kind -> Bool+-- ^ Is this kind equivalent to 'Type' i.e. TYPE LiftedRep?+tcIsLiftedTypeKind kind+  | Just (TypeLike, rep) <- sORTKind_maybe kind+  = isLiftedRuntimeRep rep+  | otherwise+  = False++tcIsBoxedTypeKind :: Kind -> Bool+-- ^ Is this kind equivalent to @TYPE (BoxedRep l)@ for some @l :: Levity@?+tcIsBoxedTypeKind kind+  | Just (TypeLike, rep) <- sORTKind_maybe kind+  = isBoxedRuntimeRep rep+  | otherwise+  = False++-- | Is this kind equivalent to @TYPE r@ (for some unknown r)?+--+-- This considers 'Constraint' to be distinct from @*@.+isTypeLikeKind :: Kind -> Bool+isTypeLikeKind kind+  = case sORTKind_maybe kind of+      Just (TypeLike, _) -> True+      _                  -> False++returnsConstraintKind :: Kind -> Bool+-- True <=> the Kind ultimately returns a Constraint+--   E.g.  * -> Constraint+--         forall k. k -> Constraint+returnsConstraintKind kind+  | Just kind' <- coreView kind = returnsConstraintKind kind'+returnsConstraintKind (ForAllTy _ ty)         = returnsConstraintKind ty+returnsConstraintKind (FunTy { ft_res = ty }) = returnsConstraintKind ty+returnsConstraintKind kind                    = isConstraintLikeKind kind++--------------------------+typeLiteralKind :: TyLit -> Kind+typeLiteralKind (NumTyLit {}) = naturalTy+typeLiteralKind (StrTyLit {}) = typeSymbolKind+typeLiteralKind (CharTyLit {}) = charTy++-- | Returns True if a type has a syntactically fixed runtime rep,+-- as per Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete.+--+-- This function is equivalent to `isFixedRuntimeRepKind . typeKind`+-- but much faster.+--+-- __Precondition:__ The type has kind @('TYPE' blah)@+typeHasFixedRuntimeRep :: HasDebugCallStack => Type -> Bool+typeHasFixedRuntimeRep = go+  where+    go (TyConApp tc _)+      | tcHasFixedRuntimeRep tc = True+    go (FunTy {})               = True+    go (LitTy {})               = True+    go (ForAllTy _ ty)          = go ty+    go ty                       = isFixedRuntimeRepKind (typeKind ty)++-- | Checks that a kind of the form 'Type', 'Constraint'+-- or @'TYPE r@ is concrete. See 'isConcreteType'.+--+-- __Precondition:__ The type has kind `TYPE blah` or `CONSTRAINT blah`+isFixedRuntimeRepKind :: HasDebugCallStack => Kind -> Bool+isFixedRuntimeRepKind k+  = assertPpr (isTYPEorCONSTRAINT k) (ppr k) $+    -- the isLiftedTypeKind check is necessary b/c of Constraint+    isConcreteType k++-- | Tests whether the given type is concrete, i.e. it+-- whether it consists only of concrete type constructors,+-- concrete type variables, and applications.+--+-- See Note [Concrete types] in GHC.Tc.Utils.Concrete.+isConcreteType :: Type -> Bool+isConcreteType = isConcreteTypeWith emptyVarSet++-- | Like 'isConcreteType', but allows passing in a set of 'TyVar's that+-- should be considered concrete.+--+-- See Note [Concrete types] in GHC.Tc.Utils.Concrete.+isConcreteTypeWith :: TyVarSet -> Type -> Bool+-- This version, with a 'TyVarSet' argument, supports 'mkSynonymTyCon',+-- which needs to test the RHS for concreteness, under the assumption that+-- the binders are instantiated to concrete types+isConcreteTypeWith conc_tvs = go+  where+    go (TyVarTy tv)        = isConcreteTyVar tv || tv `elemVarSet` conc_tvs+    go (AppTy ty1 ty2)     = go ty1 && go ty2+    go (TyConApp tc tys)   = go_tc tc tys+    go ForAllTy{}          = False+    go (FunTy _ w t1 t2)   =  go w+                           && go (typeKind t1) && go t1+                           && go (typeKind t2) && go t2+    go LitTy{}             = True+    go CastTy{}            = False+    go CoercionTy{}        = False++    go_tc :: TyCon -> [Type] -> Bool+    go_tc tc tys+      | isForgetfulSynTyCon tc  -- E.g. type S a = Int+                                -- Then (S x) is concrete even if x isn't+      , Just ty' <- expandSynTyConApp_maybe tc tys+      = go ty'++      -- Apart from forgetful synonyms, isConcreteTyCon+      -- is enough; no need to expand.  This is good for e.g+      --      type LiftedRep = BoxedRep Lifted+      | isConcreteTyCon tc+      = all go tys++      | otherwise  -- E.g. type families+      = False++{-+%************************************************************************+%*                                                                      *+         Pretty-printing+%*                                                                      *+%************************************************************************++Most pretty-printing is either in GHC.Core.TyCo.Rep or GHC.Iface.Type.++-}++-- | Does a 'TyCon' (that is applied to some number of arguments) need to be+-- ascribed with an explicit kind signature to resolve ambiguity if rendered as+-- a source-syntax type?+-- (See @Note [When does a tycon application need an explicit kind signature?]@+-- for a full explanation of what this function checks for.)+tyConAppNeedsKindSig+  :: Bool  -- ^ Should specified binders count towards injective positions in+           --   the kind of the TyCon? (If you're using visible kind+           --   applications, then you want True here.+  -> TyCon+  -> Int   -- ^ The number of args the 'TyCon' is applied to.+  -> Bool  -- ^ Does @T t_1 ... t_n@ need a kind signature? (Where @n@ is the+           --   number of arguments)+tyConAppNeedsKindSig spec_inj_pos tc n_args+  | LT <- listLengthCmp tc_binders n_args+  = False+  | otherwise+  = let (dropped_binders, remaining_binders)+          = splitAt n_args tc_binders+        result_kind  = mkTyConKind remaining_binders tc_res_kind+        result_vars  = tyCoVarsOfType result_kind+        dropped_vars = fvVarSet $+                       mapUnionFV injective_vars_of_binder dropped_binders++    in not (subVarSet result_vars dropped_vars)+  where+    tc_binders  = tyConBinders tc+    tc_res_kind = tyConResKind tc++    -- Returns the variables that would be fixed by knowing a TyConBinder. See+    -- Note [When does a tycon application need an explicit kind signature?]+    -- for a more detailed explanation of what this function does.+    injective_vars_of_binder :: TyConBinder -> FV+    injective_vars_of_binder (Bndr tv vis) =+      case vis of+        AnonTCB        -> injectiveVarsOfType False -- conservative choice+                                              (varType tv)+        NamedTCB argf  | source_of_injectivity argf+                       -> unitFV tv `unionFV`+                          injectiveVarsOfType False (varType tv)+        _              -> emptyFV++    source_of_injectivity Required  = True+    source_of_injectivity Specified = spec_inj_pos+    source_of_injectivity Inferred  = False++{-+Note [When does a tycon application need an explicit kind signature?]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There are a couple of places in GHC where we convert Core Types into forms that+more closely resemble user-written syntax. These include:++1. Template Haskell Type reification (see, for instance, GHC.Tc.Gen.Splice.reify_tc_app)+2. Converting Types to LHsTypes (such as in Haddock.Convert in haddock)++This conversion presents a challenge: how do we ensure that the resulting type+has enough kind information so as not to be ambiguous? To better motivate this+question, consider the following Core type:++  -- Foo :: Type -> Type+  type Foo = Proxy Type++There is nothing ambiguous about the RHS of Foo in Core. But if we were to,+say, reify it into a TH Type, then it's tempting to just drop the invisible+Type argument and simply return `Proxy`. But now we've lost crucial kind+information: we don't know if we're dealing with `Proxy Type` or `Proxy Bool`+or `Proxy Int` or something else! We've inadvertently introduced ambiguity.++Unlike in other situations in GHC, we can't just turn on+-fprint-explicit-kinds, as we need to produce something which has the same+structure as a source-syntax type. Moreover, we can't rely on visible kind+application, since the first kind argument to Proxy is inferred, not specified.+Our solution is to annotate certain tycons with their kinds whenever they+appear in applied form in order to resolve the ambiguity. For instance, we+would reify the RHS of Foo like so:++  type Foo = (Proxy :: Type -> Type)++We need to devise an algorithm that determines precisely which tycons need+these explicit kind signatures. We certainly don't want to annotate _every_+tycon with a kind signature, or else we might end up with horribly bloated+types like the following:++  (Either :: Type -> Type -> Type) (Int :: Type) (Char :: Type)++We only want to annotate tycons that absolutely require kind signatures in+order to resolve some sort of ambiguity, and nothing more.++Suppose we have a tycon application (T ty_1 ... ty_n). Why might this type+require a kind signature? It might require it when we need to fill in any of+T's omitted arguments. By "omitted argument", we mean one that is dropped when+reifying ty_1 ... ty_n. Sometimes, the omitted arguments are inferred and+specified arguments (e.g., TH reification in GHC.Tc.Gen.Splice), and sometimes the+omitted arguments are only the inferred ones (e.g., in situations where+specified arguments are reified through visible kind application).+Regardless, the key idea is that _some_ arguments are going to be omitted after+reification, and the only mechanism we have at our disposal for filling them in+is through explicit kind signatures.++What do we mean by "fill in"? Let's consider this small example:++  T :: forall {k}. Type -> (k -> Type) -> k++Moreover, we have this application of T:++  T @{j} Int aty++When we reify this type, we omit the inferred argument @{j}. Is it fixed by the+other (non-inferred) arguments? Yes! If we know the kind of (aty :: blah), then+we'll generate an equality constraint (kappa -> Type) and, assuming we can+solve it, that will fix `kappa`. (Here, `kappa` is the unification variable+that we instantiate `k` with.)++Therefore, for any application of a tycon T to some arguments, the Question We+Must Answer is:++* Given the first n arguments of T, do the kinds of the non-omitted arguments+  fill in the omitted arguments?++(This is still a bit hand-wavy, but we'll refine this question incrementally+as we explain more of the machinery underlying this process.)++Answering this question is precisely the role that the `injectiveVarsOfType`+and `injective_vars_of_binder` functions exist to serve. If an omitted argument+`a` appears in the set returned by `injectiveVarsOfType ty`, then knowing+`ty` determines (i.e., fills in) `a`. (More on `injective_vars_of_binder` in a+bit.)++More formally, if+`a` is in `injectiveVarsOfType ty`+and  S1(ty) ~ S2(ty),+then S1(a)  ~ S2(a),+where S1 and S2 are arbitrary substitutions.++For example, is `F` is a non-injective type family, then++  injectiveVarsOfType(Either c (Maybe (a, F b c))) = {a, c}++Now that we know what this function does, here is a second attempt at the+Question We Must Answer:++* Given the first n arguments of T (ty_1 ... ty_n), consider the binders+  of T that are instantiated by non-omitted arguments. Do the injective+  variables of these binders fill in the remainder of T's kind?++Alright, we're getting closer. Next, we need to clarify what the injective+variables of a tycon binder are. This the role that the+`injective_vars_of_binder` function serves. Here is what this function does for+each form of tycon binder:++* Anonymous binders are injective positions. For example, in the promoted data+  constructor '(:):++    '(:) :: forall a. a -> [a] -> [a]++  The second and third tyvar binders (of kinds `a` and `[a]`) are both+  anonymous, so if we had '(:) 'True '[], then the kinds of 'True and+  '[] would contribute to the kind of '(:) 'True '[]. Therefore,+  injective_vars_of_binder(_ :: a) = injectiveVarsOfType(a) = {a}.+  (Similarly, injective_vars_of_binder(_ :: [a]) = {a}.)+* Named binders:+  - Inferred binders are never injective positions. For example, in this data+    type:++      data Proxy a+      Proxy :: forall {k}. k -> Type++    If we had Proxy 'True, then the kind of 'True would not contribute to the+    kind of Proxy 'True. Therefore,+    injective_vars_of_binder(forall {k}. ...) = {}.+  - Required binders are injective positions. For example, in this data type:++      data Wurble k (a :: k) :: k+      Wurble :: forall k -> k -> k++  The first tyvar binder (of kind `forall k`) has required visibility, so if+  we had Wurble (Maybe a) Nothing, then the kind of Maybe a would+  contribute to the kind of Wurble (Maybe a) Nothing. Hence,+  injective_vars_of_binder(forall a -> ...) = {a}.+  - Specified binders /might/ be injective positions, depending on how you+    approach things. Continuing the '(:) example:++      '(:) :: forall a. a -> [a] -> [a]++    Normally, the (forall a. ...) tyvar binder wouldn't contribute to the kind+    of '(:) 'True '[], since it's not explicitly instantiated by the user. But+    if visible kind application is enabled, then this is possible, since the+    user can write '(:) @Bool 'True '[]. (In that case,+    injective_vars_of_binder(forall a. ...) = {a}.)++    There are some situations where using visible kind application is appropriate+    and others where it is not (e.g., TH+    reification), so the `injective_vars_of_binder` function is parameterized by+    a Bool which decides if specified binders should be counted towards+    injective positions or not.++Now that we've defined injective_vars_of_binder, we can refine the Question We+Must Answer once more:++* Given the first n arguments of T (ty_1 ... ty_n), consider the binders+  of T that are instantiated by non-omitted arguments. For each such binder+  b_i, take the union of all injective_vars_of_binder(b_i). Is this set a+  superset of the free variables of the remainder of T's kind?++If the answer to this question is "no", then (T ty_1 ... ty_n) needs an+explicit kind signature, since T's kind has kind variables leftover that+aren't fixed by the non-omitted arguments.++One last sticking point: what does "the remainder of T's kind" mean? You might+be tempted to think that it corresponds to all of the arguments in the kind of+T that would normally be instantiated by omitted arguments. But this isn't+quite right, strictly speaking. Consider the following (silly) example:++  S :: forall {k}. Type -> Type++And suppose we have this application of S:++  S Int Bool++The Int argument would be omitted, and+injective_vars_of_binder(_ :: Type) = {}. This is not a superset of {k}, which+might suggest that (S Bool) needs an explicit kind signature. But+(S Bool :: Type) doesn't actually fix `k`! This is because the kind signature+only affects the /result/ of the application, not all of the individual+arguments. So adding a kind signature here won't make a difference. Therefore,+the fourth (and final) iteration of the Question We Must Answer is:++* Given the first n arguments of T (ty_1 ... ty_n), consider the binders+  of T that are instantiated by non-omitted arguments. For each such binder+  b_i, take the union of all injective_vars_of_binder(b_i). Is this set a+  superset of the free variables of the kind of (T ty_1 ... ty_n)?++Phew, that was a lot of work!++How can be sure that this is correct? That is, how can we be sure that in the+event that we leave off a kind annotation, that one could infer the kind of the+tycon application from its arguments? It's essentially a proof by induction: if+we can infer the kinds of every subtree of a type, then the whole tycon+application will have an inferrable kind--unless, of course, the remainder of+the tycon application's kind has uninstantiated kind variables.++What happens if T is oversaturated? That is, if T's kind has fewer than n+arguments, in the case that the concrete application instantiates a result+kind variable with an arrow kind? If we run out of arguments, we do not attach+a kind annotation. This should be a rare case, indeed. Here is an example:++   data T1 :: k1 -> k2 -> *+   data T2 :: k1 -> k2 -> *++   type family G (a :: k) :: k+   type instance G T1 = T2++   type instance F Char = (G T1 Bool :: (* -> *) -> *)   -- F from above++Here G's kind is (forall k. k -> k), and the desugared RHS of that last+instance of F is (G (* -> (* -> *) -> *) (T1 * (* -> *)) Bool). According to+the algorithm above, there are 3 arguments to G so we should peel off 3+arguments in G's kind. But G's kind has only two arguments. This is the+rare special case, and we choose not to annotate the application of G with+a kind signature. After all, we needn't do this, since that instance would+be reified as:++   type instance F Char = G (T1 :: * -> (* -> *) -> *) Bool++So the kind of G isn't ambiguous anymore due to the explicit kind annotation+on its argument. See #8953 and test th/T8953.+-}++{-+************************************************************************+*                                                                      *+        Multiplicities+*                                                                      *+************************************************************************++These functions would prefer to be in GHC.Core.Multiplicity, but+they some are used elsewhere in this module, and wanted to bring+their friends here with them.+-}++unrestricted, linear, tymult :: a -> Scaled a++-- | Scale a payload by Many+unrestricted = Scaled ManyTy++-- | Scale a payload by One+linear = Scaled OneTy++-- | Scale a payload by Many; used for type arguments in core+tymult = Scaled ManyTy++irrelevantMult :: Scaled a -> a+irrelevantMult = scaledThing++mkScaled :: Mult -> a -> Scaled a+mkScaled = Scaled++scaledSet :: Scaled a -> b -> Scaled b+scaledSet (Scaled m _) b = Scaled m b++pattern OneTy :: Mult+pattern OneTy <- (isOneTy -> True)+  where OneTy = oneDataConTy++pattern ManyTy :: Mult+pattern ManyTy <- (isManyTy -> True)+  where ManyTy = manyDataConTy++isManyTy :: Mult -> Bool+isManyTy ty+  | Just tc <- tyConAppTyCon_maybe ty+  = tc `hasKey` manyDataConKey+isManyTy _ = False++isOneTy :: Mult -> Bool+isOneTy ty+  | Just tc <- tyConAppTyCon_maybe ty+  = tc `hasKey` oneDataConKey+isOneTy _ = False++isLinearType :: Type -> Bool+-- ^ @isLinear t@ returns @True@ of a if @t@ is a type of (curried) function+-- where at least one argument is linear (or otherwise non-unrestricted). We use+-- this function to check whether it is safe to eta reduce an Id in CorePrep. It+-- is always safe to return 'True', because 'True' deactivates the optimisation.+isLinearType ty = case ty of+                      FunTy _ ManyTy _ res -> isLinearType res+                      FunTy _ _ _ _        -> True+                      ForAllTy _ res       -> isLinearType res+                      _ -> False++{- *********************************************************************+*                                                                      *+                    Space-saving construction+*                                                                      *+********************************************************************* -}++{- Note [Using synonyms to compress types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Was: [Prefer Type over TYPE (BoxedRep Lifted)]++The Core of nearly any program will have numerous occurrences of the Types++   TyConApp BoxedRep [TyConApp Lifted []]    -- Synonym LiftedRep+   TyConApp BoxedRep [TyConApp Unlifted []]  -- Synonym UnliftedREp+   TyConApp TYPE [TyConApp LiftedRep []]     -- Synonym Type+   TyConApp TYPE [TyConApp UnliftedRep []]   -- Synonym UnliftedType++While investigating #17292 we found that these constituted a majority+of all TyConApp constructors on the heap:++    (From a sample of 100000 TyConApp closures)+    0x45f3523    - 28732 - `Type`+    0x420b840702 - 9629  - generic type constructors+    0x42055b7e46 - 9596+    0x420559b582 - 9511+    0x420bb15a1e - 9509+    0x420b86c6ba - 9501+    0x42055bac1e - 9496+    0x45e68fd    - 538   - `TYPE ...`++Consequently, we try hard to ensure that operations on such types are+efficient. Specifically, we strive to++ a. Avoid heap allocation of such types; use a single static TyConApp+ b. Use a small (shallow in the tree-depth sense) representation+    for such types++Goal (b) is particularly useful as it makes traversals (e.g. free variable+traversal, substitution, and comparison) more efficient.+Comparison in particular takes special advantage of nullary type synonym+applications (e.g. things like @TyConApp typeTyCon []@). See+* Note [Comparing type synonyms] in "GHC.Core.TyCo.Compare"+* Note [Unifying type synonyms] in "GHC.Core.Unify"++To accomplish these we use a number of tricks, implemented by mkTyConApp.++ 1. Instead of (TyConApp BoxedRep [TyConApp Lifted []]),+    we prefer a statically-allocated (TyConApp LiftedRep [])+    where `LiftedRep` is a type synonym:+       type LiftedRep = BoxedRep Lifted+    Similarly for UnliftedRep++ 2. Instead of (TyConApp TYPE [TyConApp LiftedRep []])+    we prefer the statically-allocated (TyConApp Type [])+    where `Type` is a type synonym+       type Type = TYPE LiftedRep+    Similarly for UnliftedType++These serve goal (b) since there are no applied type arguments to traverse,+e.g., during comparison.++ 3. We have a single, statically allocated top-level binding to+    represent `TyConApp GHC.Types.Type []` (namely+    'GHC.Builtin.Types.Prim.liftedTypeKind'), ensuring that we don't+    need to allocate such types (goal (a)).  See functions+    mkTYPEapp and mkBoxedRepApp++ 4. We use the sharing mechanism described in Note [Sharing nullary TyConApps]+    in GHC.Core.TyCon to ensure that we never need to allocate such+    nullary applications (goal (a)).++See #17958, #20541+-}++-- | A key function: builds a 'TyConApp' or 'FunTy' as appropriate to+-- its arguments.  Applies its arguments to the constructor from left to right.+mkTyConApp :: TyCon -> [Type] -> Type+mkTyConApp tycon []+  = -- See Note [Sharing nullary TyConApps] in GHC.Core.TyCon+    mkTyConTy tycon++mkTyConApp tycon tys@(ty1:rest)+  | Just fun_ty <- tyConAppFunTy_maybe tycon tys+  = fun_ty++  -- See Note [Using synonyms to compress types]+  | key == tYPETyConKey+  , Just ty <- mkTYPEapp_maybe ty1+  = assert (null rest) ty++  | key == cONSTRAINTTyConKey+  , Just ty <- mkCONSTRAINTapp_maybe ty1+  = assert (null rest) ty++  -- See Note [Using synonyms to compress types]+  | key == boxedRepDataConTyConKey+  , Just ty <- mkBoxedRepApp_maybe ty1+  = assert (null rest) ty++  | key == tupleRepDataConTyConKey+  , Just ty <- mkTupleRepApp_maybe ty1+  = assert (null rest) ty++  -- The catch-all case+  | otherwise+  = TyConApp tycon tys+  where+    key = tyConUnique tycon+++{- Note [Care using synonyms to compress types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Using a synonym to compress a types has a tricky wrinkle. Consider+coreView applied to (TyConApp LiftedRep [])++* coreView expands the LiftedRep synonym:+     type LiftedRep = BoxedRep Lifted++* Danger: we might apply the empty substitution to the RHS of the+  synonym.  And substTy calls mkTyConApp BoxedRep [Lifted]. And+  mkTyConApp compresses that back to LiftedRep.  Loop!++* Solution: in expandSynTyConApp_maybe, don't call substTy for nullary+  type synonyms.  That's more efficient anyway.+-}+++mkTYPEapp :: RuntimeRepType -> Type+mkTYPEapp rr+  = case mkTYPEapp_maybe rr of+       Just ty -> ty+       Nothing -> TyConApp tYPETyCon [rr]++mkTYPEapp_maybe :: RuntimeRepType -> Maybe Type+-- ^ Given a @RuntimeRep@, applies @TYPE@ to it.+-- On the fly it rewrites+--      TYPE LiftedRep      -->   liftedTypeKind    (a synonym)+--      TYPE UnliftedRep    -->   unliftedTypeKind  (ditto)+--      TYPE ZeroBitRep     -->   zeroBitTypeKind   (ditto)+-- NB: no need to check for TYPE (BoxedRep Lifted), TYPE (BoxedRep Unlifted)+--     because those inner types should already have been rewritten+--     to LiftedRep and UnliftedRep respectively, by mkTyConApp+--+-- see Note [TYPE and CONSTRAINT] in GHC.Builtin.Types.Prim.+-- See Note [Using synonyms to compress types] in GHC.Core.Type+{-# NOINLINE mkTYPEapp_maybe #-}+mkTYPEapp_maybe (TyConApp tc args)+  | key == liftedRepTyConKey    = assert (null args) $ Just liftedTypeKind   -- TYPE LiftedRep+  | key == unliftedRepTyConKey  = assert (null args) $ Just unliftedTypeKind -- TYPE UnliftedRep+  | key == zeroBitRepTyConKey   = assert (null args) $ Just zeroBitTypeKind  -- TYPE ZeroBitRep+  where+    key = tyConUnique tc+mkTYPEapp_maybe _ = Nothing++------------------+mkCONSTRAINTapp :: RuntimeRepType -> Type+-- ^ Just like mkTYPEapp+mkCONSTRAINTapp rr+  = case mkCONSTRAINTapp_maybe rr of+       Just ty -> ty+       Nothing -> TyConApp cONSTRAINTTyCon [rr]++mkCONSTRAINTapp_maybe :: RuntimeRepType -> Maybe Type+-- ^ Just like mkTYPEapp_maybe+{-# NOINLINE mkCONSTRAINTapp_maybe #-}+mkCONSTRAINTapp_maybe (TyConApp tc args)+  | tc `hasKey` liftedRepTyConKey = assert (null args) $+                                    Just constraintKind   -- CONSTRAINT LiftedRep+mkCONSTRAINTapp_maybe _ = Nothing++------------------+mkBoxedRepApp_maybe :: LevityType -> Maybe Type+-- ^ Given a `Levity`, apply `BoxedRep` to it+-- On the fly, rewrite+--      BoxedRep Lifted     -->   liftedRepTy    (a synonym)+--      BoxedRep Unlifted   -->   unliftedRepTy  (ditto)+-- See Note [TYPE and CONSTRAINT] in GHC.Builtin.Types.Prim.+-- See Note [Using synonyms to compress types] in GHC.Core.Type+{-# NOINLINE mkBoxedRepApp_maybe #-}+mkBoxedRepApp_maybe (TyConApp tc args)+  | key == liftedDataConKey   = assert (null args) $ Just liftedRepTy    -- BoxedRep Lifted+  | key == unliftedDataConKey = assert (null args) $ Just unliftedRepTy  -- BoxedRep Unlifted+  where+    key = tyConUnique tc+mkBoxedRepApp_maybe _ = Nothing++mkTupleRepApp_maybe :: Type -> Maybe Type+-- ^ Given a `[RuntimeRep]`, apply `TupleRep` to it+-- On the fly, rewrite+--      TupleRep [] -> zeroBitRepTy   (a synonym)+-- See Note [TYPE and CONSTRAINT] in GHC.Builtin.Types.Prim.+-- See Note [Using synonyms to compress types] in GHC.Core.Type+{-# NOINLINE mkTupleRepApp_maybe #-}+mkTupleRepApp_maybe (TyConApp tc args)+  | key == nilDataConKey = assert (isSingleton args) $ Just zeroBitRepTy  -- ZeroBitRep+  where+    key = tyConUnique tc+mkTupleRepApp_maybe _ = Nothing++typeOrConstraintKind :: TypeOrConstraint -> RuntimeRepType -> Kind+typeOrConstraintKind TypeLike       rep = mkTYPEapp       rep+typeOrConstraintKind ConstraintLike rep = mkCONSTRAINTapp rep++liftedTypeOrConstraintKind :: TypeOrConstraint -> Kind+liftedTypeOrConstraintKind TypeLike       = liftedTypeKind+liftedTypeOrConstraintKind ConstraintLike = constraintKind
GHC/Core/Type.hs-boot view
@@ -6,27 +6,21 @@ 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 ) -isPredTy     :: HasDebugCallStack => Type -> Bool-isCoercionTy :: Type -> Bool -mkAppTy    :: Type -> Type -> Type-mkCastTy   :: Type -> Coercion -> Type-mkTyConTy  :: TyCon -> Type-mkTyConApp :: TyCon -> [Type] -> Type-piResultTy :: HasDebugCallStack => Type -> Type -> Type--coreView :: Type -> Maybe Type-tcView :: Type -> Maybe Type-isRuntimeRepTy :: Type -> Bool-isLevityTy :: Type -> Bool-isMultiplicityTy :: Type -> Bool+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-mkTYPEapp :: Type -> Type -splitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type])-tyConAppTyCon_maybe :: Type -> Maybe TyCon--getLevity :: HasDebugCallStack => Type -> Type- partitionInvisibleTypes :: TyCon -> [Type] -> ([Type], [Type])+typeTypeOrConstraint    :: HasDebugCallStack => Type -> TypeOrConstraint
GHC/Core/Unfold.hs view
@@ -16,52 +16,53 @@ -}  -{-# LANGUAGE BangPatterns #-}  module GHC.Core.Unfold (         Unfolding, UnfoldingGuidance,   -- Abstract types +        ExprSize(..), sizeExpr,++        ArgSummary(..), nonTriv,+        CallCtxt(..),+         UnfoldingOpts (..), defaultUnfoldingOpts,         updateCreationThreshold, updateUseThreshold,         updateFunAppDiscount, updateDictDiscount,         updateVeryAggressive, updateCaseScaling,         updateCaseThreshold, updateReportPrefix, -        ArgSummary(..),--        couldBeSmallEnoughToInline, inlineBoringOk,-        smallEnoughToInline,--        callSiteInline, CallCtxt(..),-        calcUnfoldingGuidance+        inlineBoringOk, calcUnfoldingGuidance,+        uncondInlineJoin     ) where  import GHC.Prelude -import GHC.Driver.Flags- import GHC.Core import GHC.Core.Utils-import GHC.Types.Id 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.Builtin.PrimOps import GHC.Types.Id.Info-import GHC.Types.Basic  ( Arity )-import GHC.Core.Type+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.Builtin.Types.Prim ( realWorldStatePrimTy )+ import GHC.Data.Bag-import GHC.Utils.Logger+ import GHC.Utils.Misc import GHC.Utils.Outputable-import GHC.Types.ForeignCall-import GHC.Types.Name-import GHC.Types.Tickish  import qualified Data.ByteString as BS-import Data.List (isPrefixOf)-+import Data.List.NonEmpty (nonEmpty)+import qualified Data.List.NonEmpty as NE  -- | Unfolding options data UnfoldingOpts = UnfoldingOpts@@ -151,25 +152,42 @@ updateReportPrefix :: Maybe String -> UnfoldingOpts -> UnfoldingOpts updateReportPrefix n opts = opts { unfoldingReportPrefix = n } -{--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.+data ArgSummary = TrivArg       -- Nothing interesting+                | NonTrivArg    -- Arg has structure+                | ValueArg      -- Arg is a con-app or PAP+                                -- ..or con-like. Note [Conlike is interesting] -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 #8892, where-the unfolding in question was a DFun unfolding.+instance Outputable ArgSummary where+  ppr TrivArg    = text "TrivArg"+  ppr NonTrivArg = text "NonTrivArg"+  ppr ValueArg   = text "ValueArg" -But more generally, the simplifier is designed on the-basis that it is looking at occurrence-analysed expressions, so better-ensure that they actually are.+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@@ -201,44 +219,136 @@ ************************************************************************ -} +{- Note [inlineBoringOk]+~~~~~~~~~~~~~~~~~~~~~~~~+See Note [INLINE for small functions]++The function `inlineBoringOk` returns True (boringCxtOk) if the supplied+unfolding, which looks like (\x y z. body), is such that the result of+inlining a saturated call is no bigger than `body`.  Some wrinkles:++(IB1) An important case is+    - \x. (x `cast` co)++(IB2) If `body` looks like a data constructor worker, we become keener+  to inline, by ignoring the number of arguments; we just insist they+  are all trivial.  Reason: in a call like `f (g x y)`, if `g` unfolds+  to a data construtor, we can allocate a data constructor instead of+  a thunk (g x y).++  A case in point where a GADT data constructor failed to inline (#25713)+      $WK = /\a \x. K @a <co> x+  We really want to inline a boring call to $WK so that we allocate+  a data constructor not a thunk ($WK @ty x).++  But not for nullary constructors!  We don't want to turn+     f ($WRefl @ty)+  into+     f (Refl @ty <co>)+   because the latter might allocate, whereas the former shares.+   (You might wonder if (Refl @ty <co>) should allocate, but I think+   that currently it does.)  So for nullary constructors, `inlineBoringOk`+   returns False.++(IB3) Types and coercions do not count towards the expression size.+      They are ultimately erased.++(IB4) If there are no value arguments, `inlineBoringOk` we have to be+  careful (#17182).  If we have+      let y = x @Int in f y y+  there’s no reason not to inline y at both use sites — no work is+  actually duplicated.++  But not so for coercion arguments! Unlike type arguments, which have+  no runtime representation, coercion arguments *do* have a runtime+  representation (albeit the zero-width VoidRep, see Note [Coercion+  tokens] in "GHC.CoreToStg").  For example:+       let y = g @Int <co> in g y y+  Here `co` is a value argument, and calling it twice might duplicate+  work.++  Even if `g` is a data constructor, so no work is duplicated,+  inlining `y` might duplicate allocation of a data constructor object+  (#17787). See also (IB2).++  TL;DR: if `is_fun` is False, so we have no value arguments, we /do/+  count coercion arguments, despite (IB3).++(IB5) You might wonder about an unfolding like  (\x y z -> x (y z)),+  whose body is, in some sense, just as small as (g x y z).+  But `inlineBoringOk` doesn't attempt anything fancy; it just looks+  for a function call with trivial arguments, Keep it simple.++(IB6) If we have an unfolding (K op) where K is a unary-class data constructor,+  we want to inline it!  So that we get calls (f op), which in turn can see (in+  STG land) that `op` is already evaluated and properly tagged. (If `op` isn't+  trivial we will have baled out before we get to the Var case.)  This made+  a big difference in benchmarks for the `effectful` library; details in !10479.++  See Note [Unary class magic] in GHC/Core/TyCon.+-}+ inlineBoringOk :: CoreExpr -> Bool--- 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)+-- See Note [inlineBoringOk] inlineBoringOk e   = go 0 e   where+    is_fun = isValFun e+     go :: Int -> CoreExpr -> Bool-    go credit (Lam x e) | isId x           = go (credit+1) e-                        | otherwise        = go credit e-        -- See Note [Count coercion arguments in boring contexts]-    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 credit (Case scrut _ _ [Alt _ _ rhs]) -- See Note [Inline unsafeCoerce]-      | isUnsafeEqualityProof scrut        = go credit rhs-    go _      (Var {})                     = boringCxtOk-    go _      _                            = boringCxtNotOk+    -- 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 (Tick t expr)+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 expr-calcUnfoldingGuidance opts is_top_bottoming expr+  = 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 expr n_val_bndrs size+        | 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]@@ -275,7 +385,7 @@ 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 -- see Note [Implementing unsafeCoerce]+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@@ -283,7 +393,9 @@ which will build a thunk -- bad, bad, bad.  Conclusion: we really want inlineBoringOk to be True of the RHS of-unsafeCoerce.  This is (U4) in Note [Implementing unsafeCoerce].+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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -379,39 +491,70 @@     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]--Note [Count coercion arguments in boring contexts]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In inlineBoringOK, we ignore type arguments when deciding whether an-expression is okay to inline into boring contexts. This is good, since-if we have a definition like--  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. It may seem like the same reasoning applies to-coercion arguments, and indeed, in #17182 we changed inlineBoringOK to-treat coercions the same way.--However, this isn’t a good idea: 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"). This caused trouble in #17787 for DataCon wrappers for-nullary GADT constructors: the wrappers would be inlined and each use of-the constructor would lead to a separate allocation instead of just-sharing the wrapper closure.--The solution: don’t ignore coercion arguments after all. -} -uncondInline :: CoreExpr -> Arity -> Int -> Bool+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 rhs arity size+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@@ -431,7 +574,7 @@     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+    size_up (Var f) | isZeroBitId f = sizeZero                       -- Make sure we get constructor discounts even                       -- on nullary constructors                     | otherwise       = size_up_call f [] 0@@ -439,10 +582,10 @@     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_app fun [arg] (if isZeroBitExpr arg then 1 else 0)      size_up (Lam b e)-      | isId b && not (isRealWorldId b) = lamScrutDiscount opts (size_up e `addSizeN` 10)+      | isId b && not (isZeroBitId b) = lamScrutDiscount opts (size_up e `addSizeN` 10)       | otherwise = size_up e      size_up (Let (NonRec binder rhs) body)@@ -455,15 +598,12 @@               (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+    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@@ -490,14 +630,15 @@                 -- 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 --    size_up (Case e _ _ alts) = size_up e  `addSizeNSD`-                                foldr (addAltSize . size_up_alt) case_size alts       where           case_size            | is_inline_scrut e, lengthAtMost alts 1 = sizeN (-10)@@ -528,14 +669,14 @@           is_inline_scrut scrut               | (Var f, _) <- collectArgs scrut                 = case idDetails f of-                    FCallId fc  -> not (isSafeForeignCall fc)-                    PrimOpId op -> not (primOpOutOfLine op)-                    _other      -> False+                    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+      | JoinPoint join_arity <- idJoinPointHood bndr         -- Skip arguments to join point       , (_bndrs, body) <- collectNBinders join_arity rhs       = size_up body@@ -546,7 +687,7 @@     -- 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)+        | 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@@ -562,11 +703,13 @@     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 opts top_args val_args-           _                -> funSize opts top_args fun (length val_args) voids+           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@@ -580,10 +723,9 @@     ------------     -- 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-           -- OK to call isUnliftedType: binders have a fixed RuntimeRep (search for FRRBinder)+      |  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@@ -611,12 +753,14 @@                                  (xs `unionBags` ys)                                  d2  -- Ignore d1 -    isRealWorldId id = idType id `eqType` realWorldStatePrimTy+    -- 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) -    -- an expression of type State# RealWorld must be a variable-    isRealWorldExpr (Var id)   = isRealWorldId id-    isRealWorldExpr (Tick _ e) = isRealWorldExpr e-    isRealWorldExpr _          = False+    isZeroBitExpr (Var id)   = isZeroBitId id+    isZeroBitExpr (Tick _ e) = isZeroBitExpr e+    isZeroBitExpr _          = False  -- | Finds a nominal size of a string literal. litSize :: Literal -> Int@@ -630,21 +774,24 @@                       -- Key point: if  x |-> 4, then x must inline unconditionally                       --            (eg via case binding) -classOpSize :: UnfoldingOpts -> [Id] -> [CoreExpr] -> ExprSize+classOpSize :: UnfoldingOpts -> Class -> [Id] -> [CoreExpr] -> ExprSize -- See Note [Conlike is interesting]-classOpSize _ _ []-  = sizeZero-classOpSize opts top_args (arg1 : other_args)-  = SizeIs size arg_discount 0+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 = 20 + (10 * length other_args)+    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 = case arg1 of-                     Var dict | dict `elem` top_args-                              -> unitBag (dict, unfoldingDictDiscount opts)-                     _other   -> emptyBag+    arg_discount (Var dict) | dict `elem` top_args+                   = unitBag (dict, unfoldingDictDiscount opts)+    arg_discount _ = emptyBag  -- | The size of a function call callSize@@ -661,18 +808,19 @@  :: 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)+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 functions that are not constructors or primops+-- 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-  | fun `hasKey` buildIdKey   = buildSize-  | fun `hasKey` augmentIdKey = augmentSize   | otherwise = SizeIs size arg_discount res_discount   where     some_val_args = n_val_args > 0@@ -702,6 +850,8 @@ -- 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 @@ -734,7 +884,7 @@ 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 exponenial inlinings (#18282).  In short,+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@@ -929,565 +1079,3 @@  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 :: 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--}--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 :: Logger-               -> UnfoldingOpts-               -> Int                   -- Case depth-               -> Id                    -- The Id-               -> Bool                  -- True <=> unfolding is active-               -> Bool                  -- True if there are no arguments at all (incl type args)-               -> [ArgSummary]          -- One for each value arg; True if it is interesting-               -> CallCtxt              -- True <=> continuation is interesting-               -> Maybe CoreExpr        -- Unfolding, if any-callSiteInline logger opts !case_depth id active_unfolding lone_variable arg_infos cont_info-  = case idUnfolding id of-      -- idUnfolding checks for loop-breakers, returning NoUnfolding-      -- Things with an INLINE pragma may have an unfolding *and*-      -- be a loop breaker  (maybe the knot is not yet untied)-        CoreUnfolding { uf_tmpl = unf_template-                      , uf_is_work_free = is_wf-                      , uf_guidance = guidance, uf_expandable = is_exp }-          | active_unfolding -> tryUnfolding logger opts case_depth id lone_variable-                                    arg_infos cont_info unf_template-                                    is_wf is_exp guidance-          | otherwise -> traceInline logger opts id "Inactive unfolding:" (ppr id) Nothing-        NoUnfolding      -> Nothing-        BootUnfolding    -> Nothing-        OtherCon {}      -> Nothing-        DFunUnfolding {} -> Nothing     -- Never unfold a DFun---- | Report the inlining of an identifier's RHS to the user, if requested.-traceInline :: Logger -> 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]-   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--Consider a function f like this:--  f arg1 arg2 =-    case ...-      ... -> g arg1-      ... -> g arg2--This function is small. So should be safe to inline.-However sometimes this doesn't quite work out like that.-Consider this code:--f1 arg1 arg2 ... = ...-    case _foo of-      alt1 -> ... f2 arg1 ...-      alt2 -> ... f2 arg2 ...--f2 arg1 arg2 ... = ...-    case _foo of-      alt1 -> ... f3 arg1 ...-      alt2 -> ... f3 arg2 ...--f3 arg1 arg2 ... = ...--... repeats up to n times. And then f1 is-applied to some arguments:--foo = ... f1 <interestingArgs> ...--Initially f2..fn are not interesting to inline so we don't.-However we see that f1 is applied to interesting args.-So it's an obvious choice to inline those:--foo =-    ...-      case _foo of-        alt1 -> ... f2 <interestingArg> ...-        alt2 -> ... f2 <interestingArg> ...--As a result we go and inline f2 both mentions of f2 in turn are now applied to interesting-arguments and f2 is small:--foo =-    ...-      case _foo of-        alt1 -> ... case _foo of-            alt1 -> ... f3 <interestingArg> ...-            alt2 -> ... f3 <interestingArg> ...--        alt2 -> ... case _foo of-            alt1 -> ... f3 <interestingArg> ...-            alt2 -> ... f3 <interestingArg> ...--The same thing happens for each binding up to f_n, duplicating the amount of inlining-done in each step. Until at some point we are either done or run out of simplifier-ticks/RAM. This pattern happened #18730.--To combat this we introduce one more heuristic when weighing inlining decision.-We keep track of a "case-depth". Which increases each time we look inside a case-expression with more than one alternative.--We then apply a penalty to inlinings based on the case-depth at which they would-be inlined. Bounding the number of inlinings in such a scenario.--The heuristic can be tuned in two ways:--* We can ignore the first n levels of case nestings for inlining decisions using-  -funfolding-case-threshold.-* The penalty grows linear with the depth. It's computed as size*(depth-threshold)/scaling.-  Scaling can be set with -funfolding-case-scaling.--Some guidance on setting these defaults:--* A low treshold (<= 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 :: Logger -> UnfoldingOpts -> Int -> Id -> Bool -> [ArgSummary] -> CallCtxt-             -> CoreExpr -> Bool -> Bool -> UnfoldingGuidance-             -> Maybe CoreExpr-tryUnfolding logger opts !case_depth id lone_variable-             arg_infos cont_info unf_template-             is_wf is_exp guidance- = case guidance of-     UnfNever -> traceInline logger 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-          enough_args = (n_val_args >= uf_arity) || (unsat_ok && n_val_args > 0)--     UnfIfGoodArgs { ug_args = arg_discounts, ug_res = res_discount, ug_size = size }-        | unfoldingVeryAggressive opts-        -> traceInline logger opts id str (mk_doc some_benefit extra_doc True) (Just unf_template)-        | is_wf && some_benefit && small_enough-        -> traceInline logger opts id str (mk_doc some_benefit extra_doc True) (Just unf_template)-        | otherwise-        -> traceInline logger opts id str (mk_doc some_benefit extra_doc False) Nothing-        where-          some_benefit = calc_some_benefit (length arg_discounts)-          extra_doc = vcat [ text "case depth =" <+> int case_depth-                           , text "depth based penalty =" <+> int depth_penalty-                           , text "discounted size =" <+> int adjusted_size ]-          -- See Note [Avoid inlining into deeply nested cases]-          depth_treshold = unfoldingCaseThreshold opts-          depth_scaling = unfoldingCaseScaling opts-          depth_penalty | case_depth <= depth_treshold = 0-                        | otherwise       = (size * (case_depth - depth_treshold)) `div` depth_scaling-          adjusted_size = size + depth_penalty - discount-          small_enough = adjusted_size <= unfoldingUseThreshold opts-          discount = computeDiscount 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"]--    ctx = log_default_dump_context (logFlags logger)-    str = "Considering inlining: " ++ renderWithContext ctx (ppr id)-    n_val_args = length arg_infos--           -- some_benefit is used when the RHS is small enough-           -- 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_exp)  -- Note [Lone variables]-              ValAppCtxt -> True                           -- Note [Cast then apply]-              RuleArgCtxt -> uf_arity > 0  -- See Note [Unfold info lazy contexts]-              DiscArgCtxt -> uf_arity > 0  -- Note [Inlining in ArgCtxt]-              RhsCtxt     -> uf_arity > 0  ---              _other      -> False         -- See Note [Nested functions]---{--Note [Unfold into lazy contexts]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Merged into Note [RHS of lets].--Note [RHS of lets]-~~~~~~~~~~~~~~~~~~-When the call is the argument of a function with a RULE, or the RHS of a let,-we are a little bit keener to inline.  For example-     f y = (y,y,y)-     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]-~~~~~~~~~~~~~~~~~~~~~~~-At one time we treated a call of a non-top-level function as-"interesting" (regardless of how boring the context) in the hope-that inlining it would eliminate the binding, and its allocation.-Specifically, in the default case of interesting_call we had-   _other -> not is_top && uf_arity > 0--But actually postInlineUnconditionally does some of this and overall-it makes virtually no difference to nofib.  So I simplified away this-special case--Note [Cast then apply]-~~~~~~~~~~~~~~~~~~~~~~-Consider-   myIndex = __inline_me ( (/\a. <blah>) |> co )-   co :: (forall a. a -> a) ~ (forall a. T a)-     ... /\a.\x. case ((myIndex a) |> sym co) x of { ... } ...--We need to inline myIndex to unravel this; but the actual call (myIndex a) has-no value arguments.  The ValAppCtxt gives it enough incentive to inline.--Note [Inlining in ArgCtxt]-~~~~~~~~~~~~~~~~~~~~~~~~~~-The condition (arity > 0) here is very important, because otherwise-we end up inlining top-level stuff into useless places; eg-   x = I# 3#-   f = \y.  g x-This can make a very big difference: it adds 16% to nofib 'integer' allocs,-and 20% to 'power'.--At one stage I replaced this condition by 'True' (leading to the above-slow-down).  The motivation was test eyeball/inline1.hs; but that seems-to work ok now.--NOTE: arguably, we should inline in ArgCtxt only if the result of the-call is at least CONLIKE.  At least for the cases where we use ArgCtxt-for the RHS of a 'let', we only profit from the inlining if we get a-CONLIKE thing (modulo lets).--Note [Lone variables]   See also Note [Interaction of exprIsWorkFree and lone variables]-~~~~~~~~~~~~~~~~~~~~~   which appears below-The "lone-variable" case is important.  I spent ages messing about-with unsatisfactory variants, but this is nice.  The idea is that if a-variable appears all alone--        as an arg of lazy fn, or rhs    BoringCtxt-        as scrutinee of a case          CaseCtxt-        as arg of a fn                  ArgCtxt-AND-        it is bound to a cheap expression--then we should not inline it (unless there is some other reason,-e.g. it is the sole occurrence).  That is what is happening at-the use of 'lone_variable' in 'interesting_call'.--Why?  At least in the case-scrutinee situation, turning-        let x = (a,b) in case x of y -> ...-into-        let x = (a,b) in case (a,b) of y -> ...-and thence to-        let x = (a,b) in let y = (a,b) in ...-is bad if the binding for x will remain.--Another example: I discovered that strings-were getting inlined straight back into applications of 'error'-because the latter is strict.-        s = "foo"-        f = \x -> ...(error s)...--Fundamentally such contexts should not encourage inlining because, provided-the RHS is "expandable" (see Note [exprIsExpandable] in GHC.Core.Utils) the-context can ``see'' the unfolding of the variable (e.g. case or a-RULE) so there's no gain.--However, watch out:-- * Consider this:-        foo = _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 :: [Int] -> Int -> [ArgSummary] -> CallCtxt-                -> Int-computeDiscount arg_discounts res_discount arg_infos cont_info--  = 10          -- Discount of 10 because the result replaces the call-                -- so we count 10 for the function itself--    + 10 * length actual_arg_discounts-               -- Discount of 10 for each arg supplied,-               -- because the result replaces the call--    + total_arg_discount + res_discount'-  where-    actual_arg_discounts = zipWith mk_arg_discount arg_discounts arg_infos-    total_arg_discount   = sum actual_arg_discounts--    mk_arg_discount _        TrivArg    = 0-    mk_arg_discount _        NonTrivArg = 10-    mk_arg_discount discount ValueArg   = discount--    res_discount'-      | LT <- arg_discounts `compareLength` arg_infos-      = res_discount   -- Over-saturated-      | otherwise-      = case cont_info of-           BoringCtxt  -> 0-           CaseCtxt    -> res_discount  -- Presumably a constructor-           ValAppCtxt  -> res_discount  -- Presumably a function-           _           -> 40 `min` res_discount-                -- ToDo: this 40 `min` res_discount doesn't seem right-                --   for DiscArgCtxt it shouldn't matter because the function will-                --       get the arg discount for any non-triv arg-                --   for RuleArgCtxt we do want to be keener to inline; but not only-                --       constructor results-                --   for RhsCtxt I suppose that exposing a data con is good in general-                --   And 40 seems very arbitrary-                ---                -- res_discount can be very large when a function returns-                -- constructors; but we only want to invoke that large discount-                -- when there's a case continuation.-                -- Otherwise we, rather arbitrarily, threshold it.  Yuk.-                -- But we want to avoid inlining large functions that return-                -- constructors into contexts that are simply "interesting"
GHC/Core/Unfold/Make.hs view
@@ -6,15 +6,15 @@    , mkUnfolding    , mkCoreUnfolding    , mkFinalUnfolding+   , mkFinalUnfolding'    , mkSimpleUnfolding    , mkWorkerUnfolding-   , mkInlineUnfolding-   , mkInlineUnfoldingWithArity+   , mkInlineUnfoldingWithArity, mkInlineUnfoldingNoArity    , mkInlinableUnfolding    , mkWrapperUnfolding-   , mkCompulsoryUnfolding-   , mkCompulsoryUnfolding'+   , mkCompulsoryUnfolding, mkCompulsoryUnfolding'    , mkDFunUnfolding+   , mkDataConUnfolding    , specUnfolding    , certainlyWillInline    )@@ -36,6 +36,8 @@ 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 @@ -44,22 +46,29 @@ 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 = 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 --- | Used for things that absolutely must be unfolded-mkCompulsoryUnfolding :: SimpleOpts -> CoreExpr -> Unfolding-mkCompulsoryUnfolding opts expr = mkCompulsoryUnfolding' (simpleOptExpr opts expr)+-- | Same as 'mkCompulsoryUnfolding' but simplifies the unfolding first+mkCompulsoryUnfolding' :: SimpleOpts -> CoreExpr -> Unfolding+mkCompulsoryUnfolding' opts expr = mkCompulsoryUnfolding (simpleOptExpr opts expr) --- | Same as 'mkCompulsoryUnfolding' but no simple optimiser pass is performed--- on the unfolding.-mkCompulsoryUnfolding' :: CoreExpr -> Unfolding-mkCompulsoryUnfolding' expr-  = mkCoreUnfolding InlineCompulsory True-                    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 }) @@ -71,21 +80,44 @@  mkSimpleUnfolding :: UnfoldingOpts -> CoreExpr -> Unfolding mkSimpleUnfolding !opts rhs-  = mkUnfolding opts InlineRhs False False 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 [Occurrence analysis of unfoldings]+                  -- See Note [OccInfo in unfoldings and rules] in GHC.Core +mkDataConUnfolding :: CoreExpr -> Unfolding+-- Used for non-newtype data constructors with non-trivial wrappers+mkDataConUnfolding expr+  = mkCoreUnfolding StableSystemSrc True expr Nothing guide+    -- No need to simplify the expression+  where+    guide = UnfWhen { ug_arity     = manifestArity expr+                    , ug_unsat_ok  = unSaturatedOk+                    , ug_boring_ok = inlineBoringOk expr }+            -- inineBoringOk; sometimes wrappers are very simple, like+            --    \@a p q. K @a <coercion> p q+            -- and then we definitely want to inline it #25713+ mkWrapperUnfolding :: SimpleOpts -> CoreExpr -> Arity -> Unfolding -- Make the unfolding for the wrapper in a worker/wrapper split -- after demand/CPR analysis mkWrapperUnfolding opts expr arity-  = mkCoreUnfolding InlineStable True-                    (simpleOptExpr opts expr)+  = mkCoreUnfolding StableSystemSrc True+                    (simpleOptExpr opts expr) Nothing                     (UnfWhen { ug_arity     = arity                              , ug_unsat_ok  = unSaturatedOk                              , ug_boring_ok = boringCxtNotOk })@@ -96,22 +128,22 @@                   (CoreUnfolding { uf_src = src, uf_tmpl = tmpl                                  , uf_is_top = top_lvl })   | isStableSource src-  = mkCoreUnfolding src top_lvl new_tmpl guidance+  = mkCoreUnfolding src top_lvl new_tmpl Nothing guidance   where     new_tmpl = simpleOptExpr opts (work_fn tmpl)-    guidance = calcUnfoldingGuidance (so_uf_opts opts) False new_tmpl+    guidance = calcUnfoldingGuidance (so_uf_opts opts) False False new_tmpl  mkWorkerUnfolding _ _ _ = noUnfolding --- | Make an unfolding that may be used unsaturated+-- | 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).-mkInlineUnfolding :: SimpleOpts -> CoreExpr -> Unfolding-mkInlineUnfolding opts expr-  = mkCoreUnfolding InlineStable+mkInlineUnfoldingNoArity :: SimpleOpts -> UnfoldingSource -> CoreExpr -> Unfolding+mkInlineUnfoldingNoArity opts src expr+  = mkCoreUnfolding src                     True         -- Note [Top-level flag on inline rules]-                    expr' guide+                    expr' Nothing guide   where     expr' = simpleOptExpr opts expr     guide = UnfWhen { ug_arity = manifestArity expr'@@ -119,13 +151,13 @@                     , ug_boring_ok = boring_ok }     boring_ok = inlineBoringOk expr' --- | Make an unfolding that will be used once the RHS has been saturated+-- | Make an INLINE unfolding that will be used once the RHS has been saturated -- to the given arity.-mkInlineUnfoldingWithArity :: Arity -> SimpleOpts -> CoreExpr -> Unfolding-mkInlineUnfoldingWithArity arity opts expr-  = mkCoreUnfolding InlineStable+mkInlineUnfoldingWithArity :: SimpleOpts -> UnfoldingSource -> Arity -> CoreExpr -> Unfolding+mkInlineUnfoldingWithArity opts src arity expr+  = mkCoreUnfolding src                     True         -- Note [Top-level flag on inline rules]-                    expr' guide+                    expr' Nothing guide   where     expr' = simpleOptExpr opts expr     guide = UnfWhen { ug_arity = arity@@ -136,9 +168,9 @@     boring_ok | arity == 0 = True               | otherwise  = inlineBoringOk expr' -mkInlinableUnfolding :: SimpleOpts -> CoreExpr -> Unfolding-mkInlinableUnfolding opts expr-  = mkUnfolding (so_uf_opts opts) InlineStable False False 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 @@ -154,7 +186,7 @@               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 [DFunUnfoldings] in GHC.Core.Opt.Specialise+           -- For this ASSERT see Note [Specialising DFuns] in GHC.Core.Opt.Specialise     mkDFunUnfolding spec_bndrs con (map spec_arg args)       -- For DFunUnfoldings we transform       --       \obs. MkD <op1> ... <opn>@@ -165,6 +197,9 @@                    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@@ -172,7 +207,7 @@                              , uf_guidance = old_guidance })  | isStableSource src  -- See Note [Specialising unfoldings]  , UnfWhen { ug_arity = old_arity } <- old_guidance- = mkCoreUnfolding src top_lvl new_tmpl+ = mkCoreUnfolding src top_lvl new_tmpl Nothing                    (old_guidance { ug_arity = old_arity - arity_decrease })  where    new_tmpl = simpleOptExpr opts $@@ -193,25 +228,41 @@   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 = <big-rhs>-     {- 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 <big-rhs> as its unfolding, and that probably won't inline.  But-  if we don't, the specialised version of <big-rhs> 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).+* 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. -  Moreover, keeping the INLINABLE thing isn't much help, because+* 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. -  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+  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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -285,46 +336,49 @@             -> 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 expr-  = mkCoreUnfolding src top_lvl expr guidance+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 expr+    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-                -> UnfoldingGuidance -> Unfolding+                -> Maybe UnfoldingCache -> UnfoldingGuidance -> Unfolding -- Occurrence-analyses the expression before capturing it-mkCoreUnfolding src top_lvl expr guidance-  =+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] -  let is_value = exprIsHNF expr-      is_conlike = exprIsConLike expr-      is_work_free = exprIsWorkFree expr-      is_expandable = exprIsExpandable expr-  in-  -- See #20905 for what is going on here. We are careful to make sure we only-  -- have one copy of an unfolding around at once.-  -- Note [Thoughtful forcing in mkCoreUnfolding]-  CoreUnfolding { uf_tmpl         = is_value `seq`-                                    is_conlike `seq`-                                    is_work_free `seq`-                                    is_expandable `seq`-                                      occurAnalyseExpr expr,-                      -- See Note [Occurrence analysis of unfoldings]-                    uf_src          = src,-                    uf_is_top       = top_lvl,-                    uf_is_value     = is_value,-                    uf_is_conlike   = is_conlike,-                    uf_is_work_free = is_work_free,-                    uf_expandable   = is_expandable,-                    uf_guidance     = guidance }+                  , 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.@@ -343,15 +397,13 @@              UnfIfGoodArgs { ug_size = size, ug_args = args }                         -> do_cunf size args src' tmpl'         where-          src' = -- Do not change InlineCompulsory!-                 case src of-                   InlineCompulsory -> InlineCompulsory-                   _                -> InlineStable-          tmpl' = -- Do not overwrite stable unfoldings!-                  case src of-                    InlineRhs -> occurAnalyseExpr rhs'-                    _         -> uf_tmpl fn_unf+          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@@ -419,13 +471,13 @@  Core expressions retained in unfoldings is one of biggest uses of memory when compiling a program. Therefore we have to be careful about retaining copies of old or redundant-templates (see !6202 for a particularlly bad case).+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 occurence analysis-  (Note [Occurrence analysis of unfoldings])+* 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@@ -445,7 +497,7 @@ 1. Perform the predicates on the analysed expression. 2. Force the predicates to remove retainer to the old expression if we force the template. -Option 1 is bad because occurence analysis is expensive and destroys any sharing of the unfolding+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@@ -454,4 +506,3 @@ The result of fixing this led to a 1G reduction in peak memory usage (12G -> 11G) when compiling a very large module (peak 3 million terms). For more discussion see #20905. -}-
GHC/Core/Unify.hs view
@@ -1,2067 +1,2541 @@ -- (c) The University of Glasgow 2006 -{-# LANGUAGE ScopedTypeVariables, PatternSynonyms #-}--{-# LANGUAGE DeriveFunctor #-}--module GHC.Core.Unify (-        tcMatchTy, tcMatchTyKi,-        tcMatchTys, tcMatchTyKis,-        tcMatchTyX, tcMatchTysX, tcMatchTyKisX,-        tcMatchTyX_BM, ruleMatchTyKiX,--        -- * Rough matching-        RoughMatchTc(..), roughMatchTcs, roughMatchTcsLookup, instanceCantMatch,-        typesCantMatch, isRoughWildcard,--        -- Side-effect free unification-        tcUnifyTy, tcUnifyTyKi, tcUnifyTys, tcUnifyTyKis,-        tcUnifyTysFG, tcUnifyTyWithTFs,-        BindFun, BindFlag(..), matchBindFun, alwaysBindFun,-        UnifyResult, UnifyResultM(..), MaybeApartReason(..),--        -- Matching a type against a lifted type (coercion)-        liftCoMatch,--        -- The core flattening algorithm-        flattenTys, flattenTysX-   ) where--import GHC.Prelude--import GHC.Types.Var-import GHC.Types.Var.Env-import GHC.Types.Var.Set-import GHC.Types.Name( Name, mkSysTvName, mkSystemVarName )-import GHC.Core.Type     hiding ( getTvSubstEnv )-import GHC.Core.Coercion hiding ( getCvSubstEnv )-import GHC.Core.TyCon-import GHC.Core.TyCo.Rep-import GHC.Core.TyCo.FVs   ( tyCoVarsOfCoList, tyCoFVsOfTypes )-import GHC.Core.TyCo.Subst ( mkTvSubst )-import GHC.Core.RoughMap-import GHC.Core.Map.Type-import GHC.Utils.FV( FV, fvVarSet, fvVarList )-import GHC.Utils.Misc-import GHC.Data.Pair-import GHC.Utils.Outputable-import GHC.Types.Unique-import GHC.Types.Unique.FM-import GHC.Types.Unique.Set-import {-# SOURCE #-} GHC.Tc.Utils.TcType ( tcEqType )-import GHC.Exts( oneShot )-import GHC.Utils.Panic.Plain-import GHC.Data.FastString--import Data.List ( mapAccumL )-import Control.Monad-import qualified Data.Semigroup as S--import GHC.Builtin.Names (constraintKindTyConKey, liftedTypeKindTyConKey)--{---Unification is much tricker than you might think.--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.--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.--}---- | Some unification functions are parameterised by a 'BindFun', which--- says whether or not to allow a certain unification to take place.--- A 'BindFun' 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 BindFun = TyCoVar -> Type -> BindFlag---- | @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 :: Type -> Type -> Maybe TCvSubst-tcMatchTy ty1 ty2 = tcMatchTys [ty1] [ty2]--tcMatchTyX_BM :: BindFun -> TCvSubst-              -> Type -> Type -> Maybe TCvSubst-tcMatchTyX_BM bind_me subst ty1 ty2-  = tc_match_tys_x bind_me 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 :: Type -> Type -> Maybe TCvSubst-tcMatchTyKi ty1 ty2-  = tc_match_tys alwaysBindFun True [ty1] [ty2]---- | This is similar to 'tcMatchTy', but extends a substitution--- See also Note [tcMatchTy vs tcMatchTyKi]-tcMatchTyX :: TCvSubst            -- ^ Substitution to extend-           -> Type                -- ^ Template-           -> Type                -- ^ Target-           -> Maybe TCvSubst-tcMatchTyX subst ty1 ty2-  = tc_match_tys_x alwaysBindFun False subst [ty1] [ty2]---- | Like 'tcMatchTy' but over a list of types.--- See also Note [tcMatchTy vs tcMatchTyKi]-tcMatchTys :: [Type]         -- ^ Template-           -> [Type]         -- ^ Target-           -> Maybe TCvSubst -- ^ One-shot; in principle the template-                             -- variables could be free in the target-tcMatchTys tys1 tys2-  = tc_match_tys alwaysBindFun False tys1 tys2---- | Like 'tcMatchTyKi' but over a list of types.--- See also Note [tcMatchTy vs tcMatchTyKi]-tcMatchTyKis :: [Type]         -- ^ Template-             -> [Type]         -- ^ Target-             -> Maybe TCvSubst -- ^ One-shot substitution-tcMatchTyKis tys1 tys2-  = tc_match_tys alwaysBindFun True tys1 tys2---- | Like 'tcMatchTys', but extending a substitution--- See also Note [tcMatchTy vs tcMatchTyKi]-tcMatchTysX :: TCvSubst       -- ^ Substitution to extend-            -> [Type]         -- ^ Template-            -> [Type]         -- ^ Target-            -> Maybe TCvSubst -- ^ One-shot substitution-tcMatchTysX subst tys1 tys2-  = tc_match_tys_x alwaysBindFun False subst tys1 tys2---- | Like 'tcMatchTyKis', but extending a substitution--- See also Note [tcMatchTy vs tcMatchTyKi]-tcMatchTyKisX :: TCvSubst        -- ^ Substitution to extend-              -> [Type]          -- ^ Template-              -> [Type]          -- ^ Target-              -> Maybe TCvSubst  -- ^ One-shot substitution-tcMatchTyKisX subst tys1 tys2-  = tc_match_tys_x alwaysBindFun True subst tys1 tys2---- | Same as tc_match_tys_x, but starts with an empty substitution-tc_match_tys :: BindFun-             -> Bool          -- ^ match kinds?-             -> [Type]-             -> [Type]-             -> Maybe TCvSubst-tc_match_tys bind_me match_kis tys1 tys2-  = tc_match_tys_x bind_me match_kis (mkEmptyTCvSubst in_scope) tys1 tys2-  where-    in_scope = mkInScopeSet (tyCoVarsOfTypes tys1 `unionVarSet` tyCoVarsOfTypes tys2)---- | Worker for 'tcMatchTysX' and 'tcMatchTyKisX'-tc_match_tys_x :: BindFun-               -> Bool          -- ^ match kinds?-               -> TCvSubst-               -> [Type]-               -> [Type]-               -> Maybe TCvSubst-tc_match_tys_x bind_me match_kis (TCvSubst in_scope tv_env cv_env) tys1 tys2-  = case tc_unify_tys bind_me-                      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---- | 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)--- @-matchBindFun :: TyCoVarSet -> BindFun-matchBindFun tvs tv _ty-  | tv `elemVarSet` tvs = BindMe-  | otherwise           = Apart---- | Allow the binding of any variable to any type-alwaysBindFun :: BindFun-alwaysBindFun _tv _ty = BindMe--{- *********************************************************************-*                                                                      *-                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.--}--roughMatchTcs :: [Type] -> [RoughMatchTc]-roughMatchTcs tys = map typeToRoughMatchTc tys--roughMatchTcsLookup :: [Type] -> [RoughMatchLookupTc]-roughMatchTcsLookup tys = map typeToRoughMatchLookupTc tys--instanceCantMatch :: [RoughMatchTc] -> [RoughMatchTc] -> Bool--- (instanceCantMatch tcs1 tcs2) returns True if tcs1 cannot--- possibly be instantiated to actual, nor vice versa;--- 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---{--************************************************************************-*                                                                      *-                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 alwaysBindFun [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 #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 [Unification result]-~~~~~~~~~~~~~~~~~~~~~~~~~-When unifying t1 ~ t2, we return-* Unifiable s, if s is a substitution such that s(t1) is syntactically the-  same as s(t2), modulo type-synonym expansion.-* 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--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-the Semigroup instance for MaybeApartReason to prefer MARInfinite.--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.---}---- | 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 alwaysBindFun [t1] [t2]---- | Like 'tcUnifyTy', but also unifies the kinds-tcUnifyTyKi :: Type -> Type -> Maybe TCvSubst-tcUnifyTyKi t1 t2 = tcUnifyTyKis alwaysBindFun [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 alwaysBindFun twoWay True False-                       rn_env emptyTvSubstEnv emptyCvSubstEnv-                       [t1] [t2] of-      Unifiable          (subst, _) -> Just $ maybe_fix subst-      MaybeApart _reason (subst, _) -> Just $ maybe_fix subst-      -- we want to *succeed* in questionable cases. This is a-      -- pre-unification algorithm.-      SurelyApart      -> Nothing-  where-    in_scope = mkInScopeSet $ tyCoVarsOfTypes [t1, t2]-    rn_env   = mkRnEnv2 in_scope--    maybe_fix | twoWay    = niFixTCvSubst-              | otherwise = mkTvSubst in_scope -- when matching, don't confuse-                                               -- domain with range--------------------tcUnifyTys :: BindFun-           -> [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 GHC.Tc.Instance.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 :: BindFun-             -> [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---- | 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-                                             -- See Note [coreView vs tcView] in GHC.Core.Type--instance Outputable MaybeApartReason where-  ppr MARTypeFamily       = text "MARTypeFamily"-  ppr MARInfinite         = text "MARInfinite"-  ppr MARTypeVsConstraint = text "MARTypeVsConstraint"--instance Semigroup MaybeApartReason where-  -- see end of Note [Unification result] for why-  MARTypeFamily       <> r = r-  MARInfinite         <> _ = MARInfinite-  MARTypeVsConstraint <> r = r--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---- | @tcUnifyTysFG bind_tv tys1 tys2@ attempts 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 :: BindFun-             -> [Type] -> [Type]-             -> UnifyResult-tcUnifyTysFG bind_fn tys1 tys2-  = tc_unify_tys_fg False bind_fn tys1 tys2--tcUnifyTyKisFG :: BindFun-               -> [Type] -> [Type]-               -> UnifyResult-tcUnifyTyKisFG bind_fn tys1 tys2-  = tc_unify_tys_fg True bind_fn tys1 tys2--tc_unify_tys_fg :: Bool-                -> BindFun-                -> [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 :: BindFun-             -> 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)--- 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_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_skols    = emptyVarSet-                , 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 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.--}--niFixTCvSubst :: TvSubstEnv -> TCvSubst--- 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?-niFixTCvSubst tenv-  | not_fixpoint = niFixTCvSubst (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-    init_in_scope = mkInScopeSet (fvVarSet range_fvs)-    subst = foldl' add_free_tv-                  (mkTvSubst init_in_scope tenv)-                  free_tvs--    add_free_tv :: TCvSubst -> TyVar -> TCvSubst-    add_free_tv subst tv-      = extendTvSubst subst tv (mkTyVarTy tv')-     where-        tv' = updateTyVarKind (substTy subst) tv--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-  = nonDetStrictFoldUniqSet (unionVarSet . get) emptyVarSet tvs-  -- It's OK to use a non-deterministic fold 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 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.Canonical), 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. 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 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 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 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 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.--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).--}---------------- unify_ty: the main workhorse -------------type AmIUnifying = Bool   -- True  <=> Unifying-                          -- False <=> Matching--unify_ty :: UMEnv-         -> Type -> Type  -- Types to be unified and a co-         -> CoercionN     -- A coercion between their kinds-                          -- See Note [Kind coercions in Unify]-         -> UM ()--- 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 [Comparing nullary type synonyms] in GHC.Core.Type.-  | tc1 == tc2-  = return ()--  -- See Note [coreView vs tcView] in GHC.Core.Type.-  | tc1 `hasKey` constraintKindTyConKey-  , tc2 `hasKey` liftedTypeKindTyConKey-  = maybeApart MARTypeVsConstraint--  | tc2 `hasKey` constraintKindTyConKey-  , tc1 `hasKey` liftedTypeKindTyConKey-  = maybeApart MARTypeVsConstraint--unify_ty env ty1 ty2 kco-    -- Now handle the cases we can "look through": synonyms and casts.-  | Just ty1' <- tcView ty1   = unify_ty env ty1' ty2 kco-  | Just ty2' <- tcView ty2   = unify_ty env ty1 ty2' kco-  | CastTy ty1' co <- ty1     = if um_unif env-                                then unify_ty env ty1' ty2 (co `mkTransCo` kco)-                                else -- See Note [Matching in the presence of casts (1)]-                                     do { subst <- getSubst env-                                        ; let co' = substCo subst co-                                        ; 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- -- NB: This keeps Constraint and Type distinct, as it should for use in the- -- type-checker.-  | Just (tc1, tys1) <- mb_tc_app1-  , Just (tc2, tys2) <- mb_tc_app2-  , tc1 == tc2-  = if isInjectiveTyCon tc1 Nominal-    then unify_tys env tys1 tys2-    else do { let inj | isTypeFamilyTyCon tc1-                      = case tyConInjectivityInfo 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 MARTypeFamily $ 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 MARTypeFamily--  | Just (tc2, _) <- mb_tc_app2-  , not (isGenerativeTyCon tc2 Nominal)-  , um_unif env-    -- E.g.   unify_ty [a] (F ty2) =  MaybeApart, when unifying (only)-    --        because the (F ty2) behaves like a variable-    --        NB: we have already dealt with the 'ty1 = variable' case-  = maybeApart MARTypeFamily--  where-    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]--  -- tcSplitTyConApp won't split a (=>), so we handle this separately.-unify_ty env (FunTy InvisArg _w1 arg1 res1) (FunTy InvisArg _w2 arg2 res2) _kco-   -- Look at result representations, but arg representations would be redundant-   -- as anything that can appear to the left of => is lifted.-   -- And anything that can appear to the left of => is unrestricted, so skip the-   -- multiplicities.-  | Just res_rep1 <- getRuntimeRep_maybe res1-  , Just res_rep2 <- getRuntimeRep_maybe res2-  = unify_tys env [res_rep1, arg1, res1] [res_rep2, arg2, res2]--unify_ty _ (LitTy x) (LitTy y) _kco | x == y = return ()--unify_ty env (ForAllTy (Bndr tv1 _) ty1) (ForAllTy (Bndr tv2 _) ty2) kco-  = 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)-             , let (_, co_l, co_r) = decomposeFunCo Nominal kco-                     -- Because the coercion is used in a type, it should be safe to-                     -- ignore the multiplicity coercion.-                      -- 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 <- tvBindFlag env cv (CoercionTy rhs_co)-             -> do { checkRnEnv env (tyCoVarsOfCo co2)-                   ; extendCvEnv cv rhs_co }-           _ -> 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 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 ()-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]------------------------------------uVar :: UMEnv-     -> InTyVar         -- Variable to be unified-     -> Type            -- with this Type-     -> Coercion        -- :: kind tv ~N kind ty-     -> UM ()--uVar env tv1 ty kco- = do { -- Apply the ambient renaming-        let tv1' = umRnOccL env tv1--        -- Check to see whether tv1 is refined by the substitution-      ; subst <- getTvSubstEnv-      ; case (lookupVarEnv subst tv1') of-          Just ty' | um_unif env                -- Unifying, so call-                   -> unify_ty env ty' ty kco   -- 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.-                      unless ((ty' `mkCastTy` kco) `tcEqType` ty) $-                        surelyApart-                      -- NB: it's important to use `tcEqType` instead of `eqType` here,-                      -- otherwise we might not reject a substitution-                      -- which unifies `Type` with `Constraint`, e.g.-                      -- a call to tc_unify_tys with arguments-                      ---                      --   tys1 = [k,k]-                      --   tys2 = [Type, Constraint]-                      ---                      -- See test cases: T11715b, T20521.-          Nothing  -> uUnrefined env tv1' ty ty kco } -- No, continue--uUnrefined :: UMEnv-           -> OutTyVar          -- 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-    -- Use tcView, not coreView. See Note [coreView vs tcView] in GHC.Core.Type.-  | Just ty2'' <- tcView 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 tv2' = umRnOccR env tv2-       ; unless (tv1' == tv2' && um_unif env) $ do-           -- If we are unifying a ~ a, just return immediately-           -- Do not extend the substitution-           -- See Note [Self-substitution when matching]--          -- Check to see whether tv2 is refined-       { subst <- getTvSubstEnv-       ; case lookupVarEnv subst tv2 of-         {  Just ty' | um_unif env -> uUnrefined env tv1' ty' ty' kco-         ;  _ ->--    do {   -- So both are unrefined-           -- Bind one or the other, depending on which is bindable-       ; let rhs1 = ty2 `mkCastTy` mkSymCo kco-             rhs2 = ty1 `mkCastTy` kco-             b1  = tvBindFlag env tv1' rhs1-             b2  = tvBindFlag env tv2' rhs2-             ty1 = mkTyVarTy tv1'-       ; case (b1, b2) of-           (BindMe, _) -> bindTv env tv1' rhs1-           (_, BindMe) | um_unif env-                       -> bindTv (umSwapRn env) tv2 rhs2--           _ | tv1' == tv2' -> return ()-             -- How could this happen? If we're only matching and if-             -- we're comparing forall-bound variables.--           _ -> surelyApart-  }}}}--uUnrefined env tv1' ty2 _ kco -- ty2 is not a type variable-  = case tvBindFlag env tv1' rhs of-      Apart  -> surelyApart-      BindMe -> bindTv env tv1' rhs-  where-    rhs = ty2 `mkCastTy` mkSymCo kco--bindTv :: UMEnv -> OutTyVar -> Type -> UM ()--- OK, so we want to extend the substitution with tv := ty--- But first, we must do a couple of checks-bindTv env tv1 ty2-  = do  { let free_tvs2 = tyCoVarsOfType ty2--        -- Make sure tys mentions no local variables-        -- E.g.  (forall a. b) ~ (forall a. [a])-        -- We should not unify b := [a]!-        ; checkRnEnv env free_tvs2--        -- Occurs check, see Note [Fine-grained unification]-        -- Make sure you include 'kco' (which ty2 does) #14846-        ; occurs <- occursCheck env tv1 free_tvs2--        ; if occurs then maybeApart MARInfinite-                    else extendTvEnv tv1 ty2 }--occursCheck :: UMEnv -> TyVar -> VarSet -> UM Bool-occursCheck env tv free_tvs-  | um_unif env-  = do { tsubst <- getTvSubstEnv-       ; return (tv `elemVarSet` niSubstTvSet tsubst free_tvs) }--  | otherwise      -- Matching; no occurs check-  = return False   -- See Note [Self-substitution when matching]--{--%************************************************************************-%*                                                                      *-                Binding decisions-*                                                                      *-************************************************************************--}--data BindFlag-  = BindMe      -- ^ A regular type variable--  | Apart       -- ^ Declare that this type variable is /apart/ from the-                -- type provided. That is, the type variable will never-                -- be instantiated to that type.-                -- See also Note [Binding when looking up instances]-                -- in GHC.Core.InstEnv.-  deriving Eq--- NB: It would be conceivable to have an analogue to MaybeApart here,--- but there is not yet a need.--{--************************************************************************-*                                                                      *-                Unification monad-*                                                                      *-************************************************************************--}--data UMEnv-  = UMEnv { um_unif :: AmIUnifying--          , um_inj_tf :: Bool-            -- Checking for injectivity?-            -- See (end of) Note [Specification of unification]--          , um_rn_env :: RnEnv2-            -- Renaming InTyVars to OutTyVars; this eliminates-            -- shadowing, and lines up matching foralls on the left-            -- and right--          , um_skols :: TyVarSet-            -- OutTyVars bound by a forall in this unification;-            -- Do not bind these in the substitution!-            -- See the function tvBindFlag--          , um_bind_fun :: BindFun-            -- User-supplied BindFlag function,-            -- for variables not in um_skols-          }--data UMState = UMState-                   { um_tv_env   :: TvSubstEnv-                   , um_cv_env   :: CvSubstEnv }--newtype UM a-  = UM' { unUM :: UMState -> UnifyResultM (UMState, a) }-    -- See Note [The one-shot state monad trick] in GHC.Utils.Monad-  deriving (Functor)--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)--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 a -> UnifyResultM a-initUM subst_env cv_subst_env um-  = case unUM um state of-      Unifiable (_, subst)    -> Unifiable subst-      MaybeApart r (_, subst) -> MaybeApart r subst-      SurelyApart             -> SurelyApart-  where-    state = UMState { um_tv_env = subst_env-                    , um_cv_env = cv_subst_env }--tvBindFlag :: UMEnv -> OutTyVar -> Type -> BindFlag-tvBindFlag env tv rhs-  | tv `elemVarSet` um_skols env = Apart-  | otherwise                    = um_bind_fun env tv rhs--getTvSubstEnv :: UM TvSubstEnv-getTvSubstEnv = UM $ \state -> Unifiable (state, um_tv_env state)--getCvSubstEnv :: UM CvSubstEnv-getCvSubstEnv = UM $ \state -> Unifiable (state, um_cv_env state)--getSubst :: UMEnv -> UM TCvSubst-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 }, ())--umRnBndr2 :: UMEnv -> TyCoVar -> TyCoVar -> UMEnv-umRnBndr2 env v1 v2-  = env { um_rn_env = rn_env', um_skols = um_skols env `extendVarSet` v' }-  where-    (rn_env', v') = rnBndr2_var (um_rn_env env) v1 v2--checkRnEnv :: UMEnv -> VarSet -> UM ()-checkRnEnv env varset-  | isEmptyVarSet skol_vars           = return ()-  | varset `disjointVarSet` skol_vars = return ()-  | otherwise                         = surelyApart-  where-    skol_vars = um_skols env-    -- 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 (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 :: lty ~r rty, coercion to match against-            -> Coercion   -- ^ :: kind(lsubst(ty)) ~N kind(lty)-            -> Coercion   -- ^ :: kind(rsubst(ty)) ~N kind(rty)-            -> Maybe LiftCoEnv-   -- ^ Just env ==> liftCoSubst Nominal env ty == co, modulo roles.-   -- Also: Just env ==> lsubst(ty) == lty and rsubst(ty) == rty,-   -- where lsubst = lcSubstLeft(env) and rsubst = lcSubstRight(env)-ty_co_match menv subst ty co lkco rkco-  | Just ty' <- coreView ty = ty_co_match menv subst ty' co lkco rkco-     -- why coreView here, not tcView? Because we're firmly after type-checking.-     -- This function is used only during coercion optimisation.--  -- 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  = mkEmptyTCvSubst (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) <- 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 _ w ty1 ty2) co _lkco _rkco-  | Just (tc, [co_mult,rrco1,rrco2,co1,co2]) <- splitTyConAppCo_maybe co-  , tc == funTyCon-  = let rr1 = getRuntimeRep ty1-        rr2 = getRuntimeRep ty2-        Pair lkcos rkcos = traverse (fmap (mkNomReflCo . typeKind) . coercionKind)-                             [co_mult,rrco1, rrco2,co1,co2]-    in  -- NB: we include the RuntimeRep arguments in the matching; not doing so caused #21205.-        ty_co_match_args menv subst-          [w, rr1, rr2, ty1, ty2]-          [co_mult, rrco1, rrco2, co1, co2]-          lkcos rkcos--ty_co_match menv subst (ForAllTy (Bndr tv1 _) ty1)-                       (ForAllCo tv2 kind_co2 co2)-                       lkco rkco-  | isTyVar tv1 && isTyVar tv2-  = 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      = mkNthCo role 2 (downgradeRole r Nominal kind_co2)---                 :: s1' ~ t1---        eta2      = mkNthCo role 3 (downgradeRole r Nominal kind_co2)---                 :: s2' ~ t2---      Wanted:---        subst1 <- ty_co_match menv subst  s1 eta1 kco1 kco2---        subst2 <- ty_co_match menv subst1 s2 eta2 kco3 kco4---      Question: How do we get kcoi?---   2. Given:---        lkco :: <*>    -- See Note [Weird typing rule for ForAllTy] in GHC.Core.TyCo.Rep---        rkco :: <*>---      Wanted:---        ty_co_match menv' subst2 ty1 co2 lkco' rkco'---      Question: How do we get lkco' and rkco'?--ty_co_match _ subst (CoercionTy {}) _ _ _-  = Just subst -- don't inspect coercions--ty_co_match menv subst ty (GRefl r t (MCo co)) lkco rkco-  =  ty_co_match menv subst ty (GRefl r t MRefl) lkco (rkco `mkTransCo` mkSymCo co)--ty_co_match menv subst ty co1 lkco rkco-  | Just (CastTy t co, r) <- isReflCo_maybe co1-  -- In @pushRefl@, pushing reflexive coercion inside CastTy will give us-  -- t |> co ~ t ; <t> ; t ~ t |> co-  -- But transitive coercions are not helpful. Therefore we deal-  -- with it here: we do recursion on the smaller reflexive coercion,-  -- while propagating the correct kind coercions.-  = let kco' = mkSymCo co-    in ty_co_match menv subst ty (mkReflCo r t) (lkco `mkTransCo` kco')-                                                (rkco `mkTransCo` kco')---ty_co_match menv subst ty co lkco rkco-  | Just co' <- pushRefl co = ty_co_match menv subst ty co' lkco rkco-  | otherwise               = Nothing--ty_co_match_tc :: MatchEnv -> LiftCoEnv-               -> TyCon -> [Type]-               -> TyCon -> [Coercion]-               -> Maybe LiftCoEnv-ty_co_match_tc menv subst tc1 tys1 tc2 cos2-  = do { guard (tc1 == tc2)-       ; ty_co_match_args menv subst tys1 cos2 lkcos rkcos }-  where-    Pair lkcos rkcos-      = traverse (fmap (mkNomReflCo . typeKind) . 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 . typeKind) . 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 co =-  case (isReflCo_maybe co) of-    Just (AppTy ty1 ty2, Nominal)-      -> Just (AppCo (mkReflCo Nominal ty1) (mkNomReflCo ty2))-    Just (FunTy _ w ty1 ty2, r)-      | Just rep1 <- getRuntimeRep_maybe ty1-      , Just rep2 <- getRuntimeRep_maybe ty2-      ->  Just (TyConAppCo r funTyCon [ multToCo w, mkReflCo r rep1, mkReflCo r rep2-                                       , mkReflCo r ty1,  mkReflCo r ty2 ])-    Just (TyConApp tc tys, r)-      -> Just (TyConAppCo r tc (zipWith mkReflCo (tyConRolesX r tc) tys))-    Just (ForAllTy (Bndr tv _) ty, r)-      -> Just (ForAllCo tv (mkNomReflCo (varType tv)) (mkReflCo r ty))-    -- NB: NoRefl variant. Otherwise, we get a loop!-    _ -> Nothing--{--************************************************************************-*                                                                      *-              Flattening-*                                                                      *-************************************************************************--Note [Flattening type-family applications when matching instances]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-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.--We also use this flattening operation to check for class instances.-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. So we-flatten the (F a) in the target before trying to unify with instances.-(This is done in GHC.Core.InstEnv.lookupInstEnv'.)--The algorithm works by building up a TypeMap TyVar, mapping-type family applications to fresh variables. This mapping must-be threaded through all the function calls, as any entry in-the mapping must be propagated to all future nodes in the tree.--The algorithm also must track the set of in-scope variables, in-order to make fresh variables as it flattens. (We are far from a-source of fresh Uniques.) See Wrinkle 2, below.--There are wrinkles, of course:--1. The flattening algorithm must account for the possibility-   of inner `forall`s. (A `forall` seen here can happen only-   because of impredicativity. However, the flattening operation-   is an algorithm in Core, which is impredicative.)-   Suppose we have (forall b. F b) -> (forall b. F b). Of course,-   those two bs are entirely unrelated, and so we should certainly-   not flatten the two calls F b to the same variable. Instead, they-   must be treated separately. We thus carry a substitution that-   freshens variables; we must apply this substitution (in-   `coreFlattenTyFamApp`) before looking up an application in the environment.-   Note that the range of the substitution contains only TyVars, never anything-   else.--   For the sake of efficiency, we only apply this substitution when absolutely-   necessary. Namely:--   * We do not perform the substitution at all if it is empty.-   * We only need to worry about the arguments of a type family that are within-     the arity of said type family, so we can get away with not applying the-     substitution to any oversaturated type family arguments.-   * Importantly, we do /not/ achieve this substitution by recursively-     flattening the arguments, as this would be wrong. Consider `F (G a)`,-     where F and G are type families. We might decide that `F (G a)` flattens-     to `beta`. Later, the substitution is non-empty (but does not map `a`) and-     so we flatten `G a` to `gamma` and try to flatten `F gamma`. Of course,-     `F gamma` is unknown, and so we flatten it to `delta`, but it really-     should have been `beta`! Argh!--     Moral of the story: instead of flattening the arguments, just substitute-     them directly.--2. There are two different reasons we might add a variable-   to the in-scope set as we work:--     A. We have just invented a new flattening variable.-     B. We have entered a `forall`.--   Annoying here is that in-scope variable source (A) must be-   threaded through the calls. For example, consider (F b -> forall c. F c).-   Suppose that, when flattening F b, we invent a fresh variable c.-   Now, when we encounter (forall c. F c), we need to know c is already in-   scope so that we locally rename c to c'. However, if we don't thread through-   the in-scope set from one argument of (->) to the other, we won't know this-   and might get very confused.--   In contrast, source (B) increases only as we go deeper, as in-scope sets-   normally do. However, even here we must be careful. The TypeMap TyVar that-   contains mappings from type family applications to freshened variables will-   be threaded through both sides of (forall b. F b) -> (forall b. F b). We-   thus must make sure that the two `b`s don't get renamed to the same b1. (If-   they did, then looking up `F b1` would yield the same flatten var for-   each.) So, even though `forall`-bound variables should really be in the-   in-scope set only when they are in scope, we retain these variables even-   outside of their scope. This ensures that, if we encounter a fresh-   `forall`-bound b, we will rename it to b2, not b1. Note that keeping a-   larger in-scope set than strictly necessary is always OK, as in-scope sets-   are only ever used to avoid collisions.--   Sadly, the freshening substitution described in (1) really mustn't bind-   variables outside of their scope: note that its domain is the *unrenamed*-   variables. This means that the substitution gets "pushed down" (like a-   reader monad) while the in-scope set gets threaded (like a state monad).-   Because a TCvSubst contains its own in-scope set, we don't carry a TCvSubst;-   instead, we just carry a TvSubstEnv down, tying it to the InScopeSet-   traveling separately as necessary.--3. Consider `F ty_1 ... ty_n`, where F is a type family with arity k:--     type family F ty_1 ... ty_k :: res_k--   It's tempting to just flatten `F ty_1 ... ty_n` to `alpha`, where alpha is a-   flattening skolem. But we must instead flatten it to-   `alpha ty_(k+1) ... ty_n`—that is, by only flattening up to the arity of the-   type family.--   Why is this better? Consider the following concrete example from #16995:--     type family Param :: Type -> Type--     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`. But if we flatten `Param ()` to `alpha`, then GHC can't be sure if-   `alpha` is apart from `f Char`, so it won't fall through to the second-   equation. But since the `Param` type family has arity 0, we can instead-   flatten `Param ()` to `alpha ()`, about which GHC knows with confidence is-   apart from `f Char`, permitting the second equation to be reached.--   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.--flattenTys is defined here because of module dependencies.--}--data FlattenEnv-  = FlattenEnv { fe_type_map :: TypeMap (TyVar, TyCon, [Type])-                 -- domain: exactly-saturated type family applications-                 -- range: (fresh variable, type family tycon, args)-               , fe_in_scope :: InScopeSet }-                 -- See Note [Flattening type-family applications when matching instances]--emptyFlattenEnv :: InScopeSet -> FlattenEnv-emptyFlattenEnv in_scope-  = FlattenEnv { fe_type_map = emptyTypeMap-               , fe_in_scope = in_scope }--updateInScopeSet :: FlattenEnv -> (InScopeSet -> InScopeSet) -> FlattenEnv-updateInScopeSet env upd = env { fe_in_scope = upd (fe_in_scope env) }--flattenTys :: InScopeSet -> [Type] -> [Type]--- See Note [Flattening type-family applications when matching instances]-flattenTys in_scope tys = fst (flattenTysX in_scope tys)--flattenTysX :: InScopeSet -> [Type] -> ([Type], TyVarEnv (TyCon, [Type]))--- See Note [Flattening type-family applications when matching instances]--- NB: the returned types mention the fresh type variables---     in the domain of the returned env, whose range includes---     the original type family applications. Building a substitution---     from this information and applying it would yield the original---     types -- almost. The problem is that the original type might---     have something like (forall b. F a b); the returned environment---     can't really sensibly refer to that b. So it may include a locally----     bound tyvar in its range. Currently, the only usage of this env't---     checks whether there are any meta-variables in it---     (in GHC.Tc.Solver.Monad.mightEqualLater), so this is all OK.-flattenTysX in_scope tys-  = let (env, result) = coreFlattenTys emptyTvSubstEnv (emptyFlattenEnv in_scope) tys in-    (result, build_env (fe_type_map env))-  where-    build_env :: TypeMap (TyVar, TyCon, [Type]) -> TyVarEnv (TyCon, [Type])-    build_env env_in-      = foldTM (\(tv, tc, tys) env_out -> extendVarEnv env_out tv (tc, tys))-               env_in emptyVarEnv--coreFlattenTys :: TvSubstEnv -> FlattenEnv-               -> [Type] -> (FlattenEnv, [Type])-coreFlattenTys subst = mapAccumL (coreFlattenTy subst)--coreFlattenTy :: TvSubstEnv -> FlattenEnv-              -> Type -> (FlattenEnv, Type)-coreFlattenTy subst = go-  where-    go env ty | Just ty' <- coreView ty = go env ty'--    go env (TyVarTy tv)-      | Just ty <- lookupVarEnv subst tv = (env, ty)-      | otherwise                        = let (env', ki) = go env (tyVarKind tv) in-                                           (env', mkTyVarTy $ setTyVarKind tv ki)-    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)-      = coreFlattenTyFamApp subst env tc tys--      | otherwise-      = let (env', tys') = coreFlattenTys subst env tys in-        (env', mkTyConApp tc tys')--    go env ty@(FunTy { ft_mult = mult, ft_arg = ty1, ft_res = ty2 })-      = let (env1, ty1') = go env  ty1-            (env2, ty2') = go env1 ty2-            (env3, mult') = go env2 mult in-        (env3, ty { ft_mult = mult', ft_arg = ty1', ft_res = ty2' })--    go env (ForAllTy (Bndr tv vis) ty)-      = let (env1, subst', tv') = coreFlattenVarBndr subst env tv-            (env2, ty') = coreFlattenTy subst' env1 ty in-        (env2, ForAllTy (Bndr tv' vis) ty')--    go env ty@(LitTy {}) = (env, ty)--    go env (CastTy ty co)-      = let (env1, ty') = go env ty-            (env2, co') = coreFlattenCo subst env1 co in-        (env2, CastTy ty' co')--    go env (CoercionTy co)-      = let (env', co') = coreFlattenCo subst 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 :: TvSubstEnv -> FlattenEnv-              -> Coercion -> (FlattenEnv, Coercion)-coreFlattenCo subst env co-  = (env2, mkCoVarCo covar)-  where-    (env1, kind') = coreFlattenTy subst env (coercionType co)-    covar         = mkFlattenFreshCoVar (fe_in_scope env1) kind'-    -- Add the covar to the FlattenEnv's in-scope set.-    -- See Note [Flattening type-family applications when matching instances], wrinkle 2A.-    env2          = updateInScopeSet env1 (flip extendInScopeSet covar)--coreFlattenVarBndr :: TvSubstEnv -> FlattenEnv-                   -> TyCoVar -> (FlattenEnv, TvSubstEnv, TyVar)-coreFlattenVarBndr subst env tv-  = (env2, subst', tv')-  where-    -- See Note [Flattening type-family applications when matching instances], wrinkle 2B.-    kind          = varType tv-    (env1, kind') = coreFlattenTy subst env kind-    tv'           = uniqAway (fe_in_scope env1) (setVarType tv kind')-    subst'        = extendVarEnv subst tv (mkTyVarTy tv')-    env2          = updateInScopeSet env1 (flip extendInScopeSet tv')--coreFlattenTyFamApp :: TvSubstEnv -> FlattenEnv-                    -> TyCon         -- type family tycon-                    -> [Type]        -- args, already flattened-                    -> (FlattenEnv, Type)-coreFlattenTyFamApp tv_subst env fam_tc fam_args-  = case lookupTypeMap type_map fam_ty of-      Just (tv, _, _) -> (env', mkAppTys (mkTyVarTy tv) leftover_args')-      Nothing ->-        let tyvar_name = mkFlattenFreshTyName fam_tc-            tv         = uniqAway in_scope $-                         mkTyVar tyvar_name (typeKind fam_ty)--            ty'   = mkAppTys (mkTyVarTy tv) leftover_args'-            env'' = env' { fe_type_map = extendTypeMap type_map fam_ty-                                                       (tv, fam_tc, sat_fam_args)-                         , fe_in_scope = extendInScopeSet in_scope tv }-        in (env'', ty')-  where-    arity = tyConArity fam_tc-    tcv_subst = TCvSubst (fe_in_scope env) tv_subst emptyVarEnv-    (sat_fam_args, leftover_args) = assert (arity <= length fam_args) $-                                    splitAt arity fam_args-    -- Apply the substitution before looking up an application in the-    -- environment. See Note [Flattening type-family applications when matching instances],-    -- wrinkle 1.-    -- NB: substTys short-cuts the common case when the substitution is empty.-    sat_fam_args' = substTys tcv_subst sat_fam_args-    (env', leftover_args') = coreFlattenTys tv_subst env leftover_args-    -- `fam_tc` may be over-applied to `fam_args` (see-    -- Note [Flattening type-family applications when matching instances]-    -- wrinkle 3), so we split it into the arguments needed to saturate it-    -- (sat_fam_args') and the rest (leftover_args')-    fam_ty = mkTyConApp fam_tc sat_fam_args'-    FlattenEnv { fe_type_map = type_map-               , fe_in_scope = in_scope } = env'--mkFlattenFreshTyName :: Uniquable a => a -> Name-mkFlattenFreshTyName unq-  = mkSysTvName (getUnique unq) (fsLit "flt")--mkFlattenFreshCoVar :: InScopeSet -> Kind -> CoVar-mkFlattenFreshCoVar in_scope kind-  = let uniq = unsafeGetFreshLocalUnique in_scope-        name = mkSystemVarName uniq (fsLit "flc")-    in mkCoVar name kind+{-# LANGUAGE ScopedTypeVariables, PatternSynonyms, MultiWayIf #-}++{-# LANGUAGE DeriveFunctor #-}++module GHC.Core.Unify (+        tcMatchTy, tcMatchTyKi,+        tcMatchTys, tcMatchTyKis,+        tcMatchTyX, tcMatchTysX, tcMatchTyKisX,+        tcMatchTyX_BM, ruleMatchTyKiX,++        -- Side-effect free unification+        tcUnifyTy, tcUnifyTys, tcUnifyFunDeps, tcUnifyDebugger,+        tcUnifyTysFG, tcUnifyTyForInjectivity,+        BindTvFun, BindFamFun, BindFlag(..),+        matchBindTv, alwaysBindTv, alwaysBindFam, dontCareBindFam,+        UnifyResult, UnifyResultM(..), MaybeApartReason(..),+        typesCantMatch, typesAreApart,++        -- Matching a type against a lifted type (coercion)+        liftCoMatch+   ) where++import GHC.Prelude++import GHC.Types.Var+import GHC.Types.Var.Env+import GHC.Types.Var.Set+import GHC.Builtin.Names( tYPETyConKey, cONSTRAINTTyConKey )+import GHC.Core.Type     hiding ( getTvSubstEnv )+import GHC.Core.Coercion hiding ( getCvSubstEnv )+import GHC.Core.Predicate( scopedSort )+import GHC.Core.TyCon+import GHC.Core.Predicate( CanEqLHS(..), canEqLHS_maybe )+import GHC.Core.TyCon.Env+import GHC.Core.TyCo.Rep+import GHC.Core.TyCo.Compare ( eqType, tcEqType, tcEqTyConAppArgs )+import GHC.Core.TyCo.FVs     ( tyCoVarsOfCoList, tyCoFVsOfTypes )+import GHC.Core.TyCo.Subst   ( mkTvSubst )+import GHC.Core.Map.Type+import GHC.Core.Multiplicity++import GHC.Utils.FV( FV, fvVarList )+import GHC.Utils.Misc+import GHC.Utils.Outputable+import GHC.Types.Basic( SwapFlag(..) )+import GHC.Types.Unique.FM+import GHC.Exts( oneShot )+import GHC.Utils.Panic++import GHC.Data.Pair+import GHC.Data.TrieMap+import GHC.Data.Maybe( orElse )++import Control.Monad+import qualified Data.Semigroup as S+import GHC.Builtin.Types.Prim (fUNTyCon)++{- Note [The Core unifier]+~~~~~~~~~~~~~~~~~~~~~~~~~~+This module contains the (pure) unifier two types.  It is subtle in a number+of ways.  Here we summarise, but see Note [Specification of unification].++(CU1) It creates a substition only for "bindable" or "template" type variables.+  These are identified by a `um_bind_tv_fun` function passed down in the `UMEnv`+  environment.++(CU2) We want to match in the presence of foralls;+        e.g     (forall a. t1) ~ (forall b. t2)+   That is what the `um_rn_env :: RnEnv2` field of `UMEnv` is for; it does the+   alpha-renaming that makes it as if `a` and `b` were the same variable.+   Initialising the `RnEnv2`, so that it can generate a fresh binder when+   necessary, entails knowing the free variables of both types.++   Of course, we must be careful not to bind a template type variable to a+   locally bound variable.  E.g.+        (forall a. x) ~ (forall b. b)+   where `x` is the template type variable.  Then we do not want to+   bind `x` to a/b!  See `mentionsForAllBoundTyVarsL/R`.++(CU3) We want to take special care for type families.+  See the big Note [Apartness and type families]++(CU4) Rather than returning just "unifiable" or "not-unifiable" we do "fine-grained"+  unification (hence "fg" or "FG" in this module) returning three possiblities,+  captured in `UnifyResult`:+    - Unifiable subst : certainly unifiable with this type substitution+    - SurelyApart     : cannot be unifiable, regardless of how type familes reduce+    - MaybeApart      : neither of the above+  See Note [Unification result].++  Four reasons for MaybeApart (see `MaybeApartReason`).  The first two are the+  big ones!+    * MARTypeFamily:+         Family reduction might make the two types equal+             Maybe (F Int) ~ Maybe Bool+         See Note [Apartness and type families]+    * MARInfinite (occurs check):+         See Note [Infinitary substitutions]+    * MARTypeVsConstraint:+         See Note [Type and Constraint are not apart] in GHC.Builtin.Types.Prim+    * MARCast (obscure):+         See (KCU2) in Note [Kind coercions in Unify]++(CU5) We need to take care with kinds.  See Note [tcMatchTy vs tcMatchTyKi]++(CU6) The "unifier" can also do /matching/, governed by `um_unif :: AmIUnifying`.+   When matching, the LHS and RHS namespaces are unrelated. In particular, the+   bindable type variable can occur (unrelatedly) in the RHS.  E.g.+        match  (a,Maybe a) ~  ([a], Maybe [a])+   We get the substitution [a :-> [a]], without confusing the+   LHS `a` with the RHS `a`.  The substitition is "one-shot", and should not be+   iterated.++Note [Infinitary substitutions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Do the types (x, x) and ([y], y) unify? The answer is seemingly "no" --+no substitution to finite types makes these match. This is the famous+"occurs check".++But, a substitution to *infinite* types can unify these two types:+  [x |-> [[...]]], y |-> [[[...]]] ].++Why do we care? Consider these two type family instances:++  type instance F x x   = Int+  type instance F [y] y = Bool++If we also have++  type instance Looper = [Looper]++then the instances potentially overlap -- they are not "apart". So we must+distinguish failure-to-unify from definitely-apart. The solution is to use+unification over infinite terms. This is possible (see [1] for lots of gory+details), but a full algorithm is a little more powerful than we need. Instead,+we make a conservative approximation and just omit the occurs check.++  [1]: http://research.microsoft.com/en-us/um/people/simonpj/papers/ext-f/axioms-extended.pdf++tcUnifyTys considers an occurs-check problem as the same as general unification+failure.++See also #8162.++It's worth noting that unification in the presence of infinite types is not+complete. This means that, sometimes, a closed type family does not reduce+when it should. See test case indexed-types/should_fail/Overlap15 for an+example.++Note [tcMatchTy vs tcMatchTyKi]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+This module offers two variants of matching: with kinds and without.+The TyKi variant takes two types, of potentially different kinds,+and matches them. Along the way, it necessarily also matches their+kinds. The Ty variant instead assumes that the kinds are already+eqType and so skips matching up the kinds.++How do you choose between them?++1. If you know that the kinds of the two types are eqType, use+   the Ty variant. It is more efficient, as it does less work.++2. If the kinds of variables in the template type might mention type families,+   use the Ty variant (and do other work to make sure the kinds+   work out). These pure unification functions do a straightforward+   syntactic unification and do no complex reasoning about type+   families. Note that the types of the variables in instances can indeed+   mention type families, so instance lookup must use the Ty variant.++   (Nothing goes terribly wrong -- no panics -- if there might be type+   families in kinds in the TyKi variant. You just might get match+   failure even though a reducing a type family would lead to success.)++3. Otherwise, if you're sure that the variable kinds do not mention+   type families and you're not already sure that the kind of the template+   equals the kind of the target, then use the TyKi version.++Note [Unification result]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+See `UnifyResult` and `UnifyResultM`.  When unifying t1 ~ t2, we return+* Unifiable s, if s is a substitution such that s(t1) is syntactically the+  same as s(t2), modulo type-synonym expansion.+* SurelyApart, if there is no substitution s such that s(t1) = s(t2),+  where "=" includes type-family reductions.+* MaybeApart mar s, when we aren't sure. `mar` is a MaybeApartReason.++Examples+* [a] ~ Maybe b: SurelyApart, because [] and Maybe can't unify++* [(a,Int)] ~ [(Bool,b)]:  Unifiable++* [F Int] ~ [Bool]: MaybeApart MARTypeFamily, because F Int might reduce to Bool+                    (the unifier does not try this)++* a ~ Maybe a: MaybeApart MARInfinite. Not Unifiable clearly, but not SurelyApart+    either; consider+       a := Loop+       where  type family Loop where Loop = Maybe Loop++Wrinkle (UR1): see `combineMAR`+   There is the possibility that two types are MaybeApart for *both* reasons:++   * (a, F Int) ~ (Maybe a, Bool)++   What reason should we use? The *only* consumer of the reason is described+   in Note [Infinitary substitution in lookup] in GHC.Core.InstEnv. The goal+   there is identify which instances might match a target later (but don't+   match now) -- except that we want to ignore the possibility of infinitary+   substitutions. So let's examine a concrete scenario:++     class C a b c+     instance C a (Maybe a) Bool+     -- other instances, including one that will actually match+     [W] C b b (F Int)++   Do we want the instance as a future possibility? No. The only way that+   instance can match is in the presence of an infinite type (infinitely nested+   Maybes). We thus say that `MARInfinite` takes precedence, so that InstEnv treats+   this case as an infinitary substitution case; the fact that a type family is+   involved is only incidental. We thus define `combineMAR` to prefer+   `MARInfinite`.++Note [Apartness and type families]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this:++  type family F a b where+    F Int Bool = Char+    F a   b    = Double+  type family G a         -- open, no instances++How do we reduce (F (G Float) (G Float))? The first equation clearly doesn't+match immediately while the second equation does. But, before reducing, we must+make sure that the target can never become (F Int Bool). Well, no matter what G+Float becomes, it certainly won't become *both* Int and Bool, so indeed we're+safe reducing (F (G Float) (G Float)) to Double.++So we must say that the argument list+     (G Float) (G Float)   is SurelyApart from   Int Bool++This is necessary not only to get more reductions (which we might be willing to+give up on), but for /substitutivity/. If we have (F x x), we can see that (F x x)+can reduce to Double. So, it had better be the case that (F blah blah) can+reduce to Double, no matter what (blah) is!++To achieve this, `go` in `uVarOrFam` does this;++* We maintain /two/ substitutions, not just one:+     * um_tv_env: the regular substitution, mapping TyVar :-> Type+     * um_fam_env: maps (TyCon,[Type]) :-> Type, where the LHS is a type-fam application+  In effect, these constitute one substitution mapping+     CanEqLHS :-> Types++* When we attempt to unify (G Float) ~ Int, we return MaybeApart..+  but we /also/ add a "family substitution" [G Float :-> Int],+  to `um_fam_env`. See the `BindMe` case of `go` in `uVarOrFam`.++* When we later encounter (G Float) ~ Bool, we apply the family substitution,+  very much as we apply the conventional [tyvar :-> type] substitution+  when we encounter a type variable.  See the `lookupFamEnv` in `go` in+  `uVarOrFam`.++  So (G Float ~ Bool) becomes (Int ~ Bool) which is SurelyApart.  Bingo.+++Wrinkles++(ATF0) Once we encounter a type-family application, we only ever return+             MaybeApart   or   SurelyApart+  but never `Unifiable`.  Accordingly, we only return a TyCoVar substitution+  from `tcUnifyTys` and friends; we don't return a type-family substitution as+  well.  (We could imagine doing so, though.)++(ATF1) Exactly the same mechanism is used in class-instance checking.+    If we have+        instance C (Maybe b)+        instance {-# OVERLAPPING #-} C (Maybe Bool)+        [W] C (Maybe (F a))+    we want to know that the second instance might match later, when we know more about `a`.+    The function `GHC.Core.InstEnv.instEnvMatchesAndUnifiers` uses `tcUnifyTysFG` to+    account for type families in the type being matched.++(ATF2) A very similar check is made in `GHC.Tc.Utils.Unify.mightEqualLater`, which+  again uses `tcUnifyTysFG` to account for the possibility of type families.  See+  Note [What might equal later?] in GHC.Tc.Utils.Unify, esp example (10).++(ATF3) What about foralls?   For example, supppose we are unifying+           (forall a. F a) -> (forall a. F a)+   against some other type. Those two (F a) types are unrelated, bound by+   different foralls; we cannot extend the um_fam_env with a binding [F a :-> blah]++   So to keep things simple, the entire family-substitution machinery is used+   only if there are no enclosing foralls (see the `under_forall` check in+   `uSatFamApp`).  That's fine, because the apartness business is used only for+   reducing type-family applications, and class instances, and their arguments+   can't have foralls anyway.++   The bottom line is that we won't discover that+       (forall a. (a, F Int, F Int))+   is surely apart from+       (forall a. (a, Int, Bool))+   but that doesn't matter.  Fixing this would be possible, but would require+   quite a bit of head-scratching.++(ATF4) The family substitution only has /saturated/ family applications in+   its domain. Consider the following concrete example from #16995:++     type family Param :: Type -> Type   -- arity 0++     type family LookupParam (a :: Type) :: Type where+       LookupParam (f Char) = Bool+       LookupParam x        = Int++     foo :: LookupParam (Param ())+     foo = 42++   In order for `foo` to typecheck, `LookupParam (Param ())` must reduce to+   `Int`.  So    (f Char) ~ (Param ())   must be SurelyApart.  Remember, since+   `Param` is a nullary type family, it is over-saturated in (Param ()).+   This unification will only be SurelyApart if we decompose the outer AppTy+   separately, to then give (() ~ Char).++   Not only does this allow more programs to be accepted, it's also important+   for correctness. Not doing this was the root cause of the Core Lint error+   in #16995.++(ATF5) Consider+          instance (Generic1 f, Ord (Rep1 f a))+                => Ord (Generically1 f a) where ...+              -- The "..." gives rise to [W] Ord (Generically1 f a)+   where Rep1 is a type family.++   We must use the instance decl (recursively) to simplify the [W] constraint;+   we do /not/ want to worry that the `[G] Ord (Rep1 f a)` might be an+   alternative path.  So `noMatchableGivenDicts` must return False;+   so `mightMatchLater` must return False; so when um_bind_fam_fun returns+   `DontBindMe`, the unifier must return `SurelyApart`, not `MaybeApart`.  See+   `go` in `uVarOrFam`++   This looks a bit sketchy, because they aren't SurelyApart, but see+   Note [What might equal later?] in GHC.Tc.Utils.Unify, esp "Red Herring".++   If we are under a forall, we return `MaybeApart`; that seems more conservative,+   and class constraints are on tau-types so it doesn't matter.++(ATF6) When /matching/ can we ever have a type-family application on the LHS, in+   the template?  You might think not, because type-class-instance and+   type-family-instance heads can't include type families.  E.g.+            instance C (F a) where ...  -- Illegal++   But you'd be wrong: even when matching, we can see type families in the LHS template:+   * In `checkValidClass`, in `check_dm` we check that the default method has the+      right type, using matching, both ways.  And that type may have type-family+      applications in it. Examples in test CoOpt_Singletons and T26457.++   * In the specialiser: see the call to `tcMatchTy` in+     `GHC.Core.Opt.Specialise.beats_or_same`++   * With -fpolymorphic-specialisation, we might get a specialiation rule like+         RULE forall a (d :: Eq (Maybe (F a))) .+                 f @(Maybe (F a)) d = ...+     See #25965.++   * A user-written RULE could conceivably have a type-family application+     in the template.  It might not be a good rule, but I don't think we currently+     check for this.++    In all these cases we are only interested in finding a substitution /for+    type variables/ that makes the match work.  So we simply want to recurse into+    the arguments of the type family.  E.g.+       Template:   forall a.  Maybe (F a)+       Target:     Maybe (F Int)+    We want to succeed with substitution [a :-> Int].  See (ATF9).++    Conclusion: where we enter via `tcMatchTy`, `tcMatchTys`, `tc_match_tys`,+    etc, we always end up in `tc_match_tys_x`.  There we invoke the unifier+    but we do not distinguish between `SurelyApart` and `MaybeApart`. So in+    these cases we can set `um_bind_fam_fun` to `neverBindFam`.++(ATF7) There is one other, very special case of matching where we /do/ want to+   bind type families in `um_fam_env`, namely in GHC.Tc.Solver.Equality, the call+   to `tcUnifyTyForInjectivity False` in `improve_injective_wanted_top`.+   Consider+   of a match. Consider+      type family G6 a = r | r -> a+      type instance G6 [a]  = [G a]+      type instance G6 Bool = Int+   and suppose we have a Wanted constraint+      [W] G6 alpha ~ [Int]+   According to Section 5.2 of "Injective type families for Haskell", we /match/+   the RHS each of type instance with [Int].  So we try+        Template: [G a]    Target: [Int]+   and we want to succeed with MaybeApart, so that we can generate the improvement+   constraint+        [W] alpha ~ [beta]+   where beta is fresh.  We do this by binding [G a :-> Int]++(ATF8) The treatment of type families is governed by+         um_bind_fam_fun :: BindFamFun+  in UMEnv, where+         type BindFamFun = TyCon -> [Type] -> Type -> BindFlag+  There are some simple BindFamFun functions provided:+     alwaysBindFam    do the clever stuff above+     neverBindFam     treat type families as SurelyApart+     dontCareBindFam  type families shouldn't exist at all+  This function only affects the difference between the results MaybeApart and+  SurelyApart; it never does not affect whether or not we return Unifiable.++(ATF9) Decomposition.  Consider unifying+          F a  ~  F Int+  when `um_bind_fam_fun` says DontBindMe.  There is a unifying substitition [a :-> Int],+  and we want to find it, returning Unifiable. Why?+    - Remember, this is the Core unifier -- we are not doing type inference+    - When we have two equal types, like  F a ~ F a, it is ridiculous to say that they+      are MaybeApart.  Example: the two-way tcMatchTy in `checkValidClass` and #26457.++  (ATF9-1) But consider unifying+          F Int ~ F Bool+    Although Int and Bool are SurelyApart, we must return MaybeApart for the outer+    unification.  Hence the use of `don'tBeSoSure` in `go_fam_fam`; it leaves Unifiable+    alone, but weakens `SurelyApart` to `MaybeApart`.++  (ATF9-2) We want this decomposition to occur even under a forall (this was #26457).+    E.g.    (forall a. F Int) -> Int  ~   (forall a. F Int) ~ Int+++(ATF10) Injectivity.  Consider (AFT9) where F is known to be injective.  Then if we+  are unifying+          F Int ~ F Bool+  we /can/ say SurelyApart.  See the inj/noninj stuff in `go_fam_fam`.++(ATF11) Consider unifying+          [F Int, F Int, F Bool]  ~  [F Bool, Char, Double]+  We find (F Int ~ F Bool), so we can decompose.  But we /also/ want to remember+  the substitution [F Int :-> F Bool].  Then from (F Int ~ Char) we get the+  substitution [F Bool :-> Char].  And that flat-out contradicts (F Bool ~ Double)+  so we should get SurelyApart.++  Key point: when decomposing (F tys1 ~ F tys2), we should /also/ extend the+  type-family substitution.++  (ATF11-1) All this cleverness only matters when unifying, not when matching++(ATF12) There is a horrid exception for the injectivity check. See (UR1) in+  in Note [Specification of unification].++(ATF13) We have to be careful about the occurs check.+  See Note [The occurs check in the Core unifier]++SIDE NOTE.  The paper "Closed type families with overlapping equations"+http://research.microsoft.com/en-us/um/people/simonpj/papers/ext-f/axioms-extended.pdf+tries to achieve the same effect with a standard yes/no unifier, by "flattening"+the types (replacing each type-family application with a fresh type variable)+and then unifying.  But that does not work well. Consider (#25657)++    type MyEq :: k -> k -> Bool+    type family MyEq a b where+       MyEq a a = 'True+       MyEq _ _ = 'False++    type Var :: forall {k}. Tag -> k+    type family Var tag = a | a -> tag++Then, because Var is injective, we want+     MyEq (Var A) (Var B) --> False+     MyEq (Var A) (Var A) --> True++But if we flattten the types (Var A) and (Var B) we'll just get fresh type variables,+and all is lost.  But with the current algorithm we have that+    a a   ~    (Var A) (Var B)+is SurelyApart, so the first equation definitely doesn't match and we can try the+second, which does.  END OF SIDE NOTE.++Note [Shortcomings of the apartness test]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Note [Apartness and type families] is very clever.++But it still has shortcomings (#26358).  Consider unifying+    [F a, F Int, Int]  ~  [Bool, Char, a]+Working left to right you might think we would build the mapping+  F a   :-> Bool+  F Int :-> Char+Now we discover that `a` unifies with `Int`. So really these two lists are Apart+because F Int can't be both Bool and Char.++Just the same applies when adding a type-family binding to um_fam_env:+  [F (G Float), F Int, G Float] ~ [Bool, Char, Iont]+Again these are Apart, because (G Float = Int),+and (F Int) can't be both Bool and Char++But achieving this is very tricky! Perhaps whenever we unify a type variable,+or a type family, we should run it over the domain and (maybe range) of the+type-family mapping too?  Sigh.++For now we make no such attempt.+* The um_fam_env has only /un-substituted/ types.+* We look up only /un-substituted/ types in um_fam_env++This may make us say MaybeApart when we could say SurelyApart, but it has no+effect on the correctness of unification: if we return Unifiable, it really is+Unifiable.++This is all quite subtle. suppose we have:+    um_tv_env:   c :-> b+    um_fam_env   F b :-> a+and we are trying to add a :-> F c. We will call lookupFamEnv on (F, [c]), which will+fail because b and c are not equal. So we go ahead and add a :-> F c as a new tyvar eq,+getting:+    um_tv_env:   a :-> F c, c :-> b+    um_fam_env   F b :-> a++Does that loop, like this:+   a --> F c --> F b --> a?+No, because we do not substitute (F c) to (F b) and then look up in um_fam_env;+we look up only un-substituted types.+-}++{- *********************************************************************+*                                                                      *+                Binding decisions+*                                                                      *+********************************************************************* -}++data BindFlag+  = BindMe      -- ^ A bindable type variable++  | DontBindMe  -- ^ Do not bind this type variable is /apart/+                -- See also Note [Super skolems: binding when looking up instances]+                -- in GHC.Core.InstEnv.+  deriving Eq++-- | Some unification functions are parameterised by a 'BindTvFun', which+-- says whether or not to allow a certain unification to take place.+-- A 'BindTvFun' takes the 'TyVar' involved along with the 'Type' it will+-- potentially be bound to.+--+-- It is possible for the variable to actually be a coercion variable+-- (Note [Matching coercion variables]), but only when one-way matching.+-- In this case, the 'Type' will be a 'CoercionTy'.+type BindTvFun = TyCoVar -> Type -> BindFlag++-- | BindFamFun is similiar to BindTvFun, but deals with a saturated+-- type-family application.  See Note [Apartness and type families].+type BindFamFun = TyCon -> [Type] -> Type -> BindFlag++-- | Allow binding only for any variable in the set. Variables may+-- be bound to any type.+-- Used when doing simple matching; e.g. can we find a substitution+--+-- @+-- S = [a :-> t1, b :-> t2] such that+--     S( Maybe (a, b->Int )  =   Maybe (Bool, Char -> Int)+-- @+matchBindTv :: TyCoVarSet -> BindTvFun+matchBindTv tvs tv _ty+  | tv `elemVarSet` tvs = BindMe+  | otherwise           = DontBindMe++-- | Allow the binding of any variable to any type+alwaysBindTv :: BindTvFun+alwaysBindTv _tv _ty = BindMe++-- | Allow the binding of a type-family application to any type+alwaysBindFam :: BindFamFun+-- See (ATF8) in Note [Apartness and type families]+alwaysBindFam _tc _args _rhs = BindMe++dontCareBindFam :: HasCallStack => BindFamFun+-- See (ATF8) in Note [Apartness and type families]+dontCareBindFam tc args rhs+  = pprPanic "dontCareBindFam" $+    vcat [ ppr tc <+> ppr args, text "rhs" <+> ppr rhs ]++-- | Don't allow the binding of a type-family application at all+neverBindFam :: BindFamFun+-- See (ATF8) in Note [Apartness and type families]+neverBindFam _tc _args _rhs = DontBindMe+++{- *********************************************************************+*                                                                      *+                Various wrappers for matching+*                                                                      *+********************************************************************* -}++-- | @tcMatchTy t1 t2@ produces a substitution (over fvs(t1))+-- @s@ such that @s(t1)@ equals @t2@.+-- The returned substitution might bind coercion variables,+-- if the variable is an argument to a GADT constructor.+--+-- Precondition: typeKind ty1 `eqType` typeKind ty2+--+-- We don't pass in a set of "template variables" to be bound+-- by the match, because tcMatchTy (and similar functions) are+-- always used on top-level types, so we can bind any of the+-- free variables of the LHS.+-- See also Note [tcMatchTy vs tcMatchTyKi]+tcMatchTy :: HasDebugCallStack => Type -> Type -> Maybe Subst+tcMatchTy ty1 ty2 = tcMatchTys [ty1] [ty2]++tcMatchTyX_BM :: HasDebugCallStack+              => BindTvFun -> Subst+              -> Type -> Type -> Maybe Subst+tcMatchTyX_BM bind_tv subst ty1 ty2+  = tc_match_tys_x bind_tv False subst [ty1] [ty2]++-- | Like 'tcMatchTy', but allows the kinds of the types to differ,+-- and thus matches them as well.+-- See also Note [tcMatchTy vs tcMatchTyKi]+tcMatchTyKi :: HasDebugCallStack => Type -> Type -> Maybe Subst+tcMatchTyKi ty1 ty2+  = tc_match_tys alwaysBindTv True [ty1] [ty2]++-- | This is similar to 'tcMatchTy', but extends a substitution+-- See also Note [tcMatchTy vs tcMatchTyKi]+tcMatchTyX :: HasDebugCallStack+           => Subst               -- ^ Substitution to extend+           -> Type                -- ^ Template+           -> Type                -- ^ Target+           -> Maybe Subst+tcMatchTyX subst ty1 ty2+  = tc_match_tys_x alwaysBindTv False subst [ty1] [ty2]++-- | Like 'tcMatchTy' but over a list of types.+-- See also Note [tcMatchTy vs tcMatchTyKi]+tcMatchTys :: HasDebugCallStack+           => [Type]         -- ^ Template+           -> [Type]         -- ^ Target+           -> Maybe Subst    -- ^ One-shot; in principle the template+                             -- variables could be free in the target+                             -- See (CU6) in Note [The Core unifier]+tcMatchTys tys1 tys2+  = tc_match_tys alwaysBindTv False tys1 tys2++-- | Like 'tcMatchTyKi' but over a list of types.+-- See also Note [tcMatchTy vs tcMatchTyKi]+tcMatchTyKis :: HasDebugCallStack+             => [Type]         -- ^ Template+             -> [Type]         -- ^ Target+             -> Maybe Subst    -- ^ One-shot substitution+                               -- See (CU6) in Note [The Core unifier]+tcMatchTyKis tys1 tys2+  = tc_match_tys alwaysBindTv True tys1 tys2++-- | Like 'tcMatchTys', but extending a substitution+-- See also Note [tcMatchTy vs tcMatchTyKi]+tcMatchTysX :: HasDebugCallStack+            => Subst          -- ^ Substitution to extend+            -> [Type]         -- ^ Template+            -> [Type]         -- ^ Target+            -> Maybe Subst    -- ^ One-shot substitution+tcMatchTysX subst tys1 tys2+  = tc_match_tys_x alwaysBindTv False subst tys1 tys2++-- | Like 'tcMatchTyKis', but extending a substitution+-- See also Note [tcMatchTy vs tcMatchTyKi]+tcMatchTyKisX :: HasDebugCallStack+              => Subst        -- ^ Substitution to extend+              -> [Type]       -- ^ Template+              -> [Type]       -- ^ Target+              -> Maybe Subst  -- ^ One-shot substitution+tcMatchTyKisX subst tys1 tys2+  = tc_match_tys_x alwaysBindTv True subst tys1 tys2++-- | Same as tc_match_tys_x, but starts with an empty substitution+tc_match_tys :: HasDebugCallStack+             => BindTvFun+             -> Bool          -- ^ match kinds?+             -> [Type]+             -> [Type]+             -> Maybe Subst+tc_match_tys bind_me match_kis tys1 tys2+  = tc_match_tys_x bind_me match_kis (mkEmptySubst in_scope) tys1 tys2+  where+    in_scope = mkInScopeSet (tyCoVarsOfTypes tys1 `unionVarSet` tyCoVarsOfTypes tys2)++-- | Worker for 'tcMatchTysX' and 'tcMatchTyKisX'+tc_match_tys_x :: HasDebugCallStack+               => BindTvFun+               -> Bool          -- ^ match kinds?+               -> Subst+               -> [Type]+               -> [Type]+               -> Maybe Subst+tc_match_tys_x bind_tv match_kis (Subst in_scope id_env tv_env cv_env) tys1 tys2+  = case tc_unify_tys neverBindFam  -- (ATF7) in Note [Apartness and type families]+                      bind_tv+                      False  -- Matching, not unifying+                      False  -- Not an injectivity check+                      match_kis+                      RespectMultiplicities+                      (mkRnEnv2 in_scope) tv_env cv_env tys1 tys2 of+      Unifiable (tv_env', cv_env')+        -> Just $ Subst in_scope id_env tv_env' cv_env'+      _ -> Nothing++-- | This one is called from the expression matcher,+-- which already has a MatchEnv in hand+ruleMatchTyKiX+  :: TyCoVarSet          -- ^ template variables+  -> RnEnv2+  -> TvSubstEnv          -- ^ type substitution to extend+  -> Type                -- ^ Template+  -> Type                -- ^ Target+  -> Maybe TvSubstEnv+ruleMatchTyKiX tmpl_tvs rn_env tenv tmpl target+-- See Note [Kind coercions in Unify]+  = case tc_unify_tys neverBindFam (matchBindTv tmpl_tvs)+      -- neverBindFam: a type family probably shouldn't appear+      -- on the LHS of a RULE, although we don't currently prevent it.+      -- But even if it did, (ATF8) in Note [Apartness and type families]+      -- says it doesn't matter becuase here we only care about Unifiable.+      -- So neverBindFam is efficient, and sufficient.+                      False    -- Matching, not unifying+                      False    -- No doing an injectivity check+                      True     -- Match the kinds+                      IgnoreMultiplicities+                        -- See Note [Rewrite rules ignore multiplicities in FunTy]+                      rn_env tenv emptyCvSubstEnv [tmpl] [target] of+      Unifiable (tenv', _) -> Just tenv'+      _                    -> Nothing++{-+************************************************************************+*                                                                      *+                GADTs+*                                                                      *+************************************************************************++Note [Pruning dead case alternatives]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider        data T a where+                   T1 :: T Int+                   T2 :: T a++                newtype X = MkX Int+                newtype Y = MkY Char++                type family F a+                type instance F Bool = Int++Now consider    case x of { T1 -> e1; T2 -> e2 }++The question before the house is this: if I know something about the type+of x, can I prune away the T1 alternative?++Suppose x::T Char.  It's impossible to construct a (T Char) using T1,+        Answer = YES we can prune the T1 branch (clearly)++Suppose x::T (F a), where 'a' is in scope.  Then 'a' might be instantiated+to 'Bool', in which case x::T Int, so+        ANSWER = NO (clearly)++We see here that we want precisely the apartness check implemented within+tcUnifyTysFG. So that's what we do! Two types cannot match if they are surely+apart. Note that since we are simply dropping dead code, a conservative test+suffices.+-}++-- | Given a list of pairs of types, are any two members of a pair surely+-- apart, even after arbitrary type function evaluation and substitution?+typesCantMatch :: [(Type,Type)] -> Bool+-- See Note [Pruning dead case alternatives]+typesCantMatch prs = any (uncurry typesAreApart) prs++typesAreApart :: Type -> Type -> Bool+typesAreApart t1 t2 = case tcUnifyTysFG alwaysBindFam alwaysBindTv [t1] [t2] of+                        SurelyApart -> True+                        _           -> False+{-+************************************************************************+*                                                                      *+             Various wrappers for unification+*                                                                      *+********************************************************************* -}++-- | Simple unification of two types; all type variables are bindable+-- Precondition: the kinds are already equal+tcUnifyTy :: Type -> Type       -- All tyvars are bindable+          -> Maybe Subst+                       -- A regular one-shot (idempotent) substitution+tcUnifyTy t1 t2 = tcUnifyTys alwaysBindTv [t1] [t2]++tcUnifyDebugger :: Type -> Type -> Maybe Subst+tcUnifyDebugger t1 t2+  = case tc_unify_tys_fg+             True            -- Unify kinds+             neverBindFam    -- Does not affect Unifiable, so pick max efficient+                             -- See (ATF8) in Note [Apartness and type families]+             alwaysBindTv+             [t1] [t2] of+      Unifiable subst -> Just subst+      _               -> Nothing++-- | Like 'tcUnifyTys' but also unifies the kinds+tcUnifyFunDeps :: TyCoVarSet+               -> [Type] -> [Type]+               -> Maybe Subst+tcUnifyFunDeps qtvs tys1 tys2+  = case tc_unify_tys_fg+             True               -- Unify kinds+             dontCareBindFam    -- Class-instance heads never mention type families+             (matchBindTv qtvs)+             tys1 tys2 of+      Unifiable subst -> Just subst+      _               -> Nothing++-- | Unify or match a type-family RHS with a type (possibly another type-family RHS)+-- Precondition: kinds are the same+tcUnifyTyForInjectivity+    :: AmIUnifying  -- ^ True <=> do two-way unification;+                    --   False <=> do one-way matching.+                    --   See end of sec 5.2 from the paper+    -> InScopeSet     -- Should include the free tyvars of both Type args+    -> Type -> Type   -- Types to unify+    -> Maybe Subst+-- This algorithm is an implementation of the "Algorithm U" presented in+-- the paper "Injective type families for Haskell", Figures 2 and 3.+-- The code is incorporated with the standard unifier for convenience, but+-- its operation should match the specification in the paper.+tcUnifyTyForInjectivity unif in_scope t1 t2+  = case tc_unify_tys alwaysBindFam alwaysBindTv+                       unif   -- Am I unifying?+                       True   -- Do injectivity checks+                       False  -- Don't check outermost kinds+                       RespectMultiplicities+                       rn_env emptyTvSubstEnv emptyCvSubstEnv+                       [t1] [t2] of+      Unifiable          (tv_subst, _cv_subst) -> Just $ maybe_fix tv_subst+      MaybeApart _reason (tv_subst, _cv_subst) -> Just $ maybe_fix tv_subst+                 -- We want to *succeed* in questionable cases.+                 -- This is a pre-unification algorithm.+      SurelyApart      -> Nothing+  where+    rn_env   = mkRnEnv2 in_scope++    maybe_fix | unif      = niFixSubst in_scope+              | otherwise = mkTvSubst in_scope -- when matching, don't confuse+                                               -- domain with range++-----------------+tcUnifyTys :: BindTvFun+           -> [Type] -> [Type]+           -> Maybe Subst+                                -- ^ A regular one-shot (idempotent) substitution+                                -- that unifies the erased types. See comments+                                -- for 'tcUnifyTysFG'++-- The two types may have common type variables, and indeed do so in the+-- second call to tcUnifyTys in GHC.Tc.Instance.FunDeps.checkClsFD+tcUnifyTys bind_fn tys1 tys2+  = case tcUnifyTysFG neverBindFam bind_fn tys1 tys2 of+      Unifiable result -> Just result+      _                -> Nothing++-- | (tcUnifyTysFG bind_fam bind_tv tys1 tys2) does "fine-grain" unification+-- of tys1 and tys2, under the control of `bind_fam` and `bind_tv`.+-- This version requires that the kinds of the types are the same,+-- if you unify left-to-right.+-- See Note [The Core unifier]+tcUnifyTysFG :: BindFamFun -> BindTvFun+             -> [Type] -> [Type]+             -> UnifyResult+tcUnifyTysFG bind_fam bind_tv tys1 tys2+  = tc_unify_tys_fg False bind_fam bind_tv tys1 tys2++tc_unify_tys_fg :: Bool+                -> BindFamFun -> BindTvFun+                -> [Type] -> [Type]+                -> UnifyResult+tc_unify_tys_fg match_kis bind_fam bind_tv tys1 tys2+  = do { (tv_env, _) <- tc_unify_tys bind_fam bind_tv+                                  True       -- Unifying+                                  False      -- Not doing an injectivity check+                                  match_kis  -- Match outer kinds+                                  RespectMultiplicities rn_env+                                  emptyTvSubstEnv emptyCvSubstEnv+                                  tys1 tys2+       ; return $ niFixSubst in_scope tv_env }+  where+    in_scope = mkInScopeSet $ tyCoVarsOfTypes tys1 `unionVarSet` tyCoVarsOfTypes tys2+    rn_env   = mkRnEnv2 in_scope++-- | This function is actually the one to call the unifier -- a little+-- too general for outside clients, though.+tc_unify_tys :: BindFamFun -> BindTvFun+             -> AmIUnifying -- ^ True <=> unify; False <=> match+             -> Bool        -- ^ True <=> doing an injectivity check+             -> Bool        -- ^ True <=> treat the kinds as well+             -> MultiplicityFlag -- ^ see Note [Rewrite rules ignore multiplicities in FunTy] in GHC.Core.Unify+             -> RnEnv2+             -> TvSubstEnv  -- ^ substitution to extend+             -> CvSubstEnv+             -> [Type] -> [Type]+             -> UnifyResultM (TvSubstEnv, CvSubstEnv)+-- NB: It's tempting to ASSERT here that, if we're not matching kinds, then+-- the kinds of the types should be the same. However, this doesn't work,+-- as the types may be a dependent telescope, where later types have kinds+-- that mention variables occurring earlier in the list of types. Here's an+-- example (from typecheck/should_fail/T12709):+--   template: [rep :: RuntimeRep,       a :: TYPE rep]+--   target:   [LiftedRep :: RuntimeRep, Int :: TYPE LiftedRep]+-- We can see that matching the first pair will make the kinds of the second+-- pair equal. Yet, we still don't need a separate pass to unify the kinds+-- of these types, so it's appropriate to use the Ty variant of unification.+-- See also Note [tcMatchTy vs tcMatchTyKi].+tc_unify_tys bind_fam bind_tv unif inj_check match_kis match_mults rn_env tv_env cv_env tys1 tys2+  = initUM tv_env cv_env $+    do { when match_kis $+         unify_tys env kis1 kis2+       ; unify_tys env tys1 tys2 }+  where+    env = UMEnv { um_bind_tv_fun  = bind_tv+                , um_bind_fam_fun = bind_fam+                , um_foralls      = emptyVarSet+                , um_unif         = unif+                , um_inj_tf       = inj_check+                , um_arr_mult     = match_mults+                , um_rn_env       = rn_env }++    kis1 = map typeKind tys1+    kis2 = map typeKind tys2+++{- *********************************************************************+*                                                                      *+                UnifyResult, MaybeApart etc+*                                                                      *+********************************************************************* -}++{- Note [Rewrite rules ignore multiplicities in FunTy]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider the following (higher-order) rule:++m :: Bool -> Bool -> Bool+{-# RULES "m" forall f. m (f True) = f #-}++let x = m ((,) @Bool @Bool True True)++The rewrite rule expects an `f :: Bool -> Bool`, but `(,) @Bool @Bool True ::+Bool %1 -> Bool` is linear (see Note [Data constructors are linear by default]+in GHC.Core.Multiplicity) Should the rule match? Yes! According to the+principles laid out in Note [Linting linearity] in GHC.Core.Lint, optimisation+shouldn't be constrained by linearity.++However, when matching the template variable `f` to `(,) True`, we do check that+their types unify (see Note [Matching variable types] in GHC.Core.Rules). So+when unifying types for the sake of rule-matching, the unification algorithm+must be able to ignore multiplicities altogether.++How is this done?+  (1) The `um_arr_mult` field of `UMEnv` recordsw when we are doing rule-matching,+      and hence want to ignore multiplicities.+  (2) The field is set to True in by `ruleMatchTyKiX`.+  (3) It is consulted when matching `FunTy` in `unify_ty`.++Wrinkle in (3). In `unify_tc_app`, in `unify_ty`, `FunTy` is handled as if it+was a regular type constructor. In this case, and when the types being unified+are *function* arrows, but not constraint arrows, then the first argument is a+multiplicity.++We select this situation by comparing the type constructor with fUNTyCon. In+this case, and this case only, we can safely drop the first argument (using the+tail function) and unify the rest.++Note [The substitution in MaybeApart]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The constructor MaybeApart carries data with it, typically a TvSubstEnv. Why?+Because consider unifying these:++(a, a, Int) ~ (b, [b], Bool)++If we go left-to-right, we start with [a |-> b]. Then, on the middle terms, we+apply the subst we have so far and discover that we need [b |-> [b]]. Because+this fails the occurs check, we say that the types are MaybeApart (see above+Note [Infinitary substitutions]). But, we can't stop there! Because if we+continue, we discover that Int is SurelyApart from Bool, and therefore the+types are apart. This has practical consequences for the ability for closed+type family applications to reduce. See test case+indexed-types/should_compile/Overlap14.+-}++-- This type does double-duty. It is used in the UM (unifier monad) and to+-- return the final result. See Note [Unification result]+type UnifyResult = UnifyResultM Subst++-- | See Note [Unification result]+data UnifyResultM a = Unifiable a        -- the subst that unifies the types+                    | MaybeApart MaybeApartReason+                                 a       -- the subst has as much as we know+                                         -- it must be part of a most general unifier+                                         -- See Note [The substitution in MaybeApart]+                    | SurelyApart+                    deriving Functor++-- | Why are two types 'MaybeApart'? 'MARInfinite' takes precedence:+-- This is used (only) in Note [Infinitary substitution in lookup] in GHC.Core.InstEnv+-- As of Feb 2022, we never differentiate between MARTypeFamily and MARTypeVsConstraint;+-- it's really only MARInfinite that's interesting here.+data MaybeApartReason+  = MARTypeFamily   -- ^ matching e.g. F Int ~? Bool++  | MARInfinite     -- ^ matching e.g. a ~? Maybe a++  | MARTypeVsConstraint  -- ^ matching Type ~? Constraint or the arrow types+    -- See Note [Type and Constraint are not apart] in GHC.Builtin.Types.Prim++  | MARCast         -- ^ Very obscure.+    -- See (KCU2) in Note [Kind coercions in Unify]+++combineMAR :: MaybeApartReason -> MaybeApartReason -> MaybeApartReason+-- See (UR1) in Note [Unification result] for why MARInfinite wins+combineMAR MARInfinite         _ = MARInfinite   -- MARInfinite wins+combineMAR MARTypeFamily       r = r             -- Otherwise it doesn't really matter+combineMAR MARTypeVsConstraint r = r+combineMAR MARCast             r = r++instance Outputable MaybeApartReason where+  ppr MARTypeFamily       = text "MARTypeFamily"+  ppr MARInfinite         = text "MARInfinite"+  ppr MARTypeVsConstraint = text "MARTypeVsConstraint"+  ppr MARCast             = text "MARCast"++instance Semigroup MaybeApartReason where+  (<>) = combineMAR++instance Applicative UnifyResultM where+  pure  = Unifiable+  (<*>) = ap++instance Monad UnifyResultM where+  SurelyApart  >>= _ = SurelyApart+  MaybeApart r1 x >>= f = case f x of+                            Unifiable y     -> MaybeApart r1 y+                            MaybeApart r2 y -> MaybeApart (r1 S.<> r2) y+                            SurelyApart     -> SurelyApart+  Unifiable x  >>= f = f x++instance Outputable a => Outputable (UnifyResultM a) where+  ppr SurelyApart      = text "SurelyApart"+  ppr (Unifiable x)    = text "Unifiable" <+> ppr x+  ppr (MaybeApart r x) = text "MaybeApart" <+> ppr r <+> ppr x++{-+************************************************************************+*                                                                      *+                Non-idempotent substitution+*                                                                      *+************************************************************************++Note [Non-idempotent substitution]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+During unification we use a TvSubstEnv/CvSubstEnv pair that is+  (a) non-idempotent+  (b) loop-free; ie repeatedly applying it yields a fixed point++Note [Finding the substitution fixpoint]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Finding the fixpoint of a non-idempotent substitution arising from a+unification is much trickier than it looks, because of kinds.  Consider+   T k (H k (f:k)) ~ T * (g:*)+If we unify, we get the substitution+   [ k -> *+   , g -> H k (f:k) ]+To make it idempotent we don't want to get just+   [ k -> *+   , g -> H * (f:k) ]+We also want to substitute inside f's kind, to get+   [ k -> *+   , g -> H k (f:*) ]+If we don't do this, we may apply the substitution to something,+and get an ill-formed type, i.e. one where typeKind will fail.+This happened, for example, in #9106.++It gets worse.  In #14164 we wanted to take the fixpoint of+this substitution+   [ xs_asV :-> F a_aY6 (z_aY7 :: a_aY6)+                        (rest_aWF :: G a_aY6 (z_aY7 :: a_aY6))+   , a_aY6  :-> a_aXQ ]++We have to apply the substitution for a_aY6 two levels deep inside+the invocation of F!  We don't have a function that recursively+applies substitutions inside the kinds of variable occurrences (and+probably rightly so).++So, we work as follows:++ 1. Start with the current substitution (which we are+    trying to fixpoint+       [ xs :-> F a (z :: a) (rest :: G a (z :: a))+       , a  :-> b ]++ 2. Take all the free vars of the range of the substitution:+       {a, z, rest, b}+    NB: the free variable finder closes over+    the kinds of variable occurrences++ 3. If none are in the domain of the substitution, stop.+    We have found a fixpoint.++ 4. Remove the variables that are bound by the substitution, leaving+       {z, rest, b}++ 5. Do a topo-sort to put them in dependency order:+       [ b :: *, z :: a, rest :: G a z ]++ 6. Apply the substitution left-to-right to the kinds of these+    tyvars, extending it each time with a new binding, so we+    finish up with+       [ xs   :-> ..as before..+       , a    :-> b+       , b    :-> b    :: *+       , z    :-> z    :: b+       , rest :-> rest :: G b (z :: b) ]+    Note that rest now has the right kind++ 7. Apply this extended substitution (once) to the range of+    the /original/ substitution.  (Note that we do the+    extended substitution would go on forever if you tried+    to find its fixpoint, because it maps z to z.)++ 8. And go back to step 1++In Step 6 we use the free vars from Step 2 as the initial+in-scope set, because all of those variables appear in the+range of the substitution, so they must all be in the in-scope+set.  But NB that the type substitution engine does not look up+variables in the in-scope set; it is used only to ensure no+shadowing.+-}++niFixSubst :: InScopeSet -> TvSubstEnv -> Subst+-- Find the idempotent fixed point of the non-idempotent substitution+-- This is surprisingly tricky:+--   see Note [Finding the substitution fixpoint]+-- ToDo: use laziness instead of iteration?+niFixSubst in_scope tenv+  | not_fixpoint = niFixSubst in_scope (mapVarEnv (substTy subst) tenv)+  | otherwise    = subst+  where+    range_fvs :: FV+    range_fvs = tyCoFVsOfTypes (nonDetEltsUFM tenv)+          -- It's OK to use nonDetEltsUFM here because the+          -- order of range_fvs, range_tvs is immaterial++    range_tvs :: [TyVar]+    range_tvs = fvVarList range_fvs++    not_fixpoint  = any in_domain range_tvs+    in_domain tv  = tv `elemVarEnv` tenv++    free_tvs = scopedSort (filterOut in_domain range_tvs)++    -- See Note [Finding the substitution fixpoint], Step 6+    subst = foldl' add_free_tv+                  (mkTvSubst in_scope tenv)+                  free_tvs++    add_free_tv :: Subst -> TyVar -> Subst+    add_free_tv subst tv+      = extendTvSubst subst tv (mkTyVarTy tv')+     where+        tv' = updateTyVarKind (substTy subst) tv++{-+************************************************************************+*                                                                      *+                unify_ty: the main workhorse+*                                                                      *+************************************************************************++Note [Specification of unification]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The pure unifier, unify_ty, defined in this module, tries to work out+a substitution to make two types say True to eqType. NB: eqType is+itself not purely syntactic; it accounts for CastTys;+see Note [Non-trivial definitional equality] in GHC.Core.TyCo.Rep++Unlike the "impure unifiers" in the typechecker (the eager unifier in+GHC.Tc.Utils.Unify, and the constraint solver itself in GHC.Tc.Solver.Equality),+the pure unifier does /not/ work up to ~.++The algorithm implemented here is rather delicate, and we depend on it+to uphold certain properties. This is a summary of these required+properties.++Notation:+ θ,φ  substitutions+ ξ    type-function-free types+ τ,σ  other types+ τ♭   type τ, flattened++ ≡    eqType++(U1) Soundness.+     If (unify τ₁ τ₂) = Unifiable θ, then θ(τ₁) ≡ θ(τ₂).+     θ is a most general unifier for τ₁ and τ₂.++(U2) Completeness.+     If (unify ξ₁ ξ₂) = SurelyApart,+     then there exists no substitution θ such that θ(ξ₁) ≡ θ(ξ₂).++These two properties are stated as Property 11 in the "Closed Type Families"+paper (POPL'14). Below, this paper is called [CTF].++(U3) Apartness under substitution.+     If (unify ξ τ♭) = SurelyApart, then (unify ξ θ(τ)♭) = SurelyApart,+     for any θ. (Property 12 from [CTF])++(U4) Apart types do not unify.+     If (unify ξ τ♭) = SurelyApart, then there exists no θ+     such that θ(ξ) = θ(τ). (Property 13 from [CTF])++THEOREM. Completeness w.r.t ~+    If (unify τ₁♭ τ₂♭) = SurelyApart,+    then there exists no proof that (τ₁ ~ τ₂).++PROOF. See appendix of [CTF].+++The unification algorithm is used for type family injectivity, as described+in the "Injective Type Families" paper (Haskell'15), called [ITF]. When run+in this mode, it has the following properties.++(I1) If (unify σ τ) = SurelyApart, then σ and τ are not unifiable, even+     after arbitrary type family reductions.++(I2) If (unify σ τ) = MaybeApart θ, and if some+     φ exists such that φ(σ) ~ φ(τ), then φ extends θ.+++Furthermore, the RULES matching algorithm requires this property,+but only when using this algorithm for matching:++(M1) If (match σ τ) succeeds with θ, then all matchable tyvars+     in σ are bound in θ.++     Property M1 means that we must extend the substitution with,+     say (a ↦ a) when appropriate during matching.+     See also Note [Self-substitution when unifying or matching].++(M2) Completeness of matching.+     If θ(σ) = τ, then (match σ τ) = Unifiable φ,+     where θ is an extension of φ.++Wrinkle (SI1): um_inj_tf:+    Sadly, property M2 and I2 conflict. Consider++    type family F1 a b where+      F1 Int    Bool   = Char+      F1 Double String = Char++    Consider now two matching problems:++    P1. match (F1 a Bool) (F1 Int Bool)+    P2. match (F1 a Bool) (F1 Double String)++    In case P1, we must find (a ↦ Int) to satisfy M2.  In case P2, we must /not/+    find (a ↦ Double), in order to satisfy I2. (Note that the correct mapping for+    I2 is (a ↦ Int). There is no way to discover this, but we mustn't map a to+    anything else!)++    We thus must parameterize the algorithm over whether it's being used+    for an injectivity check (refrain from looking at non-injective arguments+    to type families) or not (do indeed look at those arguments).  This is+    implemented  by the um_inj_tf field of UMEnv.++    (It's all a question of whether or not to include equation (7) from Fig. 2+    of [ITF].)++    This extra parameter is a bit fiddly, perhaps, but seemingly less so than+    having two separate, almost-identical algorithms.++Note [Self-substitution when unifying or matching]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+What happens when we are unifying or matching two identical type variables?+     a ~ a++* When /unifying/, just succeed, without binding [a :-> a] in the substitution,+  else we'd get an infinite substitution.  We need to make this check before+  we do the occurs check, of course.++* When /matching/, and `a` is a bindable variable from the template, we /do/+  want to extend the substitution.  Remember, a successful match should map all+  the template variables (except ones that disappear when expanding synonyms),++  But when `a` is /not/ a bindable variable (perhaps it is a globally-in-scope+  skolem) we want to treat it like a constant `Int ~ Int` and succeed.++  Notice: no occurs check!  It's fine to match (a ~ Maybe a), because the+  template vars of the template come from a different name space to the free+  vars of the target.++  Note that this arrangement was provoked by a real failure, where the same+  unique ended up in the template as in the target. (It was a rule firing when+  compiling Data.List.NonEmpty.)++* What about matching a /non-bindable/ variable?  For example:+      template-vars   : {a}+      matching problem: (forall b. b -> a) ~ (forall c. c -> Int)+  We want to emerge with the substitution [a :-> Int]+  But on the way we will encounter (b ~ b), when we match the bits before the+  arrow under the forall, having renamed `c` to `b`.  This match should just+  succeed, just like (Int ~ Int), without extending the substitution.++  It's important to do this for /non-bindable/ variables, not just for+  forall-bound ones.  In an associated type+         instance C (Maybe a) where {  type F (Maybe a) = Int }+  `checkConsistentFamInst` matches (Maybe a) from the header against (Maybe a)+  from the type-family instance, with `a` marked as non-bindable.+++Note [Matching coercion variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this:++   type family F a++   data G a where+     MkG :: F a ~ Bool => G a++   type family Foo (x :: G a) :: F a+   type instance Foo MkG = False++We would like that to be accepted. For that to work, we need to introduce+a coercion variable on the left and then use it on the right. Accordingly,+at use sites of Foo, we need to be able to use matching to figure out the+value for the coercion. (See the desugared version:++   axFoo :: [a :: *, c :: F a ~ Bool]. Foo (MkG c) = False |> (sym c)++) We never want this action to happen during *unification* though, when+all bets are off.++Note [Kind coercions in Unify]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We wish to match/unify while ignoring casts. But, we can't just ignore+them completely, or we'll end up with ill-kinded substitutions. For example,+say we're matching `a` with `ty |> co`. If we just drop the cast, we'll+return [a |-> ty], but `a` and `ty` might have different kinds. We can't+just match/unify their kinds, either, because this might gratuitously+fail. After all, `co` is the witness that the kinds are the same -- they+may look nothing alike.++So, we pass a kind coercion `kco` to the main `unify_ty`. This coercion witnesses+the equality between the substed kind of the left-hand type and the substed+kind of the right-hand type. Note that we do not unify kinds at the leaves+(as we did previously).++Hence: (UKINV) Unification Kind Invariant+* In the call+     unify_ty ty1 ty2 kco+  it must be that+     subst(kco) :: subst(kind(ty1)) ~N subst(kind(ty2))+  where `subst` is the ambient substitution in the UM monad+* In the call+     unify_tys tys1 tys2+  (which has no kco), after we unify any prefix of tys1,tys2, the kinds of the+  head of the remaining tys1,tys2 are identical after substitution.  This+  implies, for example, that the kinds of the head of tys1,tys2 are identical+  after substitution.++Preserving (UKINV) takes a bit of work, governed by the `match_kis` flag in+`tc_unify_tys`:++* When we're working with type applications (either TyConApp or AppTy) we+  need to worry about establishing (UKINV), as the kinds of the function+  & arguments aren't (necessarily) included in the kind of the result.+  When unifying two TyConApps, this is easy, because the two TyCons are+  the same. Their kinds are thus the same. As long as we unify left-to-right,+  we'll be sure to unify types' kinds before the types themselves. (For example,+  think about Proxy :: forall k. k -> *. Unifying the first args matches up+  the kinds of the second args.)++* For AppTy, we must unify the kinds of the functions, but once these are+  unified, we can continue unifying arguments without worrying further about+  kinds.++* The interface to this module includes both "...Ty" functions and+  "...TyKi" functions. The former assume that (UKINV) is already+  established, either because the kinds are the same or because the+  list of types being passed in are the well-typed arguments to some+  type constructor (see two paragraphs above). The latter take a separate+  pre-pass over the kinds to establish (UKINV). Sometimes, it's important+  not to take the second pass, as it caused #12442.++Wrinkles++(KCU1) We ensure that the `kco` argument never mentions variables in the+  domain of either RnEnvL or RnEnvR.  Why?++  * `kco` is used only to build the final well-kinded substitution+         a :-> ty |> kco+    The range of the substitution never mentions forall-bound variables,+    so `kco` cannot either.++  * `kco` mixes up types from both left and right arguments of+    `unify_ty`, which have different renamings in the RnEnv2.++  The easiest thing is to insist that `kco` does not need renaming with+  the RnEnv2; it mentions no forall-bound variables.++  To achieve this we do a `mentionsForAllBoundTyVars` test in the+  `CastTy` cases of `unify_ty`.++(KCU2) Suppose we are unifying+            (forall a. x |> (...F a b...) ~ (forall a. y)+  We can't bind y :-> x |> (...F a b...), becuase of that free `a`.++  But if we later learn that b=Int, and F a Int = Bool,+  that free `a` might disappear, so we could unify with+      y :-> x |> (...Bool...)++  Conclusion: if there is a free forall-bound variable in a cast,+  return MaybeApart, with a MaybeApartReason of MARCast.++(KCU3) We thought, at one point, that this was all unnecessary: why should+    casts be in types in the first place? But they are sometimes. In+    dependent/should_compile/KindEqualities2, we see, for example the+    constraint Num (Int |> (blah ; sym blah)).  We naturally want to find+    a dictionary for that constraint, which requires dealing with+    coercions in this manner.++Note [Matching in the presence of casts (1)]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When matching, it is crucial that no variables from the template+end up in the range of the matching substitution (obviously!).+When unifying, that's not a constraint; instead we take the fixpoint+of the substitution at the end.++So what should we do with this, when matching?+   unify_ty (tmpl |> co) tgt kco++Previously, wrongly, we pushed 'co' in the (horrid) accumulating+'kco' argument like this:+   unify_ty (tmpl |> co) tgt kco+     = unify_ty tmpl tgt (kco ; co)++But that is obviously wrong because 'co' (from the template) ends+up in 'kco', which in turn ends up in the range of the substitution.++This all came up in #13910.  Because we match tycon arguments+left-to-right, the ambient substitution will already have a matching+substitution for any kinds; so there is an easy fix: just apply+the substitution-so-far to the coercion from the LHS.++Note that++* When matching, the first arg of unify_ty is always the template;+  we never swap round.++* The above argument is distressingly indirect. We seek a+  better way.++* One better way is to ensure that type patterns (the template+  in the matching process) have no casts.  See #14119.++Note [Matching in the presence of casts (2)]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There is another wrinkle (#17395).  Suppose (T :: forall k. k -> Type)+and we are matching+   tcMatchTy (T k (a::k))  (T j (b::j))++Then we'll match k :-> j, as expected. But then in unify_tys+we invoke+   unify_tys env (a::k) (b::j) (Refl j)++Although we have unified k and j, it's very important that we put+(Refl j), /not/ (Refl k) as the fourth argument to unify_tys.+If we put (Refl k) we'd end up with the substitution+  a :-> b |> Refl k+which is bogus because one of the template variables, k,+appears in the range of the substitution.  Eek.++Similar care is needed in unify_ty_app.+++Note [Polykinded tycon applications]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose  T :: forall k. Type -> K+and we are unifying+  ty1:  T @Type         Int       :: Type+  ty2:  T @(Type->Type) Int Int   :: Type++These two TyConApps have the same TyCon at the front but they+(legitimately) have different numbers of arguments.  They+are surelyApart, so we can report that without looking any+further (see #15704).++Note [Unifying type applications]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Unifying type applications is quite subtle, as we found+in #23134 and #22647, when type families are involved.++Suppose+   type family F a :: Type -> Type+   type family G k :: k = r | r -> k++and consider these examples:++* F Int ~ F Char, where F is injective+  Since F is injective, we can reduce this to Int ~ Char,+  therefore SurelyApart.++* F Int ~ F Char, where F is not injective+  Without injectivity, return MaybeApart.++* G Type ~ G (Type -> Type) Int+  Even though G is injective and the arguments to G are different,+  we cannot deduce apartness because the RHS is oversaturated.+  For example, G might be defined as+    G Type = Maybe Int+    G (Type -> Type) = Maybe+  So we return MaybeApart.++* F Int Bool ~ F Int Char       -- SurelyApart (since Bool is apart from Char)+  F Int Bool ~ Maybe a          -- MaybeApart+  F Int Bool ~ a b              -- MaybeApart+  F Int Bool ~ Char -> Bool     -- MaybeApart+  An oversaturated type family can match an application,+  whether it's a TyConApp, AppTy or FunTy. Decompose.++* F Int ~ a b+  We cannot decompose a saturated, or under-saturated+  type family application. We return MaybeApart.++To handle all those conditions, unify_ty goes through+the following checks in sequence, where Fn is a type family+of arity n:++* (C1) Fn x_1 ... x_n ~ Fn y_1 .. y_n+  A saturated application.+  Here we can unify arguments in which Fn is injective.+* (C2) Fn x_1 ... x_n ~ anything, anything ~ Fn x_1 ... x_n+  A saturated type family can match anything - we return MaybeApart.+* (C3) Fn x_1 ... x_m ~ a b, a b ~ Fn x_1 ... x_m where m > n+  An oversaturated type family can be decomposed.+* (C4) Fn x_1 ... x_m ~ anything, anything ~ Fn x_1 ... x_m, where m > n+  If we couldn't decompose in the previous step, we return SurelyApart.++Afterwards, the rest of the code doesn't have to worry about type families.++Note [Unifying type synonyms]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider the task of unifying two 'Type's of the form++  TyConApp tc [] ~ TyConApp tc []++where `tc` is a type synonym. A naive way to perform this comparison these+would first expand the synonym and then compare the resulting expansions.++However, this is obviously wasteful and the RHS of `tc` may be large; it is+much better to rather compare the TyCons directly. Consequently, before+expanding type synonyms in type comparisons we first look for a nullary+TyConApp and simply compare the TyCons if we find one.++Of course, if we find that the TyCons are *not* equal then we still need to+perform the expansion as their RHSs may still be unifiable.  E.g+    type T = S (a->a)+    type S a = [a]+and consider+    T Int ~ S (Int -> Int)++We can't decompose non-nullary synonyms.  E.g.+    type R a = F a    -- Where F is a type family+and consider+    R (a->a) ~ R Int+We can't conclude that  (a->) ~ Int.  (There is a currently-missed opportunity+here; if we knew that R was /injective/, perhaps we could decompose.)++We perform the nullary-type-synonym optimisation in a number of places:++ * GHC.Core.Unify.unify_ty+ * GHC.Tc.Solver.Equality.can_eq_nc'+ * GHC.Tc.Utils.Unify.uType++This optimisation is especially helpful for the ubiquitous GHC.Types.Type,+since GHC prefers to use the type synonym over @TYPE 'LiftedRep@ applications+whenever possible. See Note [Using synonyms to compress types] in+GHC.Core.Type for details.++c.f. Note [Comparing type synonyms] in GHC.Core.TyCo.Compare+-}++-------------- unify_ty: the main workhorse -----------++type AmIUnifying = Bool   -- True  <=> Unifying+                          -- False <=> Matching++type InType      = Type       -- Before applying the RnEnv2+type OutCoercion = Coercion   -- After applying the RnEnv2+++unify_ty :: UMEnv+         -> InType -> InType  -- Types to be unified+         -> OutCoercion       -- A nominal coercion between their kinds+                              -- OutCoercion: the RnEnv has already been applied+                              -- When matching, the coercion is in "target space",+                              --   not "template space"+                              -- See Note [Kind coercions in Unify]+         -> UM ()+-- Precondition: see (Unification Kind Invariant)+--+-- See Note [Specification of unification]+-- Respects newtypes, PredTypes+-- See Note [Computing equality on types] in GHC.Core.Type+unify_ty _env (TyConApp tc1 []) (TyConApp tc2 []) _kco+  -- See Note [Unifying type synonyms]+  | tc1 == tc2+  = return ()++unify_ty env ty1 ty2 kco+    -- Now handle the cases we can "look through": synonyms and casts.+  | Just ty1' <- coreView ty1 = unify_ty env ty1' ty2 kco+  | Just ty2' <- coreView ty2 = unify_ty env ty1 ty2' kco++unify_ty env (CastTy ty1 co1) ty2 kco+  | mentionsForAllBoundTyVarsL env (tyCoVarsOfCo co1)+    -- See (KCU1) in Note [Kind coercions in Unify]+  = maybeApart MARCast  -- See (KCU2)++  | um_unif env+  = unify_ty env ty1 ty2 (co1 `mkTransCo` kco)++  | otherwise -- We are matching, not unifying+  = do { subst <- getSubst env+       ; let co' = substCo subst co1+         -- We match left-to-right, so the free template vars of the+         -- coercion should already have been matched.+         -- See Note [Matching in the presence of casts (1)]+         -- NB: co1 does not mention forall-bound vars, so no need to rename+       ; unify_ty env ty1 ty2 (co' `mkTransCo` kco) }++unify_ty env ty1 (CastTy ty2 co2) kco+  | mentionsForAllBoundTyVarsR env (tyCoVarsOfCo co2)+    -- See (KCU1) in Note [Kind coercions in Unify]+  = maybeApart MARCast  -- See (KCU2)+  | otherwise+  = unify_ty env ty1 ty2 (kco `mkTransCo` mkSymCo co2)+    -- NB: co2 does not mention forall-bound variables++-- Applications need a bit of care!+-- They can match FunTy and TyConApp, so use splitAppTy_maybe+unify_ty env (AppTy ty1a ty1b) ty2 _kco+  | Just (ty2a, ty2b) <- tcSplitAppTyNoView_maybe ty2+  = unify_ty_app env ty1a [ty1b] ty2a [ty2b]++unify_ty env ty1 (AppTy ty2a ty2b) _kco+  | Just (ty1a, ty1b) <- tcSplitAppTyNoView_maybe ty1+  = unify_ty_app env ty1a [ty1b] ty2a [ty2b]++unify_ty _ (LitTy x) (LitTy y) _kco | x == y = return ()++unify_ty env (ForAllTy (Bndr tv1 _) ty1) (ForAllTy (Bndr tv2 _) ty2) kco+  -- ToDo: See Note [Unifying coercion-foralls]+  = do { unify_ty env (varType tv1) (varType tv2) (mkNomReflCo liftedTypeKind)+       ; let env' = umRnBndr2 env tv1 tv2+       ; unify_ty env' ty1 ty2 kco }++-- See Note [Matching coercion variables]+unify_ty env (CoercionTy co1) (CoercionTy co2) kco+  = do { c_subst <- getCvSubstEnv+       ; case co1 of+           CoVarCo cv+             | not (um_unif env)+             , not (cv `elemVarEnv` c_subst)   -- Not forall-bound+             , let (_mult_co, co_l, co_r) = decomposeFunCo kco+                     -- Because the coercion is used in a type, it should be safe to+                     -- ignore the multiplicity coercion, _mult_co+                      -- cv :: t1 ~ t2+                      -- co2 :: s1 ~ s2+                      -- co_l :: t1 ~ s1+                      -- co_r :: t2 ~ s2+                   rhs_co = co_l `mkTransCo` co2 `mkTransCo` mkSymCo co_r+             , BindMe <- um_bind_tv_fun env cv (CoercionTy rhs_co)+             -> if mentionsForAllBoundTyVarsR env (tyCoVarsOfCo co2)+                then surelyApart+                else extendCvEnv cv rhs_co++           _ -> return () }++unify_ty env (TyVarTy tv1) ty2 kco+  = uVarOrFam env (TyVarLHS tv1) ty2 kco++unify_ty env ty1 (TyVarTy tv2) kco+  | um_unif env  -- If unifying, can swap args; but not when matching+  = uVarOrFam (umSwapRn env) (TyVarLHS tv2) ty1 (mkSymCo kco)++-- Deal with TyConApps+unify_ty env ty1 ty2 kco+  -- Handle non-oversaturated type families first+  -- See Note [Unifying type applications]+  | Just (tc,tys) <- mb_sat_fam_app1+  = uVarOrFam env (TyFamLHS tc tys) ty2 kco++  | um_unif env+  , Just (tc,tys) <- mb_sat_fam_app2+  = uVarOrFam (umSwapRn env) (TyFamLHS tc tys) ty1 (mkSymCo kco)++  -- Handle oversaturated type families. Suppose we have+  --     (F a b) ~ (c d)    where F has arity 1+  -- We definitely want to decompose that type application! (#22647)+  --+  -- If there is no application, an oversaturated type family can only+  -- match a type variable or a saturated type family,+  -- both of which we handled earlier. So we can say surelyApart.+  | Just (tc1, _) <- mb_tc_app1+  , isTypeFamilyTyCon tc1+  = if | Just (ty1a, ty1b) <- tcSplitAppTyNoView_maybe ty1+       , Just (ty2a, ty2b) <- tcSplitAppTyNoView_maybe ty2+       -> unify_ty_app env ty1a [ty1b] ty2a [ty2b]            -- (C3)+       | otherwise -> surelyApart                             -- (C4)++  | Just (tc2, _) <- mb_tc_app2+  , isTypeFamilyTyCon tc2+  = if | Just (ty1a, ty1b) <- tcSplitAppTyNoView_maybe ty1+       , Just (ty2a, ty2b) <- tcSplitAppTyNoView_maybe ty2+       -> unify_ty_app env ty1a [ty1b] ty2a [ty2b]            -- (C3)+       | otherwise -> surelyApart                             -- (C4)++  -- At this point, neither tc1 nor tc2 can be a type family.+  | Just (tc1, tys1) <- mb_tc_app1+  , Just (tc2, tys2) <- mb_tc_app2+  , tc1 == tc2+  = do { massertPpr (isInjectiveTyCon tc1 Nominal) (ppr tc1)+       ; unify_tc_app env tc1 tys1 tys2+       }++  -- TYPE and CONSTRAINT are not Apart+  -- See Note [Type and Constraint are not apart] in GHC.Builtin.Types.Prim+  -- NB: at this point we know that the two TyCons do not match+  | Just (tc1,_) <- mb_tc_app1, let u1 = tyConUnique tc1+  , Just (tc2,_) <- mb_tc_app2, let u2 = tyConUnique tc2+  , (u1 == tYPETyConKey && u2 == cONSTRAINTTyConKey) ||+    (u2 == tYPETyConKey && u1 == cONSTRAINTTyConKey)+  = maybeApart MARTypeVsConstraint+    -- We don't bother to look inside; wrinkle (W3) in GHC.Builtin.Types.Prim+    -- Note [Type and Constraint are not apart]++  -- The arrow types are not Apart+  -- See Note [Type and Constraint are not apart] in GHC.Builtin.Types.Prim+  --     wrinkle (W2)+  -- NB1: at this point we know that the two TyCons do not match+  -- NB2: In the common FunTy/FunTy case you might wonder if we want to go via+  --      splitTyConApp_maybe.  But yes we do: we need to look at those implied+  --      kind argument in order to satisfy (Unification Kind Invariant)+  | FunTy {} <- ty1+  , FunTy {} <- ty2+  = maybeApart MARTypeVsConstraint+    -- We don't bother to look inside; wrinkle (W3) in GHC.Builtin.Types.Prim+    -- Note [Type and Constraint are not apart]++  where+    mb_tc_app1 = splitTyConApp_maybe ty1+    mb_tc_app2 = splitTyConApp_maybe ty2+    mb_sat_fam_app1 = isSatTyFamApp ty1+    mb_sat_fam_app2 = isSatTyFamApp ty2++unify_ty _ _ _ _ = surelyApart++-----------------------------+unify_tc_app :: UMEnv -> TyCon -> [Type] -> [Type] -> UM ()+-- Mainly just unifies the argument types;+-- but with a special case for fUNTyCon+unify_tc_app env tc tys1 tys2+  | tc == fUNTyCon+  , IgnoreMultiplicities <- um_arr_mult env+  , (_mult1 : no_mult_tys1) <- tys1+  , (_mult2 : no_mult_tys2) <- tys2+  = -- We're comparing function arrow types here (not constraint arrow+    -- types!), and they have at least one argument, which is the arrow's+    -- multiplicity annotation. The flag `um_arr_mult` instructs us to+    -- ignore multiplicities in this very case. This is a little tricky: see+    -- point (3) in Note [Rewrite rules ignore multiplicities in FunTy].+     unify_tys env no_mult_tys1 no_mult_tys2++  | otherwise+  = unify_tys env tys1 tys2++-----------------------------+unify_ty_app :: UMEnv -> Type -> [Type] -> Type -> [Type] -> UM ()+-- Deal with (t1 t1args) ~ (t2 t2args)+-- where   length t1args = length t2args+unify_ty_app env ty1 ty1args ty2 ty2args+  | Just (ty1', ty1a) <- splitAppTyNoView_maybe ty1+  , Just (ty2', ty2a) <- splitAppTyNoView_maybe ty2+  = unify_ty_app env ty1' (ty1a : ty1args) ty2' (ty2a : ty2args)++  | otherwise+  = do { let ki1 = typeKind ty1+             ki2 = typeKind ty2+           -- See Note [Kind coercions in Unify]+       ; unify_ty  env ki1 ki2 (mkNomReflCo liftedTypeKind)+       ; unify_ty  env ty1 ty2 (mkNomReflCo ki2)+                 -- Very important: 'ki2' not 'ki1'+                 -- See Note [Matching in the presence of casts (2)]+       ; unify_tys env ty1args ty2args }++-----------------------------+unify_tys :: UMEnv -> [Type] -> [Type] -> UM ()+-- Precondition: see (Unification Kind Invariant)+unify_tys env orig_xs orig_ys+  = go orig_xs orig_ys+  where+    go []     []     = return ()+    go (x:xs) (y:ys)+      -- See Note [Kind coercions in Unify]+      = do { unify_ty env x y (mkNomReflCo $ typeKind y)+                 -- Very important: 'y' not 'x'+                 -- See Note [Matching in the presence of casts (2)]+           ; go xs ys }+    go _ _ = surelyApart+      -- Possibly different saturations of a polykinded tycon+      -- See Note [Polykinded tycon applications]++---------------------------------+uVarOrFam :: UMEnv -> CanEqLHS -> InType -> OutCoercion -> UM ()+-- Invariants: (a) If ty1 is a TyFamLHS, then ty2 is NOT a TyVarTy+--             (b) both args have had coreView already applied+-- Why saturated?  See (ATF4) in Note [Apartness and type families]+uVarOrFam env ty1 ty2 kco+  = do { substs <- getSubstEnvs+--       ; pprTrace "uVarOrFam" (vcat+--           [ text "ty1" <+> ppr ty1+--           , text "ty2" <+> ppr ty2+--           , text "tv_env" <+> ppr (um_tv_env substs)+--           , text "fam_env" <+> ppr (um_fam_env substs) ]) $+       ; go NotSwapped substs ty1 ty2 kco }+  where+    foralld_tvs  = um_foralls env+    under_forall = not (isEmptyVarSet foralld_tvs)++    -- `go` takes two bites at the cherry; if the first one fails+    -- it swaps the arguments and tries again; and then it fails.+    -- The SwapFlag argument tells `go` whether it is on the first+    -- bite (NotSwapped) or the second (IsSwapped).+    -- E.g.    a ~ F p q+    --         Starts with: go a (F p q)+    --         if `a` not bindable, swap to: go (F p q) a++    -----------------------------+    -- LHS is a type variable+    -- The sequence of tests is very similar to go_tv+    go :: SwapFlag -> UMState -> CanEqLHS -> InType -> OutCoercion -> UM ()+    go swapped substs lhs@(TyVarLHS tv1) ty2 kco+      | Just ty1' <- lookupVarEnv (um_tv_env substs) tv1'+      = -- We already have a substitution for tv1+        if | um_unif env                          -> unify_ty env ty1' ty2 kco+           | (ty1' `mkCastTy` kco) `tcEqType` ty2 -> return ()+           | otherwise                            -> surelyApart+           -- Unifying: recurse into unify_ty+           -- Matching: we /don't/ want to just recurse here, because the range of+           --    the subst is the target type, not the template type. So, just check+           --    for normal type equality.+           -- NB: it's important to use `tcEqType` instead of `eqType` here,+           -- otherwise we might not reject a substitution+           -- which unifies `Type` with `Constraint`, e.g.+           -- a call to tc_unify_tys with arguments+           --+           --   tys1 = [k,k]+           --   tys2 = [Type, Constraint]+           --+           -- See test cases: T11715b, T20521.++      -- If we are matching or unifying a ~ a, take care+      -- See Note [Self-substitution when unifying or matching]+      | TyVarTy tv2 <- ty2+      , let tv2' = umRnOccR env tv2+      , tv1' == tv2'+      = if | um_unif env     -> return ()+           | tv1_is_bindable -> extendTvEnv tv1' ty2+           | otherwise       -> return ()++      | tv1_is_bindable+      , not (mentionsForAllBoundTyVarsR env ty2_fvs)+            -- ty2_fvs: kco does not mention forall-bound vars+      , not occurs_check+      = -- No occurs check, nor skolem-escape; just bind the tv+        -- We don't need to rename `rhs` because it mentions no forall-bound vars+        extendTvEnv tv1' rhs     -- Bind tv1:=rhs and continue++      -- When unifying, try swapping:+      -- e.g.   a    ~ F p q       with `a` not bindable: we might succeed with go_fam+      -- e.g.   a    ~ beta        with `a` not bindable: we might be able to bind `beta`+      -- e.g.   beta ~ F beta Int  occurs check; but MaybeApart after swapping+      | um_unif env+      , NotSwapped <- swapped  -- If we have swapped already, don't do so again+      , Just lhs2 <- canEqLHS_maybe ty2+      = go IsSwapped substs lhs2 (mkTyVarTy tv1) (mkSymCo kco)++      | occurs_check = maybeApart MARInfinite   -- Occurs check+      | otherwise    = surelyApart++      where+        tv1'            = umRnOccL env tv1+        ty2_fvs         = tyCoVarsOfType ty2+        rhs             = ty2 `mkCastTy` mkSymCo kco+        tv1_is_bindable | not (tv1' `elemVarSet` foralld_tvs)+                          -- tv1' is not forall-bound, but tv1 can still differ+                          -- from tv1; see Note [Cloning the template binders]+                          -- in GHC.Core.Rules.  So give tv1' to um_bind_tv_fun.+                        , BindMe <- um_bind_tv_fun env tv1' rhs+                        = True+                        | otherwise+                        = False++        occurs_check = um_unif env && uOccursCheck substs foralld_tvs lhs rhs+          -- Occurs check, only when unifying+          -- see Note [Infinitary substitutions]+          -- Make sure you include `kco` in rhs #14846++    -----------------------------+    -- LHS is a saturated type-family application+    -- Invariant: ty2 is not a TyVarTy+    go swapped substs lhs@(TyFamLHS tc1 tys1) ty2 kco+      -- Check if we have an existing substitution for the LHS; if so, recurse+      -- But not under a forall; see (ATF3) in Note [Apartness and type families]+      -- Hence the RnEnv2 is empty+      | not under_forall+      , Just ty1' <- lookupFamEnv (um_fam_env substs) tc1 tys1+      = if | um_unif env                          -> unify_ty env ty1' ty2 kco+           -- Below here we are matching+           -- The return () case deals with:+           --    Template:   (F a)..(F a)+           --    Target:     (F b)..(F b)+           -- This should match! With [a :-> b]+           | (ty1' `mkCastTy` kco) `tcEqType` ty2 -> return ()+           | otherwise                            -> maybeApart MARTypeFamily++      -- Check for equality  F tys1 ~ F tys2+      -- Very important that this can happen under a forall, so that we+      -- successfully match  (forall a. F a) ~ (forall b. F b)  See (ATF9-2)+      | Just (tc2, tys2) <- isSatTyFamApp ty2+      , tc1 == tc2+      = go_fam_fam substs tc1 tys1 tys2 kco++      -- If we are under a forall, just give up+      -- see (ATF3) and (ATF5) in Note [Apartness and type families]+      | under_forall+      = maybeApart MARTypeFamily++      -- Now check if we can bind the (F tys) to the RHS+      -- Again, not under a forall; see (ATF3)+      -- This can happen even when matching: see (ATF7)+      | BindMe <- um_bind_fam_fun env tc1 tys1 rhs+      = if uOccursCheck substs emptyVarSet lhs rhs+        then maybeApart MARInfinite+        else do { extendFamEnv tc1 tys1 rhs+                     -- We don't substitute tys1 before extending+                     -- See Note [Shortcomings of the apartness test]+                ; maybeApart MARTypeFamily }++      -- Swap in case of (F a b) ~ (G c d e)+      -- Maybe um_bind_fam_fun is False of (F a b) but true of (G c d e)+      -- NB: a type family can appear on the template when matching+      --     see (ATF6) in Note [Apartness and type families]+      -- (Only worth doing this if we are not under a forall.)+      | um_unif env+      , NotSwapped <- swapped+      , Just lhs2 <- canEqLHS_maybe ty2+      = go IsSwapped substs lhs2 (mkTyConApp tc1 tys1) (mkSymCo kco)++      | otherwise   -- See (ATF5) in Note [Apartness and type families]+      = surelyApart++      where+        rhs = ty2 `mkCastTy` mkSymCo kco++    -----------------------------+    -- go_fam_fam: LHS and RHS are both saturated type-family applications,+    --             for the same type-family F+    go_fam_fam substs tc tys1 tys2 kco+       -- Decompose (F tys1 ~ F tys2): (ATF9)+       -- Use injectivity information of F: (ATF10)+       -- But first bind the type-fam if poss: (ATF11)+      = do { bind_fam_if_poss                 -- (ATF11)+           ; unify_tys env inj_tys1 inj_tys2  -- (ATF10)+           ; unless (um_inj_tf env) $         -- (ATF12)+             don'tBeSoSure MARTypeFamily $    -- (ATF9-1)+             unify_tys env noninj_tys1 noninj_tys2 }+     where+       inj = case tyConInjectivityInfo tc of+                NotInjective -> repeat False+                Injective bs -> bs++       (inj_tys1, noninj_tys1) = partitionByList inj tys1+       (inj_tys2, noninj_tys2) = partitionByList inj tys2++       bind_fam_if_poss+         | not (um_unif env)  -- Not when matching (ATF11-1)+         = return ()+         | under_forall       -- Not under a forall (ATF3)+         = return ()+         | BindMe <- um_bind_fam_fun env tc tys1 rhs1+         = unless (uOccursCheck substs emptyVarSet (TyFamLHS tc tys1) rhs1) $+           extendFamEnv tc tys1 rhs1+         -- At this point um_unif=True, so we can unify either way+         | BindMe <- um_bind_fam_fun env tc tys2 rhs2+         = unless (uOccursCheck substs emptyVarSet (TyFamLHS tc tys2) rhs2) $+           extendFamEnv tc tys2 rhs2+         | otherwise+         = return ()++       rhs1 = mkTyConApp tc tys2 `mkCastTy` mkSymCo kco+       rhs2 = mkTyConApp tc tys1 `mkCastTy` kco+++uOccursCheck :: UMState+             -> TyVarSet -- Bound by enclosing foralls; see (OCU1)+             -> CanEqLHS -> Type   -- Can we unify (lhs := ty)?+             -> Bool+-- See Note [The occurs check in the Core unifier] and (ATF13)+uOccursCheck (UMState { um_tv_env = tv_env, um_fam_env = fam_env }) bvs lhs ty+  = go bvs ty+  where+    go :: TyCoVarSet   -- Bound by enclosing foralls; see (OCU1)+       -> Type -> Bool+    go bvs ty | Just ty' <- coreView ty = go bvs ty'+    go bvs (TyVarTy tv) | Just ty' <- lookupVarEnv tv_env tv+                        = go bvs ty'+                        | TyVarLHS tv' <- lhs, tv==tv'+                        = True+                        | otherwise+                        = go bvs (tyVarKind tv)+    go bvs (AppTy ty1 ty2)           = go bvs ty1 || go bvs ty2+    go _   (LitTy {})                = False+    go bvs (FunTy _ w arg res)       = go bvs w || go bvs arg || go bvs res+    go bvs (TyConApp tc tys)         = go_tc bvs tc tys++    go bvs (ForAllTy (Bndr tv _) ty)+      = go bvs (tyVarKind tv) ||+        (case lhs of+           TyVarLHS tv' | tv==tv'   -> False  -- Shadowing+                        | otherwise -> go (bvs `extendVarSet` tv) ty+           TyFamLHS {} -> False)  -- Lookups don't happen under a forall++    go bvs (CastTy ty  _co) = go bvs ty  -- ToDo: should we worry about `co`?+    go _   (CoercionTy _co) = False      -- ToDo: should we worry about `co`?++    go_tc bvs tc tys+      | isEmptyVarSet bvs   -- Never look up in um_fam_env under a forall (ATF3)+      , isTypeFamilyTyCon tc+      , Just ty' <- lookupFamEnv fam_env tc (take arity tys)+             -- NB: we look up /un-substituted/ types;+             -- See Note [Shortcomings of the apartness test]+      = go bvs ty' || any (go bvs) (drop arity tys)++      | TyFamLHS tc' tys' <- lhs+      , tc == tc'+      , tys `lengthAtLeast` arity  -- Saturated, or over-saturated+      , tcEqTyConAppArgs tys tys'+      = True++      | otherwise+      = any (go bvs) tys+      where+        arity = tyConArity tc++{- Note [The occurs check in the Core unifier]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The unifier applies both substitutions (um_tv_env and um_fam_env) as it goes,+so we'll get an infinite loop if we have, for example+    um_tv_env:   a :-> F b      -- (1)+    um_fam_env   F b :-> a      -- (2)++So (uOccursCheck substs lhs ty) returns True iff extending `substs` with `lhs :-> ty`+could lead to a loop. That is, could there by a type `s` such that+  applySubsts( (substs + lhs:->ty), s ) is infinite++It's vital that we do both at once: we might have (1) already and add (2);+or we might have (2) already and add (1).++A very similar task is done by GHC.Tc.Utils.Unify.checkTyEqRhs.++(OCU1) We keep track of the forall-bound variables because the um_fam_env is inactive+  under a forall; indeed it is /unsound/ to consult it because we may have a binding+  (F a :-> Int), and then unify (forall a. ...(F a)...) with something.  We don't+  want to map that (F a) to Int!++(OCU2) Performance. Consider unifying+         [a, b] ~ [big-ty, (a,a,a)]+  We'll unify a:=big-ty.  Then we'll attempt b:=(a,a,a), but must do an occurs check.+  So we'll walk over big-ty, looking for `b`.  And then again, and again, once for+  each occurrence of `a`.  A similar thing happens for+         [a, (b,b,b)] ~ [big-ty, (a,a,a)]+  albeit a bit less obviously.++  Potentially we could use a cache to record checks we have already done;+  but I have not attempted that yet.  Precisely similar remarks would apply+  to GHC.Tc.Utils.Unify.checkTyEqRhs++Note [Unifying coercion-foralls]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we try to unify (forall cv. t1) ~ (forall cv. t2).+See Note [ForAllTy] in GHC.Core.TyCo.Rep.++The problem with coercion variables is that coercion abstraction is not erased:+the `kco` shouldn't propagate from outside the ForAllTy to inside. Instead, I think+the correct new `kco` for the recursive call is `mkNomReflCo liftedTypeKind` (but I'm+a little worried it might be Constraint sometimes).++This potential problem has been there a long time, and I'm going to let+sleeping dogs lie for now.+-}++{-+************************************************************************+*                                                                      *+                Unification monad+*                                                                      *+************************************************************************+-}++data UMEnv+  = UMEnv { um_unif :: AmIUnifying++          , um_inj_tf :: Bool+            -- Checking for injectivity?+            -- See (SI1) in Note [Specification of unification]++          , um_arr_mult :: MultiplicityFlag+            -- Whether to unify multiplicity arguments when unifying arrows.+            -- See Note [Rewrite rules ignore multiplicities in FunTy]++          , um_rn_env :: RnEnv2+            -- Renaming InTyVars to OutTyVars; this eliminates shadowing, and+            -- lines up matching foralls on the left and right+            -- See (CU2) in Note [The Core unifier]++          , um_foralls :: TyVarSet+            -- OutTyVars bound by a forall in this unification;+            -- Do not bind these in the substitution!+            -- See the function tvBindFlag++          , um_bind_tv_fun :: BindTvFun+            -- User-supplied BindFlag function, for variables not in um_foralls+            -- See (CU1) in Note [The Core unifier]++          , um_bind_fam_fun :: BindFamFun+            -- Similar to um_bind_tv_fun, but for type-family applications+            -- See (ATF8) in Note [Apartness and type families]+          }++type FamSubstEnv = TyConEnv (ListMap TypeMap Type)+  -- Map a TyCon and a list of types to a type+  -- Domain of FamSubstEnv is exactly-saturated type-family+  -- applications (F t1...tn)++lookupFamEnv :: FamSubstEnv -> TyCon -> [Type] -> Maybe Type+lookupFamEnv env tc tys+  = do { tys_map <- lookupTyConEnv env tc+       ; lookupTM tys tys_map }++data UMState = UMState+                   { um_tv_env   :: TvSubstEnv+                   , um_cv_env   :: CvSubstEnv+                   , um_fam_env  :: FamSubstEnv }+  -- um_tv_env, um_cv_env, um_fam_env are all "global" substitutions;+  -- that is, neither their domains nor their ranges mention any variables+  -- in um_foralls; i.e. variables bound by foralls inside the types being unified++  -- When /matching/ um_fam_env is usually empty; but not quite always.+  -- See (ATF7) of Note [Apartness and type families]++newtype UM a+  = UM' { unUM :: UMState -> UnifyResultM (UMState, a) }+    -- See Note [The one-shot state monad trick] in GHC.Utils.Monad++pattern UM :: (UMState -> UnifyResultM (UMState, a)) -> UM a+-- See Note [The one-shot state monad trick] in GHC.Utils.Monad+pattern UM m <- UM' m+  where+    UM m = UM' (oneShot m)+{-# COMPLETE UM #-}++instance Functor UM where+  fmap f (UM m) = UM (\s -> fmap (\(s', v) -> (s', f v)) (m s))++instance Applicative UM where+      pure a = UM (\s -> pure (s, a))+      (<*>)  = ap++instance Monad UM where+  {-# INLINE (>>=) #-}+  -- See Note [INLINE pragmas and (>>)] in GHC.Utils.Monad+  m >>= k  = UM (\state ->+                  do { (state', v) <- unUM m state+                     ; unUM (k v) state' })++instance MonadFail UM where+    fail _   = UM (\_ -> SurelyApart) -- failed pattern match++initUM :: TvSubstEnv  -- subst to extend+       -> CvSubstEnv+       -> UM ()+       -> UnifyResultM (TvSubstEnv, CvSubstEnv)+initUM subst_env cv_subst_env um+  = case unUM um state of+      Unifiable (state, _)    -> Unifiable (get state)+      MaybeApart r (state, _) -> MaybeApart r (get state)+      SurelyApart             -> SurelyApart+  where+    state = UMState { um_tv_env = subst_env+                    , um_cv_env = cv_subst_env+                    , um_fam_env = emptyTyConEnv }+    get (UMState { um_tv_env = tv_env, um_cv_env = cv_env }) = (tv_env, cv_env)++getTvSubstEnv :: UM TvSubstEnv+getTvSubstEnv = UM $ \state -> Unifiable (state, um_tv_env state)++getCvSubstEnv :: UM CvSubstEnv+getCvSubstEnv = UM $ \state -> Unifiable (state, um_cv_env state)++getSubstEnvs :: UM UMState+getSubstEnvs = UM $ \state -> Unifiable (state, state)++getSubst :: UMEnv -> UM Subst+getSubst env = do { tv_env <- getTvSubstEnv+                  ; cv_env <- getCvSubstEnv+                  ; let in_scope = rnInScopeSet (um_rn_env env)+                  ; return (mkTCvSubst in_scope tv_env cv_env) }++extendTvEnv :: TyVar -> Type -> UM ()+extendTvEnv tv ty = UM $ \state ->+  Unifiable (state { um_tv_env = extendVarEnv (um_tv_env state) tv ty }, ())++extendCvEnv :: CoVar -> Coercion -> UM ()+extendCvEnv cv co = UM $ \state ->+  Unifiable (state { um_cv_env = extendVarEnv (um_cv_env state) cv co }, ())++extendFamEnv :: TyCon -> [Type] -> Type -> UM ()+extendFamEnv tc tys ty = UM $ \state ->+  Unifiable (state { um_fam_env = extend (um_fam_env state) tc }, ())+  where+    extend :: FamSubstEnv -> TyCon -> FamSubstEnv+    extend = alterTyConEnv alter_tm++    alter_tm :: Maybe (ListMap TypeMap Type) -> Maybe (ListMap TypeMap Type)+    alter_tm m_elt = Just (alterTM tys (\_ -> Just ty) (m_elt `orElse` emptyTM))++umRnBndr2 :: UMEnv -> TyCoVar -> TyCoVar -> UMEnv+umRnBndr2 env v1 v2+  = env { um_rn_env = rn_env', um_foralls = um_foralls env `extendVarSet` v' }+  where+    (rn_env', v') = rnBndr2_var (um_rn_env env) v1 v2++mentionsForAllBoundTyVarsL, mentionsForAllBoundTyVarsR :: UMEnv -> VarSet -> Bool+-- See (CU2) in Note [The Core unifier]+mentionsForAllBoundTyVarsL = mentions_forall_bound_tvs inRnEnvL+mentionsForAllBoundTyVarsR = mentions_forall_bound_tvs inRnEnvR++mentions_forall_bound_tvs :: (RnEnv2 -> TyVar -> Bool) -> UMEnv -> VarSet -> Bool+mentions_forall_bound_tvs in_rn_env env varset+  | isEmptyVarSet (um_foralls env)               = False+  | anyVarSet (in_rn_env (um_rn_env env)) varset = True+  | otherwise                                    = False+    -- NB: That isEmptyVarSet guard is a critical optimization;+    -- it means we don't have to calculate the free vars of+    -- the type, often saving quite a bit of allocation.++-- | Converts any SurelyApart to a MaybeApart+don'tBeSoSure :: MaybeApartReason -> UM () -> UM ()+don'tBeSoSure r um = UM $ \ state ->+  case unUM um state of+    SurelyApart -> MaybeApart r (state, ())+    other       -> other++umRnOccL :: UMEnv -> TyVar -> TyVar+umRnOccL env v = rnOccL (um_rn_env env) v++umRnOccR :: UMEnv -> TyVar -> TyVar+umRnOccR env v = rnOccR (um_rn_env env) v++umSwapRn :: UMEnv -> UMEnv+umSwapRn env = env { um_rn_env = rnSwap (um_rn_env env) }++maybeApart :: MaybeApartReason -> UM ()+maybeApart r = UM (\state -> MaybeApart r (state, ()))++surelyApart :: UM a+surelyApart = UM (\_ -> SurelyApart)++{-+%************************************************************************+%*                                                                      *+            Matching a (lifted) type against a coercion+%*                                                                      *+%************************************************************************++This section defines essentially an inverse to liftCoSubst. It is defined+here to avoid a dependency from Coercion on this module.++-}++data MatchEnv = ME { me_tmpls :: TyVarSet+                   , me_env   :: RnEnv2 }++-- | 'liftCoMatch' is sort of inverse to 'liftCoSubst'.  In particular, if+--   @liftCoMatch vars ty co == Just s@, then @liftCoSubst s ty == co@,+--   where @==@ there means that the result of 'liftCoSubst' has the same+--   type as the original co; but may be different under the hood.+--   That is, it matches a type against a coercion of the same+--   "shape", and returns a lifting substitution which could have been+--   used to produce the given coercion from the given type.+--   Note that this function is incomplete -- it might return Nothing+--   when there does indeed exist a possible lifting context.+--+-- This function is incomplete in that it doesn't respect the equality+-- in `eqType`. That is, it's possible that this will succeed for t1 and+-- fail for t2, even when t1 `eqType` t2. That's because it depends on+-- there being a very similar structure between the type and the coercion.+-- This incompleteness shouldn't be all that surprising, especially because+-- it depends on the structure of the coercion, which is a silly thing to do.+--+-- The lifting context produced doesn't have to be exacting in the roles+-- of the mappings. This is because any use of the lifting context will+-- also require a desired role. Thus, this algorithm prefers mapping to+-- nominal coercions where it can do so.+liftCoMatch :: TyCoVarSet -> Type -> Coercion -> Maybe LiftingContext+liftCoMatch tmpls ty co+  = do { cenv1 <- ty_co_match menv emptyVarEnv ki ki_co ki_ki_co ki_ki_co+       ; cenv2 <- ty_co_match menv cenv1       ty co+                              (mkNomReflCo co_lkind) (mkNomReflCo co_rkind)+       ; return (LC (mkEmptySubst in_scope) cenv2) }+  where+    menv     = ME { me_tmpls = tmpls, me_env = mkRnEnv2 in_scope }+    in_scope = mkInScopeSet (tmpls `unionVarSet` tyCoVarsOfCo co)+    -- Like tcMatchTy, assume all the interesting variables+    -- in ty are in tmpls++    ki       = typeKind ty+    ki_co    = promoteCoercion co+    ki_ki_co = mkNomReflCo liftedTypeKind++    Pair co_lkind co_rkind = coercionKind ki_co++-- | 'ty_co_match' does all the actual work for 'liftCoMatch'.+ty_co_match :: MatchEnv   -- ^ ambient helpful info+            -> LiftCoEnv  -- ^ incoming subst+            -> Type       -- ^ ty, type to match+            -> Coercion   -- ^ co :: lty ~r rty, coercion to match against+            -> Coercion   -- ^ :: kind(lsubst(ty)) ~N kind(lty)+            -> Coercion   -- ^ :: kind(rsubst(ty)) ~N kind(rty)+            -> Maybe LiftCoEnv+   -- ^ Just env ==> liftCoSubst Nominal env ty == co, modulo roles.+   -- Also: Just env ==> lsubst(ty) == lty and rsubst(ty) == rty,+   -- where lsubst = lcSubstLeft(env) and rsubst = lcSubstRight(env)+ty_co_match menv subst ty co lkco rkco+  | Just ty' <- coreView ty = ty_co_match menv subst ty' co lkco rkco++  -- handle Refl case:+  | tyCoVarsOfType ty `isNotInDomainOf` subst+  , Just (ty', _) <- isReflCo_maybe co+  , ty `eqType` ty'+    -- Why `eqType` and not `tcEqType`? Because this function is only used+    -- during coercion optimisation, after type-checking has finished.+  = Just subst++  where+    isNotInDomainOf :: VarSet -> VarEnv a -> Bool+    isNotInDomainOf set env+      = noneSet (\v -> elemVarEnv v env) set++    noneSet :: (Var -> Bool) -> VarSet -> Bool+    noneSet f = allVarSet (not . f)++ty_co_match menv subst ty co lkco rkco+  | CastTy ty' co' <- ty+     -- See Note [Matching in the presence of casts (1)]+  = let empty_subst  = mkEmptySubst (rnInScopeSet (me_env menv))+        substed_co_l = substCo (liftEnvSubstLeft empty_subst subst)  co'+        substed_co_r = substCo (liftEnvSubstRight empty_subst subst) co'+    in+    ty_co_match menv subst ty' co (substed_co_l `mkTransCo` lkco)+                                  (substed_co_r `mkTransCo` rkco)++  | SymCo co' <- co+  = swapLiftCoEnv <$> ty_co_match menv (swapLiftCoEnv subst) ty co' rkco lkco++  -- Match a type variable against a non-refl coercion+ty_co_match menv subst (TyVarTy tv1) co lkco rkco+  | Just co1' <- lookupVarEnv subst tv1' -- tv1' is already bound to co1+  = if eqCoercionX (nukeRnEnvL rn_env) co1' co+    then Just subst+    else Nothing       -- no match since tv1 matches two different coercions++  | tv1' `elemVarSet` me_tmpls menv           -- tv1' is a template var+  = if any (inRnEnvR rn_env) (tyCoVarsOfCoList co)+    then Nothing      -- occurs check failed+    else Just $ extendVarEnv subst tv1' $+                castCoercionKind co (mkSymCo lkco) (mkSymCo rkco)++  | otherwise+  = Nothing++  where+    rn_env = me_env menv+    tv1' = rnOccL rn_env tv1++  -- just look through SubCo's. We don't really care about roles here.+ty_co_match menv subst ty (SubCo co) lkco rkco+  = ty_co_match menv subst ty co lkco rkco++ty_co_match menv subst (AppTy ty1a ty1b) co _lkco _rkco+  | Just (co2, arg2) <- splitAppCo_maybe co     -- c.f. Unify.match on AppTy+  = ty_co_match_app menv subst ty1a [ty1b] co2 [arg2]+ty_co_match menv subst ty1 (AppCo co2 arg2) _lkco _rkco+  | Just (ty1a, ty1b) <- splitAppTyNoView_maybe ty1+       -- yes, the one from Type, not TcType; this is for coercion optimization+  = ty_co_match_app menv subst ty1a [ty1b] co2 [arg2]++ty_co_match menv subst (TyConApp tc1 tys) (TyConAppCo _ tc2 cos) _lkco _rkco+  = ty_co_match_tc menv subst tc1 tys tc2 cos++ty_co_match menv subst (FunTy { ft_mult = w, ft_arg = ty1, ft_res = ty2 })+            (FunCo { fco_mult = co_w, fco_arg = co1, fco_res = co2 }) _lkco _rkco+  = ty_co_match_args menv subst [w,    rep1,    rep2,    ty1, ty2]+                                [co_w, co1_rep, co2_rep, co1, co2]+  where+     rep1    = getRuntimeRep ty1+     rep2    = getRuntimeRep ty2+     co1_rep = mkRuntimeRepCo co1+     co2_rep = mkRuntimeRepCo co2+    -- NB: we include the RuntimeRep arguments in the matching;+    --     not doing so caused #21205.++ty_co_match menv subst (ForAllTy (Bndr tv1 vis1t) ty1)+                       (ForAllCo tv2 vis1c vis2c kind_co2 co2)+                       lkco rkco+  | isTyVar tv1 && isTyVar tv2+  , vis1t == vis1c && vis1c == vis2c -- Is this necessary?+      -- Is this visibility check necessary?  @rae says: yes, I think the+      -- check is necessary, if we're caring about visibility (and we are).+      -- But ty_co_match is a dark and not important corner.+  = do { subst1 <- ty_co_match menv subst (tyVarKind tv1) kind_co2+                               ki_ki_co ki_ki_co+       ; let rn_env0 = me_env menv+             rn_env1 = rnBndr2 rn_env0 tv1 tv2+             menv'   = menv { me_env = rn_env1 }+       ; ty_co_match menv' subst1 ty1 co2 lkco rkco }+  where+    ki_ki_co = mkNomReflCo liftedTypeKind++-- ty_co_match menv subst (ForAllTy (Bndr cv1 _) ty1)+--                        (ForAllCo cv2 kind_co2 co2)+--                        lkco rkco+--   | isCoVar cv1 && isCoVar cv2+--   We seems not to have enough information for this case+--   1. Given:+--        cv1      :: (s1 :: k1) ~r (s2 :: k2)+--        kind_co2 :: (s1' ~ s2') ~N (t1 ~ t2)+--        eta1      = mkSelCo (SelTyCon 2 role) (downgradeRole r Nominal kind_co2)+--                 :: s1' ~ t1+--        eta2      = mkSelCo (SelTyCon 3 role) (downgradeRole r Nominal kind_co2)+--                 :: s2' ~ t2+--      Wanted:+--        subst1 <- ty_co_match menv subst  s1 eta1 kco1 kco2+--        subst2 <- ty_co_match menv subst1 s2 eta2 kco3 kco4+--      Question: How do we get kcoi?+--   2. Given:+--        lkco :: <*>    -- See Note [Weird typing rule for ForAllTy] in GHC.Core.TyCo.Rep+--        rkco :: <*>+--      Wanted:+--        ty_co_match menv' subst2 ty1 co2 lkco' rkco'+--      Question: How do we get lkco' and rkco'?++ty_co_match _ subst (CoercionTy {}) _ _ _+  = Just subst -- don't inspect coercions++ty_co_match menv subst ty (GRefl r t (MCo co)) lkco rkco+  =  ty_co_match menv subst ty (GRefl r t MRefl) lkco (rkco `mkTransCo` mkSymCo co)++ty_co_match menv subst ty co1 lkco rkco+  | Just (CastTy t co, r) <- isReflCo_maybe co1+  -- In @pushRefl@, pushing reflexive coercion inside CastTy will give us+  -- t |> co ~ t ; <t> ; t ~ t |> co+  -- But transitive coercions are not helpful. Therefore we deal+  -- with it here: we do recursion on the smaller reflexive coercion,+  -- while propagating the correct kind coercions.+  = let kco' = mkSymCo co+    in ty_co_match menv subst ty (mkReflCo r t) (lkco `mkTransCo` kco')+                                                (rkco `mkTransCo` kco')++ty_co_match menv subst ty co lkco rkco+  | Just co' <- pushRefl co = ty_co_match menv subst ty co' lkco rkco+  | otherwise               = Nothing++ty_co_match_tc :: MatchEnv -> LiftCoEnv+               -> TyCon -> [Type]+               -> TyCon -> [Coercion]+               -> Maybe LiftCoEnv+ty_co_match_tc menv subst tc1 tys1 tc2 cos2+  = do { guard (tc1 == tc2)+       ; ty_co_match_args menv subst tys1 cos2 }++ty_co_match_app :: MatchEnv -> LiftCoEnv+                -> Type -> [Type] -> Coercion -> [Coercion]+                -> Maybe LiftCoEnv+ty_co_match_app menv subst ty1 ty1args co2 co2args+  | Just (ty1', ty1a) <- splitAppTyNoView_maybe ty1+  , Just (co2', co2a) <- splitAppCo_maybe co2+  = ty_co_match_app menv subst ty1' (ty1a : ty1args) co2' (co2a : co2args)++  | otherwise+  = do { subst1 <- ty_co_match menv subst ki1 ki2 ki_ki_co ki_ki_co+       ; let Pair lkco rkco = mkNomReflCo <$> coercionKind ki2+       ; subst2 <- ty_co_match menv subst1 ty1 co2 lkco rkco+       ; ty_co_match_args menv subst2 ty1args co2args }+  where+    ki1 = typeKind ty1+    ki2 = promoteCoercion co2+    ki_ki_co = mkNomReflCo liftedTypeKind++ty_co_match_args :: MatchEnv -> LiftCoEnv -> [Type] -> [Coercion]+                 -> Maybe LiftCoEnv+ty_co_match_args menv subst (ty:tys) (arg:args)+  = do { let Pair lty rty = coercionKind arg+             lkco = mkNomReflCo (typeKind lty)+             rkco = mkNomReflCo (typeKind rty)+       ; subst' <- ty_co_match menv subst ty arg lkco rkco+       ; ty_co_match_args menv subst' tys args }+ty_co_match_args _    subst []       [] = Just subst+ty_co_match_args _    _     _        _  = Nothing++pushRefl :: Coercion -> Maybe Coercion+pushRefl co =+  case (isReflCo_maybe co) of+    Just (AppTy ty1 ty2, Nominal)+      -> Just (AppCo (mkReflCo Nominal ty1) (mkNomReflCo ty2))+    Just (FunTy af w ty1 ty2, r)+      ->  Just (FunCo r af af (mkReflCo r w) (mkReflCo r ty1) (mkReflCo r ty2))+    Just (TyConApp tc tys, r)+      -> Just (TyConAppCo r tc (zipWith mkReflCo (tyConRoleListX r tc) tys))+    Just (ForAllTy (Bndr tv vis) ty, r)+      -> Just (ForAllCo { fco_tcv = tv, fco_visL = vis, fco_visR = vis+                        , fco_kind = mkNomReflCo (varType tv)+                        , fco_body = mkReflCo r ty })+    _ -> Nothing
GHC/Core/UsageEnv.hs view
@@ -6,17 +6,19 @@   , bottomUE   , deleteUE   , lookupUE+  , popUE   , scaleUE   , scaleUsage   , supUE   , supUEs-  , unitUE+  , 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@@ -46,16 +48,21 @@ addUsage (MUsage x) (MUsage y) = MUsage $ mkMultAdd x y  scaleUsage :: Mult -> Usage -> Usage-scaleUsage One Bottom     = Bottom-scaleUsage _   Zero       = Zero-scaleUsage x   Bottom     = MUsage x-scaleUsage x   (MUsage y) = MUsage $ mkMultMul x y+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 -unitUE :: NamedThing n => n -> Mult -> UsageEnv-unitUE x w = UsageEnv (unitNameEnv (getName x) w) False+-- | 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@@ -67,25 +74,29 @@   UsageEnv (plusNameEnv_C mkMultAdd e1 e2) (b1 || b2)  scaleUE :: Mult -> UsageEnv -> UsageEnv-scaleUE One ue = ue+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 Many e2 Many) 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 = Many+                                        | otherwise = ManyTy          combineUsage (Just x) Nothing  | b2        = x-                                        | otherwise = Many+                                        | otherwise = ManyTy          combineUsage Nothing  Nothing  = pprPanic "supUE" (ppr e1 <+> ppr e2) -- Note: If you are changing this logic, check 'mkMultSup' in Multiplicity as well. -supUEs :: [UsageEnv] -> UsageEnv+-- 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@@ -97,6 +108,9 @@   case lookupNameEnv e (getName x) of     Just w  -> MUsage w     Nothing -> if has_bottom then Bottom else Zero++popUE :: NamedThing n => UsageEnv -> n -> (Usage, UsageEnv)+popUE ue x = (lookupUE ue x, deleteUE ue x)  instance Outputable UsageEnv where   ppr (UsageEnv ne b) = text "UsageEnv:" <+> ppr ne <+> ppr b
GHC/Core/Utils.hs view
@@ -11,2885 +11,3056 @@         -- * Constructing expressions         mkCast, mkCastMCo, mkPiMCo,         mkTick, mkTicks, mkTickNoHNF, tickHNFArgs,-        bindNonRec, needsCaseBinding,-        mkAltExpr, mkDefaultCase, mkSingleAltCase,--        -- * Taking expressions apart-        findDefault, addDefault, findAlt, isDefaultAlt,-        mergeAlts, trimConArgs,-        filterAlts, combineIdenticalAlts, refineDefaultAlt,-        scaleAltsBy,--        -- * Properties of expressions-        exprType, coreAltType, coreAltsType, mkLamType, mkLamTypes,-        mkFunctionType,-        exprIsDupable, exprIsTrivial, getIdFromTrivialExpr, exprIsDeadEnd,-        getIdFromTrivialExpr_maybe,-        exprIsCheap, exprIsExpandable, exprIsCheapX, CheapAppFun,-        exprIsHNF, exprOkForSpeculation, exprOkForSideEffects, exprIsWorkFree,-        exprIsConLike,-        isCheapApp, isExpandableApp, isSaturatedConApp,-        exprIsTickedString, exprIsTickedString_maybe,-        exprIsTopLevelBindable,-        altsAreExhaustive,--        -- * Equality-        cheapEqExpr, cheapEqExpr', eqExpr,-        diffBinds,--        -- * Lambdas and eta reduction-        tryEtaReduce, canEtaReduceToArity,--        -- * Manipulating data constructors and types-        exprToType,-        applyTypeToArgs,-        dataConRepInstPat, dataConRepFSInstPat,-        isEmptyTy, normSplitTyConApp_maybe,--        -- * Working with ticks-        stripTicksTop, stripTicksTopE, stripTicksTopT,-        stripTicksE, stripTicksT,--        -- * StaticPtr-        collectMakeStaticArgs,--        -- * Join points-        isJoinBind,--        -- * Tag inference-        mkStrictFieldSeqs, shouldStrictifyIdForCbv, shouldUseCbvForId,--        -- * unsafeEqualityProof-        isUnsafeEqualityProof,--        -- * Dumping stuff-        dumpIdInfoOfProgram-    ) where--import GHC.Prelude-import GHC.Platform--import GHC.Core-import GHC.Core.Ppr-import GHC.Core.FVs( exprFreeVars )-import GHC.Core.DataCon-import GHC.Core.Type as Type-import GHC.Core.FamInstEnv-import GHC.Core.Predicate-import GHC.Core.TyCo.Rep( TyCoBinder(..), TyBinder )-import GHC.Core.Coercion-import GHC.Core.Reduction-import GHC.Core.TyCon-import GHC.Core.Multiplicity-import GHC.Core.Map.Expr ( eqCoreExpr )--import GHC.Builtin.Names ( makeStaticName, unsafeEqualityProofIdKey )-import GHC.Builtin.PrimOps--import GHC.Types.Var-import GHC.Types.SrcLoc-import GHC.Types.Var.Env-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, Levity(..)-                       )-import GHC.Types.Unique-import GHC.Types.Unique.Set--import GHC.Data.FastString-import GHC.Data.Maybe-import GHC.Data.List.SetOps( minusList )-import GHC.Data.Pair-import GHC.Data.OrdList--import GHC.Utils.Constants (debugIsOn)-import GHC.Utils.Outputable-import GHC.Utils.Panic-import GHC.Utils.Panic.Plain-import GHC.Utils.Misc-import GHC.Utils.Trace--import Data.ByteString     ( ByteString )-import Data.Function       ( on )-import Data.List           ( sort, sortBy, partition, zipWith4, mapAccumL )-import Data.Ord            ( comparing )-import qualified Data.Set as Set-import GHC.Types.RepType (isZeroBitTy)-import GHC.Types.Demand (isStrictDmd, isAbsDmd, isDeadEndAppSig)--{--************************************************************************-*                                                                      *-\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)         = 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 (pprCoreExpr e) (exprType fun) args--exprType other = pprPanic "exprType" (pprCoreExpr other)--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  :: 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 body_ty-   | isTyVar v-   = mkForAllTy v Inferred body_ty--   | isCoVar v-   , v `elemVarSet` tyCoVarsOfType body_ty-   = mkForAllTy v Required body_ty--   | otherwise-   = mkFunctionType (varMult v) (varType v) body_ty--mkFunctionType :: Mult -> Type -> Type -> Type--- This one works out the AnonArgFlag from the argument type--- See GHC.Types.Var Note [AnonArgFlag]-mkFunctionType mult arg_ty res_ty-   | isPredTy arg_ty -- See GHC.Types.Var Note [AnonArgFlag]-   = assert (eqType mult Many) $-     mkInvisFunTy mult arg_ty res_ty--   | otherwise-   = mkVisFunTy mult arg_ty res_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 => SDoc -> Type -> [CoreExpr] -> Type--- ^ Determines the type resulting from applying an expression with given type---- to given argument expressions.--- The first argument is just for debugging, and gives some context-applyTypeToArgs pp_e op_ty args-  = go op_ty args-  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 "Expression:" <+> pp_e-                        , 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 :: CoreExpr -> CoercionR -> CoreExpr-mkCast e co-  | assertPpr (coercionRole co == Representational)-              (text "coercion" <+> ppr co <+> text "passed to mkCast"-               <+> ppr e <+> text "has wrong role" <+> ppr (coercionRole co)) $-    isReflCo co-  = e--mkCast (Coercion e_co) co-  | isCoVarType (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)--mkCast (Cast expr co2) co-  = warnPprTrace (let { from_ty = coercionLKind co;-                        to_ty2  = coercionRKind co2 } in-                     not (from_ty `eqType` to_ty2))-             "mkCast"-             (vcat ([ text "expr:" <+> ppr expr-                   , text "co2:" <+> ppr co2-                   , text "co:" <+> ppr co ])) $-    mkCast expr (mkTransCo co2 co)--mkCast (Tick t expr) co-   = Tick t (mkCast expr co)--mkCast expr co-  = let from_ty = coercionLKind co in-    warnPprTrace (not (from_ty `eqType` exprType expr))-          "Trying to coerce" (text "(" <> ppr expr-          $$ text "::" <+> ppr (exprType expr) <> text ")"-          $$ ppr co $$ ppr (coercionType co)-          $$ callStackDoc) $-    (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' :: (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--    -- 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 :: 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---- | Tests whether we have to use a @case@ rather than @let@ binding for this expression--- as per the invariants of 'CoreExpr': see "GHC.Core#let_app_invariant"-needsCaseBinding :: Type -> CoreExpr -> Bool-needsCaseBinding ty rhs =-  mightBeUnliftedType ty && not (exprOkForSpeculation rhs)-        -- Make a case expression instead of a let-        -- These can arise either from the desugarer,-        -- or from beta reductions: (\x.e) (x +# y)--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.--}------------------------------------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, addDefault trimmed_alts maybe_deflt)-  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)      -- 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 = 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 [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 exapple (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.--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 -> []  -- See Note [-                  _       -> [con1]--    cheapEqTicked e1 e2 = cheapEqExpr' tickishFloatable e1 e2-    identical_to_alt1 (Alt _con bndrs rhs)-      = all isDeadBinder bndrs && rhs `cheapEqTicked` rhs1-    tickss = map (\(Alt _ _ rhs) -> stripTicksT tickishFloatable rhs) elim_rest--combineIdenticalAlts imposs_cons alts-  = (False, imposs_cons, alts)---- Scales the multiplicity of the binders of a list of case alternatives. That--- is, in [C x1…xn -> u], the multiplicity of x1…xn is scaled.-scaleAltsBy :: Mult -> [CoreAlt] -> [CoreAlt]-scaleAltsBy w alts = map scaleAlt alts-  where-    scaleAlt :: CoreAlt -> CoreAlt-    scaleAlt (Alt con bndrs rhs) = Alt con (map scaleBndr bndrs) rhs--    scaleBndr :: CoreBndr -> CoreBndr-    scaleBndr b = scaleVarBy w b---{- *********************************************************************-*                                                                      *-             exprIsTrivial-*                                                                      *-************************************************************************--Note [exprIsTrivial]-~~~~~~~~~~~~~~~~~~~~-@exprIsTrivial@ is true of expressions we are unconditionally happy to-                duplicate; simple variables and constants, and type-                applications.  Note that primop Ids aren't considered-                trivial unless--Note [Variables are trivial]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-There used to be a gruesome test for (hasNoBinding v) in the-Var case:-        exprIsTrivial (Var v) | hasNoBinding v = idArity v == 0-The idea here is that a constructor worker, like \$wJust, is-really short for (\x -> \$wJust x), because \$wJust has no binding.-So it should be treated like a lambda.  Ditto unsaturated primops.-But now constructor workers are not "have-no-binding" Ids.  And-completely un-applied primops and foreign-call Ids are sufficiently-rare that I plan to allow them to be duplicated and put up with-saturating them.--Note [Tick trivial]-~~~~~~~~~~~~~~~~~~~-Ticks are only trivial if they are pure annotations. If we treat-"tick<n> x" as trivial, it will be inlined inside lambdas and the-entry count will be skewed, for example.  Furthermore "scc<n> x" will-turn into just "x" in mkTick.--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.--}--exprIsTrivial :: CoreExpr -> Bool--- If you modify this function, you may also--- need to modify getIdFromTrivialExpr-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 :: HasDebugCallStack => CoreExpr -> Id-getIdFromTrivialExpr e-    = fromMaybe (pprPanic "getIdFromTrivialExpr" (ppr e))-                (getIdFromTrivialExpr_maybe e)--getIdFromTrivialExpr_maybe :: CoreExpr -> Maybe Id--- See Note [getIdFromTrivialExpr]--- Th equations for this should line up with those for exprIsTrivial-getIdFromTrivialExpr_maybe e-  = go e-  where-    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 (Case e _ _ [])                    = go e-    go (Var v) = Just v-    go _       = Nothing--{--exprIsDeadEnd is a very cheap and cheerful function; it may return-False for bottoming expressions, but it never costs much to ask.  See-also GHC.Core.Opt.Arity.exprBotStrictness_maybe, but that's a bit more-expensive.--}--exprIsDeadEnd :: CoreExpr -> Bool--- See Note [Bottoming expressions]-exprIsDeadEnd e-  | isEmptyTy (exprType e)-  = True-  | otherwise-  = go 0 e-  where-    go n (Var v)                 = isDeadEndAppSig (idDmdSig v) n-    go n (App e a) | isTypeArg a = go n e-                   | otherwise   = go (n+1) e-    go n (Tick _ e)              = go n e-    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 GHC.Core-    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 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.---************************************************************************-*                                                                      *-             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--}-----------------------exprIsWorkFree :: CoreExpr -> Bool   -- See Note [exprIsWorkFree]-exprIsWorkFree e = exprIsCheapX isWorkFreeApp e--exprIsCheap :: CoreExpr -> Bool-exprIsCheap e = exprIsCheapX isCheapApp e--exprIsCheapX :: CheapAppFun -> CoreExpr -> Bool-{-# INLINE exprIsCheapX #-}--- allow specialization of exprIsCheap and exprIsWorkFree--- instead of having an unknown call to ok_app-exprIsCheapX ok_app e-  = ok e-  where-    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)        = 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)         = go n e && ok r-    go n (Let (Rec prs) e)            = go n e && all (ok . snd) prs--      -- Case: see Note [Case expressions are work-free]-      -- App, Let: see Note [Arguments and let-bindings exprIsCheapX]---{- 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.)--}----------------------------------------exprIsExpandable :: CoreExpr -> Bool--- See Note [exprIsExpandable]-exprIsExpandable e-  = ok e-  where-    ok e = go 0 e--    -- n is the number of value arguments-    go n (Var v)                      = isExpandableApp v n-    go _ (Lit {})                     = True-    go _ (Type {})                    = True-    go _ (Coercion {})                = True-    go n (Cast e _)                   = go n e-    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 _ (Case {})                    = False-    go _ (Let {})                     = False-----------------------------------------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--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-      _                -> 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 {} -> True  -- Actually 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-      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 InvisArg _ -> all_pred_args (n_val_args-1) ty-           Anon VisArg _   -> False--       | 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 [isExpandableApp: bottoming functions]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-It's important that isExpandableApp does not respond True to bottoming-functions.  Recall  undefined :: HasCallStack => a-Suppose isExpandableApp responded True to (undefined d), and we had:--  x = undefined <dict-expr>--Then Simplify.prepareRhs would ANF the RHS:--  d = <dict-expr>-  x = undefined d--This is already bad: we gain nothing from having x bound to (undefined-var), unlike the case for data constructors.  Worse, we get the-simplifier loop described in OccurAnal Note [Cascading inlines].-Suppose x occurs just once; OccurAnal.occAnalNonRecRhs decides x will-certainly_inline; so we end up inlining d right back into x; but in-the end x doesn't inline because it is bottom (preInlineUnconditionally);-so the process repeats.. We could elaborate the certainly_inline logic-some more, but it's better just to treat bottoming bindings as-non-expandable, because ANFing them is a bad idea in the first place.--Note [Record selection]-~~~~~~~~~~~~~~~~~~~~~~~~~~-I'm experimenting with making record selection-look cheap, so we will substitute it inside a-lambda.  Particularly for dictionary field selection.--BUT: Take care with (sel d x)!  The (sel d) might be cheap, but-there's no guarantee that (sel d x) will be too.  Hence (n_val_args == 1)--Note [Expandable overloadings]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Suppose the user wrote this-   {-# RULE  forall x. foo (negate x) = h x #-}-   f x = ....(foo (negate x))....-They'd expect the rule to fire. But since negate is overloaded, we might-get this:-    f = \d -> let n = negate d in \x -> ...foo (n x)...-So we treat the application of a function (negate in this case) to a-*dictionary* as expandable.  In effect, every function is CONLIKE when-it's applied only to dictionaries.---************************************************************************-*                                                                      *-             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 "GHC.Builtin.PrimOps"--- and Note [Transformations affected by can_fail and has_side_effects]------ 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--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 _ (Let {}) = False-  -- Lets can be stacked deeply, so just give up.-  -- In any case, the argument of exprOkForSpeculation is-  -- usually in a strict context, so any lets will have been-  -- floated away.--expr_ok primop_ok (Case scrut bndr _ alts)-  =  -- See Note [exprOkForSpeculation: case expressions]-     expr_ok primop_ok scrut-  && isUnliftedType (idType bndr)-      -- OK to call isUnliftedType: binders always have a fixed RuntimeRep-  && all (\(Alt _ _ rhs) -> expr_ok primop_ok rhs) alts-  && altsAreExhaustive alts--expr_ok primop_ok other_expr-  | (expr, args) <- collectArgs other_expr-  = case stripTicksTopE (not . tickishCounts) expr of-        Var f            -> app_ok primop_ok f args--        -- 'LitRubbish' is the only literal that can occur in the head of an-        -- application and will not be matched by the above case (Var /= Lit).-        -- See Note [How a rubbish literal can be the head of an application]-        -- in GHC.Types.Literal-        Lit lit | debugIsOn, not (isLitRubbish lit)-                 -> pprPanic "Non-rubbish lit in app head" (ppr lit)-                 | otherwise-                 -> True--        _ -> False--------------------------------app_ok :: (PrimOp -> Bool) -> Id -> [CoreExpr] -> Bool-app_ok primop_ok fun args-  = 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-        | primOpIsDiv 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--        | SeqOp <- op  -- See Note [exprOkForSpeculation and SeqOp/DataToTagOp]-        -> False       --     for the special cases for SeqOp and DataToTagOp-        | DataToTagOp <- op-        -> False-        | KeepAliveOp <- op-        -> False--        | otherwise-        -> primop_ok op  -- Check the primop itself-        && and (zipWith primop_arg_ok arg_tys args)  -- Check the arguments--      _  -- Unlifted types-         -- c.f. the Var case of exprIsHNF-         | Just Unlifted <- typeLevity_maybe (idType fun)-         -> assertPpr (n_val_args == 0) (ppr fun $$ ppr args)-            True  -- Our only unlifted types are Int# etc, so will have-                  -- no value args.  The assert is just to check this.-                  -- If we added unlifted function types this would change,-                  -- and we'd need to actually test n_val_args == 0.--         -- Partial applications-         | idArity fun > n_val_args -> True--         -- Functions that terminate fast without raising exceptions etc-         -- See Note [Discarding unnecessary unsafeEqualityProofs]-         | fun `hasKey` unsafeEqualityProofIdKey -> True--         | otherwise -> False-             -- NB: even in the nullary case, do /not/ check-             --     for evaluated-ness of the fun;-             --     see Note [exprOkForSpeculation and evaluated variables]-  where-    n_val_args   = valArgCount args-    (arg_tys, _) = splitPiTys (idType fun)--    primop_arg_ok :: TyBinder -> CoreExpr -> Bool-    primop_arg_ok (Named _) _ = True   -- A type argument-    primop_arg_ok (Anon _ ty) arg      -- A term argument-       | Just Lifted <- typeLevity_maybe (scaledThing ty)-       = True -- See Note [Primops with lifted arguments]-       | otherwise-       = expr_ok primop_ok arg--------------------------------altsAreExhaustive :: [Alt b] -> Bool--- True  <=> the case alternatives are definitely exhaustive--- False <=> they may or may not be-altsAreExhaustive []-  = False    -- Should not happen-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--{- 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/app 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/app 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 [Primops with lifted arguments]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Is this ok-for-speculation (see #13027)?-   reallyUnsafePtrEquality# a b-Well, yes.  The primop accepts lifted arguments and does not-evaluate them.  Indeed, in general primops are, well, primitive-and do not perform evaluation.--Bottom line:-  * In exprOkForSpeculation we simply ignore all lifted arguments.-  * In the rare case of primops that /do/ evaluate their arguments,-    (namely DataToTagOp and SeqOp) return False; see-    Note [exprOkForSpeculation and evaluated variables]--Note [exprOkForSpeculation and SeqOp/DataToTagOp]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Most primops with lifted arguments don't evaluate them-(see Note [Primops with lifted arguments]), so we can ignore-that argument entirely when doing exprOkForSpeculation.--But DataToTagOp and SeqOp are exceptions to that rule.-For reasons described in Note [exprOkForSpeculation and-evaluated variables], we simply return False for them.--Not doing this made #5129 go bad.-Lots of discussion in #15696.--Note [exprOkForSpeculation and evaluated variables]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Recall that-  seq#       :: forall a s. a -> State# s -> (# State# s, a #)-  dataToTag# :: forall a.   a -> Int#-must always evaluate their first argument.--Now consider these examples:- * case x of y { DEFAULT -> ....y.... }-   Should 'y' (alone) be considered ok-for-speculation?-- * case x of y { DEFAULT -> ....f (dataToTag# y)... }-   Should (dataToTag# y) be considered ok-for-spec?--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 -> ....f (dataToTag# x)... }--And now the expression does not obey the let/app invariant!  Yikes!-Moreover we really might float (f (dataToTag# x)) outside the case,-and then it really, really doesn't obey the let/app 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 DataToTagOp and SeqOp.--Note that exprIsHNF /can/ and does take advantage of evaluated-ness;-it doesn't have the trickiness of the let/app invariant to worry about.--Note [Discarding unnecessary unsafeEqualityProofs]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In #20143 we found-   case unsafeEqualityProof @t1 @t2 of UnsafeRefl cv[dead] -> blah-where 'blah' didn't mention 'cv'.  We'd like to discard this-redundant use of unsafeEqualityProof, via GHC.Core.Opt.Simplify.rebuildCase.-To do this we need to know-  (a) that cv is unused (done by OccAnal), and-  (b) that unsafeEqualityProof terminates rapidly without side effects.--At the moment we check that explicitly here in exprOkForSideEffects,-but one might imagine a more systematic check in future.---************************************************************************-*                                                                      *-             exprIsHNF, exprIsConLike-*                                                                      *-************************************************************************--}---- 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 "GHC.Core#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-      =  id_app_is_value v 0 -- 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-      || ( typeLevity_maybe (idType v) == Just Unlifted )-        -- 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 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--    -- 'n' is the number of value args to which the expression is applied-    -- And n>0: there is at least one value argument-    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--{--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 [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 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 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 :: TCvSubst -> (TyCoVar, FastString, Unique) -> (TCvSubst, 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]-        mkLocalIdOrCoVar name (mult `mkMultMul` m) (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 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----eqExpr :: InScopeSet -> CoreExpr -> CoreExpr -> Bool--- Compares for equality, modulo alpha--- TODO: remove eqExpr once GHC 9.4 is released-eqExpr _ = eqCoreExpr-{-# DEPRECATED eqExpr "Use 'GHC.Core.Map.Expr.eqCoreExpr', 'eqExpr' will be removed in GHC 9.6" #-}---- Used by diffBinds, which is itself only used in GHC.Core.Lint.lintAnnots-eqTickish :: RnEnv2 -> CoreTickish -> CoreTickish -> Bool-eqTickish env (Breakpoint lext lid lids) (Breakpoint rext rid rids)-      = lid == rid &&-        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 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) =-                  (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-       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-         -- 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-    && levityInfo info1 == levityInfo 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 _ _ 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 terminate after all.-  Result: seg-fault because the boolean case actually gets a function value.-  See #1947.--  So it's important to do the right thing.--* With linear types, eta-reduction can break type-checking:-        f :: A ⊸ B-        g :: A -> B-        g = \x. f x--  The above is correct, but eta-reducing g would yield g=f, the linter will-  complain that g and f don't have the same type.--* Note [Arity care]-  ~~~~~~~~~~~~~~~~~-  We need to be careful if we just look at f's-  arity. Currently (Dec07), f's arity is visible in its own RHS (see-  Note [Arity robustness] in GHC.Core.Opt.Simplify.Env) so we must *not* trust the-  arity when checking that 'f' is a value.  Otherwise we will-  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.--}---- When updating this function, make sure to update--- CorePrep.tryEtaReducePrep as well!-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 (exprType fun)-      = 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 = -- There are arguments to reduce...-                    fun_arity fun >= incoming_arity &&-                    -- ... and the function can be eta reduced to arity 0-                    canEtaReduceToArity fun 0 0-    ----------------    fun_arity fun             -- See Note [Arity care]-       | isLocalId fun-       , 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)-           -> Type             -- Type of the function to which the argument is applied-           -> 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 ty) co _-       | Just tv <- getTyVar_maybe ty-       , bndr == tv  = Just (mkHomoForAllCos [tv] co, [])-    ok_arg bndr (Var v) co fun_ty-       | bndr == v-       , let mult = idMult bndr-       , Just (fun_mult, _, _) <- splitFunTy_maybe fun_ty-       , mult `eqType` fun_mult -- There is no change in multiplicity, otherwise we must abort-       = Just (mkFunResCo Representational (idScaledType 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 (mkFunCo 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 to the specified arity?--- See Note [Eta reduction conditions].-canEtaReduceToArity :: Id -> JoinArity -> Arity -> Bool-canEtaReduceToArity fun dest_join_arity dest_arity =-  not $-        hasNoBinding fun-       -- Don't undersaturate functions with no binding.--    ||  ( isJoinId fun && dest_join_arity < idJoinArity fun )-       -- Don't undersaturate join points.-       -- See Note [Invariants on join points] in GHC.Core, and #20599--    || ( dest_arity < idCbvMarkArity fun )-       -- Don't undersaturate StrictWorkerIds.-       -- See Note [CBV Function Ids]  in GHC.CoreToStg.Prep.--    ||  isLinearType (idType fun)-       -- Don't perform eta reduction on linear types.-       -- If `f :: A %1-> B` and `g :: A -> B`,-       -- then `g x = f x` is OK but `g = f` is not.-       -- See Note [Eta reduction conditions].--{--Note [Eta reduction of an eval'd function]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-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 #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.--}--{--************************************************************************-*                                                                      *-\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.-normSplitTyConApp_maybe :: FamInstEnvs -> Type -> Maybe (TyCon, [Type], Coercion)-normSplitTyConApp_maybe fam_envs ty-  | let Reduction co ty1 = topNormaliseType_maybe fam_envs ty-                           `orElse` (mkReflRedn Representational ty)-  , Just (tc, tc_args) <- splitTyConApp_maybe ty1-  = Just (tc, tc_args, co)-normSplitTyConApp_maybe _ _ = Nothing--{--*****************************************************-*-* StaticPtr-*-*****************************************************--}---- | @collectMakeStaticArgs (makeStatic t srcLoc e)@ yields--- @Just (makeStatic, t, srcLoc, e)@.------ Returns @Nothing@ for every other expression.-collectMakeStaticArgs-  :: CoreExpr -> Maybe (CoreExpr, Type, CoreExpr, CoreExpr)-collectMakeStaticArgs e-    | (fun@(Var b), [Type t, loc, arg], _) <- collectArgsTicks (const True) e-    , idName b == makeStaticName = Just (fun, t, loc, arg)-collectMakeStaticArgs _          = Nothing--{--************************************************************************-*                                                                      *-\subsection{Join points}-*                                                                      *-************************************************************************--}---- | Does this binding bind a join point (or a recursive group of join points)?-isJoinBind :: CoreBind -> Bool-isJoinBind (NonRec b _)       = isJoinId b-isJoinBind (Rec ((b, _) : _)) = isJoinId b-isJoinBind _                  = False--dumpIdInfoOfProgram :: Bool -> (IdInfo -> SDoc) -> CoreProgram -> SDoc-dumpIdInfoOfProgram dump_locals ppr_id_info binds = vcat (map printId ids)-  where-  ids = sortBy (stableNameCmp `on` getName) (concatMap getIds binds)-  getIds (NonRec i _) = [ i ]-  getIds (Rec bs)     = map fst bs-  -- By default only include full info for exported ids, unless we run in the verbose-  -- pprDebug mode.-  printId id | isExportedId id || dump_locals = ppr id <> colon <+> (ppr_id_info (idInfo id))-             | otherwise       = empty--{--************************************************************************-*                                                                      *-\subsection{Tag inference things}-*                                                                      *-************************************************************************--}--{- Note [Call-by-value for worker args]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If we unbox a constructor with strict fields we want to-preserve the information that some of the arguments came-out of strict fields and therefore should be already properly-tagged, however we can't express this directly in core.--Instead what we do is generate a worker like this:--  data T = MkT A !B--  foo = case T of MkT a b -> $wfoo a b--  $wfoo a b = case b of b' -> rhs[b/b']--This makes the worker strict in b causing us to use a more efficient-calling convention for `b` where the caller needs to ensure `b` is-properly tagged and evaluated before it's passed to $wfoo. See Note [CBV Function Ids].--Usually the argument will be known to be properly tagged at the call site so there is-no additional work for the caller and the worker can be more efficient since it can-assume the presence of a tag.--This is especially true for recursive functions like this:-    -- myPred expect it's argument properly tagged-    myPred !x = ...--    loop :: MyPair -> Int-    loop (MyPair !x !y) =-        case x of-            A -> 1-            B -> 2-            _ -> loop (MyPair (myPred x) (myPred y))--Here we would ordinarily not be strict in y after unboxing.-However if we pass it as a regular argument then this means on-every iteration of loop we will incur an extra seq on y before-we can pass it to `myPred` which isn't great! That is in STG after-tag inference we get:--    Rec {-    Find.$wloop [InlPrag=[2], Occ=LoopBreaker]-      :: Find.MyEnum -> Find.MyEnum -> GHC.Prim.Int#-    [GblId[StrictWorker([!, ~])],-    Arity=2,-    Str=<1L><ML>,-    Unf=OtherCon []] =-        {} \r [x y]-            case x<TagProper> of x' [Occ=Once1] {-              __DEFAULT ->-                  case y of y' [Occ=Once1] {-                  __DEFAULT ->-                  case Find.$wmyPred y' of pred_y [Occ=Once1] {-                  __DEFAULT ->-                  case Find.$wmyPred x' of pred_x [Occ=Once1] {-                  __DEFAULT -> Find.$wloop pred_x pred_y;-                  };-                  };-              Find.A -> 1#;-              Find.B -> 2#;-            };-    end Rec }--Here comes the tricky part: If we make $wloop strict in both x/y and we get:--    Rec {-    Find.$wloop [InlPrag=[2], Occ=LoopBreaker]-      :: Find.MyEnum -> Find.MyEnum -> GHC.Prim.Int#-    [GblId[StrictWorker([!, !])],-    Arity=2,-    Str=<1L><!L>,-    Unf=OtherCon []] =-        {} \r [x y]-            case y<TagProper> of y' [Occ=Once1] { __DEFAULT ->-            case x<TagProper> of x' [Occ=Once1] {-              __DEFAULT ->-                  case Find.$wmyPred y' of pred_y [Occ=Once1] {-                  __DEFAULT ->-                  case Find.$wmyPred x' of pred_x [Occ=Once1] {-                  __DEFAULT -> Find.$wloop pred_x pred_y;-                  };-                  };-              Find.A -> 1#;-              Find.B -> 2#;-            };-    end Rec }--Here both x and y are known to be tagged in the function body since we pass strict worker args using unlifted cbv.-This means the seqs on x and y both become no-ops and compared to the first version the seq on `y` disappears at runtime.--The downside is that the caller of $wfoo potentially has to evaluate `y` once if we can't prove it isn't already evaluated.-But y coming out of a strict field is in WHNF so safe to evaluated. And most of the time it will be properly tagged+evaluated-already at the call site because of the Strict Field Invariant! See Note [Strict Field Invariant] for more in this.-This makes GHC itself around 1% faster despite doing slightly more work! So this is generally quite good.--We only apply this when we think there is a benefit in doing so however. There are a number of cases in which-it would be useless to insert an extra seq. ShouldStrictifyIdForCbv tries to identify these to avoid churn in the-simplifier. See Note [Which Ids should be strictified] for details on this.--}-mkStrictFieldSeqs :: [(Id,StrictnessMark)] -> CoreExpr -> (CoreExpr)-mkStrictFieldSeqs args rhs =-  foldr addEval rhs args-    where-      case_ty = exprType rhs-      addEval :: (Id,StrictnessMark) -> (CoreExpr) -> (CoreExpr)-      addEval (arg_id,arg_cbv) (rhs)-        -- Argument representing strict field.-        | isMarkedStrict arg_cbv-        , shouldStrictifyIdForCbv arg_id-        -- Make sure to remove unfoldings here to avoid the simplifier dropping those for OtherCon[] unfoldings.-        = Case (Var $! zapIdUnfolding arg_id) arg_id case_ty ([Alt DEFAULT [] rhs])-        -- Normal argument-        | otherwise = do-          rhs--{- Note [Which Ids should be strictified]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-For some arguments we would like to convince GHC to pass them call by value.-One way to achieve this is described in see Note [Call-by-value for worker args].--We separate the concerns of "should we pass this argument using cbv" and-"should we do so by making the rhs strict in this argument".-This note deals with the second part.--There are multiple reasons why we might not want to insert a seq in the rhs to-strictify a functions argument:--1) The argument doesn't exist at runtime.--For zero width types (like Types) there is no benefit as we don't operate on them-at runtime at all. This includes things like void#, coercions and state tokens.--2) The argument is a unlifted type.--If the argument is a unlifted type the calling convention already is explicitly-cbv. This means inserting a seq on this argument wouldn't do anything as the seq-would be a no-op *and* it wouldn't affect the calling convention.--3) The argument is absent.--If the argument is absent in the body there is no advantage to it being passed as-cbv to the function. The function won't ever look at it so we don't safe any work.--This mostly happens for join point. For example we might have:--    data T = MkT ![Int] [Char]-    f t = case t of MkT xs{strict} ys-> snd (xs,ys)--and abstract the case alternative to:--    f t = join j1 = \xs ys -> snd (xs,ys)-          in case t of MkT xs{strict} ys-> j1 xs xy--While we "use" xs inside `j1` it's not used inside the function `snd` we pass it to.-In short a absent demand means neither our RHS, nor any function we pass the argument-to will inspect it. So there is no work to be saved by forcing `xs` early.--NB: There is an edge case where if we rebox we *can* end up seqing an absent value.-Note [Absent fillers] has an example of this. However this is so rare it's not worth-caring about here.--4) The argument is already strict.--Consider this code:--    data T = MkT ![Int]-    f t = case t of MkT xs{strict} -> reverse xs--The `xs{strict}` indicates that `xs` is used strictly by the `reverse xs`.-If we do a w/w split, and add the extra eval on `xs`, we'll get--    $wf xs =-        case xs of xs1 ->-            let t = MkT xs1 in-            case t of MkT xs2 -> reverse xs2--That's not wrong; but the w/w body will simplify to--    $wf xs = case xs of xs1 -> reverse xs1--and now we'll drop the `case xs` because `xs1` is used strictly in its scope.-Adding that eval was a waste of time.  So don't add it for strictly-demanded Ids.--5) Functions--Functions are tricky (see Note [TagInfo of functions] in InferTags).-But the gist of it even if we make a higher order function argument strict-we can't avoid the tag check when it's used later in the body.-So there is no benefit.---}--- | Do we expect there to be any benefit if we make this var strict--- in order for it to get treated as as cbv argument?--- See Note [Which Ids should be strictified]--- See Note [CBV Function Ids] for more background.-shouldStrictifyIdForCbv :: Var -> Bool-shouldStrictifyIdForCbv = wantCbvForId False---- Like shouldStrictifyIdForCbv but also wants to use cbv for strict args.-shouldUseCbvForId :: Var -> Bool-shouldUseCbvForId = wantCbvForId True---- When we strictify we want to skip strict args otherwise the logic is the same--- as for shouldUseCbvForId so we common up the logic here.--- Basically returns true if it would be benefitial for runtime to pass this argument--- as CBV independent of weither or not it's correct. E.g. it might return true for lazy args--- we are not allowed to force.-wantCbvForId :: Bool -> Var -> Bool-wantCbvForId cbv_for_strict v-  -- Must be a runtime var.-  -- See Note [Which Ids should be strictified] point 1)-  | isId v-  , not $ isZeroBitTy ty-  -- Unlifted things don't need special measures to be treated as cbv-  -- See Note [Which Ids should be strictified] point 2)-  , mightBeLiftedType ty-  -- Functions sometimes get a zero tag so we can't eliminate the tag check.-  -- See Note [TagInfo of functions] in InferTags.-  -- See Note [Which Ids should be strictified] point 5)-  , not $ isFunTy ty-  -- If the var is strict already a seq is redundant.-  -- See Note [Which Ids should be strictified] point 4)-  , not (isStrictDmd dmd) || cbv_for_strict-  -- If the var is absent a seq is almost always useless.-  -- See Note [Which Ids should be strictified] point 3)-  , not (isAbsDmd dmd)-  = True-  | otherwise-  = False-  where-    ty = idType v-    dmd = idDemandInfo v--{- *********************************************************************-*                                                                      *-             unsafeEqualityProof-*                                                                      *-********************************************************************* -}--isUnsafeEqualityProof :: CoreExpr -> Bool--- See (U3) and (U4) in--- Note [Implementing unsafeCoerce] in base:Unsafe.Coerce-isUnsafeEqualityProof e-  | Var v `App` Type _ `App` Type _ `App` Type _ <- e-  = v `hasKey` unsafeEqualityProofIdKey-  | otherwise-  = False+        bindNonRec, needsCaseBinding, needsCaseBindingL,+        mkAltExpr, mkDefaultCase, mkSingleAltCase,++        -- * Taking expressions apart+        findDefault, addDefault, findAlt, isDefaultAlt,+        mergeAlts, mergeCaseAlts, trimConArgs,+        filterAlts, combineIdenticalAlts, refineDefaultAlt,+        scaleAltsBy,++        -- * Properties of expressions+        exprType, coreAltType, coreAltsType,+        mkLamType, mkLamTypes,+        mkFunctionType,+        exprIsTrivial, getIdFromTrivialExpr, getIdFromTrivialExpr_maybe,+        trivial_expr_fold,+        exprIsDupable, exprIsCheap, exprIsExpandable, exprIsCheapX, CheapAppFun,+        exprIsHNF, exprOkForSpeculation, exprOkToDiscard, exprOkForSpecEval,+        exprIsWorkFree, exprIsConLike,+        isCheapApp, isExpandableApp, isSaturatedConApp,+        exprIsTickedString, exprIsTickedString_maybe,+        exprIsTopLevelBindable,+        exprIsUnaryClassFun, isUnaryClassId,+        altsAreExhaustive, etaExpansionTick,++        -- * Equality+        cheapEqExpr, cheapEqExpr', diffBinds,++        -- * Manipulating data constructors and types+        exprToType,+        applyTypeToArgs,+        dataConRepInstPat, dataConRepFSInstPat,+        isEmptyTy, normSplitTyConApp_maybe,++        -- * Working with ticks+        stripTicksTop, stripTicksTopE, stripTicksTopT,+        stripTicksE, stripTicksT,++        -- * InScopeSet things which work over CoreBinds+        mkInScopeSetBndrs, extendInScopeSetBind, extendInScopeSetBndrs,++        -- * StaticPtr+        collectMakeStaticArgs,++        -- * Join points+        isJoinBind,++        -- * Tag inference+        mkStrictFieldSeqs, shouldStrictifyIdForCbv, shouldUseCbvForId,++        -- * unsafeEqualityProof+        isUnsafeEqualityCase,++        -- * Dumping stuff+        dumpIdInfoOfProgram+    ) where++import GHC.Prelude+import GHC.Platform++import GHC.Core+import GHC.Core.Ppr+import GHC.Core.FVs( bindFreeVars )+import GHC.Core.DataCon+import GHC.Core.Type as Type+import GHC.Core.Predicate( isEqPred )+import GHC.Core.Predicate( isUnaryClass )+import GHC.Core.FamInstEnv+import GHC.Core.TyCo.Compare( eqType, eqTypeX )+import GHC.Core.Coercion+import GHC.Core.Reduction+import GHC.Core.TyCon+import GHC.Core.Multiplicity++import GHC.Builtin.Names ( makeStaticName, unsafeEqualityProofIdKey, unsafeReflDataConKey )+import GHC.Builtin.PrimOps++import GHC.Types.Var+import GHC.Types.SrcLoc+import GHC.Types.Var.Env+import GHC.Types.Var.Set+import GHC.Types.Name+import GHC.Types.Literal+import GHC.Types.Tickish+import GHC.Types.Id+import GHC.Types.Id.Info+import GHC.Types.Basic( Arity )+import GHC.Types.Unique+import GHC.Types.Unique.Set+import GHC.Types.Demand+import GHC.Types.RepType (isZeroBitTy)++import GHC.Data.FastString+import GHC.Data.Maybe+import GHC.Data.List.SetOps( minusList )+import GHC.Data.OrdList++import GHC.Utils.Constants (debugIsOn)+import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Utils.Misc++import Data.ByteString     ( ByteString )+import Data.Function       ( on )+import Data.List           ( sort, sortBy, partition, zipWith4, mapAccumL )+import qualified Data.List as Partial ( init, last )+import Data.Ord            ( comparing )+import Control.Monad       ( guard )+import qualified Data.Set as Set++{-+************************************************************************+*                                                                      *+\subsection{Find the type of a Core atom/expression}+*                                                                      *+************************************************************************+-}++exprType :: HasDebugCallStack => CoreExpr -> Type+-- ^ Recover the type of a well-typed Core expression. Fails when+-- applied to the actual 'GHC.Core.Type' expression as it cannot+-- really be said to have a type+exprType (Var var)           = idType var+exprType (Lit lit)           = literalType lit+exprType (Coercion co)       = coercionType co+exprType (Let bind body)+  | NonRec tv rhs <- bind    -- See Note [Type bindings]+  , Type ty <- rhs           = substTyWithUnchecked [tv] [ty] (exprType body)+  | otherwise                = exprType body+exprType (Case _ _ ty _)     = ty+exprType (Cast _ co)         = coercionRKind co+exprType (Tick _ e)          = exprType e+exprType (Lam binder expr)   = mkLamType binder (exprType expr)+exprType e@(App _ _)+  = case collectArgs e of+        (fun, args) -> applyTypeToArgs (exprType fun) args+exprType (Type ty) = pprPanic "exprType" (ppr ty)++coreAltType :: CoreAlt -> Type+-- ^ Returns the type of the alternatives right hand side+coreAltType alt@(Alt _ bs rhs)+  = case occCheckExpand bs rhs_ty of+      -- Note [Existential variables and silly type synonyms]+      Just ty -> ty+      Nothing -> pprPanic "coreAltType" (pprCoreAlt alt $$ ppr rhs_ty)+  where+    rhs_ty = exprType rhs++coreAltsType :: [CoreAlt] -> Type+-- ^ Returns the type of the first alternative, which should be the same as for all alternatives+coreAltsType (alt:_) = coreAltType alt+coreAltsType []      = panic "coreAltsType"++mkLamType  :: HasDebugCallStack => Var -> Type -> Type+-- ^ Makes a @(->)@ type or an implicit forall type, depending+-- on whether it is given a type variable or a term variable.+-- This is used, for example, when producing the type of a lambda.+--+mkLamTypes :: [Var] -> Type -> Type+-- ^ 'mkLamType' for multiple type or value arguments++mkLamType v body_ty+   | isTyVar v+   = mkForAllTy (Bndr v coreTyLamForAllTyFlag) body_ty+     -- coreTyLamForAllTyFlag: see Note [Required foralls in Core]+     --                        in GHC.Core.TyCo.Rep++   | isCoVar v+   , v `elemVarSet` tyCoVarsOfType body_ty+     -- See Note [Unused coercion variable in ForAllTy] in GHC.Core.TyCo.Rep+   = mkForAllTy (Bndr v coreTyLamForAllTyFlag) body_ty++   | otherwise+   = mkFunctionType (idMult v) (idType v) body_ty++mkLamTypes vs ty = foldr mkLamType ty vs++{-+Note [Type bindings]+~~~~~~~~~~~~~~~~~~~~+Core does allow type bindings, although such bindings are+not much used, except in the output of the desugarer.+Example:+     let a = Int in (\x:a. x)+Given this, exprType must be careful to substitute 'a' in the+result type (#8522).++Note [Existential variables and silly type synonyms]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+        data T = forall a. T (Funny a)+        type Funny a = Bool+        f :: T -> Bool+        f (T x) = x++Now, the type of 'x' is (Funny a), where 'a' is existentially quantified.+That means that 'exprType' and 'coreAltsType' may give a result that *appears*+to mention an out-of-scope type variable.  See #3409 for a more real-world+example.++Various possibilities suggest themselves:++ - Ignore the problem, and make Lint not complain about such variables++ - Expand all type synonyms (or at least all those that discard arguments)+      This is tricky, because at least for top-level things we want to+      retain the type the user originally specified.++ - Expand synonyms on the fly, when the problem arises. That is what+   we are doing here.  It's not too expensive, I think.++Note that there might be existentially quantified coercion variables, too.+-}++applyTypeToArgs :: HasDebugCallStack => Type -> [CoreExpr] -> Type+-- ^ Determines the type resulting from applying an expression with given type+--- to given argument expressions.+applyTypeToArgs op_ty args+  = go op_ty args+  where+    go op_ty []                   = op_ty+    go op_ty (Type ty : args)     = go_ty_args op_ty [ty] args+    go op_ty (Coercion co : args) = go_ty_args op_ty [mkCoercionTy co] args+    go op_ty (_ : args)           | Just (_, _, _, res_ty) <- splitFunTy_maybe op_ty+                                  = go res_ty args+    go _ args = pprPanic "applyTypeToArgs" (panic_msg args)++    -- go_ty_args: accumulate type arguments so we can+    -- instantiate all at once with piResultTys+    go_ty_args op_ty rev_tys (Type ty : args)+       = go_ty_args op_ty (ty:rev_tys) args+    go_ty_args op_ty rev_tys (Coercion co : args)+       = go_ty_args op_ty (mkCoercionTy co : rev_tys) args+    go_ty_args op_ty rev_tys args+       = go (piResultTys op_ty (reverse rev_tys)) args++    panic_msg as = vcat [ text "Type:" <+> ppr op_ty+                        , text "Args:" <+> ppr args+                        , text "Args':" <+> ppr as ]++mkCastMCo :: CoreExpr -> MCoercionR -> CoreExpr+mkCastMCo e MRefl    = e+mkCastMCo e (MCo co) = Cast e co+  -- We are careful to use (MCo co) only when co is not reflexive+  -- Hence (Cast e co) rather than (mkCast e co)++mkPiMCo :: Var -> MCoercionR -> MCoercionR+mkPiMCo _  MRefl   = MRefl+mkPiMCo v (MCo co) = MCo (mkPiCo Representational v co)+++{- *********************************************************************+*                                                                      *+             Casts+*                                                                      *+********************************************************************* -}++-- | Wrap the given expression in the coercion safely, dropping+-- identity coercions and coalescing nested coercions+mkCast :: HasDebugCallStack => CoreExpr -> CoercionR -> CoreExpr++mkCast expr co+  = assertPpr (coercionRole co == Representational)+              (text "coercion" <+> ppr co <+> text "passed to mkCast"+               <+> ppr expr <+> text "has wrong role" <+> ppr (coercionRole co)) $+    warnPprTrace (not (coercionLKind co `eqType` exprType expr))+          "Trying to coerce" (text "(" <> ppr expr+          $$ text "::" <+> ppr (exprType expr) <> text ")"+          $$ ppr co $$ ppr (coercionType co)+          $$ callStackDoc) $+    case expr of+      Cast expr co2 -> mkCast expr (mkTransCo co2 co)+      Tick t expr   -> Tick t (mkCast expr co)++      Coercion e_co | isEqPred (coercionRKind co)+         -- The guard here checks that g has a (~#) on both sides,+         -- otherwise decomposeCo fails.  Can in principle happen+         -- with unsafeCoerce+                      -> Coercion (mkCoCast e_co co)++      _ | isReflCo co -> expr+        | otherwise   -> Cast expr co+++{- *********************************************************************+*                                                                      *+             Attaching ticks+*                                                                      *+********************************************************************* -}++-- | Wraps the given expression in the source annotation, dropping the+-- annotation if possible.+mkTick :: CoreTickish -> CoreExpr -> CoreExpr+mkTick t orig_expr = mkTick' id id orig_expr+ where+  -- Some ticks (cost-centres) can be split in two, with the+  -- non-counting part having laxer placement properties.+  canSplit = tickishCanSplit t && tickishPlace (mkNoCount t) /= tickishPlace t+  -- mkTick' handles floating of ticks *into* the expression.+  -- In this function, `top` is applied after adding the tick, and `rest` before.+  -- This will result in applications that look like (top $ Tick t $ rest expr).+  -- If we want to push the tick deeper, we pre-compose `top` with a function+  -- adding the tick.+  mkTick' :: (CoreExpr -> CoreExpr) -- apply after adding tick (float through)+          -> (CoreExpr -> CoreExpr) -- apply before adding tick (float with)+          -> CoreExpr               -- current expression+          -> CoreExpr+  mkTick' top rest expr = case expr of+    -- Float ticks into unsafe coerce the same way we would do with a cast.+    Case scrut bndr ty alts@[Alt ac abs _rhs]+      | Just rhs <- isUnsafeEqualityCase scrut bndr alts+      -> top $ mkTick' (\e -> Case scrut bndr ty [Alt ac abs e]) rest rhs++    -- Cost centre ticks should never be reordered relative to each+    -- other. Therefore we can stop whenever two collide.+    Tick t2 e+      | ProfNote{} <- t2, ProfNote{} <- t -> top $ Tick t $ rest expr++    -- Otherwise we assume that ticks of different placements float+    -- through each other.+      | tickishPlace t2 /= tickishPlace t -> mkTick' (top . Tick t2) rest e++    -- For annotations this is where we make sure to not introduce+    -- redundant ticks.+      | tickishContains t t2              -> mkTick' top rest e+      | tickishContains t2 t              -> orig_expr+      | otherwise                         -> mkTick' top (rest . Tick t2) e++    -- Ticks don't care about types, so we just float all ticks+    -- through them. Note that it's not enough to check for these+    -- cases top-level. While mkTick will never produce Core with type+    -- expressions below ticks, such constructs can be the result of+    -- unfoldings. We therefore make an effort to put everything into+    -- the right place no matter what we start with.+    Cast e co   -> mkTick' (top . flip Cast co) rest e+    Coercion co -> Coercion co++    Lam x e+      -- Always float through type lambdas. Even for non-type lambdas,+      -- floating is allowed for all but the most strict placement rule.+      | not (isRuntimeVar x) || tickishPlace t /= PlaceRuntime+      -> mkTick' (top . Lam x) rest e++      -- If it is both counting and scoped, we split the tick into its+      -- two components, often allowing us to keep the counting tick on+      -- the outside of the lambda and push the scoped tick inside.+      -- The point of this is that the counting tick can probably be+      -- floated, and the lambda may then be in a position to be+      -- beta-reduced.+      | canSplit+      -> top $ Tick (mkNoScope t) $ rest $ Lam x $ mkTick (mkNoCount t) e++    App f arg+      -- Always float through type applications.+      | not (isRuntimeArg arg)+      -> mkTick' (top . flip App arg) rest f++      -- We can also float through constructor applications, placement+      -- permitting. Again we can split.+      | isSaturatedConApp expr && (tickishPlace t==PlaceCostCentre || canSplit)+      -> if tickishPlace t == PlaceCostCentre+         then top $ rest $ tickHNFArgs t expr+         else top $ Tick (mkNoScope t) $ rest $ tickHNFArgs (mkNoCount t) expr++    Var x+      | notFunction && tickishPlace t == PlaceCostCentre+      -> orig_expr+      | notFunction && canSplit+      -> top $ Tick (mkNoScope t) $ rest expr+      where+        -- SCCs can be eliminated on variables provided the variable+        -- is not a function.  In these cases the SCC makes no difference:+        -- the cost of evaluating the variable will be attributed to its+        -- definition site.  When the variable refers to a function, however,+        -- an SCC annotation on the variable affects the cost-centre stack+        -- when the function is called, so we must retain those.+        notFunction = not (isFunTy (idType x))++    Lit{}+      | tickishPlace t == PlaceCostCentre+      -> orig_expr++    -- Catch-all: Annotate where we stand+    _any -> top $ Tick t $ rest expr++mkTicks :: [CoreTickish] -> CoreExpr -> CoreExpr+mkTicks ticks expr = foldr mkTick expr ticks++isSaturatedConApp :: CoreExpr -> Bool+isSaturatedConApp e = go e []+  where go (App f a) as = go f (a:as)+        go (Var fun) args+           = isConLikeId fun && idArity fun == valArgCount args+        go (Cast f _) as = go f as+        go _ _ = False++mkTickNoHNF :: CoreTickish -> CoreExpr -> CoreExpr+mkTickNoHNF t e+  | exprIsHNF e = tickHNFArgs t e+  | otherwise   = mkTick t e++-- push a tick into the arguments of a HNF (call or constructor app)+tickHNFArgs :: CoreTickish -> CoreExpr -> CoreExpr+tickHNFArgs t e = push t e+ where+  push t (App f (Type u)) = App (push t f) (Type u)+  push t (App f arg) = App (push t f) (mkTick t arg)+  push _t e = e++-- | Strip ticks satisfying a predicate from top of an expression+stripTicksTop :: (CoreTickish -> Bool) -> Expr b -> ([CoreTickish], Expr b)+stripTicksTop p = go []+  where go ts (Tick t e) | p t = go (t:ts) e+        go ts other            = (reverse ts, other)++-- | Strip ticks satisfying a predicate from top of an expression,+-- returning the remaining expression+stripTicksTopE :: (CoreTickish -> Bool) -> Expr b -> Expr b+stripTicksTopE p = go+  where go (Tick t e) | p t = go e+        go other            = other++-- | Strip ticks satisfying a predicate from top of an expression,+-- returning the ticks+stripTicksTopT :: (CoreTickish -> Bool) -> Expr b -> [CoreTickish]+stripTicksTopT p = go []+  where go ts (Tick t e) | p t = go (t:ts) e+        go ts _                = ts++-- | Completely strip ticks satisfying a predicate from an+-- expression. Note this is O(n) in the size of the expression!+stripTicksE :: (CoreTickish -> Bool) -> Expr b -> Expr b+stripTicksE p expr = go expr+  where go (App e a)        = App (go e) (go a)+        go (Lam b e)        = Lam b (go e)+        go (Let b e)        = Let (go_bs b) (go e)+        go (Case e b t as)  = Case (go e) b t (map go_a as)+        go (Cast e c)       = Cast (go e) c+        go (Tick t e)+          | p t             = go e+          | otherwise       = Tick t (go e)+        go other            = other+        go_bs (NonRec b e)  = NonRec b (go e)+        go_bs (Rec bs)      = Rec (map go_b bs)+        go_b (b, e)         = (b, go e)+        go_a (Alt c bs e)   = Alt c bs (go e)++stripTicksT :: (CoreTickish -> Bool) -> Expr b -> [CoreTickish]+stripTicksT p expr = fromOL $ go expr+  where go (App e a)        = go e `appOL` go a+        go (Lam _ e)        = go e+        go (Let b e)        = go_bs b `appOL` go e+        go (Case e _ _ as)  = go e `appOL` concatOL (map go_a as)+        go (Cast e _)       = go e+        go (Tick t e)+          | p t             = t `consOL` go e+          | otherwise       = go e+        go _                = nilOL+        go_bs (NonRec _ e)  = go e+        go_bs (Rec bs)      = concatOL (map go_b bs)+        go_b (_, e)         = go e+        go_a (Alt _ _ e)    = go e++{-+************************************************************************+*                                                                      *+\subsection{Other expression construction}+*                                                                      *+************************************************************************+-}++bindNonRec :: HasDebugCallStack => Id -> CoreExpr -> CoreExpr -> CoreExpr+-- ^ @bindNonRec x r b@ produces either:+--+-- > let x = r in b+--+-- or:+--+-- > case r of x { _DEFAULT_ -> b }+--+-- depending on whether we have to use a @case@ or @let@+-- binding for the expression (see 'needsCaseBinding').+-- It's used by the desugarer to avoid building bindings+-- that give Core Lint a heart attack, although actually+-- the simplifier deals with them perfectly well. See+-- also 'GHC.Core.Make.mkCoreLet'+bindNonRec bndr rhs body+  | isTyVar bndr                       = let_bind+  | isCoVar bndr                       = if isCoArg rhs then let_bind+    {- See Note [Binding coercions] -}                  else case_bind+  | isJoinId bndr                      = let_bind+  | needsCaseBinding (idType bndr) rhs = case_bind+  | otherwise                          = let_bind+  where+    case_bind = mkDefaultCase rhs bndr body+    let_bind  = Let (NonRec bndr rhs) body++-- | `needsCaseBinding` tests whether we have to use a @case@ rather than @let@+-- binding for this expression as per the invariants of 'CoreExpr': see+-- "GHC.Core#let_can_float_invariant"+-- (needsCaseBinding ty rhs) requires that `ty` has a well-defined levity, else+-- `typeLevity ty` will fail; but that should be the case because+-- `needsCaseBinding` is only called once typechecking is complete+needsCaseBinding :: HasDebugCallStack => Type -> CoreExpr -> Bool+needsCaseBinding ty rhs = needsCaseBindingL (typeLevity ty) rhs++needsCaseBindingL :: Levity -> CoreExpr -> Bool+-- True <=> make a case expression instead of a let+-- These can arise either from the desugarer,+-- or from beta reductions: (\x.e) (x +# y)+needsCaseBindingL Lifted   _rhs = False+needsCaseBindingL Unlifted rhs = not (exprOkForSpeculation rhs)++mkAltExpr :: AltCon     -- ^ Case alternative constructor+          -> [CoreBndr] -- ^ Things bound by the pattern match+          -> [Type]     -- ^ The type arguments to the case alternative+          -> CoreExpr+-- ^ This guy constructs the value that the scrutinee must have+-- given that you are in one particular branch of a case+mkAltExpr (DataAlt con) args inst_tys+  = mkConApp con (map Type inst_tys ++ varsToCoreExprs args)+mkAltExpr (LitAlt lit) [] []+  = Lit lit+mkAltExpr (LitAlt _) _ _ = panic "mkAltExpr LitAlt"+mkAltExpr DEFAULT _ _ = panic "mkAltExpr DEFAULT"++mkDefaultCase :: CoreExpr -> Id -> CoreExpr -> CoreExpr+-- Make (case x of y { DEFAULT -> e }+mkDefaultCase scrut case_bndr body+  = Case scrut case_bndr (exprType body) [Alt DEFAULT [] body]++mkSingleAltCase :: CoreExpr -> Id -> AltCon -> [Var] -> CoreExpr -> CoreExpr+-- Use this function if possible, when building a case,+-- because it ensures that the type on the Case itself+-- doesn't mention variables bound by the case+-- See Note [Care with the type of a case expression]+mkSingleAltCase scrut case_bndr con bndrs body+  = Case scrut case_bndr case_ty [Alt con bndrs body]+  where+    body_ty = exprType body++    case_ty -- See Note [Care with the type of a case expression]+      | Just body_ty' <- occCheckExpand bndrs body_ty+      = body_ty'++      | otherwise+      = pprPanic "mkSingleAltCase" (ppr scrut $$ ppr bndrs $$ ppr body_ty)++{- Note [Care with the type of a case expression]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider a phantom type synonym+   type S a = Int+and we want to form the case expression+   case x of K (a::*) -> (e :: S a)++We must not make the type field of the case-expression (S a) because+'a' isn't in scope.  Hence the call to occCheckExpand.  This caused+issue #17056.++NB: this situation can only arise with type synonyms, which can+falsely "mention" type variables that aren't "really there", and which+can be eliminated by expanding the synonym.++Note [Binding coercions]+~~~~~~~~~~~~~~~~~~~~~~~~+Consider binding a CoVar, c = e.  Then, we must satisfy+Note [Core type and coercion invariant] in GHC.Core,+which allows only (Coercion co) on the RHS.++************************************************************************+*                                                                      *+               Operations over case alternatives+*                                                                      *+************************************************************************++The default alternative must be first, if it exists at all.+This makes it easy to find, though it makes matching marginally harder.+-}++-- | Extract the default case alternative+findDefault :: [Alt b] -> ([Alt b], Maybe (Expr b))+findDefault (Alt DEFAULT args rhs : alts) = assert (null args) (alts, Just rhs)+findDefault alts                          =                    (alts, Nothing)++addDefault :: [Alt b] -> Maybe (Expr b) -> [Alt b]+addDefault alts Nothing    = alts+addDefault alts (Just rhs) = Alt DEFAULT [] rhs : alts++isDefaultAlt :: Alt b -> Bool+isDefaultAlt (Alt DEFAULT _ _) = True+isDefaultAlt _                 = False++-- | Find the case alternative corresponding to a particular+-- constructor: panics if no such constructor exists+findAlt :: AltCon -> [Alt b] -> Maybe (Alt b)+    -- A "Nothing" result *is* legitimate+    -- See Note [Unreachable code]+findAlt con alts+  = case alts of+        (deflt@(Alt DEFAULT _ _):alts) -> go alts (Just deflt)+        _                              -> go alts Nothing+  where+    go []                     deflt = deflt+    go (alt@(Alt con1 _ _) : alts) deflt+      = case con `cmpAltCon` con1 of+          LT -> deflt   -- Missed it already; the alts are in increasing order+          EQ -> Just alt+          GT -> assert (not (con1 == DEFAULT)) $ go alts deflt++{- Note [Unreachable code]+~~~~~~~~~~~~~~~~~~~~~~~~~~+It is possible (although unusual) for GHC to find a case expression+that cannot match.  For example:++     data Col = Red | Green | Blue+     x = Red+     f v = case x of+              Red -> ...+              _ -> ...(case x of { Green -> e1; Blue -> e2 })...++Suppose that for some silly reason, x isn't substituted in the case+expression.  (Perhaps there's a NOINLINE on it, or profiling SCC stuff+gets in the way; cf #3118.)  Then the full-laziness pass might produce+this++     x = Red+     lvl = case x of { Green -> e1; Blue -> e2 })+     f v = case x of+             Red -> ...+             _ -> ...lvl...++Now if x gets inlined, we won't be able to find a matching alternative+for 'Red'.  That's because 'lvl' is unreachable.  So rather than crashing+we generate (error "Inaccessible alternative").++Similar things can happen (augmented by GADTs) when the Simplifier+filters down the matching alternatives in GHC.Core.Opt.Simplify.rebuildCase.+-}++---------------------------------+mergeCaseAlts :: Id -> [CoreAlt] -> Maybe ([CoreBind], [CoreAlt])+-- See Note [Merge Nested Cases]+mergeCaseAlts outer_bndr (Alt DEFAULT _ deflt_rhs : outer_alts)+  | Just (joins, inner_alts) <- go deflt_rhs+  = Just (joins, mergeAlts outer_alts inner_alts)+                -- NB: mergeAlts gives priority to the left+                --      case x of+                --        A -> e1+                --        DEFAULT -> case x of+                --                      A -> e2+                --                      B -> e3+                -- When we merge, we must ensure that e1 takes+                -- precedence over e2 as the value for A!+  where+    go :: CoreExpr -> Maybe ([CoreBind], [CoreAlt])++    -- Whizzo: we can merge!+    go (Case (Var inner_scrut_var) inner_bndr _ inner_alts)+       | inner_scrut_var == outer_bndr+       , not (inner_bndr == outer_bndr)   -- Avoid shadowing+       , let wrap_let rhs' = Let (NonRec inner_bndr (Var outer_bndr)) rhs'+                -- inner_bndr is never dead!  It's the scrutinee!+                -- The let is OK even for unboxed binders+                -- See Note [Merge Nested Cases] wrinkle (MC2)+             do_one (Alt con bndrs rhs)+               | any (== outer_bndr) bndrs = Nothing+               | otherwise                 = Just (Alt con bndrs (wrap_let rhs))+       = do { alts' <- mapM do_one inner_alts+            ; return ([], alts') }++    -- Deal with tagToEnum# See Note [Merge Nested Cases] wrinkle (MC3)+    go (App (App (Var f) (Type type_arg)) (Var v))+      | v == outer_bndr+      , Just TagToEnumOp <- isPrimOpId_maybe f+      , Just tc  <- tyConAppTyCon_maybe type_arg+      , Just (dc1:dcs) <- tyConDataCons_maybe tc   -- At least one data constructor+      , dcs `lengthAtMost` 3  -- Arbitrary+      = return ( [], mk_alts dc1 dcs)+      where+        mk_lit dc = mkLitIntUnchecked $ toInteger $ dataConTagZ dc+        mk_rhs dc = Var (dataConWorkId dc)+        mk_alts dc1 dcs =  Alt DEFAULT              [] (mk_rhs dc1)+                        : [Alt (LitAlt (mk_lit dc)) [] (mk_rhs dc) | dc <- dcs]++    -- Float out let/join bindings+    -- See Note [Merge Nested Cases] wrinkle (MC4)+    go (Let bind body)+      | null outer_alts || isJoinBind bind+      = do { (joins, alts) <- go body++             -- Check for capture; but only if we could otherwise do a merge+           ; let capture = outer_bndr `elem` bindersOf bind+                           || outer_bndr `elemVarSet` bindFreeVars bind+           ; guard (not capture)++           ; return (bind:joins, alts ) }+      | otherwise+      = Nothing++    -- We don't want ticks to get in the way; just push them inwards.+    -- (This happens when you add SourceTicks e.g. GHC.Num.Integer.integerLt#)+    go (Tick t body)+      = do { (joins, alts) <- go body+           ; return (joins, [Alt con bs (Tick t rhs) | Alt con bs rhs <- alts]) }++    go _ = Nothing++mergeCaseAlts _ _ = Nothing++---------------------------------+mergeAlts :: [Alt a] -> [Alt a] -> [Alt a]+-- ^ Merge alternatives preserving order; alternatives in+-- the first argument shadow ones in the second+mergeAlts [] as2 = as2+mergeAlts as1 [] = as1+mergeAlts (a1:as1) (a2:as2)+  = case a1 `cmpAlt` a2 of+        LT -> a1 : mergeAlts as1      (a2:as2)+        EQ -> a1 : mergeAlts as1      as2       -- Discard a2+        GT -> a2 : mergeAlts (a1:as1) as2+++---------------------------------+trimConArgs :: AltCon -> [CoreArg] -> [CoreArg]+-- ^ Given:+--+-- > case (C a b x y) of+-- >        C b x y -> ...+--+-- We want to drop the leading type argument of the scrutinee+-- leaving the arguments to match against the pattern++trimConArgs DEFAULT      args = assert (null args) []+trimConArgs (LitAlt _)   args = assert (null args) []+trimConArgs (DataAlt dc) args = dropList (dataConUnivTyVars dc) args++filterAlts :: TyCon                -- ^ Type constructor of scrutinee's type (used to prune possibilities)+           -> [Type]               -- ^ And its type arguments+           -> [AltCon]             -- ^ 'imposs_cons': constructors known to be impossible due to the form of the scrutinee+           -> [Alt b] -- ^ Alternatives+           -> ([AltCon], [Alt b])+             -- Returns:+             --  1. Constructors that will never be encountered by the+             --     *default* case (if any).  A superset of imposs_cons+             --  2. The new alternatives, trimmed by+             --        a) remove imposs_cons+             --        b) remove constructors which can't match because of GADTs+             --+             -- NB: the final list of alternatives may be empty:+             -- This is a tricky corner case.  If the data type has no constructors,+             -- which GHC allows, or if the imposs_cons covers all constructors (after taking+             -- account of GADTs), then no alternatives can match.+             --+             -- If callers need to preserve the invariant that there is always at least one branch+             -- in a "case" statement then they will need to manually add a dummy case branch that just+             -- calls "error" or similar.+filterAlts _tycon inst_tys imposs_cons alts+  = imposs_deflt_cons `seqList`+      (imposs_deflt_cons, addDefault trimmed_alts maybe_deflt)+  -- Very important to force `imposs_deflt_cons` as that forces `alt_cons`, which+  -- is essentially as retaining `alts_wo_default` or any `Alt b` for that matter+  -- leads to a huge space leak (see #22102 and !8896)+  where+    (alts_wo_default, maybe_deflt) = findDefault alts+    alt_cons = [con | Alt con _ _ <- alts_wo_default]++    trimmed_alts = filterOut (impossible_alt inst_tys) alts_wo_default++    imposs_cons_set = Set.fromList imposs_cons+    imposs_deflt_cons =+      imposs_cons ++ filterOut (`Set.member` imposs_cons_set) alt_cons+         -- "imposs_deflt_cons" are handled+         --   EITHER by the context,+         --   OR by a non-DEFAULT branch in this case expression.++    impossible_alt :: [Type] -> Alt b -> Bool+    impossible_alt _ (Alt con _ _) | con `Set.member` imposs_cons_set = True+    impossible_alt inst_tys (Alt (DataAlt con) _ _) = dataConCannotMatch inst_tys con+    impossible_alt _  _                             = False++-- | Refine the default alternative to a 'DataAlt', if there is a unique way to do so.+-- See Note [Refine DEFAULT case alternatives]+refineDefaultAlt :: [Unique]          -- ^ Uniques for constructing new binders+                 -> Mult              -- ^ Multiplicity annotation of the case expression+                 -> TyCon             -- ^ Type constructor of scrutinee's type+                 -> [Type]            -- ^ Type arguments of scrutinee's type+                 -> [AltCon]          -- ^ Constructors that cannot match the DEFAULT (if any)+                 -> [CoreAlt]+                 -> (Bool, [CoreAlt]) -- ^ 'True', if a default alt was replaced with a 'DataAlt'+refineDefaultAlt us mult tycon tys imposs_deflt_cons all_alts+  | Alt DEFAULT _ rhs : rest_alts <- all_alts+  , isAlgTyCon tycon            -- It's a data type, tuple, or unboxed tuples.+  , not (isNewTyCon tycon)      -- Exception 1 in Note [Refine DEFAULT case alternatives]+  , not (isTypeDataTyCon tycon) -- Exception 2 in Note [Refine DEFAULT case alternatives]+  , Just all_cons <- tyConDataCons_maybe tycon+  , let imposs_data_cons = mkUniqSet [con | DataAlt con <- imposs_deflt_cons]+                             -- We now know it's a data type, so we can use+                             -- UniqSet rather than Set (more efficient)+        impossible con   = con `elementOfUniqSet` imposs_data_cons+                             || dataConCannotMatch tys con+  = case filterOut impossible all_cons of+       -- Eliminate the default alternative+       -- altogether if it can't match:+       []    -> (False, rest_alts)++       -- It matches exactly one constructor, so fill it in:+       [con] -> (True, mergeAlts rest_alts [Alt (DataAlt con) (ex_tvs ++ arg_ids) rhs])+                       -- We need the mergeAlts to keep the alternatives in the right order+             where+                (ex_tvs, arg_ids) = dataConRepInstPat us mult con tys++       -- It matches more than one, so do nothing+       _  -> (False, all_alts)++  | debugIsOn, isAlgTyCon tycon, null (tyConDataCons tycon)+  , not (isFamilyTyCon tycon || isAbstractTyCon tycon)+        -- Check for no data constructors+        -- This can legitimately happen for abstract types and type families,+        -- so don't report that+  = (False, all_alts)++  | otherwise      -- The common case+  = (False, all_alts)++{- Note [Merge Nested Cases]+~~~~~~~~~~~~~~~~~~~~~~~~~+       case e of b {             ==>   case e of b {+         p1 -> rhs1                      p1 -> rhs1+         ...                             ...+         pm -> rhsm                      pm -> rhsm+         _  -> case b of b' {            pn -> let b'=b in rhsn+                     pn -> rhsn          ...+                     ...                 po -> let b'=b in rhso+                     po -> rhso          _  -> let b'=b in rhsd+                     _  -> rhsd+       }++which merges two cases in one case when -- the default alternative of+the outer case scrutinises the same variable as the outer case. This+transformation is called Case Merging.  It avoids that the same+variable is scrutinised multiple times.++Wrinkles++(MC1) Historical note. I tried making `mergeCaseAlts` "looks though" an inner+     single-alternative case-on-variable. For example+       case x of {+          ...outer-alts...+          DEFAULT -> case y of (a,b) ->+                     case x of { A -> rhs1; B -> rhs2 }+    ===>+       case x of+         ...outer-alts...+         a -> case y of (a,b) -> rhs1+         B -> case y of (a,b) -> rhs2++    This duplicates the `case y` but it removes the case x; so it is a win+    in terms of execution time (combining the cases on x) at the cost of+    perhaps duplicating the `case y`.  A case in point is integerEq, which+    is defined thus+        integerEq :: Integer -> Integer -> Bool+        integerEq !x !y = isTrue# (integerEq# x y)+    which becomes+        integerEq+          = \ (x :: Integer) (y_aAL :: Integer) ->+              case x of x1 { __DEFAULT ->+              case y of y1 { __DEFAULT ->+              case x1 of {+                IS x2 -> case y1 of {+                           __DEFAULT -> GHC.Types.False;+                           IS y2     -> tagToEnum# @Bool (==# x2 y2) };+                IP x2 -> ...+                IN x2 -> ...+    We want to merge the outer `case x` with the inner `case x1`.++    But (a) this is all a bit dubious: see #24251, and+        (b) it is hard to combine with (MC4)+    So I'm not doing this any more.  If we want to do it, we'll handle it+    separately: #24251.++    End of historical note++(MC2) The auxiliary bindings b'=b are annoying, because they force another+      simplifier pass, but there seems no easy way to avoid them.  See+      Note [Which transformations are innocuous] in GHC.Core.Opt.Stats.++(MC3) Consider+         case f x of (r::Int#) -> tagToEnum# r :: Bool+      `mergeCaseAlts` as a special case to treat this as if it was+         case f x of r ->+           case r of { 0# -> False; 1# -> True }+      which can be merged to+         case f x of { 0# -> False; 1# -> True }++      To see why this is important, return to+         case f x of (r::Int#) -> tagToEnum# r :: Bool+      and supppose `f` inlines to a case expression.  Then then we get+         let $j r = tagToEnum# r+         case .. of { .. jump $j 0#; ...jump $j 1# ... }+      Now if the entire expression is consumed by another case-expression,+      that outer case will only see (tagToEnum# r) which it can't do much+      with.  Whereas the result of the above case-merge generates much better+      code: no branching on Int#++(MC4) Consider+          case f x of r ->+            join $j y = <rhs> in+            case r of { ...alts ... }+      This is pretty common, and it a pity for it to defeat the case-merge+      transformation; and it makes the optimiser fragile to inlining decisions+      for join points.++      So `mergeCaseAlts` floats out any join points. It doesn't float out+      non-join-points unless the /outer/ case has just one alternative; doing+      so would risk more allocation++(MC5) See Note [Cascading case merge]++See also Note [Example of case-merging and caseRules] in GHC.Core.Opt.Simplify.Utils+++Note [Cascading case merge]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Case merging should cascade in one sweep, because the Simplifier tries it /after/+simplifying (and hence case-merging) the inner case.  For example++      case e of a {+        DEFAULT -> case a of b+                      DEFAULT -> case b of c {+                                     DEFAULT -> e+                                     A -> ea+                      B -> eb+        C -> ec+==> {simplify inner case}+      case e of a {+        DEFAULT -> case a of b+                      DEFAULT -> let c = b in e+                      A -> let c = b in ea+                      B -> eb+        C -> ec+==> {case-merge on outer case}+      case e of a {+        DEFAULT -> let b = a in let c = b in e+        A -> let b = a in let c = b in ea+        B -> let b = a in eb+        C -> ec+++However here's a tricky case that we still don't catch, and I don't+see how to catch it in one pass:++  case x of c1 { I# a1 ->+  case a1 of c2 ->+    0 -> ...+    DEFAULT -> case x of c3 { I# a2 ->+               case a2 of ...++After occurrence analysis (and its binder-swap) we get this++  case x of c1 { I# a1 ->+  let x = c1 in         -- Binder-swap addition+  case a1 of c2 ->+    0 -> ...+    DEFAULT -> case x of c3 { I# a2 ->+               case a2 of ...++When we simplify the inner case x, we'll see that+x=c1=I# a1.  So we'll bind a2 to a1, and get++  case x of c1 { I# a1 ->+  case a1 of c2 ->+    0 -> ...+    DEFAULT -> case a1 of ...++This is correct, but we can't do a case merge in this sweep+because c2 /= a1.  Reason: the binding c1=I# a1 went inwards+without getting changed to c1=I# c2.++I don't think this is worth fixing, even if I knew how. It'll+all come out in the next pass anyway.+++Note [Refine DEFAULT case alternatives]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+refineDefaultAlt replaces the DEFAULT alt with a constructor if there+is one possible value it could be.++The simplest example being+    foo :: () -> ()+    foo x = case x of !_ -> ()+which rewrites to+    foo :: () -> ()+    foo x = case x of () -> ()++There are two reasons in general why replacing a DEFAULT alternative+with a specific constructor is desirable.++1. We can simplify inner expressions.  For example++       data Foo = Foo1 ()++       test :: Foo -> ()+       test x = case x of+                  DEFAULT -> mid (case x of+                                    Foo1 x1 -> x1)++   refineDefaultAlt fills in the DEFAULT here with `Foo ip1` and then+   x becomes bound to `Foo ip1` so is inlined into the other case+   which causes the KnownBranch optimisation to kick in. If we don't+   refine DEFAULT to `Foo ip1`, we are left with both case expressions.++2. combineIdenticalAlts does a better job. For example (Simon Jacobi)+       data D = C0 | C1 | C2++       case e of+         DEFAULT -> e0+         C0      -> e1+         C1      -> e1++   When we apply combineIdenticalAlts to this expression, it can't+   combine the alts for C0 and C1, as we already have a default case.+   But if we apply refineDefaultAlt first, we get+       case e of+         C0 -> e1+         C1 -> e1+         C2 -> e0+   and combineIdenticalAlts can turn that into+       case e of+         DEFAULT -> e1+         C2 -> e0++   It isn't obvious that refineDefaultAlt does this but if you look+   at its one call site in GHC.Core.Opt.Simplify.Utils then the+   `imposs_deflt_cons` argument is populated with constructors which+   are matched elsewhere.++There are two exceptions where we avoid refining a DEFAULT case:++* Exception 1: Newtypes++  We can have a newtype, if we are just doing an eval:++    case x of { DEFAULT -> e }++  And we don't want to fill in a default for them!++* Exception 2: `type data` declarations++  The data constructors for a `type data` declaration (see+  Note [Type data declarations] in GHC.Rename.Module) do not exist at the+  value level. Nevertheless, it is possible to strictly evaluate a value+  whose type is a `type data` declaration. Test case+  type-data/should_compile/T2294b.hs contains an example:++    type data T a where+      A :: T Int++    f :: T a -> ()+    f !x = ()++  We want to generate the following Core for f:++    f = \(@a) (x :: T a) ->+         case x of+           __DEFAULT -> ()++  Namely, we do _not_ want to match on `A`, as it doesn't exist at the value+  level! See wrinkle (W2b) in Note [Type data declarations] in GHC.Rename.Module+++Note [Combine identical alternatives]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If several alternatives are identical, merge them into a single+DEFAULT alternative.  I've occasionally seen this making a big+difference:++     case e of               =====>     case e of+       C _ -> f x                         D v -> ....v....+       D v -> ....v....                   DEFAULT -> f x+       DEFAULT -> f x++The point is that we merge common RHSs, at least for the DEFAULT case.+[One could do something more elaborate but I've never seen it needed.]+To avoid an expensive test, we just merge branches equal to the *first*+alternative; this picks up the common cases+     a) all branches equal+     b) some branches equal to the DEFAULT (which occurs first)++The case where Combine Identical Alternatives transformation showed up+was like this (base/Foreign/C/Err/Error.hs):++        x | p `is` 1 -> e1+          | p `is` 2 -> e2+        ...etc...++where @is@ was something like++        p `is` n = p /= (-1) && p == n++This gave rise to a horrible sequence of cases++        case p of+          (-1) -> $j p+          1    -> e1+          DEFAULT -> $j p++and similarly in cascade for all the join points!++Note [Combine identical alternatives: wrinkles]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++* It's important that we try to combine alternatives *before*+  simplifying them, rather than after. Reason: because+  Simplify.simplAlt may zap the occurrence info on the binders in the+  alternatives, which in turn defeats combineIdenticalAlts use of+  isDeadBinder (see #7360).++  You can see this in the call to combineIdenticalAlts in+  GHC.Core.Opt.Simplify.Utils.prepareAlts.  Here the alternatives have type InAlt+  (the "In" meaning input) rather than OutAlt.++* combineIdenticalAlts does not work well for nullary constructors+      case x of y+         []    -> f []+         (_:_) -> f y+  Here we won't see that [] and y are the same.  Sigh! This problem+  is solved in CSE, in GHC.Core.Opt.CSE.combineAlts, which does a better version+  of combineIdenticalAlts. But sadly it doesn't have the occurrence info we have+  here.+  See Note [Combine case alts: awkward corner] in GHC.Core.Opt.CSE).++Note [Care with impossible-constructors when combining alternatives]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have (#10538)+   data T = A | B | C | D++      case x::T of   (Imposs-default-cons {A,B})+         DEFAULT -> e1+         A -> e2+         B -> e1++When calling combineIdentialAlts, we'll have computed that the+"impossible constructors" for the DEFAULT alt is {A,B}, since if x is+A or B we'll take the other alternatives.  But suppose we combine B+into the DEFAULT, to get++      case x::T of   (Imposs-default-cons {A})+         DEFAULT -> e1+         A -> e2++Then we must be careful to trim the impossible constructors to just {A},+else we risk compiling 'e1' wrong!++Not only that, but we take care when there is no DEFAULT beforehand,+because we are introducing one.  Consider++   case x of   (Imposs-default-cons {A,B,C})+     A -> e1+     B -> e2+     C -> e1++Then when combining the A and C alternatives we get++   case x of   (Imposs-default-cons {B})+     DEFAULT -> e1+     B -> e2++Note that we have a new DEFAULT branch that we didn't have before.  So+we need delete from the "impossible-default-constructors" all the+known-con alternatives that we have eliminated. (In #11172 we+missed the first one.)++-}++combineIdenticalAlts :: [AltCon]    -- Constructors that cannot match DEFAULT+                     -> [CoreAlt]+                     -> (Bool,      -- True <=> something happened+                         [AltCon],  -- New constructors that cannot match DEFAULT+                         [CoreAlt]) -- New alternatives+-- See Note [Combine identical alternatives]+-- True <=> we did some combining, result is a single DEFAULT alternative+combineIdenticalAlts imposs_deflt_cons (Alt con1 bndrs1 rhs1 : rest_alts)+  | all isDeadBinder bndrs1    -- Remember the default+  , not (null elim_rest) -- alternative comes first+  = (True, imposs_deflt_cons', deflt_alt : filtered_rest)+  where+    (elim_rest, filtered_rest) = partition identical_to_alt1 rest_alts+    deflt_alt = Alt DEFAULT [] (mkTicks (concat tickss) rhs1)++     -- See Note [Care with impossible-constructors when combining alternatives]+    imposs_deflt_cons' = imposs_deflt_cons `minusList` elim_cons+    elim_cons = elim_con1 ++ map (\(Alt con _ _) -> con) elim_rest+    elim_con1 = case con1 of     -- Don't forget con1!+                  DEFAULT -> []+                  _       -> [con1]++    cheapEqTicked e1 e2 = cheapEqExpr' tickishFloatable e1 e2+    identical_to_alt1 (Alt _con bndrs rhs)+      = all isDeadBinder bndrs && rhs `cheapEqTicked` rhs1+    tickss = map (\(Alt _ _ rhs) -> stripTicksT tickishFloatable rhs) elim_rest++combineIdenticalAlts imposs_cons alts+  = (False, imposs_cons, alts)++-- Scales the multiplicity of the binders of a list of case alternatives. That+-- is, in [C x1…xn -> u], the multiplicity of x1…xn is scaled.+scaleAltsBy :: Mult -> [CoreAlt] -> [CoreAlt]+scaleAltsBy w alts = map scaleAlt alts+  where+    scaleAlt :: CoreAlt -> CoreAlt+    scaleAlt (Alt con bndrs rhs) = Alt con (map scaleBndr bndrs) rhs++    scaleBndr :: CoreBndr -> CoreBndr+    scaleBndr b = scaleVarBy w b+++{- *********************************************************************+*                                                                      *+             exprIsTrivial+*                                                                      *+************************************************************************++Note [exprIsTrivial]+~~~~~~~~~~~~~~~~~~~~+@exprIsTrivial@ is true of expressions we are unconditionally happy to+                duplicate; simple variables and constants, and type+                applications.  Note that primop Ids aren't considered+                trivial unless++Note [Variables are trivial]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There used to be a gruesome test for (hasNoBinding v) in the+Var case:+        exprIsTrivial (Var v) | hasNoBinding v = idArity v == 0+The idea here is that a constructor worker, like \$wJust, is+really short for (\x -> \$wJust x), because \$wJust has no binding.+So it should be treated like a lambda.  Ditto unsaturated primops.+But now constructor workers are not "have-no-binding" Ids.  And+completely un-applied primops and foreign-call Ids are sufficiently+rare that I plan to allow them to be duplicated and put up with+saturating them.++Note [Tick trivial]+~~~~~~~~~~~~~~~~~~~+Ticks are only trivial if they are pure annotations. If we treat+"tick<n> x" as trivial, it will be inlined inside lambdas and the+entry count will be skewed, for example.  Furthermore "scc<n> x" will+turn into just "x" in mkTick. At least if `x` is not a function.++Note [Empty case is trivial]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The expression (case (x::Int) Bool of {}) is just a type-changing+case used when we are sure that 'x' will not return.  See+Note [Empty case alternatives] in GHC.Core.++If the scrutinee is trivial, then so is the whole expression; and the+CoreToSTG pass in fact drops the case expression leaving only the+scrutinee.++Having more trivial expressions is good.  Moreover, if we don't treat+it as trivial we may land up with let-bindings like+   let v = case x of {} in ...+and after CoreToSTG that gives+   let v = x in ...+and that confuses the code generator (#11155). So best to kill+it off at source.+-}++{-# INLINE trivial_expr_fold #-}+trivial_expr_fold :: (Id -> r) -> (Literal -> r) -> r -> r -> CoreExpr -> r+-- ^ The worker function for Note [exprIsTrivial] and Note [getIdFromTrivialExpr]+-- This is meant to have the code of both functions in one place and make it+-- easy to derive custom predicates.+--+-- (trivial_expr_fold k_id k_triv k_not_triv e)+-- * returns (k_id x) if `e` is a variable `x` (with trivial wrapping)+-- * returns (k_lit x) if `e` is a trivial literal `l` (with trivial wrapping)+-- * returns k_triv if `e` is a literal, type, or coercion (with trivial wrapping)+-- * returns k_not_triv otherwise+--+-- where "trivial wrapping" is+-- * Type application or abstraction+-- * Ticks other than `tickishIsCode`+-- * `case e of {}` an empty case+trivial_expr_fold k_id k_lit k_triv k_not_triv = go+  where+    -- If you change this function, be sure to change+    -- SetLevels.notWorthFloating as well!+    -- (Or yet better: Come up with a way to share code with this function.)+    go (Var v)                            = k_id v  -- See Note [Variables are trivial]+    go (Lit l)    | litIsTrivial l        = k_lit l+    go (Type _)                           = k_triv+    go (Coercion _)                       = k_triv+    go (App f arg)+      | not (isRuntimeArg arg)            = go f+      | exprIsUnaryClassFun f             = go arg+      | otherwise                         = k_not_triv+    go (Lam b e)  | not (isRuntimeVar b)  = go e+    go (Tick t e) | not (tickishIsCode t) = go e              -- See Note [Tick trivial]+    go (Cast e _)                         = go e+    go (Case e b _ as)+      | null as+      = go e     -- See Note [Empty case is trivial]+      | Just rhs <- isUnsafeEqualityCase e b as+      = go rhs   -- See (U2) of Note [Implementing unsafeCoerce] in base:Unsafe.Coerce+    go _                                  = k_not_triv++exprIsTrivial :: CoreExpr -> Bool+exprIsTrivial e = trivial_expr_fold (const True) (const True) True False e++{-+Note [getIdFromTrivialExpr]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+When substituting in a breakpoint we need to strip away the type cruft+from a trivial expression and get back to the Id.  The invariant is+that the expression we're substituting was originally trivial+according to exprIsTrivial, AND the expression is not a literal.+See Note [substTickish] for how breakpoint substitution preserves+this extra invariant.++We also need this functionality in CorePrep to extract out Id of a+function which we are saturating.  However, in this case we don't know+if the variable actually refers to a literal; thus we use+'getIdFromTrivialExpr_maybe' to handle this case.  See test+T12076lit for an example where this matters.+-}++getIdFromTrivialExpr :: HasDebugCallStack => CoreExpr -> Id+-- See Note [getIdFromTrivialExpr]+getIdFromTrivialExpr e = trivial_expr_fold id (const panic) panic panic e+  where+    panic = pprPanic "getIdFromTrivialExpr" (ppr e)++getIdFromTrivialExpr_maybe :: CoreExpr -> Maybe Id+getIdFromTrivialExpr_maybe e = trivial_expr_fold Just (const Nothing) Nothing Nothing e++{- *********************************************************************+*                                                                      *+             exprIsDupable+*                                                                      *+************************************************************************++Note [exprIsDupable]+~~~~~~~~~~~~~~~~~~~~+@exprIsDupable@ is true of expressions that can be duplicated at a modest+                cost in code size.  This will only happen in different case+                branches, so there's no issue about duplicating work.++                That is, exprIsDupable returns True of (f x) even if+                f is very very expensive to call.++                Its only purpose is to avoid fruitless let-binding+                and then inlining of case join points+-}++exprIsDupable :: Platform -> CoreExpr -> Bool+exprIsDupable platform e+  = isJust (go dupAppSize e)+  where+    go :: Int -> CoreExpr -> Maybe Int+    go n (Type {})     = Just n+    go n (Coercion {}) = Just n+    go n (Var {})      = decrement n+    go n (Tick _ e)    = go n e+    go n (Cast e _)    = go n e+    go n (App f a) | Just n' <- go n a = go n' f+    go n (Lit lit) | litIsDupable platform lit = decrement n+    go _ _ = Nothing++    decrement :: Int -> Maybe Int+    decrement 0 = Nothing+    decrement n = Just (n-1)++dupAppSize :: Int+dupAppSize = 8   -- Size of term we are prepared to duplicate+                 -- This is *just* big enough to make test MethSharing+                 -- inline enough join points.  Really it should be+                 -- smaller, and could be if we fixed #4960.++{-+************************************************************************+*                                                                      *+             exprIsCheap, exprIsExpandable+*                                                                      *+************************************************************************++Note [exprIsWorkFree]+~~~~~~~~~~~~~~~~~~~~~+exprIsWorkFree is used when deciding whether to inline something; we+don't inline it if doing so might duplicate work, by peeling off a+complete copy of the expression.  Here we do not want even to+duplicate a primop (#5623):+   eg   let x = a #+ b in x +# x+   we do not want to inline/duplicate x++Previously we were a bit more liberal, which led to the primop-duplicating+problem.  However, being more conservative did lead to a big regression in+one nofib benchmark, wheel-sieve1.  The situation looks like this:++   let noFactor_sZ3 :: GHC.Types.Int -> GHC.Types.Bool+       noFactor_sZ3 = case s_adJ of _ { GHC.Types.I# x_aRs ->+         case GHC.Prim.<=# x_aRs 2 of _ {+           GHC.Types.False -> notDivBy ps_adM qs_adN;+           GHC.Types.True -> lvl_r2Eb }}+       go = \x. ...(noFactor (I# y))....(go x')...++The function 'noFactor' is heap-allocated and then called.  Turns out+that 'notDivBy' is strict in its THIRD arg, but that is invisible to+the caller of noFactor, which therefore cannot do w/w and+heap-allocates noFactor's argument.  At the moment (May 12) we are just+going to put up with this, because the previous more aggressive inlining+(which treated 'noFactor' as work-free) was duplicating primops, which+in turn was making inner loops of array calculations runs slow (#5623)++Note [Case expressions are work-free]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Are case-expressions work-free?  Consider+    let v = case x of (p,q) -> p+        go = \y -> ...case v of ...+Should we inline 'v' at its use site inside the loop?  At the moment+we do.  I experimented with saying that case are *not* work-free, but+that increased allocation slightly.  It's a fairly small effect, and at+the moment we go for the slightly more aggressive version which treats+(case x of ....) as work-free if the alternatives are.++Moreover it improves arities of overloaded functions where+there is only dictionary selection (no construction) involved++Note [exprIsCheap]+~~~~~~~~~~~~~~~~~~+See also Note [Interaction of exprIsWorkFree and lone variables] in GHC.Core.Unfold++@exprIsCheap@ looks at a Core expression and returns \tr{True} if+it is obviously in weak head normal form, or is cheap to get to WHNF.+Note that that's not the same as exprIsDupable; an expression might be+big, and hence not dupable, but still cheap.++By ``cheap'' we mean a computation we're willing to:+        push inside a lambda, or+        inline at more than one place+That might mean it gets evaluated more than once, instead of being+shared.  The main examples of things which aren't WHNF but are+``cheap'' are:++  *     case e of+          pi -> ei+        (where e, and all the ei are cheap)++  *     let x = e in b+        (where e and b are cheap)++  *     op x1 ... xn+        (where op is a cheap primitive operator)++  *     error "foo"+        (because we are happy to substitute it inside a lambda)++Notice that a variable is considered 'cheap': we can push it inside a lambda,+because sharing will make sure it is only evaluated once.++Note [exprIsCheap and exprIsHNF]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Note that exprIsHNF does not imply exprIsCheap.  Eg+        let x = fac 20 in Just x+This responds True to exprIsHNF (you can discard a seq), but+False to exprIsCheap.++Note [Arguments and let-bindings exprIsCheapX]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+What predicate should we apply to the argument of an application, or the+RHS of a let-binding?++We used to say "exprIsTrivial arg" due to concerns about duplicating+nested constructor applications, but see #4978.  So now we just recursively+use exprIsCheapX.++We definitely want to treat let and app the same.  The principle here is+that+   let x = blah in f x+should behave equivalently to+   f blah++This in turn means that the 'letrec g' does not prevent eta expansion+in this (which it previously was):+    f = \x. let v = case x of+                      True -> letrec g = \w. blah+                              in g+                      False -> \x. x+            in \w. v True+-}++-------------------------------------+type CheapAppFun = Id -> Arity -> Bool+  -- Is an application of this function to n *value* args+  -- always cheap, assuming the arguments are cheap?+  -- True mainly of data constructors, partial applications;+  -- but with minor variations:+  --    isWorkFreeApp+  --    isCheapApp+  --    isExpandableApp++exprIsCheapX :: CheapAppFun -> Bool -> CoreExpr -> Bool+{-# INLINE exprIsCheapX #-}+-- allow specialization of exprIsCheap, exprIsWorkFree and exprIsExpandable+-- instead of having an unknown call to ok_app+-- expandable=True <=> Treat Case and Let as cheap, if their sub-expressions are.+--                     This flag is set for exprIsExpandable+exprIsCheapX ok_app expandable e+  = ok e+  where+    ok e = go 0 e++    -- n is the number of value arguments+    go n (Var v)                      = ok_app v n+    go _ (Lit {})                     = True+    go _ (Type {})                    = True+    go _ (Coercion {})                = True+    go n (Cast e _)                   = go n e+    go n (Case scrut _ _ alts)        = not expandable && ok scrut &&+                                        and [ go n rhs | Alt _ _ rhs <- alts ]+    go n (Tick t e) | tickishCounts t = False+                    | otherwise       = go n e+    go n (Lam x e)  | isRuntimeVar x  = n==0 || go (n-1) e+                    | otherwise       = go n e+    go n (App f e)  | isRuntimeArg e  = go (n+1) f && ok e+                    | otherwise       = go n f+    go n (Let (NonRec _ r) e)         = not expandable && go n e && ok r+    go n (Let (Rec prs) e)            = not expandable && go n e && all (ok . snd) prs++      -- Case: see Note [Case expressions are work-free]+      -- App, Let: see Note [Arguments and let-bindings exprIsCheapX]++--------------------+exprIsWorkFree :: CoreExpr -> Bool+-- See Note [exprIsWorkFree]+exprIsWorkFree e = exprIsCheapX isWorkFreeApp False e++--------------------+exprIsCheap :: CoreExpr -> Bool+-- See Note [exprIsCheap]+exprIsCheap e = exprIsCheapX isCheapApp False e++--------------------+exprIsExpandable :: CoreExpr -> Bool+-- See Note [exprIsExpandable]+exprIsExpandable e = exprIsCheapX isExpandableApp True e++isWorkFreeApp :: CheapAppFun+isWorkFreeApp fn n_val_args+  | n_val_args == 0           -- No value args+  = True+  | n_val_args < idArity fn   -- Partial application+  = True+  | otherwise+  = case idDetails fn of+      DataConWorkId {} -> True+      PrimOpId op _    -> primOpIsWorkFree op+      _                -> False++isCheapApp :: CheapAppFun+isCheapApp fn n_val_args+  | isWorkFreeApp fn n_val_args = True+  | isDeadEndId fn              = True  -- See Note [isCheapApp: bottoming functions]+  | otherwise+  = case idDetails fn of+      -- DataConWorkId {} -> _  -- Handled by isWorkFreeApp+      RecSelId {}      -> n_val_args == 1  -- See Note [Record selection]+      ClassOpId {}     -> n_val_args == 1+      PrimOpId op _    -> primOpIsCheap op+      _                -> False+        -- In principle we should worry about primops+        -- that return a type variable, since the result+        -- might be applied to something, but I'm not going+        -- to bother to check the number of args++isExpandableApp :: CheapAppFun+isExpandableApp fn n_val_args+  | isWorkFreeApp fn n_val_args = True+  | otherwise+  = case idDetails fn of+      -- DataConWorkId {} -> _  -- Handled by isWorkFreeApp+      RecSelId {}  -> n_val_args == 1  -- See Note [Record selection]+      ClassOpId {} -> n_val_args == 1+      PrimOpId {}  -> False+      _ | isDeadEndId fn     -> False+          -- See Note [isExpandableApp: bottoming functions]+        | isConLikeId fn     -> True+        | all_args_are_preds -> True+        | otherwise          -> False++  where+     -- See if all the arguments are PredTys (implicit params or classes)+     -- If so we'll regard it as expandable; see Note [Expandable overloadings]+     all_args_are_preds = all_pred_args n_val_args (idType fn)++     all_pred_args n_val_args ty+       | n_val_args == 0+       = True++       | Just (bndr, ty) <- splitPiTy_maybe ty+       = case bndr of+           Named {}  -> all_pred_args n_val_args ty+           Anon _ af -> isInvisibleFunArg af && all_pred_args (n_val_args-1) ty++       | otherwise+       = False++{- Note [isCheapApp: bottoming functions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+I'm not sure why we have a special case for bottoming+functions in isCheapApp.  Maybe we don't need it.++Note [exprIsExpandable]+~~~~~~~~~~~~~~~~~~~~~~~+An expression is "expandable" if we are willing to duplicate it, if doing+so might make a RULE or case-of-constructor fire.  Consider+   let x = (a,b)+       y = build g+   in ....(case x of (p,q) -> rhs)....(foldr k z y)....++We don't inline 'x' or 'y' (see Note [Lone variables] in GHC.Core.Unfold),+but we do want++ * the case-expression to simplify+   (via exprIsConApp_maybe, exprIsLiteral_maybe)++ * the foldr/build RULE to fire+   (by expanding the unfolding during rule matching)++So we classify the unfolding of a let-binding as "expandable" (via the+uf_expandable field) if we want to do this kind of on-the-fly+expansion.  Specifically:++* True of constructor applications (K a b)++* True of applications of a "CONLIKE" Id; see Note [CONLIKE pragma] in GHC.Types.Basic.+  (NB: exprIsCheap might not be true of this)++* False of case-expressions.  If we have+    let x = case ... in ...(case x of ...)...+  we won't simplify.  We have to inline x.  See #14688.++* False of let-expressions (same reason); and in any case we+  float lets out of an RHS if doing so will reveal an expandable+  application (see SimplEnv.doFloatFromRhs).++* Take care: exprIsExpandable should /not/ be true of primops.  I+  found this in test T5623a:+    let q = /\a. Ptr a (a +# b)+    in case q @ Float of Ptr v -> ...q...++  q's inlining should not be expandable, else exprIsConApp_maybe will+  say that (q @ Float) expands to (Ptr a (a +# b)), and that will+  duplicate the (a +# b) primop, which we should not do lightly.+  (It's quite hard to trigger this bug, but T13155 does so for GHC 8.0.)++Note [isExpandableApp: bottoming functions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It's important that isExpandableApp does not respond True to bottoming+functions.  Recall  undefined :: HasCallStack => a+Suppose isExpandableApp responded True to (undefined d), and we had:++  x = undefined <dict-expr>++Then Simplify.prepareRhs would ANF the RHS:++  d = <dict-expr>+  x = undefined d++This is already bad: we gain nothing from having x bound to (undefined+var), unlike the case for data constructors.  Worse, we get the+simplifier loop described in OccurAnal Note [Cascading inlines].+Suppose x occurs just once; OccurAnal.occAnalNonRecRhs decides x will+certainly_inline; so we end up inlining d right back into x; but in+the end x doesn't inline because it is bottom (preInlineUnconditionally);+so the process repeats.. We could elaborate the certainly_inline logic+some more, but it's better just to treat bottoming bindings as+non-expandable, because ANFing them is a bad idea in the first place.++Note [Record selection]+~~~~~~~~~~~~~~~~~~~~~~~~~~+I'm experimenting with making record selection+look cheap, so we will substitute it inside a+lambda.  Particularly for dictionary field selection.++BUT: Take care with (sel d x)!  The (sel d) might be cheap, but+there's no guarantee that (sel d x) will be too.  Hence (n_val_args == 1)++Note [Expandable overloadings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose the user wrote this+   {-# RULE  forall x. foo (negate x) = h x #-}+   f x = ....(foo (negate x))....+They'd expect the rule to fire. But since negate is overloaded, we might+get this:+    f = \d -> let n = negate d in \x -> ...foo (n x)...+So we treat the application of a function (negate in this case) to a+*dictionary* as expandable.  In effect, every function is CONLIKE when+it's applied only to dictionaries.+-}++isUnaryClassId :: Id -> Bool+-- True of (a) the method selector (classop)+--         (b) the dictionary data constructor+-- of a unary class+isUnaryClassId v+  | Just cls <- isClassOpId_maybe v     = isUnaryClass cls+  | Just dc  <- isDataConWorkId_maybe v = isUnaryClassDataCon dc+  | otherwise                           = False++exprIsUnaryClassFun :: CoreExpr -> Bool+-- True of an a type application (f @t1 .. @tn),+-- where `f` is a unary-class-id+-- See (UCM4) in Note [Unary class magic] in GHC.Core.TyCon+exprIsUnaryClassFun (App f (Type {}))       = exprIsUnaryClassFun f+exprIsUnaryClassFun (Var v)                 = isUnaryClassId v+exprIsUnaryClassFun _                       = False+++{- *********************************************************************+*                                                                      *+             exprOkForSpeculation+*                                                                      *+********************************************************************* -}++-----------------------------+-- | To a first approximation, 'exprOkForSpeculation' returns True of+-- an expression that is:+--+--  * Safe to evaluate even if normal order eval might not+--    evaluate the expression at all, and+--+--  * Safe /not/ to evaluate even if normal order would do so+--+-- More specifically, this means that:+--  * A: Evaluation of the expression reaches weak-head-normal-form,+--  * B: soon,+--  * C: without causing a write side effect (e.g. writing a mutable variable).+--+-- In particular, an expression that may+--  * throw a synchronous Haskell exception, or+--  * risk an unchecked runtime exception (e.g. array+--    out of bounds, divide by zero)+-- is /not/ considered OK-for-speculation, as these violate condition A.+--+-- For 'exprOkToDiscard', condition A is weakened to allow expressions+-- that might risk an unchecked runtime exception but must otherwise+-- reach weak-head-normal-form.+-- (Note that 'exprOkForSpeculation' implies 'exprOkToDiscard')+--+-- But in fact both functions are a bit more conservative than the above,+-- in at least the following ways:+--+--  * W1: We do not take advantage of already-evaluated lifted variables.+--        As a result, 'exprIsHNF' DOES NOT imply 'exprOkForSpeculation';+--        if @y@ is a case-binder of lifted type, then @exprIsHNF y@ is+--        'True', while @exprOkForSpeculation y@ is 'False'.+--        See Note [exprOkForSpeculation and evaluated variables] for why.+--  * W2: Read-effects on mutable variables are currently also included.+--        See Note [Classifying primop effects] "GHC.Builtin.PrimOps".+--  * W3: Currently, 'exprOkForSpeculation' always returns 'False' for+--        let-expressions.  Lets can be stacked deeply, so we just give up.+--        In any case, the argument of 'exprOkForSpeculation' is usually in+--        a strict context, so any lets will have been floated away.+--+--+-- As an example of the considerations in this test, consider:+--+-- > let x = case y# +# 1# of { r# -> I# r# }+-- > in E+--+-- being translated to:+--+-- > case y# +# 1# of { r# ->+-- >    let x = I# r#+-- >    in E+-- > }+--+-- We can only do this if the @y# +# 1#@ is ok for speculation: it has no+-- side effects, and can't diverge or raise an exception.+--+--+-- See also Note [Classifying primop effects] in "GHC.Builtin.PrimOps"+-- and Note [Transformations affected by primop effects].+--+-- 'exprOkForSpeculation' is used to define Core's let-can-float+-- invariant.  (See Note [Core let-can-float invariant] in+-- "GHC.Core".)  It is therefore frequently called on arguments of+-- unlifted type, especially via 'needsCaseBinding'.  But it is+-- sometimes called on expressions of lifted type as well.  For+-- example, see Note [Speculative evaluation] in "GHC.CoreToStg.Prep".+++exprOkForSpeculation, exprOkToDiscard :: CoreExpr -> Bool+exprOkForSpeculation = expr_ok fun_always_ok primOpOkForSpeculation+exprOkToDiscard      = expr_ok fun_always_ok primOpOkToDiscard++fun_always_ok :: Id -> Bool+fun_always_ok _ = True++-- | A special version of 'exprOkForSpeculation' used during+-- Note [Speculative evaluation]. When the predicate arg `fun_ok` returns False+-- for `b`, then `b` is never considered ok-for-spec.+exprOkForSpecEval :: (Id -> Bool) -> CoreExpr -> Bool+exprOkForSpecEval fun_ok = expr_ok fun_ok primOpOkForSpeculation++expr_ok :: (Id -> Bool) -> (PrimOp -> Bool) -> CoreExpr -> Bool+expr_ok _ _ (Lit _)      = True+expr_ok _ _ (Type _)     = True+expr_ok _ _ (Coercion _) = True++expr_ok fun_ok primop_ok (Var v)    = app_ok fun_ok primop_ok v []+expr_ok fun_ok primop_ok (Cast e _) = expr_ok fun_ok primop_ok e+expr_ok fun_ok primop_ok (Lam b e)+                 | isTyVar b = expr_ok fun_ok primop_ok  e+                 | otherwise = True++-- Tick annotations that *tick* cannot be speculated, because these+-- are meant to identify whether or not (and how often) the particular+-- source expression was evaluated at runtime.+expr_ok fun_ok primop_ok (Tick tickish e)+   | tickishCounts tickish = False+   | otherwise             = expr_ok fun_ok primop_ok e++expr_ok _ _ (Let {}) = False+-- See W3 in the Haddock comment for exprOkForSpeculation++expr_ok fun_ok primop_ok (Case scrut bndr _ alts)+  =  -- See Note [exprOkForSpeculation: case expressions]+     expr_ok fun_ok primop_ok scrut+  && isUnliftedType (idType bndr)+      -- OK to call isUnliftedType: binders always have a fixed RuntimeRep+  && all (\(Alt _ _ rhs) -> expr_ok fun_ok primop_ok rhs) alts+  && altsAreExhaustive alts++expr_ok fun_ok primop_ok other_expr+  | (expr, args) <- collectArgs other_expr+  = case stripTicksTopE (not . tickishCounts) expr of+        Var f ->+           app_ok fun_ok primop_ok f args++        -- 'LitRubbish' is the only literal that can occur in the head of an+        -- application and will not be matched by the above case (Var /= Lit).+        -- See Note [How a rubbish literal can be the head of an application]+        -- in GHC.Types.Literal+        Lit lit | debugIsOn, not (isLitRubbish lit)+                 -> pprPanic "Non-rubbish lit in app head" (ppr lit)+                 | otherwise+                 -> True++        _ -> False++-----------------------------+app_ok :: (Id -> Bool) -> (PrimOp -> Bool) -> Id -> [CoreArg] -> Bool+app_ok fun_ok primop_ok fun args+  | not (fun_ok fun)+  = False -- This code path is only taken for Note [Speculative evaluation]++  | idArity fun > n_val_args+  -- Partial application: just check passing the arguments is OK+  = args_ok++  | otherwise+  = case idDetails fun of+      DFunId unary_class -> not unary_class+         -- DFuns terminate, unless the dict is implemented+         -- by a no-op in which case they may not+         -- See (UCM3) in Note [Unary class magic] in GHC.Core.TyCon++      DataConWorkId dc+        | isLazyDataConRep dc+        -> args_ok+        | otherwise+        -> fields_ok (dataConRepStrictness dc)++      ClassOpId _ is_terminating_result+        | is_terminating_result -- See Note [exprOkForSpeculation and type classes]+        -> assertPpr (n_val_args == 1) (ppr fun $$ ppr args) $+           True+           -- assert: terminating result type => can't be applied;+           -- c.f the _other case below++      PrimOpId op _+        | primOpIsDiv op+        , Lit divisor <- Partial.last args+            -- there can be 2 args (most div primops) or 3 args+            -- (WordQuotRem2Op), hence the use of last/init+        -> not (isZeroLit divisor) && all (expr_ok fun_ok primop_ok) (Partial.init args)+              -- Special case for dividing operations that fail+              -- In general they are NOT ok-for-speculation+              -- (which primop_ok will catch), but they ARE OK+              -- if the divisor is definitely non-zero.+              -- Often there is a literal divisor, and this+              -- can get rid of a thunk in an inner loop++        | otherwise -> primop_ok op && args_ok++      _other  -- Unlifted and terminating types;+              -- Also c.f. the Var case of exprIsHNF+         |  isTerminatingType fun_ty  -- See Note [exprOkForSpeculation and type classes]+         || definitelyUnliftedType fun_ty+         -> assertPpr (n_val_args == 0) (ppr fun $$ ppr args)+            True  -- Both terminating types (e.g. Eq a), and unlifted types (e.g. Int#)+                  -- are non-functions and so will have no value args.  The assert is+                  -- just to check this.+                  -- (If we added unlifted function types this would change,+                  -- and we'd need to actually test n_val_args == 0.)++         -- Functions that terminate fast without raising exceptions etc+         -- See (U12) of Note [Implementing unsafeCoerce]+         | fun `hasKey` unsafeEqualityProofIdKey -> True++         | otherwise -> False+             -- NB: even in the nullary case, do /not/ check+             --     for evaluated-ness of the fun;+             --     see Note [exprOkForSpeculation and evaluated variables]+  where+    fun_ty       = idType fun+    n_val_args   = valArgCount args+    (arg_tys, _) = splitPiTys fun_ty++    -- Even if a function call itself is OK, any unlifted+    -- args are still evaluated eagerly and must be checked+    args_ok = all2Prefix arg_ok arg_tys args+    arg_ok :: PiTyVarBinder -> CoreExpr -> Bool+    arg_ok (Named _) _ = True   -- A type argument+    arg_ok (Anon ty _) arg      -- A term argument+       | definitelyLiftedType (scaledThing ty)+       = True -- lifted args are not evaluated eagerly+       | otherwise+       = expr_ok fun_ok primop_ok arg++    -- Used for strict DataCon worker arguments+    -- See (SFC1) of Note [Strict fields in Core]+    fields_ok str_marks = all3Prefix field_ok arg_tys str_marks args+    field_ok :: PiTyVarBinder -> StrictnessMark -> CoreExpr -> Bool+    field_ok (Named _)   _   _ = True+    field_ok (Anon ty _) str arg+       | NotMarkedStrict <- str                 -- iff it's a lazy field+       , definitelyLiftedType (scaledThing ty)  -- and its type is lifted+       = True                                   -- then the worker app does not eval+       | otherwise+       = expr_ok fun_ok primop_ok arg++-----------------------------+altsAreExhaustive :: [Alt b] -> Bool+-- True  <=> the case alternatives are definitely exhaustive+-- False <=> they may or may not be+altsAreExhaustive []+  = True    -- The scrutinee never returns; see Note [Empty case alternatives] in GHC.Core+altsAreExhaustive (Alt con1 _ _ : alts)+  = case con1 of+      DEFAULT   -> True+      LitAlt {} -> False+      DataAlt c -> alts `lengthIs` (tyConFamilySize (dataConTyCon c) - 1)+      -- It is possible to have an exhaustive case that does not+      -- enumerate all constructors, notably in a GADT match, but+      -- we behave conservatively here -- I don't think it's important+      -- enough to deserve special treatment++-- | Should we look past this tick when eta-expanding the given function?+--+-- See Note [Ticks and mandatory eta expansion]+-- Takes the function we are applying as argument.+etaExpansionTick :: Id -> GenTickish pass -> Bool+etaExpansionTick id t+  = hasNoBinding id &&+    ( tickishFloatable t || isProfTick t )++{- Note [exprOkForSpeculation and type classes]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider (#22745, #15205)++  \(d :: C a b). case eq_sel (sc_sel d) of+                   (co :: t1 ~# t2) [Dead] ->  blah++We know that+* eq_sel's argument (sc_sel d) has dictionary type, so it definitely terminates+  (again Note [NON-BOTTOM-DICTS invariant] in GHC.Core)+* eq_sel is simply a superclass selector, and hence is fast+* The field that eq_sel picks is of unlifted type, and hence can't be bottom+  (remember the dictionary argument itself is non-bottom)++So we can treat (eq_sel (sc_sel d)) as ok-for-speculation.  We must check++a) That the function is a class-op, with IdDetails of ClassOpId++b) That the result type of the class-op is terminating or unlifted.  E.g. for+     class C a => D a where ...+     class C a where { op :: a -> a }+   Since C is represented by a newtype, (sc_sel (d :: D a)) might+   not be terminating.++Rather than repeatedly test if the result of the class-op is a+terminating/unlifted type, we cache it as a field of ClassOpId. See+GHC.Types.Id.Make.mkDictSelId for where this field is initialised.++Note [exprOkForSpeculation: case expressions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+exprOkForSpeculation accepts very special case expressions.+Reason: (a ==# b) is ok-for-speculation, but the litEq rules+in GHC.Core.Opt.ConstantFold convert it (a ==# 3#) to+   case a of { DEFAULT -> 0#; 3# -> 1# }+for excellent reasons described in+  GHC.Core.Opt.ConstantFold Note [The litEq rule: converting equality to case].+So, annoyingly, we want that case expression to be+ok-for-speculation too. Bother.++But we restrict it sharply:++* We restrict it to unlifted scrutinees. Consider this:+     case x of y {+       DEFAULT -> ... (let v::Int# = case y of { True  -> e1+                                               ; False -> e2 }+                       in ...) ...++  Does the RHS of v satisfy the let-can-float invariant?  Previously we said+  yes, on the grounds that y is evaluated.  But the binder-swap done+  by GHC.Core.Opt.SetLevels would transform the inner alternative to+     DEFAULT -> ... (let v::Int# = case x of { ... }+                     in ...) ....+  which does /not/ satisfy the let-can-float invariant, because x is+  not evaluated. See Note [Binder-swap during float-out]+  in GHC.Core.Opt.SetLevels.  To avoid this awkwardness it seems simpler+  to stick to unlifted scrutinees where the issue does not+  arise.++* We restrict it to exhaustive alternatives. A non-exhaustive+  case manifestly isn't ok-for-speculation. for example,+  this is a valid program (albeit a slightly dodgy one)+    let v = case x of { B -> ...; C -> ... }+    in case x of+         A -> ...+         _ ->  ...v...v....+  Should v be considered ok-for-speculation?  Its scrutinee may be+  evaluated, but the alternatives are incomplete so we should not+  evaluate it strictly.++  Now, all this is for lifted types, but it'd be the same for any+  finite unlifted type. We don't have many of them, but we might+  add unlifted algebraic types in due course.+++----- Historical note: #15696: --------+  Previously GHC.Core.Opt.SetLevels used exprOkForSpeculation to guide+  floating of single-alternative cases; it now uses exprIsHNF+  Note [Floating single-alternative cases].++  But in those days, consider+    case e of x { DEAFULT ->+      ...(case x of y+            A -> ...+            _ -> ...(case (case x of { B -> p; C -> p }) of+                       I# r -> blah)...+  If GHC.Core.Opt.SetLevels considers the inner nested case as+  ok-for-speculation it can do case-floating (in GHC.Core.Opt.SetLevels).+  So we'd float to:+    case e of x { DEAFULT ->+    case (case x of { B -> p; C -> p }) of I# r ->+    ...(case x of y+            A -> ...+            _ -> ...blah...)...+  which is utterly bogus (seg fault); see #5453.++----- Historical note: #3717: --------+    foo :: Int -> Int+    foo 0 = 0+    foo n = (if n < 5 then 1 else 2) `seq` foo (n-1)++In earlier GHCs, we got this:+    T.$wfoo =+      \ (ww :: GHC.Prim.Int#) ->+        case ww of ds {+          __DEFAULT -> case (case <# ds 5 of _ {+                          GHC.Types.False -> lvl1;+                          GHC.Types.True -> lvl})+                       of _ { __DEFAULT ->+                       T.$wfoo (GHC.Prim.-# ds_XkE 1) };+          0 -> 0 }++Before join-points etc we could only get rid of two cases (which are+redundant) by recognising that the (case <# ds 5 of { ... }) is+ok-for-speculation, even though it has /lifted/ type.  But now join+points do the job nicely.+------- End of historical note ------------+++Note [exprOkForSpeculation and evaluated variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider these examples:+ * case x of y { DEFAULT -> ....y.... }+   Should 'y' (alone) be considered ok-for-speculation?++ * case x of y { DEFAULT -> ....let z = dataToTagLarge# y... }+   Should (dataToTagLarge# y) be considered ok-for-spec? Recall that+     dataToTagLarge# :: forall a. a -> Int#+   must always evaluate its argument. (See also Note [DataToTag overview].)++You could argue 'yes', because in the case alternative we know that+'y' is evaluated.  But the binder-swap transformation, which is+extremely useful for float-out, changes these expressions to+   case x of y { DEFAULT -> ....x.... }+   case x of y { DEFAULT -> ....let z = dataToTagLarge# x... }++And now the expression does not obey the let-can-float invariant!  Yikes!+Moreover we really might float (dataToTagLarge# x) outside the case,+and then it really, really doesn't obey the let-can-float invariant.++The solution is simple: exprOkForSpeculation does not try to take+advantage of the evaluated-ness of (lifted) variables.  And it returns+False (always) for primops that perform evaluation.  We achieve the latter+by marking the relevant primops as "ThrowsException" or+"ReadWriteEffect"; see also Note [Classifying primop effects] in+GHC.Builtin.PrimOps.++Note that exprIsHNF /can/ and does take advantage of evaluated-ness;+it doesn't have the trickiness of the let-can-float invariant to worry about.++************************************************************************+*                                                                      *+             exprIsHNF, exprIsConLike+*                                                                      *+************************************************************************+-}++-- Note [exprIsHNF]             See also Note [exprIsCheap and exprIsHNF]+-- ~~~~~~~~~~~~~~~~+-- | exprIsHNF returns true for expressions that are certainly /already/+-- evaluated to /head/ normal form.  This is used to decide whether it's ok+-- to perform case-to-let for lifted expressions, which changes:+--+-- > case x of x' { _ -> e }+--+--    into:+--+-- > let x' = x in e+--+-- and in so doing makes the binding lazy.+--+-- So, it does /not/ treat variables as evaluated, unless they say they are.+--+-- However, it /does/ treat partial applications and constructor applications+-- as values, even if their arguments are non-trivial, provided the argument+-- type is lifted. For example, both of these are values:+--+-- > (:) (f x) (map f xs)+-- > map (...redex...)+--+-- because 'seq' on such things completes immediately.+--+-- For unlifted argument types, we have to be careful:+--+-- > C (f x :: Int#)+--+-- Suppose @f x@ diverges; then @C (f x)@ is not a value.+-- We check for this using needsCaseBinding below+exprIsHNF :: CoreExpr -> Bool           -- True => Value-lambda, constructor, PAP+exprIsHNF = exprIsHNFlike isDataConWorkId isEvaldUnfolding++-- | Similar to 'exprIsHNF' but includes CONLIKE functions as well as+-- data constructors. Conlike arguments are considered interesting by the+-- inliner.+exprIsConLike :: CoreExpr -> Bool       -- True => lambda, conlike, PAP+exprIsConLike = exprIsHNFlike isConLikeId isConLikeUnfolding++-- | Returns true for values or value-like expressions. These are lambdas,+-- constructors / CONLIKE functions (as determined by the function argument)+-- or PAPs.+--+exprIsHNFlike :: HasDebugCallStack => (Var -> Bool) -> (Unfolding -> Bool) -> CoreExpr -> Bool+exprIsHNFlike is_con is_con_unf e+  = -- pprTraceWith "hnf" (\r -> ppr r <+> ppr e) $+    is_hnf_like e+  where+    is_hnf_like (Var v) -- NB: There are no value args at this point+      =  id_app_is_value v [] -- Catches nullary constructors,+                              --      so that [] and () are values, for example+                              -- and (e.g.) primops that don't have unfoldings+      || is_con_unf (idUnfolding v)+        -- Check the thing's unfolding; it might be bound to a value+        --   or to a guaranteed-evaluated variable (isEvaldUnfolding)+        --   Contrast with Note [exprOkForSpeculation and evaluated variables]+        -- We don't look through loop breakers here, which is a bit conservative+        -- but otherwise I worry that if an Id's unfolding is just itself,+        -- we could get an infinite loop++      || definitelyUnliftedType (idType v)+        -- Unlifted binders are always evaluated (#20140)++    is_hnf_like (Lit l)          = not (isLitRubbish l)+        -- Regarding a LitRubbish as ConLike leads to unproductive inlining in+        -- WWRec, see #20035+    is_hnf_like (Type _)         = True       -- Types are honorary Values;+                                              -- we don't mind copying them+    is_hnf_like (Coercion _)     = True       -- Same for coercions+    is_hnf_like (Lam b e)        = isRuntimeVar b || is_hnf_like e+    is_hnf_like (Tick tickish e) = not (tickishCounts tickish)+                                   && is_hnf_like e+                                      -- See Note [exprIsHNF Tick]+    is_hnf_like (Cast e _)       = is_hnf_like e+    is_hnf_like (App e a)+      | isValArg a               = app_is_value e [a]+      | otherwise                = is_hnf_like e+    is_hnf_like (Let _ e)        = is_hnf_like e  -- Lazy let(rec)s don't affect us+    is_hnf_like (Case e b _ as)+      | Just rhs <- isUnsafeEqualityCase e b as+      = is_hnf_like rhs+    is_hnf_like _                = False++    -- Collect arguments through Casts and Ticks and call id_app_is_value+    app_is_value :: CoreExpr -> [CoreArg] -> Bool+    app_is_value (Var f)    as = id_app_is_value f as+    app_is_value (Tick _ f) as = app_is_value f as+    app_is_value (Cast f _) as = app_is_value f as+    app_is_value (App f a)  as | isValArg a = app_is_value f (a:as)+                               | otherwise  = app_is_value f as+    app_is_value _          _  = False++    id_app_is_value id val_args+      | Just dc <- isDataConWorkId_maybe id+      , isUnaryClassDataCon  dc+      = all is_hnf_like val_args  -- Look through unary class data cons+      | otherwise+      -- See Note [exprIsHNF for function applications]+      --   for the specification and examples+      = case compare (idArity id) (length val_args) of+          EQ | is_con id ->      -- Saturated app of a DataCon/CONLIKE Id+            case mb_str_marks id of+              Just str_marks ->  -- with strict fields; see (SFC1) of Note [Strict fields in Core]+                assert (val_args `equalLength` str_marks) $+                fields_hnf str_marks+              Nothing ->         -- without strict fields: like PAP+                args_hnf         -- NB: CONLIKEs are lazy!++          GT ->                  -- PAP: Check unlifted val_args+            args_hnf++          _  -> False++      where+        -- Saturated, Strict DataCon: Check unlifted val_args and strict fields+        fields_hnf str_marks = all3Prefix check_field val_arg_tys str_marks val_args++        -- PAP: Check unlifted val_args+        args_hnf             = all2Prefix check_arg   val_arg_tys           val_args++        fun_ty = idType id+        val_arg_tys = mapMaybe anonPiTyBinderType_maybe (collectPiTyBinders fun_ty)+          -- val_arg_tys = map exprType val_args, but much less costly.+          -- The obvious definition regresses T16577 by 30% so we don't do it.++        check_arg a_ty a+          | mightBeUnliftedType a_ty = is_hnf_like a+          | otherwise                = True+         -- Check unliftedness; for example f (x /# 12#) where f has arity two,+         -- and the first argument is unboxed. This is not a value!+         -- But  f 34#  is a value, so check args for HNFs.+         -- NB: We check arity (and CONLIKEness) first because it's cheaper+         --     and we reject quickly on saturated apps.+        check_field a_ty str a+          | mightBeUnliftedType a_ty = is_hnf_like a+          | isMarkedStrict str       = is_hnf_like a+          | otherwise                = True+          -- isMarkedStrict: Respect Note [Strict fields in Core]++        mb_str_marks id+          | Just dc <- isDataConWorkId_maybe id+          , not (isLazyDataConRep dc)+          = Just (dataConRepStrictness dc)+          | otherwise+          = Nothing++{-# INLINE exprIsHNFlike #-}++{-+Note [exprIsHNF Tick]+~~~~~~~~~~~~~~~~~~~~~+We can discard source annotations on HNFs as long as they aren't+tick-like:++  scc c (\x . e)    =>  \x . e+  scc c (C x1..xn)  =>  C x1..xn++So we regard these as HNFs.  Tick annotations that tick are not+regarded as HNF if the expression they surround is HNF, because the+tick is there to tell us that the expression was evaluated, so we+don't want to discard a seq on it.++Note [exprIsHNF for function applications]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider an application with an Id head where the argument is a redex:++  f <redex>++Is this expression a value?++The answer depends on the type of `f`, its arity and whether or not it is a+strict data constructor. The decision diagram is as follows:++* If <redex> is unlifted, it is *not* a value (regardless of arity!)+* Otherwise, <redex> is lifted.+  Does its `idArity` (a lower bound on the actual arity)+  exceed the number of actual arguments (= 1)?+  * If so, it is a PAP and thus a value+  * If not, it is a saturated call.+    Is it a lazy data constructor?   Then it is a value.+    Is it a strict data constructor? Then it is *not* a value. (See also Note [Strict fields in Core].)+    Otherwise, it is a regular, possibly saturated function call, and hence *not* a value.++The code in exprIsHNF is tweaked for efficiency, hence it delays the+unliftedness check after the arity check.++Here are a few examples (enshrined in testcase AppIsHNF) to bring home this+point. Let us say that++  f :: Int# -> Int -> Int -> Int, with idArity 3+  expensive# :: Int -> Int#  -- unlifted result+  expensive  :: Int -> Int   -- lifted result+  data T where+    K1 :: !Int -> Int -> T -- strict field+    K2 :: Int# -> Int -> T -- unlifted field++Now consider++  f (expensive# 1) 2    -- Not HNF+  f 1# (expensive 2)    -- HNF++  K1 1 (expensive 2)   -- HNF+  K1 (expensive 1) 2   -- Not HNF+  K1 (expensive 1)     -- HNF      (!)++  K2 1# (expensive 1)   -- HNF+  K2 (expensive# 1) 2   -- Not HNF+  K2 (expensive# 1)     -- Not HNF (!)++Note that the cases marked (!) exemplify that strict fields are different to+unlifted fields when considering partial applications: Unlifted fields are+evaluated eagerly whereas evaluation of strict fields is delayed until the call+is saturated.+-}++-- | Can we bind this 'CoreExpr' at the top level?+exprIsTopLevelBindable :: CoreExpr -> Type -> Bool+-- See Note [Core top-level string literals]+-- Precondition: exprType expr = ty+-- Top-level literal strings can't even be wrapped in ticks+--   see Note [Core top-level string literals] in "GHC.Core"+exprIsTopLevelBindable expr ty+  = not (mightBeUnliftedType ty)+    -- Note that 'expr' may not have a fixed runtime representation here,+    -- consequently we must use 'mightBeUnliftedType' rather than 'isUnliftedType',+    -- as the latter would panic.+  || exprIsTickedString expr++-- | Check if the expression is zero or more Ticks wrapped around a literal+-- string.+exprIsTickedString :: CoreExpr -> Bool+exprIsTickedString = isJust . exprIsTickedString_maybe++-- | Extract a literal string from an expression that is zero or more Ticks+-- wrapped around a literal string. Returns Nothing if the expression has a+-- different shape.+-- Used to "look through" Ticks in places that need to handle literal strings.+exprIsTickedString_maybe :: CoreExpr -> Maybe ByteString+exprIsTickedString_maybe (Lit (LitString bs)) = Just bs+exprIsTickedString_maybe (Tick t e)+  -- we don't tick literals with CostCentre ticks, compare to mkTick+  | tickishPlace t == PlaceCostCentre = Nothing+  | otherwise = exprIsTickedString_maybe e+exprIsTickedString_maybe _ = Nothing++{-+************************************************************************+*                                                                      *+             Instantiating data constructors+*                                                                      *+************************************************************************++These InstPat functions go here to avoid circularity between DataCon and Id+-}++dataConRepInstPat   ::                 [Unique] -> Mult -> DataCon -> [Type] -> ([TyCoVar], [Id])+dataConRepFSInstPat :: [FastString] -> [Unique] -> Mult -> DataCon -> [Type] -> ([TyCoVar], [Id])++dataConRepInstPat   = dataConInstPat (repeat ((fsLit "ipv")))+dataConRepFSInstPat = dataConInstPat++dataConInstPat :: [FastString]          -- A long enough list of FSs to use for names+               -> [Unique]              -- An equally long list of uniques, at least one for each binder+               -> Mult                  -- The multiplicity annotation of the case expression: scales the multiplicity of variables+               -> DataCon+               -> [Type]                -- Types to instantiate the universally quantified tyvars+               -> ([TyCoVar], [Id])     -- Return instantiated variables+-- dataConInstPat arg_fun fss us mult con inst_tys returns a tuple+-- (ex_tvs, arg_ids),+--+--   ex_tvs are intended to be used as binders for existential type args+--+--   arg_ids are intended to be used as binders for value arguments,+--     and their types have been instantiated with inst_tys and ex_tys+--     The arg_ids include both evidence and+--     programmer-specified arguments (both after rep-ing)+--+-- Example.+--  The following constructor T1+--+--  data T a where+--    T1 :: forall b. Int -> b -> T(a,b)+--    ...+--+--  has representation type+--   forall a. forall a1. forall b. (a ~ (a1,b)) =>+--     Int -> b -> T a+--+--  dataConInstPat fss us T1 (a1',b') will return+--+--  ([a1'', b''], [c :: (a1', b')~(a1'', b''), x :: Int, y :: b''])+--+--  where the double-primed variables are created with the FastStrings and+--  Uniques given as fss and us+dataConInstPat fss uniqs mult con inst_tys+  = assert (univ_tvs `equalLength` inst_tys) $+    (ex_bndrs, arg_ids)+  where+    univ_tvs = dataConUnivTyVars con+    ex_tvs   = dataConExTyCoVars con+    arg_tys  = dataConRepArgTys con+    arg_strs = dataConRepStrictness con  -- 1-1 with arg_tys+    n_ex = length ex_tvs++      -- split the Uniques and FastStrings+    (ex_uniqs, id_uniqs) = splitAt n_ex uniqs+    (ex_fss,   id_fss)   = splitAt n_ex fss++      -- Make the instantiating substitution for universals+    univ_subst = zipTvSubst univ_tvs inst_tys++      -- Make existential type variables, applying and extending the substitution+    (full_subst, ex_bndrs) = mapAccumL mk_ex_var univ_subst+                                       (zip3 ex_tvs ex_fss ex_uniqs)++    mk_ex_var :: Subst -> (TyCoVar, FastString, Unique) -> (Subst, TyCoVar)+    mk_ex_var subst (tv, fs, uniq) = (Type.extendTCvSubstWithClone subst tv+                                       new_tv+                                     , new_tv)+      where+        new_tv | isTyVar tv+               = mkTyVar (mkSysTvName uniq fs) kind+               | otherwise+               = mkCoVar (mkSystemVarName uniq fs) kind+        kind   = Type.substTyUnchecked subst (varType tv)++      -- Make value vars, instantiating types+    arg_ids = zipWith4 mk_id_var id_uniqs id_fss arg_tys arg_strs+    mk_id_var uniq fs (Scaled m ty) str+      = setCaseBndrEvald str $  -- See Note [Mark evaluated arguments]+        mkUserLocalOrCoVar (mkVarOccFS fs) uniq+                           (mult `mkMultMul` m) (Type.substTy full_subst ty) noSrcSpan++{-+Note [Mark evaluated arguments]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When pattern matching on a constructor with strict fields, the binder+can have an 'evaldUnfolding'.  Moreover, it *should* have one, so that+when loading an interface file unfolding like:+  data T = MkT !Int+  f x = case x of { MkT y -> let v::Int# = case y of I# n -> n+1+                             in ... }+we don't want Lint to complain.  The 'y' is evaluated, so the+case in the RHS of the binding for 'v' is fine.  But only if we+*know* that 'y' is evaluated.++c.f. add_evals in GHC.Core.Opt.Simplify.simplAlt++************************************************************************+*                                                                      *+         Equality+*                                                                      *+************************************************************************+-}++-- | A cheap equality test which bales out fast!+--      If it returns @True@ the arguments are definitely equal,+--      otherwise, they may or may not be equal.+cheapEqExpr :: Expr b -> Expr b -> Bool+cheapEqExpr = cheapEqExpr' (const False)++-- | Cheap expression equality test, can ignore ticks by type.+cheapEqExpr' :: (CoreTickish -> Bool) -> Expr b -> Expr b -> Bool+{-# INLINE cheapEqExpr' #-}+cheapEqExpr' ignoreTick e1 e2+  = go e1 e2+  where+    go (Var v1)   (Var v2)         = v1 == v2+    go (Lit lit1) (Lit lit2)       = lit1 == lit2+    go (Type t1)  (Type t2)        = t1 `eqType` t2+    go (Coercion c1) (Coercion c2) = c1 `eqCoercion` c2+    go (App f1 a1) (App f2 a2)     = f1 `go` f2 && a1 `go` a2+    go (Cast e1 t1) (Cast e2 t2)   = e1 `go` e2 && t1 `eqCoercion` t2++    go (Tick t1 e1) e2 | ignoreTick t1 = go e1 e2+    go e1 (Tick t2 e2) | ignoreTick t2 = go e1 e2+    go (Tick t1 e1) (Tick t2 e2) = t1 == t2 && e1 `go` e2++    go _ _ = False++++-- Used by diffBinds, which is itself only used in GHC.Core.Lint.lintAnnots+eqTickish :: RnEnv2 -> CoreTickish -> CoreTickish -> Bool+eqTickish env (Breakpoint lext lid lids) (Breakpoint rext rid rids)+      = lid == rid &&+        map (rnOccL env) lids == map (rnOccR env) rids &&+        lext == rext+eqTickish _ l r = l == r++-- | Finds differences between core bindings, see @diffExpr@.+--+-- The main problem here is that while we expect the binds to have the+-- same order in both lists, this is not guaranteed. To do this+-- properly we'd either have to do some sort of unification or check+-- all possible mappings, which would be seriously expensive. So+-- instead we simply match single bindings as far as we can. This+-- leaves us just with mutually recursive and/or mismatching bindings,+-- which we then speculatively match by ordering them. It's by no means+-- perfect, but gets the job done well enough.+--+-- Only used in GHC.Core.Lint.lintAnnots+diffBinds :: Bool -> RnEnv2 -> [(Var, CoreExpr)] -> [(Var, CoreExpr)]+          -> ([SDoc], RnEnv2)+diffBinds top env binds1 = go (length binds1) env binds1+ where go _    env []     []+          = ([], env)+       go _fuel env [] binds2+          -- No binds remaining to compare on the left? Bail out early.+          = (warn env [] binds2, env)+       go _fuel env binds1 []+          -- No binds remaining to compare on the right? Bail out early.+          = (warn env binds1 [], env)+       go fuel env binds1@(bind1:_) binds2@(_:_)+          -- Iterated over all binds without finding a match? Then+          -- try speculatively matching binders by order.+          | fuel == 0+          = if not $ env `inRnEnvL` fst bind1+            then let env' = uncurry (rnBndrs2 env) $ unzip $+                            zip (sort $ map fst binds1) (sort $ map fst binds2)+                 in go (length binds1) env' binds1 binds2+            -- If we have already tried that, give up+            else (warn env binds1 binds2, env)+       go fuel env ((bndr1,expr1):binds1) binds2+          | let matchExpr (bndr,expr) =+                  (isTyVar bndr || not top || null (diffIdInfo env bndr bndr1)) &&+                  null (diffExpr top (rnBndr2 env bndr1 bndr) expr1 expr)++          , (binds2l, (bndr2,_):binds2r) <- break matchExpr binds2+          = go (length binds1) (rnBndr2 env bndr1 bndr2)+                binds1 (binds2l ++ binds2r)+          | otherwise -- No match, so push back (FIXME O(n^2))+          = go (fuel-1) env (binds1++[(bndr1,expr1)]) binds2++       -- We have tried everything, but couldn't find a good match. So+       -- now we just return the comparison results when we pair up+       -- the binds in a pseudo-random order.+       warn env binds1 binds2 =+         concatMap (uncurry (diffBind env)) (zip binds1' binds2') +++         unmatched "unmatched left-hand:" (drop l binds1') +++         unmatched "unmatched right-hand:" (drop l binds2')+        where binds1' = sortBy (comparing fst) binds1+              binds2' = sortBy (comparing fst) binds2+              l = min (length binds1') (length binds2')+       unmatched _   [] = []+       unmatched txt bs = [text txt $$ ppr (Rec bs)]+       diffBind env (bndr1,expr1) (bndr2,expr2)+         | ds@(_:_) <- diffExpr top env expr1 expr2+         = locBind "in binding" bndr1 bndr2 ds+         -- Special case for TyVar, which we checked were bound to the same types in+         -- diffExpr, but don't have any IdInfo we would panic if called diffIdInfo.+         -- These let-bound types are created temporarily by the simplifier but inlined+         -- immediately.+         | isTyVar bndr1 && isTyVar bndr2+         = []+         | otherwise+         = diffIdInfo env bndr1 bndr2++-- | Finds differences between core expressions, modulo alpha and+-- renaming. Setting @top@ means that the @IdInfo@ of bindings will be+-- checked for differences as well.+diffExpr :: Bool -> RnEnv2 -> CoreExpr -> CoreExpr -> [SDoc]+diffExpr _   env (Var v1)   (Var v2)   | rnOccL env v1 == rnOccR env v2 = []+diffExpr _   _   (Lit lit1) (Lit lit2) | lit1 == lit2                   = []+diffExpr _   env (Type t1)  (Type t2)  | eqTypeX env t1 t2              = []+diffExpr _   env (Coercion co1) (Coercion co2)+                                       | eqCoercionX env co1 co2        = []+diffExpr top env (Cast e1 co1)  (Cast e2 co2)+  | eqCoercionX env co1 co2                = diffExpr top env e1 e2+diffExpr top env (Tick n1 e1)   e2+  | not (tickishIsCode n1)                 = diffExpr top env e1 e2+diffExpr top env e1             (Tick n2 e2)+  | not (tickishIsCode n2)                 = diffExpr top env e1 e2+diffExpr top env (Tick n1 e1)   (Tick n2 e2)+  | eqTickish env n1 n2                    = diffExpr top env e1 e2+ -- The error message of failed pattern matches will contain+ -- generated names, which are allowed to differ.+diffExpr _   _   (App (App (Var absent) _) _)+                 (App (App (Var absent2) _) _)+  | isDeadEndId absent && isDeadEndId absent2 = []+diffExpr top env (App f1 a1)    (App f2 a2)+  = diffExpr top env f1 f2 ++ diffExpr top env a1 a2+diffExpr top env (Lam b1 e1)  (Lam b2 e2)+  | eqTypeX env (varType b1) (varType b2)   -- False for Id/TyVar combination+  = diffExpr top (rnBndr2 env b1 b2) e1 e2+diffExpr top env (Let bs1 e1) (Let bs2 e2)+  = let (ds, env') = diffBinds top env (flattenBinds [bs1]) (flattenBinds [bs2])+    in ds ++ diffExpr top env' e1 e2+diffExpr top env (Case e1 b1 t1 a1) (Case e2 b2 t2 a2)+  | equalLength a1 a2 && not (null a1) || eqTypeX env t1 t2+    -- See Note [Empty case alternatives] in GHC.Data.TrieMap+  = diffExpr top env e1 e2 ++ concat (zipWith diffAlt a1 a2)+  where env' = rnBndr2 env b1 b2+        diffAlt (Alt c1 bs1 e1) (Alt c2 bs2 e2)+          | c1 /= c2  = [text "alt-cons " <> ppr c1 <> text " /= " <> ppr c2]+          | otherwise = diffExpr top (rnBndrs2 env' bs1 bs2) e1 e2+diffExpr _  _ e1 e2+  = [fsep [ppr e1, text "/=", ppr e2]]++-- | Find differences in @IdInfo@. We will especially check whether+-- the unfoldings match, if present (see @diffUnfold@).+diffIdInfo :: RnEnv2 -> Var -> Var -> [SDoc]+diffIdInfo env bndr1 bndr2+  | arityInfo info1 == arityInfo info2+    && cafInfo info1 == cafInfo info2+    && oneShotInfo info1 == oneShotInfo info2+    && inlinePragInfo info1 == inlinePragInfo info2+    && occInfo info1 == occInfo info2+    && demandInfo info1 == demandInfo info2+    && callArityInfo info1 == callArityInfo info2+  = locBind "in unfolding of" bndr1 bndr2 $+    diffUnfold env (realUnfoldingInfo info1) (realUnfoldingInfo info2)+  | otherwise+  = locBind "in Id info of" bndr1 bndr2+    [fsep [pprBndr LetBind bndr1, text "/=", pprBndr LetBind bndr2]]+  where info1 = idInfo bndr1; info2 = idInfo bndr2++-- | Find differences in unfoldings. Note that we will not check for+-- differences of @IdInfo@ in unfoldings, as this is generally+-- redundant, and can lead to an exponential blow-up in complexity.+diffUnfold :: RnEnv2 -> Unfolding -> Unfolding -> [SDoc]+diffUnfold _   NoUnfolding    NoUnfolding                 = []+diffUnfold _   BootUnfolding  BootUnfolding               = []+diffUnfold _   (OtherCon cs1) (OtherCon cs2) | cs1 == cs2 = []+diffUnfold env (DFunUnfolding bs1 c1 a1)+               (DFunUnfolding bs2 c2 a2)+  | c1 == c2 && equalLength bs1 bs2+  = concatMap (uncurry (diffExpr False env')) (zip a1 a2)+  where env' = rnBndrs2 env bs1 bs2+diffUnfold env (CoreUnfolding t1 _ _ c1 g1)+               (CoreUnfolding t2 _ _ c2 g2)+  | c1 == c2 && g1 == g2+  = diffExpr False env t1 t2+diffUnfold _   uf1 uf2+  = [fsep [ppr uf1, text "/=", ppr uf2]]++-- | Add location information to diff messages+locBind :: String -> Var -> Var -> [SDoc] -> [SDoc]+locBind loc b1 b2 diffs = map addLoc diffs+  where addLoc d            = d $$ nest 2 (parens (text loc <+> bindLoc))+        bindLoc | b1 == b2  = ppr b1+                | otherwise = ppr b1 <> char '/' <> ppr b2+++{- *********************************************************************+*                                                                      *+\subsection{Determining non-updatable right-hand-sides}+*                                                                      *+************************************************************************++Top-level constructor applications can usually be allocated+statically, but they can't if the constructor, or any of the+arguments, come from another DLL (because we can't refer to static+labels in other DLLs).++If this happens we simply make the RHS into an updatable thunk,+and 'execute' it rather than allocating it statically.+-}++{-+************************************************************************+*                                                                      *+\subsection{Type utilities}+*                                                                      *+************************************************************************+-}++-- | True if the type has no non-bottom elements, e.g. when it is an empty+-- datatype, or a GADT with non-satisfiable type parameters, e.g. Int :~: Bool.+-- See Note [Bottoming expressions]+--+-- See Note [No alternatives lint check] for another use of this function.+isEmptyTy :: Type -> Bool+isEmptyTy ty+    -- Data types where, given the particular type parameters, no data+    -- constructor matches, are empty.+    -- This includes data types with no constructors, e.g. Data.Void.Void.+    | Just (tc, inst_tys) <- splitTyConApp_maybe ty+    , Just dcs <- tyConDataCons_maybe tc+    , all (dataConCannotMatch inst_tys) dcs+    = True+    | otherwise+    = False++-- | If @normSplitTyConApp_maybe _ ty = Just (tc, tys, co)@+-- then @ty |> co = tc tys@. It's 'splitTyConApp_maybe', but looks through+-- coercions via 'topNormaliseType_maybe'. Hence the \"norm\" prefix.+--+-- Postcondition: tc is not a newtype (guaranteed by topNormaliseType_maybe)+normSplitTyConApp_maybe :: FamInstEnvs -> Type -> Maybe (TyCon, [Type], Coercion)+normSplitTyConApp_maybe fam_envs ty+  | let Reduction co ty1 = topNormaliseType_maybe fam_envs ty+                           `orElse` (mkReflRedn Representational ty)+  , Just (tc, tc_args) <- splitTyConApp_maybe ty1+  , not (isNewTyCon tc)  -- How can tc be a newtype, after `topNormaliseType`?+                         -- Answer: if it is a recursive newtype, `topNormaliseType`+                         --         may be a no-op.   Example: tc226+  = Just (tc, tc_args, co)+normSplitTyConApp_maybe _ _ = Nothing++{-+*****************************************************+*+* InScopeSet things+*+*****************************************************+-}+++extendInScopeSetBind :: InScopeSet -> CoreBind -> InScopeSet+extendInScopeSetBind (InScope in_scope) binds+   = InScope $ foldBindersOfBindStrict extendVarSet in_scope binds++extendInScopeSetBndrs :: InScopeSet -> [CoreBind] -> InScopeSet+extendInScopeSetBndrs (InScope in_scope) binds+   = InScope $ foldBindersOfBindsStrict extendVarSet in_scope binds++mkInScopeSetBndrs :: [CoreBind] -> InScopeSet+mkInScopeSetBndrs binds = foldBindersOfBindsStrict extendInScopeSet emptyInScopeSet binds++{-+*****************************************************+*+* StaticPtr+*+*****************************************************+-}++-- | @collectMakeStaticArgs (makeStatic t srcLoc e)@ yields+-- @Just (makeStatic, t, srcLoc, e)@.+--+-- Returns @Nothing@ for every other expression.+collectMakeStaticArgs+  :: CoreExpr -> Maybe (CoreExpr, Type, CoreExpr, CoreExpr)+collectMakeStaticArgs e+    | (fun@(Var b), [Type t, loc, arg], _) <- collectArgsTicks (const True) e+    , idName b == makeStaticName = Just (fun, t, loc, arg)+collectMakeStaticArgs _          = Nothing++{-+************************************************************************+*                                                                      *+\subsection{Join points}+*                                                                      *+************************************************************************+-}++-- | Does this binding bind a join point (or a recursive group of join points)?+isJoinBind :: CoreBind -> Bool+isJoinBind (NonRec b _)       = isJoinId b+isJoinBind (Rec ((b, _) : _)) = isJoinId b+isJoinBind _                  = False++dumpIdInfoOfProgram :: Bool -> (IdInfo -> SDoc) -> CoreProgram -> SDoc+dumpIdInfoOfProgram dump_locals ppr_id_info binds = vcat (map printId ids)+  where+  ids = sortBy (stableNameCmp `on` getName) (concatMap getIds binds)+  getIds (NonRec i _) = [ i ]+  getIds (Rec bs)     = map fst bs+  -- By default only include full info for exported ids, unless we run in the verbose+  -- pprDebug mode.+  printId id | isExportedId id || dump_locals = ppr id <> colon <+> (ppr_id_info (idInfo id))+             | otherwise       = empty++{-+************************************************************************+*                                                                      *+\subsection{Tag inference things}+*                                                                      *+************************************************************************+-}++{- Note [Call-by-value for worker args]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we unbox a constructor with strict fields we want to+preserve the information that some of the arguments came+out of strict fields and therefore should be already properly+tagged, however we can't express this directly in core.++Instead what we do is generate a worker like this:++  data T = MkT A !B++  foo = case T of MkT a b -> $wfoo a b++  $wfoo a b = case b of b' -> rhs[b/b']++This makes the worker strict in b causing us to use a more efficient+calling convention for `b` where the caller needs to ensure `b` is+properly tagged and evaluated before it's passed to $wfoo. See Note [CBV Function Ids].++Usually the argument will be known to be properly tagged at the call site so there is+no additional work for the caller and the worker can be more efficient since it can+assume the presence of a tag.++This is especially true for recursive functions like this:+    -- myPred expect it's argument properly tagged+    myPred !x = ...++    loop :: MyPair -> Int+    loop (MyPair !x !y) =+        case x of+            A -> 1+            B -> 2+            _ -> loop (MyPair (myPred x) (myPred y))++Here we would ordinarily not be strict in y after unboxing.+However if we pass it as a regular argument then this means on+every iteration of loop we will incur an extra seq on y before+we can pass it to `myPred` which isn't great! That is in STG after+tag inference we get:++    Rec {+    Find.$wloop [InlPrag=[2], Occ=LoopBreaker]+      :: Find.MyEnum -> Find.MyEnum -> GHC.Prim.Int#+    [GblId[StrictWorker([!, ~])],+    Arity=2,+    Str=<1L><ML>,+    Unf=OtherCon []] =+        {} \r [x y]+            case x<TagProper> of x' [Occ=Once1] {+              __DEFAULT ->+                  case y of y' [Occ=Once1] {+                  __DEFAULT ->+                  case Find.$wmyPred y' of pred_y [Occ=Once1] {+                  __DEFAULT ->+                  case Find.$wmyPred x' of pred_x [Occ=Once1] {+                  __DEFAULT -> Find.$wloop pred_x pred_y;+                  };+                  };+              Find.A -> 1#;+              Find.B -> 2#;+            };+    end Rec }++Here comes the tricky part: If we make $wloop strict in both x/y and we get:++    Rec {+    Find.$wloop [InlPrag=[2], Occ=LoopBreaker]+      :: Find.MyEnum -> Find.MyEnum -> GHC.Prim.Int#+    [GblId[StrictWorker([!, !])],+    Arity=2,+    Str=<1L><!L>,+    Unf=OtherCon []] =+        {} \r [x y]+            case y<TagProper> of y' [Occ=Once1] { __DEFAULT ->+            case x<TagProper> of x' [Occ=Once1] {+              __DEFAULT ->+                  case Find.$wmyPred y' of pred_y [Occ=Once1] {+                  __DEFAULT ->+                  case Find.$wmyPred x' of pred_x [Occ=Once1] {+                  __DEFAULT -> Find.$wloop pred_x pred_y;+                  };+                  };+              Find.A -> 1#;+              Find.B -> 2#;+            };+    end Rec }++Here both x and y are known to be tagged in the function body since we pass strict worker args using unlifted cbv.+This means the seqs on x and y both become no-ops and compared to the first version the seq on `y` disappears at runtime.++The downside is that the caller of $wfoo potentially has to evaluate `y` once if we can't prove it isn't already evaluated.+But y coming out of a strict field is in WHNF so safe to evaluated. And most of the time it will be properly tagged+evaluated+already at the call site because of the EPT Invariant! See Note [EPT enforcement] for more in this.+This makes GHC itself around 1% faster despite doing slightly more work! So this is generally quite good.++We only apply this when we think there is a benefit in doing so however. There are a number of cases in which+it would be useless to insert an extra seq. ShouldStrictifyIdForCbv tries to identify these to avoid churn in the+simplifier. See Note [Which Ids should be strictified] for details on this.+-}+mkStrictFieldSeqs :: [(Id,StrictnessMark)] -> CoreExpr -> (CoreExpr)+mkStrictFieldSeqs args rhs =+  foldr addEval rhs args+    where+      case_ty = exprType rhs+      addEval :: (Id,StrictnessMark) -> (CoreExpr) -> (CoreExpr)+      addEval (arg_id,arg_cbv) (rhs)+        -- Argument representing strict field.+        | isMarkedStrict arg_cbv+        , shouldStrictifyIdForCbv arg_id+        -- Make sure to remove unfoldings here to avoid the simplifier dropping those for OtherCon[] unfoldings.+        = Case (Var $! zapIdUnfolding arg_id) arg_id case_ty ([Alt DEFAULT [] rhs])+        -- Normal argument+        | otherwise = do+          rhs++{- Note [Which Ids should be strictified]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For some arguments we would like to convince GHC to pass them call by value.+One way to achieve this is described in see Note [Call-by-value for worker args].++We separate the concerns of "should we pass this argument using cbv" and+"should we do so by making the rhs strict in this argument".+This note deals with the second part.++There are multiple reasons why we might not want to insert a seq in the rhs to+strictify a functions argument:++1) The argument doesn't exist at runtime.++For zero width types (like Types) there is no benefit as we don't operate on them+at runtime at all. This includes things like void#, coercions and state tokens.++2) The argument is a unlifted type.++If the argument is a unlifted type the calling convention already is explicitly+cbv. This means inserting a seq on this argument wouldn't do anything as the seq+would be a no-op *and* it wouldn't affect the calling convention.++3) The argument is absent.++If the argument is absent in the body there is no advantage to it being passed as+cbv to the function. The function won't ever look at it so we don't safe any work.++This mostly happens for join point. For example we might have:++    data T = MkT ![Int] [Char]+    f t = case t of MkT xs{strict} ys-> snd (xs,ys)++and abstract the case alternative to:++    f t = join j1 = \xs ys -> snd (xs,ys)+          in case t of MkT xs{strict} ys-> j1 xs xy++While we "use" xs inside `j1` it's not used inside the function `snd` we pass it to.+In short a absent demand means neither our RHS, nor any function we pass the argument+to will inspect it. So there is no work to be saved by forcing `xs` early.++NB: There is an edge case where if we rebox we *can* end up seqing an absent value.+Note [Absent fillers] has an example of this. However this is so rare it's not worth+caring about here.++4) The argument is already strict.++Consider this code:++    data T = MkT ![Int]+    f t = case t of MkT xs{strict} -> reverse xs++The `xs{strict}` indicates that `xs` is used strictly by the `reverse xs`.+If we do a w/w split, and add the extra eval on `xs`, we'll get++    $wf xs =+        case xs of xs1 ->+            let t = MkT xs1 in+            case t of MkT xs2 -> reverse xs2++That's not wrong; but the w/w body will simplify to++    $wf xs = case xs of xs1 -> reverse xs1++and now we'll drop the `case xs` because `xs1` is used strictly in its scope.+Adding that eval was a waste of time.  So don't add it for strictly-demanded Ids.++5) Functions++Functions are tricky (see Note [TagInfo of functions] in EnforceEpt).+But the gist of it even if we make a higher order function argument strict+we can't avoid the tag check when it's used later in the body.+So there is no benefit.++-}+-- | Do we expect there to be any benefit if we make this var strict+-- in order for it to get treated as as cbv argument?+-- See Note [Which Ids should be strictified]+-- See Note [CBV Function Ids] for more background.+shouldStrictifyIdForCbv :: Var -> Bool+shouldStrictifyIdForCbv = wantCbvForId False++-- Like shouldStrictifyIdForCbv but also wants to use cbv for strict args.+shouldUseCbvForId :: Var -> Bool+shouldUseCbvForId = wantCbvForId True++-- When we strictify we want to skip strict args otherwise the logic is the same+-- as for shouldUseCbvForId so we common up the logic here.+-- Basically returns true if it would be beneficial for runtime to pass this argument+-- as CBV independent of weither or not it's correct. E.g. it might return true for lazy args+-- we are not allowed to force.+wantCbvForId :: Bool -> Var -> Bool+wantCbvForId cbv_for_strict v+  -- Must be a runtime var.+  -- See Note [Which Ids should be strictified] point 1)+  | isId v+  , not $ isZeroBitTy ty+  -- Unlifted things don't need special measures to be treated as cbv+  -- See Note [Which Ids should be strictified] point 2)+  , mightBeLiftedType ty+  -- Functions sometimes get a zero tag so we can't eliminate the tag check.+  -- See Note [TagInfo of functions] in EnforceEpt.+  -- See Note [Which Ids should be strictified] point 5)+  , not $ isFunTy ty+  -- If the var is strict already a seq is redundant.+  -- See Note [Which Ids should be strictified] point 4)+  , not (isStrictDmd dmd) || cbv_for_strict+  -- If the var is absent a seq is almost always useless.+  -- See Note [Which Ids should be strictified] point 3)+  , not (isAbsDmd dmd)+  = True+  | otherwise+  = False+  where+    ty = idType v+    dmd = idDemandInfo v++{- *********************************************************************+*                                                                      *+             unsafeEqualityProof+*                                                                      *+********************************************************************* -}++isUnsafeEqualityCase :: CoreExpr -> Id -> [CoreAlt] -> Maybe CoreExpr+-- See (U3) and (U4) in+-- Note [Implementing unsafeCoerce] in base:Unsafe.Coerce+isUnsafeEqualityCase scrut bndr alts+  | [Alt ac _ rhs] <- alts+  , DataAlt dc <- ac+  , dc `hasKey` unsafeReflDataConKey+  , isDeadBinder bndr+      -- We can only discard the case if the case-binder is dead+      -- It usually is, but see #18227+  , Var v `App` _ `App` _ `App` _ <- scrut+  , v `hasKey` unsafeEqualityProofIdKey+      -- Check that the scrutinee really is unsafeEqualityProof+      -- and not, say, error+  = Just rhs+  | otherwise+  = Nothing
− GHC/Core/Utils.hs-boot 
@@ -1,6 +0,0 @@-module GHC.Core.Utils where--import GHC.Core.Multiplicity-import GHC.Core.Type--mkFunctionType :: Mult -> Type -> Type -> Type
GHC/CoreToIface.hs view
@@ -1,4 +1,3 @@- {-# LANGUAGE Strict #-} -- See Note [Avoiding space leaks in toIface*]  -- | Functions for converting Core things to interface file things.@@ -8,8 +7,9 @@     , toIfaceTvBndrs     , toIfaceIdBndr     , toIfaceBndr+    , toIfaceTopBndr     , toIfaceForAllBndr-    , toIfaceTyCoVarBinders+    , toIfaceForAllBndrs     , toIfaceTyVar       -- * Types     , toIfaceType, toIfaceTypeX@@ -36,12 +36,14 @@     , toIfUnfolding     , toIfaceTickish     , toIfaceBind+    , toIfaceTopBind     , toIfaceAlt     , toIfaceCon     , toIfaceApp     , toIfaceVar       -- * Other stuff     , toIfaceLFInfo+    , toIfaceBooleanFormula     ) where  import GHC.Prelude@@ -56,18 +58,19 @@ import GHC.Core.Multiplicity import GHC.Core.PatSyn import GHC.Core.TyCo.Rep-import GHC.Core.TyCo.Tidy ( tidyCo )+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.Builtin.Names  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 )+import GHC.Types.Id.Make ( noinlineIdName, noinlineConstraintIdName ) import GHC.Types.Literal import GHC.Types.Name import GHC.Types.Basic@@ -75,16 +78,18 @@ import GHC.Types.Var.Env import GHC.Types.Var.Set import GHC.Types.Tickish-import GHC.Types.Demand ( isTopSig )+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.Utils.Trace -import Data.Maybe ( catMaybes )+import GHC.Hs.Extension (GhcRn) +import Data.Maybe ( isNothing, catMaybes )+ {- Note [Avoiding space leaks in toIface*]    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -117,7 +122,7 @@ toIfaceTvBndr = toIfaceTvBndrX emptyVarSet  toIfaceTvBndrX :: VarSet -> TyVar -> IfaceTvBndr-toIfaceTvBndrX fr tyvar = ( occNameFS (getOccName tyvar)+toIfaceTvBndrX fr tyvar = ( mkIfLclName (occNameFS (getOccName tyvar))                           , toIfaceTypeX fr (tyVarKind tyvar)                           ) @@ -129,7 +134,7 @@  toIfaceIdBndrX :: VarSet -> CoVar -> IfaceIdBndr toIfaceIdBndrX fr covar = ( toIfaceType (idMult covar)-                          , occNameFS (getOccName covar)+                          , mkIfLclName (occNameFS (getOccName covar))                           , toIfaceTypeX fr (varType covar)                           ) @@ -143,12 +148,15 @@   | isId var  = IfaceIdBndr (toIfaceIdBndrX fr var)   | otherwise = IfaceTvBndr (toIfaceTvBndrX fr var) -toIfaceTyCoVarBinder :: VarBndr Var vis -> VarBndr IfaceBndr vis-toIfaceTyCoVarBinder (Bndr tv vis) = Bndr (toIfaceBndr tv) vis+toIfaceForAllBndrs :: [VarBndr TyCoVar vis] -> [VarBndr IfaceBndr vis]+toIfaceForAllBndrs = map toIfaceForAllBndr -toIfaceTyCoVarBinders :: [VarBndr Var vis] -> [VarBndr IfaceBndr vis]-toIfaceTyCoVarBinders = map toIfaceTyCoVarBinder+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+ {- ************************************************************************ *                                                                      *@@ -169,7 +177,7 @@ --    translates the tyvars in 'free' as IfaceFreeTyVars -- -- Synonyms are retained in the interface type-toIfaceTypeX fr (TyVarTy tv)   -- See Note [Free tyvars in IfaceType] in GHC.Iface.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 {})  =@@ -211,17 +219,11 @@     arity = tyConArity tc     n_tys = length tys -toIfaceTyVar :: TyVar -> FastString-toIfaceTyVar = occNameFS . getOccName--toIfaceCoVar :: CoVar -> FastString-toIfaceCoVar = occNameFS . getOccName--toIfaceForAllBndr :: (VarBndr TyCoVar flag) -> (VarBndr IfaceBndr flag)-toIfaceForAllBndr = toIfaceForAllBndrX emptyVarSet+toIfaceTyVar :: TyVar -> IfLclName+toIfaceTyVar = mkIfLclName . occNameFS . getOccName -toIfaceForAllBndrX :: VarSet -> (VarBndr TyCoVar flag) -> (VarBndr IfaceBndr flag)-toIfaceForAllBndrX fr (Bndr v vis) = Bndr (toIfaceBndrX fr v) vis+toIfaceCoVar :: CoVar -> IfLclName+toIfaceCoVar = mkIfLclName . occNameFS . getOccName  ---------------- toIfaceTyCon :: TyCon -> IfaceTyCon@@ -230,7 +232,7 @@   where     tc_name = tyConName tc     info    = mkIfaceTyConInfo promoted sort-    promoted | isPromotedDataCon tc = IsPromoted+    promoted | isDataKindsPromotedDataCon tc = IsPromoted              | otherwise            = NotPromoted      tupleSort :: TyCon -> Maybe IfaceTyConSort@@ -263,7 +265,7 @@  toIfaceTyLit :: TyLit -> IfaceTyLit toIfaceTyLit (NumTyLit x) = IfaceNumTyLit x-toIfaceTyLit (StrTyLit x) = IfaceStrTyLit x+toIfaceTyLit (StrTyLit x) = IfaceStrTyLit (LexicalFastString x) toIfaceTyLit (CharTyLit x) = IfaceCharTyLit x  ----------------@@ -282,42 +284,44 @@     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 in IfaceType] in GHC.Iface.Type-      | cv `elemVarSet` fr  = IfaceFreeCoVar cv-      | otherwise           = IfaceCoVarCo (toIfaceCoVar cv)-    go (HoleCo h)           = IfaceHoleCo  (coHoleCoVar h)+      -- 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 (NthCo _r d co)      = IfaceNthCo 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 (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         = panic "toIfaceCoercion"-      | otherwise                =-        IfaceTyConAppCo r (toIfaceTyCon tc) (map go cos)-    go (FunCo r w co1 co2)   = IfaceFunCo r (go w) (go co1) (go co2)+    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 (ForAllCo tv k co) = IfaceForAllCo (toIfaceBndr tv)-                                          (toIfaceCoercionX fr' k)-                                          (toIfaceCoercionX fr' co)+    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 -    go_prov :: UnivCoProvenance -> IfaceUnivCoProv-    go_prov (PhantomProv co)    = IfacePhantomProv (go co)-    go_prov (ProofIrrelProv co) = IfaceProofIrrelProv (go co)-    go_prov (PluginProv str)    = IfacePluginProv str-    go_prov (CorePrepProv b)    = IfaceCorePrepProv b+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@@ -338,7 +342,10 @@ -- Is 'blib' visible?  It depends on the visibility flag on j, -- so we have to substitute for k.  Annoying! toIfaceAppArgsX fr kind ty_args-  = go (mkEmptyTCvSubst in_scope) kind ty_args+  | null ty_args+  = IA_Nil+  | otherwise+  = go (mkEmptySubst in_scope) kind ty_args   where     in_scope = mkInScopeSet (tyCoVarsOfTypes ty_args) @@ -353,17 +360,12 @@         ts' = go (extendTCvSubst env tv t) res ts      go env (FunTy { ft_af = af, ft_res = res }) (t:ts)-      = IA_Arg (toIfaceTypeX fr t) argf (go env res ts)-      where-        argf = case af of-                 VisArg   -> Required-                 InvisArg -> Inferred-                   -- It's rare for a kind to have a constraint argument, but-                   -- it can happen. See Note [AnonTCB InvisArg] in GHC.Core.TyCon.+      = assert (isVisibleFunArg af)+        IA_Arg (toIfaceTypeX fr t) Required (go env res ts)      go env ty ts@(t1:ts1)       | not (isEmptyTCvSubst env)-      = go (zapTCvSubst env) (substTy env ty) ts+      = go (zapSubst env) (substTy env ty) ts         -- See Note [Care with kind instantiation] in GHC.Core.Type        | otherwise@@ -410,8 +412,8 @@     (_univ_tvs, req_theta, _ex_tvs, prov_theta, args, rhs_ty) = patSynSig ps     univ_bndrs = patSynUnivTyVarBinders ps     ex_bndrs   = patSynExTyVarBinders ps-    (env1, univ_bndrs') = tidyTyCoVarBinders emptyTidyEnv univ_bndrs-    (env2, ex_bndrs')   = tidyTyCoVarBinders env1 ex_bndrs+    (env1, univ_bndrs') = tidyForAllTyBinders emptyTidyEnv univ_bndrs+    (env2, ex_bndrs')   = tidyForAllTyBinders env1 ex_bndrs     to_if_pr (name, _type, needs_dummy) = (name, needs_dummy)  {-@@ -426,29 +428,39 @@ toIfaceBang _    HsLazy              = IfNoBang toIfaceBang _   (HsUnpack Nothing)   = IfUnpack toIfaceBang env (HsUnpack (Just co)) = IfUnpackCo (toIfaceCoercion (tidyCo env co))-toIfaceBang _   HsStrict             = IfStrict+toIfaceBang _   (HsStrict _)         = IfStrict  toIfaceSrcBang :: HsSrcBang -> IfaceSrcBang toIfaceSrcBang (HsSrcBang _ unpk bang) = IfSrcBang unpk bang  toIfaceLetBndr :: Id -> IfaceLetBndr-toIfaceLetBndr id  = IfLetBndr (occNameFS (getOccName id))+toIfaceLetBndr id  = IfLetBndr (mkIfLclName (occNameFS (getOccName id)))                                (toIfaceType (idType id))                                (toIfaceIdInfo (idInfo id))-                               (toIfaceJoinInfo (isJoinId_maybe 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 (WorkerLikeId dmds)            = IfWorkerLikeId dmds 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+                           , 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@@ -458,7 +470,7 @@ toIfaceIdInfo :: IdInfo -> IfaceIdInfo toIfaceIdInfo id_info   = catMaybes [arity_hsinfo, caf_hsinfo, strict_hsinfo, cpr_hsinfo,-               inline_hsinfo,  unfold_hsinfo, levity_hsinfo]+               inline_hsinfo,  unfold_hsinfo]                -- NB: strictness and arity must appear in the list before unfolding                -- See GHC.IfaceToCore.tcUnfolding   where@@ -476,7 +488,7 @@     ------------  Strictness  --------------         -- No point in explicitly exporting TopSig     sig_info = dmdSigInfo id_info-    strict_hsinfo | not (isTopSig sig_info) = Just (HsDmdSig sig_info)+    strict_hsinfo | not (isNopSig sig_info) = Just (HsDmdSig sig_info)                   | otherwise               = Nothing      ------------  CPR --------------@@ -492,34 +504,18 @@     inline_hsinfo | isDefaultInlinePragma inline_prag = Nothing                   | otherwise = Just (HsInline inline_prag) -    ------------  Representation polymorphism  -----------    levity_hsinfo | isNeverRepPolyIdInfo 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_cache = cache                                 , 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+    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!-  where-    if_rhs = toIfaceExpr rhs  toIfUnfolding lb (DFunUnfolding { df_bndrs = bndrs, df_args = args })   = Just (HsUnfold lb (IfDFunUnfold (map toIfaceBndr bndrs) (map toIfaceExpr args)))@@ -536,6 +532,20 @@  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+ {- ************************************************************************ *                                                                      *@@ -546,7 +556,7 @@  toIfaceExpr :: CoreExpr -> IfaceExpr toIfaceExpr (Var v)         = toIfaceVar v-toIfaceExpr (Lit (LitRubbish r)) = IfaceLitRubbish (toIfaceType r)+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)@@ -554,12 +564,10 @@ 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)+  | 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)-  | Just t' <- toIfaceTickish t = IfaceTick t' (toIfaceExpr e)-  | otherwise                   = toIfaceExpr e+toIfaceExpr (Tick t e)      = IfaceTick (toIfaceTickish t) (toIfaceExpr e)  toIfaceOneShot :: Id -> IfaceOneShot toIfaceOneShot id | isId id@@ -569,22 +577,49 @@                   = IfaceNoOneShot  ----------------------toIfaceTickish :: CoreTickish -> 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 (#8333)+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+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 getOccFS bs) (toIfaceExpr r)+toIfaceAlt (Alt c bs r) = IfaceAlt (toIfaceCon c) (map (mkIfLclName . getOccFS) bs) (toIfaceExpr r)  --------------------- toIfaceCon :: AltCon -> IfaceConAlt@@ -592,7 +627,7 @@ toIfaceCon (LitAlt l)   = assertPpr (not (isLitRubbish l)) (ppr l) $                           -- assert: see Note [Rubbish literals] wrinkle (b)                           IfaceLitAlt l-toIfaceCon DEFAULT      = IfaceDefault+toIfaceCon DEFAULT      = IfaceDefaultAlt  --------------------- toIfaceApp :: Expr CoreBndr -> [Arg CoreBndr] -> IfaceExpr@@ -621,18 +656,23 @@ toIfaceVar v     | isBootUnfolding (idUnfolding v)     = -- See Note [Inlining and hs-boot files]-      IfaceApp (IfaceApp (IfaceExt noinlineIdName)-                         (IfaceType (toIfaceType (idType v))))+      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 (getOccFS name)-  where name = idName v+    | 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@@ -658,6 +698,7 @@     LFLetNoEscape ->       panic "toIfaceLFInfo: LFLetNoEscape" + {- Note [Inlining and hs-boot files] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider this example (#10083, #12789):@@ -709,7 +750,8 @@     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.+    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@@ -725,5 +767,35 @@ slower by 8% overall (on #9872a-d, and T1969: the reason is that these NOINLINE'd functions now can't be profitably inlined outside of the hs-boot loop.++Note [Interface File with Core: Sharing RHSs]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++IMPORTANT: This optimisation is currently disabled due to #22807, it can be+           re-enabled once #22056 is implemented.++In order to avoid duplicating definitions for bindings which already have unfoldings+we do some minor headstands to avoid serialising the RHS of a definition if it has+*any* unfolding.++* Only global things have unfoldings, because local things have had their unfoldings stripped.+* For any global thing which has an unstable unfolding, we just use that.++In order to implement this sharing:++* When creating the interface, check the criteria above and don't serialise the RHS+  if such a case.++* When reading an interface, look at the realIdUnfolding, and then the+  maybeUnfoldingTemplate.  See `tc_iface_binding` for where this happens.++There are two main reasons why the mi_extra_decls field exists rather than shoe-horning+all the core bindings++1. mi_extra_decls retains the recursive group structure of the original program which+   is very convenient as otherwise we would have to do the analysis again when loading+   the program.+2. There are additional local top-level bindings which don't make it into mi_decls. It's+   best to keep these separate from mi_decls as mi_decls is used to compute the ABI hash.  -}
GHC/CoreToIface.hs-boot view
@@ -11,7 +11,7 @@ -- For GHC.Core.TyCo.Rep toIfaceTypeX :: VarSet -> Type -> IfaceType toIfaceTyLit :: TyLit -> IfaceTyLit-toIfaceForAllBndr :: (VarBndr TyCoVar flag) -> (VarBndr IfaceBndr flag)+toIfaceForAllBndrs :: [VarBndr TyCoVar flag] -> [VarBndr IfaceBndr flag] toIfaceTyCon :: TyCon -> IfaceTyCon toIfaceTcArgs :: TyCon -> [Type] -> IfaceAppArgs toIfaceCoercionX :: VarSet -> Coercion -> IfaceCoercion
GHC/CoreToStg.hs view
@@ -14,16 +14,12 @@ -- And, as we have the info in hand, we may convert some lets to -- let-no-escapes. -module GHC.CoreToStg ( coreToStg ) where+module GHC.CoreToStg ( CoreToStgOpts (..), coreToStg ) where  import GHC.Prelude -import GHC.Driver.Session-import GHC.Driver.Config.Stg.Debug- import GHC.Core-import GHC.Core.Utils   ( exprType, findDefault, isJoinBind-                        , exprIsTickedString_maybe )+import GHC.Core.Utils import GHC.Core.Opt.Arity   ( manifestArity ) import GHC.Core.Type import GHC.Core.TyCon@@ -31,7 +27,8 @@  import GHC.Stg.Syntax import GHC.Stg.Debug-import GHC.Stg.Utils+import GHC.Stg.Make+import GHC.Stg.Utils (allowTopLevelConApp)  import GHC.Types.RepType import GHC.Types.Id.Make ( coercionTokenId )@@ -40,30 +37,23 @@ import GHC.Types.CostCentre import GHC.Types.Tickish import GHC.Types.Var.Env-import GHC.Types.Name   ( isExternalName, nameModule_maybe )-import GHC.Types.Basic  ( Arity )+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.Types.Demand    ( isUsedOnceDmd )-import GHC.Types.SrcLoc    ( mkGeneralSrcSpan )  import GHC.Unit.Module-import GHC.Builtin.Types ( unboxedUnitDataCon )-import GHC.Data.FastString+import GHC.Platform        ( Platform ) import GHC.Platform.Ways-import GHC.Builtin.PrimOps ( PrimCall(..) )+import GHC.Builtin.PrimOps  import GHC.Utils.Outputable import GHC.Utils.Monad import GHC.Utils.Misc (HasDebugCallStack) import GHC.Utils.Panic-import GHC.Utils.Panic.Plain-import GHC.Utils.Trace  import Control.Monad (ap)-import Data.Maybe (fromMaybe)-import Data.Tuple (swap)  -- Note [Live vs free] -- ~~~~~~~~~~~~~~~~~~~@@ -231,29 +221,50 @@ -- (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 :: DynFlags -> Module -> ModLocation -> CoreProgram+coreToStg :: CoreToStgOpts -> Module -> ModLocation -> CoreProgram           -> ([StgTopBinding], InfoTableProvMap, CollectedCCs)-coreToStg dflags this_mod ml pgm+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 dflags this_mod emptyVarEnv emptyCollectedCCs pgm+      = coreTopBindsToStg opts this_mod emptyVarEnv emptyCollectedCCs pgm      -- See Note [Mapping Info Tables to Source Positions]-    (!pgm'', !denv) =-        if gopt Opt_InfoTableMap dflags-          then collectDebugInformation (initStgDebugOpts dflags) ml pgm'-          else (pgm', emptyInfoTableProvMap)+    (!pgm'', !denv)+      | opt_InfoTableMap+      = collectDebugInformation stgDebugOpts ml pgm'+      | otherwise = (pgm', emptyInfoTableProvMap) -    prof = ways dflags `hasWay` WayProf+    prof = hasWay ways WayProf      final_ccs-      | prof && gopt Opt_AutoSccsOnIndividualCafs dflags+      | 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)@@ -263,7 +274,7 @@     (all_cafs_cc, all_cafs_ccs) = getAllCAFsCC this_mod  coreTopBindsToStg-    :: DynFlags+    :: CoreToStgOpts     -> Module     -> IdEnv HowBound           -- environment for the bindings     -> CollectedCCs@@ -272,17 +283,17 @@  coreTopBindsToStg _      _        env ccs []   = (env, ccs, [])-coreTopBindsToStg dflags this_mod env ccs (b:bs)+coreTopBindsToStg opts this_mod env ccs (b:bs)   | NonRec _ rhs <- b, isTyCoArg rhs-  = coreTopBindsToStg dflags this_mod env1 ccs1 bs+  = coreTopBindsToStg opts this_mod env1 ccs1 bs   | otherwise   = (env2, ccs2, b':bs')   where-    (env1, ccs1, b' ) = coreTopBindToStg dflags this_mod env ccs b-    (env2, ccs2, bs') = coreTopBindsToStg dflags this_mod env1 ccs1 bs+    (env1, ccs1, b' ) = coreTopBindToStg opts this_mod env ccs b+    (env2, ccs2, bs') = coreTopBindsToStg opts this_mod env1 ccs1 bs  coreTopBindToStg-        :: DynFlags+        :: CoreToStgOpts         -> Module         -> IdEnv HowBound         -> CollectedCCs@@ -298,16 +309,18 @@         how_bound = LetBound TopLet 0     in (env', ccs, StgTopStringLit id str) -coreTopBindToStg dflags this_mod env ccs (NonRec id rhs)+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 -        (stg_rhs, ccs') =-            initCts dflags env $-              coreToTopStgRhs dflags ccs this_mod (id,rhs)+        (ccs', (id', stg_rhs)) =+            initCts platform env $+              coreToTopStgRhs opts this_mod ccs (id,rhs) -        bind = StgTopLifted $ StgNonRec id stg_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@@ -315,42 +328,40 @@       --     assertion again!     (env', ccs', bind) -coreTopBindToStg dflags this_mod env ccs (Rec pairs)+coreTopBindToStg opts@CoreToStgOpts+  { coreToStg_platform = platform+  } this_mod env ccs (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'          -- generate StgTopBindings and CAF cost centres created for CAFs         (ccs', stg_rhss)-          = initCts dflags env' $-              mapAccumLM (\ccs rhs -> swap <$> coreToTopStgRhs dflags ccs this_mod rhs)-                         ccs-                         pairs-        bind = StgTopLifted $ StgRec (zip binders stg_rhss)+          = initCts platform env' $ mapAccumLM (coreToTopStgRhs opts this_mod) ccs pairs+        bind = StgTopLifted $ StgRec stg_rhss     in     (env', ccs', bind)  coreToTopStgRhs-        :: DynFlags-        -> CollectedCCs+        :: CoreToStgOpts         -> Module+        -> CollectedCCs         -> (Id,CoreExpr)-        -> CtsM (StgRhs, CollectedCCs)+        -> CtsM (CollectedCCs, (Id, StgRhs)) -coreToTopStgRhs dflags ccs this_mod (bndr, rhs)-  = do { new_rhs <- coreToPreStgRhs rhs+coreToTopStgRhs opts this_mod ccs (bndr, rhs)+  = do { new_rhs <- coreToMkStgRhs bndr rhs         ; let (stg_rhs, ccs') =-               mkTopStgRhs dflags this_mod ccs bndr new_rhs+               mkTopStgRhs (allowTopLevelConApp (coreToStg_platform opts) (coreToStg_ExternalDynamicRefs opts))+                           (coreToStg_AutoSccsOnIndividualCafs opts)+                           this_mod ccs bndr new_rhs              stg_arity =                stgRhsArity stg_rhs -       ; return (assertPpr (arity_ok stg_arity) (mk_arity_msg stg_arity) stg_rhs,-                 ccs') }+       ; 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@@ -377,7 +388,7 @@  -- 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 coreToPreStgRhs.+-- handle with the function coreToMkStgRhs.  coreToStgExpr         :: HasDebugCallStack => CoreExpr@@ -393,20 +404,25 @@ -- 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 [] []+coreToStgExpr (Var v) = coreToStgApp v [] [] (idType v) coreToStgExpr (Coercion _)   -- See Note [Coercion tokens]-  = coreToStgApp coercionTokenId [] []+  = coreToStgApp coercionTokenId [] [] (idType coercionTokenId)  coreToStgExpr expr@(App _ _)   = case app_head of-      Var f -> coreToStgApp f args ticks -- Regular application-      Lit l | isLitRubbish l             -- If there is LitRubbish at the head,-            -> return (StgLit l)         --    discard the arguments+      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-      (app_head, args, ticks) = myCollectArgs expr+      res_ty                  = exprType expr+      (app_head, args, ticks) = myCollectArgs expr res_ty+ coreToStgExpr expr@(Lam _ _)   = let         (args, body) = myCollectBinders expr@@ -428,45 +444,29 @@   = coreToStgExpr expr  -- Cases require a little more real work.--{--coreToStgExpr (Case scrut _ _ [])+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-    -- 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 e0@(Case scrut bndr _ [alt]) = do-  | isUnsafeEqualityProof scrut-  , isDeadBinder bndr -- We can only discard the case if the case-binder is dead-                      -- It usually is, but see #18227-  , (_,_,rhs) <- alt+  | Just rhs <- isUnsafeEqualityCase scrut bndr alts+  -- See (U2) in Note [Implementing unsafeCoerce] in base:Unsafe.Coerce   = coreToStgExpr rhs-    -- See (U2) in Note [Implementing unsafeCoerce] in base:Unsafe.Coerce--} --- The normal case for case-expressions-coreToStgExpr (Case scrut bndr _ alts)+  | 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)-      | DataAlt c <- con, c == unboxedUnitDataCon-      = -- This case is a bit smelly.-        -- See Note [Nullary unboxed tuple] in GHC.Core.Type-        -- where a nullary tuple is mapped to (State# World#)-        assert (null binders) $-        do { rhs2 <- coreToStgExpr rhs-           ; return GenStgAlt{alt_con=DEFAULT,alt_bndrs=mempty,alt_rhs=rhs2}-           }-      | otherwise       = let     -- Remove type variables             binders' = filterStgBinders binders         in@@ -501,8 +501,7 @@    prim_reps = typePrimRep bndr_ty     _is_poly_alt_tycon tc-        =  isFunTyCon tc-        || isPrimTyCon tc   -- "Any" is lifted but primitive+        =  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@@ -526,62 +525,86 @@  coreToStgApp :: Id            -- Function              -> [CoreArg]     -- Arguments-             -> [CoreTickish] -- Debug ticks+             -> [StgTickish]  -- From the application nodes+             -> Type          -- Type of the whole application              -> CtsM StgExpr-coreToStgApp f args ticks = do-    (args', ticks') <- coreToStgArgs args-    how_bound <- lookupVarCts f+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 -    let-        n_val_args       = valArgCount args+       -- 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 -        -- 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+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 [] -        res_ty = exprType (mkApps (Var f) args)-        app = case idDetails f of-                DataConWorkId dc-                  | saturated    -> StgConApp dc NoNumber args'-                                      (dropRuntimeRepArgs (fromMaybe [] (tyConAppArgs_maybe res_ty)))+      -- 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 -                -- Some primitive operator that might be implemented as a library call.-                -- As noted by Note [Eta expanding primops] in GHC.Builtin.PrimOps-                -- we require that primop applications be saturated.-                PrimOpId op      -> assert saturated $-                                    StgOpApp (StgPrimOp op) 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 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 exactly_saturated $+                          StgOpApp (StgFCallOp call (idType f)) stg_args res_ty -                -- A regular foreign call.-                FCallId call     -> assert saturated $-                                    StgOpApp (StgFCallOp call (idType f)) args' res_ty+      TickBoxOpId {}   -> pprPanic "coreToStg TickBox" $ ppr (f,stg_args) -                TickBoxOpId {}   -> pprPanic "coreToStg TickBox" $ ppr (f,args')-                _other           -> StgApp f 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 -        add_tick !t !e = StgTick t e-        tapp = foldr add_tick app (map (coreToStgTick res_ty) ticks ++ ticks') -    -- Forcing these fixes a leak in the code generator, noticed while-    -- profiling for trac #4367-    app `seq` return tapp-+-- 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 ([], [])@@ -594,42 +617,30 @@   = do { (args', ts) <- coreToStgArgs args        ; return (StgVarArg coercionTokenId : args', ts) } -coreToStgArgs (Tick t e : args)-  = assert (not (tickishIsCode t)) $-    do { (args', ts) <- coreToStgArgs (e : args)-       ; let !t' = coreToStgTick (exprType e) t-       ; return (args', t':ts) }- coreToStgArgs (arg : args) = do         -- Non-type argument     (stg_args, ticks) <- coreToStgArgs args-    arg' <- coreToStgExpr arg-    let-        (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--    platform <- targetPlatform <$> getDynFlags-    let-        arg_rep = typePrimRep (exprType arg)-        stg_arg_rep = typePrimRep (stgArgType stg_arg)+    -- We know that `arg` must be trivial, but it may contain Ticks.+    -- Example from test case `decodeMyStack`:+    --   $ @... ((src<decodeMyStack.hs:18:26-28> Data.Tuple.snd) @Int @[..])+    -- Note that unfortunately the Tick is not at the top.+    -- So we'll traverse the expression twice:+    --   * Once with `stripTicksT` (which collects *all* ticks from the expression)+    --   * and another time with `getStgArgFromTrivialArg`.+    -- Since the argument is trivial, the only place the Tick can occur is+    -- somehow wrapping a variable (give or take type args, as above).+    platform <- getPlatform+    let arg_ty = exprType arg+        ticks' = map (coreToStgTick arg_ty) (stripTicksT (not . tickishIsCode) arg)+        arg' = getStgArgFromTrivialArg arg+        arg_rep = typePrimRep arg_ty+        stg_arg_rep = stgArgRep arg'         bad_args = not (primRepsCompatible platform arg_rep stg_arg_rep) -    warnPprTrace bad_args "Dangerous-looking argument. Probable cause: bad unsafeCoerce#" (ppr arg) $-     return (stg_arg : stg_args, ticks ++ aticks)+    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@@ -694,165 +705,24 @@              -> CtsM StgRhs  coreToStgRhs (bndr, rhs) = do-    new_rhs <- coreToPreStgRhs rhs+    new_rhs <- coreToMkStgRhs bndr rhs     return (mkStgRhs bndr new_rhs) --- Represents the RHS of a binding for use with mk(Top)StgRhs.-data PreStgRhs = PreStgRhs [Id] StgExpr -- The [Id] is empty for thunks- -- Convert the RHS of a binding from Core to STG. This is a wrapper around -- coreToStgExpr that can handle value lambdas.-coreToPreStgRhs :: HasDebugCallStack => CoreExpr -> CtsM PreStgRhs-coreToPreStgRhs (Cast expr _) = coreToPreStgRhs expr-coreToPreStgRhs expr@(Lam _ _) =-    let-        (args, body) = myCollectBinders expr-        args'        = filterStgBinders args-    in-        extendVarEnvCts [ (a, LambdaBound) | a <- args' ] $ do-          body' <- coreToStgExpr body-          return (PreStgRhs args' body')-coreToPreStgRhs expr = PreStgRhs [] <$> coreToStgExpr expr---- Generate a top-level RHS. Any new cost centres generated for CAFs will be--- appended to `CollectedCCs` argument.-mkTopStgRhs :: DynFlags -> Module -> CollectedCCs-            -> Id -> PreStgRhs -> (StgRhs, CollectedCCs)--mkTopStgRhs dflags this_mod ccs bndr (PreStgRhs bndrs rhs)-  | not (null bndrs)-  = -- The list of arguments is non-empty, so not CAF-    ( StgRhsClosure noExtFieldSilent-                    dontCareCCS-                    ReEntrant-                    bndrs rhs-    , ccs )--  -- After this point we know that `bndrs` is empty,-  -- so this is not a function binding-  | StgConApp con mn args _ <- unticked_rhs-  , -- Dynamic StgConApps are updatable-    not (isDllConApp (targetPlatform dflags) (gopt Opt_ExternalDynamicRefs dflags) this_mod con args)-  = -- CorePrep does this right, but just to make sure-    assertPpr (not (isUnboxedTupleDataCon con || isUnboxedSumDataCon con))-              (ppr bndr $$ ppr con $$ ppr args)-    ( StgRhsCon dontCareCCS con mn ticks args, ccs )--  -- Otherwise it's a CAF, see Note [Cost-centre initialization plan].-  | gopt Opt_AutoSccsOnIndividualCafs dflags-  = ( StgRhsClosure noExtFieldSilent-                    caf_ccs-                    upd_flag [] rhs-    , collectCC caf_cc caf_ccs ccs )--  | otherwise-  = ( StgRhsClosure noExtFieldSilent-                    all_cafs_ccs-                    upd_flag [] rhs-    , ccs )--  where-    (ticks, unticked_rhs) = stripStgTicksTop (not . tickishIsCode) rhs--    upd_flag | isUsedOnceDmd (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 -> PreStgRhs -> StgRhs-mkStgRhs bndr (PreStgRhs bndrs rhs)-  | not (null bndrs)-  = StgRhsClosure noExtFieldSilent-                  currentCCS-                  ReEntrant-                  bndrs rhs--  -- After this point we know that `bndrs` is empty,-  -- so this is not a function binding--  | isJoinId bndr -- Must be a nullary join point-  = -- It might have /type/ arguments (T18328),-    -- so its JoinArity might be >0-    StgRhsClosure noExtFieldSilent-                  currentCCS-                  ReEntrant -- ignored for LNE-                  [] rhs--  | StgConApp con mn args _ <- unticked_rhs-  = StgRhsCon currentCCS con mn ticks args--  | otherwise-  = StgRhsClosure noExtFieldSilent-                  currentCCS-                  upd_flag [] rhs-  where-    (ticks, unticked_rhs) = stripStgTicksTop (not . tickishIsCode) rhs--    upd_flag | isUsedOnceDmd (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.--}+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@@ -863,7 +733,7 @@ -- *down*.  newtype CtsM a = CtsM-    { unCtsM :: DynFlags -- Needed for checking for bad coercions in coreToStgArgs+    { unCtsM :: Platform -- Needed for checking for bad coercions in coreToStgArgs              -> IdEnv HowBound              -> a     }@@ -901,8 +771,8 @@  -- The std monad functions: -initCts :: DynFlags -> IdEnv HowBound -> CtsM a -> a-initCts dflags env m = unCtsM m dflags env+initCts :: Platform -> IdEnv HowBound -> CtsM a -> a+initCts platform env m = unCtsM m platform env   @@ -913,8 +783,8 @@ returnCts e = CtsM $ \_ _ -> e  thenCts :: CtsM a -> (a -> CtsM b) -> CtsM b-thenCts m k = CtsM $ \dflags env-  -> unCtsM (k (unCtsM m dflags env)) dflags env+thenCts m k = CtsM $ \platform env+  -> unCtsM (k (unCtsM m platform env)) platform env  instance Applicative CtsM where     pure = returnCts@@ -923,15 +793,15 @@ instance Monad CtsM where     (>>=)  = thenCts -instance HasDynFlags CtsM where-    getDynFlags = CtsM $ \dflags _ -> dflags+getPlatform :: CtsM Platform+getPlatform = CtsM const  -- Functions specific to this monad:  extendVarEnvCts :: [(Id, HowBound)] -> CtsM a -> CtsM a extendVarEnvCts ids_w_howbound expr-   =    CtsM $   \dflags env-   -> unCtsM expr dflags (extendVarEnvList env ids_w_howbound)+   =    CtsM $   \platform env+   -> unCtsM expr platform (extendVarEnvList env ids_w_howbound)  lookupVarCts :: Id -> CtsM HowBound lookupVarCts v = CtsM $ \_ env -> lookupBinding env v@@ -941,15 +811,6 @@                         Just xx -> xx                         Nothing -> assertPpr (isGlobalId v) (ppr v) ImportBound -getAllCAFsCC :: Module -> (CostCentre, CostCentreStack)-getAllCAFsCC this_mod =-    let-      span = mkGeneralSrcSpan (mkFastString "<entire-module>") -- XXX do better-      all_cafs_cc  = mkAllCafsCC this_mod span-      all_cafs_ccs = mkSingletonCCS all_cafs_cc-    in-      (all_cafs_cc, all_cafs_ccs)- -- Misc.  filterStgBinders :: [Var] -> [Var]@@ -965,21 +826,46 @@  -- | If the argument expression is (potential chain of) 'App', return the head -- of the app chain, and collect ticks/args along the chain.-myCollectArgs :: HasDebugCallStack => CoreExpr -> (CoreExpr, [CoreArg], [CoreTickish])-myCollectArgs expr+-- 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 _v)       as ts = (h, as, ts)-    go (App f a)        as ts = go f (a: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]-                                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 e                as ts = (e, as, ts)+    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.@@ -1003,3 +889,12 @@ stgArity _ (LetBound _ arity) = arity stgArity f ImportBound        = idArity f stgArity _ LambdaBound        = 0++data CoreToStgOpts = CoreToStgOpts+  { coreToStg_platform :: Platform+  , coreToStg_ways :: Ways+  , coreToStg_AutoSccsOnIndividualCafs :: Bool+  , coreToStg_InfoTableMap :: Bool+  , coreToStg_ExternalDynamicRefs :: Bool+  , coreToStg_stgDebugOpts :: StgDebugOpts+  }
+ GHC/CoreToStg/AddImplicitBinds.hs view
@@ -0,0 +1,151 @@+{-+(c) The University of Glasgow, 1994-2006++Add implicit bindings+-}++module GHC.CoreToStg.AddImplicitBinds ( addImplicitBinds ) where++import GHC.Prelude++import GHC.CoreToStg.Prep( CorePrepPgmConfig(..) )++import GHC.Unit( ModLocation(..) )++import GHC.Core+import GHC.Core.DataCon( DataCon, dataConWorkId, dataConWrapId )+import GHC.Core.TyCon( TyCon, tyConDataCons, isBoxedDataTyCon, tyConClass_maybe )+import GHC.Core.Class( classAllSelIds )++import GHC.Types.Name+import GHC.Types.Tickish( GenTickish( SourceNote ) )+import GHC.Types.Id( dataConWrapUnfolding_maybe )+import GHC.Types.Id.Make( mkDictSelRhs )+import GHC.Types.SrcLoc ( SrcSpan(..), realSrcLocSpan, mkRealSrcLoc )++import GHC.Utils.Outputable+import GHC.Data.FastString+++{- *********************************************************************+*                                                                      *+        Implicit bindings+*                                                                      *+********************************************************************* -}++{- Note [Injecting implicit bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+`addImplicitBinds` injects the so-called "implicit bindings" generated by+the TyCons of the module. Specifically:++ * Data constructor wrappers+ * Data constructor workers: see Note [Data constructor workers]+ * Class op selectors: we want curriedn versions of these too++Note that /record selector/ are injected much earlier, at the beginning+of the pipeline -- see Note [Record selectors] in GHC.Tc.TyCl.Utils.++At one time I tried injecting the implicit bindings *early*, at the+beginning of SimplCore.  But that gave rise to real difficulty,+because GlobalIds are supposed to have *fixed* IdInfo, but the+simplifier and other core-to-core passes mess with IdInfo all the+time.  The straw that broke the camels back was when a class selector+got the wrong arity -- ie the simplifier gave it arity 2, whereas+importing modules were expecting it to have arity 1 (#2844).+It's much safer just to inject them right at the end, after tidying.++Oh: two other reasons for injecting them late:++  - If implicit Ids are already in the bindings when we start tidying,+    we'd have to be careful not to treat them as external Ids (in+    the sense of chooseExternalIds); else the Ids mentioned in *their*+    RHSs will be treated as external and you get an interface file+    saying      a18 = <blah>+    but nothing referring to a18 (because the implicit Id is the+    one that does, and implicit Ids don't appear in interface files).++  - More seriously, the tidied type-envt will include the implicit+    Id replete with a18 in its unfolding; but we won't take account+    of a18 when computing a fingerprint for the class; result chaos.++Note [Data constructor workers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Create any necessary "implicit" bindings for data con workers.  We+create the rather strange (non-recursive!) binding++        $wC = \x y -> $wC x y++i.e. a curried constructor that allocates.  This means that we can+treat the worker for a constructor like any other function in the rest+of the compiler.  The point here is that CoreToStg will generate a+StgConApp for the RHS, rather than a call to the worker (which would+give a loop).  As Lennart says: the ice is thin here, but it works.++Hmm.  Should we create bindings for dictionary constructors?  They are+always fully applied, and the bindings are just there to support+partial applications. But it's easier to let them through.+-}+++addImplicitBinds :: CorePrepPgmConfig -> ModLocation+                 -> [TyCon] -> CoreProgram -> IO CoreProgram+addImplicitBinds pgm_cfg mod_loc tycons binds+  = return (implicit_binds ++ binds)+  where+    gen_debug_info = cpPgm_generateDebugInfo pgm_cfg+    implicit_binds = concatMap (mkImplicitBinds gen_debug_info mod_loc) tycons+++mkImplicitBinds :: Bool -> ModLocation -> TyCon -> [CoreBind]+-- See Note [Data constructor workers]+-- c.f. Note [Injecting implicit bindings] in GHC.Iface.Tidy+mkImplicitBinds gen_debug_info mod_loc tycon+  = classop_binds ++ datacon_binds+  where+    datacon_binds+      | isBoxedDataTyCon tycon+      = concatMap (dataConBinds gen_debug_info mod_loc) (tyConDataCons tycon)+      | otherwise+      = []+      -- The 'otherwise' includes family TyCons of course, but also (less obviously)+      --  * Newtypes: see Note [Compulsory newtype unfolding] in GHC.Types.Id.Make+      --  * type data: we don't want any code for type-only stuff (#24620)++    classop_binds+      | Just cls <- tyConClass_maybe tycon+      = [ NonRec op (mkDictSelRhs cls val_index)+        | (op, val_index) <- classAllSelIds cls `zip` [0..] ]+     | otherwise+     = []++dataConBinds :: Bool -> ModLocation -> DataCon -> [CoreBind]+dataConBinds gen_debug_info mod_loc data_con+  = wrapper_bind ++ worker_bind+  where+    work_id = dataConWorkId data_con+    wrap_id = dataConWrapId data_con+    worker_bind  = [NonRec work_id (add_tick (Var work_id))]+      -- worker_bind: the ice is thin here, but it works:+      --              CorePrep will eta-expand it+    wrapper_bind = case dataConWrapUnfolding_maybe wrap_id of+                     Nothing  -> []+                     Just rhs -> [NonRec wrap_id rhs]+    add_tick = tick_it gen_debug_info mod_loc (getName data_con)++tick_it :: Bool -> ModLocation -> Name -> CoreExpr -> CoreExpr+-- If we want to generate debug info, we put a source note on the+-- worker. This is useful, especially for heap profiling.+tick_it generate_debug_info mod_loc name+  | not generate_debug_info               = id+  | RealSrcSpan span _ <- nameSrcSpan name = tick span+  | Just file <- ml_hs_file mod_loc       = tick (span1 file)+  | otherwise                             = tick (span1 "???")+  where+    tick span  = Tick $ SourceNote span $+                 LexicalFastString $ mkFastString $+                 renderWithContext defaultSDocContext $ ppr name+    span1 file = realSrcLocSpan $ mkRealSrcLoc (mkFastString file) 1 1++++
GHC/CoreToStg/Prep.hs view
@@ -1,2286 +1,2858 @@--{-# LANGUAGE BangPatterns #-}--{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}--{--(c) The University of Glasgow, 1994-2006---Core pass to saturate constructors and PrimOps--}--module GHC.CoreToStg.Prep-   ( corePrepPgm-   , corePrepExpr-   , mkConvertNumLiteral-   )-where--import GHC.Prelude--import GHC.Platform--import GHC.Driver.Session-import GHC.Driver.Env-import GHC.Driver.Ppr--import GHC.Tc.Utils.Env-import GHC.Unit--import GHC.Builtin.Names-import GHC.Builtin.Types--import GHC.Core.Utils-import GHC.Core.Opt.Arity-import GHC.Core.FVs-import GHC.Core.Opt.Monad ( CoreToDo(..) )-import GHC.Core.Lint    ( endPassIO )-import GHC.Core-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.Core.TyCo.Rep( UnivCoProvenance(..) )--import GHC.Data.Maybe-import GHC.Data.OrdList-import GHC.Data.FastString-import GHC.Data.Pair--import GHC.Utils.Error-import GHC.Utils.Misc-import GHC.Utils.Panic-import GHC.Utils.Panic.Plain-import GHC.Utils.Outputable-import GHC.Utils.Monad  ( mapAccumLM )-import GHC.Utils.Logger-import GHC.Utils.Trace--import GHC.Types.Demand-import GHC.Types.Var-import GHC.Types.Var.Set-import GHC.Types.Var.Env-import GHC.Types.Id-import GHC.Types.Id.Info-import GHC.Types.Id.Make ( realWorldPrimId )-import GHC.Types.Basic-import GHC.Types.Name   ( NamedThing(..), nameSrcSpan, isInternalName )-import GHC.Types.SrcLoc ( SrcSpan(..), realSrcLocSpan, mkRealSrcLoc )-import GHC.Types.Literal-import GHC.Types.Tickish-import GHC.Types.TyThing-import GHC.Types.Unique.Supply--import Data.List        ( unfoldr )-import Data.Functor.Identity-import Control.Monad--{--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.  [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 GHC.Types.Id.Make-    Also replace (noinline e) by e.--10. Convert bignum literals into their core representation.--11. Uphold tick consistency while doing this: We move ticks out of-    (non-type) applications where we can, and make sure that we-    annotate according to scoping rules when floating.--12. Collect cost centres (including cost centres in unfoldings) if we're in-    profiling mode. We have to do this here beucase we won't have unfoldings-    after this pass (see `trimUnfolding` and Note [Drop unfoldings and rules].--13. Eliminate case clutter in favour of unsafe coercions.-    See Note [Unsafe coercions]--14. Eliminate some magic Ids, specifically-     runRW# (\s. e)  ==>  e[readWorldId/s]-             lazy e  ==>  e-         noinline 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 [Unsafe coercions]-~~~~~~~~~~~~~~~~~~~~~~~-CorePrep does these two transformations:--1. Convert empty case to cast with an unsafe coercion-          (case e of {}) ===>  e |> unsafe-co-   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, if the scrutinee *does* return, we may get a seg-fault.-   A belt-and-braces approach would be to persist empty-alternative-   cases to code generator, and put a return point anyway that calls a-   runtime system error function.--   Notice that eliminating empty case can lead to an ill-kinded coercion-       case error @Int "foo" of {}  :: Int#-       ===> error @Int "foo" |> unsafe-co-       where unsafe-co :: Int ~ Int#-   But that's fine because the expression diverges anyway. And it's-   no different to what happened before.--2. Eliminate unsafeEqualityProof in favour of an unsafe coercion-           case unsafeEqualityProof of UnsafeRefl g -> e-           ===>  e[unsafe-co/g]-   See (U2) in Note [Implementing unsafeCoerce] in base:Unsafe.Coerce--   Note that this requires us to substitute 'unsafe-co' for 'g', and-   that is the main (current) reason for cpe_tyco_env in CorePrepEnv.-   Tiresome, but not difficult.--These transformations get rid of "case clutter", leaving only casts.-We are doing no further significant tranformations, so the reasons-for the case forms have disappeared. And it is extremely helpful for-the ANF-ery, CoreToStg, and backends, if trivial expressions really do-look trivial. #19700 was an example.--In both cases, the "unsafe-co" is just (UnivCo ty1 ty2 (CorePrepProv b)),-The boolean 'b' says whether the unsafe coercion is supposed to be-kind-homogeneous (yes for (2), no for (1).  This information is used-/only/ by Lint.--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 logger-               (text "CorePrep"<+>brackets (ppr this_mod))-               (\a -> a `seqList` ()) $ do-    us <- mkSplitUniqSupply 's'-    initialCorePrepEnv <- mkInitialCorePrepEnv 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-    logger = hsc_logger hsc_env--corePrepExpr :: HscEnv -> CoreExpr -> IO CoreExpr-corePrepExpr hsc_env expr = do-    let logger = hsc_logger hsc_env-    withTiming logger (text "CorePrep [expr]") (\e -> e `seq` ()) $ do-      us <- mkSplitUniqSupply 's'-      initialCorePrepEnv <- mkInitialCorePrepEnv hsc_env-      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 `appendFloats` floatss)--mkDataConWorkers :: DynFlags -> ModLocation -> [TyCon] -> [CoreBind]--- See Note [Data constructor workers]--- c.f. Note [Injecting implicit bindings] in GHC.Iface.Tidy-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-     | not (needSourceNotes dflags)           = 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 [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 #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--************************************************************************-*                                                                      *-                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 { (env1, bndr1) <- cpCloneBndr env bndr-       ; let dmd         = idDemandInfo bndr-             is_unlifted = isUnliftedType (idType bndr)-       ; (floats, rhs1) <- cpePair top_lvl NonRecursive-                                   dmd is_unlifted-                                   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-                     = addFloat floats new_float--             new_float = mkFloat dmd is_unlifted 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-       ; stuff <- zipWithM (cpePair top_lvl Recursive topDmd False env')-                           bndrs1 rhss--       ; let (floats_s, rhss1) = unzip stuff-             all_pairs = foldrOL add_float (bndrs1 `zip` rhss1)-                                           (concatFloats floats_s)--       ; return (extendCorePrepEnvList env (bndrs `zip` bndrs1),-                 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 -> OutId -> CoreExpr-        -> UniqSM (Floats, CpeRhs)--- Used for all bindings--- The binder is already cloned, hence an OutId-cpePair top_lvl is_rec dmd is_unlifted env bndr rhs-  = assert (not (isJoinId bndr)) $ -- those should use cpeJoinPair-    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 warnPprTrace True "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--       ; return (floats4, rhs4) }-  where-    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-      | allLazyTop floats-      = return (floats, rhs)--      | Just floats <- canFloat floats rhs-      = return floats--      | 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--- 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 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 (Type ty)-  = return (emptyFloats, Type (cpSubstTy env ty))-cpeRhsE env (Coercion co)-  = return (emptyFloats, Coercion (cpSubstCo env co))-cpeRhsE env expr@(Lit (LitNumber nt i))-   = case cpe_convertNumLit env nt i of-      Nothing -> return (emptyFloats, expr)-      Just e  -> cpeRhsE env e-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)-  -- Pull out ticks if they are allowed to be floated.-  | floatableTick tickish-  = do { (floats, body) <- cpeRhsE env expr-         -- See [Floating Ticks in CorePrep]-       ; return (unitFloat (FloatTick tickish) `appendFloats` floats, body) }-  | otherwise-  = do { body <- cpeBodyNF env expr-       ; return (emptyFloats, mkTick tickish' body) }-  where-    tickish' | Breakpoint ext n fvs <- tickish-             -- See also 'substTickish'-             = Breakpoint ext n (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') }---- Eliminate empty case--- See Note [Unsafe coercions]-cpeRhsE env (Case scrut _ ty [])-  = do { (floats, scrut') <- cpeRhsE env scrut-       ; let ty'       = cpSubstTy env ty-             scrut_ty' = exprType scrut'-             co'       = mkUnivCo prov Representational scrut_ty' ty'-             prov      = CorePrepProv False-               -- False says that the kinds of two types may differ-               -- E.g. we might cast Int to Int#.  This is fine-               -- because the scrutinee is guaranteed to diverge--       ; return (floats, Cast scrut' co') }-   -- This can give rise to-   --   Warning: Unsafe coercion: between unboxed and boxed value-   -- but it's fine because 'scrut' diverges---- Eliminate unsafeEqualityProof--- See Note [Unsafe coercions]-cpeRhsE env (Case scrut bndr _ alts)-  | isUnsafeEqualityProof scrut-  , isDeadBinder bndr -- We can only discard the case if the case-binder-                      -- is dead.  It usually is, but see #18227-  , [Alt _ [co_var] rhs] <- alts-  , let Pair ty1 ty2 = coVarTypes co_var-        the_co = mkUnivCo prov Nominal (cpSubstTy env ty1) (cpSubstTy env ty2)-        prov   = CorePrepProv True  -- True <=> kind homogeneous-        env'   = extendCoVarEnv env co_var the_co-  = cpeRhsE env' rhs--cpeRhsE env (Case scrut bndr ty alts)-  = do { (floats, scrut') <- cpeBody env scrut-       ; (env', bndr2) <- cpCloneBndr env bndr-       ; let alts'-                 -- 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.-               | gopt Opt_CatchNonexhaustiveCases (cpe_dynFlags env)-               , not (altsAreExhaustive alts)-               = addDefault alts (Just err)-               | otherwise = alts-               where err = mkRuntimeErrorApp rUNTIME_ERROR_ID ty-                                             "Bottoming expression returned"-       ; alts'' <- mapM (sat_alt env') alts'--       ; return (floats, Case scrut' bndr2 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 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 { let rhs = cpeEtaExpand (exprArity expr) expr-       ; fn <- newVar (exprType rhs)-       ; let 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 CoreTickish--instance Outputable ArgInfo where-  ppr (CpeApp arg) = text "app" <+> ppr arg-  ppr (CpeCast co) = text "cast" <+> ppr co-  ppr (CpeTick tick) = text "tick" <+> ppr tick--{- Note [Ticks and mandatory eta expansion]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Something like-    `foo x = ({-# SCC foo #-} tagToEnum#) x :: Bool`-caused a compiler panic in #20938. Why did this happen?-The simplifier will eta-reduce the rhs giving us a partial-application of tagToEnum#. The tick is then pushed inside the-type argument. That is we get-    `(Tick<foo> tagToEnum#) @Bool`-CorePrep would go on to see a undersaturated tagToEnum# application-and eta expand the expression under the tick. Giving us:-    (Tick<scc> (\forall a. x -> tagToEnum# @a x) @Bool-Suddenly tagToEnum# is applied to a polymorphic type and the code generator-panics as it needs a concrete type to determine the representation.--The problem in my eyes was that the tick covers a partial application-of a primop. There is no clear semantic for such a construct as we can't-partially apply a primop since they do not have bindings.-We fix this by expanding the scope of such ticks slightly to cover the body-of the eta-expanded expression.--We do this by:-* Checking if an application is headed by a primOpish thing.-* If so we collect floatable ticks and usually but also profiling ticks-  along with regular arguments.-* When rebuilding the application we check if any profiling ticks appear-  before the primop is fully saturated.-* If the primop isn't fully satured we eta expand the primop application-  and scope the tick to scope over the body of the saturated expression.--Going back to #20938 this means starting with-    `(Tick<foo> tagToEnum#) @Bool`-we check if the function head is a primop (yes). This means we collect the-profiling tick like if it was floatable. Giving us-    (tagToEnum#, [CpeTick foo, CpeApp @Bool]).-cpe_app filters out the tick as a underscoped tick on the expression-`tagToEnum# @Bool`. During eta expansion we then put that tick back onto the-body of the eta-expansion lambdas. Giving us `\x -> Tick<foo> (tagToEnum# @Bool x)`.--}-cpeApp :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)--- May return a CpeRhs because of saturating primops-cpeApp top_env expr-  = do { let (terminal, args) = 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 (CpeApp arg : as)-        go (Cast fun co)      as-            = go fun (CpeCast co : as)-        go (Tick tickish fun) as-            -- Profiling ticks are slightly less strict so we expand their scope-            -- if they cover partial applications of things like primOps.-            -- See Note [Ticks and mandatory eta expansion]-            | floatableTick tickish || isProfTick tickish-            , Var vh <- head-            , Var head' <- lookupCorePrepEnv top_env vh-            , hasNoBinding head'-            = (head,as')-            where-              (head,as') = go fun (CpeTick tickish : as)--        -- Terminal could still be an app if it's wrapped by a tick.-        -- E.g. Tick<foo> (f x) can give us (f x) as terminal.-        go terminal as = (terminal, as)--    cpe_app :: CorePrepEnv-            -> CoreExpr -- The thing we are calling-            -> [ArgInfo]-            -> UniqSM (Floats, CpeRhs)-    cpe_app env (Var f) (CpeApp Type{} : CpeApp arg : args)-        | f `hasKey` lazyIdKey          -- Replace (lazy a) with a, and-            -- See Note [lazyId magic] in GHC.Types.Id.Make-       || f `hasKey` noinlineIdKey      -- Replace (noinline a) with a-            -- See Note [noinlineId 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) (CpeApp _runtimeRep@Type{} : CpeApp _type@Type{} : CpeApp arg : rest)-        | f `hasKey` runRWKey-        -- N.B. While it may appear that n == 1 in the case of runRW#-        -- applications, keep in mind that we may have applications that return-        , has_value_arg (CpeApp arg : rest)-        -- See Note [runRW magic]-        -- Replace (runRW# f) by (f realWorld#), beta reducing if possible (this-        -- is why we return a CorePrepEnv as well)-        = case arg of-            Lam s body -> cpe_app (extendCorePrepEnv env s realWorldPrimId) body rest-            _          -> cpe_app env arg (CpeApp (Var realWorldPrimId) : rest)-             -- TODO: What about casts?-        where-          has_value_arg [] = False-          has_value_arg (CpeApp arg:_rest)-            | not (isTyCoArg arg) = True-          has_value_arg (_:rest) = has_value_arg rest--    cpe_app env (Var v) args-      = 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-            CpeCast {} -> go infos n-            CpeTick tickish-              | floatableTick tickish                 -> go infos n-              -- If we can't guarantee a tick will be floated out of the application-              -- we can't guarantee the value args following it will be applied.-              | otherwise                             -> n-            CpeApp e                                  -> go infos n'-              where-                !n'-                  | isTypeArg e = n-                  | otherwise   = n+1--    -- Saturate if necessary-    mb_saturate head app floats 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-        -> [Demand]-        -> Maybe Arity-        -> UniqSM (CpeApp-                  ,Floats-                  ,[CoreTickish] -- Underscoped ticks. See Note [Ticks and mandatory eta expansion]-                  )-    rebuild_app env args app floats ss req_depth =-      rebuild_app' env args app floats ss [] (fromMaybe 0 req_depth)--    rebuild_app'-        :: CorePrepEnv-        -> [ArgInfo] -- The arguments (inner to outer)-        -> CpeApp-        -> Floats-        -> [Demand]-        -> [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--      CpeApp (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--      CpeApp (Coercion co)-        -> rebuild_app' env as (App fun' (Coercion co')) floats ss' rt_ticks req_depth-        where-            co' = cpSubstCo env co-            ss'-              | null ss = []-              | otherwise = tail ss--      CpeApp arg -> do-        let (ss1, ss_rest)  -- See Note [lazyId magic] in GHC.Types.Id.Make-               = case (ss, isLazyExpr arg) of-                   (_   : ss_rest, True)  -> (topDmd, ss_rest)-                   (ss1 : ss_rest, False) -> (ss1,    ss_rest)-                   ([],            _)     -> (topDmd, [])-        (fs, arg') <- cpeArg top_env ss1 arg-        rebuild_app' env as (App fun' arg') (fs `appendFloats` floats) ss_rest rt_ticks (req_depth-1)--      CpeCast 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]-      CpeTick tickish-        | tickishPlace tickish == PlaceRuntime-        , req_depth > 0-        -> assert (isProfTick tickish) $-           rebuild_app' env as fun' floats ss (tickish:rt_ticks) req_depth-        | otherwise-        -- See [Floating Ticks in CorePrep]-        -> rebuild_app' env as fun' (addFloat floats (FloatTick tickish)) ss 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 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 -> UniqSM (Floats, CpeArg)-cpeArg env dmd arg-  = do { (floats1, arg1) <- cpeRhsE env arg     -- arg1 can be a lambda-       ; let arg_ty      = exprType arg1-             is_unlifted = isUnliftedType arg_ty-             want_float  = wantFloatNested NonRecursive dmd is_unlifted-       ; (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)-       }--{--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 #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--- -----------------------------------------------------------------------------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.--}--maybeSaturate :: Id -> CpeApp -> Int -> [CoreTickish] -> UniqSM CpeRhs-maybeSaturate fn expr n_args unsat_ticks-  | hasNoBinding fn        -- There's no binding-  = return $ wrapLamBody (\body -> foldr mkTick body unsat_ticks) sat_expr--  | mark_arity > 0 -- A call-by-value function. See Note [CBV Function Ids]-  , not applied_marks-  = assertPpr-      ( not (isJoinId fn)) -- See Note [Do not eta-expand join points]-      ( ppr fn $$ text "expr:" <+> ppr expr $$ text "n_args:" <+> ppr n_args $$-          text "marks:" <+> ppr (idCbvMarks_maybe fn) $$-          text "join_arity" <+> ppr (isJoinId_maybe fn) $$-          text "fn_arity" <+> ppr fn_arity-       ) $-    -- pprTrace "maybeSat"-    --   ( ppr fn $$ text "expr:" <+> ppr expr $$ text "n_args:" <+> ppr n_args $$-    --       text "marks:" <+> ppr (idCbvMarks_maybe fn) $$-    --       text "join_arity" <+> ppr (isJoinId_maybe fn) $$-    --       text "fn_arity" <+> ppr fn_arity $$-    --       text "excess_arity" <+> ppr excess_arity $$-    --       text "mark_arity" <+> ppr mark_arity-    --    ) $-    return sat_expr--  | otherwise-  = 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 "maybeSaturate" $ (idCbvMarks_maybe fn))-    -- For join points we never eta-expand (See Note [Do not eta-expand join points])-    -- so we assert all arguments that need to be passed cbv are visible so that the backend can evalaute them if required..-{--************************************************************************-*                                                                      *-                Simple GHC.Core 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 GHC.Core.Opt.Arity.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 }--}---- When updating this function, make sure it lines up with--- GHC.Core.Utils.tryEtaReduce!-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-  =-    -- pprTrace "prep-reduce" (-    --   text "reduced:" <> ppr remaining_expr $$-    --   ppr (remaining_args)-    --   ) $-    Just remaining_expr-  where-    (f, args) = collectArgs expr-    remaining_expr = mkApps f remaining_args-    fvs_remaining = exprFreeVars remaining_expr-    (remaining_args, last_args) = splitAt n_remaining args-    n_remaining = length args - length bndrs-    n_remaining_vals = length $ filter isRuntimeArg remaining_args--    ok bndr (Var arg) = bndr == arg-    ok _    _         = False--    ok_to_eta_reduce (Var f) = canEtaReduceToArity f n_remaining n_remaining_vals-    ok_to_eta_reduce _       = False -- Safe. ToDo: generalise---tryEtaReducePrep bndrs (Tick tickish e)-  | tickishFloatable tickish-  = 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.--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'--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.--}--data FloatingBind-  = FloatLet CoreBind    -- Rhs of bindings are CpeRhss-                         -- They are always of lifted type;-                         -- unlifted ones are done with FloatCase-- | FloatCase-      CpeBody         -- Always ok-for-speculation-      Id              -- Case binder-      AltCon [Var]    -- Single alternative-      Bool            -- Ok-for-speculation; False of a strict,-                      -- but lifted binding-- -- | See Note [Floating Ticks in CorePrep]- | FloatTick CoreTickish--data Floats = Floats OkToSpec (OrdList FloatingBind)--instance Outputable FloatingBind where-  ppr (FloatLet b) = ppr b-  ppr (FloatCase r b k bs ok) = text "case" <> braces (ppr ok) <+> ppr r-                                <+> text "of"<+> ppr b <> text "@"-                                <> case bs of-                                   [] -> ppr k-                                   _  -> parens (ppr k <+> ppr bs)-  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-  | is_strict || ok_for_spec -- See Note [Speculative evaluation]-  , not is_hnf  = FloatCase rhs bndr DEFAULT [] ok_for_spec-    -- Don't make a case for a HNF binding, even if it's strict-    -- Otherwise we get  case (\x -> e) of ...!--  | is_unlifted = FloatCase rhs bndr DEFAULT [] True-      -- we used to assertPpr ok_for_spec (ppr rhs) here, but it is now disabled-      -- because exprOkForSpeculation isn't stable under ANF-ing. See for-      -- example #19489 where the following unlifted expression:-      ---      --    GHC.Prim.(#|_#) @LiftedRep @LiftedRep @[a_ax0] @[a_ax0]-      --                    (GHC.Types.: @a_ax0 a2_agq a3_agl)-      ---      -- is ok-for-spec but is ANF-ised into:-      ---      --    let sat = GHC.Types.: @a_ax0 a2_agq a3_agl-      --    in GHC.Prim.(#|_#) @LiftedRep @LiftedRep @[a_ax0] @[a_ax0] sat-      ---      -- which isn't ok-for-spec because of the let-expression.--  | 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   = isStrUsedDmd dmd-    ok_for_spec = exprOkForSpeculation rhs--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 rhs bndr con bs _) body = Case rhs bndr (exprType body) [Alt con bs 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 = get_bind b                 : bs-    get (FloatCase body var _ _ _) bs = get_bind (NonRec var body) : bs-    get b _ = pprPanic "corePrepPgm" (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]-------------------------------------------------------------------------------canFloat :: Floats -> CpeRhs -> Maybe (Floats, CpeRhs)-canFloat (Floats ok_to_spec fs) rhs-  | OkToSpec <- ok_to_spec           -- Worth trying-  , Just fs' <- go nilOL (fromOL fs)-  = Just (Floats OkToSpec fs', rhs)-  | otherwise-  = Nothing-  where-    go :: OrdList FloatingBind -> [FloatingBind]-       -> Maybe (OrdList FloatingBind)--    go (fbs_out) [] = Just fbs_out--    go fbs_out (fb@(FloatLet _) : fbs_in)-      = go (fbs_out `snocOL` fb) fbs_in--    go fbs_out (ft@FloatTick{} : fbs_in)-      = go (fbs_out `snocOL` ft) fbs_in--    go _ (FloatCase{} : _) = Nothing---wantFloatNested :: RecFlag -> Demand -> Bool -> Floats -> CpeRhs -> Bool-wantFloatNested is_rec dmd is_unlifted floats rhs-  =  isEmptyFloats floats-  || isStrUsedDmd 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 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 [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_tyco_env :: Maybe CpeTyCoEnv -- See Note [CpeTyCoEnv]--        , cpe_convertNumLit   :: LitNumType -> Integer -> Maybe CoreExpr-        -- ^ Convert some numeric literals (Integer, Natural) into their-        -- final Core form-    }--mkInitialCorePrepEnv :: HscEnv -> IO CorePrepEnv-mkInitialCorePrepEnv hsc_env = do-   convertNumLit <- mkConvertNumLiteral hsc_env-   return $ CPE-      { cpe_dynFlags      = hsc_dflags hsc_env-      , cpe_env           = emptyVarEnv-      , cpe_tyco_env      = Nothing-      , cpe_convertNumLit = convertNumLit-      }--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-----------------------------------------------------------------------------------           CpeTyCoEnv--- -----------------------------------------------------------------------------{- Note [CpeTyCoEnv]-~~~~~~~~~~~~~~~~~~~~-The cpe_tyco_env :: Maybe CpeTyCoEnv field carries a substitution-for type and coercion varibles--* We need the coercion substitution to support the elimination of-  unsafeEqualityProof (see Note [Unsafe coercions])--* We need the type substitution in case one of those unsafe-  coercions occurs in the kind of tyvar binder (sigh)--We don't need an in-scope set because we don't clone any of these-binders at all, so no new capture can take place.--The cpe_tyco_env is almost always empty -- it only gets populated-when we get under an usafeEqualityProof.  Hence the Maybe CpeTyCoEnv,-which makes everything into a no-op in the common case.--}--data CpeTyCoEnv = TCE TvSubstEnv CvSubstEnv--emptyTCE :: CpeTyCoEnv-emptyTCE = TCE emptyTvSubstEnv emptyCvSubstEnv--extend_tce_cv :: CpeTyCoEnv -> CoVar -> Coercion -> CpeTyCoEnv-extend_tce_cv (TCE tv_env cv_env) cv co-  = TCE tv_env (extendVarEnv cv_env cv co)--extend_tce_tv :: CpeTyCoEnv -> TyVar -> Type -> CpeTyCoEnv-extend_tce_tv (TCE tv_env cv_env) tv ty-  = TCE (extendVarEnv tv_env tv ty) cv_env--lookup_tce_cv :: CpeTyCoEnv -> CoVar -> Coercion-lookup_tce_cv (TCE _ cv_env) cv-  = case lookupVarEnv cv_env cv of-        Just co -> co-        Nothing -> mkCoVarCo cv--lookup_tce_tv :: CpeTyCoEnv -> TyVar -> Type-lookup_tce_tv (TCE tv_env _) tv-  = case lookupVarEnv tv_env tv of-        Just ty -> ty-        Nothing -> mkTyVarTy tv--extendCoVarEnv :: CorePrepEnv -> CoVar -> Coercion -> CorePrepEnv-extendCoVarEnv cpe@(CPE { cpe_tyco_env = mb_tce }) cv co-  = cpe { cpe_tyco_env = Just (extend_tce_cv tce cv co) }-  where-    tce = mb_tce `orElse` emptyTCE---cpSubstTy :: CorePrepEnv -> Type -> Type-cpSubstTy (CPE { cpe_tyco_env = mb_env }) ty-  = case mb_env of-      Just env -> runIdentity (subst_ty env ty)-      Nothing  -> ty--cpSubstCo :: CorePrepEnv -> Coercion -> Coercion-cpSubstCo (CPE { cpe_tyco_env = mb_env }) co-  = case mb_env of-      Just tce -> runIdentity (subst_co tce co)-      Nothing  -> co--subst_tyco_mapper :: TyCoMapper CpeTyCoEnv Identity-subst_tyco_mapper = TyCoMapper-  { tcm_tyvar      = \env tv -> return (lookup_tce_tv env tv)-  , tcm_covar      = \env cv -> return (lookup_tce_cv env cv)-  , tcm_hole       = \_ hole -> pprPanic "subst_co_mapper:hole" (ppr hole)-  , tcm_tycobinder = \env tcv _vis -> if isTyVar tcv-                                      then return (subst_tv_bndr env tcv)-                                      else return (subst_cv_bndr env tcv)-  , tcm_tycon      = \tc -> return tc }--subst_ty :: CpeTyCoEnv -> Type     -> Identity Type-subst_co :: CpeTyCoEnv -> Coercion -> Identity Coercion-(subst_ty, _, subst_co, _) = mapTyCoX subst_tyco_mapper--cpSubstTyVarBndr :: CorePrepEnv -> TyVar -> (CorePrepEnv, TyVar)-cpSubstTyVarBndr env@(CPE { cpe_tyco_env = mb_env }) tv-  = case mb_env of-      Nothing  -> (env, tv)-      Just tce -> (env { cpe_tyco_env = Just tce' }, tv')-               where-                  (tce', tv') = subst_tv_bndr tce tv--subst_tv_bndr :: CpeTyCoEnv -> TyVar -> (CpeTyCoEnv, TyVar)-subst_tv_bndr tce tv-  = (extend_tce_tv tce tv (mkTyVarTy tv'), tv')-  where-    tv'   = mkTyVar (tyVarName tv) kind'-    kind' = runIdentity $ subst_ty tce $ tyVarKind tv--cpSubstCoVarBndr :: CorePrepEnv -> CoVar -> (CorePrepEnv, CoVar)-cpSubstCoVarBndr env@(CPE { cpe_tyco_env = mb_env }) cv-  = case mb_env of-      Nothing  -> (env, cv)-      Just tce -> (env { cpe_tyco_env = Just tce' }, cv')-               where-                  (tce', cv') = subst_cv_bndr tce cv--subst_cv_bndr :: CpeTyCoEnv -> CoVar -> (CpeTyCoEnv, CoVar)-subst_cv_bndr tce cv-  = (extend_tce_cv tce cv (mkCoVarCo cv'), cv')-  where-    cv' = mkCoVar (varName cv) ty'-    ty' = runIdentity (subst_ty tce $ varType cv)----------------------------------------------------------------------------------- Cloning binders--- -----------------------------------------------------------------------------cpCloneBndrs :: CorePrepEnv -> [InVar] -> UniqSM (CorePrepEnv, [OutVar])-cpCloneBndrs env bs = mapAccumLM cpCloneBndr env bs--cpCloneBndr  :: CorePrepEnv -> InVar -> UniqSM (CorePrepEnv, OutVar)-cpCloneBndr env bndr-  | isTyVar bndr-  = return (cpSubstTyVarBndr env bndr)--  | isCoVar bndr-  = return (cpSubstCoVarBndr env bndr)--  | otherwise-  = do { bndr' <- clone_it bndr--       -- Drop (now-useless) rules/unfoldings-       -- See Note [Drop unfoldings and rules]-       -- and Note [Preserve evaluatedness] in GHC.Core.Tidy-       ; let unfolding' = trimUnfolding (realIdUnfolding bndr)-                          -- Simplifier will set the Id's unfolding--             bndr'' = bndr' `setIdUnfolding`      unfolding'-                            `setIdSpecialisation` emptyRuleInfo--       ; return (extendCorePrepEnv env bndr bndr'', bndr'') }-  where-    clone_it bndr-      | isLocalId bndr-      = do { uniq <- getUniqueM-           ; let ty' = cpSubstTy env (idType bndr)-           ; return (setVarUnique (setIdType bndr ty') 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 :: Type -> UniqSM Id-newVar ty- = seqType ty `seq` do-     uniq <- getUniqueM-     return (mkSysLocalOrCoVar (fsLit "sat") uniq Many 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 r b con bs ok) = FloatCase (mkTick t r) b con bs 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)--floatableTick :: GenTickish pass -> Bool-floatableTick tickish =-    tickishPlace tickish == PlaceNonLam &&-    tickish `tickishScopesLike` SoftScope----------------------------------------------------------------------------------- Numeric literals--- ------------------------------------------------------------------------------- | Create a function that converts Bignum literals into their final CoreExpr-mkConvertNumLiteral-   :: HscEnv-   -> IO (LitNumType -> Integer -> Maybe CoreExpr)-mkConvertNumLiteral hsc_env = do-   let-      dflags   = hsc_dflags hsc_env-      platform = targetPlatform dflags-      home_unit = hsc_home_unit hsc_env-      guardBignum act-         | isHomeUnitInstanceOf home_unit primUnitId-         = return $ panic "Bignum literals are not supported in ghc-prim"-         | isHomeUnitInstanceOf home_unit bignumUnitId-         = return $ panic "Bignum literals are not supported in ghc-bignum"-         | otherwise = act--      lookupBignumId n      = guardBignum (tyThingId <$> lookupGlobal hsc_env n)--   -- The lookup is done here but the failure (panic) is reported lazily when we-   -- try to access the `bigNatFromWordList` function.-   ---   -- If we ever get built-in ByteArray# literals, we could avoid the lookup by-   -- directly using the Integer/Natural wired-in constructors for big numbers.--   bignatFromWordListId <- lookupBignumId bignatFromWordListName--   let-      convertNumLit nt i = case nt of-         LitNumBigNat  -> Just (convertBignatPrim i)-         _             -> Nothing--      convertBignatPrim i =-         let-            target    = targetPlatform dflags--            -- ByteArray# literals aren't supported (yet). Were they supported,-            -- we would use them directly. We would need to handle-            -- wordSize/endianness conversion between host and target-            -- wordSize  = platformWordSize platform-            -- byteOrder = platformByteOrder platform--            -- For now we build a list of Words and we produce-            -- `bigNatFromWordList# list_of_words`--            words = mkListExpr wordTy (reverse (unfoldr f i))-               where-                  f 0 = Nothing-                  f x = let low  = x .&. mask-                            high = x `shiftR` bits-                        in Just (mkConApp wordDataCon [Lit (mkLitWord platform low)], high)-                  bits = platformWordSizeInBits target-                  mask = 2 ^ bits - 1--         in mkApps (Var bignatFromWordListId) [words]---   return convertNumLit-+{-# LANGUAGE ViewPatterns #-}++{-+(c) The University of Glasgow, 1994-2006+++Core pass to saturate constructors and PrimOps+-}++module GHC.CoreToStg.Prep+   ( CorePrepConfig (..)+   , CorePrepPgmConfig (..)+   , corePrepPgm+   , corePrepExpr+   )+where++import GHC.Prelude++import GHC.Platform++import GHC.Driver.Flags++import GHC.Unit++import GHC.Builtin.Names+import GHC.Builtin.PrimOps+import GHC.Builtin.PrimOps.Ids+import GHC.Builtin.Types+import GHC.Builtin.Types.Prim++import GHC.Core.Utils+import GHC.Core.Opt.Arity+import GHC.Core.Lint    ( EndPassConfig(..), endPassIO )+import GHC.Core+import GHC.Core.Subst+import GHC.Core.Make hiding( FloatBind(..) )   -- We use our own FloatBind here+import GHC.Core.Type+import GHC.Core.Coercion+import GHC.Core.TyCon+import GHC.Core.DataCon+import GHC.Core.Opt.OccurAnal++import GHC.Data.Maybe+import GHC.Data.OrdList+import GHC.Data.FastString+import GHC.Data.Graph.UnVar++import GHC.Utils.Error+import GHC.Utils.Misc+import GHC.Utils.Panic+import GHC.Utils.Outputable+import GHC.Utils.Monad  ( mapAccumLM )+import GHC.Utils.Logger++import GHC.Types.Demand+import GHC.Types.Var+import GHC.Types.Id+import GHC.Types.Id.Info+import GHC.Types.Id.Make ( realWorldPrimId )+import GHC.Types.Basic+import GHC.Types.Name   ( OccName, NamedThing(..), isInternalName )+import GHC.Types.Name.Occurrence (occNameString)+import GHC.Types.Literal+import GHC.Types.Tickish+import GHC.Types.Unique.Supply++import qualified Data.ByteString as BS+import qualified Data.ByteString.Builder as BB+import Data.ByteString.Builder.Prim++import Control.Monad+import Data.List (intercalate)++{-+Note [CorePrep Overview]+~~~~~~~~~~~~~~~~~~~~~~~~++The goal of this pass is to prepare for code generation.++1.  Saturate constructor and primop applications.++2.  Convert to A-normal form; that is, function arguments+    are always variables.++    * Use case for strict arguments:+        f E ==> case E of x -> f x+        (where f is strict)++    * Use let for non-trivial lazy arguments+        f E ==> let x = E in f x+        (were f is lazy and x is non-trivial)++3.  Similarly, convert any unboxed lets into cases.+    [I'm experimenting with leaving 'ok-for-speculation'+     rhss in let-form right up to this point.]++4.  Ensure that *value* lambdas only occur as the RHS of a binding+    (The code generator can't deal with anything else.)+    Type lambdas are ok, however, because the code gen discards them.++5.  ANF-isation results in additional bindings that can obscure values.+    We float these out; see Note [Floating in CorePrep].++6.  Clone all local Ids.  See Note [Cloning in CorePrep]++7.  Give each dynamic CCall occurrence a fresh unique; this is+    rather like the cloning step above.++8. Convert bignum literals into their core representation.++9. Uphold tick consistency while doing this: We move ticks out of+    (non-type) applications where we can, and make sure that we+    annotate according to scoping rules when floating.++10. Collect cost centres (including cost centres in unfoldings) if we're in+    profiling mode. We have to do this here because we won't have unfoldings+    after this pass (see `trimUnfolding` and Note [Drop unfoldings and rules].++11. Eliminate some magic Ids, specifically+     runRW# (\s. e)  ==>  e[readWorldId/s]+             lazy e  ==>  e (see Note [lazyId magic] in GHC.Types.Id.Make)+         noinline e  ==>  e+           nospec e  ==>  e+     ToDo:  keepAlive# ...+    This is done in cpeApp++This is all done modulo type applications and abstractions, so that+when type erasure is done for conversion to STG, we don't end up with+any trivial or useless bindings.++Note [CorePrep invariants]+~~~~~~~~~~~~~~~~~~~~~~~~~~+Here is the syntax of the Core produced by CorePrep:++    Trivial expressions+       arg ::= lit     |  var+            |  arg ty  |  /\a. arg+            |  co      |  arg |> co++    Applications+       app ::= lit  |  var  |  app arg  |  app ty  |  app co  |  app |> co++    Expressions+       body ::= app+             |  let(rec) x = rhs in body     -- Boxed only+             |  case body of pat -> body+             |  /\a. body | /\c. body+             |  body |> co++    Right hand sides (only place where value lambdas can occur)+       rhs ::= /\a.rhs  |  \x.rhs  |  body++We define a synonym for each of these non-terminals.  Functions+with the corresponding name produce a result in that syntax.++Note [Cloning in CorePrep]+~~~~~~~~~~~~~~~~~~~~~~~~~~+In CorePrep we+* Always clone non-CoVar Ids, so each has a unique Unique+* Sometimes clone CoVars and TyVars++We always clone non-CoVarIds, for three reasons++1. Things associated with labels in the final code must be truly unique in+   order to avoid labels being shadowed in the final output.++2. Even binders without info tables like function arguments or alternative+   bound binders must be unique at least in their type/unique combination.+   We only emit a single declaration for each binder when compiling to C+   so if binders are not unique we would either get duplicate declarations+   or misstyped variables. The later happend in #22402.++3. We heavily use unique-keyed maps in the backend which can go wrong when+   ids with the same unique are meant to represent the same variable.++Generally speaking we don't clone TyVars or CoVars. The code gen doesn't need+that (they are erased), and doing so would be tiresome because then we'd need+to substitute in types and coercions.  But sometimes need to: see+Note [Cloning CoVars and TyVars]++Note [Cloning CoVars and TyVars]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Normally we don't need to clone TyVars and CoVars, but there is one occasion+when we do (see #24463).  When we have+    case unsafeEqualityProof ... of UnsafeRefl g -> ...+we try to float it, using UnsafeEqualityCase.+Why?  See (U3) in Note [Implementing unsafeCoerce]++Alas, floating it widens the scope of `g`, and that led to catastrophe in+#24463, when two identically-named g's shadowed.++Solution: clone `g`; see `cpCloneCoVarBndr`.++BUT once we clone `g` we must apply the cloning substitution to all types+and coercions.  But that in turn means that, given a binder like+   /\ (a :: kind |> g). blah+we must substitute in a's kind, and hence need to substitute for `a`+itself in `blah`.++So our plan is:+  * Maintain a full Subst in `cpe_subst`++  * Clone a CoVar when we we meet an `isUnsafeEqualityCase`;+    otherwise TyVar/CoVar binders are never cloned.++  * So generally the TCvSubst is empty++  * Apply the substitution to type and coercion arguments in Core; but+    happily `substTy` has a no-op short-cut for an empty TCvSubst, so this+    is usually very cheap.++  * In `cpCloneBndr`, for a tyvar/covar binder, check for an empty substitution;+    in that case just do nothing+-}++type CpeArg  = CoreExpr    -- Non-terminal 'arg'+type CpeApp  = CoreExpr    -- Non-terminal 'app'+type CpeBody = CoreExpr    -- Non-terminal 'body'+type CpeRhs  = CoreExpr    -- Non-terminal 'rhs'++{-+************************************************************************+*                                                                      *+                Top level stuff+*                                                                      *+************************************************************************+-}++data CorePrepPgmConfig = CorePrepPgmConfig+  { cpPgm_endPassConfig     :: !EndPassConfig+  , cpPgm_generateDebugInfo :: !Bool+  }++corePrepPgm :: Logger+            -> CorePrepConfig+            -> CorePrepPgmConfig+            -> Module -> CoreProgram+            -> IO CoreProgram+corePrepPgm logger cp_cfg pgm_cfg+            this_mod binds =+    withTiming logger+               (text "CorePrep"<+>brackets (ppr this_mod))+               (\a -> a `seqList` ()) $ do+    let initialCorePrepEnv = mkInitialCorePrepEnv cp_cfg++    us <- mkSplitUniqSupply 's'+    let+        floats = initUs_ us $+                 corePrepTopBinds initialCorePrepEnv binds+        binds_out = deFloatTop floats++    endPassIO logger (cpPgm_endPassConfig pgm_cfg)+              binds_out []++    return binds_out++corePrepExpr :: Logger -> CorePrepConfig -> CoreExpr -> IO CoreExpr+corePrepExpr logger config expr = do+    withTiming logger (text "CorePrep [expr]") (\e -> e `seq` ()) $ do+      us <- mkSplitUniqSupply 's'+      let initialCorePrepEnv = mkInitialCorePrepEnv config+      let new_expr = initUs_ us (cpeBodyNF initialCorePrepEnv expr)+      putDumpFileMaybe logger Opt_D_dump_prep "CorePrep" FormatCore (ppr new_expr)+      return new_expr++corePrepTopBinds :: CorePrepEnv -> [CoreBind] -> UniqSM Floats+-- Note [Floating out of top level bindings]+corePrepTopBinds initialCorePrepEnv binds+  = go initialCorePrepEnv binds+  where+    go _   []             = return emptyFloats+    go env (bind : binds) = do (env', floats, maybe_new_bind)+                                 <- cpeBind TopLevel env bind+                               massert (isNothing maybe_new_bind)+                                 -- Only join points get returned this way by+                                 -- cpeBind, and no join point may float to top+                               floatss <- go env' binds+                               return (floats `zipFloats` floatss)++{- *********************************************************************+*                                                                      *+                The main code+*                                                                      *+********************************************************************* -}++{- Note [Floating in CorePrep]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+ANFisation risks producing a lot of nested lets that obscures values:+  let v = (:) (f 14) [] in e+  ==> { ANF in CorePrep }+  let v = let sat = f 14 in (:) sat [] in e+Here, `v` is not a value anymore, and we'd allocate a thunk closure for `v` that+allocates a thunk for `sat` and then allocates the cons cell.+Hence we carry around a bunch of floated bindings with us so that we again+expose the values:+  let v = let sat = f 14 in (:) sat [] in e+  ==> { Float sat }+  let sat = f 14 in+  let v = (:) sat [] in e+(We will not do this transformation if `v` does not become a value afterwards;+see Note [wantFloatLocal].)+If `v` is bound at the top-level, we might even float `sat` to top-level;+see Note [Floating out of top level bindings].+For nested let bindings, we have to keep in mind Note [Core letrec invariant]+and may exploit strict contexts; see Note [wantFloatLocal].++There are 3 main categories of floats, encoded in the `FloatingBind` type:++  * `Float`: A floated binding, as `sat` above.+    These come in different flavours as described by their `FloatInfo` and+    `BindInfo`, which captures how far the binding can be floated and whether or+    not we want to case-bind. See Note [BindInfo and FloatInfo].+  * `UnsafeEqualityCase`: Used for floating around unsafeEqualityProof bindings;+    see (U3) of Note [Implementing unsafeCoerce].+    It's exactly a `Float` that is `CaseBound` and `LazyContextFloatable`+    (see `mkNonRecFloat`), but one that has a non-DEFAULT Case alternative to+    bind the unsafe coercion field of the Refl constructor.+  * `FloatTick`: A floated `Tick`. See Note [Floating Ticks in CorePrep].++It is quite essential that CorePrep *does not* rearrange the order in which+evaluations happen, in contrast to, e.g., FloatOut, because CorePrep lowers+the seq# primop into a Case (see Note [seq# magic]). Fortunately, CorePrep does+not attempt to reorder the telescope of Floats or float out out of non-floated+binding sites (such as Case alts) in the first place; for that it would have to+do some kind of data dependency analysis.++Note [Floating out of top level bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+NB: we do need to float out of top-level bindings+Consider        x = length [True,False]+We want to get+                s1 = False : []+                s2 = True  : s1+                x  = length s2++We return a *list* of bindings, because we may start with+        x* = f (g y)+where x is demanded, in which case we want to finish with+        a = g y+        x* = f a+And then x will actually end up case-bound++Note [Join points and floating]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Join points can float out of other join points but not out of value bindings:++  let z =+    let  w = ... in -- can float+    join k = ... in -- can't float+    ... jump k ...+  join j x1 ... xn =+    let  y = ... in -- can float (but don't want to)+    join h = ... in -- can float (but not much point)+    ... jump h ...+  in ...++Here, the jump to h remains valid if h is floated outward, but the jump to k+does not.++We don't float *out* of join points. It would only be safe to float out of+nullary join points (or ones where the arguments are all either type arguments+or dead binders). Nullary join points aren't ever recursive, so they're always+effectively one-shot functions, which we don't float out of. We *could* float+join points from nullary join points, but there's no clear benefit at this+stage.++Note [Dead code in CorePrep]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Imagine that we got an input program like this (see #4962):++  f :: Show b => Int -> (Int, b -> Maybe Int -> Int)+  f x = (g True (Just x) + g () (Just x), g)+    where+      g :: Show a => a -> Maybe Int -> Int+      g _ Nothing = x+      g y (Just z) = if z > 100 then g y (Just (z + length (show y))) else g y unknown++After specialisation and SpecConstr, we would get something like this:++  f :: Show b => Int -> (Int, b -> Maybe Int -> Int)+  f x = (g$Bool_True_Just x + g$Unit_Unit_Just x, g)+    where+      {-# RULES g $dBool = g$Bool+                g $dUnit = g$Unit #-}+      g = ...+      {-# RULES forall x. g$Bool True (Just x) = g$Bool_True_Just x #-}+      g$Bool = ...+      {-# RULES forall x. g$Unit () (Just x) = g$Unit_Unit_Just x #-}+      g$Unit = ...+      g$Bool_True_Just = ...+      g$Unit_Unit_Just = ...++Note that the g$Bool and g$Unit functions are actually dead code: they+are only kept alive by the occurrence analyser because they are+referred to by the rules of g, which is being kept alive by the fact+that it is used (unspecialised) in the returned pair.++However, at the CorePrep stage there is no way that the rules for g+will ever fire, and it really seems like a shame to produce an output+program that goes to the trouble of allocating a closure for the+unreachable g$Bool and g$Unit functions.++The way we fix this is to:+ * In cloneBndr, drop all unfoldings/rules++ * In deFloatTop, run a simple dead code analyser on each top-level+   RHS to drop the dead local bindings.++The reason we don't just OccAnal the whole output of CorePrep is that+the tidier ensures that all top-level binders are GlobalIds, so they+don't show up in the free variables any longer. So if you run the+occurrence analyser on the output of CoreTidy (or later) you e.g. turn+this program:++  Rec {+  f = ... f ...+  }++Into this one:++  f = ... f ...++(Since f is not considered to be free in its own RHS.)+++Note [keepAlive# magic]+~~~~~~~~~~~~~~~~~~~~~~~+When interacting with foreign code, it is often necessary for the user to+extend the lifetime of a heap object beyond the lifetime that would be apparent+from the on-heap references alone. For instance, a program like:++  foreign import safe "hello" hello :: ByteArray# -> IO ()++  callForeign :: IO ()+  callForeign = IO $ \s0 ->+    case newByteArray# n# s0 of (# s1, barr #) ->+      unIO hello barr s1++As-written this program is susceptible to memory-unsafety since there are+no references to `barr` visible to the garbage collector. Consequently, if a+garbage collection happens during the execution of the C function `hello`, it+may be that the array is freed while in use by the foreign function.++To address this, we introduced a new primop, keepAlive#, which "scopes over"+the computation needing the kept-alive value:++  keepAlive# :: forall (ra :: RuntimeRep) (rb :: RuntimeRep) (a :: TYPE a) (b :: TYPE b).+                a -> State# RealWorld -> (State# RealWorld -> b) -> b++When entered, an application (keepAlive# x s k) will apply `k` to the state+token, evaluating it to WHNF. However, during the course of this evaluation+will *guarantee* that `x` is considered to be alive.++There are a few things to note here:++ - we are RuntimeRep-polymorphic in the value to be kept-alive. This is+   necessary since we will often (but not always) be keeping alive something+   unlifted (like a ByteArray#)++ - we are RuntimeRep-polymorphic in the result value since the result may take+   many forms (e.g. a boxed value, a raw state token, or a (# State s, result #).++We implement this operation by desugaring to touch# during CorePrep (see+GHC.CoreToStg.Prep.cpeApp). Specifically,++  keepAlive# x s0 k++is transformed to:++  case k s0 of r ->+  case touch# x realWorld# of s1 ->+    r++Operationally, `keepAlive# x s k` is equivalent to pushing a stack frame with a+pointer to `x` and entering `k s0`. This compilation strategy is safe+because we do no optimization on STG that would drop or re-order the+continuation containing the `touch#`. However, if we were to become more+aggressive in our STG pipeline then we would need to revisit this.++Beyond this CorePrep transformation, there is very little special about+keepAlive#. However, we did explore (and eventually gave up on)+an optimisation which would allow unboxing of constructed product results,+which we describe below.+++Lost optimisation: CPR unboxing+--------------------------------+One unfortunate property of this approach is that the simplifier is unable to+unbox the result of a keepAlive# expression. For instance, consider the program:++  case keepAlive# arr s0 (+         \s1 -> case peekInt arr s1 of+                  (# s2, r #) -> I# r+  ) of+    I# x -> ...++This is a surprisingly common pattern, previously used, e.g., in+GHC.IO.Buffer.readWord8Buf. While exploring ideas, we briefly played around+with optimising this away by pushing strict contexts (like the+`case [] of I# x -> ...` above) into keepAlive#'s continuation. While this can+recover unboxing, it can also unfortunately in general change the asymptotic+memory (namely stack) behavior of the program. For instance, consider++  writeN =+    ...+      case keepAlive# x s0 (\s1 -> something s1) of+        (# s2, x #) ->+          writeN ...++As it is tail-recursive, this program will run in constant space. However, if+we push outer case into the continuation we get:++  writeN =++      case keepAlive# x s0 (\s1 ->+        case something s1 of+          (# s2, x #) ->+            writeN ...+      ) of+        ...++Which ends up building a stack which is linear in the recursion depth. For this+reason, we ended up giving up on this optimisation.+++Historical note: touch# and its inadequacy+------------------------------------------+Prior to the introduction of `keepAlive#` we instead addressed the need for+lifetime extension with the `touch#` primop:++    touch# :: a -> State# s -> State# s++This operation would ensure that the `a` value passed as the first argument was+considered "alive" at the time the primop application is entered.++For instance, the user might modify `callForeign` as:++  callForeign :: IO ()+  callForeign s0 = IO $ \s0 ->+    case newByteArray# n# s0 of (# s1, barr #) ->+    case unIO hello barr s1 of (# s2, () #) ->+    case touch# barr s2 of s3 ->+      (# s3, () #)++However, in #14346 we discovered that this primop is insufficient in the+presence of simplification. For instance, consider a program like:++  callForeign :: IO ()+  callForeign s0 = IO $ \s0 ->+    case newByteArray# n# s0 of (# s1, barr #) ->+    case unIO (forever $ hello barr) s1 of (# s2, () #) ->+    case touch# barr s2 of s3 ->+      (# s3, () #)++In this case the Simplifier may realize that (forever $ hello barr)+will never return and consequently that the `touch#` that follows is dead code.+As such, it will be dropped, resulting in memory unsoundness.+This unsoundness lead to the introduction of keepAlive#.++++Other related tickets:++ - #15544+ - #17760+ - #14375+ - #15260+ - #18061+-}++cpeBind :: TopLevelFlag -> CorePrepEnv -> CoreBind+        -> UniqSM (CorePrepEnv,+                   Floats,         -- Floating value bindings+                   Maybe CoreBind) -- Just bind' <=> returned new bind; no float+                                   -- Nothing <=> added bind' to floats instead+cpeBind top_lvl env (NonRec bndr rhs)+  | not (isJoinId bndr)+  = do { (env1, bndr1) <- cpCloneBndr env bndr+       ; let dmd = idDemandInfo bndr+             lev = typeLevity (idType bndr)+       ; (floats, rhs1) <- cpePair top_lvl NonRecursive+                                   dmd lev env bndr1 rhs+       -- See Note [Inlining in CorePrep]+       ; let triv_rhs = exprIsTrivial rhs1+             env2    | triv_rhs  = extendCorePrepEnvExpr env1 bndr rhs1+                     | otherwise = env1+             floats1 | triv_rhs, isInternalName (idName bndr)+                     = floats+                     | otherwise+                     = snocFloat floats new_float++             (new_float, _bndr2) = mkNonRecFloat env lev bndr1 rhs1++       ; return (env2, floats1, Nothing) }++  | otherwise -- A join point; see Note [Join points and floating]+  = assert (not (isTopLevel top_lvl)) $ -- can't have top-level join point+    do { (_, bndr1) <- cpCloneBndr env bndr+       ; (bndr2, rhs1) <- cpeJoinPair env bndr1 rhs+       ; return (extendCorePrepEnv env bndr bndr2,+                 emptyFloats,+                 Just (NonRec bndr2 rhs1)) }++cpeBind top_lvl env (Rec pairs)+  | not (isJoinId (head bndrs))+  = do { (env, bndrs1) <- cpCloneBndrs env bndrs+       ; let env' = enterRecGroupRHSs env bndrs1+       ; stuff <- zipWithM (cpePair top_lvl Recursive topDmd Lifted env')+                           bndrs1 rhss++       ; let (zipManyFloats -> floats, rhss1) = unzip stuff+             -- Glom all floats into the Rec, *except* FloatStrings; see+             -- see Note [ANF-ising literal string arguments], Wrinkle (FS1)+             is_lit (Float (NonRec _ rhs) CaseBound TopLvlFloatable) = exprIsTickedString rhs+             is_lit _                                                = False+             (string_floats, top) = partitionOL is_lit (fs_binds floats)+                 -- Strings will *always* be in `top_floats` (we made sure of+                 -- that in `snocOL`), so that's the only field we need to+                 -- partition.+             floats'   = floats { fs_binds = top }+             all_pairs = foldrOL add_float (bndrs1 `zip` rhss1) (getFloats floats')+       -- use env below, so that we reset cpe_rec_ids+       ; return (extendCorePrepEnvList env (bndrs `zip` bndrs1),+                 snocFloat (emptyFloats { fs_binds = string_floats })+                           (Float (Rec all_pairs) LetBound TopLvlFloatable),+                 Nothing) }++  | otherwise -- See Note [Join points and floating]+  = do { (env, bndrs1) <- cpCloneBndrs env bndrs+       ; let env' = enterRecGroupRHSs env bndrs1+       ; pairs1 <- zipWithM (cpeJoinPair env') bndrs1 rhss++       ; let bndrs2 = map fst pairs1+       -- use env below, so that we reset cpe_rec_ids+       ; return (extendCorePrepEnvList env (bndrs `zip` bndrs2),+                 emptyFloats,+                 Just (Rec pairs1)) }+  where+    (bndrs, rhss) = unzip pairs++    -- Flatten all the floats, and the current+    -- group into a single giant Rec+    add_float (Float bind bound _) prs2+      | bound /= CaseBound+      || all (not . isUnliftedType . idType) (bindersOf bind)+           -- The latter check is hit in -O0 (i.e., flavours quick, devel2)+           -- for dictionary args which haven't been floated out yet, #24102.+           -- They are preferably CaseBound, but since they are lifted we may+           -- just as well put them in the Rec, in contrast to lifted bindings.+      = case bind of+          NonRec x e -> (x,e) : prs2+          Rec prs1 -> prs1 ++ prs2+    add_float f _ = pprPanic "cpeBind" (ppr f)+++---------------+cpePair :: TopLevelFlag -> RecFlag -> Demand -> Levity+        -> CorePrepEnv -> OutId -> CoreExpr+        -> UniqSM (Floats, CpeRhs)+-- Used for all bindings+-- The binder is already cloned, hence an OutId+cpePair top_lvl is_rec dmd lev env0 bndr rhs+  = assert (not (isJoinId bndr)) $ -- those should use cpeJoinPair+    do { (floats1, rhs1) <- cpeRhsE env rhs++       -- See if we are allowed to float this stuff out of the RHS+       ; let dec = want_float_from_rhs floats1 rhs1+       ; (floats2, rhs2) <- executeFloatDecision env dec floats1 rhs1++       -- Make the arity match up+       ; (floats3, rhs3)+            <- if manifestArity rhs1 <= arity+               then return (floats2, cpeEtaExpand arity rhs2)+               else warnPprTrace True "CorePrep: silly extra arguments:" (ppr bndr) $+                               -- Note [Silly extra arguments]+                    (do { v <- newVar env (idType bndr)+                        ; let (float, v') = mkNonRecFloat env Lifted v rhs2+                        ; return ( snocFloat floats2 float+                                 , cpeEtaExpand arity (Var v')) })++        -- Wrap floating ticks+       ; let (floats4, rhs4) = wrapTicks floats3 rhs3++       ; return (floats4, rhs4) }+  where+    env = pushBinderContext bndr env0++    arity = idArity bndr        -- We must match this arity++    want_float_from_rhs floats rhs+      | isTopLevel top_lvl = wantFloatTop floats+      | otherwise          = wantFloatLocal is_rec dmd lev floats rhs++{- Note [Silly extra arguments]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we had this+        f{arity=1} = \x\y. e+We *must* match the arity on the Id, so we have to generate+        f' = \x\y. e+        f  = \x. f' x++It's a bizarre case: why is the arity on the Id wrong?  Reason+(in the days of __inline_me__):+        f{arity=0} = __inline_me__ (let v = expensive in \xy. e)+When InlineMe notes go away this won't happen any more.  But+it seems good for CorePrep to be robust.+-}++---------------+cpeJoinPair :: CorePrepEnv -> JoinId -> CoreExpr+            -> UniqSM (JoinId, CpeRhs)+-- Used for all join bindings+-- No eta-expansion: see Note [Do not eta-expand join points] in GHC.Core.Opt.Simplify.Utils+cpeJoinPair env bndr rhs+  = assert (isJoinId bndr) $+    do { let join_arity = case idJoinPointHood bndr of+                 JoinPoint join_arity -> join_arity+                 _ -> panic "cpeJoinPair"+             (bndrs, body)        = collectNBinders join_arity rhs++       ; (env', bndrs') <- cpCloneBndrs env bndrs++       ; body' <- cpeBodyNF env' body -- Will let-bind the body if it starts+                                      -- with a lambda++       ; let rhs'  = mkCoreLams bndrs' body'+             bndr' = bndr `setIdUnfolding` evaldUnfolding+                          `setIdArity` count isId bndrs+                            -- See Note [Arity and join points]++       ; return (bndr', rhs') }++{-+Note [Arity and join points]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Up to now, we've allowed a join point to have an arity greater than its join+arity (minus type arguments), since this is what's useful for eta expansion.+However, for code gen purposes, its arity must be exactly the number of value+arguments it will be called with, and it must have exactly that many value+lambdas. Hence if there are extra lambdas we must let-bind the body of the RHS:++  join j x y z = \w -> ... in ...+    =>+  join j x y z = (let f = \w -> ... in f) in ...++This is also what happens with Note [Silly extra arguments]. Note that it's okay+for us to mess with the arity because a join point is never exported.+-}++-- ---------------------------------------------------------------------------+--              CpeRhs: produces a result satisfying CpeRhs+-- ---------------------------------------------------------------------------++cpeRhsE :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)+-- If+--      e  ===>  (bs, e')+-- then+--      e = let bs in e'        (semantically, that is!)+--+-- For example+--      f (g x)   ===>   ([v = g x], f v)++cpeRhsE env (Type ty)+  = return (emptyFloats, Type (cpSubstTy env ty))+cpeRhsE env (Coercion co)+  = return (emptyFloats, Coercion (cpSubstCo env co))+cpeRhsE env expr@(Lit lit)+  | LitNumber LitNumBigNat i <- lit+    = cpeBigNatLit env i+  | otherwise = return (emptyFloats, expr)+cpeRhsE env expr@(Var {})  = cpeApp env expr+cpeRhsE env expr@(App {})  = cpeApp env expr++cpeRhsE env (Let bind body)+  = do { (env', bind_floats, maybe_bind') <- cpeBind NotTopLevel env bind+       ; (body_floats, body') <- cpeRhsE env' body+       ; let expr' = case maybe_bind' of Just bind' -> Let bind' body'+                                         Nothing    -> body'+       ; return (bind_floats `appFloats` body_floats, expr') }++cpeRhsE env (Tick tickish expr)+  -- Pull out ticks if they are allowed to be floated.+  | tickishFloatable tickish+  = do { (floats, body) <- cpeRhsE env expr+         -- See [Floating Ticks in CorePrep]+       ; return (FloatTick tickish `consFloat` floats, body) }+  | otherwise+  = do { body <- cpeBodyNF env expr+       ; return (emptyFloats, mkTick tickish' body) }+  where+    tickish' | Breakpoint ext bid fvs <- tickish+             -- See also 'substTickish'+             = Breakpoint ext bid (map (getIdFromTrivialExpr . lookupCorePrepEnv env) fvs)+             | otherwise+             = tickish++cpeRhsE env (Cast expr co)+   = do { (floats, expr') <- cpeRhsE env expr+        ; return (floats, Cast expr' (cpSubstCo env co)) }++cpeRhsE env expr@(Lam {})+   = do { let (bndrs,body) = collectBinders expr+        ; (env', bndrs') <- cpCloneBndrs env bndrs+        ; body' <- cpeBodyNF env' body+        ; return (emptyFloats, mkLams bndrs' body') }++cpeRhsE env (Case scrut bndr _ alts@[Alt con [covar] _])+  -- See (U3) in Note [Implementing unsafeCoerce]+  -- We need make the Case float, otherwise we get+  --   let x = case ... of UnsafeRefl co ->+  --           let y = expr in+  --           K y+  --   in f x+  -- instead of+  --   case ... of UnsafeRefl co ->+  --   let y = expr in+  --   let x = K y+  --   in f x+  -- Note that `x` is a value here. This is visible in the GHCi debugger tests+  -- (such as `print003`).+  | Just rhs <- isUnsafeEqualityCase scrut bndr alts+  = do { (floats_scrut, scrut) <- cpeBody env scrut++       ; (env, bndr')  <- cpCloneBndr env bndr+       ; (env, covar') <- cpCloneCoVarBndr env covar+                          -- Important: here we clone the CoVar+                          -- See Note [Cloning CoVars and TyVars]++         -- Up until here this should do exactly the same as the regular code+         -- path of `cpeRhsE Case{}`.+       ; (floats_rhs, rhs) <- cpeBody env rhs+         -- ... but we want to float `floats_rhs` as in (U3) so that rhs' might+         -- become a value+       ; let case_float = UnsafeEqualityCase scrut bndr' con [covar']+         -- NB: It is OK to "evaluate" the proof eagerly.+         --     Usually there's the danger that we float the unsafeCoerce out of+         --     a branching Case alt. Not so here, because the regular code path+         --     for `cpeRhsE Case{}` will not float out of alts.+             floats = snocFloat floats_scrut case_float `appFloats` floats_rhs+       ; return (floats, rhs) }++cpeRhsE env (Case scrut bndr _ [Alt (DataAlt dc) [token_out, res] rhs])+  -- See item (SEQ4) of Note [seq# magic]. We want to match+  --   case seq# @a @RealWorld <ok-to-discard> s of (# s', _ #) -> rhs[s']+  -- and simplify to rhs[s]. Triggers in T15226.+  | isUnboxedTupleDataCon dc+  , (Var f,[_ty1, _ty2, arg, Var token_in]) <- collectArgs scrut+  , f `hasKey` seqHashKey+  , exprOkToDiscard arg+      -- ok-to-discard, because we want to discard the evaluation of `arg`.+      -- ok-to-discard includes ok-for-spec, but *also* CanFail primops such as+      -- `quotInt# 1# 0#`, but not ThrowsException primops.+      -- See Note [Classifying primop effects]+      -- and Note [Transformations affected by primop effects] for why this is+      -- the correct choice.+  , Var token_in' <- lookupCorePrepEnv env token_in+  , isDeadBinder res, isDeadBinder bndr+      -- Check that bndr and res are dead+      -- We can rely on `isDeadBinder res`, despite the fact that the Simplifier+      -- often zaps the OccInfo on case-alternative binders (see Note [DataAlt occ info]+      -- in GHC.Core.Opt.Simplify.Iteration) because the scrutinee is not a+      -- variable, and in that case the zapping doesn't happen; see that Note.+  = cpeRhsE (extendCorePrepEnv env token_out token_in') rhs++cpeRhsE env (Case scrut bndr ty alts)+  = do { (floats, scrut') <- cpeBody env scrut+       ; (env', bndr2) <- cpCloneBndr env bndr+       ; let bndr3 = bndr2 `setIdUnfolding` evaldUnfolding+       ; let alts'+               | cp_catchNonexhaustiveCases $ cpe_config env+                 -- Suppose the alternatives do not cover all the data constructors of the type.+                 -- That may be fine: perhaps an earlier case has dealt with the missing cases.+                 -- But this is a relatively sophisticated property, so we provide a GHC-debugging flag+                 -- `-fcatch-nonexhaustive-cases` which adds a DEFAULT alternative to such cases+                 -- (This alternative will only be taken if there is a bug in GHC.)+               , not (altsAreExhaustive alts)+               = addDefault alts (Just err)+               | otherwise = alts+               where err = mkImpossibleExpr ty "cpeRhsE: missing case alternative"+       ; alts'' <- mapM (sat_alt env') alts'++       ; case alts'' of+           [Alt DEFAULT _ rhs] -- See Note [Flatten case-binds]+             | let float = mkCaseFloat bndr3 scrut'+             -> return (snocFloat floats float, rhs)+           _ -> return (floats, Case scrut' bndr3 (cpSubstTy env ty) alts'') }+  where+    sat_alt env (Alt con bs rhs)+       = do { (env2, bs') <- cpCloneBndrs env bs+            ; rhs' <- cpeBodyNF env2 rhs+            ; return (Alt con bs' rhs') }++-- ---------------------------------------------------------------------------+--              CpeBody: produces a result satisfying CpeBody+-- ---------------------------------------------------------------------------++-- | Convert a 'CoreExpr' so it satisfies 'CpeBody', without+-- producing any floats (any generated floats are immediately+-- let-bound using 'wrapBinds').  Generally you want this, esp.+-- when you've reached a binding form (e.g., a lambda) and+-- floating any further would be incorrect.+cpeBodyNF :: CorePrepEnv -> CoreExpr -> UniqSM CpeBody+cpeBodyNF env expr+  = do { (floats, body) <- cpeBody env expr+       ; return (wrapBinds floats body) }++-- | Convert a 'CoreExpr' so it satisfies 'CpeBody'; also produce+-- a list of 'Floats' which are being propagated upwards.  In+-- fact, this function is used in only two cases: to+-- implement 'cpeBodyNF' (which is what you usually want),+-- and in the case when a let-binding is in a case scrutinee--here,+-- we can always float out:+--+--      case (let x = y in z) of ...+--      ==> let x = y in case z of ...+--+cpeBody :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeBody)+cpeBody env expr+  = do { (floats1, rhs) <- cpeRhsE env expr+       ; (floats2, body) <- rhsToBody env rhs+       ; return (floats1 `appFloats` floats2, body) }++--------+rhsToBody :: CorePrepEnv -> CpeRhs -> UniqSM (Floats, CpeBody)+-- Remove top level lambdas by let-binding++rhsToBody env (Tick t expr)+  | tickishScoped t == NoScope  -- only float out of non-scoped annotations+  = do { (floats, expr') <- rhsToBody env expr+       ; return (floats, mkTick t expr') }++rhsToBody env (Cast e co)+        -- You can get things like+        --      case e of { p -> coerce t (\s -> ...) }+  = do { (floats, e') <- rhsToBody env e+       ; return (floats, Cast e' co) }++rhsToBody env expr@(Lam {})   -- See Note [No eta reduction needed in rhsToBody]+  | all isTyVar bndrs           -- Type lambdas are ok+  = return (emptyFloats, expr)+  | otherwise                   -- Some value lambdas+  = do { let rhs = cpeEtaExpand (exprArity expr) expr+       ; fn <- newVar env (exprType rhs)+       ; let float = Float (NonRec fn rhs) LetBound TopLvlFloatable+       ; return (unitFloat float, Var fn) }+  where+    (bndrs,_) = collectBinders expr++rhsToBody _env expr = return (emptyFloats, expr)+++{- Note [No eta reduction needed in rhsToBody]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Historical note.  In the olden days we used to have a Prep-specific+eta-reduction step in rhsToBody:+  rhsToBody expr@(Lam {})+    | Just no_lam_result <- tryEtaReducePrep bndrs body+    = return (emptyFloats, no_lam_result)++The goal was to reduce+        case x of { p -> \xs. map f xs }+    ==> case x of { p -> map f }++to avoid allocating a lambda.  Of course, we'd allocate a PAP+instead, which is hardly better, but that's the way it was.++Now we simply don't bother with this. It doesn't seem to be a win,+and it's extra work.+-}++-- ---------------------------------------------------------------------------+--              CpeApp: produces a result satisfying CpeApp+-- ---------------------------------------------------------------------------++data ArgInfo = AIApp  CoreArg -- NB: Not a CpeApp yet+             | AICast Coercion+             | AITick CoreTickish++instance Outputable ArgInfo where+  ppr (AIApp arg) = text "app" <+> ppr arg+  ppr (AICast co) = text "cast" <+> ppr co+  ppr (AITick tick) = text "tick" <+> ppr tick++{- Note [Ticks and mandatory eta expansion]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Something like+    `foo x = ({-# SCC foo #-} tagToEnum#) x :: Bool`+caused a compiler panic in #20938. Why did this happen?+The simplifier will eta-reduce the rhs giving us a partial+application of tagToEnum#. The tick is then pushed inside the+type argument. That is we get+    `(Tick<foo> tagToEnum#) @Bool`+CorePrep would go on to see a undersaturated tagToEnum# application+and eta expand the expression under the tick. Giving us:+    (Tick<scc> (\forall a. x -> tagToEnum# @a x) @Bool+Suddenly tagToEnum# is applied to a polymorphic type and the code generator+panics as it needs a concrete type to determine the representation.++The problem in my eyes was that the tick covers a partial application+of a primop. There is no clear semantic for such a construct as we can't+partially apply a primop since they do not have bindings.+We fix this by expanding the scope of such ticks slightly to cover the body+of the eta-expanded expression.++We do this by:+* Checking if an application is headed by a primOpish thing.+* If so we collect floatable ticks and usually but also profiling ticks+  along with regular arguments.+* When rebuilding the application we check if any profiling ticks appear+  before the primop is fully saturated.+* If the primop isn't fully satured we eta expand the primop application+  and scope the tick to scope over the body of the saturated expression.++Going back to #20938 this means starting with+    `(Tick<foo> tagToEnum#) @Bool`+we check if the function head is a primop (yes). This means we collect the+profiling tick like if it was floatable. Giving us+    (tagToEnum#, [CpeTick foo, CpeApp @Bool]).+cpe_app filters out the tick as a underscoped tick on the expression+`tagToEnum# @Bool`. During eta expansion we then put that tick back onto the+body of the eta-expansion lambdas. Giving us `\x -> Tick<foo> (tagToEnum# @Bool x)`.+-}+cpeApp :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)+-- May return a CpeRhs (instead of CpeApp) because of saturating primops+cpeApp top_env expr+  = do { let (terminal, args) = collect_args expr+      --  ; pprTraceM "cpeApp" $ (ppr expr)+       ; cpe_app top_env terminal args+       }++  where+    -- We have a nested data structure of the form+    -- e `App` a1 `App` a2 ... `App` an, convert it into+    -- (e, [CpeApp a1, CpeApp a2, ..., CpeApp an], depth)+    -- We use 'ArgInfo' because we may also need to+    -- record casts and ticks.  Depth counts the number+    -- of arguments that would consume strictness information+    -- (so, no type or coercion arguments.)+    collect_args :: CoreExpr -> (CoreExpr, [ArgInfo])+    collect_args e = go e []+      where+        go (App fun arg)      as+            = go fun (AIApp arg : as)+        go (Cast fun co)      as+            = go fun (AICast co : as)+        go (Tick tickish fun) as+            -- Profiling ticks are slightly less strict so we expand their scope+            -- if they cover partial applications of things like primOps.+            -- See Note [Ticks and mandatory eta expansion]+            -- Here we look inside `fun` before we make the final decision about+            -- floating the tick which isn't optimal for perf. But this only makes+            -- a difference if we have a non-floatable tick which is somewhat rare.+            | Var vh <- head+            , Var head' <- lookupCorePrepEnv top_env vh+            , etaExpansionTick head' tickish+            = (head,as')+            where+              (head,as') = go fun (AITick tickish : as)++        -- Terminal could still be an app if it's wrapped by a tick.+        -- E.g. Tick<foo> (f x) can give us (f x) as terminal.+        go terminal as = (terminal, as)++    cpe_app :: CorePrepEnv+            -> CoreExpr -- The thing we are calling+            -> [ArgInfo]+            -> UniqSM (Floats, CpeRhs)+    cpe_app env (Var f) (AIApp Type{} : AIApp arg : args)+        | f `hasKey` lazyIdKey          -- Replace (lazy a) with a, and+            -- See Note [lazyId magic] in GHC.Types.Id.Make+       || f `hasKey` noinlineIdKey || f `hasKey` noinlineConstraintIdKey+            -- Replace (noinline a) with a+            -- See Note [noinlineId magic] in GHC.Types.Id.Make+       || f `hasKey` nospecIdKey        -- Replace (nospec a) with a+            -- See Note [nospecId magic] in GHC.Types.Id.Make++        -- Consider the code:+        --+        --      lazy (f x) y+        --+        -- We need to make sure that we need to recursively collect arguments on+        -- "f x", otherwise we'll float "f x" out (it's not a variable) and+        -- end up with this awful -ddump-prep:+        --+        --      case f x of f_x {+        --        __DEFAULT -> f_x y+        --      }+        --+        -- rather than the far superior "f x y".  Test case is par01.+        = let (terminal, args') = collect_args arg+          in cpe_app env terminal (args' ++ args)++    -- runRW# magic+    cpe_app env (Var f) (AIApp _runtimeRep@Type{} : AIApp _type@Type{} : AIApp arg : rest)+        | f `hasKey` runRWKey+        -- N.B. While it may appear that n == 1 in the case of runRW#+        -- applications, keep in mind that we may have applications that return+        , has_value_arg (AIApp arg : rest)+        -- See Note [runRW magic]+        -- Replace (runRW# f) by (f realWorld#), beta reducing if possible (this+        -- is why we return a CorePrepEnv as well)+        = case arg of+            Lam s body -> cpe_app (extendCorePrepEnv env s realWorldPrimId) body rest+            _          -> cpe_app env arg (AIApp (Var realWorldPrimId) : rest)+             -- TODO: What about casts?+        where+          has_value_arg [] = False+          has_value_arg (AIApp arg:_rest)+            | not (isTyCoArg arg) = True+          has_value_arg (_:rest) = has_value_arg rest++    -- See Note [seq# magic]. This is the step for CorePrep+    cpe_app env (Var f) [AIApp (Type ty), AIApp _st_ty@Type{}, AIApp thing, AIApp token]+        | f `hasKey` seqHashKey+        -- seq# thing token+        --    ==>   case token of s   { __DEFAULT ->+        --          case thing of res { __DEFAULT -> (# token, res#) } },+        -- allocating CaseBound Floats for token and thing as needed+        = do { (floats1, token) <- cpeArg env topDmd token+             ; (floats2, thing) <- cpeBody env thing+             ; case_bndr <- (`setIdUnfolding` evaldUnfolding) <$> newVar env ty+             ; let tup = mkCoreUnboxedTuple [token, Var case_bndr]+             ; let float = mkCaseFloat case_bndr thing+             ; return (floats1 `appFloats` floats2 `snocFloat` float, tup) }++    cpe_app env (Var v) args+      = do { v1 <- fiddleCCall v+           ; let e2 = lookupCorePrepEnv env v1+                 hd = getIdFromTrivialExpr_maybe e2+                 -- Determine number of required arguments. See Note [Ticks and mandatory eta expansion]+                 min_arity = case hd of+                   Just v_hd -> if hasNoBinding v_hd then Just $! (idArity v_hd) else Nothing+                   Nothing -> Nothing+          --  ; pprTraceM "cpe_app:stricts:" (ppr v <+> ppr args $$ ppr stricts $$ ppr (idCbvMarks_maybe v))+           ; (app, floats, unsat_ticks) <- rebuild_app env args e2 emptyFloats stricts min_arity+           ; mb_saturate hd app floats unsat_ticks depth }+        where+          depth = val_args args+          stricts = case idDmdSig v of+                            DmdSig (DmdType _ demands)+                              | listLengthCmp demands depth /= GT -> demands+                                    -- length demands <= depth+                              | otherwise                         -> []+                -- If depth < length demands, then we have too few args to+                -- satisfy strictness  info so we have to  ignore all the+                -- strictness info, e.g. + (error "urk")+                -- Here, we can't evaluate the arg strictly, because this+                -- partial application might be seq'd++        -- We inlined into something that's not a var and has no args.+        -- Bounce it back up to cpeRhsE.+    cpe_app env fun [] = cpeRhsE env fun++    -- Here we get:+    -- N-variable fun, better let-bind it+    -- This case covers literals, apps, lams or let expressions applied to arguments.+    -- Basically things we want to ANF before applying to arguments.+    cpe_app env fun args+      = do { (fun_floats, fun') <- cpeArg env evalDmd fun+                          -- If evalDmd says that it's sure to be evaluated,+                          -- we'll end up case-binding it+           ; (app, floats,unsat_ticks) <- rebuild_app env args fun' fun_floats [] Nothing+           ; mb_saturate Nothing app floats unsat_ticks (val_args args) }++    -- Count the number of value arguments *and* coercions (since we don't eliminate the later in STG)+    val_args :: [ArgInfo] -> Int+    val_args args = go args 0+      where+        go [] !n = n+        go (info:infos) n =+          case info of+            AICast {} -> go infos n+            AITick tickish+              | tickishFloatable tickish                 -> go infos n+              -- If we can't guarantee a tick will be floated out of the application+              -- we can't guarantee the value args following it will be applied.+              | otherwise                             -> n+            AIApp e                                  -> go infos n'+              where+                !n'+                  | isTypeArg e = n+                  | otherwise   = n+1++    -- Saturate if necessary+    mb_saturate head app floats unsat_ticks depth =+       case head of+         Just fn_id -> do { sat_app <- maybeSaturate fn_id app depth unsat_ticks+                          ; return (floats, sat_app) }+         _other     -> do { massert (null unsat_ticks)+                          ; return (floats, app) }++    -- Deconstruct and rebuild the application, floating any non-atomic+    -- arguments to the outside.  We collect the type of the expression,+    -- the head of the application, and the number of actual value arguments,+    -- all of which are used to possibly saturate this application if it+    -- has a constructor or primop at the head.+    rebuild_app+        :: CorePrepEnv+        -> [ArgInfo]                  -- The arguments (inner to outer)+        -> CpeApp                     -- The function+        -> Floats                     -- INVARIANT: These floats don't bind anything that is in the CpeApp!+                                      -- Just stuff floated out from the head of the application.+        -> [Demand]+        -> Maybe Arity+        -> UniqSM (CpeApp+                  ,Floats+                  ,[CoreTickish] -- Underscoped ticks. See Note [Ticks and mandatory eta expansion]+                  )+    rebuild_app env args app floats ss req_depth =+      rebuild_app' env args app floats ss [] (fromMaybe 0 req_depth)++    rebuild_app'+        :: CorePrepEnv+        -> [ArgInfo] -- The arguments (inner to outer); substitution not applied+        -> CpeApp    -- Substitution already applied+        -> Floats+        -> [Demand]+        -> [CoreTickish]+        -> Int -- Number of arguments required to satisfy minimal tick scopes.+        -> UniqSM (CpeApp, Floats, [CoreTickish])+    rebuild_app' _ [] app floats ss rt_ticks !_req_depth+      = assertPpr (null ss) (ppr ss)-- make sure we used all the strictness info+        return (app, floats, rt_ticks)++    rebuild_app' env (a : as) fun' floats ss rt_ticks req_depth = case a of+      -- See Note [Ticks and mandatory eta expansion]+      _ | not (null rt_ticks), req_depth <= 0+        -> let tick_fun = foldr mkTick fun' rt_ticks+           in rebuild_app' env (a : as) tick_fun floats ss rt_ticks req_depth++      AIApp (Type arg_ty)+        -> rebuild_app' env as (App fun' (Type arg_ty')) floats ss rt_ticks req_depth+        where+           arg_ty' = cpSubstTy env arg_ty++      AIApp (Coercion co)+        -> rebuild_app' env as (App fun' (Coercion co')) floats (drop 1 ss) rt_ticks req_depth+        where+           co' = cpSubstCo env co++      AIApp arg -> do+        let (ss1, ss_rest)  -- See Note [lazyId magic] in GHC.Types.Id.Make+               = case (ss, isLazyExpr arg) of+                   (_   : ss_rest, True)  -> (topDmd, ss_rest)+                   (ss1 : ss_rest, False) -> (ss1,    ss_rest)+                   ([],            _)     -> (topDmd, [])+        (fs, arg') <- cpeArg env ss1 arg+        rebuild_app' env as (App fun' arg') (fs `zipFloats` floats) ss_rest rt_ticks (req_depth-1)++      AICast co+        -> rebuild_app' env as (Cast fun' co') floats ss rt_ticks req_depth+        where+           co' = cpSubstCo env co++      -- See Note [Ticks and mandatory eta expansion]+      AITick tickish+        | tickishPlace tickish == PlaceRuntime+        , req_depth > 0+        -> assert (isProfTick tickish) $+           rebuild_app' env as fun' floats ss (tickish:rt_ticks) req_depth+        | otherwise+        -- See [Floating Ticks in CorePrep]+        -> rebuild_app' env as fun' (snocFloat floats (FloatTick tickish)) ss rt_ticks req_depth++isLazyExpr :: CoreExpr -> Bool+-- See Note [lazyId magic] in GHC.Types.Id.Make+isLazyExpr (Cast e _)              = isLazyExpr e+isLazyExpr (Tick _ e)              = isLazyExpr e+isLazyExpr (Var f `App` _ `App` _) = f `hasKey` lazyIdKey+isLazyExpr _                       = False++{- Note [runRW magic]+~~~~~~~~~~~~~~~~~~~~~+Some definitions, for instance @runST@, must have careful control over float out+of the bindings in their body. Consider this use of @runST@,++    f x = runST ( \ s -> let (a, s')  = newArray# 100 [] s+                             (_, s'') = fill_in_array_or_something a x s'+                         in freezeArray# a s'' )++If we inline @runST@, we'll get:++    f x = let (a, s')  = newArray# 100 [] realWorld#{-NB-}+              (_, s'') = fill_in_array_or_something a x s'+          in freezeArray# a s''++And now if we allow the @newArray#@ binding to float out to become a CAF,+we end up with a result that is totally and utterly wrong:++    f = let (a, s')  = newArray# 100 [] realWorld#{-NB-} -- YIKES!!!+        in \ x ->+            let (_, s'') = fill_in_array_or_something a x s'+            in freezeArray# a s''++All calls to @f@ will share a {\em single} array! Clearly this is nonsense and+must be prevented.++This is what @runRW#@ gives us: by being inlined extremely late in the+optimization (right before lowering to STG, in CorePrep), we can ensure that+no further floating will occur. This allows us to safely inline things like+@runST@, which are otherwise needlessly expensive (see #10678 and #5916).++'runRW' has a variety of quirks:++ * 'runRW' is known-key with a NOINLINE definition in+   GHC.Magic. This definition is used in cases where runRW is curried.++ * In addition to its normal Haskell definition in GHC.Magic, we give it+   a special late inlining here in CorePrep and GHC.StgToByteCode, avoiding+   the incorrect sharing due to float-out noted above.++ * It is levity-polymorphic:++    runRW# :: forall (r1 :: RuntimeRep). (o :: TYPE r)+           => (State# RealWorld -> (# State# RealWorld, o #))+           -> (# State# RealWorld, o #)++ * It has some special simplification logic to allow unboxing of results when+   runRW# appears in a strict context. See Note [Simplification of runRW#]+   below.++ * Since its body is inlined, we allow runRW#'s argument to contain jumps to+   join points. That is, the following is allowed:++    join j x = ...+    in runRW# @_ @_ (\s -> ... jump j 42 ...)++   The Core Linter knows about this. See Note [Linting of runRW#] in+   GHC.Core.Lint for details.++   The occurrence analyser and SetLevels also know about this, as described in+   Note [Simplification of runRW#].++Other relevant Notes:++ * Note [Simplification of runRW#] below, describing a transformation of runRW+   applications in strict contexts performed by the simplifier.+ * Note [Linting of runRW#] in GHC.Core.Lint+ * Note [runRW arg] below, describing a non-obvious case where the+   late-inlining could go wrong.++Note [runRW arg]+~~~~~~~~~~~~~~~~~~~+Consider the Core program (from #11291),++   runRW# (case bot of {})++The late inlining logic in cpe_app would transform this into:++   (case bot of {}) realWorld#++Which would rise to a panic in CoreToStg.myCollectArgs, which expects only+variables in function position.++However, as runRW#'s strictness signature captures the fact that it will call+its argument this can't happen: the simplifier will transform the bottoming+application into simply (case bot of {}).++Note that this reasoning does *not* apply to non-bottoming continuations like:++    hello :: Bool -> Int+    hello n =+      runRW# (+          case n of+            True -> \s -> 23+            _    -> \s -> 10)++Why? The difference is that (case bot of {}) is considered by okCpeArg to be+trivial, consequently cpeArg (which the catch-all case of cpe_app calls on both+the function and the arguments) will forgo binding it to a variable. By+contrast, in the non-bottoming case of `hello` above  the function will be+deemed non-trivial and consequently will be case-bound.++Note [Simplification of runRW#]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider the program,++    case runRW# (\s -> I# 42#) of+      I# n# -> f n#++There is no reason why we should allocate an I# constructor given that we+immediately destructure it.++To avoid this the simplifier has a special transformation rule, specific to+runRW#, that pushes a strict context into runRW#'s continuation.  See the+`runRW#` guard in `GHC.Core.Opt.Simplify.rebuildCall`.  That is, it transforms++    K[ runRW# @r @ty cont ]+              ~>+    runRW# @r @ty (\s -> K[cont s])++This has a few interesting implications. Consider, for instance, this program:++    join j = ...+    in case runRW# @r @ty cont of+         result -> jump j result++Performing the transform described above would result in:++    join j x = ...+    in runRW# @r @ty (\s ->+         case cont of in+           result -> jump j result+       )++If runRW# were a "normal" function this call to join point j would not be+allowed in its continuation argument. However, since runRW# is inlined (as+described in Note [runRW magic] above), such join point occurrences are+completely fine. Both occurrence analysis (see the runRW guard in occAnalApp)+and Core Lint (see the App case of lintCoreExpr) have special treatment for+runRW# applications. See Note [Linting of runRW#] for details on the latter.++Moreover, it's helpful to ensure that runRW's continuation isn't floated out+For instance, if we have++    runRW# (\s -> do_something)++where do_something contains only top-level free variables, we may be tempted to+float the argument to the top-level. However, we must resist this urge as since+doing so would then require that runRW# produce an allocation and call, e.g.:++    let lvl = \s -> do_somethign+    in+    ....(runRW# lvl)....++whereas without floating the inlining of the definition of runRW would result+in straight-line code. Consequently, GHC.Core.Opt.SetLevels.lvlApp has special+treatment for runRW# applications, ensure the arguments are not floated as+MFEs.++Now that we float evaluation context into runRW#, we also have to give runRW# a+special higher-order CPR transformer lest we risk #19822. E.g.,++  case runRW# (\s -> doThings) of x -> Data.Text.Text x something something'+      ~>+  runRW# (\s -> case doThings s of x -> Data.Text.Text x something something')++The former had the CPR property, and so should the latter.++Other considered designs+------------------------+One design that was rejected was to *require* that runRW#'s continuation be+headed by a lambda. However, this proved to be quite fragile. For instance,+SetLevels is very eager to float bottoming expressions. For instance given+something of the form,++    runRW# @r @ty (\s -> case expr of x -> undefined)++SetLevels will see that the body the lambda is bottoming and will consequently+float it to the top-level (assuming expr has no free coercion variables which+prevent this). We therefore end up with++    runRW# @r @ty (\s -> lvl s)++Which the simplifier will beta reduce, leaving us with++    runRW# @r @ty lvl++Breaking our desired invariant. Ultimately we decided to simply accept that+the continuation may not be a manifest lambda.+++-- ---------------------------------------------------------------------------+--      CpeArg: produces a result satisfying CpeArg+-- ---------------------------------------------------------------------------++Note [ANF-ising literal string arguments]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider a Core program like,++    data Foo = Foo Addr#+    foo = Foo "turtle"#++String literals are non-trivial, see 'GHC.Types.Literal.litIsTrivial', hence+they are non-atomic in STG.+With -O1, FloatOut is likely to have floated most of these strings to top-level,+not least to give CSE a chance to deduplicate strings early (before the+linker, that is).+(Notable exceptions seem to be applications of 'unpackAppendCString#'.)+But with -O0, there is no FloatOut, so CorePrep must do the ANFisation to++    s = "turtle"#+    foo = Foo s++(String literals are the only kind of binding allowed at top-level and hence+their `FloatInfo` is `TopLvlFloatable`.)++This appears to lead to bad code if the arg is under a lambda, because CorePrep+doesn't float out of RHSs, e.g., (T23270)++    foo x = ... patError "turtle"# ...+==> foo x = ... case "turtle"# of s { __DEFAULT -> petError s } ...++This looks bad because it evals an HNF on every call.+But actually, it doesn't, because "turtle"# is already an HNF. Here is the Cmm:++  [section ""cstring" . cB4_str" {+       cB4_str:+           I8[] "turtle"+   }+  ...+  _sAG::I64 = cB4_str;+  R2 = _sAG::I64;+  Sp = Sp + 8;+  call Control.Exception.Base.patError_info(R2) args: 8, res: 0, upd: 8;++Wrinkles:++(FS1) We detect string literals in `cpeBind Rec{}` and float them out anyway;+      otherwise we'd try to bind a string literal in a letrec, violating+      Note [Core letrec invariant]. Since we know that literals don't have+      free variables, we float further.+      Arguably, we could just as well relax the letrec invariant for+      string literals, or anthing that is a value (lifted or not).+      This is tracked in #24036.+-}++-- This is where we arrange that a non-trivial argument is let-bound+cpeArg :: CorePrepEnv -> Demand+       -> CoreArg -> UniqSM (Floats, CpeArg)+cpeArg env dmd arg+  = do { (floats1, arg1) <- cpeRhsE env arg     -- arg1 can be a lambda+       ; let arg_ty = exprType arg1+             lev    = typeLevity arg_ty+             dec    = wantFloatLocal NonRecursive dmd lev floats1 arg1+       ; (floats2, arg2) <- executeFloatDecision env dec floats1 arg1+                -- Else case: arg1 might have lambdas, and we can't+                --            put them inside a wrapBinds++       -- Now ANF-ise any non-trivial argument+       -- NB: "non-trivial" includes string literals;+       -- see Note [ANF-ising literal string arguments]+       ; if exprIsTrivial arg2+         then return (floats2, arg2)+         else do { v <- (`setIdDemandInfo` dmd) <$> newVar env arg_ty+                       -- See Note [Pin demand info on floats]+                 ; let arity = cpeArgArity env dec floats1 arg2+                       arg3  = cpeEtaExpand arity arg2+                       -- See Note [Eta expansion of arguments in CorePrep]+                 ; let (arg_float, v') = mkNonRecFloat env lev v arg3+                 ---; pprTraceM "cpeArg" (ppr arg1 $$ ppr dec $$ ppr arg2)+                 ; return (snocFloat floats2 arg_float, varToCoreExpr v') }+       }++cpeArgArity :: CorePrepEnv -> FloatDecision -> Floats -> CoreArg -> Arity+-- ^ See Note [Eta expansion of arguments in CorePrep]+-- Returning 0 means "no eta-expansion"; see cpeEtaExpand+cpeArgArity env float_decision floats1 arg+  | FloatNone <- float_decision+         -- If we did not float+  , not (isEmptyFloats floats1)+         -- ... but there was something to float+  , fs_info floats1 `floatsAtLeastAsFarAs` LazyContextFloatable+         -- ... and we could have floated it out of a lazy arg+  = 0    -- ... then short-cut, because floats1 is likely expensive!+         -- See wrinkle (EA2) in Note [Eta expansion of arguments in CorePrep]++  | Just ao <- cp_arityOpts (cpe_config env) -- Just <=> -O1 or -O2+  , not (eta_would_wreck_join arg)+            -- See Wrinkle (EA1) of Note [Eta expansion of arguments in CorePrep]+  = case exprEtaExpandArity ao arg of+      Nothing -> 0+      Just at -> arityTypeArity at++  | otherwise+  = exprArity arg -- this is cheap enough for -O0++eta_would_wreck_join :: CoreExpr -> Bool+-- ^ Identify the cases where we'd generate invalid `CpeApp`s as described in+-- Wrinkle (EA1) of Note [Eta expansion of arguments in CorePrep]+eta_would_wreck_join (Let bs e)        = isJoinBind bs || eta_would_wreck_join e+eta_would_wreck_join (Lam _ e)         = eta_would_wreck_join e+eta_would_wreck_join (Cast e _)        = eta_would_wreck_join e+eta_would_wreck_join (Tick _ e)        = eta_would_wreck_join e+eta_would_wreck_join (Case _ _ _ alts) = any eta_would_wreck_join (rhssOfAlts alts)+eta_would_wreck_join _                 = False++maybeSaturate :: Id -> CpeApp -> Int -> [CoreTickish] -> UniqSM CpeRhs+maybeSaturate fn expr n_args unsat_ticks+  | hasNoBinding fn        -- There's no binding+    -- See Note [Eta expansion of hasNoBinding things in CorePrep]+  = return $ wrapLamBody (\body -> foldr mkTick body unsat_ticks) sat_expr++  | mark_arity > 0 -- A call-by-value function. See Note [CBV Function Ids]+  , not applied_marks+  = assertPpr+      ( not (isJoinId fn)) -- See Note [Do not eta-expand join points]+      ( ppr fn $$ text "expr:" <+> ppr expr $$ text "n_args:" <+> ppr n_args $$+          text "marks:" <+> ppr (idCbvMarks_maybe fn) $$+          text "join_arity" <+> ppr (idJoinPointHood fn) $$+          text "fn_arity" <+> ppr fn_arity+       ) $+    -- pprTrace "maybeSat"+    --   ( ppr fn $$ text "expr:" <+> ppr expr $$ text "n_args:" <+> ppr n_args $$+    --       text "marks:" <+> ppr (idCbvMarks_maybe fn) $$+    --       text "join_arity" <+> ppr (isJoinId_maybe fn) $$+    --       text "fn_arity" <+> ppr fn_arity $$+    --       text "excess_arity" <+> ppr excess_arity $$+    --       text "mark_arity" <+> ppr mark_arity+    --    ) $+    return sat_expr++  | otherwise+  = assert (null unsat_ticks) $+    return expr+  where+    mark_arity    = idCbvMarkArity fn+    fn_arity      = idArity fn+    excess_arity  = (max fn_arity mark_arity) - n_args+    sat_expr      = cpeEtaExpand excess_arity expr+    applied_marks = n_args >= (length . dropWhile (not . isMarkedCbv) .+                               reverse . expectJust $ (idCbvMarks_maybe fn))+    -- For join points we never eta-expand (See Note [Do not eta-expand join points])+    -- so we assert all arguments that need to be passed cbv are visible so that the+    -- backend can evalaute them if required..++{- Note [Eta expansion]+~~~~~~~~~~~~~~~~~~~~~~~+Eta expand to match the arity claimed by the binder Remember,+CorePrep must not change arity++Eta expansion might not have happened already, because it is done by+the simplifier only when there at least one lambda already.++NB1:we could refrain when the RHS is trivial (which can happen+    for exported things).  This would reduce the amount of code+    generated (a little) and make things a little worse for+    code compiled without -O.  The case in point is data constructor+    wrappers.++NB2: we have to be careful that the result of etaExpand doesn't+   invalidate any of the assumptions that CorePrep is attempting+   to establish.  One possible cause is eta expanding inside of+   an SCC note - we're now careful in etaExpand to make sure the+   SCC is pushed inside any new lambdas that are generated.++Note [Eta expansion of hasNoBinding things in CorePrep]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+maybeSaturate deals with eta expanding to saturate things that can't deal+with unsaturated applications (identified by 'hasNoBinding', currently+foreign calls, unboxed tuple/sum constructors, and representation-polymorphic+primitives such as 'coerce' and 'unsafeCoerce#').++Historical Note: Note that eta expansion in CorePrep used to be very fragile+due to the "prediction" of CAFfyness that we used to make during tidying.  We+previously saturated primop applications here as well but due to this+fragility (see #16846) we now deal with this another way, as described in+Note [Primop wrappers] in GHC.Builtin.PrimOps.++Note [Eta expansion and the CorePrep invariants]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It turns out to be much much easier to do eta expansion+*after* the main CorePrep stuff.  But that places constraints+on the eta expander: given a CpeRhs, it must return a CpeRhs.++For example here is what we do not want:+                f = /\a -> g (h 3)      -- h has arity 2+After ANFing we get+                f = /\a -> let s = h 3 in g s+and now we do NOT want eta expansion to give+                f = /\a -> \ y -> (let s = h 3 in g s) y++Instead GHC.Core.Opt.Arity.etaExpand gives+                f = /\a -> \y -> let s = h 3 in g s y++Note [Eta expansion of arguments in CorePrep]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose `g = \x y. blah` and consider the expression `f (g x)`; we ANFise to++  let t = g x+  in f t++We really don't want that `t` to be a thunk! That just wastes runtime, updating+a thunk with a PAP etc. The code generator could in principle allocate a PAP,+but in fact it does not know how to do that -- it's easier just to eta-expand:++  let t = \y. g x y+  in f t++To what arity should we eta-expand the argument? `cpeArg` uses two strategies,+governed by the presence of `-fdo-clever-arg-eta-expansion` (implied by -O):++  1. Cheap, with -O0: just use `exprArity`.+  2. More clever but expensive, with -O1 -O2: use `exprEtaExpandArity`,+     same function the Simplifier uses to eta expand RHSs and lambda bodies.++The only reason for using (1) rather than (2) is to keep compile times down.+Using (2) in -O0 bumped up compiler allocations by 2-3% in tests T4801 and+T5321*. However, Plan (2) catches cases that (1) misses.+For example (#23083, assuming -fno-pedantic-bottoms):++  let t = case z of __DEFAULT -> g x+  in f t++to++  let t = \y -> case z of __DEFAULT -> g x y+  in f t++Note that there is a missed opportunity in eta expanding `t` earlier, in the+Simplifier: It would allow us to inline `g`, potentially enabling further+simplification. But then we could have inlined `g` into the PAP to begin with,+and that is discussed in #23150; hence we needn't worry about that in CorePrep.++There is a nasty Wrinkle:++(EA1) When eta expanding an argument headed by a join point, we might get+      "crap", as Note [Eta expansion for join points] in GHC.Core.Opt.Arity puts+      it.  This crap means the output does not conform to the syntax in+      Note [CorePrep invariants], which then makes later passes crash (#25033).+      Consider++        f (join j x = rhs in ...(j 1)...(j 2)...)++      where the argument has arity 1. We might be tempted to eta expand, to++        f (\y -> (join j x = rhs in ...(j 1)...(j 2)...) y)++      Why hasn't the App to `y` been pushed into the join point? That's exactly+      the crap of Note [Eta expansion for join points], so we have to put up+      with it here.+      In our case, (join j x = rhs in ...(j 1)...(j 2)...) is not a valid+      `CpeApp` (see Note [CorePrep invariants]) and we'd get a crash in the App+      case of `coreToStgExpr`.++      Hence, in `eta_would_wreck_join`, we check for the cases where an+      intervening join point binding in the tail context of the argument would+      make eta-expansion break Note [CorePrep invariants], in which+      case we abstain from eta expansion.++      This scenario occurs rarely; hence it's OK to generate sub-optimal code.+      The alternative would be to fix Note [Eta expansion for join points], but+      that's quite challenging due to unfoldings of (recursive) join points.++      `eta_would_wreck_join` sees if there are any join points, like `j` above+      that would be messed up.   It must look inside lambdas (#25033); consider+             f (\x. join j y = ... in ...(j 1)...(j 3)...)+      We can't eta expand that `\x` any more than we could if the join was at+      the top.  (And when there's a lambda, we don't have a thunk anyway.)++(EA2) In cpeArgArity, if float_decision=FloatNone the `arg` will look like+           let <binds> in rhs+      where <binds> is non-empty and can't be floated out of a lazy context (see+      `wantFloatLocal`). So we can't eta-expand it anyway, so we can return 0+      forthwith.  Without this short-cut we will call exprEtaExpandArity on the+      `arg`, and <binds> might be enormous. exprEtaExpandArity be very expensive+      on this: it uses arityType, and may look at <binds>.++      On the other hand, if float_decision = FloatAll, there will be no+      let-bindings around 'arg'; they will have floated out.  So+      exprEtaExpandArity is cheap.++      This can make a huge difference on deeply nested expressions like+         f (f (f (f (f  ...))))+      #24471 is a good example, where Prep took 25% of compile time!+-}++cpeEtaExpand :: Arity -> CpeRhs -> CpeRhs+cpeEtaExpand arity expr+  | arity == 0 = expr+  | otherwise  = etaExpand arity expr++{-+************************************************************************+*                                                                      *+                Floats+*                                                                      *+************************************************************************++Note [Pin demand info on floats]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We pin demand info on floated lets, so that we can see one-shot thunks.+For example,+  f (g x)+where `f` uses its argument at most once, creates a Float for `y = g x` and we+should better pin appropriate demand info on `y`.++Note [Flatten case-binds]+~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have the following call, where f is strict:+   f (case x of DEFAULT -> blah)+(For the moment, ignore the fact that the Simplifier will have floated that+`case` out because `f` is strict.)+In Prep, `cpeArg` will ANF-ise that argument, and we'll get a `FloatingBind`++    Float (a = case x of y { DEFAULT -> blah }) CaseBound top-lvl++with the call `f a`.  When we wrap that `Float` we will get++   case (case x of y { DEFAULT -> blah }) of a { DEFAULT -> f a }++which is a bit silly. Actually the rest of the back end can cope with nested+cases like this, but it is harder to read and we'd prefer the more direct:++   case x of y { DEFAULT ->+   case blah of a { DEFAULT -> f a }}++This is easy to avoid: turn that++   case x of DEFAULT -> blah++into a FloatingBind of its own.  This is easily done in the Case+equation for `cpsRhsE`.  Then our example will generate /two/ floats:++    Float (y = x)    CaseBound str-ctx+    Float (a = blah) CaseBound top-lvl++and we'll end up with nested cases.++Of course, the Simplifier never leaves us with an argument like this, but we+/can/ see++  data T a = T !a+  ... case seq# (case x of y { __DEFAULT -> T y }) s of (# s', x' #) -> rhs++and the above footwork in cpsRhsE avoids generating a nested case.+++Note [Pin evaluatedness on floats]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When creating a new float `sat=e` in `mkNonRecFloat`, we propagate `sat` with an+`evaldUnfolding` if `e` is a value.++To see why, consider a call to a CBV function, such as a DataCon worker with+*strict* fields, in an argument context, such as++  data Box a = Box !a+  ... f (Box e) ...++where `f` is *lazy* and `e` is ok-for-spec, e.g. `e = I# (x +# 1#)`.+After ANFisation, we want to get the very nice code++  case x +# 1# of x' ->+  let sat = I# x' in+  let sat2 = Box sat in+  f sat2++Note that Case (2) of Note [wantFloatLocal] is in effect. That is,++  * x' is unlifted but ok-for-spec, hence floated out of the lazy arg of f+  * Since x' is unlifted, `I# x'` is a value, and so `sat` can be let-bound.+  * Since `sat` is a value, `Box sat` is a value as well, and so `sat2` can+    be let-bound.++Hence no thunk needs to be allocated! However, in order to recognise+`Box sat` as a value, it is crucial that the newly created `sat` has an+`evaldUnfolding`; otherwise the strict worker `Box` forces an eval on `sat`.+and we would get the far worse code++  let sat2 =+    case x +# 1# of x' ->+    case I# x' of sat' ->+    Box sat in+  f sat2++A live example of this is T24730, inspired by $walexGetByte.++Note [Speculative evaluation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Since call-by-value is much cheaper than call-by-need, we case-bind arguments+that are either++  1. Strictly evaluated anyway, according to the DmdSig of the callee, or+  2. ok-for-spec, according to 'exprOkForSpeculation'.+     This includes DFuns `$fEqList a`, for example.+     (Could identify more in the future; see reference to !1866 below.)++While (1) is a no-brainer and always beneficial, (2) is a bit+more subtle, as the careful haddock for 'exprOkForSpeculation'+points out. Still, by case-binding the argument we don't need+to allocate a thunk for it, whose closure must be retained as+long as the callee might evaluate it. And if it is evaluated on+most code paths anyway, we get to turn the unknown eval in the+callee into a known call at the call site.++Very Nasty Wrinkle++We must be very careful not to speculate recursive calls!  Doing so+might well change termination behavior.++That comes up in practice for DFuns, which are considered ok-for-spec,+because they always immediately return a constructor.+See Note [NON-BOTTOM-DICTS invariant] in GHC.Core.++But not so if you speculate the recursive call, as #20836 shows:++  class Foo m => Foo m where+    runFoo :: m a -> m a+  newtype Trans m a = Trans { runTrans :: m a }+  instance Monad m => Foo (Trans m) where+    runFoo = id++(NB: class Foo m => Foo m` looks weird and needs -XUndecidableSuperClasses. The+example in #20836 is more compelling, but boils down to the same thing.)+This program compiles to the following DFun for the `Trans` instance:++  Rec {+  $fFooTrans+    = \ @m $dMonad -> C:Foo ($fFooTrans $dMonad) (\ @a -> id)+  end Rec }++Note that the DFun immediately terminates and produces a dictionary, just+like DFuns ought to, but it calls itself recursively to produce the `Foo m`+dictionary. But alas, if we treat `$fFooTrans` as always-terminating, so+that we can speculate its calls, and hence use call-by-value, we get:++  $fFooTrans+    = \ @m $dMonad -> case ($fFooTrans $dMonad) of sc ->+                      C:Foo sc (\ @a -> id)++and that's an infinite loop!+Note that this bad-ness only happens in `$fFooTrans`'s own RHS. In the+*body* of the letrec, it's absolutely fine to use call-by-value on+`foo ($fFooTrans d)`.++Our solution is this: we track in cpe_rec_ids the set of enclosing+recursively-bound Ids, the RHSs of which we are currently transforming and then+in 'exprOkForSpecEval' (a special entry point to 'exprOkForSpeculation',+basically) we'll say that any binder in this set is not ok-for-spec.++Note if we have a letrec group `Rec { f1 = rhs1; ...; fn = rhsn }`, and we+prep up `rhs1`, we have to include not only `f1`, but all binders of the group+`f1..fn` in this set, otherwise our fix is not robust wrt. mutual recursive+DFuns.++NB: If at some point we decide to have a termination analysis for general+functions (#8655, !1866), we need to take similar precautions for (guarded)+recursive functions:++  repeat x = x : repeat x++Same problem here: As written, repeat evaluates rapidly to WHNF. So `repeat x`+is a cheap call that we are willing to speculate, but *not* in repeat's RHS.+Fortunately, pce_rec_ids already has all the information we need in that case.++The problem is very similar to Note [Eta reduction in recursive RHSs].+Here as well as there it is *unsound* to change the termination properties+of the very function whose termination properties we are exploiting.++It is also similar to Note [Do not strictify a DFun's parameter dictionaries],+where marking recursive DFuns (of undecidable *instances*) strict in dictionary+*parameters* leads to quite the same change in termination as above.++Note [BindInfo and FloatInfo]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The `BindInfo` of a `Float` describes whether it will be case-bound or+let-bound:++  * `LetBound`: A let binding `let x = rhs in ...`, can be Rec or NonRec.+  * `CaseBound`: A case binding `case rhs of x -> { __DEFAULT -> .. }`.+                 (So always NonRec.)+                 Some case-bound things (string literals, lifted bindings)+                 can float to top-level (but not all), hence it is similar+                 to, but not the same as `StrictContextFloatable :: FloatInfo`+                 described below.++This info is used in `wrapBinds` to pick the corresponding binding form.++We want to case-bind iff the binding is (non-recursive, and) either++  * ok-for-spec-eval (and perhaps lifted, see Note [Speculative evaluation]), or+  * unlifted, or+  * strictly used++The `FloatInfo` of a `Float` describes how far it can float without+(a) violating Core invariants and (b) changing semantics.++  * Any binding is at least `StrictContextFloatable`, meaning we may float it+    out of a strict context such as `f <>` where `f` is strict.+    We may never float out of a Case alternative `case e of p -> <>`, though,+    even if we made sure that `p` does not capture any variables of the float,+    because that risks sequencing guarantees of Note [seq# magic].++  * A binding is `LazyContextFloatable` if we may float it out of a lazy context+    such as `let x = <> in Just x`.+    Counterexample: A strict or unlifted binding that isn't ok-for-spec-eval+                    such as `case divInt# x y of r -> { __DEFAULT -> I# r }`.+                    Here, we may not foat out the strict `r = divInt# x y`.++  * A binding is `TopLvlFloatable` if it is `LazyContextFloatable` and also can+    be bound at the top level.+    Counterexample: A strict or unlifted binding (ok-for-spec-eval or not)+                    such as `case x +# y of r -> { __DEFAULT -> I# r }`.++This meaning of "at least" is encoded in `floatsAtLeastAsFarAs`.+Note that today, `LetBound` implies `TopLvlFloatable`, so we could make do with+the the following enum (check `mkNonRecFloat` for whether this is up to date):++   LetBoundTopLvlFloatable          (lifted or boxed values)+  CaseBoundTopLvlFloatable          (strings, ok-for-spec-eval and lifted)+  CaseBoundLazyContextFloatable     (ok-for-spec-eval and unlifted)+  CaseBoundStrictContextFloatable   (not ok-for-spec-eval and unlifted)++Although there is redundancy in the current encoding, SG thinks it is cleaner+conceptually.++See also Note [Floats and FloatDecision] for how we maintain whole groups of+floats and how far they go.++Note [Controlling Speculative Evaluation]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Most of the time, speculative evaluation in the coreprep phase has a positive+effect on performance, however we have found that some forms of speculative+evaluation can lead to large performance regressions. See #25284.++Therefore we have some flags to control which types of speculative evaluation+are done:++  -fspec-eval+     Globally enable/disable speculative evaluation ( -fno-spec-eval also turns+     off all other speculative evaluation). On by default for all+     optimization levels. Turning on this flag by itself should never cause+     a performance regression. Please open a ticket if you find any.++  -fspec-eval-dictfun+     Enable speculative evaluation for dictionary functions. Off by default+     since it can cause an increase in allocations (#24284). We have no+     examples that show a large performance improvement when turning on this+     flag. Please open a ticket if you find any.++Also see the optimization section in the User's Guide for the description of+these flags and when to use them.++Note [Floats and FloatDecision]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We have a special datatype `Floats` for modelling a telescope of `FloatingBind`+and caching its "maximum" `FloatInfo`, according to `floatsAtLeastAsFarAs`+(see Note [BindInfo and FloatInfo] for the ordering).+There are several operations for creating and combining `Floats` that maintain+scoping and the cached `FloatInfo`.++When deciding whether we want to float out a `Floats` out of a binding context+such as `let x = <> in e` (let), `f <>` (app), or `x = <>; ...` (top-level),+we consult the cached `FloatInfo` of the `Floats`:++  * If we want to float to the top-level (`x = <>; ...`), we check whether+    we may float-at-least-as-far-as `TopLvlFloatable`, in which case we+    respond with `FloatAll :: FloatDecision`; otherwise we say `FloatNone`.+  * If we want to float locally (let or app), then the floating decision is+    described in Note [wantFloatLocal].++`executeFloatDecision` is then used to act on the particular `FloatDecision`.+-}++-- See Note [BindInfo and FloatInfo]+data BindInfo+  = CaseBound -- ^ A strict binding+  | LetBound  -- ^ A lazy or value binding+  deriving Eq++-- See Note [BindInfo and FloatInfo]+data FloatInfo+  = TopLvlFloatable+  -- ^ Anything that can be bound at top-level, such as arbitrary lifted+  -- bindings or anything that responds True to `exprIsHNF`, such as literals or+  -- saturated DataCon apps where unlifted or strict args are values.++  | LazyContextFloatable+  -- ^ Anything that can be floated out of a lazy context.+  -- In addition to any 'TopLvlFloatable' things, this includes (unlifted)+  -- bindings that are ok-for-spec that we intend to case-bind.++  | StrictContextFloatable+  -- ^ Anything that can be floated out of a strict evaluation context.+  -- That is possible for all bindings; this is the Top element of 'FloatInfo'.++  deriving Eq++instance Outputable BindInfo where+  ppr CaseBound = text "Case"+  ppr LetBound  = text "Let"++instance Outputable FloatInfo where+  ppr TopLvlFloatable = text "top-lvl"+  ppr LazyContextFloatable = text "lzy-ctx"+  ppr StrictContextFloatable = text "str-ctx"++-- See Note [Floating in CorePrep]+-- and Note [BindInfo and FloatInfo]+data FloatingBind+  = Float !CoreBind !BindInfo !FloatInfo    -- Never a join-point binding+  | UnsafeEqualityCase !CoreExpr !CoreBndr !AltCon ![CoreBndr]+  | FloatTick CoreTickish++-- See Note [Floats and FloatDecision]+data Floats+  = Floats+  { fs_info  :: !FloatInfo+  , fs_binds :: !(OrdList FloatingBind)+  }++instance Outputable FloatingBind where+  ppr (Float b bi fi) = ppr bi <+> ppr fi <+> ppr b+  ppr (FloatTick t) = ppr t+  ppr (UnsafeEqualityCase scrut b k bs) = text "case" <+> ppr scrut+                                <+> text "of"<+> ppr b <> text "@"+                                <> case bs of+                                   [] -> ppr k+                                   _  -> parens (ppr k <+> ppr bs)++instance Outputable Floats where+  ppr (Floats info binds) = text "Floats" <> brackets (ppr info) <> braces (ppr binds)++lubFloatInfo :: FloatInfo -> FloatInfo -> FloatInfo+lubFloatInfo StrictContextFloatable _                      = StrictContextFloatable+lubFloatInfo _                      StrictContextFloatable = StrictContextFloatable+lubFloatInfo LazyContextFloatable   _                      = LazyContextFloatable+lubFloatInfo _                      LazyContextFloatable   = LazyContextFloatable+lubFloatInfo TopLvlFloatable        TopLvlFloatable        = TopLvlFloatable++floatsAtLeastAsFarAs :: FloatInfo -> FloatInfo -> Bool+-- See Note [Floats and FloatDecision]+floatsAtLeastAsFarAs l r = l `lubFloatInfo` r == r++emptyFloats :: Floats+emptyFloats = Floats TopLvlFloatable nilOL++isEmptyFloats :: Floats -> Bool+isEmptyFloats (Floats _ b) = isNilOL b++getFloats :: Floats -> OrdList FloatingBind+getFloats = fs_binds++unitFloat :: FloatingBind -> Floats+unitFloat = snocFloat emptyFloats++floatInfo :: FloatingBind -> FloatInfo+floatInfo (Float _ _ info)     = info+floatInfo UnsafeEqualityCase{} = LazyContextFloatable -- See Note [Floating in CorePrep]+floatInfo FloatTick{}          = TopLvlFloatable      -- We filter these out in cpePair,+                                                      -- see Note [Floating Ticks in CorePrep]++-- | Append a `FloatingBind` `b` to a `Floats` telescope `bs` that may reference any+-- binding of the 'Floats'.+snocFloat :: Floats -> FloatingBind -> Floats+snocFloat floats fb =+  Floats { fs_info  = lubFloatInfo (fs_info floats) (floatInfo fb)+         , fs_binds = fs_binds floats `snocOL` fb }++-- | Cons a `FloatingBind` `b` to a `Floats` telescope `bs` which scopes over+-- `b`.+consFloat :: FloatingBind -> Floats -> Floats+consFloat fb floats =+  Floats { fs_info  = lubFloatInfo (fs_info floats) (floatInfo fb)+         , fs_binds = fb `consOL`  fs_binds floats }++-- | Append two telescopes, nesting the right inside the left.+appFloats :: Floats -> Floats -> Floats+appFloats outer inner =+  Floats { fs_info  = lubFloatInfo (fs_info outer) (fs_info inner)+         , fs_binds = fs_binds outer `appOL` fs_binds inner }++-- | Zip up two `Floats`, none of which scope over the other+zipFloats :: Floats -> Floats -> Floats+-- We may certainly just nest one telescope in the other, so appFloats is a+-- valid implementation strategy.+zipFloats = appFloats++-- | `zipFloats` a bunch of independent telescopes.+zipManyFloats :: [Floats] -> Floats+zipManyFloats = foldr zipFloats emptyFloats++data FloatInfoArgs+  = FIA+  { fia_levity :: Levity+  , fia_demand :: Demand+  , fia_is_hnf :: Bool+  , fia_is_triv :: Bool+  , fia_is_string :: Bool+  , fia_is_dc_worker :: Bool+  , fia_ok_for_spec :: Bool+  }++defFloatInfoArgs :: Id -> CoreExpr -> FloatInfoArgs+defFloatInfoArgs bndr rhs+  = FIA+  { fia_levity = typeLevity (idType bndr)+  , fia_demand = idDemandInfo bndr -- mkCaseFloat uses evalDmd+  , fia_is_hnf = exprIsHNF rhs+  , fia_is_triv = exprIsTrivial rhs+  , fia_is_string = exprIsTickedString rhs+  , fia_is_dc_worker = isJust (isDataConId_maybe bndr) -- mkCaseFloat uses False+  , fia_ok_for_spec = False -- mkNonRecFloat uses exprOkForSpecEval+  }++decideFloatInfo :: FloatInfoArgs -> (BindInfo, FloatInfo)+decideFloatInfo FIA{fia_levity=lev, fia_demand=dmd, fia_is_hnf=is_hnf,+                    fia_is_triv=is_triv, fia_is_string=is_string,+                    fia_is_dc_worker=is_dc_worker, fia_ok_for_spec=ok_for_spec}+  | Lifted <- lev, is_hnf, not is_triv = (LetBound, TopLvlFloatable)+      -- is_lifted: We currently don't allow unlifted values at the+      --            top-level or inside letrecs+      --            (but SG thinks that in principle, we should)+      -- is_triv:   Should not turn `case x of x' ->` into `let x' = x`+      --            when x is a HNF (cf. fun3 of T24264)+  | is_dc_worker          = (LetBound, TopLvlFloatable)+      -- We need this special case for nullary unlifted DataCon+      -- workers/wrappers (top-level bindings) until #17521 is fixed+  | is_string             = (CaseBound, TopLvlFloatable)+      -- String literals are unboxed (so must be case-bound) and float to+      -- the top-level+  | ok_for_spec           = (CaseBound, case lev of Unlifted -> LazyContextFloatable+                                                    Lifted   -> TopLvlFloatable)+      -- See Note [Speculative evaluation]+      -- Ok-for-spec-eval things will be case-bound, lifted or not.+      -- But when it's lifted we are ok with floating it to top-level+      -- (where it is actually bound lazily).+  | Unlifted <- lev       = (CaseBound, StrictContextFloatable)+  | isStrUsedDmd dmd      = (CaseBound, StrictContextFloatable)+      -- These will never be floated out of a lazy RHS context+  | Lifted   <- lev       = (LetBound, TopLvlFloatable)+      -- And these float freely but can't be speculated, hence LetBound++mkCaseFloat :: Id -> CpeRhs -> FloatingBind+mkCaseFloat bndr scrut+  = -- pprTrace "mkCaseFloat" (ppr bndr <+> ppr (bound,info)+    --                             -- <+> ppr is_lifted <+> ppr is_strict+    --                             -- <+> ppr ok_for_spec <+> ppr evald+    --                           $$ ppr scrut) $+    Float (NonRec bndr scrut) bound info+  where+    !(bound, info) = decideFloatInfo $ (defFloatInfoArgs bndr scrut)+      { fia_demand       = evalDmd+          -- Strict demand, so that we do not let-bind unless it's a value+      , fia_is_dc_worker = False+          -- DataCon worker *bindings* are never case-bound+      , fia_ok_for_spec  = False+          -- We do not currently float around case bindings.+          -- (ok-for-spec case bindings are unlikely anyway.)+      }++mkNonRecFloat :: CorePrepEnv -> Levity -> Id -> CpeRhs -> (FloatingBind, Id)+mkNonRecFloat env lev bndr rhs+  = -- pprTrace "mkNonRecFloat" (ppr bndr <+> ppr (bound,info)+    --                             <+> if is_strict then text "strict" else if is_lifted then text "lazy" else text "unlifted"+    --                             <+> if ok_for_spec then text "ok-for-spec" else empty+    --                             <+> if evald then text "evald" else empty+    --                           $$ ppr rhs) $+    (Float (NonRec bndr' rhs) bound info, bndr')+  where+    !(bound, info) = decideFloatInfo $ (defFloatInfoArgs bndr rhs)+      { fia_levity = lev+      , fia_is_hnf = is_hnf+      , fia_ok_for_spec = ok_for_spec+      }++    is_hnf      = exprIsHNF rhs+    cfg         = cpe_config env++    ok_for_spec = exprOkForSpecEval call_ok_for_spec rhs+    -- See Note [Controlling Speculative Evaluation]+    call_ok_for_spec x+      | is_rec_call x                           = False+      | not (cp_specEval cfg)                   = False+      | not (cp_specEvalDFun cfg) && isDFunId x = False+      | otherwise                               = True+    is_rec_call = (`elemUnVarSet` cpe_rec_ids env)++    -- See Note [Pin evaluatedness on floats]+    bndr' | is_hnf    = bndr `setIdUnfolding` evaldUnfolding+          | otherwise = bndr++-- | Wrap floats around an expression+wrapBinds :: Floats -> CpeBody -> CpeBody+wrapBinds floats body+  = -- pprTraceWith "wrapBinds" (\res -> ppr floats $$ ppr body $$ ppr res) $+    foldrOL mk_bind body (getFloats floats)+  where+    -- See Note [BindInfo and FloatInfo] on whether we pick Case or Let here+    mk_bind f@(Float bind CaseBound _) body+      | NonRec bndr rhs <- bind+      = mkDefaultCase rhs bndr body+      | otherwise+      = pprPanic "wrapBinds" (ppr f)+    mk_bind (Float bind _ _) body+      = Let bind body+    mk_bind (UnsafeEqualityCase scrut b con bs) body+      = mkSingleAltCase scrut b con bs body+    mk_bind (FloatTick tickish) body+      = mkTick tickish body++-- | Put floats at top-level+deFloatTop :: Floats -> [CoreBind]+-- Precondition: No Strict or LazyContextFloatable 'FloatInfo', no ticks!+deFloatTop floats+  = foldrOL get [] (getFloats floats)+  where+    get (Float b _ TopLvlFloatable) bs+      = get_bind b : bs+    get b _  = pprPanic "deFloatTop" (ppr b)++    -- See Note [Dead code in CorePrep]+    get_bind (NonRec x e) = NonRec x (occurAnalyseExpr e)+    get_bind (Rec xes)    = Rec [(x, occurAnalyseExpr e) | (x, e) <- xes]++---------------------------------------------------------------------------++{- Note [wantFloatLocal]+~~~~~~~~~~~~~~~~~~~~~~~~+Consider+  let x = let y = e1 in e2+  in e+Similarly for `(\x. e) (let y = e1 in e2)`.+Do we want to float `y` out of `x`?+(This is discussed in detail in the paper+"Let-floating: moving bindings to give faster programs".)++`wantFloatLocal` is concerned with answering this question.+It considers the Demand on `x`, whether or not `e2` is unlifted and the+`FloatInfo` of the `y` binding (e.g., it might itself be unlifted, a value,+strict, or ok-for-spec).++We float out if ...+  1. ... the binding context is strict anyway, so either `x` is used strictly+     or has unlifted type.+     Doing so is trivially sound and won`t increase allocations, so we+     return `FloatAll`.+     This might happen while ANF-ising `f (g (h 13))` where `f`,`g` are strict:+       f (g (h 13))+       ==> { ANF }+       case (case h 13 of r -> g r) of r2 -> f r2+       ==> { Float }+       case h 13 of r -> case g r of r2 -> f r2+     The latter is easier to read and grows less stack.+  2. ... `e2` becomes a value in doing so, in which case we won't need to+     allocate a thunk for `x`/the arg that closes over the FVs of `e1`.+     In general, this is only sound if `y=e1` is `LazyContextFloatable`.+     (See Note [BindInfo and FloatInfo].)+     Nothing is won if `x` doesn't become a value+     (i.e., `let x = let sat = f 14 in g sat in e`),+     so we return `FloatNone` if there is any float that is+     `StrictContextFloatable`, and return `FloatAll` otherwise.++To elaborate on (2), consider the case when the floated binding is+`e1 = divInt# a b`, e.g., not `LazyContextFloatable`:+  let x = I# (a `divInt#` b)+  in e+this ANFises to+  let x = case a `divInt#` b of r { __DEFAULT -> I# r }+  in e+If `x` is used lazily, we may not float `r` further out.+A float binding `x +# y` is OK, though, and so every ok-for-spec-eval+binding is `LazyContextFloatable`.++Wrinkles:++ (W1) When the outer binding is a letrec, i.e.,+        letrec x = case a +# b of r { __DEFAULT -> f y r }+               y = [x]+        in e+      we don't want to float `LazyContextFloatable` bindings such as `r` either+      and require `TopLvlFloatable` instead.+      The reason is that we don't track FV of FloatBindings, so we would need+      to park them in the letrec,+        letrec r = a +# b -- NB: r`s RHS might scope over x and y+               x = f y r+               y = [x]+        in e+      and now we have violated Note [Core letrec invariant].+      So we preempt this case in `wantFloatLocal`, responding `FloatNone` unless+      all floats are `TopLvlFloatable`.+-}++data FloatDecision+  = FloatNone+  | FloatAll++instance Outputable FloatDecision where+  ppr FloatNone = text "none"+  ppr FloatAll  = text "all"++executeFloatDecision :: CorePrepEnv -> FloatDecision -> Floats -> CpeRhs -> UniqSM (Floats, CpeRhs)+executeFloatDecision env dec floats rhs+  = case dec of+      FloatAll                 -> return (floats, rhs)+      FloatNone+        | isEmptyFloats floats -> return (emptyFloats, rhs)+        | otherwise            -> do { (floats', body) <- rhsToBody env rhs+                                     ; return (emptyFloats, wrapBinds floats $+                                                            wrapBinds floats' body) }+            -- FloatNone case: `rhs` might have lambdas, and we can't+            -- put them inside a wrapBinds, which expects a `CpeBody`.++wantFloatTop :: Floats -> FloatDecision+wantFloatTop fs+  | fs_info fs `floatsAtLeastAsFarAs` TopLvlFloatable = FloatAll+  | otherwise                                         = FloatNone++wantFloatLocal :: RecFlag -> Demand -> Levity -> Floats -> CpeRhs -> FloatDecision+-- See Note [wantFloatLocal]+wantFloatLocal is_rec rhs_dmd rhs_lev floats rhs+  |  isEmptyFloats floats -- Well yeah...+  || isStrUsedDmd rhs_dmd -- Case (1) of Note [wantFloatLocal]+  || rhs_lev == Unlifted  -- dito+  || (fs_info floats `floatsAtLeastAsFarAs` max_float_info && exprIsHNF rhs)+                          -- Case (2) of Note [wantFloatLocal]+  = FloatAll++  | otherwise+  = FloatNone+  where+    max_float_info | isRec is_rec = TopLvlFloatable+                   | otherwise    = LazyContextFloatable+                    -- See Note [wantFloatLocal], Wrinkle (W1)+                    -- for 'is_rec'++{-+************************************************************************+*                                                                      *+                Cloning+*                                                                      *+************************************************************************+-}++-- ---------------------------------------------------------------------------+--                      The environment+-- ---------------------------------------------------------------------------++{- Note [Inlining in CorePrep]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+There is a subtle but important invariant that must be upheld in the output+of CorePrep: there are no "trivial" updatable thunks.  Thus, this Core+is impermissible:++     let x :: ()+         x = y++(where y is a reference to a GLOBAL variable).  Thunks like this are silly:+they can always be profitably replaced by inlining x with y. Consequently,+the code generator/runtime does not bother implementing this properly+(specifically, there is no implementation of stg_ap_0_upd_info, which is the+stack frame that would be used to update this thunk.  The "0" means it has+zero free variables.)++In general, the inliner is good at eliminating these let-bindings.  However,+there is one case where these trivial updatable thunks can arise: when+we are optimizing away 'lazy' (see Note [lazyId magic], and also+'cpeRhsE'.)  Then, we could have started with:++     let x :: ()+         x = lazy @() y++which is a perfectly fine, non-trivial thunk, but then CorePrep will drop+'lazy', giving us 'x = y' which is trivial and impermissible.  The solution is+CorePrep to have a miniature inlining pass which deals with cases like this.+We can then drop the let-binding altogether.++Why does the removal of 'lazy' have to occur in CorePrep?  The gory details+are in Note [lazyId magic] in GHC.Types.Id.Make, but the main reason is that+lazy must appear in unfoldings (optimizer output) and it must prevent+call-by-value for catch# (which is implemented by CorePrep.)++An alternate strategy for solving this problem is to have the inliner treat+'lazy e' as a trivial expression if 'e' is trivial.  We decided not to adopt+this solution to keep the definition of 'exprIsTrivial' simple.++There is ONE caveat however: for top-level bindings we have+to preserve the binding so that we float the (hacky) non-recursive+binding for data constructors; see Note [Data constructor workers].++Note [CorePrepEnv: cpe_subst]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+CorePrepEnv carries a substitution `Subst` in the `cpe_subst1 field,+for these reasons:++1. To support cloning of local Ids so that they are+   all unique (see Note [Cloning in CorePrep])++2. To support beta-reduction of runRW, see Note [runRW magic] and+   Note [runRW arg].++3. To let us inline trivial RHSs of non top-level let-bindings,+   see Note [lazyId magic], Note [Inlining in CorePrep] (#12076)++   Note that, if (y::forall a. a->a), we could get+      x = lazy @(forall a.a) y @Bool+   so after eliminating `lazy`, we need to replace occurrences of `x` with+   `y @Bool`, not just `y`.  Situations like this can easily arise with+   higher-rank types; thus, `cpe_subst` must map to CoreExprs, not Ids, which+   oc course it does++4. The TyCoVar part of the substitution is used only for+   Note [Cloning CoVars and TyVars]+-}++data CorePrepConfig = CorePrepConfig+  { cp_catchNonexhaustiveCases :: !Bool+  -- ^ Whether to generate a default alternative with ``error`` in these+  -- cases. This is helpful when debugging demand analysis or type+  -- checker bugs which can sometimes manifest as segmentation faults.++  , cp_platform                :: Platform++  , cp_arityOpts               :: !(Maybe ArityOpts)+  -- ^ Configuration for arity analysis ('exprEtaExpandArity').+  -- See Note [Eta expansion of arguments in CorePrep]+  -- When 'Nothing' (e.g., -O0, -O1), use the cheaper 'exprArity' instead+  , cp_specEval                :: !Bool+  -- ^ Whether to perform speculative evaluation+  -- See Note [Controlling Speculative Evaluation]+  , cp_specEvalDFun            :: !Bool+  -- ^ Whether to perform speculative evaluation on DFuns+  }++data CorePrepEnv+  = CPE { cpe_config          :: !CorePrepConfig+        -- ^ This flag is intended to aid in debugging strictness+        -- analysis bugs. These are particularly nasty to chase down as+        -- they may manifest as segmentation faults. When this flag is+        -- enabled we instead produce an 'error' expression to catch+        -- the case where a function we think should bottom+        -- unexpectedly returns.++        , cpe_subst :: Subst  -- ^ See Note [CorePrepEnv: cpe_subst]++        , cpe_rec_ids :: UnVarSet -- Faster OutIdSet; See Note [Speculative evaluation]++        , cpe_context :: [OccName] -- ^ See Note [Binder context]+    }++mkInitialCorePrepEnv :: CorePrepConfig -> CorePrepEnv+mkInitialCorePrepEnv cfg = CPE+      { cpe_config        = cfg+      , cpe_subst         = emptySubst+      , cpe_rec_ids       = emptyUnVarSet+      , cpe_context       = []+      }++extendCorePrepEnv :: CorePrepEnv -> Id -> Id -> CorePrepEnv+extendCorePrepEnv cpe@(CPE { cpe_subst = subst }) id id'+    = cpe { cpe_subst = subst2 }+    where+      subst1 = extendSubstInScope subst id'+      subst2 = extendIdSubst subst1 id (Var id')++extendCorePrepEnvList :: CorePrepEnv -> [(Id,Id)] -> CorePrepEnv+extendCorePrepEnvList cpe@(CPE { cpe_subst = subst }) prs+    = cpe { cpe_subst = subst2 }+    where+      subst1 = extendSubstInScopeList subst (map snd prs)+      subst2 = extendIdSubstList subst1 [(id, Var id') | (id,id') <- prs]++extendCorePrepEnvExpr :: CorePrepEnv -> Id -> CoreExpr -> CorePrepEnv+extendCorePrepEnvExpr cpe id expr+    = cpe { cpe_subst = extendIdSubst (cpe_subst cpe) id expr }++lookupCorePrepEnv :: CorePrepEnv -> Id -> CoreExpr+lookupCorePrepEnv cpe id+  = case lookupIdSubst_maybe (cpe_subst cpe) id of+       Just e -> e+       Nothing -> Var id+    -- Do not use GHC.Core.Subs.lookupIdSubst because that is a no-op on GblIds;+    -- and Tidy has made top-level externally-visible Ids into GblIds++enterRecGroupRHSs :: CorePrepEnv -> [OutId] -> CorePrepEnv+enterRecGroupRHSs env grp+  = env { cpe_rec_ids = extendUnVarSetList grp (cpe_rec_ids env) }++cpSubstTy :: CorePrepEnv -> Type -> Type+cpSubstTy (CPE { cpe_subst = subst }) ty = substTy subst ty+          -- substTy has a short-cut if the TCvSubst is empty++cpSubstCo :: CorePrepEnv -> Coercion -> Coercion+cpSubstCo (CPE { cpe_subst = subst }) co = substCo subst co+          -- substCo has a short-cut if the TCvSubst is empty++-- | See Note [Binder context]+pushBinderContext :: Id -> CorePrepEnv -> CorePrepEnv+pushBinderContext ident env+  | lengthAtLeast (cpe_context env) 2+  = env+  | otherwise+  = env { cpe_context = getOccName ident : cpe_context env}++------------------------------------------------------------------------------+-- Cloning binders+-- ---------------------------------------------------------------------------++cpCloneBndrs :: CorePrepEnv -> [InVar] -> UniqSM (CorePrepEnv, [OutVar])+cpCloneBndrs env bs = mapAccumLM cpCloneBndr env bs++cpCloneCoVarBndr :: CorePrepEnv -> InVar -> UniqSM (CorePrepEnv, OutVar)+-- Clone the CoVar+-- See Note [Cloning CoVars and TyVars]+cpCloneCoVarBndr env@(CPE { cpe_subst = subst }) covar+  = assertPpr (isCoVar covar) (ppr covar) $+    do { uniq <- getUniqueM+       ; let covar1 = setVarUnique covar uniq+             covar2 = updateVarType (substTy subst) covar1+             subst1 = extendTCvSubstWithClone subst covar covar2+       ; return (env { cpe_subst = subst1 }, covar2) }++cpCloneBndr  :: CorePrepEnv -> InVar -> UniqSM (CorePrepEnv, OutVar)+-- See Note [Cloning in CorePrep]+cpCloneBndr env@(CPE { cpe_subst = subst }) bndr+  | isTyCoVar bndr  -- See Note [Cloning CoVars and TyVars]+  = if isEmptyTCvSubst subst    -- The common case+    then return (env { cpe_subst = extendSubstInScope subst bndr }, bndr)+    else -- No need to clone the Unique; but we must apply the substitution+         let bndr1  = updateVarType (substTy subst) bndr+             subst1 = extendTCvSubstWithClone subst bndr bndr1+         in return (env { cpe_subst = subst1 }, bndr1)++  | otherwise  -- A non-CoVar Id+  = do { bndr1 <- clone_it bndr+       ; let bndr2 = updateIdTypeAndMult (substTy subst) bndr1++       -- Drop (now-useless) rules/unfoldings+       -- See Note [Drop unfoldings and rules]+       -- and Note [Preserve evaluatedness] in GHC.Core.Tidy+       -- And force it.. otherwise the old unfolding is just retained.+       -- See #22071+       ; let !unfolding' = trimUnfolding (realIdUnfolding bndr)+                          -- Simplifier will set the Id's unfolding++             bndr3 = bndr2 `setIdUnfolding`      unfolding'+                           `setIdSpecialisation` emptyRuleInfo++       ; return (extendCorePrepEnv env bndr bndr3, bndr3) }+  where+    clone_it bndr+      | isLocalId bndr+      = do { uniq <- getUniqueM+           ; return (setVarUnique bndr uniq) }++      | otherwise   -- Top level things, which we don't want+                    -- to clone, have become GlobalIds by now+      = return bndr++{- Note [Drop unfoldings and rules]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We want to drop the unfolding/rules on every Id:++  - We are now past interface-file generation, and in the+    codegen pipeline, so we really don't need full unfoldings/rules++  - The unfolding/rule may be keeping stuff alive that we'd like+    to discard.  See  Note [Dead code in CorePrep]++  - Getting rid of unnecessary unfoldings reduces heap usage++  - We are changing uniques, so if we didn't discard unfoldings/rules+    we'd have to substitute in them++HOWEVER, we want to preserve evaluated-ness;+see Note [Preserve evaluatedness] in GHC.Core.Tidy.+-}++------------------------------------------------------------------------------+-- Cloning ccall Ids; each must have a unique name,+-- to give the code generator a handle to hang it on+-- ---------------------------------------------------------------------------++fiddleCCall :: Id -> UniqSM Id+fiddleCCall id+  | isFCallId id = (id `setVarUnique`) <$> getUniqueM+  | otherwise    = return id++------------------------------------------------------------------------------+-- Generating new binders+-- ---------------------------------------------------------------------------++newVar :: CorePrepEnv ->  Type -> UniqSM Id+newVar env ty+ -- See Note [Binder context]+ = seqType ty `seq` mkSysLocalOrCoVarM (fsLit occ) ManyTy ty+   where occ = intercalate "_" (map occNameString $ cpe_context env) ++ "_sat"++{- Note [Binder context]+   ~~~~~~~~~~~~~~~~~~~~~+   To ensure that the compiled program (specifically symbol names)+   remains understandable to the user we maintain a context+   of binders that we are currently under. This allows us to give+   identifiers conjured during CorePrep more contextually-meaningful+   names. This is done in `newVar`.+ -}++------------------------------------------------------------------------------+-- Floating ticks+-- ---------------------------------------------------------------------------+--+-- Note [Floating Ticks in CorePrep]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- It might seem counter-intuitive to float ticks by default, given+-- that we don't actually want to move them if we can help it. On the+-- other hand, nothing gets very far in CorePrep anyway, and we want+-- to preserve the order of let bindings and tick annotations in+-- relation to each other. For example, if we just wrapped let floats+-- when they pass through ticks, we might end up performing the+-- following transformation:+--+--   src<...> let foo = bar in baz+--   ==>  let foo = src<...> bar in src<...> baz+--+-- Because the let-binding would float through the tick, and then+-- immediately materialize, achieving nothing but decreasing tick+-- accuracy. The only special case is the following scenario:+--+--   let foo = src<...> (let a = b in bar) in baz+--   ==>  let foo = src<...> bar; a = src<...> b in baz+--+-- Here we would not want the source tick to end up covering "baz" and+-- therefore refrain from pushing ticks outside. Instead, we copy them+-- into the floating binds (here "a") in cpePair. Note that where "b"+-- or "bar" are (value) lambdas we have to push the annotations+-- further inside in order to uphold our rules.+--+-- All of this is implemented below in @wrapTicks@.++-- | Like wrapFloats, but only wraps tick floats+wrapTicks :: Floats -> CoreExpr -> (Floats, CoreExpr)+wrapTicks floats expr+  | (floats1, ticks1) <- fold_fun go floats+  = (floats1, foldrOL mkTick expr ticks1)+  where fold_fun f floats =+           let (binds, ticks) = foldlOL f (nilOL,nilOL) (fs_binds floats)+           in (floats { fs_binds = binds }, ticks)+        -- Deeply nested constructors will produce long lists of+        -- redundant source note floats here. We need to eliminate+        -- those early, as relying on mkTick to spot it after the fact+        -- can yield O(n^3) complexity [#11095]+        go (flt_binds, ticks) (FloatTick t)+          = assert (tickishPlace t == PlaceNonLam)+            (flt_binds, if any (flip tickishContains t) ticks+                        then ticks else ticks `snocOL` t)+        go (flt_binds, ticks) f@UnsafeEqualityCase{}+          -- unsafe equality case will be erased; don't wrap anything!+          = (flt_binds `snocOL` f, ticks)+        go (flt_binds, ticks) f@Float{}+          = (flt_binds `snocOL` foldrOL wrap f ticks, ticks)++        wrap t (Float bind bound info) = Float (wrapBind t bind) bound info+        wrap _ f                 = pprPanic "Unexpected FloatingBind" (ppr f)+        wrapBind t (NonRec binder rhs) = NonRec binder (mkTick t rhs)+        wrapBind t (Rec pairs)         = Rec (mapSnd (mkTick t) pairs)++------------------------------------------------------------------------------+-- Numeric literals+-- ---------------------------------------------------------------------------++-- | Converts Bignum literals into their final CoreExpr+cpeBigNatLit+   :: CorePrepEnv -> Integer -> UniqSM (Floats, CpeRhs)+cpeBigNatLit env i = assert (i >= 0) $ do+  let+    platform = cp_platform (cpe_config env)++    -- Per the documentation in GHC.Internal.Bignum.BigNat, a BigNat# is:+    --   "Represented as an array of limbs (Word#) stored in+    --   little-endian order (Word# themselves use machine order)."+    --+    --   "Invariant (canonical representation): higher Word# is non-zero."+    -- So we need to break up the integer into target-word-sized chunks,+    -- and encode each of them using the target's byte-order.+    encodeBigNat+      :: forall a. Num a => FixedPrim a -> BS.ByteString+    encodeBigNat encodeWord+      = BS.toStrict (BB.toLazyByteString (primUnfoldrFixed encodeWord f i))+      -- (quadratic complexity due to repeated shifts... ok for now)+      where+        f 0 = Nothing+        f x = let low  = fromInteger x :: a+                  high = x `shiftR` bits+              in Just (low, high)+        bits = platformWordSizeInBits platform++    words :: BS.ByteString+    words = case (platformWordSize platform, platformByteOrder platform) of+      (PW4, LittleEndian) -> encodeBigNat word32LE+      (PW4, BigEndian   ) -> encodeBigNat word32BE+      (PW8, LittleEndian) -> encodeBigNat word64LE+      (PW8, BigEndian   ) -> encodeBigNat word64BE++  -- Ideally we would just generate a ByteArray# literal here:+  --   pure (emptyFloats, Lit (LitByteArray words))+  -- But sadly we don't have those yet, even in Core. (See also #17747.)+  -- So instead we generate:+  --   * An `Addr#` literal that contains the contents of the+  --      `ByteArray#` we want to create.  This gets its own float.+  --   * A call to `newByteArray#` with the appropriate size+  --   * A call to `copyAddrToByteArray#` to initialize the `ByteArray#`+  --   * A call to `unsafeFreezeByteArray#` to make the types match+  litAddrId <- mkSysLocalM (fsLit "bigNatGuts") ManyTy addrPrimTy+  -- returned from newByteArray#:+  deadNewByteArrayTupleId+    <- fmap (`setIdOccInfo` IAmDead) . mkSysLocalM (fsLit "tup") ManyTy $+         mkTupleTy Unboxed [ realWorldStatePrimTy+                           , realWorldMutableByteArrayPrimTy+                           ]+  stateTokenFromNewByteArrayId+    <- mkSysLocalM (fsLit "token") ManyTy realWorldStatePrimTy+  mutableByteArrayId+    <- mkSysLocalM (fsLit "mba") ManyTy realWorldMutableByteArrayPrimTy+  -- returned from copyAddrToByteArray#:+  stateTokenFromCopyId+    <- mkSysLocalM (fsLit "token") ManyTy realWorldStatePrimTy+  -- returned from unsafeFreezeByteArray#:+  deadFreezeTupleId+    <- fmap (`setIdOccInfo` IAmDead) . mkSysLocalM (fsLit "tup") ManyTy $+         mkTupleTy Unboxed [realWorldStatePrimTy, byteArrayPrimTy]+  stateTokenFromFreezeId+    <- (`setIdOccInfo` IAmDead) <$>+         mkSysLocalM (fsLit "token") ManyTy realWorldStatePrimTy+  byteArrayId <- mkSysLocalM (fsLit "ba") ManyTy byteArrayPrimTy++  let+    litAddrRhs = Lit (LitString words)+      -- not "mkLitString"; that does UTF-8 encoding, which we don't want here+    (litAddrFloat, litAddrId') = mkNonRecFloat env Unlifted litAddrId litAddrRhs++    contentsLength = mkIntLit platform (toInteger (BS.length words))++    newByteArrayCall =+      Var (primOpId NewByteArrayOp_Char)+        `App` Type realWorldTy+        `App` contentsLength+        `App` Var realWorldPrimId++    copyContentsCall =+      Var (primOpId CopyAddrToByteArrayOp)+        `App` Type realWorldTy+        `App` Var litAddrId'+        `App` Var mutableByteArrayId+        `App` mkIntLit platform 0+        `App` contentsLength+        `App` Var stateTokenFromNewByteArrayId++    unsafeFreezeCall =+      Var (primOpId UnsafeFreezeByteArrayOp)+        `App` Type realWorldTy+        `App` Var mutableByteArrayId+        `App` Var stateTokenFromCopyId++    unboxed2tuple_altcon :: AltCon+    unboxed2tuple_altcon = DataAlt (tupleDataCon Unboxed 2)++    finalRhs =+      Case newByteArrayCall deadNewByteArrayTupleId byteArrayPrimTy+        [ Alt unboxed2tuple_altcon+              [stateTokenFromNewByteArrayId, mutableByteArrayId]+              copyContentsCase+        ]++    copyContentsCase =+      Case copyContentsCall stateTokenFromCopyId byteArrayPrimTy+        [ Alt DEFAULT [] unsafeFreezeCase+        ]++    unsafeFreezeCase =+      Case unsafeFreezeCall deadFreezeTupleId byteArrayPrimTy+        [ Alt unboxed2tuple_altcon+              [stateTokenFromFreezeId, byteArrayId]+              (Var byteArrayId)+        ]++  pure (emptyFloats `snocFloat` litAddrFloat, finalRhs)
GHC/Data/Bag.hs view
@@ -6,20 +6,21 @@ Bag: an unordered collection with duplicates -} -{-# LANGUAGE ScopedTypeVariables, DeriveFunctor, TypeFamilies #-}+{-# 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,+        mapBag, pprBag,         elemBag, lengthBag,         filterBag, partitionBag, partitionBagWith,-        concatBag, catBagMaybes, foldBag,+        concatBag, catBagMaybes, foldBag_flip,         isEmptyBag, isSingletonBag, consBag, snocBag, anyBag, allBag,         listToBag, nonEmptyToBag, bagToList, headMaybe, mapAccumBagL,-        concatMapBag, concatMapBagPair, mapMaybeBag,-        mapBagM, mapBagM_,+        concatMapBag, concatMapBagPair, mapMaybeBag, mapMaybeBagM, unzipBag,+        mapBagM, mapBagM_, lookupBag,         flatMapBagM, flatMapBagPairM,         mapAndUnzipBagM, mapAccumBagLM,         anyBagM, filterBagM@@ -33,11 +34,13 @@ import GHC.Utils.Monad import Control.Monad import Data.Data-import Data.Maybe( mapMaybe, listToMaybe )+import Data.Maybe( mapMaybe ) import Data.List ( partition, mapAccumL ) import Data.List.NonEmpty ( NonEmpty(..) )-import qualified Data.Foldable as Foldable+import qualified Data.List.NonEmpty as NE import qualified Data.Semigroup ( (<>) )+import Control.Applicative( Alternative( (<|>) ) )+import Control.DeepSeq  infixr 3 `consBag` infixl 3 `snocBag`@@ -46,9 +49,15 @@   = EmptyBag   | UnitBag a   | TwoBags (Bag a) (Bag a) -- INVARIANT: neither branch is empty-  | ListBag [a]             -- INVARIANT: the list is non-empty-  deriving (Functor)+  | 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 @@ -91,7 +100,7 @@ isSingletonBag EmptyBag      = False isSingletonBag (UnitBag _)   = True isSingletonBag (TwoBags _ _) = False          -- Neither is empty-isSingletonBag (ListBag xs)  = isSingleton xs+isSingletonBag (ListBag (_:|xs)) = null xs  filterBag :: (a -> Bool) -> Bag a -> Bag a filterBag _    EmptyBag = EmptyBag@@ -99,7 +108,7 @@ 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)+filterBag pred (ListBag vs)    = listToBag (filter pred (toList vs))  filterBagM :: Monad m => (a -> m Bool) -> Bag a -> m (Bag a) filterBagM _    EmptyBag = return EmptyBag@@ -112,9 +121,21 @@   sat2 <- filterBagM pred b2   return (sat1 `unionBags` sat2) filterBagM pred (ListBag vs) = do-  sat <- filterM pred vs+  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@@ -134,11 +155,10 @@                                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 bss = foldr add emptyBag bss-  where-    add bs rs = bs `unionBags` rs+concatBag = foldr unionBags emptyBag  catBagMaybes :: Bag (Maybe a) -> Bag a catBagMaybes bs = foldr add emptyBag bs@@ -156,7 +176,7 @@   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+  where (sats, fails) = partition pred (toList vs)   partitionBagWith :: (a -> Either b c) -> Bag a@@ -172,26 +192,12 @@   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--}+  where (sats, fails) = partitionWith pred (toList vs) --- 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+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@@ -221,8 +227,19 @@                                   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)+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@@ -232,12 +249,14 @@                                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@@ -248,6 +267,7 @@ 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)@@ -259,6 +279,7 @@   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)@@ -268,8 +289,9 @@                                        (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+                                       let (rs,ss) = NE.unzip ts                                        return (ListBag rs, ListBag ss)+{-# INLINEABLE mapAndUnzipBagM #-}  mapAccumBagL ::(acc -> x -> (acc, y)) -- ^ combining function             -> acc                    -- ^ initial state@@ -295,56 +317,49 @@                                        ; 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 vs = ListBag vs+listToBag (x:xs) = ListBag (x:|xs)  nonEmptyToBag :: NonEmpty a -> Bag a nonEmptyToBag (x :| []) = UnitBag x-nonEmptyToBag (x :| xs) = ListBag (x : xs)+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 l) = listToMaybe l+headMaybe (ListBag (v:|_)) = Just v  instance (Outputable a) => Outputable (Bag a) where-    ppr bag = braces (pprWithCommas ppr (bagToList bag))+    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 Foldable.Foldable Bag where-  foldr _ z EmptyBag        = z-  foldr k z (UnitBag x)     = k x z-  foldr k z (TwoBags b1 b2) = foldr k (foldr k z b2) b1-  foldr k z (ListBag xs)    = foldr k z xs--  foldl _ z EmptyBag        = z-  foldl k z (UnitBag x)     = k z x-  foldl k z (TwoBags b1 b2) = foldl k (foldl k z b1) b2-  foldl k z (ListBag xs)    = foldl k z xs--  foldl' _ z EmptyBag        = z-  foldl' k z (UnitBag x)     = k z x-  foldl' k z (TwoBags b1 b2) = let r1 = foldl' k z b1 in seq r1 $ foldl' k r1 b2-  foldl' k z (ListBag xs)    = foldl' k z xs--instance Traversable Bag where-  traverse _ EmptyBag        = pure EmptyBag-  traverse f (UnitBag x)     = UnitBag <$> f x-  traverse f (TwoBags b1 b2) = TwoBags <$> traverse f b1 <*> traverse f b2-  traverse f (ListBag xs)    = ListBag <$> traverse f xs  instance IsList (Bag a) where   type Item (Bag a) = a
GHC/Data/Bitmap.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE BangPatterns #-}- -- -- (c) The University of Glasgow 2003-2006 --
GHC/Data/Bool.hs view
@@ -4,7 +4,7 @@   ) where -import GHC.Prelude+import GHC.Prelude.Basic  data OverridingBool   = Auto
GHC/Data/BooleanFormula.hs view
@@ -1,5 +1,6 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveTraversable  #-}+{-# OPTIONS_GHC -Wno-orphans #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE TypeFamilies #-}  -------------------------------------------------------------------------------- -- | Boolean formulas without quantifiers and without negation.@@ -8,75 +9,64 @@ -- This module is used to represent minimal complete definitions for classes. -- module GHC.Data.BooleanFormula (-        BooleanFormula(..), LBooleanFormula,-        mkFalse, mkTrue, mkAnd, mkOr, mkVar,+        module Language.Haskell.Syntax.BooleanFormula,         isFalse, isTrue,+        bfMap, bfTraverse,         eval, simplify, isUnsatisfied,         implies, impliesAtom,-        pprBooleanFormula, pprBooleanFormulaNice+        pprBooleanFormula, pprBooleanFormulaNice, pprBooleanFormulaNormal   ) where -import GHC.Prelude--import Data.List ( nub, intersperse )-import Data.Data+import Data.List ( intersperse )+import Data.List.NonEmpty ( NonEmpty (..), init, last ) -import GHC.Utils.Monad-import GHC.Utils.Outputable-import GHC.Utils.Binary-import GHC.Parser.Annotation ( LocatedL )-import GHC.Types.SrcLoc+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 LBooleanFormula a = LocatedL (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 []+type instance Anno (BooleanFormula (GhcPass p)) = SrcSpanAnnL --- Convert a Bool to a BooleanFormula-mkBool :: Bool -> BooleanFormula a-mkBool False = mkFalse-mkBool True  = mkTrue+-- 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. --- Make a conjunction, and try to simplify-mkAnd :: Eq a => [LBooleanFormula a] -> BooleanFormula a-mkAnd = maybe mkFalse (mkAnd' . nub) . concatMapM fromAnd+-- 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-  -- 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+    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 -mkOr :: Eq a => [LBooleanFormula a] -> BooleanFormula a-mkOr = maybe mkTrue (mkOr' . nub) . concatMapM fromOr+bfTraverse  :: Applicative f+            => (LIdP (GhcPass p) -> f (LIdP (GhcPass p')))+            -> BooleanFormula (GhcPass p)+            -> f (BooleanFormula (GhcPass p'))+bfTraverse f = go   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+    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] ~~~~~~~~~~~~~~~~~~~~~~@@ -115,15 +105,15 @@ -- Evaluation and simplification ---------------------------------------------------------------------- -isFalse :: BooleanFormula a -> Bool+isFalse :: BooleanFormula (GhcPass p) -> Bool isFalse (Or []) = True isFalse _ = False -isTrue :: BooleanFormula a -> Bool+isTrue :: BooleanFormula (GhcPass p) -> Bool isTrue (And []) = True isTrue _ = False -eval :: (a -> Bool) -> BooleanFormula a -> Bool+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@@ -131,18 +121,24 @@  -- 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 :: 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 (\(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 (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 a => (a -> Bool) -> BooleanFormula a -> Maybe (BooleanFormula a)+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'@@ -155,42 +151,42 @@ --   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+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+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 :: (Uniquable (IdP (GhcPass p))) => BooleanFormula (GhcPass p) -> BooleanFormula (GhcPass p) -> Bool implies e1 e2 = go (Clause emptyUniqSet [e1]) (Clause emptyUniqSet [e2])   where-    go :: Uniquable a => Clause a -> Clause a -> Bool+    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 x r -> True-                  | otherwise -> go (extendClauseAtoms l x) { clauseExprs = hyps } r+            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 x l -> True-                  | otherwise -> go l (extendClauseAtoms r x) { clauseExprs = cons }+            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 a = Clause {-        clauseAtoms :: UniqSet a,-        clauseExprs :: [BooleanFormula a]+data Clause p = Clause {+        clauseAtoms :: UniqSet (IdP p),+        clauseExprs :: [BooleanFormula p]     }-extendClauseAtoms :: Uniquable a => Clause a -> a -> Clause a+extendClauseAtoms :: Uniquable (IdP p) => Clause p -> IdP p -> Clause p extendClauseAtoms c x = c { clauseAtoms = addOneToUniqSet (clauseAtoms c) x } -memberClauseAtoms :: Uniquable a => a -> Clause a -> Bool+memberClauseAtoms :: Uniquable (IdP p) => IdP p -> Clause p -> Bool memberClauseAtoms x c = x `elementOfUniqSet` clauseAtoms c  ----------------------------------------------------------------------@@ -199,65 +195,46 @@  -- 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'  :: (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 []) = 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 :: (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 a => BooleanFormula a -> SDoc+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' xs@(_:_) = fsep (punctuate comma (init xs)) <> text ", and" <+> last xs+  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 (OutputableBndr a) => Outputable (BooleanFormula a) where+instance OutputableBndrId p => Outputable (BooleanFormula (GhcPass p)) where   ppr = pprBooleanFormulaNormal -pprBooleanFormulaNormal :: (OutputableBndr a)-                        => BooleanFormula a -> SDoc+pprBooleanFormulaNormal :: OutputableBndrId p => BooleanFormula (GhcPass p) -> SDoc pprBooleanFormulaNormal = go   where-    go (Var x)    = pprPrefixOcc x+    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)---------------------------------------------------------------------------- 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
GHC/Data/EnumSet.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | A tiny wrapper around 'IntSet.IntSet' for representing sets of 'Enum' -- things. module GHC.Data.EnumSet@@ -15,11 +13,12 @@  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)+  deriving (Semigroup, Monoid, NFData)  member :: Enum a => a -> EnumSet a -> Bool member x (EnumSet s) = IntSet.member (fromEnum x) s
GHC/Data/FastMutInt.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples #-}+{-# LANGUAGE MagicHash, UnboxedTuples #-} {-# OPTIONS_GHC -O2 #-} -- We always optimise this, otherwise performance of a non-optimised -- compiler is severely affected@@ -13,7 +13,7 @@         atomicFetchAddFastMut   ) where -import GHC.Prelude+import GHC.Prelude.Basic  import GHC.Base
GHC/Data/FastString.hs view
@@ -1,15 +1,20 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# 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:@@ -30,8 +35,8 @@ --   * 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+--   * 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.@@ -52,10 +57,14 @@         fastStringToShortByteString,         mkFastStringShortByteString, +        -- * ShortText+        fastStringToShortText,+         -- * FastZString         FastZString,         hPutFZS,         zString,+        zStringTakeN,         lengthFZS,          -- * FastStrings@@ -82,11 +91,9 @@         lengthFS,         nullFS,         appendFS,-        headFS,         concatFS,         consFS,         nilFS,-        isUnderscoreFS,         lexicalCompareFS,         uniqCompareFS, @@ -102,16 +109,16 @@          -- ** Construction         mkPtrString#,-        mkPtrString,          -- ** Deconstruction         unpackPtrString,+        unpackPtrStringTakeN,          -- ** Operations         lengthPS        ) where -import GHC.Prelude as Prelude+import GHC.Prelude.Basic as Prelude  import GHC.Utils.Encoding import GHC.Utils.IO.Unsafe@@ -128,25 +135,17 @@ import qualified Data.ByteString.Char8    as BSC import qualified Data.ByteString.Unsafe   as BS import qualified Data.ByteString.Short    as SBS-#if !MIN_VERSION_bytestring(0,11,0)-import qualified Data.ByteString.Short.Internal as SBS-#endif+import GHC.Data.ShortText (ShortText(..)) import Foreign.C import System.IO import Data.Data import Data.IORef-import Data.Char import Data.Semigroup as Semi  import Foreign -#if MIN_VERSION_GLASGOW_HASKELL(9,3,0,0) import GHC.Conc.Sync    (sharedCAF)-#endif -#if __GLASGOW_HASKELL__ < 811-import GHC.Base (unpackCString#,unpackNBytes#)-#endif import GHC.Exts import GHC.IO @@ -161,6 +160,9 @@ fastStringToShortByteString :: FastString -> ShortByteString fastStringToShortByteString = fs_sbs +fastStringToShortText :: FastString -> ShortText+fastStringToShortText = ShortText . fs_sbs+ fastZStringToByteString :: FastZString -> ByteString fastZStringToByteString (FastZString bs) = bs @@ -183,6 +185,14 @@ 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 @@ -191,8 +201,8 @@  -- ----------------------------------------------------------------------------- -{-| A 'FastString' is a UTF-8 encoded string together with a unique ID. All-'FastString's are stored in a global hashtable to support fast O(1)+{-| 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@@ -276,13 +286,16 @@ -- `lexicalCompareFS` (i.e. which compares FastStrings on their String -- representation). Hence it is deterministic from one run to the other. newtype LexicalFastString-   = LexicalFastString FastString+   = 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 @@ -297,9 +310,18 @@ See Note [Updating the FastString table] on how it's updated. -} data FastStringTable = FastStringTable-  {-# UNPACK #-} !FastMutInt -- the unique ID counter shared with all buckets-  {-# UNPACK #-} !FastMutInt -- number of computed z-encodings for all buckets-  (Array# (IORef FastStringTableSegment)) -- concurrent segments+  {-# 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@@ -381,17 +403,13 @@    -- use the support wired into the RTS to share this CAF among all images of   -- libHSghc-#if !MIN_VERSION_GLASGOW_HASKELL(9,3,0,0)-  return tab-#else   sharedCAF tab getOrSetLibHSghcFastStringTable --- from the 9.3 RTS; the previouss RTS before might not have this symbol.  The+-- 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)-#endif  {- @@ -406,7 +424,8 @@ 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+   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@@ -459,8 +478,7 @@   FastStringTableSegment lock _ buckets# <- readIORef segmentRef   let idx# = hashToIndex# buckets# hash#   bucket <- IO $ readArray# buckets# idx#-  res <- bucket_match bucket sbs-  case res of+  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@@ -479,8 +497,7 @@       FastStringTableSegment _ counter buckets# <- maybeResizeSegment segmentRef       let idx# = hashToIndex# buckets# hash#       bucket <- IO $ readArray# buckets# idx#-      res <- bucket_match bucket sbs-      case res of+      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@@ -491,11 +508,16 @@           _ <- atomicFetchAddFastMut counter 1           return fs -bucket_match :: [FastString] -> ShortByteString -> IO (Maybe FastString)-bucket_match [] _ = return Nothing-bucket_match (fs@(FastString {fs_sbs=fs_sbs}) : ls) sbs-  | fs_sbs == sbs = return (Just fs)-  | otherwise     =  bucket_match ls sbs+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 =@@ -531,13 +553,13 @@ {-# NOINLINE[1] mkFastString #-} mkFastString str =   inlinePerformIO $ do-    sbs <- utf8EncodeShortByteString str+    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) = utf8EncodeString x #-}+"bytesFS/mkFastString" forall x. bytesFS (mkFastString x) = utf8EncodeByteString x #-}  -- | Creates a 'FastString' from a UTF-8 encoded @[Word8]@ mkFastStringByteList :: [Word8] -> FastString@@ -554,7 +576,7 @@                                -> FastMutInt -> IO FastString mkNewFastStringShortByteString sbs uid n_zencs = do   let zstr = mkZFastString n_zencs sbs-  chars <- countUTF8Chars sbs+      chars = utf8CountCharsShortByteString sbs   return (FastString uid chars sbs zstr)  hashStr  :: ShortByteString -> Int@@ -570,11 +592,7 @@           -- 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.-#if __GLASGOW_HASKELL__ >= 901           !c = int8ToInt# (indexInt8Array# ba# n)-#else-          !c = indexInt8Array# ba# n-#endif           !h2 = (h *# 16777619#) `xorI#` c         in           loop h2 (n +# 1#)@@ -590,7 +608,7 @@ nullFS :: FastString -> Bool nullFS fs = SBS.null $ fs_sbs fs --- | Unpacks and decodes the FastString+-- | Lazily unpacks and decodes the FastString unpackFS :: FastString -> String unpackFS fs = utf8DecodeShortByteString $ fs_sbs fs @@ -609,11 +627,6 @@ concatFS :: [FastString] -> FastString concatFS = mkFastStringShortByteString . mconcat . map fs_sbs -headFS :: FastString -> Char-headFS fs-  | SBS.null $ fs_sbs fs = panic "headFS: Empty FastString"-headFS fs = head $ unpackFS fs- consFS :: Char -> FastString -> FastString consFS c fs = mkFastString (c : unpackFS fs) @@ -629,9 +642,6 @@ nilFS :: FastString nilFS = mkFastString "" -isUnderscoreFS :: FastString -> Bool-isUnderscoreFS fs = fs == fsLit "_"- -- ----------------------------------------------------------------------------- -- Stats @@ -673,35 +683,19 @@ {-# INLINE mkPtrString# #-} mkPtrString# a# = PtrString (Ptr a#) (ptrStrLength (Ptr a#)) --- | Encode a 'String' into a newly allocated 'PtrString' using Latin-1--- encoding.  The original string must not contain non-Latin-1 characters--- (above codepoint @0xff@).-{-# NOINLINE[0] mkPtrString #-} -- see rules below-mkPtrString :: String -> PtrString-mkPtrString s =- -- we don't use `unsafeDupablePerformIO` here to avoid potential memory leaks- -- and because someone might be using `eqAddr#` to check for string equality.- unsafePerformIO (do-   let len = length s-   p <- mallocBytes len-   let-     loop :: Int -> String -> IO ()-     loop !_ []    = return ()-     loop n (c:cs) = do-        pokeByteOff p n (fromIntegral (ord c) :: Word8)-        loop (1+n) cs-   loop 0 s-   return (PtrString p len)- )--{-# RULES "mkPtrString"-    forall x . mkPtrString (unpackCString# x) = mkPtrString#  x #-}- -- | Decode a 'PtrString' back into a 'String' using Latin-1 encoding. -- This does not free the memory associated with 'PtrString'. unpackPtrString :: PtrString -> String 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@@ -709,10 +703,6 @@ -- ----------------------------------------------------------------------------- -- under the carpet -#if !MIN_VERSION_GLASGOW_HASKELL(9,0,0,0)-foreign import ccall unsafe "strlen"-  cstringLength# :: Addr# -> Int#-#endif  ptrStrLength :: Ptr Word8 -> Int {-# INLINE ptrStrLength #-}
GHC/Data/FastString/Env.hs view
@@ -18,7 +18,8 @@         filterFsEnv,         plusFsEnv, plusFsEnv_C, alterFsEnv,         lookupFsEnv, lookupFsEnv_NF, delFromFsEnv, delListFromFsEnv,-        elemFsEnv, mapFsEnv,+        elemFsEnv, mapFsEnv, strictMapFsEnv, mapMaybeFsEnv,+        nonDetFoldFsEnv,          -- * Deterministic FastString environments (maps)         DFastStringEnv,@@ -60,6 +61,7 @@ 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@@ -78,8 +80,19 @@ 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_NF" (lookupFsEnv env n)+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
+ GHC/Data/FlatBag.hs view
@@ -0,0 +1,132 @@+{-# LANGUAGE UnboxedTuples #-}+module GHC.Data.FlatBag+  ( FlatBag(EmptyFlatBag, UnitFlatBag, TupleFlatBag)+  , emptyFlatBag+  , unitFlatBag+  , sizeFlatBag+  , elemsFlatBag+  , mappendFlatBag+  -- * Construction+  , fromList+  , fromSmallArray+  ) where++import GHC.Prelude++import Control.DeepSeq++import GHC.Data.SmallArray++-- | Store elements in a flattened representation.+--+-- A 'FlatBag' is a data structure that stores an ordered list of elements+-- in a flat structure, avoiding the overhead of a linked list.+-- Use this data structure, if the code requires the following properties:+--+-- * Elements are stored in a long-lived object, and benefit from a flattened+--   representation.+-- * The 'FlatBag' will be traversed but not extended or filtered.+-- * The number of elements should be known.+-- * Sharing of the empty case improves memory behaviour.+--+-- A 'FlagBag' aims to have as little overhead as possible to store its elements.+-- To achieve that, it distinguishes between the empty case, singleton, tuple+-- and general case.+-- Thus, we only pay for the additional three words of an 'Array' if we have at least+-- three elements.+data FlatBag a+  = EmptyFlatBag+  | UnitFlatBag !a+  | TupleFlatBag !a !a+  | FlatBag {-# UNPACK #-} !(SmallArray a)++instance Functor FlatBag where+  fmap _ EmptyFlatBag = EmptyFlatBag+  fmap f (UnitFlatBag a) = UnitFlatBag $ f a+  fmap f (TupleFlatBag a b) = TupleFlatBag (f a) (f b)+  fmap f (FlatBag e) = FlatBag $ mapSmallArray f e++instance Foldable FlatBag where+  foldMap _ EmptyFlatBag = mempty+  foldMap f (UnitFlatBag a) = f a+  foldMap f (TupleFlatBag a b) = f a `mappend` f b+  foldMap f (FlatBag arr) = foldMapSmallArray f arr++  length = fromIntegral . sizeFlatBag++instance Traversable FlatBag where+  traverse _ EmptyFlatBag = pure EmptyFlatBag+  traverse f (UnitFlatBag a) = UnitFlatBag <$> f a+  traverse f (TupleFlatBag a b) = TupleFlatBag <$> f a <*> f b+  traverse f fl@(FlatBag arr) = fromList (fromIntegral $ sizeofSmallArray arr) <$> traverse f (elemsFlatBag fl)++instance NFData a => NFData (FlatBag a) where+  rnf EmptyFlatBag = ()+  rnf (UnitFlatBag a) = rnf a+  rnf (TupleFlatBag a b) = rnf a `seq` rnf b+  rnf (FlatBag arr) = rnfSmallArray arr++-- | Create an empty 'FlatBag'.+--+-- The empty 'FlatBag' is shared over all instances.+emptyFlatBag :: FlatBag a+emptyFlatBag = EmptyFlatBag++-- | Create a singleton 'FlatBag'.+unitFlatBag :: a -> FlatBag a+unitFlatBag = UnitFlatBag++-- | Calculate the size of+sizeFlatBag :: FlatBag a -> Word+sizeFlatBag EmptyFlatBag = 0+sizeFlatBag UnitFlatBag{} = 1+sizeFlatBag TupleFlatBag{} = 2+sizeFlatBag (FlatBag arr) = fromIntegral $ sizeofSmallArray arr++-- | Get all elements that are stored in the 'FlatBag'.+elemsFlatBag :: FlatBag a -> [a]+elemsFlatBag EmptyFlatBag = []+elemsFlatBag (UnitFlatBag a) = [a]+elemsFlatBag (TupleFlatBag a b) = [a, b]+elemsFlatBag (FlatBag arr) =+  [indexSmallArray arr i | i <- [0 .. sizeofSmallArray arr - 1]]++-- | Combine two 'FlatBag's.+--+-- The new 'FlatBag' contains all elements from both 'FlatBag's.+--+-- If one of the 'FlatBag's is empty, the old 'FlatBag' is reused.+mappendFlatBag :: FlatBag a -> FlatBag a -> FlatBag a+mappendFlatBag EmptyFlatBag b = b+mappendFlatBag a EmptyFlatBag = a+mappendFlatBag (UnitFlatBag a) (UnitFlatBag b) = TupleFlatBag a b+mappendFlatBag a b =+  fromList (sizeFlatBag a + sizeFlatBag b)+           (elemsFlatBag a ++ elemsFlatBag b)++-- | Store the list in a flattened memory representation, avoiding the memory overhead+-- of a linked list.+--+-- The size 'n' needs to be smaller or equal to the length of the list.+-- If it is smaller than the length of the list, overflowing elements are+-- discarded. It is undefined behaviour to set 'n' to be bigger than the+-- length of the list.+fromList :: Word -> [a] -> FlatBag a+fromList n elts =+  case elts of+    [] -> EmptyFlatBag+    [a] -> UnitFlatBag a+    [a, b] -> TupleFlatBag a b+    xs ->+      FlatBag (listToArray (fromIntegral n) fst snd (zip [0..] xs))++-- | Convert a 'SizedSeq' into its flattened representation.+-- A 'FlatBag a' is more memory efficient than '[a]', if no further modification+-- is necessary.+fromSmallArray :: SmallArray a -> FlatBag a+fromSmallArray s = case sizeofSmallArray s of+                      0 -> EmptyFlatBag+                      1 -> UnitFlatBag (indexSmallArray s 0)+                      2 -> TupleFlatBag (indexSmallArray s 0) (indexSmallArray s 1)+                      _ -> FlatBag s+
+ GHC/Data/Graph/Collapse.hs view
@@ -0,0 +1,259 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++module GHC.Data.Graph.Collapse+  ( PureSupernode(..)+  , Supernode(..)+  , collapseInductiveGraph+  , VizCollapseMonad(..)+  , NullCollapseViz(..)+  , runNullCollapse+  , MonadUniqDSM(..)+  )+where++import GHC.Prelude++import Control.Exception+import Control.Monad+import Data.List (delete, union, insert, intersect)+import Data.Semigroup++import GHC.Cmm.Dataflow.Label+import GHC.Data.Graph.Inductive.Graph+import GHC.Types.Unique.DSM+import GHC.Utils.Panic hiding (assert)+++{-|+Module      : GHC.Data.Graph.Collapse+Description : Implement the "collapsing" algorithm Hecht and Ullman++A control-flow graph is reducible if and only if it is collapsible+according to the definition of Hecht and Ullman (1972).   This module+implements the collapsing algorithm of Hecht and Ullman, and if it+encounters a graph that is not collapsible, it splits nodes until the+graph is fully collapsed.  It then reports what nodes (if any) had to+be split in order to collapse the graph.  The information is used+upstream to node-split Cmm graphs.++The module uses the inductive graph representation cloned from the+Functional Graph Library (Hackage package `fgl`, modules+`GHC.Data.Graph.Inductive.*`.)++-}++-- Full reference to paper: Matthew S. Hecht and Jeffrey D. Ullman+-- (1972).  Flow Graph Reducibility. SIAM J. Comput., 1(2), 188–202.+-- https://doi.org/10.1137/0201014+++------------------ Graph-splitting monad -----------------------++-- | If you want to visualize the graph-collapsing algorithm, create+-- an instance of monad `VizCollapseMonad`.  Each step in the+-- algorithm is announced to the monad as a side effect.  If you don't+-- care about visualization, you would use the `NullCollapseViz`+-- monad, in which these operations are no-ops.++class (MonadUniqDSM m, Graph gr, Supernode s m) => VizCollapseMonad m gr s where+  consumeByInGraph :: Node -> Node -> gr s () -> m ()+  splitGraphAt :: gr s () -> LNode s -> m ()+  finalGraph :: gr s () -> m ()++-- | The identity monad as a `VizCollapseMonad`.  Use this monad when+-- you want efficiency in graph collapse.+newtype NullCollapseViz a = NullCollapseViz { unNCV :: UniqDSM a }+  deriving (Functor, Applicative, Monad, MonadGetUnique)++instance MonadUniqDSM NullCollapseViz where+  liftUniqDSM = NullCollapseViz++instance (Graph gr, Supernode s NullCollapseViz) =>+    VizCollapseMonad NullCollapseViz gr s where+  consumeByInGraph _ _ _ = return ()+  splitGraphAt _ _ = return ()+  finalGraph _ = return ()++runNullCollapse :: NullCollapseViz a -> UniqDSM a+runNullCollapse = unNCV+++------------------ Utility functions on graphs -----------------------+++-- | Tell if a `Node` has a single predecessor.+singlePred :: Graph gr => gr a b -> Node -> Bool+singlePred gr n+    | ([_], _, _, _) <- context gr n = True+    | otherwise = False++-- | Use this function to extract information about a `Node` that you+-- know is in a `Graph`.  It's like `match` from `Graph`, but it must+-- succeed.+forceMatch :: (Graph gr)+           => Node -> gr s b -> (Context s b, gr s b)+forceMatch node g = case match node g of (Just c, g') -> (c, g')+                                         _ -> panicDump node g+ where panicDump :: Graph gr => Node -> gr s b -> any+       panicDump k _g =+         panic $ "GHC.Data.Graph.Collapse failed to match node " ++ show k++-- | Rewrite the label of a given node.+updateNode :: DynGraph gr => (s -> s) -> Node -> gr s b -> gr s b+updateNode relabel node g = (preds, n, relabel this, succs) & g'+    where ((preds, n, this, succs), g') = forceMatch node g+++-- | Test if a graph has but a single node.+singletonGraph :: Graph gr => gr a b -> Bool+singletonGraph g = case labNodes g of [_] -> True+                                      _ -> False+++----------------  Supernodes ------------------------------------++-- | A "supernode" stands for a collection of one or more nodes (basic+-- blocks) that have been coalesced by the Hecht-Ullman algorithm.+-- A collection in a supernode constitutes a /reducible/ subgraph of a+-- control-flow graph.  (When an entire control-flow graph is collapsed+-- to a single supernode, the flow graph is reducible.)+--+-- The idea of node splitting is to collapse a control-flow graph down+-- to a single supernode, then materialize (``inflate'') the reducible+-- equivalent graph from that supernode.  The `Supernode` class+-- defines only the methods needed to collapse; rematerialization is+-- the responsibility of the client.+--+-- During the Hecht-Ullman algorithm, every supernode has a unique+-- entry point, which is given by `superLabel`.  But this invariant is+-- not guaranteed by the class methods and is not a law of the class.+-- The `mapLabels` function rewrites all labels that appear in a+-- supernode (both definitions and uses).  The `freshen` function+-- replaces every appearance of a /defined/ label with a fresh label.+-- (Appearances include both definitions and uses.)+--+-- Laws:+-- @+--    superLabel (n <> n') == superLabel n+--    blocks (n <> n') == blocks n `union` blocks n'+--    mapLabels f (n <> n') = mapLabels f n <> mapLabels f n'+--    mapLabels id == id+--    mapLabels (f . g) == mapLabels f . mapLabels g+-- @+--+-- (We expect `freshen` to distribute over `<>`, but because of+-- the fresh names involved, formulating a precise law is a bit+-- challenging.)++class (Semigroup node) => PureSupernode node where+  superLabel :: node -> Label+  mapLabels :: (Label -> Label) -> (node -> node)++class (MonadGetUnique m, PureSupernode node) => Supernode node m where+  freshen :: node -> m node++  -- ghost method+  -- blocks :: node -> Set Block++------------------ Functions specific to the algorithm -----------------------++-- | Merge two nodes, return new graph plus list of nodes that newly have a single+-- predecessor.  This function implements transformation $T_2$ from+-- the Hecht and Ullman paper (merge the node into its unique+-- predecessor).  It then also removes self-edges (transformation $T_1$ from+-- the Hecht and Ullman paper).  There is no need for a separate+-- implementation of $T_1$.+--+-- `consumeBy v u g` returns the graph that results when node v is+-- consumed by node u in graph g.  Both v and u are replaced with a new node u'+-- with these properties:+--+--    LABELS(u') = LABELS(u) `union` LABELS(v)+--    SUCC(u') = SUCC(u) `union` SUCC(v) - { u }+--    every node that previously points to u now points to u'+--+-- It also returns a list of nodes in the result graph that+-- are *newly* single-predecessor nodes.++consumeBy :: (DynGraph gr, PureSupernode s)+          => Node -> Node -> gr s () -> (gr s (), [Node])+consumeBy toNode fromNode g =+    assert (toPreds == [((), fromNode)]) $+    (newGraph, newCandidates)+  where ((toPreds,   _, to,   toSuccs),   g')  = forceMatch toNode   g+        ((fromPreds, _, from, fromSuccs), g'') = forceMatch fromNode g'+        context = ( fromPreds -- by construction, can't have `toNode`+                  , fromNode+                  , from <> to+                  , delete ((), fromNode) toSuccs `union` fromSuccs+                  )+        newGraph = context & g''+        newCandidates = filter (singlePred newGraph) changedNodes+        changedNodes = fromNode `insert` map snd (toSuccs `intersect` fromSuccs)++-- | Split a given node.  The node is replaced with a collection of replicas,+-- one for each predecessor.  After the split, every predecessor+-- points to a unique replica.+split :: forall gr s b m . (DynGraph gr, Supernode s m)+      => Node -> gr s b -> m (gr s b)+split node g = assert (isMultiple preds) $ foldM addReplica g' newNodes+  where ((preds, _, this, succs), g') = forceMatch node g+        newNodes :: [((b, Node), Node)]+        newNodes = zip preds [maxNode+1..]+        (_, maxNode) = nodeRange g+        thisLabel = superLabel this+        addReplica :: gr s b -> ((b, Node), Node) -> m (gr s b)+        addReplica g ((b, pred), newNode) = do+            newSuper <- freshen this+            return $ add newSuper+          where add newSuper =+                  updateNode (thisLabel `replacedWith` superLabel newSuper) pred $+                  ([(b, pred)], newNode, newSuper, succs) & g++replacedWith :: PureSupernode s => Label -> Label -> s -> s+replacedWith old new = mapLabels (\l -> if l == old then new else l)+++-- | Does a list have more than one element? (in constant time).+isMultiple :: [a] -> Bool+isMultiple [] = False+isMultiple [_] = False+isMultiple (_:_:_) = True++-- | Find a candidate for splitting by finding a node that has multiple predecessors.++anySplittable :: forall gr a b . Graph gr => gr a b -> LNode a+anySplittable g = case splittable of+                    n : _ -> n+                    [] -> panic "anySplittable found no splittable nodes"+  where splittable = filter (isMultiple . pre g . fst) $ labNodes g+        splittable :: [LNode a]+++------------------ The collapsing algorithm -----------------------++-- | Using the algorithm of Hecht and Ullman (1972), collapse a graph+-- into a single node, splitting nodes as needed.  Record+-- visualization events in monad `m`.+collapseInductiveGraph :: (DynGraph gr, Supernode s m, VizCollapseMonad m gr s)+                       => gr s () -> m (gr s ())+collapseInductiveGraph g = drain g worklist+  where worklist :: [[Node]] -- nodes with exactly one predecessor+        worklist = [filter (singlePred g) $ nodes g]++        drain g [] = if singletonGraph g then finalGraph g >> return g+                     else let (n, super) = anySplittable g+                          in  do splitGraphAt g (n, super)+                                 collapseInductiveGraph =<< split n g+        drain g ([]:nss) = drain g nss+        drain g ((n:ns):nss) = let (g', ns') = consumeBy n (theUniquePred n) g+                               in  do consumeByInGraph n (theUniquePred n) g+                                      drain g' (ns':ns:nss)+         where theUniquePred n+                 | ([(_, p)], _, _, _) <- context g n = p+                 | otherwise =+                     panic "node claimed to have a unique predecessor; it doesn't"
GHC/Data/Graph/Color.hs view
@@ -95,7 +95,7 @@          -- 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.+        --      there's a change we can color them here anyway.         (graph_prob, ksNoColor)                 = assignColors colors graph_triv ksProblems @@ -328,8 +328,7 @@                         -- See Note [Unique Determinism and code generation]          colors_conflict = mkUniqSet-                        $ catMaybes-                        $ map nodeColor nsConflicts+                        $ mapMaybe nodeColor nsConflicts          -- the prefs of our neighbors         colors_neighbor_prefs@@ -380,6 +379,4 @@                 = Nothing     in   chooseColor--
GHC/Data/Graph/Directed.hs view
@@ -4,15 +4,18 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE DeriveFunctor #-}  module GHC.Data.Graph.Directed (         Graph, graphFromEdgedVerticesOrd, graphFromEdgedVerticesUniq,+        graphFromVerticesAndAdjacency, emptyGraph, -        SCC(..), Node(..), flattenSCC, flattenSCCs,+        SCC(..), Node(..), G.flattenSCC, G.flattenSCCs,         stronglyConnCompG,         topologicalSortG,         verticesG, edgesG, hasVertexG,-        reachableG, reachablesG, transposeG, allReachable, outgoingG,+        reachablesG,+        transposeG, outgoingG,         emptyG,          findCycle,@@ -41,10 +44,9 @@ -- removed them since they were not used anywhere in GHC. ------------------------------------------------------------------------------ - import GHC.Prelude -import GHC.Utils.Misc ( minWith, count )+import GHC.Utils.Misc ( sortWith, count ) import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Data.Maybe ( expectJust )@@ -57,15 +59,15 @@ import qualified Data.Set as Set  import qualified Data.Graph as G-import Data.Graph hiding (Graph, Edge, transposeG, reachable)-import Data.Tree+import Data.Graph ( Vertex, Bounds, SCC(..) ) -- Used in the underlying representation import GHC.Types.Unique import GHC.Types.Unique.FM-import qualified Data.IntMap as IM-import qualified Data.IntSet as IS-import qualified Data.Map as M-import qualified Data.Set as S +-- 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+ {- ************************************************************************ *                                                                      *@@ -84,14 +86,6 @@         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- {-| Representation for nodes of the Graph.   * The @payload@ is user data, just carried around in this module@@ -107,7 +101,7 @@       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@@ -217,48 +211,53 @@      [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.+-- | 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-  = go Set.empty (new_work root_deps []) []+  = goRoots plausible_roots   where     env :: Map.Map key (Node key payload)     env = Map.fromList [ (node_key node, node) | node <- 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)-                                           (node_dependencies node))-                            | node <- graph ])-    DigraphNode root_payload root_key root_deps = root+    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) -    -- '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 ] @@ -290,19 +289,11 @@ -}  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)+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]@@ -333,7 +324,7 @@         => [Node key payload]         -> [SCC (Node key payload)] stronglyConnCompFromEdgedVerticesOrdR =-  stronglyConnCompG . graphFromEdgedVertices reduceNodesIntoVerticesOrd+  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@@ -344,7 +335,7 @@         => [Node key payload]         -> [SCC (Node key payload)] stronglyConnCompFromEdgedVerticesUniqR =-  stronglyConnCompG . graphFromEdgedVertices reduceNodesIntoVerticesUniq+  stronglyConnCompG . graphFromEdgedVerticesUniq  {- ************************************************************************@@ -356,44 +347,24 @@  topologicalSortG :: Graph node -> [node] topologicalSortG graph = map (gr_vertex_to_node graph) result-  where result = {-# SCC "Digraph.topSort" #-} topSort (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]+  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 "reachableG" (gr_node_to_vertex graph from)+  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.+-- | 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 ] --- | Efficiently construct a map which maps each key to it's set of transitive--- dependencies.-allReachable :: Ord key => Graph node -> (node -> key) -> M.Map key (S.Set key)-allReachable (Graph g from _) conv =-  M.fromList [(conv (from v), IS.foldr (\k vs -> conv (from k) `S.insert` vs) S.empty vs)-             | (v, vs) <- IM.toList int_graph]-  where-    int_graph = reachableGraph g- hasVertexG :: Graph node -> node -> Bool hasVertexG graph node = isJust $ gr_node_to_vertex graph node -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)@@ -402,64 +373,12 @@ emptyG :: Graph node -> Bool emptyG g = graphEmpty (gr_int_graph g) -{--************************************************************************-*                                                                      *-*      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         = concatMap 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)--reachableGraph :: IntGraph -> IM.IntMap IS.IntSet-reachableGraph g = res-  where-    do_one v = IS.unions (IS.fromList (g ! v) : mapMaybe (flip IM.lookup res) (g ! v))-    res = IM.fromList [(v, do_one v) | v <- vertices g]--{- ************************************************************************ *                                                                      * *                         Classify Edge Types@@ -547,3 +466,22 @@           ends'' = addToUFM ends' n time''         in         (time'' + 1, starts'', ends'')++graphFromVerticesAndAdjacency+        :: Ord key+        => [Node key payload]+        -> [(key, key)]  -- First component is source vertex key,+                         -- second is target vertex key (thing depended on)+                         -- Unlike the other interface I insist they correspond to+                         -- actual vertices because the alternative hides bugs. I can't+                         -- do the same thing for the other one for backcompat reasons.+        -> Graph (Node key payload)+graphFromVerticesAndAdjacency []       _     = emptyGraph+graphFromVerticesAndAdjacency vertices edges = Graph graph vertex_node (key_vertex . key_extractor)+  where key_extractor = node_key+        (bounds, vertex_node, key_vertex, _) = reduceNodesIntoVerticesOrd vertices key_extractor+        key_vertex_pair (a, b) = (expectJust $ key_vertex a,+                                  expectJust $ key_vertex b)+        reduced_edges = map key_vertex_pair edges+        graph = G.buildG bounds reduced_edges+
+ GHC/Data/Graph/Directed/Internal.hs view
@@ -0,0 +1,79 @@+module GHC.Data.Graph.Directed.Internal where++import GHC.Prelude+import GHC.Utils.Outputable++import Data.Array+import qualified Data.Graph as G+import Data.Graph ( Vertex, SCC(..) ) -- Used in the underlying representation+import Data.Tree++data Graph node = Graph {+    gr_int_graph      :: IntGraph,+    gr_vertex_to_node :: Vertex -> node,+    gr_node_to_vertex :: node -> Maybe Vertex+}++data Edge node = Edge node node++------------------------------------------------------------+-- Nodes and Edges+------------------------------------------------------------++verticesG :: Graph node -> [node]+verticesG graph = map (gr_vertex_to_node graph) $ G.vertices (gr_int_graph graph)++edgesG :: Graph node -> [Edge node]+edgesG graph = map (\(v1, v2) -> Edge (v2n v1) (v2n v2)) $ G.edges (gr_int_graph graph)+  where v2n = gr_vertex_to_node graph++------------------------------------------------------------+-- Showing Graphs+------------------------------------------------------------++instance Outputable node => Outputable (Graph node) where+    ppr graph = vcat [+                  hang (text "Vertices:") 2 (vcat (map ppr $ verticesG graph)),+                  hang (text "Edges:") 2 (vcat (map ppr $ edgesG graph))+                ]++instance Outputable node => Outputable (Edge node) where+    ppr (Edge from to) = ppr from <+> text "->" <+> ppr to++{-+************************************************************************+*                                                                      *+*      IntGraphs+*                                                                      *+************************************************************************+-}++type IntGraph = G.Graph++------------------------------------------------------------+-- Depth first search numbering+------------------------------------------------------------++-- Data.Tree has flatten for Tree, but nothing for Forest+preorderF           :: Forest a -> [a]+preorderF ts         = concatMap flatten ts++------------------------------------------------------------+-- Finding reachable vertices+------------------------------------------------------------++-- This generalizes reachable which was found in Data.Graph+reachable    :: IntGraph -> [Vertex] -> [Vertex]+reachable g vs = preorderF (G.dfs g vs)++scc :: IntGraph -> [SCC Vertex]+scc graph = map decode forest+  where+    forest = {-# SCC "Digraph.scc" #-} G.scc graph++    decode (Node v []) | mentions_itself v = CyclicSCC [v]+                       | otherwise         = AcyclicSCC v+    decode other = CyclicSCC (dec other [])+      where dec (Node v ts) vs = v : foldr dec vs ts+    mentions_itself v = v `elem` (graph ! v)+
+ GHC/Data/Graph/Directed/Reachability.hs view
@@ -0,0 +1,178 @@+-- | An abstract interface for a fast reachability data structure constructed+-- from a 'GHC.Data.Graph.Directed' graph.+module GHC.Data.Graph.Directed.Reachability+  ( ReachabilityIndex++  -- * Constructing a reachability index+  , graphReachability, cyclicGraphReachability++  -- * Reachability queries+  , allReachable, allReachableMany+  , isReachable, isReachableMany++  -- * Debugging+  , reachabilityIndexMembers++  )+  where++import GHC.Prelude+import GHC.Data.Maybe++import qualified Data.Graph as G+import Data.Graph ( Vertex, SCC(..) )++import Data.Array ((!))+import qualified Data.IntMap as IM+import qualified Data.IntSet as IS++import GHC.Data.Graph.Directed.Internal++--------------------------------------------------------------------------------+-- * Reachability index+--------------------------------------------------------------------------------++-- | The abstract data structure for fast reachability queries+data ReachabilityIndex node = ReachabilityIndex {+    index :: IM.IntMap IS.IntSet,+    from_vertex :: Vertex -> node,+    to_vertex :: node -> Maybe Vertex+}++--+reachabilityIndexMembers :: ReachabilityIndex node -> [node]+reachabilityIndexMembers (ReachabilityIndex index from_vert _) = map from_vert (IM.keys index)++--------------------------------------------------------------------------------+-- * Construction+--------------------------------------------------------------------------------++-- | Construct a 'ReachabilityIndex' from an acyclic 'Graph'.+-- If the graph can have cycles, use 'cyclicGraphReachability'+graphReachability :: Graph node -> ReachabilityIndex node+graphReachability (Graph g from to) =+  ReachabilityIndex{index = reachableGraph, from_vertex = from, to_vertex = to}+    where+      reachableGraph :: IM.IntMap IS.IntSet+      reachableGraph = IM.fromList [(v, do_one v) | v <- G.vertices g]++      do_one v = IS.unions (IS.fromList (g ! v) : mapMaybe (flip IM.lookup reachableGraph) (g ! v))++-- | Construct a 'ReachabilityIndex' from a 'Graph' which may have cycles.+-- If this reachability index is just going to be used once, it may make sense+-- to use 'reachablesG' instead, which will traverse the reachable nodes without+-- constructing the index -- which may be faster.+cyclicGraphReachability :: Graph node -> ReachabilityIndex node+cyclicGraphReachability (Graph g from to) =+  ReachabilityIndex{index = reachableGraphCyclic, from_vertex = from, to_vertex = to}+    where+      reachableGraphCyclic :: IM.IntMap IS.IntSet+      reachableGraphCyclic = foldl' add_one_comp mempty comps++      neighboursOf v = g!v++      comps = scc g++      -- To avoid divergence on cyclic input, we build the result+      -- strongly connected component by component, in topological+      -- order. For each SCC, we know that:+      --+      --   * All vertices in the component can reach all other vertices+      --     in the component ("local" reachables)+      --+      --   * Other reachable vertices ("remote" reachables) must come+      --     from earlier components, either via direct neighbourhood, or+      --     transitively from earlier reachability map+      --+      -- This allows us to build the extension of the reachability map+      -- directly, without any self-reference, thereby avoiding a loop.+      add_one_comp :: IM.IntMap IS.IntSet -> SCC Vertex -> IM.IntMap IS.IntSet+      add_one_comp earlier (AcyclicSCC v) = IM.insert v all_remotes earlier+        where+          earlier_neighbours = neighboursOf v+          earlier_further = mapMaybe (flip IM.lookup earlier) earlier_neighbours+          all_remotes = IS.unions (IS.fromList earlier_neighbours : earlier_further)+      add_one_comp earlier (CyclicSCC vs) = IM.union (IM.fromList [(v, local v `IS.union` all_remotes) | v <- vs]) earlier+        where+          all_locals = IS.fromList vs+          local v = IS.delete v all_locals+              -- Arguably, for a cyclic SCC we should include each+              -- vertex in its own reachable set. However, this could+              -- lead to a lot of extra pain in client code to avoid+              -- looping when traversing the reachability map.+          all_neighbours = IS.fromList (concatMap neighboursOf vs)+          earlier_neighbours = all_neighbours IS.\\ all_locals+          earlier_further = mapMaybe (flip IM.lookup earlier) (IS.toList earlier_neighbours)+          all_remotes = IS.unions (earlier_neighbours : earlier_further)++--------------------------------------------------------------------------------+-- * Reachability queries+--------------------------------------------------------------------------------++-- | 'allReachable' returns the nodes reachable from the given @root@ node.+--+-- Properties:+--  * The list of nodes /does not/ include the @root@ node!+--  * The list of nodes is deterministically ordered, but according to an+--     internal order determined by the indices attributed to graph nodes.+--+-- If you need a topologically sorted list, consider using the functions exposed from 'GHC.Data.Graph.Directed' on 'Graph' instead.+allReachable :: ReachabilityIndex node -> node {-^ The @root@ node -} -> [node] {-^ All nodes reachable from @root@ -}+allReachable (ReachabilityIndex index from to) root = map from result+  where root_i = expectJust (to root)+        hits = {-# SCC "allReachable" #-} IM.lookup root_i index+        result = IS.toList $! expectJust hits++-- | 'allReachableMany' returns all nodes reachable from the many given @roots@.+--+-- Properties:+--  * The list of nodes /does not/ include the @roots@ node!+--  * The list of nodes is deterministically ordered, but according to an+--     internal order determined by the indices attributed to graph nodes.+--  * This function has $O(n)$ complexity where $n$ is the number of @roots@.+--+-- If you need a topologically sorted list, consider using the functions+-- exposed from 'GHC.Data.Graph.Directed' on 'Graph' instead ('reachableG').+allReachableMany :: ReachabilityIndex node -> [node] {-^ The @roots@ -} -> [node] {-^ All nodes reachable from all @roots@ -}+allReachableMany (ReachabilityIndex index from to) roots = map from (IS.toList hits)+  where roots_i = [ v | Just v <- map to roots ]+        hits = {-# SCC "allReachableMany" #-}+               IS.unions $ map (expectJust . flip IM.lookup index) roots_i++-- | Fast reachability query.+--+-- On graph @g@ with nodes @a@ and @b@, @isReachable g a b@+-- asks whether @b@ can be reached through @g@ starting from @a@.+--+-- Properties:+--  * No self loops, i.e. @isReachable _ a a == False@+isReachable :: ReachabilityIndex node {-^ @g@ -}+            -> node -- ^ @a@+            -> node -- ^ @b@+            -> Bool -- ^ @b@ is reachable from @a@+isReachable (ReachabilityIndex index _ to) a b =+    IS.member b_i $+    expectJust $ IM.lookup a_i index+  where a_i = expectJust $ to a+        b_i = expectJust $ to b++-- | Fast reachability query with many roots.+--+-- On graph @g@ with many nodes @roots@ and node @b@, @isReachableMany g as b@+-- asks whether @b@ can be reached through @g@ from any of the @roots@.+--+-- By partially applying this function to a set of roots, the resulting function can+-- be applied many times and share the initial work.+--+-- Properties:+--  * No self loops, i.e. @isReachableMany _ [a] a == False@+isReachableMany :: ReachabilityIndex node -- ^ @g@+                -> [node] -- ^ @roots@+                -> (node -> Bool) -- ^ @b@ is reachable from any of the @roots@+isReachableMany (ReachabilityIndex index _ to) roots =+  let roots_i = [ v | Just v <- map to roots ]+      unions =+          IS.unions $+            map (expectJust . flip IM.lookup index) roots_i+  in \b -> let b_i = expectJust $ to b+           in IS.member b_i unions
+ GHC/Data/Graph/Inductive/Graph.hs view
@@ -0,0 +1,642 @@+-- (c) 1999-2005 by Martin Erwig (see copyright at bottom)+-- | Static and Dynamic Inductive Graphs+--+-- Code is from Hackage `fgl` package version 5.7.0.3+--+module GHC.Data.Graph.Inductive.Graph (+    -- * General Type Defintions+    -- ** Node and Edge Types+    Node,LNode,UNode,+    Edge,LEdge,UEdge,+    -- ** Types Supporting Inductive Graph View+    Adj,Context,MContext,Decomp,GDecomp,UContext,UDecomp,+    Path,LPath(..),UPath,+    -- * Graph Type Classes+    -- | We define two graph classes:+    --+    --   Graph: static, decomposable graphs.+    --    Static means that a graph itself cannot be changed+    --+    --   DynGraph: dynamic, extensible graphs.+    --             Dynamic graphs inherit all operations from static graphs+    --             but also offer operations to extend and change graphs.+    --+    -- Each class contains in addition to its essential operations those+    -- derived operations that might be overwritten by a more efficient+    -- implementation in an instance definition.+    --+    -- Note that labNodes is essentially needed because the default definition+    -- for matchAny is based on it: we need some node from the graph to define+    -- matchAny in terms of match. Alternatively, we could have made matchAny+    -- essential and have labNodes defined in terms of ufold and matchAny.+    -- However, in general, labNodes seems to be (at least) as easy to define+    -- as matchAny. We have chosen labNodes instead of the function nodes since+    -- nodes can be easily derived from labNodes, but not vice versa.+    Graph(..),+    DynGraph(..),+    -- * Operations+    order,+    size,+    -- ** Graph Folds and Maps+    ufold,gmap,nmap,emap,nemap,+    -- ** Graph Projection+    nodes,edges,toEdge,edgeLabel,toLEdge,newNodes,gelem,+    -- ** Graph Construction and Destruction+    insNode,insEdge,delNode,delEdge,delLEdge,delAllLEdge,+    insNodes,insEdges,delNodes,delEdges,+    buildGr,mkUGraph,+    -- ** Subgraphs+    gfiltermap,nfilter,labnfilter,labfilter,subgraph,+    -- ** Graph Inspection+    context,lab,neighbors,lneighbors,+    suc,pre,lsuc,lpre,+    out,inn,outdeg,indeg,deg,+    hasEdge,hasNeighbor,hasLEdge,hasNeighborAdj,+    equal,+    -- ** Context Inspection+    node',lab',labNode',neighbors',lneighbors',+    suc',pre',lpre',lsuc',+    out',inn',outdeg',indeg',deg',+    -- * Pretty-printing+    prettify,+    prettyPrint,+    -- * Ordering of Graphs+    OrdGr(..)+) where++import GHC.Prelude++import           Control.Arrow (first)+import           Data.Function (on)+import qualified Data.IntSet   as IntSet+import           Data.List     (delete, groupBy, sort, sortBy, (\\))+import           Data.List.NonEmpty (nonEmpty)+import           Data.Maybe    (fromMaybe, isJust)++import GHC.Utils.Panic++-- | Unlabeled node+type  Node   = Int+-- | Labeled node+type LNode a = (Node,a)+-- | Quasi-unlabeled node+type UNode   = LNode ()++-- | Unlabeled edge+type  Edge   = (Node,Node)+-- | Labeled edge+type LEdge b = (Node,Node,b)+-- | Quasi-unlabeled edge+type UEdge   = LEdge ()++-- | Unlabeled path+type Path    = [Node]+-- | Labeled path+newtype LPath a = LP { unLPath :: [LNode a] }++instance (Show a) => Show (LPath a) where+  show (LP xs) = show xs++instance (Eq a) => Eq (LPath a) where+  (LP [])        == (LP [])        = True+  (LP ((_,x):_)) == (LP ((_,y):_)) = x==y+  (LP _)         == (LP _)         = False++instance (Ord a) => Ord (LPath a) where+  compare (LP [])        (LP [])        = EQ+  compare (LP ((_,x):_)) (LP ((_,y):_)) = compare x y+  compare _ _ = panic "LPath: cannot compare two empty paths"++-- | Quasi-unlabeled path+type UPath   = [UNode]++-- | Labeled links to or from a 'Node'.+type Adj b        = [(b,Node)]+-- | Links to the 'Node', the 'Node' itself, a label, links from the 'Node'.+--+--   In other words, this captures all information regarding the+--   specified 'Node' within a graph.+type Context a b  = (Adj b,Node,a,Adj b) -- Context a b "=" Context' a b "+" Node+type MContext a b = Maybe (Context a b)+-- | 'Graph' decomposition - the context removed from a 'Graph', and the rest+-- of the 'Graph'.+type Decomp g a b = (MContext a b,g a b)+-- | The same as 'Decomp', only more sure of itself.+type GDecomp g a b  = (Context a b,g a b)++-- | Unlabeled context.+type UContext     = ([Node],Node,[Node])+-- | Unlabeled decomposition.+type UDecomp g    = (Maybe UContext,g)++-- | Minimum implementation: 'empty', 'isEmpty', 'match', 'mkGraph', 'labNodes'+class Graph gr where+  {-# MINIMAL empty, isEmpty, match, mkGraph, labNodes #-}++  -- | An empty 'Graph'.+  empty     :: gr a b++  -- | True if the given 'Graph' is empty.+  isEmpty   :: gr a b -> Bool++  -- | Decompose a 'Graph' into the 'MContext' found for the given node and the+  -- remaining 'Graph'.+  match     :: Node -> gr a b -> Decomp gr a b++  -- | Create a 'Graph' from the list of 'LNode's and 'LEdge's.+  --+  --   For graphs that are also instances of 'DynGraph', @mkGraph ns+  --   es@ should be equivalent to @('insEdges' es . 'insNodes' ns)+  --   'empty'@.+  mkGraph   :: [LNode a] -> [LEdge b] -> gr a b++  -- | A list of all 'LNode's in the 'Graph'.+  labNodes  :: gr a b -> [LNode a]++  -- | Decompose a graph into the 'Context' for an arbitrarily-chosen 'Node'+  -- and the remaining 'Graph'.+  matchAny  :: gr a b -> GDecomp gr a b+  matchAny g = case labNodes g of+                 []      -> panic "Match Exception, Empty Graph"+                 (v,_):_ | (Just c,g') <- match v g -> (c,g')+                 _       -> panic "This can't happen: failed to match node in graph"+++  -- | The number of 'Node's in a 'Graph'.+  noNodes   :: gr a b -> Int+  noNodes = length . labNodes++  -- | The minimum and maximum 'Node' in a 'Graph'.+  nodeRange :: gr a b -> (Node,Node)+  nodeRange g = case nonEmpty (nodes g) of+      Nothing -> panic "nodeRange of empty graph"+      Just vs -> (minimum vs, maximum vs)++  -- | A list of all 'LEdge's in the 'Graph'.+  labEdges  :: gr a b -> [LEdge b]+  labEdges = ufold (\(_,v,_,s)->(map (\(l,w)->(v,w,l)) s ++)) []++class (Graph gr) => DynGraph gr where+  -- | Merge the 'Context' into the 'DynGraph'.+  --+  --   Context adjacencies should only refer to either a Node already+  --   in a graph or the node in the Context itself (for loops).+  --+  --   Behaviour is undefined if the specified 'Node' already exists+  --   in the graph.+  (&) :: Context a b -> gr a b -> gr a b+++-- | The number of nodes in the graph.  An alias for 'noNodes'.+order :: (Graph gr) => gr a b -> Int+order = noNodes++-- | The number of edges in the graph.+--+--   Note that this counts every edge found, so if you are+--   representing an unordered graph by having each edge mirrored this+--   will be incorrect.+--+--   If you created an unordered graph by either mirroring every edge+--   (including loops!) or using the @undir@ function in+--   "Data.Graph.Inductive.Basic" then you can safely halve the value+--   returned by this.+size :: (Graph gr) => gr a b -> Int+size = length . labEdges++-- | Fold a function over the graph by recursively calling 'match'.+ufold :: (Graph gr) => (Context a b -> c -> c) -> c -> gr a b -> c+ufold f u g+  | isEmpty g = u+  | otherwise = f c (ufold f u g')+  where+    (c,g') = matchAny g++-- | Map a function over the graph by recursively calling 'match'.+gmap :: (DynGraph gr) => (Context a b -> Context c d) -> gr a b -> gr c d+gmap f = ufold (\c->(f c&)) empty+{-# NOINLINE [0] gmap #-}++-- | Map a function over the 'Node' labels in a graph.+nmap :: (DynGraph gr) => (a -> c) -> gr a b -> gr c b+nmap f = gmap (\(p,v,l,s)->(p,v,f l,s))+{-# NOINLINE [0] nmap #-}++-- | Map a function over the 'Edge' labels in a graph.+emap :: (DynGraph gr) => (b -> c) -> gr a b -> gr a c+emap f = gmap (\(p,v,l,s)->(map1 f p,v,l,map1 f s))+  where+    map1 g = map (first g)+{-# NOINLINE [0] emap #-}++-- | Map functions over both the 'Node' and 'Edge' labels in a graph.+nemap :: (DynGraph gr) => (a -> c) -> (b -> d) -> gr a b -> gr c d+nemap fn fe = gmap (\(p,v,l,s) -> (fe' p,v,fn l,fe' s))+  where+    fe' = map (first fe)+{-# NOINLINE [0] nemap #-}++-- | List all 'Node's in the 'Graph'.+nodes :: (Graph gr) => gr a b -> [Node]+nodes = map fst . labNodes++-- | List all 'Edge's in the 'Graph'.+edges :: (Graph gr) => gr a b -> [Edge]+edges = map toEdge . labEdges++-- | Drop the label component of an edge.+toEdge :: LEdge b -> Edge+toEdge (v,w,_) = (v,w)++-- | Add a label to an edge.+toLEdge :: Edge -> b -> LEdge b+toLEdge (v,w) l = (v,w,l)++-- | The label in an edge.+edgeLabel :: LEdge b -> b+edgeLabel (_,_,l) = l++-- | List N available 'Node's, i.e. 'Node's that are not used in the 'Graph'.+newNodes :: (Graph gr) => Int -> gr a b -> [Node]+newNodes i g+  | isEmpty g = [0..i-1]+  | otherwise = [n+1..n+i]+  where+    (_,n) = nodeRange g++-- | 'True' if the 'Node' is present in the 'Graph'.+gelem :: (Graph gr) => Node -> gr a b -> Bool+gelem v = isJust . fst . match v++-- | Insert a 'LNode' into the 'Graph'.+insNode :: (DynGraph gr) => LNode a -> gr a b -> gr a b+insNode (v,l) = (([],v,l,[])&)+{-# NOINLINE [0] insNode #-}++-- | Insert a 'LEdge' into the 'Graph'.+insEdge :: (DynGraph gr) => LEdge b -> gr a b -> gr a b+insEdge (v,w,l) g = (pr,v,la,(l,w):su) & g'+  where+    (mcxt,g') = match v g+    (pr,_,la,su) = fromMaybe+                     (panic ("insEdge: cannot add edge from non-existent vertex " ++ show v))+                     mcxt+{-# NOINLINE [0] insEdge #-}++-- | Remove a 'Node' from the 'Graph'.+delNode :: (Graph gr) => Node -> gr a b -> gr a b+delNode v = delNodes [v]++-- | Remove an 'Edge' from the 'Graph'.+--+--   NOTE: in the case of multiple edges, this will delete /all/ such+--   edges from the graph as there is no way to distinguish between+--   them.  If you need to delete only a single such edge, please use+--   'delLEdge'.+delEdge :: (DynGraph gr) => Edge -> gr a b -> gr a b+delEdge (v,w) g = case match v g of+                    (Nothing,_)          -> g+                    (Just (p,v',l,s),g') -> (p,v',l,filter ((/=w).snd) s) & g'++-- | Remove an 'LEdge' from the 'Graph'.+--+--   NOTE: in the case of multiple edges with the same label, this+--   will only delete the /first/ such edge.  To delete all such+--   edges, please use 'delAllLedge'.+delLEdge :: (DynGraph gr, Eq b) => LEdge b -> gr a b -> gr a b+delLEdge = delLEdgeBy delete++-- | Remove all edges equal to the one specified.+delAllLEdge :: (DynGraph gr, Eq b) => LEdge b -> gr a b -> gr a b+delAllLEdge = delLEdgeBy (filter . (/=))++delLEdgeBy :: (DynGraph gr) => ((b,Node) -> Adj b -> Adj b)+              -> LEdge b -> gr a b -> gr a b+delLEdgeBy f (v,w,b) g = case match v g of+                           (Nothing,_)          -> g+                           (Just (p,v',l,s),g') -> (p,v',l,f (b,w) s) & g'++-- | Insert multiple 'LNode's into the 'Graph'.+insNodes   :: (DynGraph gr) => [LNode a] -> gr a b -> gr a b+insNodes vs g = foldl' (flip insNode) g vs+{-# INLINABLE insNodes #-}++-- | Insert multiple 'LEdge's into the 'Graph'.+insEdges :: (DynGraph gr) => [LEdge b] -> gr a b -> gr a b+insEdges es g = foldl' (flip insEdge) g es+{-# INLINABLE insEdges #-}++-- | Remove multiple 'Node's from the 'Graph'.+delNodes :: (Graph gr) => [Node] -> gr a b -> gr a b+delNodes vs g = foldl' (snd .: flip match) g vs++-- | Remove multiple 'Edge's from the 'Graph'.+delEdges :: (DynGraph gr) => [Edge] -> gr a b -> gr a b+delEdges es g = foldl' (flip delEdge) g es++-- | Build a 'Graph' from a list of 'Context's.+--+--   The list should be in the order such that earlier 'Context's+--   depend upon later ones (i.e. as produced by @'ufold' (:) []@).+buildGr :: (DynGraph gr) => [Context a b] -> gr a b+buildGr = foldr (&) empty++-- | Build a quasi-unlabeled 'Graph'.+mkUGraph :: (Graph gr) => [Node] -> [Edge] -> gr () ()+mkUGraph vs es = mkGraph (labUNodes vs) (labUEdges es)+   where+     labUEdges = map (`toLEdge` ())+     labUNodes = map (flip (,) ())++-- | Build a graph out of the contexts for which the predicate is+-- satisfied by recursively calling 'match'.+gfiltermap :: DynGraph gr => (Context a b -> MContext c d) -> gr a b -> gr c d+gfiltermap f = ufold (maybe id (&) . f) empty++-- | Returns the subgraph only containing the labelled nodes which+-- satisfy the given predicate.+labnfilter :: Graph gr => (LNode a -> Bool) -> gr a b -> gr a b+labnfilter p gr = delNodes (map fst . filter (not . p) $ labNodes gr) gr++-- | Returns the subgraph only containing the nodes which satisfy the+-- given predicate.+nfilter :: DynGraph gr => (Node -> Bool) -> gr a b -> gr a b+nfilter f = labnfilter (f . fst)++-- | Returns the subgraph only containing the nodes whose labels+-- satisfy the given predicate.+labfilter :: DynGraph gr => (a -> Bool) -> gr a b -> gr a b+labfilter f = labnfilter (f . snd)++-- | Returns the subgraph induced by the supplied nodes.+subgraph :: DynGraph gr => [Node] -> gr a b -> gr a b+subgraph vs = let vs' = IntSet.fromList vs+              in nfilter (`IntSet.member` vs')++-- | Find the context for the given 'Node'.  Causes an error if the 'Node' is+-- not present in the 'Graph'.+context :: (Graph gr) => gr a b -> Node -> Context a b+context g v = fromMaybe (panic ("Match Exception, Node: "++show v))+                        (fst (match v g))++-- | Find the label for a 'Node'.+lab :: (Graph gr) => gr a b -> Node -> Maybe a+lab g v = fmap lab' . fst $ match v g++-- | Find the neighbors for a 'Node'.+neighbors :: (Graph gr) => gr a b -> Node -> [Node]+neighbors = map snd .: lneighbors++-- | Find the labelled links coming into or going from a 'Context'.+lneighbors :: (Graph gr) => gr a b -> Node -> Adj b+lneighbors = maybe [] lneighbors' .: mcontext++-- | Find all 'Node's that have a link from the given 'Node'.+suc :: (Graph gr) => gr a b -> Node -> [Node]+suc = map snd .: context4l++-- | Find all 'Node's that link to to the given 'Node'.+pre :: (Graph gr) => gr a b -> Node -> [Node]+pre = map snd .: context1l++-- | Find all 'Node's that are linked from the given 'Node' and the label of+-- each link.+lsuc :: (Graph gr) => gr a b -> Node -> [(Node,b)]+lsuc = map flip2 .: context4l++-- | Find all 'Node's that link to the given 'Node' and the label of each link.+lpre :: (Graph gr) => gr a b -> Node -> [(Node,b)]+lpre = map flip2 .: context1l++-- | Find all outward-bound 'LEdge's for the given 'Node'.+out :: (Graph gr) => gr a b -> Node -> [LEdge b]+out g v = map (\(l,w)->(v,w,l)) (context4l g v)++-- | Find all inward-bound 'LEdge's for the given 'Node'.+inn :: (Graph gr) => gr a b -> Node -> [LEdge b]+inn g v = map (\(l,w)->(w,v,l)) (context1l g v)++-- | The outward-bound degree of the 'Node'.+outdeg :: (Graph gr) => gr a b -> Node -> Int+outdeg = length .: context4l++-- | The inward-bound degree of the 'Node'.+indeg :: (Graph gr) => gr a b -> Node -> Int+indeg  = length .: context1l++-- | The degree of the 'Node'.+deg :: (Graph gr) => gr a b -> Node -> Int+deg = deg' .: context++-- | The 'Node' in a 'Context'.+node' :: Context a b -> Node+node' (_,v,_,_) = v++-- | The label in a 'Context'.+lab' :: Context a b -> a+lab' (_,_,l,_) = l++-- | The 'LNode' from a 'Context'.+labNode' :: Context a b -> LNode a+labNode' (_,v,l,_) = (v,l)++-- | All 'Node's linked to or from in a 'Context'.+neighbors' :: Context a b -> [Node]+neighbors' (p,_,_,s) = map snd p++map snd s++-- | All labelled links coming into or going from a 'Context'.+lneighbors' :: Context a b -> Adj b+lneighbors' (p,_,_,s) = p ++ s++-- | All 'Node's linked to in a 'Context'.+suc' :: Context a b -> [Node]+suc' = map snd . context4l'++-- | All 'Node's linked from in a 'Context'.+pre' :: Context a b -> [Node]+pre' = map snd . context1l'++-- | All 'Node's linked from in a 'Context', and the label of the links.+lsuc' :: Context a b -> [(Node,b)]+lsuc' = map flip2 . context4l'++-- | All 'Node's linked from in a 'Context', and the label of the links.+lpre' :: Context a b -> [(Node,b)]+lpre' = map flip2 . context1l'++-- | All outward-directed 'LEdge's in a 'Context'.+out' :: Context a b -> [LEdge b]+out' c@(_,v,_,_) = map (\(l,w)->(v,w,l)) (context4l' c)++-- | All inward-directed 'LEdge's in a 'Context'.+inn' :: Context a b -> [LEdge b]+inn' c@(_,v,_,_) = map (\(l,w)->(w,v,l)) (context1l' c)++-- | The outward degree of a 'Context'.+outdeg' :: Context a b -> Int+outdeg' = length . context4l'++-- | The inward degree of a 'Context'.+indeg' :: Context a b -> Int+indeg' = length . context1l'++-- | The degree of a 'Context'.+deg' :: Context a b -> Int+deg' (p,_,_,s) = length p+length s++-- | Checks if there is a directed edge between two nodes.+hasEdge :: Graph gr => gr a b -> Edge -> Bool+hasEdge gr (v,w) = w `elem` suc gr v++-- | Checks if there is an undirected edge between two nodes.+hasNeighbor :: Graph gr => gr a b -> Node -> Node -> Bool+hasNeighbor gr v w = w `elem` neighbors gr v++-- | Checks if there is a labelled edge between two nodes.+hasLEdge :: (Graph gr, Eq b) => gr a b -> LEdge b -> Bool+hasLEdge gr (v,w,l) = (w,l) `elem` lsuc gr v++-- | Checks if there is an undirected labelled edge between two nodes.+hasNeighborAdj :: (Graph gr, Eq b) => gr a b -> Node -> (b,Node) -> Bool+hasNeighborAdj gr v a = a `elem` lneighbors gr v++----------------------------------------------------------------------+-- GRAPH EQUALITY+----------------------------------------------------------------------++slabNodes :: (Graph gr) => gr a b -> [LNode a]+slabNodes = sortBy (compare `on` fst) . labNodes++glabEdges :: (Graph gr) => gr a b -> [GroupEdges b]+glabEdges = map (GEs . groupLabels)+            . groupBy ((==) `on` toEdge)+            . sortBy (compare `on` toEdge)+            . labEdges+  where+    groupLabels les = toLEdge (toEdge (head les)) (map edgeLabel les)++equal :: (Eq a,Eq b,Graph gr) => gr a b -> gr a b -> Bool+equal g g' = slabNodes g == slabNodes g' && glabEdges g == glabEdges g'+-- This assumes that nodes aren't repeated (which shouldn't happen for+-- sane graph instances).  If node IDs are repeated, then the usage of+-- slabNodes cannot guarantee stable ordering.++-- Newtype wrapper just to test for equality of multiple edges.  This+-- is needed because without an Ord constraint on `b' it is not+-- possible to guarantee a stable ordering on edge labels.+newtype GroupEdges b = GEs (LEdge [b])+  deriving (Show, Read)++instance (Eq b) => Eq (GroupEdges b) where+  (GEs (v1,w1,bs1)) == (GEs (v2,w2,bs2)) = v1 == v2+                                           && w1 == w2+                                           && eqLists bs1 bs2++eqLists :: (Eq a) => [a] -> [a] -> Bool+eqLists xs ys = null (xs \\ ys) && null (ys \\ xs)+-- OK to use \\ here as we want each value in xs to cancel a *single*+-- value in ys.++----------------------------------------------------------------------+-- UTILITIES+----------------------------------------------------------------------++-- auxiliary functions used in the implementation of the+-- derived class members+--+(.:) :: (c -> d) -> (a -> b -> c) -> a -> b -> d+-- f .: g = \x y->f (g x y)+-- f .: g = (f .) . g+-- (.:) f = ((f .) .)+-- (.:) = (.) (.) (.)+(.:) = (.) . (.)++flip2 :: (a,b) -> (b,a)+flip2 (x,y) = (y,x)++-- projecting on context elements+--+context1l :: (Graph gr) => gr a b -> Node -> Adj b+context1l = maybe [] context1l' .: mcontext++context4l :: (Graph gr) => gr a b -> Node -> Adj b+context4l = maybe [] context4l' .: mcontext++mcontext :: (Graph gr) => gr a b -> Node -> MContext a b+mcontext = fst .: flip match++context1l' :: Context a b -> Adj b+context1l' (p,v,_,s) = p++filter ((==v).snd) s++context4l' :: Context a b -> Adj b+context4l' (p,v,_,s) = s++filter ((==v).snd) p++----------------------------------------------------------------------+-- PRETTY PRINTING+----------------------------------------------------------------------++-- | Pretty-print the graph.  Note that this loses a lot of+--   information, such as edge inverses, etc.+prettify :: (DynGraph gr, Show a, Show b) => gr a b -> String+prettify g = foldr (showsContext . context g) id (nodes g) ""+  where+    showsContext (_,n,l,s) sg = shows n . (':':) . shows l+                                . showString "->" . shows s+                                . ('\n':) . sg++-- | Pretty-print the graph to stdout.+prettyPrint :: (DynGraph gr, Show a, Show b) => gr a b -> IO ()+prettyPrint = putStr . prettify++----------------------------------------------------------------------+-- Ordered Graph+----------------------------------------------------------------------++-- | OrdGr comes equipped with an Ord instance, so that graphs can be+--   used as e.g. Map keys.+newtype OrdGr gr a b = OrdGr { unOrdGr :: gr a b }+  deriving (Read,Show)++instance (Graph gr, Ord a, Ord b) => Eq (OrdGr gr a b) where+  g1 == g2 = compare g1 g2 == EQ++instance (Graph gr, Ord a, Ord b) => Ord (OrdGr gr a b) where+  compare (OrdGr g1) (OrdGr g2) =+    (compare `on` sort . labNodes) g1 g2+    `mappend` (compare `on` sort . labEdges) g1 g2+++{-----------------------------------------------------------------++Copyright (c) 1999-2008, Martin Erwig+              2010, Ivan Lazar Miljenovic+              2022, Norman Ramsey+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice,+   this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+   notice, this list of conditions and the following disclaimer in the+   documentation and/or other materials provided with the distribution.++3. Neither the name of the author nor the names of its contributors may be+   used to endorse or promote products derived from this software without+   specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE+LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR+CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF+SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS+INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN+CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)+ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.++----------------------------------------------------------------}
+ GHC/Data/Graph/Inductive/PatriciaTree.hs view
@@ -0,0 +1,344 @@++-- |An efficient implementation of 'Data.Graph.Inductive.Graph.Graph'+-- using big-endian patricia tree (i.e. "Data.IntMap").+--+-- This module provides the following specialised functions to gain+-- more performance, using GHC's RULES pragma:+--+-- * 'Data.Graph.Inductive.Graph.insNode'+--+-- * 'Data.Graph.Inductive.Graph.insEdge'+--+-- * 'Data.Graph.Inductive.Graph.gmap'+--+-- * 'Data.Graph.Inductive.Graph.nmap'+--+-- * 'Data.Graph.Inductive.Graph.emap'+--+-- Code is from Hackage `fgl` package version 5.7.0.3+++module GHC.Data.Graph.Inductive.PatriciaTree+    ( Gr+    , UGr+    )+    where++import GHC.Prelude++import GHC.Data.Graph.Inductive.Graph++import           Data.IntMap         (IntMap)+import qualified Data.IntMap         as IM+import           Data.List           (sort)+import           Data.Maybe          (fromMaybe)+import           Data.Tuple          (swap)++import qualified Data.IntMap.Strict as IMS++import GHC.Generics (Generic)++import Data.Bifunctor++----------------------------------------------------------------------+-- GRAPH REPRESENTATION+----------------------------------------------------------------------++newtype Gr a b = Gr (GraphRep a b)+  deriving (Generic)++type GraphRep a b = IntMap (Context' a b)+type Context' a b = (IntMap [b], a, IntMap [b])++type UGr = Gr () ()++----------------------------------------------------------------------+-- CLASS INSTANCES+----------------------------------------------------------------------++instance (Eq a, Ord b) => Eq (Gr a b) where+  (Gr g1) == (Gr g2) = fmap sortAdj g1 == fmap sortAdj g2+    where+      sortAdj (p,n,s) = (fmap sort p,n,fmap sort s)++instance (Show a, Show b) => Show (Gr a b) where+  showsPrec d g = showParen (d > 10) $+                    showString "mkGraph "+                    . shows (labNodes g)+                    . showString " "+                    . shows (labEdges g)++instance (Read a, Read b) => Read (Gr a b) where+  readsPrec p = readParen (p > 10) $ \ r -> do+    ("mkGraph", s) <- lex r+    (ns,t) <- reads s+    (es,u) <- reads t+    return (mkGraph ns es, u)++instance Graph Gr where+    empty           = Gr IM.empty++    isEmpty (Gr g)  = IM.null g++    match           = matchGr++    mkGraph vs es   = insEdges es+                      . Gr+                      . IM.fromList+                      . map (second (\l -> (IM.empty,l,IM.empty)))+                      $ vs++    labNodes (Gr g) = [ (node, label)+                            | (node, (_, label, _)) <- IM.toList g ]++    noNodes   (Gr g) = IM.size g++    nodeRange (Gr g) = fromMaybe (error "nodeRange of empty graph")+                       $ liftA2 (,) (ix (IM.minViewWithKey g))+                                    (ix (IM.maxViewWithKey g))+      where+        ix = fmap (fst . fst)++    labEdges (Gr g) = do (node, (_, _, s)) <- IM.toList g+                         (next, labels)    <- IM.toList s+                         label             <- labels+                         return (node, next, label)++instance DynGraph Gr where+    (p, v, l, s) & (Gr g)+        = let !g1 = IM.insert v (preds, l, succs) g+              !(np, preds) = fromAdjCounting p+              !(ns, succs) = fromAdjCounting s+              !g2 = addSucc g1 v np preds+              !g3 = addPred g2 v ns succs+          in Gr g3+++instance Functor (Gr a) where+  fmap = fastEMap++instance Bifunctor Gr where+  bimap = fastNEMap++  first = fastNMap++  second = fastEMap+++matchGr :: Node -> Gr a b -> Decomp Gr a b+matchGr node (Gr g)+    = case IM.lookup node g of+        Nothing+            -> (Nothing, Gr g)++        Just (p, label, s)+            -> let !g1 = IM.delete node g+                   !p' = IM.delete node p+                   !s' = IM.delete node s+                   !g2 = clearPred g1 node s'+                   !g3 = clearSucc g2 node p'+               in (Just (toAdj p', node, label, toAdj s), Gr g3)++----------------------------------------------------------------------+-- OVERRIDING FUNCTIONS+----------------------------------------------------------------------++{-++{- RULES+      "insNode/Data.Graph.Inductive.PatriciaTree"  insNode = fastInsNode+  -}+fastInsNode :: LNode a -> Gr a b -> Gr a b+fastInsNode (v, l) (Gr g) = g' `seq` Gr g'+  where+    g' = IM.insert v (IM.empty, l, IM.empty) g++-}+{-# RULES+      "insEdge/GHC.Data.Graph.Inductive.PatriciaTree"  insEdge = fastInsEdge+  #-}+fastInsEdge :: LEdge b -> Gr a b -> Gr a b+fastInsEdge (v, w, l) (Gr g) = g2 `seq` Gr g2+  where+    g1 = IM.adjust addS' v g+    g2 = IM.adjust addP' w g1++    addS' (ps, l', ss) = (ps, l', IM.insertWith addLists w [l] ss)+    addP' (ps, l', ss) = (IM.insertWith addLists v [l] ps, l', ss)++{-++{- RULES+      "gmap/Data.Graph.Inductive.PatriciaTree"  gmap = fastGMap+  -}+fastGMap :: forall a b c d. (Context a b -> Context c d) -> Gr a b -> Gr c d+fastGMap f (Gr g) = Gr (IM.mapWithKey f' g)+  where+    f' :: Node -> Context' a b -> Context' c d+    f' = ((fromContext . f) .) . toContext++{- RULES+      "nmap/Data.Graph.Inductive.PatriciaTree"  nmap = fastNMap+  -}+-}+fastNMap :: forall a b c. (a -> c) -> Gr a b -> Gr c b+fastNMap f (Gr g) = Gr (IM.map f' g)+  where+    f' :: Context' a b -> Context' c b+    f' (ps, a, ss) = (ps, f a, ss)+{-++{- RULES+      "emap/GHC.Data.Graph.Inductive.PatriciaTree"  emap = fastEMap+   -}+-}+fastEMap :: forall a b c. (b -> c) -> Gr a b -> Gr a c+fastEMap f (Gr g) = Gr (IM.map f' g)+  where+    f' :: Context' a b -> Context' a c+    f' (ps, a, ss) = (IM.map (map f) ps, a, IM.map (map f) ss)++{-  RULES+      "nemap/GHC.Data.Graph.Inductive.PatriciaTree"  nemap = fastNEMap+   -}++fastNEMap :: forall a b c d. (a -> c) -> (b -> d) -> Gr a b -> Gr c d+fastNEMap fn fe (Gr g) = Gr (IM.map f g)+  where+    f :: Context' a b -> Context' c d+    f (ps, a, ss) = (IM.map (map fe) ps, fn a, IM.map (map fe) ss)++++----------------------------------------------------------------------+-- UTILITIES+----------------------------------------------------------------------++toAdj :: IntMap [b] -> Adj b+toAdj = concatMap expand . IM.toList+  where+    expand (n,ls) = map (flip (,) n) ls++--fromAdj :: Adj b -> IntMap [b]+--fromAdj = IM.fromListWith addLists . map (second (:[]) . swap)++data FromListCounting a = FromListCounting !Int !(IntMap a)+  deriving (Eq, Show, Read)++getFromListCounting :: FromListCounting a -> (Int, IntMap a)+getFromListCounting (FromListCounting i m) = (i, m)+{-# INLINE getFromListCounting #-}++fromListWithKeyCounting :: (Int -> a -> a -> a) -> [(Int, a)] -> (Int, IntMap a)+fromListWithKeyCounting f = getFromListCounting . foldl' ins (FromListCounting 0 IM.empty)+  where+    ins (FromListCounting i t) (k,x) = FromListCounting (i + 1) (IM.insertWithKey f k x t)+{-# INLINE fromListWithKeyCounting #-}++fromListWithCounting :: (a -> a -> a) -> [(Int, a)] -> (Int, IntMap a)+fromListWithCounting f = fromListWithKeyCounting (\_ x y -> f x y)+{-# INLINE fromListWithCounting #-}++fromAdjCounting :: Adj b -> (Int, IntMap [b])+fromAdjCounting = fromListWithCounting addLists . map (second (:[]) . swap)++-- We use differenceWith to modify a graph more than bulkThreshold times,+-- and repeated insertWith otherwise.+bulkThreshold :: Int+bulkThreshold = 5++--toContext :: Node -> Context' a b -> Context a b+--toContext v (ps, a, ss) = (toAdj ps, v, a, toAdj ss)++--fromContext :: Context a b -> Context' a b+--fromContext (ps, _, a, ss) = (fromAdj ps, a, fromAdj ss)++-- A version of @++@ where order isn't important, so @xs ++ [x]@+-- becomes @x:xs@.  Used when we have to have a function of type @[a]+-- -> [a] -> [a]@ but one of the lists is just going to be a single+-- element (and it isn't possible to tell which).+addLists :: [a] -> [a] -> [a]+addLists [a] as  = a : as+addLists as  [a] = a : as+addLists xs  ys  = xs ++ ys++addSucc :: forall a b . GraphRep a b -> Node -> Int -> IM.IntMap [b] -> GraphRep a b+addSucc g0 v numAdd xs+  | numAdd < bulkThreshold = foldlWithKey' go g0 xs+  where+    go :: GraphRep a b -> Node -> [b] -> GraphRep a b+    go g p l = IMS.adjust f p g+      where f (ps, l', ss) = let !ss' = IM.insertWith addLists v l ss+                             in (ps, l', ss')+addSucc g v _ xs = IMS.differenceWith go g xs+  where+    go :: Context' a b -> [b] -> Maybe (Context' a b)+    go (ps, l', ss) l = let !ss' = IM.insertWith addLists v l ss+                        in Just (ps, l', ss')++foldlWithKey' :: (a -> IM.Key -> b -> a) -> a -> IntMap b -> a+foldlWithKey' =+  IM.foldlWithKey'++addPred :: forall a b . GraphRep a b -> Node -> Int -> IM.IntMap [b] -> GraphRep a b+addPred g0 v numAdd xs+  | numAdd < bulkThreshold = foldlWithKey' go g0 xs+  where+    go :: GraphRep a b -> Node -> [b] -> GraphRep a b+    go g p l = IMS.adjust f p g+      where f (ps, l', ss) = let !ps' = IM.insertWith addLists v l ps+                             in (ps', l', ss)+addPred g v _ xs = IMS.differenceWith go g xs+  where+    go :: Context' a b -> [b] -> Maybe (Context' a b)+    go (ps, l', ss) l = let !ps' = IM.insertWith addLists v l ps+                        in Just (ps', l', ss)++clearSucc :: forall a b x . GraphRep a b -> Node -> IM.IntMap x -> GraphRep a b+clearSucc g v = IMS.differenceWith go g+  where+    go :: Context' a b -> x -> Maybe (Context' a b)+    go (ps, l, ss) _ = let !ss' = IM.delete v ss+                       in Just (ps, l, ss')++clearPred :: forall a b x . GraphRep a b -> Node -> IM.IntMap x -> GraphRep a b+clearPred g v = IMS.differenceWith go g+  where+    go :: Context' a b -> x -> Maybe (Context' a b)+    go (ps, l, ss) _ = let !ps' = IM.delete v ps+                       in Just (ps', l, ss)++{-----------------------------------------------------------------++Copyright (c) 1999-2008, Martin Erwig+              2010, Ivan Lazar Miljenovic+              2022, Norman Ramsey+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice,+   this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+   notice, this list of conditions and the following disclaimer in the+   documentation and/or other materials provided with the distribution.++3. Neither the name of the author nor the names of its contributors may be+   used to endorse or promote products derived from this software without+   specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE+LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR+CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF+SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS+INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN+CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)+ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.++----------------------------------------------------------------}
GHC/Data/Graph/Ops.hs view
@@ -253,7 +253,7 @@   -- | Add a coalescence edge to the graph, creating nodes if required.---      It is considered adventageous to assign the same color to nodes in a coalesence.+--      It is considered advantageous to assign the same color to nodes in a coalescence. addCoalesce         :: Uniquable k         => (k, cls) -> (k, cls)@@ -491,7 +491,7 @@          = 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 coelesce set then just ignore it.+                                -- 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@@ -609,7 +609,7 @@                         $  nonDetEltsUFM $ graphMap graph         , not $ null badNodes         = pprPanic "GHC.Data.Graph.Ops.validateGraph"-                (  text "Supposably colored graph has uncolored nodes."+                (  text "Supposedly colored graph has uncolored nodes."                 $$ text "  uncolored nodes: " <> hcat (map (ppr . nodeId) badNodes)                 $$ doc ) @@ -633,7 +633,7 @@                                 $  nonDetEltsUniqSet $ nodeConflicts node             -- See Note [Unique Determinism and code generation] -        , neighbourColors       <- catMaybes $ map nodeColor neighbors+        , neighbourColors       <- mapMaybe nodeColor neighbors         , elem color neighbourColors         = False
GHC/Data/Graph/UnVar.hs view
@@ -16,8 +16,8 @@ -} module GHC.Data.Graph.UnVar     ( UnVarSet-    , emptyUnVarSet, mkUnVarSet, varEnvDom, unionUnVarSet, unionUnVarSets-    , extendUnVarSet, delUnVarSet+    , emptyUnVarSet, mkUnVarSet, unionUnVarSet, unionUnVarSets+    , extendUnVarSet, extendUnVarSetList, delUnVarSet, delUnVarSetList     , elemUnVarSet, isEmptyUnVarSet     , UnVarGraph     , emptyUnVarGraph@@ -26,30 +26,34 @@     , neighbors     , hasLoopAt     , delNode+    , domUFMUnVarSet     ) where  import GHC.Prelude -import GHC.Types.Id-import GHC.Types.Var.Env-import GHC.Types.Unique.FM+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 Data.IntSet as S+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 adjancet nodes-newtype UnVarSet = UnVarSet (S.IntSet)+-- Set of uniques, i.e. for adjacent nodes+newtype UnVarSet = UnVarSet S.Word64Set     deriving Eq -k :: Var -> Int+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 @@ -63,6 +67,9 @@ 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' @@ -72,12 +79,12 @@ mkUnVarSet :: [Var] -> UnVarSet mkUnVarSet vs = UnVarSet $ S.fromList $ map k vs -varEnvDom :: VarEnv a -> UnVarSet-varEnvDom ae = UnVarSet $ ufmToSet_Directly ae- 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) @@ -86,7 +93,7 @@  instance Outputable UnVarSet where     ppr (UnVarSet s) = braces $-        hcat $ punctuate comma [ ppr (getUnique i) | i <- S.toList s]+        hcat $ punctuate comma [ ppr (mkUniqueGrimily i) | i <- S.toList s]  data UnVarGraph = CBPG  !UnVarSet !UnVarSet -- ^ complete bipartite graph                 | CG    !UnVarSet           -- ^ complete graph
GHC/Data/IOEnv.hs view
@@ -22,19 +22,19 @@         IOEnvFailure(..),          -- Getting at the environment-        getEnv, setEnv, updEnv,+        getEnv, setEnv, updEnv, updEnvIO,          runIOEnv, unsafeInterleaveM, uninterruptibleMaskM_,         tryM, tryAllM, tryMostM, fixM,          -- I/O operations-        IORef, newMutVar, readMutVar, writeMutVar, updMutVar, updMutVarM,+        IORef, newMutVar, readMutVar, writeMutVar, updMutVar,         atomicUpdMutVar, atomicUpdMutVar'   ) where  import GHC.Prelude -import GHC.Driver.Session+import GHC.Driver.DynFlags import {-# SOURCE #-} GHC.Driver.Hooks import GHC.IO (catchException) import GHC.Utils.Exception@@ -227,12 +227,6 @@ updMutVar :: IORef a -> (a -> a) -> IOEnv env () updMutVar var upd = liftIO (modifyIORef var upd) -updMutVarM :: IORef a -> (a -> IOEnv env a) -> IOEnv env ()-updMutVarM ref upd-  = do { contents     <- liftIO $ readIORef ref-       ; new_contents <- upd contents-       ; liftIO $ writeIORef ref new_contents }- -- | 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@@ -259,3 +253,8 @@ updEnv :: (env -> env') -> IOEnv env' a -> IOEnv env a {-# INLINE updEnv #-} updEnv upd (IOEnv m) = IOEnv (\ env -> m (upd env))++-- | Perform a computation with an altered environment+updEnvIO :: (env -> IO env') -> IOEnv env' a -> IOEnv env a+{-# INLINE updEnvIO #-}+updEnvIO upd (IOEnv m) = IOEnv (\ env -> m =<< upd env)
+ GHC/Data/List.hs view
@@ -0,0 +1,25 @@+module GHC.Data.List where++mapAndUnzip :: (a -> (b, c)) -> [a] -> ([b], [c])+mapAndUnzip _ [] = ([], [])+mapAndUnzip f (x:xs)+  = let (r1,  r2)  = f x+        (rs1, rs2) = mapAndUnzip f xs+    in+    (r1:rs1, r2:rs2)++mapAndUnzip3 :: (a -> (b, c, d)) -> [a] -> ([b], [c], [d])+mapAndUnzip3 _ [] = ([], [], [])+mapAndUnzip3 f (x:xs)+  = let (r1,  r2,  r3)  = f x+        (rs1, rs2, rs3) = mapAndUnzip3 f xs+    in+    (r1:rs1, r2:rs2, r3:rs3)++mapAndUnzip4 :: (a -> (b, c, d, e)) -> [a] -> ([b], [c], [d], [e])+mapAndUnzip4 _ [] = ([], [], [], [])+mapAndUnzip4 f (x:xs)+  = let (r1,  r2,  r3, r4)  = f x+        (rs1, rs2, rs3, rs4) = mapAndUnzip4 f xs+    in+    (r1:rs1, r2:rs2, r3:rs3, r4:rs4)
+ GHC/Data/List/Infinite.hs view
@@ -0,0 +1,206 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE RankNTypes #-}++module GHC.Data.List.Infinite+  ( Infinite (..)+  , head, tail+  , filter+  , (++)+  , unfoldr+  , (!!)+  , groupBy+  , dropList+  , iterate+  , concatMap+  , allListsOf+  , toList+  , repeat+  , enumFrom+  ) where++import Prelude ((-), Applicative (..), Bool (..), Enum (succ), Foldable, Functor (..), Int, Maybe (..), Monad (..), Traversable (..), (<$>), flip, otherwise)+import Control.Category (Category (..))+import Control.Monad (guard)+import qualified Data.Foldable as F+import Data.List.NonEmpty (NonEmpty (..))+import qualified GHC.Base as List (build)++infixr 5 `Inf`++data Infinite a = Inf a (Infinite a)+  deriving (Foldable, Functor, Traversable)++head :: Infinite a -> a+head (Inf a _) = a+{-# NOINLINE [1] head #-}++tail :: Infinite a -> Infinite a+tail (Inf _ as) = as+{-# NOINLINE [1] tail #-}++{-# RULES+"head/build" forall (g :: forall b . (a -> b -> b) -> b) . head (build g) = g \ x _ -> x+  #-}++instance Applicative Infinite where+    pure = repeat+    Inf f fs <*> Inf a as = Inf (f a) (fs <*> as)++instance Monad Infinite where+    x >>= f = join (f <$> x)+      where+        join (Inf a as) = head a `Inf` join (tail <$> as)++mapMaybe :: (a -> Maybe b) -> Infinite a -> Infinite b+mapMaybe f = go+  where+    go (Inf a as) = let bs = go as in case f a of+        Nothing -> bs+        Just b -> Inf b bs+{-# NOINLINE [1] mapMaybe #-}++{-# RULES+"mapMaybe" [~1] forall f as . mapMaybe f as = build \ c -> foldr (mapMaybeFB c f) as+"mapMaybeList" [1] forall f . foldr (mapMaybeFB Inf f) = mapMaybe f+  #-}++{-# INLINE [0] mapMaybeFB #-}+mapMaybeFB :: (b -> r -> r) -> (a -> Maybe b) -> a -> r -> r+mapMaybeFB cons f a bs = case f a of+    Nothing -> bs+    Just r -> cons r bs++filter :: (a -> Bool) -> Infinite a -> Infinite a+filter f = mapMaybe (\ a -> a <$ guard (f a))+{-# INLINE filter #-}++infixr 5 +++(++) :: Foldable f => f a -> Infinite a -> Infinite a+(++) = flip (F.foldr Inf)++unfoldr :: (b -> (a, b)) -> b -> Infinite a+unfoldr f b = build \ c -> let go b = case f b of (a, b') -> a `c` go b' in go b+{-# INLINE unfoldr #-}++(!!) :: Infinite a -> Int -> a+Inf a _ !! 0 = a+Inf _ as !! n = as !! (n-1)++groupBy :: (a -> a -> Bool) -> Infinite a -> Infinite (NonEmpty a)+groupBy eq = go+  where+    go (Inf a as) = Inf (a:|bs) (go cs)+      where (bs, cs) = span (eq a) as++span :: (a -> Bool) -> Infinite a -> ([a], Infinite a)+span p = spanJust (\ a -> a <$ guard (p a))+{-# INLINE span #-}++spanJust :: (a -> Maybe b) -> Infinite a -> ([b], Infinite a)+spanJust p = go+  where+    go as@(Inf a as')+      | Just b <- p a = let (bs, cs) = go as' in (b:bs, cs)+      | otherwise = ([], as)++iterate :: (a -> a) -> a -> Infinite a+iterate f = go where go a = Inf a (go (f a))+{-# NOINLINE [1] iterate #-}++{-# RULES+"iterate" [~1] forall f a . iterate f a = build (\ c -> iterateFB c f a)+"iterateFB" [1] iterateFB Inf = iterate+  #-}++iterateFB :: (a -> b -> b) -> (a -> a) -> a -> b+iterateFB c f a = go a+  where go a = a `c` go (f a)+{-# INLINE [0] iterateFB #-}++concatMap :: Foldable f => (a -> f b) -> Infinite a -> Infinite b+concatMap f = go where go (Inf a as) = f a ++ go as+{-# NOINLINE [1] concatMap #-}++{-# RULES "concatMap" forall f as . concatMap f as = build \ c -> foldr (\ x b -> F.foldr c b (f x)) as #-}++{-# SPECIALIZE concatMap :: (a -> [b]) -> Infinite a -> Infinite b #-}++foldr :: (a -> b -> b) -> Infinite a -> b+foldr f = go where go (Inf a as) = f a (go as)+{-# INLINE [0] foldr #-}++build :: (forall b . (a -> b -> b) -> b) -> Infinite a+build g = g Inf+{-# INLINE [1] build #-}++-- Analogous to 'foldr'/'build' fusion for '[]'+{-# RULES+"foldr/build" forall f (g :: forall b . (a -> b -> b) -> b) . foldr f (build g) = g f+"foldr/id" foldr Inf = id++"foldr/cons/build" forall f a (g :: forall b . (a -> b -> b) -> b) . foldr f (Inf a (build g)) = f a (g f)+  #-}++{-# RULES+"map" [~1] forall f (as :: Infinite a) . fmap f as = build \ c -> foldr (mapFB c f) as+"mapFB" forall c f g . mapFB (mapFB c f) g = mapFB c (f . g)+"mapFB/id" forall c . mapFB c (\ x -> x) = c+  #-}++mapFB :: (b -> c -> c) -> (a -> b) -> a -> c -> c+mapFB c f = \ x ys -> c (f x) ys+{-# INLINE [0] mapFB #-}++dropList :: [a] -> Infinite b -> Infinite b+dropList [] bs = bs+dropList (_:as) (Inf _ bs) = dropList as bs++-- | Compute all lists of the given alphabet.+-- For example: @'allListsOf' "ab" = ["a", "b", "aa", "ba", "ab", "bb", "aaa", "baa", "aba", ...]@+allListsOf :: [a] -> Infinite [a]+allListsOf as = concatMap (\ bs -> [a:bs | a <- as]) ([] `Inf` allListsOf as)++-- See Note [Fusion for `Infinite` lists].+toList :: Infinite a -> [a]+toList = \ as -> List.build (\ c _ -> foldr c as)+{-# INLINE toList #-}++repeat :: a -> Infinite a+repeat a = as where as = Inf a as+{-# INLINE [0] repeat #-}++repeatFB :: (a -> b -> b) -> a -> b+repeatFB c x = xs where xs = c x xs+{-# INLINE [0] repeatFB #-}++{-# RULES+"repeat" [~1] forall a . repeat a = build \ c -> repeatFB c a+"repeatFB" [1] repeatFB Inf = repeat+  #-}++enumFrom :: Enum a => a -> Infinite a+enumFrom = iterate succ+{-# INLINE enumFrom #-}++{-+Note [Fusion for `Infinite` lists]+~~~~~~~~~~~~~~~~~~~~+We use RULES to support foldr/build fusion for Infinite lists, analogously to the RULES in+GHC.Base to support fusion for regular lists. In particular, we define the following:+• `build :: (forall b . (a -> b -> b) -> b) -> Infinite a`+• `foldr :: (a -> b -> b) -> Infinite a -> b`+• A RULE `foldr f (build g) = g f`+• `Infinite`-producing functions in terms of `build`, and `Infinite`-consuming functions in+  terms of `foldr`++This can work across data types. For example, consider `toList :: Infinite a -> [a]`.+We want 'toList' to be both a good consumer (of 'Infinite' lists) and a good producer (of '[]').+Ergo, we define it in terms of 'Infinite.foldr' and `List.build`.++For a bigger example, consider `List.map f (toList (Infinite.map g as))`++We want to fuse away the intermediate `Infinite` structure between `Infnite.map` and `toList`,+and the list structure between `toList` and `List.map`. And indeed we do: see test+"InfiniteListFusion".+-}
+ GHC/Data/List/NonEmpty.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE LambdaCase #-}++module GHC.Data.List.NonEmpty (module Data.List.NonEmpty, module GHC.Data.List.NonEmpty, toList) where++import Prelude (Bool, (.))+import Control.Applicative+import qualified Control.Monad as List (zipWithM)+import Data.Foldable (Foldable (toList))+import Data.List.NonEmpty hiding (toList, unzip)+import qualified Data.List as List+import qualified GHC.Data.List as List++zipWithM :: Applicative f => (a -> b -> f c) -> NonEmpty a -> NonEmpty b -> f (NonEmpty c)+zipWithM f (a:|as) (b:|bs) = liftA2 (:|) (f a b) (List.zipWithM f as bs)+-- Inline to enable fusion of `List.zipWithM`+-- See Note [Fusion for zipN/zipWithN] in List.hs+{-# INLINE zipWithM #-}++unzip :: NonEmpty (a, b) -> (NonEmpty a, NonEmpty b)+unzip ((a,b):|xs) = (a:|as, b:|bs)+  where+    (as, bs) = List.unzip xs++unzip3 :: NonEmpty (a, b, c) -> (NonEmpty a, NonEmpty b, NonEmpty c)+unzip3 ((a,b,c):|xs) = (a:|as, b:|bs, c:|cs)+  where+    (as, bs, cs) = List.unzip3 xs++mapAndUnzip :: (a -> (b, c)) -> NonEmpty a -> (NonEmpty b, NonEmpty c)+mapAndUnzip f (x:|xs) = (b:|bs, c:|cs)+  where+    (b, c) = f x+    (bs, cs) = List.mapAndUnzip f xs++mapAndUnzip3 :: (a -> (b, c, d)) -> NonEmpty a -> (NonEmpty b, NonEmpty c, NonEmpty d)+mapAndUnzip3 f (x:|xs) = (b:|bs, c:|cs, d:|ds)+  where+    (b, c, d) = f x+    (bs, cs, ds) = List.mapAndUnzip3 f xs++isSingleton :: NonEmpty a -> Bool+isSingleton = List.null . tail
GHC/Data/List/SetOps.hs view
@@ -12,13 +12,13 @@ -- -- Avoid using them as much as possible module GHC.Data.List.SetOps (-        unionLists, minusList,+        unionLists, unionListsOrd, minusList,          -- Association lists         Assoc, assoc, assocMaybe, assocUsing, assocDefault, assocDefaultUsing,          -- Duplicate handling-        hasNoDups, removeDups, nubOrdBy, findDupsEq,+        hasNoDups, removeDups, removeDupsOn, nubOrdBy, findDupsEq,         equivClasses,          -- Indexing@@ -33,11 +33,11 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Misc-import GHC.Utils.Trace  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@@ -54,6 +54,19 @@ -}  ++-- | 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.@@ -161,7 +174,7 @@     eq a b = case cmp a b of { EQ -> True; _ -> False }  -- | Remove the duplicates from a list using the provided--- comparison function.+-- 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.@@ -180,6 +193,9 @@     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.
GHC/Data/Maybe.hs view
@@ -32,9 +32,12 @@ import Control.Monad.Trans.Maybe import Control.Exception (SomeException(..)) import Data.Maybe-import Data.Foldable ( foldlM )+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` @@ -47,7 +50,7 @@ -}  firstJust :: Maybe a -> Maybe a -> Maybe a-firstJust a b = firstJusts [a, b]+firstJust = (<|>)  -- | Takes a list of @Maybes@ and returns the first @Just@ if there is one, or -- @Nothing@ otherwise.@@ -65,14 +68,17 @@   go Nothing         action  = action   go result@(Just _) _action = return result -expectJust :: HasCallStack => String -> Maybe a -> a+expectJust :: HasCallStack => Maybe a -> a+-- always enable the call stack to get the location even on non-debug builds {-# INLINE expectJust #-}-expectJust _   (Just x) = x-expectJust err Nothing  = error ("expectJust " ++ err)+expectJust = fromMaybe expectJustError +expectJustError :: HasCallStack => a+expectJustError = pprPanic "expectJust" empty+{-# NOINLINE expectJustError #-}+ whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m ()-whenIsJust (Just x) f = f x-whenIsJust Nothing  _ = return ()+whenIsJust = for_  -- | Flipped version of @fromMaybe@, useful for chaining. orElse :: Maybe a -> a -> a
GHC/Data/OrdList.hs view
@@ -4,11 +4,8 @@   -}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE BangPatterns #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE UnboxedSums #-} {-# LANGUAGE UnboxedTuples #-}  -- | Provide trees (of instructions), so that lists of instructions can be@@ -17,8 +14,8 @@         OrdList, pattern NilOL, pattern ConsOL, pattern SnocOL,         nilOL, isNilOL, unitOL, appOL, consOL, snocOL, concatOL, lastOL,         headOL,-        mapOL, mapOL', fromOL, toOL, foldrOL, foldlOL, reverseOL, fromOLReverse,-        strictlyEqOL, strictlyOrdOL+        mapOL, mapOL', fromOL, toOL, foldrOL, foldlOL,+        partitionOL, reverseOL, fromOLReverse, strictlyEqOL, strictlyOrdOL ) where  import GHC.Prelude@@ -28,6 +25,8 @@ 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`@@ -37,7 +36,7 @@ data OrdList a   = None   | One a-  | Many [a]          -- Invariant: non-empty+  | Many (NonEmpty a)   | Cons a (OrdList a)   | Snoc (OrdList a) a   | Two (OrdList a) -- Invariant: non-empty@@ -100,8 +99,12 @@ 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 (One a)       = VJust a NilOL+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)@@ -109,15 +112,18 @@ viewCons (Two as1 as2) = case viewCons as1 of   VJust a' as1' -> VJust a' (Two as1' as2)   VNothing      -> viewCons as2-viewCons _ = VNothing  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 (One a)       = VJust NilOL a-viewSnoc (Many (reverse -> a:as)) = VJust (Many (reverse as)) 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'@@ -125,18 +131,17 @@ viewSnoc (Two as1 as2) = case viewSnoc as2 of   VJust as2' a' -> VJust (Two as1 as2') a'   VNothing      -> viewSnoc as1-viewSnoc _ = VNothing  headOL None        = panic "headOL" headOL (One a)     = a-headOL (Many as)   = head as+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)   = last as+lastOL (Many as)   = NE.last as lastOL (Cons _ as) = lastOL as lastOL (Snoc _ a)  = a lastOL (Two _ as)  = lastOL as@@ -164,7 +169,7 @@         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+        go (Many xs)  acc = NE.toList xs ++ acc  fromOLReverse :: OrdList a -> [a] fromOLReverse a = go a []@@ -175,7 +180,7 @@         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 xs ++ acc+        go (Many xs)  acc = reverse (NE.toList xs) ++ acc  mapOL :: (a -> b) -> OrdList a -> OrdList b mapOL = fmap@@ -192,7 +197,9 @@ mapOL' f (Two b1 b2) = let !b1' = mapOL' f b1                            !b2' = mapOL' f b2                        in Two b1' b2'-mapOL' f (Many xs)   = Many $! strictMap f xs+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@@ -211,10 +218,29 @@ 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 xs = Many xs+toOL (x : xs) = Many (x :| xs)  reverseOL :: OrdList a -> OrdList a reverseOL None = None@@ -222,7 +248,7 @@ 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 (reverse xs)+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
+ GHC/Data/OsPath.hs view
@@ -0,0 +1,29 @@+module GHC.Data.OsPath+  (+  -- * OsPath initialisation and transformation+    OsPath+  , OsString+  , encodeUtf+  , decodeUtf+  , unsafeDecodeUtf+  , unsafeEncodeUtf+  , os+  -- * Common utility functions+  , (</>)+  , (<.>)+  )+  where++import GHC.Prelude++import GHC.Utils.Misc (HasCallStack)+import GHC.Utils.Panic (panic)++import System.OsPath+import System.Directory.Internal (os)++-- | Decode an 'OsPath' to 'FilePath', throwing an 'error' if decoding failed.+-- Prefer 'decodeUtf' and gracious error handling.+unsafeDecodeUtf :: HasCallStack => OsPath -> FilePath+unsafeDecodeUtf p =+  either (\err -> panic $ "Failed to decodeUtf \"" ++ show p ++ "\", because: " ++ show err) id (decodeUtf p)
GHC/Data/Pair.hs view
@@ -4,15 +4,15 @@ -}  -{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveTraversable #-}  module GHC.Data.Pair    ( Pair(..)    , unPair    , toPair    , swap-   , pLiftFst-   , pLiftSnd+   , pLiftFst, pLiftSnd+   , unzipPairs    ) where @@ -22,7 +22,7 @@ import qualified Data.Semigroup as Semi  data Pair a = Pair { pFst :: a, pSnd :: a }-  deriving (Functor)+  deriving (Foldable, Functor, Traversable) -- Note that Pair is a *unary* type constructor -- whereas (,) is binary @@ -34,12 +34,6 @@   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 Semi.Semigroup a => Semi.Semigroup (Pair a) where   Pair a1 b1 <> Pair a2 b2 =  Pair (a1 Semi.<> a2) (b1 Semi.<> b2) @@ -64,3 +58,14 @@  pLiftSnd :: (a -> a) -> Pair a -> Pair a pLiftSnd f (Pair a b) = Pair a (f b)++unzipPairs :: [Pair a] -> ([a], [a])+unzipPairs [] = ([], [])+unzipPairs (Pair a b : prs) = (a:as, b:bs)+  where+    !(as,bs) = unzipPairs prs+    -- This makes the unzip work eagerly, building no thunks at+    -- the cost of doing all the work up-front.++instance Foldable1 Pair where+    foldMap1 f (Pair a b) = f a Semi.<> f b
GHC/Data/SmallArray.hs view
@@ -11,18 +11,32 @@   , 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@@ -32,6 +46,9 @@ 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@@ -41,7 +58,13 @@ {-# 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@@ -64,16 +87,69 @@   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+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
GHC/Data/Stream.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE RankNTypes #-} -- -----------------------------------------------------------------------------@@ -8,7 +9,7 @@  -- | Monadic streams module GHC.Data.Stream (-    Stream(..), StreamS(..), runStream, yield, liftIO,+    Stream(..), StreamS(..), runStream, yield, liftIO, liftEff, hoistEff,     collect,  consume, fromList,     map, mapM, mapAccumL_   ) where@@ -66,9 +67,7 @@ data StreamS m a b = Yield a (StreamS m a b)                    | Done b                    | Effect (m (StreamS m a b))--instance Monad m => Functor (StreamS m a) where-  fmap = liftM+  deriving (Functor)  instance Monad m => Applicative (StreamS m a) where   pure = Done@@ -126,7 +125,7 @@ -- | 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--- effiency problems.+-- 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)@@ -141,3 +140,22 @@     go c f1 h1 (Yield a p) = Effect (f c a >>= (\(c', b) -> f1 b                                            >>= \r' -> return $ Yield r' (go c' f1 h1 p)))     go c f1 h1 (Effect m) = Effect (go c f1 h1 <$> m)++-- | Lift an effect into the Stream+liftEff :: Monad m => m b -> Stream m a b+liftEff eff = Stream $ \_f g -> Effect (g <$> eff)++-- | Hoist the underlying Stream effect+-- Note this is not very efficience since, just like 'mapAccumL_', it also needs+-- to traverse and rebuild the whole stream.+hoistEff :: forall m n a b. (Applicative m, Monad n) => (forall x. m x -> n x) -> Stream m a b -> Stream n a b+hoistEff h s = Stream $ \f g -> hs f g (runStream s :: StreamS m a b) where+  hs :: (a -> n r')+     -> (b -> StreamS n r' r)+     -> StreamS m a b+     -> StreamS n r' r+  hs f g x = case x of+    Done d -> g d+    Yield a r -> Effect (f a >>= \r' -> return $ Yield r' (hs f g r))+    Effect e -> Effect (h (hs f g <$> e))+
GHC/Data/Strict.hs view
@@ -9,8 +9,8 @@ module GHC.Data.Strict (     Maybe(Nothing, Just),     fromMaybe,+    GHC.Data.Strict.maybe,     Pair(And),-     -- Not used at the moment:     --     -- Either(Left, Right),@@ -18,16 +18,26 @@   ) 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)
GHC/Data/StringBuffer.hs view
@@ -6,10 +6,9 @@ Buffers for scanning string input stored in external arrays. -} -{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE LambdaCase #-}  {-# OPTIONS_GHC -O2 #-} -- We always optimise this, otherwise performance of a non-optimised@@ -48,6 +47,7 @@           -- * Parsing integers         parseUnsignedInteger,+        findHashOffset,          -- * Checking for bi-directional format characters         containsBidirectionalFormatChar,@@ -76,12 +76,7 @@ import GHC.Exts  import Foreign-#if MIN_VERSION_base(4,15,0) import GHC.ForeignPtr (unsafeWithForeignPtr)-#else-unsafeWithForeignPtr :: ForeignPtr a -> (Ptr a -> IO b) -> IO b-unsafeWithForeignPtr = withForeignPtr-#endif  -- ----------------------------------------------------------------------------- -- The StringBuffer type@@ -199,7 +194,7 @@   let size = utf8EncodedLength str   buf <- mallocForeignPtrArray (size+3)   unsafeWithForeignPtr buf $ \ptr -> do-    utf8EncodeStringPtr ptr str+    utf8EncodePtr ptr str     pokeArray (ptr `plusPtr` size :: Ptr Word8) [0,0,0]     -- sentinels for UTF-8 decoding   return (StringBuffer buf size 0)@@ -297,7 +292,7 @@   inlinePerformIO $     unsafeWithForeignPtr buf $ \p -> do       p' <- utf8PrevChar (p `plusPtr` cur)-      return (fst (utf8DecodeChar p'))+      return (fst (utf8DecodeCharPtr p'))  -- ----------------------------------------------------------------------------- -- Moving@@ -383,7 +378,7 @@                -> String lexemeToString _ 0 = "" lexemeToString (StringBuffer buf _ cur) bytes =-  utf8DecodeStringLazy buf cur bytes+  utf8DecodeForeignPtr buf cur bytes  lexemeToFastString :: StringBuffer                    -> Int               -- ^ @n@, the number of bytes@@ -405,7 +400,7 @@     go buf0 n acc p | n == 0 || buf0 >= p = return acc     go buf0 n acc p = do         p' <- utf8PrevChar p-        let (c,_) = utf8DecodeChar p'+        let (c,_) = utf8DecodeCharPtr p'         go buf0 (n - 1) (c:acc) p'  -- -----------------------------------------------------------------------------@@ -414,7 +409,19 @@ 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+           | otherwise = case fst (utf8DecodeCharPtr (ptr `plusPtr` (cur + i))) of                '_'  -> go (i + 1) x    -- skip "_" (#14473)                char -> go (i + 1) (x * radix + toInteger (char_to_int char))   in go 0 0++-- | Find the offset of the '#' character in the StringBuffer.+--+-- Make sure that it contains one before calling this function!+findHashOffset :: StringBuffer -> Int+findHashOffset (StringBuffer buf _ cur)+  = inlinePerformIO $ withForeignPtr buf $ \ptr -> do+      let+        go p = peek p >>= \case+          (0x23 :: Word8) -> pure $! ((p `minusPtr` ptr) - cur)+          _               -> go (p `plusPtr` 1)+      go (ptr `plusPtr` cur)
GHC/Data/TrieMap.hs view
@@ -13,8 +13,6 @@    MaybeMap,    -- * Maps over 'List' values    ListMap,-   -- * Maps over 'Literal's-   LiteralMap,    -- * 'TrieMap' class    TrieMap(..), insertTM, deleteTM, foldMapTM, isEmptyTM, @@ -30,7 +28,6 @@  import GHC.Prelude -import GHC.Types.Literal import GHC.Types.Unique.DFM import GHC.Types.Unique( Uniquable ) @@ -66,14 +63,13 @@ type XT a = Maybe a -> Maybe a  -- How to alter a non-existent elt (Nothing)                                 --               or an existing elt (Just) -class TrieMap m where+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-   mapTM    :: (a->b) -> m a -> 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;@@ -117,6 +113,25 @@ 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@@ -130,8 +145,8 @@   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   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@@ -142,8 +157,8 @@   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   filterTM f m = Map.filter f m+  mapMaybeTM f m = Map.mapMaybe f m   {-@@ -219,8 +234,8 @@   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   filterTM f m = filterUDFM f m+  mapMaybeTM f m = mapMaybeUDFM f m  {- ************************************************************************@@ -235,22 +250,23 @@  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-   mapTM    = mapMb    filterTM = ftMaybe+   mapMaybeTM = mpMaybe  instance TrieMap m => Foldable (MaybeMap m) where   foldMap = foldMapTM -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@@ -269,6 +285,10 @@ 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@@ -290,14 +310,19 @@   = 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-   mapTM    = mapList    filterTM = ftList+   mapMaybeTM = mpList  instance TrieMap m => Foldable (ListMap m) where   foldMap = foldMapTM@@ -305,10 +330,6 @@ instance (TrieMap m, Outputable a) => Outputable (ListMap m a) where   ppr m = text "List elts" <+> ppr (foldTM (:) m []) -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@@ -326,17 +347,11 @@  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 = mapTM (filterTM f) mcons }--{--************************************************************************-*                                                                      *-                   Basic maps-*                                                                      *-************************************************************************--}+  = LM { lm_nil = filterMaybe f mnil, lm_cons = fmap (filterTM f) mcons } -type LiteralMap  a = Map.Map Literal a+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 }  {- ************************************************************************@@ -380,6 +395,11 @@   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@@ -387,8 +407,8 @@    lookupTM = lkG    alterTM  = xtG    foldTM   = fdG-   mapTM    = mapG    filterTM = ftG+   mapMaybeTM = mpG  instance (Eq (Key m), TrieMap m) => Foldable (GenMap m) where   foldMap = foldMapTM@@ -431,10 +451,10 @@ xtG k f (MultiMap m) = MultiMap (alterTM k f m)  {-# INLINEABLE mapG #-}-mapG :: TrieMap m => (a -> b) -> GenMap m a -> GenMap m b+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 (mapTM f m)+mapG f (MultiMap m) = MultiMap (fmap f m)  {-# INLINEABLE fdG #-} fdG :: TrieMap m => (a -> b -> b) -> GenMap m a -> b -> b@@ -451,3 +471,11 @@ ftG f (MultiMap m) = MultiMap (filterTM f m)   -- we don't have enough information to reconstruct the key to make   -- a SingletonMap++{-# INLINEABLE mpG #-}+mpG :: TrieMap m => (a -> Maybe b) -> GenMap m a -> GenMap m b+mpG _ EmptyMap = EmptyMap+mpG f (SingletonMap k v) = case f v of+                             Just v' -> SingletonMap k v'+                             Nothing -> EmptyMap+mpG f (MultiMap m) = MultiMap (mapMaybeTM f m)
+ GHC/Data/Unboxed.hs view
@@ -0,0 +1,56 @@+-- Unboxed counterparts to data structures++{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE UnliftedNewtypes #-}++{-# OPTIONS_GHC -fno-omit-interface-pragmas #-}+  -- If you use -fomit-interface-pragmas for your build, we won't+  -- inline the matcher for JustUB, and that turns out to have a+  -- catastropic effect on Lint, which uses unboxed Maybes.+  -- Simple fix: switch off -fomit-interface-pragmas for this tiny+  -- and very stable module.++module GHC.Data.Unboxed (+  MaybeUB(JustUB, NothingUB),+  fmapMaybeUB, fromMaybeUB, apMaybeUB, maybeUB+  ) where++import GHC.Prelude hiding (Maybe(..), Either(..))++-- | Like Maybe, but using unboxed sums.+--+-- Use with care. Using a unboxed maybe is not always a win+-- in execution *time* even when allocations go down. So make+-- sure to benchmark for execution time as well. If the difference+-- in *runtime* for the compiler is too small to measure it's likely+-- better to use a regular Maybe instead.+--+-- This is since it causes more function arguments to be passed, and+-- potentially more variables to be captured by closures increasing+-- closure size.+newtype MaybeUB a = MaybeUB (# (# #) | a #)++pattern JustUB :: a -> MaybeUB a+pattern JustUB x = MaybeUB (# | x #)++pattern NothingUB :: MaybeUB a+pattern NothingUB = MaybeUB (# (# #) | #)++{-# COMPLETE NothingUB, JustUB #-}++fromMaybeUB :: a -> MaybeUB a -> a+fromMaybeUB d NothingUB = d+fromMaybeUB _ (JustUB x) = x++apMaybeUB :: MaybeUB (a -> b) -> MaybeUB a -> MaybeUB b+apMaybeUB (JustUB f) (JustUB x) = JustUB (f x)+apMaybeUB _ _ = NothingUB++fmapMaybeUB :: (a -> b) -> MaybeUB a -> MaybeUB b+fmapMaybeUB _f NothingUB = NothingUB+fmapMaybeUB f (JustUB x) = JustUB $ f x++maybeUB :: b -> (a -> b) -> MaybeUB a -> b+maybeUB _def f (JustUB x) = f x+maybeUB def _f NothingUB = def
+ GHC/Data/Word64Map.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE MonoLocalBinds #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Word64Map+-- Copyright   :  (c) Daan Leijen 2002+--                (c) Andriy Palamarchuk 2008+-- License     :  BSD-style+-- Maintainer  :  libraries@haskell.org+-- Portability :  portable+--+-- An efficient implementation of maps from integer keys to values+-- (dictionaries).+--+-- This module re-exports the value lazy "Data.Word64Map.Lazy" API, plus+-- several deprecated value strict functions. Please note that these functions+-- have different strictness properties than those in "Data.Word64Map.Strict":+-- they only evaluate the result of the combining function. For example, the+-- default value to 'insertWith'' is only evaluated if the combining function+-- is called and uses it.+--+-- These modules are intended to be imported qualified, to avoid name+-- clashes with Prelude functions, e.g.+--+-- >  import Data.Word64Map (Word64Map)+-- >  import qualified Data.Word64Map as Word64Map+--+-- The implementation is based on /big-endian patricia trees/.  This data+-- structure performs especially well on binary operations like 'union'+-- and 'intersection'.  However, my benchmarks show that it is also+-- (much) faster on insertions and deletions when compared to a generic+-- size-balanced map implementation (see "Data.Map").+--+--    * Chris Okasaki and Andy Gill,  \"/Fast Mergeable Integer Maps/\",+--      Workshop on ML, September 1998, pages 77-86,+--      <http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.37.5452>+--+--    * D.R. Morrison, \"/PATRICIA -- Practical Algorithm To Retrieve Information Coded In Alphanumeric/\",+--      Journal of the ACM, 15(4), October 1968, pages 514-534.+--+-- Operation comments contain the operation time complexity in+-- the Big-O notation <http://en.wikipedia.org/wiki/Big_O_notation>.+-- Many operations have a worst-case complexity of \(O(\min(n,64))\).+-- This means that the operation can become linear in the number of+-- elements with a maximum of \(64\)+-----------------------------------------------------------------------------++module GHC.Data.Word64Map+    ( module GHC.Data.Word64Map.Lazy+    ) where++import GHC.Data.Word64Map.Lazy
+ GHC/Data/Word64Map/Internal.hs view
@@ -0,0 +1,3575 @@+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE TypeFamilies #-}++{-# OPTIONS_HADDOCK not-home #-}+{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}+++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Word64Map.Internal+-- Copyright   :  (c) Daan Leijen 2002+--                (c) Andriy Palamarchuk 2008+--                (c) wren romano 2016+-- License     :  BSD-style+-- Maintainer  :  libraries@haskell.org+-- Portability :  portable+--+-- = WARNING+--+-- This module is considered __internal__.+--+-- The Package Versioning Policy __does not apply__.+--+-- The contents of this module may change __in any way whatsoever__+-- and __without any warning__ between minor versions of this package.+--+-- Authors importing this module are expected to track development+-- closely.+--+-- = Description+--+-- This defines the data structures and core (hidden) manipulations+-- on representations.+--+-- @since 0.5.9+-----------------------------------------------------------------------------++-- [Note: INLINE bit fiddling]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- It is essential that the bit fiddling functions like mask, zero, branchMask+-- etc are inlined. If they do not, the memory allocation skyrockets. The GHC+-- usually gets it right, but it is disastrous if it does not. Therefore we+-- explicitly mark these functions INLINE.+++-- [Note: Local 'go' functions and capturing]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- Care must be taken when using 'go' function which captures an argument.+-- Sometimes (for example when the argument is passed to a data constructor,+-- as in insert), GHC heap-allocates more than necessary. Therefore C-- code+-- must be checked for increased allocation when creating and modifying such+-- functions.+++-- [Note: Order of constructors]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- The order of constructors of Word64Map matters when considering performance.+-- Currently in GHC 7.0, when type has 3 constructors, they are matched from+-- the first to the last -- the best performance is achieved when the+-- constructors are ordered by frequency.+-- On GHC 7.0, reordering constructors from Nil | Tip | Bin to Bin | Tip | Nil+-- improves the benchmark by circa 10%.+--++module GHC.Data.Word64Map.Internal (+    -- * Map type+      Word64Map(..), Key          -- instance Eq,Show++    -- * Operators+    , (!), (!?), (\\)++    -- * Query+    , null+    , size+    , member+    , notMember+    , lookup+    , findWithDefault+    , lookupLT+    , lookupGT+    , lookupLE+    , lookupGE+    , disjoint++    -- * Construction+    , empty+    , singleton++    -- ** Insertion+    , insert+    , insertWith+    , insertWithKey+    , insertLookupWithKey++    -- ** Delete\/Update+    , delete+    , adjust+    , adjustWithKey+    , update+    , updateWithKey+    , updateLookupWithKey+    , alter+    , alterF++    -- * Combine++    -- ** Union+    , union+    , unionWith+    , unionWithKey+    , unions+    , unionsWith++    -- ** Difference+    , difference+    , differenceWith+    , differenceWithKey++    -- ** Intersection+    , intersection+    , intersectionWith+    , intersectionWithKey++    -- ** Compose+    , compose++    -- ** General combining function+    , SimpleWhenMissing+    , SimpleWhenMatched+    , runWhenMatched+    , runWhenMissing+    , merge+    -- *** @WhenMatched@ tactics+    , zipWithMaybeMatched+    , zipWithMatched+    -- *** @WhenMissing@ tactics+    , mapMaybeMissing+    , dropMissing+    , preserveMissing+    , mapMissing+    , filterMissing++    -- ** Applicative general combining function+    , WhenMissing (..)+    , WhenMatched (..)+    , mergeA+    -- *** @WhenMatched@ tactics+    -- | The tactics described for 'merge' work for+    -- 'mergeA' as well. Furthermore, the following+    -- are available.+    , zipWithMaybeAMatched+    , zipWithAMatched+    -- *** @WhenMissing@ tactics+    -- | The tactics described for 'merge' work for+    -- 'mergeA' as well. Furthermore, the following+    -- are available.+    , traverseMaybeMissing+    , traverseMissing+    , filterAMissing++    -- ** Deprecated general combining function+    , mergeWithKey+    , mergeWithKey'++    -- * Traversal+    -- ** Map+    , map+    , mapWithKey+    , traverseWithKey+    , traverseMaybeWithKey+    , mapAccum+    , mapAccumWithKey+    , mapAccumRWithKey+    , mapKeys+    , mapKeysWith+    , mapKeysMonotonic++    -- * Folds+    , foldr+    , foldl+    , foldrWithKey+    , foldlWithKey+    , foldMapWithKey++    -- ** Strict folds+    , foldr'+    , foldl'+    , foldrWithKey'+    , foldlWithKey'++    -- * Conversion+    , elems+    , keys+    , assocs+    , keysSet+    , fromSet++    -- ** Lists+    , toList+    , fromList+    , fromListWith+    , fromListWithKey++    -- ** Ordered lists+    , toAscList+    , toDescList+    , fromAscList+    , fromAscListWith+    , fromAscListWithKey+    , fromDistinctAscList++    -- * Filter+    , filter+    , filterWithKey+    , restrictKeys+    , withoutKeys+    , partition+    , partitionWithKey++    , takeWhileAntitone+    , dropWhileAntitone+    , spanAntitone++    , mapMaybe+    , mapMaybeWithKey+    , mapEither+    , mapEitherWithKey++    , split+    , splitLookup+    , splitRoot++    -- * Submap+    , isSubmapOf, isSubmapOfBy+    , isProperSubmapOf, isProperSubmapOfBy++    -- * Min\/Max+    , lookupMin+    , lookupMax+    , findMin+    , findMax+    , deleteMin+    , deleteMax+    , deleteFindMin+    , deleteFindMax+    , updateMin+    , updateMax+    , updateMinWithKey+    , updateMaxWithKey+    , minView+    , maxView+    , minViewWithKey+    , maxViewWithKey++    -- * Debugging+    , showTree+    , showTreeWith++    -- * Internal types+    , Mask, Prefix, Nat++    -- * Utility+    , natFromInt+    , intFromNat+    , link+    , linkWithMask+    , bin+    , binCheckLeft+    , binCheckRight+    , zero+    , nomatch+    , match+    , mask+    , maskW+    , shorter+    , branchMask+    , highestBitMask++    -- * Used by "Word64Map.Merge.Lazy" and "Word64Map.Merge.Strict"+    , mapWhenMissing+    , mapWhenMatched+    , lmapWhenMissing+    , contramapFirstWhenMatched+    , contramapSecondWhenMatched+    , mapGentlyWhenMissing+    , mapGentlyWhenMatched+    ) where++import GHC.Prelude.Basic hiding+  (lookup, filter, foldr, foldl, foldl', null, map)++import Data.Functor.Identity (Identity (..))+import Data.Semigroup (Semigroup(stimes,(<>)),stimesIdempotentMonoid)+import Data.Functor.Classes++import Control.DeepSeq (NFData(rnf))+import qualified Data.Foldable as Foldable+import Data.Maybe (fromMaybe)++import GHC.Data.Word64Set.Internal (Key)+import qualified GHC.Data.Word64Set.Internal as Word64Set+import GHC.Utils.Containers.Internal.BitUtil+import GHC.Utils.Containers.Internal.StrictPair++import Data.Coerce+import Data.Data (Data(..), Constr, mkConstr, constrIndex, Fixity(Prefix),+                  DataType, mkDataType, gcast1)+import GHC.Exts (build)+import qualified GHC.Exts as GHCExts+import Text.Read+import qualified Control.Category as Category+import Data.Word+++-- A "Nat" is a 64 bit machine word (an unsigned Int64)+type Nat = Word64++natFromInt :: Key -> Nat+natFromInt = id+{-# INLINE natFromInt #-}++intFromNat :: Nat -> Key+intFromNat = id+{-# INLINE intFromNat #-}++{--------------------------------------------------------------------+  Types+--------------------------------------------------------------------}+++-- | A map of integers to values @a@.++-- See Note: Order of constructors+data Word64Map a = Bin {-# UNPACK #-} !Prefix+                    {-# UNPACK #-} !Mask+                    !(Word64Map a)+                    !(Word64Map a)+-- Fields:+--   prefix: The most significant bits shared by all keys in this Bin.+--   mask: The switching bit to determine if a key should follow the left+--         or right subtree of a 'Bin'.+-- Invariant: Nil is never found as a child of Bin.+-- Invariant: The Mask is a power of 2. It is the largest bit position at which+--            two keys of the map differ.+-- Invariant: Prefix is the common high-order bits that all elements share to+--            the left of the Mask bit.+-- Invariant: In (Bin prefix mask left right), left consists of the elements that+--            don't have the mask bit set; right is all the elements that do.+              | Tip {-# UNPACK #-} !Key a+              | Nil++type Prefix = Word64+type Mask   = Word64+++-- Some stuff from "Data.Word64Set.Internal", for 'restrictKeys' and+-- 'withoutKeys' to use.+type Word64SetPrefix = Word64+type Word64SetBitMap = Word64++bitmapOf :: Word64 -> Word64SetBitMap+bitmapOf x = shiftLL 1 (fromIntegral (x .&. Word64Set.suffixBitMask))+{-# INLINE bitmapOf #-}++{--------------------------------------------------------------------+  Operators+--------------------------------------------------------------------}++-- | \(O(\min(n,W))\). Find the value at a key.+-- Calls 'error' when the element can not be found.+--+-- > fromList [(5,'a'), (3,'b')] ! 1    Error: element not in the map+-- > fromList [(5,'a'), (3,'b')] ! 5 == 'a'++(!) :: Word64Map a -> Key -> a+(!) m k = find k m++-- | \(O(\min(n,W))\). Find the value at a key.+-- Returns 'Nothing' when the element can not be found.+--+-- > fromList [(5,'a'), (3,'b')] !? 1 == Nothing+-- > fromList [(5,'a'), (3,'b')] !? 5 == Just 'a'+--+-- @since 0.5.11++(!?) :: Word64Map a -> Key -> Maybe a+(!?) m k = lookup k m++-- | Same as 'difference'.+(\\) :: Word64Map a -> Word64Map b -> Word64Map a+m1 \\ m2 = difference m1 m2++infixl 9 !?,\\{-This comment teaches CPP correct behaviour -}++{--------------------------------------------------------------------+  Types+--------------------------------------------------------------------}++instance Monoid (Word64Map a) where+    mempty  = empty+    mconcat = unions+    mappend = (<>)++-- | @since 0.5.7+instance Semigroup (Word64Map a) where+    (<>)    = union+    stimes  = stimesIdempotentMonoid++-- | Folds in order of increasing key.+instance Foldable.Foldable Word64Map where+  fold = go+    where go Nil = mempty+          go (Tip _ v) = v+          go (Bin _ m l r)+            | m < 0     = go r `mappend` go l+            | otherwise = go l `mappend` go r+  {-# INLINABLE fold #-}+  foldr = foldr+  {-# INLINE foldr #-}+  foldl = foldl+  {-# INLINE foldl #-}+  foldMap f t = go t+    where go Nil = mempty+          go (Tip _ v) = f v+          go (Bin _ m l r)+            | m < 0     = go r `mappend` go l+            | otherwise = go l `mappend` go r+  {-# INLINE foldMap #-}+  foldl' = foldl'+  {-# INLINE foldl' #-}+  foldr' = foldr'+  {-# INLINE foldr' #-}+  length = size+  {-# INLINE length #-}+  null   = null+  {-# INLINE null #-}+  toList = elems -- NB: Foldable.toList /= Word64Map.toList+  {-# INLINE toList #-}+  elem = go+    where go !_ Nil = False+          go x (Tip _ y) = x == y+          go x (Bin _ _ l r) = go x l || go x r+  {-# INLINABLE elem #-}+  maximum = start+    where start Nil = error "Data.Foldable.maximum (for Data.Word64Map): empty map"+          start (Tip _ y) = y+          start (Bin _ m l r)+            | m < 0     = go (start r) l+            | otherwise = go (start l) r++          go !m Nil = m+          go m (Tip _ y) = max m y+          go m (Bin _ _ l r) = go (go m l) r+  {-# INLINABLE maximum #-}+  minimum = start+    where start Nil = error "Data.Foldable.minimum (for Data.Word64Map): empty map"+          start (Tip _ y) = y+          start (Bin _ m l r)+            | m < 0     = go (start r) l+            | otherwise = go (start l) r++          go !m Nil = m+          go m (Tip _ y) = min m y+          go m (Bin _ _ l r) = go (go m l) r+  {-# INLINABLE minimum #-}+  sum = foldl' (+) 0+  {-# INLINABLE sum #-}+  product = foldl' (*) 1+  {-# INLINABLE product #-}++-- | Traverses in order of increasing key.+instance Traversable Word64Map where+    traverse f = traverseWithKey (\_ -> f)+    {-# INLINE traverse #-}++instance NFData a => NFData (Word64Map a) where+    rnf Nil = ()+    rnf (Tip _ v) = rnf v+    rnf (Bin _ _ l r) = rnf l `seq` rnf r+++{--------------------------------------------------------------------+  A Data instance+--------------------------------------------------------------------}++-- This instance preserves data abstraction at the cost of inefficiency.+-- We provide limited reflection services for the sake of data abstraction.++instance Data a => Data (Word64Map a) where+  gfoldl f z im = z fromList `f` (toList im)+  toConstr _     = fromListConstr+  gunfold k z c  = case constrIndex c of+    1 -> k (z fromList)+    _ -> error "gunfold"+  dataTypeOf _   = intMapDataType+  dataCast1 f    = gcast1 f++fromListConstr :: Constr+fromListConstr = mkConstr intMapDataType "fromList" [] Prefix++intMapDataType :: DataType+intMapDataType = mkDataType "Data.Word64Map.Internal.Word64Map" [fromListConstr]+++{--------------------------------------------------------------------+  Query+--------------------------------------------------------------------}+-- | \(O(1)\). Is the map empty?+--+-- > Data.Word64Map.null (empty)           == True+-- > Data.Word64Map.null (singleton 1 'a') == False++null :: Word64Map a -> Bool+null Nil = True+null _   = False+{-# INLINE null #-}++-- | \(O(n)\). Number of elements in the map.+--+-- > size empty                                   == 0+-- > size (singleton 1 'a')                       == 1+-- > size (fromList([(1,'a'), (2,'c'), (3,'b')])) == 3+size :: Word64Map a -> Int+size = go 0+  where+    go !acc (Bin _ _ l r) = go (go acc l) r+    go acc (Tip _ _) = 1 + acc+    go acc Nil = acc++-- | \(O(\min(n,W))\). Is the key a member of the map?+--+-- > member 5 (fromList [(5,'a'), (3,'b')]) == True+-- > member 1 (fromList [(5,'a'), (3,'b')]) == False++-- See Note: Local 'go' functions and capturing]+member :: Key -> Word64Map a -> Bool+member !k = go+  where+    go (Bin p m l r) | nomatch k p m = False+                     | zero k m  = go l+                     | otherwise = go r+    go (Tip kx _) = k == kx+    go Nil = False++-- | \(O(\min(n,W))\). Is the key not a member of the map?+--+-- > notMember 5 (fromList [(5,'a'), (3,'b')]) == False+-- > notMember 1 (fromList [(5,'a'), (3,'b')]) == True++notMember :: Key -> Word64Map a -> Bool+notMember k m = not $ member k m++-- | \(O(\min(n,W))\). Lookup the value at a key in the map. See also 'Data.Map.lookup'.++-- See Note: Local 'go' functions and capturing+lookup :: Key -> Word64Map a -> Maybe a+lookup !k = go+  where+    go (Bin _p m l r) | zero k m  = go l+                      | otherwise = go r+    go (Tip kx x) | k == kx   = Just x+                  | otherwise = Nothing+    go Nil = Nothing++-- See Note: Local 'go' functions and capturing]+find :: Key -> Word64Map a -> a+find !k = go+  where+    go (Bin _p m l r) | zero k m  = go l+                      | otherwise = go r+    go (Tip kx x) | k == kx   = x+                  | otherwise = not_found+    go Nil = not_found++    not_found = error ("Word64Map.!: key " ++ show k ++ " is not an element of the map")++-- | \(O(\min(n,W))\). The expression @('findWithDefault' def k map)@+-- returns the value at key @k@ or returns @def@ when the key is not an+-- element of the map.+--+-- > findWithDefault 'x' 1 (fromList [(5,'a'), (3,'b')]) == 'x'+-- > findWithDefault 'x' 5 (fromList [(5,'a'), (3,'b')]) == 'a'++-- See Note: Local 'go' functions and capturing]+findWithDefault :: a -> Key -> Word64Map a -> a+findWithDefault def !k = go+  where+    go (Bin p m l r) | nomatch k p m = def+                     | zero k m  = go l+                     | otherwise = go r+    go (Tip kx x) | k == kx   = x+                  | otherwise = def+    go Nil = def++-- | \(O(\min(n,W))\). Find largest key smaller than the given one and return the+-- corresponding (key, value) pair.+--+-- > lookupLT 3 (fromList [(3,'a'), (5,'b')]) == Nothing+-- > lookupLT 4 (fromList [(3,'a'), (5,'b')]) == Just (3, 'a')++-- See Note: Local 'go' functions and capturing.+lookupLT :: Key -> Word64Map a -> Maybe (Key, a)+lookupLT !k t = case t of+    Bin _ m l r | m < 0 -> if k >= 0 then go r l else go Nil r+    _ -> go Nil t+  where+    go def (Bin p m l r)+      | nomatch k p m = if k < p then unsafeFindMax def else unsafeFindMax r+      | zero k m  = go def l+      | otherwise = go l r+    go def (Tip ky y)+      | k <= ky   = unsafeFindMax def+      | otherwise = Just (ky, y)+    go def Nil = unsafeFindMax def++-- | \(O(\min(n,W))\). Find smallest key greater than the given one and return the+-- corresponding (key, value) pair.+--+-- > lookupGT 4 (fromList [(3,'a'), (5,'b')]) == Just (5, 'b')+-- > lookupGT 5 (fromList [(3,'a'), (5,'b')]) == Nothing++-- See Note: Local 'go' functions and capturing.+lookupGT :: Key -> Word64Map a -> Maybe (Key, a)+lookupGT !k t = case t of+    Bin _ m l r | m < 0 -> if k >= 0 then go Nil l else go l r+    _ -> go Nil t+  where+    go def (Bin p m l r)+      | nomatch k p m = if k < p then unsafeFindMin l else unsafeFindMin def+      | zero k m  = go r l+      | otherwise = go def r+    go def (Tip ky y)+      | k >= ky   = unsafeFindMin def+      | otherwise = Just (ky, y)+    go def Nil = unsafeFindMin def++-- | \(O(\min(n,W))\). Find largest key smaller or equal to the given one and return+-- the corresponding (key, value) pair.+--+-- > lookupLE 2 (fromList [(3,'a'), (5,'b')]) == Nothing+-- > lookupLE 4 (fromList [(3,'a'), (5,'b')]) == Just (3, 'a')+-- > lookupLE 5 (fromList [(3,'a'), (5,'b')]) == Just (5, 'b')++-- See Note: Local 'go' functions and capturing.+lookupLE :: Key -> Word64Map a -> Maybe (Key, a)+lookupLE !k t = case t of+    Bin _ m l r | m < 0 -> if k >= 0 then go r l else go Nil r+    _ -> go Nil t+  where+    go def (Bin p m l r)+      | nomatch k p m = if k < p then unsafeFindMax def else unsafeFindMax r+      | zero k m  = go def l+      | otherwise = go l r+    go def (Tip ky y)+      | k < ky    = unsafeFindMax def+      | otherwise = Just (ky, y)+    go def Nil = unsafeFindMax def++-- | \(O(\min(n,W))\). Find smallest key greater or equal to the given one and return+-- the corresponding (key, value) pair.+--+-- > lookupGE 3 (fromList [(3,'a'), (5,'b')]) == Just (3, 'a')+-- > lookupGE 4 (fromList [(3,'a'), (5,'b')]) == Just (5, 'b')+-- > lookupGE 6 (fromList [(3,'a'), (5,'b')]) == Nothing++-- See Note: Local 'go' functions and capturing.+lookupGE :: Key -> Word64Map a -> Maybe (Key, a)+lookupGE !k t = case t of+    Bin _ m l r | m < 0 -> if k >= 0 then go Nil l else go l r+    _ -> go Nil t+  where+    go def (Bin p m l r)+      | nomatch k p m = if k < p then unsafeFindMin l else unsafeFindMin def+      | zero k m  = go r l+      | otherwise = go def r+    go def (Tip ky y)+      | k > ky    = unsafeFindMin def+      | otherwise = Just (ky, y)+    go def Nil = unsafeFindMin def+++-- Helper function for lookupGE and lookupGT. It assumes that if a Bin node is+-- given, it has m > 0.+unsafeFindMin :: Word64Map a -> Maybe (Key, a)+unsafeFindMin Nil = Nothing+unsafeFindMin (Tip ky y) = Just (ky, y)+unsafeFindMin (Bin _ _ l _) = unsafeFindMin l++-- Helper function for lookupLE and lookupLT. It assumes that if a Bin node is+-- given, it has m > 0.+unsafeFindMax :: Word64Map a -> Maybe (Key, a)+unsafeFindMax Nil = Nothing+unsafeFindMax (Tip ky y) = Just (ky, y)+unsafeFindMax (Bin _ _ _ r) = unsafeFindMax r++{--------------------------------------------------------------------+  Disjoint+--------------------------------------------------------------------}+-- | \(O(n+m)\). Check whether the key sets of two maps are disjoint+-- (i.e. their 'intersection' is empty).+--+-- > disjoint (fromList [(2,'a')]) (fromList [(1,()), (3,())])   == True+-- > disjoint (fromList [(2,'a')]) (fromList [(1,'a'), (2,'b')]) == False+-- > disjoint (fromList [])        (fromList [])                 == True+--+-- > disjoint a b == null (intersection a b)+--+-- @since 0.6.2.1+disjoint :: Word64Map a -> Word64Map b -> Bool+disjoint Nil _ = True+disjoint _ Nil = True+disjoint (Tip kx _) ys = notMember kx ys+disjoint xs (Tip ky _) = notMember ky xs+disjoint t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)+  | shorter m1 m2 = disjoint1+  | shorter m2 m1 = disjoint2+  | p1 == p2      = disjoint l1 l2 && disjoint r1 r2+  | otherwise     = True+  where+    disjoint1 | nomatch p2 p1 m1 = True+              | zero p2 m1       = disjoint l1 t2+              | otherwise        = disjoint r1 t2+    disjoint2 | nomatch p1 p2 m2 = True+              | zero p1 m2       = disjoint t1 l2+              | otherwise        = disjoint t1 r2++{--------------------------------------------------------------------+  Compose+--------------------------------------------------------------------}+-- | Relate the keys of one map to the values of+-- the other, by using the values of the former as keys for lookups+-- in the latter.+--+-- Complexity: \( O(n * \min(m,W)) \), where \(m\) is the size of the first argument+--+-- > compose (fromList [('a', "A"), ('b', "B")]) (fromList [(1,'a'),(2,'b'),(3,'z')]) = fromList [(1,"A"),(2,"B")]+--+-- @+-- ('compose' bc ab '!?') = (bc '!?') <=< (ab '!?')+-- @+--+-- __Note:__ Prior to v0.6.4, "Data.Word64Map.Strict" exposed a version of+-- 'compose' that forced the values of the output 'Word64Map'. This version does+-- not force these values.+--+-- @since 0.6.3.1+compose :: Word64Map c -> Word64Map Word64 -> Word64Map c+compose bc !ab+  | null bc = empty+  | otherwise = mapMaybe (bc !?) ab++{--------------------------------------------------------------------+  Construction+--------------------------------------------------------------------}+-- | \(O(1)\). The empty map.+--+-- > empty      == fromList []+-- > size empty == 0++empty :: Word64Map a+empty+  = Nil+{-# INLINE empty #-}++-- | \(O(1)\). A map of one element.+--+-- > singleton 1 'a'        == fromList [(1, 'a')]+-- > size (singleton 1 'a') == 1++singleton :: Key -> a -> Word64Map a+singleton k x+  = Tip k x+{-# INLINE singleton #-}++{--------------------------------------------------------------------+  Insert+--------------------------------------------------------------------}+-- | \(O(\min(n,W))\). Insert a new key\/value pair in the map.+-- If the key is already present in the map, the associated value is+-- replaced with the supplied value, i.e. 'insert' is equivalent to+-- @'insertWith' 'const'@.+--+-- > insert 5 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'x')]+-- > insert 7 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'a'), (7, 'x')]+-- > insert 5 'x' empty                         == singleton 5 'x'++insert :: Key -> a -> Word64Map a -> Word64Map a+insert !k x t@(Bin p m l r)+  | nomatch k p m = link k (Tip k x) p t+  | zero k m      = Bin p m (insert k x l) r+  | otherwise     = Bin p m l (insert k x r)+insert k x t@(Tip ky _)+  | k==ky         = Tip k x+  | otherwise     = link k (Tip k x) ky t+insert k x Nil = Tip k x++-- right-biased insertion, used by 'union'+-- | \(O(\min(n,W))\). Insert with a combining function.+-- @'insertWith' f key value mp@+-- will insert the pair (key, value) into @mp@ if key does+-- not exist in the map. If the key does exist, the function will+-- insert @f new_value old_value@.+--+-- > insertWith (++) 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "xxxa")]+-- > insertWith (++) 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")]+-- > insertWith (++) 5 "xxx" empty                         == singleton 5 "xxx"++insertWith :: (a -> a -> a) -> Key -> a -> Word64Map a -> Word64Map a+insertWith f k x t+  = insertWithKey (\_ x' y' -> f x' y') k x t++-- | \(O(\min(n,W))\). Insert with a combining function.+-- @'insertWithKey' f key value mp@+-- will insert the pair (key, value) into @mp@ if key does+-- not exist in the map. If the key does exist, the function will+-- insert @f key new_value old_value@.+--+-- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value+-- > insertWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:xxx|a")]+-- > insertWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")]+-- > insertWithKey f 5 "xxx" empty                         == singleton 5 "xxx"++insertWithKey :: (Key -> a -> a -> a) -> Key -> a -> Word64Map a -> Word64Map a+insertWithKey f !k x t@(Bin p m l r)+  | nomatch k p m = link k (Tip k x) p t+  | zero k m      = Bin p m (insertWithKey f k x l) r+  | otherwise     = Bin p m l (insertWithKey f k x r)+insertWithKey f k x t@(Tip ky y)+  | k == ky       = Tip k (f k x y)+  | otherwise     = link k (Tip k x) ky t+insertWithKey _ k x Nil = Tip k x++-- | \(O(\min(n,W))\). The expression (@'insertLookupWithKey' f k x map@)+-- is a pair where the first element is equal to (@'lookup' k map@)+-- and the second element equal to (@'insertWithKey' f k x map@).+--+-- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value+-- > insertLookupWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "5:xxx|a")])+-- > insertLookupWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == (Nothing,  fromList [(3, "b"), (5, "a"), (7, "xxx")])+-- > insertLookupWithKey f 5 "xxx" empty                         == (Nothing,  singleton 5 "xxx")+--+-- This is how to define @insertLookup@ using @insertLookupWithKey@:+--+-- > let insertLookup kx x t = insertLookupWithKey (\_ a _ -> a) kx x t+-- > insertLookup 5 "x" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "x")])+-- > insertLookup 7 "x" (fromList [(5,"a"), (3,"b")]) == (Nothing,  fromList [(3, "b"), (5, "a"), (7, "x")])++insertLookupWithKey :: (Key -> a -> a -> a) -> Key -> a -> Word64Map a -> (Maybe a, Word64Map a)+insertLookupWithKey f !k x t@(Bin p m l r)+  | nomatch k p m = (Nothing,link k (Tip k x) p t)+  | zero k m      = let (found,l') = insertLookupWithKey f k x l+                    in (found,Bin p m l' r)+  | otherwise     = let (found,r') = insertLookupWithKey f k x r+                    in (found,Bin p m l r')+insertLookupWithKey f k x t@(Tip ky y)+  | k == ky       = (Just y,Tip k (f k x y))+  | otherwise     = (Nothing,link k (Tip k x) ky t)+insertLookupWithKey _ k x Nil = (Nothing,Tip k x)+++{--------------------------------------------------------------------+  Deletion+--------------------------------------------------------------------}+-- | \(O(\min(n,W))\). Delete a key and its value from the map. When the key is not+-- a member of the map, the original map is returned.+--+-- > delete 5 (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"+-- > delete 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]+-- > delete 5 empty                         == empty++delete :: Key -> Word64Map a -> Word64Map a+delete !k t@(Bin p m l r)+  | nomatch k p m = t+  | zero k m      = binCheckLeft p m (delete k l) r+  | otherwise     = binCheckRight p m l (delete k r)+delete k t@(Tip ky _)+  | k == ky       = Nil+  | otherwise     = t+delete _k Nil = Nil++-- | \(O(\min(n,W))\). Adjust a value at a specific key. When the key is not+-- a member of the map, the original map is returned.+--+-- > adjust ("new " ++) 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")]+-- > adjust ("new " ++) 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]+-- > adjust ("new " ++) 7 empty                         == empty++adjust ::  (a -> a) -> Key -> Word64Map a -> Word64Map a+adjust f k m+  = adjustWithKey (\_ x -> f x) k m++-- | \(O(\min(n,W))\). Adjust a value at a specific key. When the key is not+-- a member of the map, the original map is returned.+--+-- > let f key x = (show key) ++ ":new " ++ x+-- > adjustWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")]+-- > adjustWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]+-- > adjustWithKey f 7 empty                         == empty++adjustWithKey ::  (Key -> a -> a) -> Key -> Word64Map a -> Word64Map a+adjustWithKey f !k (Bin p m l r)+  | zero k m      = Bin p m (adjustWithKey f k l) r+  | otherwise     = Bin p m l (adjustWithKey f k r)+adjustWithKey f k t@(Tip ky y)+  | k == ky       = Tip ky (f k y)+  | otherwise     = t+adjustWithKey _ _ Nil = Nil+++-- | \(O(\min(n,W))\). The expression (@'update' f k map@) updates the value @x@+-- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is+-- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@.+--+-- > let f x = if x == "a" then Just "new a" else Nothing+-- > update f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")]+-- > update f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]+-- > update f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"++update ::  (a -> Maybe a) -> Key -> Word64Map a -> Word64Map a+update f+  = updateWithKey (\_ x -> f x)++-- | \(O(\min(n,W))\). The expression (@'update' f k map@) updates the value @x@+-- at @k@ (if it is in the map). If (@f k x@) is 'Nothing', the element is+-- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@.+--+-- > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing+-- > updateWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")]+-- > updateWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]+-- > updateWithKey f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"++updateWithKey ::  (Key -> a -> Maybe a) -> Key -> Word64Map a -> Word64Map a+updateWithKey f !k (Bin p m l r)+  | zero k m      = binCheckLeft p m (updateWithKey f k l) r+  | otherwise     = binCheckRight p m l (updateWithKey f k r)+updateWithKey f k t@(Tip ky y)+  | k == ky       = case (f k y) of+                      Just y' -> Tip ky y'+                      Nothing -> Nil+  | otherwise     = t+updateWithKey _ _ Nil = Nil++-- | \(O(\min(n,W))\). Lookup and update.+-- The function returns original value, if it is updated.+-- This is different behavior than 'Data.Map.updateLookupWithKey'.+-- Returns the original key value if the map entry is deleted.+--+-- > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing+-- > updateLookupWithKey f 5 (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "5:new a")])+-- > updateLookupWithKey f 7 (fromList [(5,"a"), (3,"b")]) == (Nothing,  fromList [(3, "b"), (5, "a")])+-- > updateLookupWithKey f 3 (fromList [(5,"a"), (3,"b")]) == (Just "b", singleton 5 "a")++updateLookupWithKey ::  (Key -> a -> Maybe a) -> Key -> Word64Map a -> (Maybe a,Word64Map a)+updateLookupWithKey f !k (Bin p m l r)+  | zero k m      = let !(found,l') = updateLookupWithKey f k l+                    in (found,binCheckLeft p m l' r)+  | otherwise     = let !(found,r') = updateLookupWithKey f k r+                    in (found,binCheckRight p m l r')+updateLookupWithKey f k t@(Tip ky y)+  | k==ky         = case (f k y) of+                      Just y' -> (Just y,Tip ky y')+                      Nothing -> (Just y,Nil)+  | otherwise     = (Nothing,t)+updateLookupWithKey _ _ Nil = (Nothing,Nil)++++-- | \(O(\min(n,W))\). The expression (@'alter' f k map@) alters the value @x@ at @k@, or absence thereof.+-- 'alter' can be used to insert, delete, or update a value in an 'Word64Map'.+-- In short : @'lookup' k ('alter' f k m) = f ('lookup' k m)@.+alter :: (Maybe a -> Maybe a) -> Key -> Word64Map a -> Word64Map a+alter f !k t@(Bin p m l r)+  | nomatch k p m = case f Nothing of+                      Nothing -> t+                      Just x -> link k (Tip k x) p t+  | zero k m      = binCheckLeft p m (alter f k l) r+  | otherwise     = binCheckRight p m l (alter f k r)+alter f k t@(Tip ky y)+  | k==ky         = case f (Just y) of+                      Just x -> Tip ky x+                      Nothing -> Nil+  | otherwise     = case f Nothing of+                      Just x -> link k (Tip k x) ky t+                      Nothing -> Tip ky y+alter f k Nil     = case f Nothing of+                      Just x -> Tip k x+                      Nothing -> Nil++-- | \(O(\min(n,W))\). The expression (@'alterF' f k map@) alters the value @x@ at+-- @k@, or absence thereof.  'alterF' can be used to inspect, insert, delete,+-- or update a value in an 'Word64Map'.  In short : @'lookup' k <$> 'alterF' f k m = f+-- ('lookup' k m)@.+--+-- Example:+--+-- @+-- interactiveAlter :: Int -> Word64Map String -> IO (Word64Map String)+-- interactiveAlter k m = alterF f k m where+--   f Nothing = do+--      putStrLn $ show k +++--          " was not found in the map. Would you like to add it?"+--      getUserResponse1 :: IO (Maybe String)+--   f (Just old) = do+--      putStrLn $ "The key is currently bound to " ++ show old +++--          ". Would you like to change or delete it?"+--      getUserResponse2 :: IO (Maybe String)+-- @+--+-- 'alterF' is the most general operation for working with an individual+-- key that may or may not be in a given map.+--+-- Note: 'alterF' is a flipped version of the @at@ combinator from+-- @Control.Lens.At@.+--+-- @since 0.5.8++alterF :: Functor f+       => (Maybe a -> f (Maybe a)) -> Key -> Word64Map a -> f (Word64Map a)+-- This implementation was stolen from 'Control.Lens.At'.+alterF f k m = (<$> f mv) $ \fres ->+  case fres of+    Nothing -> maybe m (const (delete k m)) mv+    Just v' -> insert k v' m+  where mv = lookup k m++{--------------------------------------------------------------------+  Union+--------------------------------------------------------------------}+-- | The union of a list of maps.+--+-- > unions [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])]+-- >     == fromList [(3, "b"), (5, "a"), (7, "C")]+-- > unions [(fromList [(5, "A3"), (3, "B3")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "a"), (3, "b")])]+-- >     == fromList [(3, "B3"), (5, "A3"), (7, "C")]++unions :: Foldable f => f (Word64Map a) -> Word64Map a+unions xs+  = Foldable.foldl' union empty xs++-- | The union of a list of maps, with a combining operation.+--+-- > unionsWith (++) [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])]+-- >     == fromList [(3, "bB3"), (5, "aAA3"), (7, "C")]++unionsWith :: Foldable f => (a->a->a) -> f (Word64Map a) -> Word64Map a+unionsWith f ts+  = Foldable.foldl' (unionWith f) empty ts++-- | \(O(n+m)\). The (left-biased) union of two maps.+-- It prefers the first map when duplicate keys are encountered,+-- i.e. (@'union' == 'unionWith' 'const'@).+--+-- > union (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "a"), (7, "C")]++union :: Word64Map a -> Word64Map a -> Word64Map a+union m1 m2+  = mergeWithKey' Bin const id id m1 m2++-- | \(O(n+m)\). The union with a combining function.+--+-- > unionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "aA"), (7, "C")]++unionWith :: (a -> a -> a) -> Word64Map a -> Word64Map a -> Word64Map a+unionWith f m1 m2+  = unionWithKey (\_ x y -> f x y) m1 m2++-- | \(O(n+m)\). The union with a combining function.+--+-- > let f key left_value right_value = (show key) ++ ":" ++ left_value ++ "|" ++ right_value+-- > unionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "5:a|A"), (7, "C")]++unionWithKey :: (Key -> a -> a -> a) -> Word64Map a -> Word64Map a -> Word64Map a+unionWithKey f m1 m2+  = mergeWithKey' Bin (\(Tip k1 x1) (Tip _k2 x2) -> Tip k1 (f k1 x1 x2)) id id m1 m2++{--------------------------------------------------------------------+  Difference+--------------------------------------------------------------------}+-- | \(O(n+m)\). Difference between two maps (based on keys).+--+-- > difference (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 3 "b"++difference :: Word64Map a -> Word64Map b -> Word64Map a+difference m1 m2+  = mergeWithKey (\_ _ _ -> Nothing) id (const Nil) m1 m2++-- | \(O(n+m)\). Difference with a combining function.+--+-- > let f al ar = if al == "b" then Just (al ++ ":" ++ ar) else Nothing+-- > differenceWith f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (7, "C")])+-- >     == singleton 3 "b:B"++differenceWith :: (a -> b -> Maybe a) -> Word64Map a -> Word64Map b -> Word64Map a+differenceWith f m1 m2+  = differenceWithKey (\_ x y -> f x y) m1 m2++-- | \(O(n+m)\). Difference with a combining function. When two equal keys are+-- encountered, the combining function is applied to the key and both values.+-- If it returns 'Nothing', the element is discarded (proper set difference).+-- If it returns (@'Just' y@), the element is updated with a new value @y@.+--+-- > let f k al ar = if al == "b" then Just ((show k) ++ ":" ++ al ++ "|" ++ ar) else Nothing+-- > differenceWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (10, "C")])+-- >     == singleton 3 "3:b|B"++differenceWithKey :: (Key -> a -> b -> Maybe a) -> Word64Map a -> Word64Map b -> Word64Map a+differenceWithKey f m1 m2+  = mergeWithKey f id (const Nil) m1 m2+++-- TODO(wrengr): re-verify that asymptotic bound+-- | \(O(n+m)\). Remove all the keys in a given set from a map.+--+-- @+-- m \`withoutKeys\` s = 'filterWithKey' (\\k _ -> k ``Word64Set.notMember`` s) m+-- @+--+-- @since 0.5.8+withoutKeys :: Word64Map a -> Word64Set.Word64Set -> Word64Map a+withoutKeys t1@(Bin p1 m1 l1 r1) t2@(Word64Set.Bin p2 m2 l2 r2)+    | shorter m1 m2  = difference1+    | shorter m2 m1  = difference2+    | p1 == p2       = bin p1 m1 (withoutKeys l1 l2) (withoutKeys r1 r2)+    | otherwise      = t1+    where+    difference1+        | nomatch p2 p1 m1  = t1+        | zero p2 m1        = binCheckLeft p1 m1 (withoutKeys l1 t2) r1+        | otherwise         = binCheckRight p1 m1 l1 (withoutKeys r1 t2)+    difference2+        | nomatch p1 p2 m2  = t1+        | zero p1 m2        = withoutKeys t1 l2+        | otherwise         = withoutKeys t1 r2+withoutKeys t1@(Bin p1 m1 _ _) (Word64Set.Tip p2 bm2) =+    let minbit = bitmapOf p1+        lt_minbit = minbit - 1+        maxbit = bitmapOf (p1 .|. (m1 .|. (m1 - 1)))+        gt_maxbit = (-maxbit) `xor` maxbit+    -- TODO(wrengr): should we manually inline/unroll 'updatePrefix'+    -- and 'withoutBM' here, in order to avoid redundant case analyses?+    in updatePrefix p2 t1 $ withoutBM (bm2 .|. lt_minbit .|. gt_maxbit)+withoutKeys t1@(Bin _ _ _ _) Word64Set.Nil = t1+withoutKeys t1@(Tip k1 _) t2+    | k1 `Word64Set.member` t2 = Nil+    | otherwise = t1+withoutKeys Nil _ = Nil+++updatePrefix+    :: Word64SetPrefix -> Word64Map a -> (Word64Map a -> Word64Map a) -> Word64Map a+updatePrefix !kp t@(Bin p m l r) f+    | m .&. Word64Set.suffixBitMask /= 0 =+        if p .&. Word64Set.prefixBitMask == kp then f t else t+    | nomatch kp p m = t+    | zero kp m      = binCheckLeft p m (updatePrefix kp l f) r+    | otherwise      = binCheckRight p m l (updatePrefix kp r f)+updatePrefix kp t@(Tip kx _) f+    | kx .&. Word64Set.prefixBitMask == kp = f t+    | otherwise = t+updatePrefix _ Nil _ = Nil+++withoutBM :: Word64SetBitMap -> Word64Map a -> Word64Map a+withoutBM 0 t = t+withoutBM bm (Bin p m l r) =+    let leftBits = bitmapOf (p .|. m) - 1+        bmL = bm .&. leftBits+        bmR = bm `xor` bmL -- = (bm .&. complement leftBits)+    in  bin p m (withoutBM bmL l) (withoutBM bmR r)+withoutBM bm t@(Tip k _)+    -- TODO(wrengr): need we manually inline 'Word64Set.Member' here?+    | k `Word64Set.member` Word64Set.Tip (k .&. Word64Set.prefixBitMask) bm = Nil+    | otherwise = t+withoutBM _ Nil = Nil+++{--------------------------------------------------------------------+  Intersection+--------------------------------------------------------------------}+-- | \(O(n+m)\). The (left-biased) intersection of two maps (based on keys).+--+-- > intersection (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "a"++intersection :: Word64Map a -> Word64Map b -> Word64Map a+intersection m1 m2+  = mergeWithKey' bin const (const Nil) (const Nil) m1 m2+++-- TODO(wrengr): re-verify that asymptotic bound+-- | \(O(n+m)\). The restriction of a map to the keys in a set.+--+-- @+-- m \`restrictKeys\` s = 'filterWithKey' (\\k _ -> k ``Word64Set.member`` s) m+-- @+--+-- @since 0.5.8+restrictKeys :: Word64Map a -> Word64Set.Word64Set -> Word64Map a+restrictKeys t1@(Bin p1 m1 l1 r1) t2@(Word64Set.Bin p2 m2 l2 r2)+    | shorter m1 m2  = intersection1+    | shorter m2 m1  = intersection2+    | p1 == p2       = bin p1 m1 (restrictKeys l1 l2) (restrictKeys r1 r2)+    | otherwise      = Nil+    where+    intersection1+        | nomatch p2 p1 m1  = Nil+        | zero p2 m1        = restrictKeys l1 t2+        | otherwise         = restrictKeys r1 t2+    intersection2+        | nomatch p1 p2 m2  = Nil+        | zero p1 m2        = restrictKeys t1 l2+        | otherwise         = restrictKeys t1 r2+restrictKeys t1@(Bin p1 m1 _ _) (Word64Set.Tip p2 bm2) =+    let minbit = bitmapOf p1+        ge_minbit = complement (minbit - 1)+        maxbit = bitmapOf (p1 .|. (m1 .|. (m1 - 1)))+        le_maxbit = maxbit .|. (maxbit - 1)+    -- TODO(wrengr): should we manually inline/unroll 'lookupPrefix'+    -- and 'restrictBM' here, in order to avoid redundant case analyses?+    in restrictBM (bm2 .&. ge_minbit .&. le_maxbit) (lookupPrefix p2 t1)+restrictKeys (Bin _ _ _ _) Word64Set.Nil = Nil+restrictKeys t1@(Tip k1 _) t2+    | k1 `Word64Set.member` t2 = t1+    | otherwise = Nil+restrictKeys Nil _ = Nil+++-- | \(O(\min(n,W))\). Restrict to the sub-map with all keys matching+-- a key prefix.+lookupPrefix :: Word64SetPrefix -> Word64Map a -> Word64Map a+lookupPrefix !kp t@(Bin p m l r)+    | m .&. Word64Set.suffixBitMask /= 0 =+        if p .&. Word64Set.prefixBitMask == kp then t else Nil+    | nomatch kp p m = Nil+    | zero kp m      = lookupPrefix kp l+    | otherwise      = lookupPrefix kp r+lookupPrefix kp t@(Tip kx _)+    | (kx .&. Word64Set.prefixBitMask) == kp = t+    | otherwise = Nil+lookupPrefix _ Nil = Nil+++restrictBM :: Word64SetBitMap -> Word64Map a -> Word64Map a+restrictBM 0 _ = Nil+restrictBM bm (Bin p m l r) =+    let leftBits = bitmapOf (p .|. m) - 1+        bmL = bm .&. leftBits+        bmR = bm `xor` bmL -- = (bm .&. complement leftBits)+    in  bin p m (restrictBM bmL l) (restrictBM bmR r)+restrictBM bm t@(Tip k _)+    -- TODO(wrengr): need we manually inline 'Word64Set.Member' here?+    | k `Word64Set.member` Word64Set.Tip (k .&. Word64Set.prefixBitMask) bm = t+    | otherwise = Nil+restrictBM _ Nil = Nil+++-- | \(O(n+m)\). The intersection with a combining function.+--+-- > intersectionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "aA"++intersectionWith :: (a -> b -> c) -> Word64Map a -> Word64Map b -> Word64Map c+intersectionWith f m1 m2+  = intersectionWithKey (\_ x y -> f x y) m1 m2++-- | \(O(n+m)\). The intersection with a combining function.+--+-- > let f k al ar = (show k) ++ ":" ++ al ++ "|" ++ ar+-- > intersectionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "5:a|A"++intersectionWithKey :: (Key -> a -> b -> c) -> Word64Map a -> Word64Map b -> Word64Map c+intersectionWithKey f m1 m2+  = mergeWithKey' bin (\(Tip k1 x1) (Tip _k2 x2) -> Tip k1 (f k1 x1 x2)) (const Nil) (const Nil) m1 m2++{--------------------------------------------------------------------+  MergeWithKey+--------------------------------------------------------------------}++-- | \(O(n+m)\). A high-performance universal combining function. Using+-- 'mergeWithKey', all combining functions can be defined without any loss of+-- efficiency (with exception of 'union', 'difference' and 'intersection',+-- where sharing of some nodes is lost with 'mergeWithKey').+--+-- Please make sure you know what is going on when using 'mergeWithKey',+-- otherwise you can be surprised by unexpected code growth or even+-- corruption of the data structure.+--+-- When 'mergeWithKey' is given three arguments, it is inlined to the call+-- site. You should therefore use 'mergeWithKey' only to define your custom+-- combining functions. For example, you could define 'unionWithKey',+-- 'differenceWithKey' and 'intersectionWithKey' as+--+-- > myUnionWithKey f m1 m2 = mergeWithKey (\k x1 x2 -> Just (f k x1 x2)) id id m1 m2+-- > myDifferenceWithKey f m1 m2 = mergeWithKey f id (const empty) m1 m2+-- > myIntersectionWithKey f m1 m2 = mergeWithKey (\k x1 x2 -> Just (f k x1 x2)) (const empty) (const empty) m1 m2+--+-- When calling @'mergeWithKey' combine only1 only2@, a function combining two+-- 'Word64Map's is created, such that+--+-- * if a key is present in both maps, it is passed with both corresponding+--   values to the @combine@ function. Depending on the result, the key is either+--   present in the result with specified value, or is left out;+--+-- * a nonempty subtree present only in the first map is passed to @only1@ and+--   the output is added to the result;+--+-- * a nonempty subtree present only in the second map is passed to @only2@ and+--   the output is added to the result.+--+-- The @only1@ and @only2@ methods /must return a map with a subset (possibly empty) of the keys of the given map/.+-- The values can be modified arbitrarily. Most common variants of @only1@ and+-- @only2@ are 'id' and @'const' 'empty'@, but for example @'map' f@ or+-- @'filterWithKey' f@ could be used for any @f@.++mergeWithKey :: (Key -> a -> b -> Maybe c) -> (Word64Map a -> Word64Map c) -> (Word64Map b -> Word64Map c)+             -> Word64Map a -> Word64Map b -> Word64Map c+mergeWithKey f g1 g2 = mergeWithKey' bin combine g1 g2+  where -- We use the lambda form to avoid non-exhaustive pattern matches warning.+        combine = \(Tip k1 x1) (Tip _k2 x2) ->+          case f k1 x1 x2 of+            Nothing -> Nil+            Just x -> Tip k1 x+        {-# INLINE combine #-}+{-# INLINE mergeWithKey #-}++-- Slightly more general version of mergeWithKey. It differs in the following:+--+-- * the combining function operates on maps instead of keys and values. The+--   reason is to enable sharing in union, difference and intersection.+--+-- * mergeWithKey' is given an equivalent of bin. The reason is that in union*,+--   Bin constructor can be used, because we know both subtrees are nonempty.++mergeWithKey' :: (Prefix -> Mask -> Word64Map c -> Word64Map c -> Word64Map c)+              -> (Word64Map a -> Word64Map b -> Word64Map c) -> (Word64Map a -> Word64Map c) -> (Word64Map b -> Word64Map c)+              -> Word64Map a -> Word64Map b -> Word64Map c+mergeWithKey' bin' f g1 g2 = go+  where+    go t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)+      | shorter m1 m2  = merge1+      | shorter m2 m1  = merge2+      | p1 == p2       = bin' p1 m1 (go l1 l2) (go r1 r2)+      | otherwise      = maybe_link p1 (g1 t1) p2 (g2 t2)+      where+        merge1 | nomatch p2 p1 m1  = maybe_link p1 (g1 t1) p2 (g2 t2)+               | zero p2 m1        = bin' p1 m1 (go l1 t2) (g1 r1)+               | otherwise         = bin' p1 m1 (g1 l1) (go r1 t2)+        merge2 | nomatch p1 p2 m2  = maybe_link p1 (g1 t1) p2 (g2 t2)+               | zero p1 m2        = bin' p2 m2 (go t1 l2) (g2 r2)+               | otherwise         = bin' p2 m2 (g2 l2) (go t1 r2)++    go t1'@(Bin _ _ _ _) t2'@(Tip k2' _) = merge0 t2' k2' t1'+      where+        merge0 t2 k2 t1@(Bin p1 m1 l1 r1)+          | nomatch k2 p1 m1 = maybe_link p1 (g1 t1) k2 (g2 t2)+          | zero k2 m1 = bin' p1 m1 (merge0 t2 k2 l1) (g1 r1)+          | otherwise  = bin' p1 m1 (g1 l1) (merge0 t2 k2 r1)+        merge0 t2 k2 t1@(Tip k1 _)+          | k1 == k2 = f t1 t2+          | otherwise = maybe_link k1 (g1 t1) k2 (g2 t2)+        merge0 t2 _  Nil = g2 t2++    go t1@(Bin _ _ _ _) Nil = g1 t1++    go t1'@(Tip k1' _) t2' = merge0 t1' k1' t2'+      where+        merge0 t1 k1 t2@(Bin p2 m2 l2 r2)+          | nomatch k1 p2 m2 = maybe_link k1 (g1 t1) p2 (g2 t2)+          | zero k1 m2 = bin' p2 m2 (merge0 t1 k1 l2) (g2 r2)+          | otherwise  = bin' p2 m2 (g2 l2) (merge0 t1 k1 r2)+        merge0 t1 k1 t2@(Tip k2 _)+          | k1 == k2 = f t1 t2+          | otherwise = maybe_link k1 (g1 t1) k2 (g2 t2)+        merge0 t1 _  Nil = g1 t1++    go Nil t2 = g2 t2++    maybe_link _ Nil _ t2 = t2+    maybe_link _ t1 _ Nil = t1+    maybe_link p1 t1 p2 t2 = link p1 t1 p2 t2+    {-# INLINE maybe_link #-}+{-# INLINE mergeWithKey' #-}+++{--------------------------------------------------------------------+  mergeA+--------------------------------------------------------------------}++-- | A tactic for dealing with keys present in one map but not the+-- other in 'merge' or 'mergeA'.+--+-- A tactic of type @WhenMissing f k x z@ is an abstract representation+-- of a function of type @Key -> x -> f (Maybe z)@.+--+-- @since 0.5.9++data WhenMissing f x y = WhenMissing+  { missingSubtree :: Word64Map x -> f (Word64Map y)+  , missingKey :: Key -> x -> f (Maybe y)}++-- | @since 0.5.9+instance (Applicative f, Monad f) => Functor (WhenMissing f x) where+  fmap = mapWhenMissing+  {-# INLINE fmap #-}+++-- | @since 0.5.9+instance (Applicative f, Monad f) => Category.Category (WhenMissing f)+  where+    id = preserveMissing+    f . g =+      traverseMaybeMissing $ \ k x -> do+        y <- missingKey g k x+        case y of+          Nothing -> pure Nothing+          Just q  -> missingKey f k q+    {-# INLINE id #-}+    {-# INLINE (.) #-}+++-- | Equivalent to @ReaderT k (ReaderT x (MaybeT f))@.+--+-- @since 0.5.9+instance (Applicative f, Monad f) => Applicative (WhenMissing f x) where+  pure x = mapMissing (\ _ _ -> x)+  f <*> g =+    traverseMaybeMissing $ \k x -> do+      res1 <- missingKey f k x+      case res1 of+        Nothing -> pure Nothing+        Just r  -> (pure $!) . fmap r =<< missingKey g k x+  {-# INLINE pure #-}+  {-# INLINE (<*>) #-}+++-- | Equivalent to @ReaderT k (ReaderT x (MaybeT f))@.+--+-- @since 0.5.9+instance (Applicative f, Monad f) => Monad (WhenMissing f x) where+  m >>= f =+    traverseMaybeMissing $ \k x -> do+      res1 <- missingKey m k x+      case res1 of+        Nothing -> pure Nothing+        Just r  -> missingKey (f r) k x+  {-# INLINE (>>=) #-}+++-- | Map covariantly over a @'WhenMissing' f x@.+--+-- @since 0.5.9+mapWhenMissing+  :: (Applicative f, Monad f)+  => (a -> b)+  -> WhenMissing f x a+  -> WhenMissing f x b+mapWhenMissing f t = WhenMissing+  { missingSubtree = \m -> missingSubtree t m >>= \m' -> pure $! fmap f m'+  , missingKey     = \k x -> missingKey t k x >>= \q -> (pure $! fmap f q) }+{-# INLINE mapWhenMissing #-}+++-- | Map covariantly over a @'WhenMissing' f x@, using only a+-- 'Functor f' constraint.+mapGentlyWhenMissing+  :: Functor f+  => (a -> b)+  -> WhenMissing f x a+  -> WhenMissing f x b+mapGentlyWhenMissing f t = WhenMissing+  { missingSubtree = \m -> fmap f <$> missingSubtree t m+  , missingKey     = \k x -> fmap f <$> missingKey t k x }+{-# INLINE mapGentlyWhenMissing #-}+++-- | Map covariantly over a @'WhenMatched' f k x@, using only a+-- 'Functor f' constraint.+mapGentlyWhenMatched+  :: Functor f+  => (a -> b)+  -> WhenMatched f x y a+  -> WhenMatched f x y b+mapGentlyWhenMatched f t =+  zipWithMaybeAMatched $ \k x y -> fmap f <$> runWhenMatched t k x y+{-# INLINE mapGentlyWhenMatched #-}+++-- | Map contravariantly over a @'WhenMissing' f _ x@.+--+-- @since 0.5.9+lmapWhenMissing :: (b -> a) -> WhenMissing f a x -> WhenMissing f b x+lmapWhenMissing f t = WhenMissing+  { missingSubtree = \m -> missingSubtree t (fmap f m)+  , missingKey     = \k x -> missingKey t k (f x) }+{-# INLINE lmapWhenMissing #-}+++-- | Map contravariantly over a @'WhenMatched' f _ y z@.+--+-- @since 0.5.9+contramapFirstWhenMatched+  :: (b -> a)+  -> WhenMatched f a y z+  -> WhenMatched f b y z+contramapFirstWhenMatched f t =+  WhenMatched $ \k x y -> runWhenMatched t k (f x) y+{-# INLINE contramapFirstWhenMatched #-}+++-- | Map contravariantly over a @'WhenMatched' f x _ z@.+--+-- @since 0.5.9+contramapSecondWhenMatched+  :: (b -> a)+  -> WhenMatched f x a z+  -> WhenMatched f x b z+contramapSecondWhenMatched f t =+  WhenMatched $ \k x y -> runWhenMatched t k x (f y)+{-# INLINE contramapSecondWhenMatched #-}+++-- | A tactic for dealing with keys present in one map but not the+-- other in 'merge'.+--+-- A tactic of type @SimpleWhenMissing x z@ is an abstract+-- representation of a function of type @Key -> x -> Maybe z@.+--+-- @since 0.5.9+type SimpleWhenMissing = WhenMissing Identity+++-- | A tactic for dealing with keys present in both maps in 'merge'+-- or 'mergeA'.+--+-- A tactic of type @WhenMatched f x y z@ is an abstract representation+-- of a function of type @Key -> x -> y -> f (Maybe z)@.+--+-- @since 0.5.9+newtype WhenMatched f x y z = WhenMatched+  { matchedKey :: Key -> x -> y -> f (Maybe z) }+++-- | Along with zipWithMaybeAMatched, witnesses the isomorphism+-- between @WhenMatched f x y z@ and @Key -> x -> y -> f (Maybe z)@.+--+-- @since 0.5.9+runWhenMatched :: WhenMatched f x y z -> Key -> x -> y -> f (Maybe z)+runWhenMatched = matchedKey+{-# INLINE runWhenMatched #-}+++-- | Along with traverseMaybeMissing, witnesses the isomorphism+-- between @WhenMissing f x y@ and @Key -> x -> f (Maybe y)@.+--+-- @since 0.5.9+runWhenMissing :: WhenMissing f x y -> Key-> x -> f (Maybe y)+runWhenMissing = missingKey+{-# INLINE runWhenMissing #-}+++-- | @since 0.5.9+instance Functor f => Functor (WhenMatched f x y) where+  fmap = mapWhenMatched+  {-# INLINE fmap #-}+++-- | @since 0.5.9+instance (Monad f, Applicative f) => Category.Category (WhenMatched f x)+  where+    id = zipWithMatched (\_ _ y -> y)+    f . g =+      zipWithMaybeAMatched $ \k x y -> do+        res <- runWhenMatched g k x y+        case res of+          Nothing -> pure Nothing+          Just r  -> runWhenMatched f k x r+    {-# INLINE id #-}+    {-# INLINE (.) #-}+++-- | Equivalent to @ReaderT Key (ReaderT x (ReaderT y (MaybeT f)))@+--+-- @since 0.5.9+instance (Monad f, Applicative f) => Applicative (WhenMatched f x y) where+  pure x = zipWithMatched (\_ _ _ -> x)+  fs <*> xs =+    zipWithMaybeAMatched $ \k x y -> do+      res <- runWhenMatched fs k x y+      case res of+        Nothing -> pure Nothing+        Just r  -> (pure $!) . fmap r =<< runWhenMatched xs k x y+  {-# INLINE pure #-}+  {-# INLINE (<*>) #-}+++-- | Equivalent to @ReaderT Key (ReaderT x (ReaderT y (MaybeT f)))@+--+-- @since 0.5.9+instance (Monad f, Applicative f) => Monad (WhenMatched f x y) where+  m >>= f =+    zipWithMaybeAMatched $ \k x y -> do+      res <- runWhenMatched m k x y+      case res of+        Nothing -> pure Nothing+        Just r  -> runWhenMatched (f r) k x y+  {-# INLINE (>>=) #-}+++-- | Map covariantly over a @'WhenMatched' f x y@.+--+-- @since 0.5.9+mapWhenMatched+  :: Functor f+  => (a -> b)+  -> WhenMatched f x y a+  -> WhenMatched f x y b+mapWhenMatched f (WhenMatched g) =+  WhenMatched $ \k x y -> fmap (fmap f) (g k x y)+{-# INLINE mapWhenMatched #-}+++-- | A tactic for dealing with keys present in both maps in 'merge'.+--+-- A tactic of type @SimpleWhenMatched x y z@ is an abstract+-- representation of a function of type @Key -> x -> y -> Maybe z@.+--+-- @since 0.5.9+type SimpleWhenMatched = WhenMatched Identity+++-- | When a key is found in both maps, apply a function to the key+-- and values and use the result in the merged map.+--+-- > zipWithMatched+-- >   :: (Key -> x -> y -> z)+-- >   -> SimpleWhenMatched x y z+--+-- @since 0.5.9+zipWithMatched+  :: Applicative f+  => (Key -> x -> y -> z)+  -> WhenMatched f x y z+zipWithMatched f = WhenMatched $ \ k x y -> pure . Just $ f k x y+{-# INLINE zipWithMatched #-}+++-- | When a key is found in both maps, apply a function to the key+-- and values to produce an action and use its result in the merged+-- map.+--+-- @since 0.5.9+zipWithAMatched+  :: Applicative f+  => (Key -> x -> y -> f z)+  -> WhenMatched f x y z+zipWithAMatched f = WhenMatched $ \ k x y -> Just <$> f k x y+{-# INLINE zipWithAMatched #-}+++-- | When a key is found in both maps, apply a function to the key+-- and values and maybe use the result in the merged map.+--+-- > zipWithMaybeMatched+-- >   :: (Key -> x -> y -> Maybe z)+-- >   -> SimpleWhenMatched x y z+--+-- @since 0.5.9+zipWithMaybeMatched+  :: Applicative f+  => (Key -> x -> y -> Maybe z)+  -> WhenMatched f x y z+zipWithMaybeMatched f = WhenMatched $ \ k x y -> pure $ f k x y+{-# INLINE zipWithMaybeMatched #-}+++-- | When a key is found in both maps, apply a function to the key+-- and values, perform the resulting action, and maybe use the+-- result in the merged map.+--+-- This is the fundamental 'WhenMatched' tactic.+--+-- @since 0.5.9+zipWithMaybeAMatched+  :: (Key -> x -> y -> f (Maybe z))+  -> WhenMatched f x y z+zipWithMaybeAMatched f = WhenMatched $ \ k x y -> f k x y+{-# INLINE zipWithMaybeAMatched #-}+++-- | Drop all the entries whose keys are missing from the other+-- map.+--+-- > dropMissing :: SimpleWhenMissing x y+--+-- prop> dropMissing = mapMaybeMissing (\_ _ -> Nothing)+--+-- but @dropMissing@ is much faster.+--+-- @since 0.5.9+dropMissing :: Applicative f => WhenMissing f x y+dropMissing = WhenMissing+  { missingSubtree = const (pure Nil)+  , missingKey     = \_ _ -> pure Nothing }+{-# INLINE dropMissing #-}+++-- | Preserve, unchanged, the entries whose keys are missing from+-- the other map.+--+-- > preserveMissing :: SimpleWhenMissing x x+--+-- prop> preserveMissing = Merge.Lazy.mapMaybeMissing (\_ x -> Just x)+--+-- but @preserveMissing@ is much faster.+--+-- @since 0.5.9+preserveMissing :: Applicative f => WhenMissing f x x+preserveMissing = WhenMissing+  { missingSubtree = pure+  , missingKey     = \_ v -> pure (Just v) }+{-# INLINE preserveMissing #-}+++-- | Map over the entries whose keys are missing from the other map.+--+-- > mapMissing :: (k -> x -> y) -> SimpleWhenMissing x y+--+-- prop> mapMissing f = mapMaybeMissing (\k x -> Just $ f k x)+--+-- but @mapMissing@ is somewhat faster.+--+-- @since 0.5.9+mapMissing :: Applicative f => (Key -> x -> y) -> WhenMissing f x y+mapMissing f = WhenMissing+  { missingSubtree = \m -> pure $! mapWithKey f m+  , missingKey     = \k x -> pure $ Just (f k x) }+{-# INLINE mapMissing #-}+++-- | Map over the entries whose keys are missing from the other+-- map, optionally removing some. This is the most powerful+-- 'SimpleWhenMissing' tactic, but others are usually more efficient.+--+-- > mapMaybeMissing :: (Key -> x -> Maybe y) -> SimpleWhenMissing x y+--+-- prop> mapMaybeMissing f = traverseMaybeMissing (\k x -> pure (f k x))+--+-- but @mapMaybeMissing@ uses fewer unnecessary 'Applicative'+-- operations.+--+-- @since 0.5.9+mapMaybeMissing+  :: Applicative f => (Key -> x -> Maybe y) -> WhenMissing f x y+mapMaybeMissing f = WhenMissing+  { missingSubtree = \m -> pure $! mapMaybeWithKey f m+  , missingKey     = \k x -> pure $! f k x }+{-# INLINE mapMaybeMissing #-}+++-- | Filter the entries whose keys are missing from the other map.+--+-- > filterMissing :: (k -> x -> Bool) -> SimpleWhenMissing x x+--+-- prop> filterMissing f = Merge.Lazy.mapMaybeMissing $ \k x -> guard (f k x) *> Just x+--+-- but this should be a little faster.+--+-- @since 0.5.9+filterMissing+  :: Applicative f => (Key -> x -> Bool) -> WhenMissing f x x+filterMissing f = WhenMissing+  { missingSubtree = \m -> pure $! filterWithKey f m+  , missingKey     = \k x -> pure $! if f k x then Just x else Nothing }+{-# INLINE filterMissing #-}+++-- | Filter the entries whose keys are missing from the other map+-- using some 'Applicative' action.+--+-- > filterAMissing f = Merge.Lazy.traverseMaybeMissing $+-- >   \k x -> (\b -> guard b *> Just x) <$> f k x+--+-- but this should be a little faster.+--+-- @since 0.5.9+filterAMissing+  :: Applicative f => (Key -> x -> f Bool) -> WhenMissing f x x+filterAMissing f = WhenMissing+  { missingSubtree = \m -> filterWithKeyA f m+  , missingKey     = \k x -> bool Nothing (Just x) <$> f k x }+{-# INLINE filterAMissing #-}+++-- | \(O(n)\). Filter keys and values using an 'Applicative' predicate.+filterWithKeyA+  :: Applicative f => (Key -> a -> f Bool) -> Word64Map a -> f (Word64Map a)+filterWithKeyA _ Nil           = pure Nil+filterWithKeyA f t@(Tip k x)   = (\b -> if b then t else Nil) <$> f k x+filterWithKeyA f (Bin p m l r)+  | m < 0     = liftA2 (flip (bin p m)) (filterWithKeyA f r) (filterWithKeyA f l)+  | otherwise = liftA2 (bin p m) (filterWithKeyA f l) (filterWithKeyA f r)++-- | This wasn't in Data.Bool until 4.7.0, so we define it here+bool :: a -> a -> Bool -> a+bool f _ False = f+bool _ t True  = t+++-- | Traverse over the entries whose keys are missing from the other+-- map.+--+-- @since 0.5.9+traverseMissing+  :: Applicative f => (Key -> x -> f y) -> WhenMissing f x y+traverseMissing f = WhenMissing+  { missingSubtree = traverseWithKey f+  , missingKey = \k x -> Just <$> f k x }+{-# INLINE traverseMissing #-}+++-- | Traverse over the entries whose keys are missing from the other+-- map, optionally producing values to put in the result. This is+-- the most powerful 'WhenMissing' tactic, but others are usually+-- more efficient.+--+-- @since 0.5.9+traverseMaybeMissing+  :: Applicative f => (Key -> x -> f (Maybe y)) -> WhenMissing f x y+traverseMaybeMissing f = WhenMissing+  { missingSubtree = traverseMaybeWithKey f+  , missingKey = f }+{-# INLINE traverseMaybeMissing #-}+++-- | \(O(n)\). Traverse keys\/values and collect the 'Just' results.+--+-- @since 0.6.4+traverseMaybeWithKey+  :: Applicative f => (Key -> a -> f (Maybe b)) -> Word64Map a -> f (Word64Map b)+traverseMaybeWithKey f = go+    where+    go Nil           = pure Nil+    go (Tip k x)     = maybe Nil (Tip k) <$> f k x+    go (Bin p m l r)+      | m < 0     = liftA2 (flip (bin p m)) (go r) (go l)+      | otherwise = liftA2 (bin p m) (go l) (go r)+++-- | Merge two maps.+--+-- 'merge' takes two 'WhenMissing' tactics, a 'WhenMatched' tactic+-- and two maps. It uses the tactics to merge the maps. Its behavior+-- is best understood via its fundamental tactics, 'mapMaybeMissing'+-- and 'zipWithMaybeMatched'.+--+-- Consider+--+-- @+-- merge (mapMaybeMissing g1)+--              (mapMaybeMissing g2)+--              (zipWithMaybeMatched f)+--              m1 m2+-- @+--+-- Take, for example,+--+-- @+-- m1 = [(0, \'a\'), (1, \'b\'), (3, \'c\'), (4, \'d\')]+-- m2 = [(1, "one"), (2, "two"), (4, "three")]+-- @+--+-- 'merge' will first \"align\" these maps by key:+--+-- @+-- m1 = [(0, \'a\'), (1, \'b\'),               (3, \'c\'), (4, \'d\')]+-- m2 =           [(1, "one"), (2, "two"),           (4, "three")]+-- @+--+-- It will then pass the individual entries and pairs of entries+-- to @g1@, @g2@, or @f@ as appropriate:+--+-- @+-- maybes = [g1 0 \'a\', f 1 \'b\' "one", g2 2 "two", g1 3 \'c\', f 4 \'d\' "three"]+-- @+--+-- This produces a 'Maybe' for each key:+--+-- @+-- keys =     0        1          2           3        4+-- results = [Nothing, Just True, Just False, Nothing, Just True]+-- @+--+-- Finally, the @Just@ results are collected into a map:+--+-- @+-- return value = [(1, True), (2, False), (4, True)]+-- @+--+-- The other tactics below are optimizations or simplifications of+-- 'mapMaybeMissing' for special cases. Most importantly,+--+-- * 'dropMissing' drops all the keys.+-- * 'preserveMissing' leaves all the entries alone.+--+-- When 'merge' is given three arguments, it is inlined at the call+-- site. To prevent excessive inlining, you should typically use+-- 'merge' to define your custom combining functions.+--+--+-- Examples:+--+-- prop> unionWithKey f = merge preserveMissing preserveMissing (zipWithMatched f)+-- prop> intersectionWithKey f = merge dropMissing dropMissing (zipWithMatched f)+-- prop> differenceWith f = merge diffPreserve diffDrop f+-- prop> symmetricDifference = merge diffPreserve diffPreserve (\ _ _ _ -> Nothing)+-- prop> mapEachPiece f g h = merge (diffMapWithKey f) (diffMapWithKey g)+--+-- @since 0.5.9+merge+  :: SimpleWhenMissing a c -- ^ What to do with keys in @m1@ but not @m2@+  -> SimpleWhenMissing b c -- ^ What to do with keys in @m2@ but not @m1@+  -> SimpleWhenMatched a b c -- ^ What to do with keys in both @m1@ and @m2@+  -> Word64Map a -- ^ Map @m1@+  -> Word64Map b -- ^ Map @m2@+  -> Word64Map c+merge g1 g2 f m1 m2 =+  runIdentity $ mergeA g1 g2 f m1 m2+{-# INLINE merge #-}+++-- | An applicative version of 'merge'.+--+-- 'mergeA' takes two 'WhenMissing' tactics, a 'WhenMatched'+-- tactic and two maps. It uses the tactics to merge the maps.+-- Its behavior is best understood via its fundamental tactics,+-- 'traverseMaybeMissing' and 'zipWithMaybeAMatched'.+--+-- Consider+--+-- @+-- mergeA (traverseMaybeMissing g1)+--               (traverseMaybeMissing g2)+--               (zipWithMaybeAMatched f)+--               m1 m2+-- @+--+-- Take, for example,+--+-- @+-- m1 = [(0, \'a\'), (1, \'b\'), (3,\'c\'), (4, \'d\')]+-- m2 = [(1, "one"), (2, "two"), (4, "three")]+-- @+--+-- 'mergeA' will first \"align\" these maps by key:+--+-- @+-- m1 = [(0, \'a\'), (1, \'b\'),               (3, \'c\'), (4, \'d\')]+-- m2 =           [(1, "one"), (2, "two"),           (4, "three")]+-- @+--+-- It will then pass the individual entries and pairs of entries+-- to @g1@, @g2@, or @f@ as appropriate:+--+-- @+-- actions = [g1 0 \'a\', f 1 \'b\' "one", g2 2 "two", g1 3 \'c\', f 4 \'d\' "three"]+-- @+--+-- Next, it will perform the actions in the @actions@ list in order from+-- left to right.+--+-- @+-- keys =     0        1          2           3        4+-- results = [Nothing, Just True, Just False, Nothing, Just True]+-- @+--+-- Finally, the @Just@ results are collected into a map:+--+-- @+-- return value = [(1, True), (2, False), (4, True)]+-- @+--+-- The other tactics below are optimizations or simplifications of+-- 'traverseMaybeMissing' for special cases. Most importantly,+--+-- * 'dropMissing' drops all the keys.+-- * 'preserveMissing' leaves all the entries alone.+-- * 'mapMaybeMissing' does not use the 'Applicative' context.+--+-- When 'mergeA' is given three arguments, it is inlined at the call+-- site. To prevent excessive inlining, you should generally only use+-- 'mergeA' to define custom combining functions.+--+-- @since 0.5.9+mergeA+  :: (Applicative f)+  => WhenMissing f a c -- ^ What to do with keys in @m1@ but not @m2@+  -> WhenMissing f b c -- ^ What to do with keys in @m2@ but not @m1@+  -> WhenMatched f a b c -- ^ What to do with keys in both @m1@ and @m2@+  -> Word64Map a -- ^ Map @m1@+  -> Word64Map b -- ^ Map @m2@+  -> f (Word64Map c)+mergeA+    WhenMissing{missingSubtree = g1t, missingKey = g1k}+    WhenMissing{missingSubtree = g2t, missingKey = g2k}+    WhenMatched{matchedKey = f}+    = go+  where+    go t1  Nil = g1t t1+    go Nil t2  = g2t t2++    -- This case is already covered below.+    -- go (Tip k1 x1) (Tip k2 x2) = mergeTips k1 x1 k2 x2++    go (Tip k1 x1) t2' = merge2 t2'+      where+        merge2 t2@(Bin p2 m2 l2 r2)+          | nomatch k1 p2 m2 = linkA k1 (subsingletonBy g1k k1 x1) p2 (g2t t2)+          | zero k1 m2       = binA p2 m2 (merge2 l2) (g2t r2)+          | otherwise        = binA p2 m2 (g2t l2) (merge2 r2)+        merge2 (Tip k2 x2)   = mergeTips k1 x1 k2 x2+        merge2 Nil           = subsingletonBy g1k k1 x1++    go t1' (Tip k2 x2) = merge1 t1'+      where+        merge1 t1@(Bin p1 m1 l1 r1)+          | nomatch k2 p1 m1 = linkA p1 (g1t t1) k2 (subsingletonBy g2k k2 x2)+          | zero k2 m1       = binA p1 m1 (merge1 l1) (g1t r1)+          | otherwise        = binA p1 m1 (g1t l1) (merge1 r1)+        merge1 (Tip k1 x1)   = mergeTips k1 x1 k2 x2+        merge1 Nil           = subsingletonBy g2k k2 x2++    go t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)+      | shorter m1 m2  = merge1+      | shorter m2 m1  = merge2+      | p1 == p2       = binA p1 m1 (go l1 l2) (go r1 r2)+      | otherwise      = linkA p1 (g1t t1) p2 (g2t t2)+      where+        merge1 | nomatch p2 p1 m1  = linkA p1 (g1t t1) p2 (g2t t2)+               | zero p2 m1        = binA p1 m1 (go  l1 t2) (g1t r1)+               | otherwise         = binA p1 m1 (g1t l1)    (go  r1 t2)+        merge2 | nomatch p1 p2 m2  = linkA p1 (g1t t1) p2 (g2t t2)+               | zero p1 m2        = binA p2 m2 (go  t1 l2) (g2t    r2)+               | otherwise         = binA p2 m2 (g2t    l2) (go  t1 r2)++    subsingletonBy gk k x = maybe Nil (Tip k) <$> gk k x+    {-# INLINE subsingletonBy #-}++    mergeTips k1 x1 k2 x2+      | k1 == k2  = maybe Nil (Tip k1) <$> f k1 x1 x2+      | k1 <  k2  = liftA2 (subdoubleton k1 k2) (g1k k1 x1) (g2k k2 x2)+        {-+        = link_ k1 k2 <$> subsingletonBy g1k k1 x1 <*> subsingletonBy g2k k2 x2+        -}+      | otherwise = liftA2 (subdoubleton k2 k1) (g2k k2 x2) (g1k k1 x1)+    {-# INLINE mergeTips #-}++    subdoubleton _ _   Nothing Nothing     = Nil+    subdoubleton _ k2  Nothing (Just y2)   = Tip k2 y2+    subdoubleton k1 _  (Just y1) Nothing   = Tip k1 y1+    subdoubleton k1 k2 (Just y1) (Just y2) = link k1 (Tip k1 y1) k2 (Tip k2 y2)+    {-# INLINE subdoubleton #-}++    -- A variant of 'link_' which makes sure to execute side-effects+    -- in the right order.+    linkA+        :: Applicative f+        => Prefix -> f (Word64Map a)+        -> Prefix -> f (Word64Map a)+        -> f (Word64Map a)+    linkA p1 t1 p2 t2+      | zero p1 m = binA p m t1 t2+      | otherwise = binA p m t2 t1+      where+        m = branchMask p1 p2+        p = mask p1 m+    {-# INLINE linkA #-}++    -- A variant of 'bin' that ensures that effects for negative keys are executed+    -- first.+    binA+        :: Applicative f+        => Prefix+        -> Mask+        -> f (Word64Map a)+        -> f (Word64Map a)+        -> f (Word64Map a)+    binA p m a b+      | m < 0     = liftA2 (flip (bin p m)) b a+      | otherwise = liftA2       (bin p m)  a b+    {-# INLINE binA #-}+{-# INLINE mergeA #-}+++{--------------------------------------------------------------------+  Min\/Max+--------------------------------------------------------------------}++-- | \(O(\min(n,W))\). Update the value at the minimal key.+--+-- > updateMinWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"3:b"), (5,"a")]+-- > updateMinWithKey (\ _ _ -> Nothing)                     (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"++updateMinWithKey :: (Key -> a -> Maybe a) -> Word64Map a -> Word64Map a+updateMinWithKey f t =+  case t of Bin p m l r | m < 0 -> binCheckRight p m l (go f r)+            _ -> go f t+  where+    go f' (Bin p m l r) = binCheckLeft p m (go f' l) r+    go f' (Tip k y) = case f' k y of+                        Just y' -> Tip k y'+                        Nothing -> Nil+    go _ Nil = error "updateMinWithKey Nil"++-- | \(O(\min(n,W))\). Update the value at the maximal key.+--+-- > updateMaxWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"b"), (5,"5:a")]+-- > updateMaxWithKey (\ _ _ -> Nothing)                     (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"++updateMaxWithKey :: (Key -> a -> Maybe a) -> Word64Map a -> Word64Map a+updateMaxWithKey f t =+  case t of Bin p m l r | m < 0 -> binCheckLeft p m (go f l) r+            _ -> go f t+  where+    go f' (Bin p m l r) = binCheckRight p m l (go f' r)+    go f' (Tip k y) = case f' k y of+                        Just y' -> Tip k y'+                        Nothing -> Nil+    go _ Nil = error "updateMaxWithKey Nil"+++data View a = View {-# UNPACK #-} !Key a !(Word64Map a)++-- | \(O(\min(n,W))\). Retrieves the maximal (key,value) pair of the map, and+-- the map stripped of that element, or 'Nothing' if passed an empty map.+--+-- > maxViewWithKey (fromList [(5,"a"), (3,"b")]) == Just ((5,"a"), singleton 3 "b")+-- > maxViewWithKey empty == Nothing++maxViewWithKey :: Word64Map a -> Maybe ((Key, a), Word64Map a)+maxViewWithKey t = case t of+  Nil -> Nothing+  _ -> Just $ case maxViewWithKeySure t of+                View k v t' -> ((k, v), t')+{-# INLINE maxViewWithKey #-}++maxViewWithKeySure :: Word64Map a -> View a+maxViewWithKeySure t =+  case t of+    Nil -> error "maxViewWithKeySure Nil"+    Bin p m l r | m < 0 ->+      case go l of View k a l' -> View k a (binCheckLeft p m l' r)+    _ -> go t+  where+    go (Bin p m l r) =+        case go r of View k a r' -> View k a (binCheckRight p m l r')+    go (Tip k y) = View k y Nil+    go Nil = error "maxViewWithKey_go Nil"+-- See note on NOINLINE at minViewWithKeySure+{-# NOINLINE maxViewWithKeySure #-}++-- | \(O(\min(n,W))\). Retrieves the minimal (key,value) pair of the map, and+-- the map stripped of that element, or 'Nothing' if passed an empty map.+--+-- > minViewWithKey (fromList [(5,"a"), (3,"b")]) == Just ((3,"b"), singleton 5 "a")+-- > minViewWithKey empty == Nothing++minViewWithKey :: Word64Map a -> Maybe ((Key, a), Word64Map a)+minViewWithKey t =+  case t of+    Nil -> Nothing+    _ -> Just $ case minViewWithKeySure t of+                  View k v t' -> ((k, v), t')+-- We inline this to give GHC the best possible chance of+-- getting rid of the Maybe, pair, and Int constructors, as+-- well as a thunk under the Just. That is, we really want to+-- be certain this inlines!+{-# INLINE minViewWithKey #-}++minViewWithKeySure :: Word64Map a -> View a+minViewWithKeySure t =+  case t of+    Nil -> error "minViewWithKeySure Nil"+    Bin p m l r | m < 0 ->+      case go r of+        View k a r' -> View k a (binCheckRight p m l r')+    _ -> go t+  where+    go (Bin p m l r) =+        case go l of View k a l' -> View k a (binCheckLeft p m l' r)+    go (Tip k y) = View k y Nil+    go Nil = error "minViewWithKey_go Nil"+-- There's never anything significant to be gained by inlining+-- this. Sufficiently recent GHC versions will inline the wrapper+-- anyway, which should be good enough.+{-# NOINLINE minViewWithKeySure #-}++-- | \(O(\min(n,W))\). Update the value at the maximal key.+--+-- > updateMax (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "Xa")]+-- > updateMax (\ _ -> Nothing)         (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"++updateMax :: (a -> Maybe a) -> Word64Map a -> Word64Map a+updateMax f = updateMaxWithKey (const f)++-- | \(O(\min(n,W))\). Update the value at the minimal key.+--+-- > updateMin (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "Xb"), (5, "a")]+-- > updateMin (\ _ -> Nothing)         (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"++updateMin :: (a -> Maybe a) -> Word64Map a -> Word64Map a+updateMin f = updateMinWithKey (const f)++-- | \(O(\min(n,W))\). Retrieves the maximal key of the map, and the map+-- stripped of that element, or 'Nothing' if passed an empty map.+maxView :: Word64Map a -> Maybe (a, Word64Map a)+maxView t = fmap (\((_, x), t') -> (x, t')) (maxViewWithKey t)++-- | \(O(\min(n,W))\). Retrieves the minimal key of the map, and the map+-- stripped of that element, or 'Nothing' if passed an empty map.+minView :: Word64Map a -> Maybe (a, Word64Map a)+minView t = fmap (\((_, x), t') -> (x, t')) (minViewWithKey t)++-- | \(O(\min(n,W))\). Delete and find the maximal element.+-- This function throws an error if the map is empty. Use 'maxViewWithKey'+-- if the map may be empty.+deleteFindMax :: Word64Map a -> ((Key, a), Word64Map a)+deleteFindMax = fromMaybe (error "deleteFindMax: empty map has no maximal element") . maxViewWithKey++-- | \(O(\min(n,W))\). Delete and find the minimal element.+-- This function throws an error if the map is empty. Use 'minViewWithKey'+-- if the map may be empty.+deleteFindMin :: Word64Map a -> ((Key, a), Word64Map a)+deleteFindMin = fromMaybe (error "deleteFindMin: empty map has no minimal element") . minViewWithKey++-- | \(O(\min(n,W))\). The minimal key of the map. Returns 'Nothing' if the map is empty.+lookupMin :: Word64Map a -> Maybe (Key, a)+lookupMin Nil = Nothing+lookupMin (Tip k v) = Just (k,v)+lookupMin (Bin _ m l r)+  | m < 0     = go r+  | otherwise = go l+    where go (Tip k v)      = Just (k,v)+          go (Bin _ _ l' _) = go l'+          go Nil            = Nothing++-- | \(O(\min(n,W))\). The minimal key of the map. Calls 'error' if the map is empty.+-- Use 'minViewWithKey' if the map may be empty.+findMin :: Word64Map a -> (Key, a)+findMin t+  | Just r <- lookupMin t = r+  | otherwise = error "findMin: empty map has no minimal element"++-- | \(O(\min(n,W))\). The maximal key of the map. Returns 'Nothing' if the map is empty.+lookupMax :: Word64Map a -> Maybe (Key, a)+lookupMax Nil = Nothing+lookupMax (Tip k v) = Just (k,v)+lookupMax (Bin _ m l r)+  | m < 0     = go l+  | otherwise = go r+    where go (Tip k v)      = Just (k,v)+          go (Bin _ _ _ r') = go r'+          go Nil            = Nothing++-- | \(O(\min(n,W))\). The maximal key of the map. Calls 'error' if the map is empty.+-- Use 'maxViewWithKey' if the map may be empty.+findMax :: Word64Map a -> (Key, a)+findMax t+  | Just r <- lookupMax t = r+  | otherwise = error "findMax: empty map has no maximal element"++-- | \(O(\min(n,W))\). Delete the minimal key. Returns an empty map if the map is empty.+--+-- Note that this is a change of behaviour for consistency with 'Data.Map.Map' &#8211;+-- versions prior to 0.5 threw an error if the 'Word64Map' was already empty.+deleteMin :: Word64Map a -> Word64Map a+deleteMin = maybe Nil snd . minView++-- | \(O(\min(n,W))\). Delete the maximal key. Returns an empty map if the map is empty.+--+-- Note that this is a change of behaviour for consistency with 'Data.Map.Map' &#8211;+-- versions prior to 0.5 threw an error if the 'Word64Map' was already empty.+deleteMax :: Word64Map a -> Word64Map a+deleteMax = maybe Nil snd . maxView+++{--------------------------------------------------------------------+  Submap+--------------------------------------------------------------------}+-- | \(O(n+m)\). Is this a proper submap? (ie. a submap but not equal).+-- Defined as (@'isProperSubmapOf' = 'isProperSubmapOfBy' (==)@).+isProperSubmapOf :: Eq a => Word64Map a -> Word64Map a -> Bool+isProperSubmapOf m1 m2+  = isProperSubmapOfBy (==) m1 m2++{- | \(O(n+m)\). Is this a proper submap? (ie. a submap but not equal).+ The expression (@'isProperSubmapOfBy' f m1 m2@) returns 'True' when+ @keys m1@ and @keys m2@ are not equal,+ all keys in @m1@ are in @m2@, and when @f@ returns 'True' when+ applied to their respective values. For example, the following+ expressions are all 'True':++  > isProperSubmapOfBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)])+  > isProperSubmapOfBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)])++ But the following are all 'False':++  > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)])+  > isProperSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)])+  > isProperSubmapOfBy (<)  (fromList [(1,1)])       (fromList [(1,1),(2,2)])+-}+isProperSubmapOfBy :: (a -> b -> Bool) -> Word64Map a -> Word64Map b -> Bool+isProperSubmapOfBy predicate t1 t2+  = case submapCmp predicate t1 t2 of+      LT -> True+      _  -> False++submapCmp :: (a -> b -> Bool) -> Word64Map a -> Word64Map b -> Ordering+submapCmp predicate t1@(Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)+  | shorter m1 m2  = GT+  | shorter m2 m1  = submapCmpLt+  | p1 == p2       = submapCmpEq+  | otherwise      = GT  -- disjoint+  where+    submapCmpLt | nomatch p1 p2 m2  = GT+                | zero p1 m2        = submapCmp predicate t1 l2+                | otherwise         = submapCmp predicate t1 r2+    submapCmpEq = case (submapCmp predicate l1 l2, submapCmp predicate r1 r2) of+                    (GT,_ ) -> GT+                    (_ ,GT) -> GT+                    (EQ,EQ) -> EQ+                    _       -> LT++submapCmp _         (Bin _ _ _ _) _  = GT+submapCmp predicate (Tip kx x) (Tip ky y)+  | (kx == ky) && predicate x y = EQ+  | otherwise                   = GT  -- disjoint+submapCmp predicate (Tip k x) t+  = case lookup k t of+     Just y | predicate x y -> LT+     _                      -> GT -- disjoint+submapCmp _    Nil Nil = EQ+submapCmp _    Nil _   = LT++-- | \(O(n+m)\). Is this a submap?+-- Defined as (@'isSubmapOf' = 'isSubmapOfBy' (==)@).+isSubmapOf :: Eq a => Word64Map a -> Word64Map a -> Bool+isSubmapOf m1 m2+  = isSubmapOfBy (==) m1 m2++{- | \(O(n+m)\).+ The expression (@'isSubmapOfBy' f m1 m2@) returns 'True' if+ all keys in @m1@ are in @m2@, and when @f@ returns 'True' when+ applied to their respective values. For example, the following+ expressions are all 'True':++  > isSubmapOfBy (==) (fromList [(1,1)]) (fromList [(1,1),(2,2)])+  > isSubmapOfBy (<=) (fromList [(1,1)]) (fromList [(1,1),(2,2)])+  > isSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1),(2,2)])++ But the following are all 'False':++  > isSubmapOfBy (==) (fromList [(1,2)]) (fromList [(1,1),(2,2)])+  > isSubmapOfBy (<) (fromList [(1,1)]) (fromList [(1,1),(2,2)])+  > isSubmapOfBy (==) (fromList [(1,1),(2,2)]) (fromList [(1,1)])+-}+isSubmapOfBy :: (a -> b -> Bool) -> Word64Map a -> Word64Map b -> Bool+isSubmapOfBy predicate t1@(Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)+  | shorter m1 m2  = False+  | shorter m2 m1  = match p1 p2 m2 &&+                       if zero p1 m2+                       then isSubmapOfBy predicate t1 l2+                       else isSubmapOfBy predicate t1 r2+  | otherwise      = (p1==p2) && isSubmapOfBy predicate l1 l2 && isSubmapOfBy predicate r1 r2+isSubmapOfBy _         (Bin _ _ _ _) _ = False+isSubmapOfBy predicate (Tip k x) t     = case lookup k t of+                                         Just y  -> predicate x y+                                         Nothing -> False+isSubmapOfBy _         Nil _           = True++{--------------------------------------------------------------------+  Mapping+--------------------------------------------------------------------}+-- | \(O(n)\). Map a function over all values in the map.+--+-- > map (++ "x") (fromList [(5,"a"), (3,"b")]) == fromList [(3, "bx"), (5, "ax")]++map :: (a -> b) -> Word64Map a -> Word64Map b+map f = go+  where+    go (Bin p m l r) = Bin p m (go l) (go r)+    go (Tip k x)     = Tip k (f x)+    go Nil           = Nil++{-# NOINLINE [1] map #-}+{-# RULES+"map/map" forall f g xs . map f (map g xs) = map (f . g) xs+"map/coerce" map coerce = coerce+ #-}++-- | \(O(n)\). Map a function over all values in the map.+--+-- > let f key x = (show key) ++ ":" ++ x+-- > mapWithKey f (fromList [(5,"a"), (3,"b")]) == fromList [(3, "3:b"), (5, "5:a")]++mapWithKey :: (Key -> a -> b) -> Word64Map a -> Word64Map b+mapWithKey f t+  = case t of+      Bin p m l r -> Bin p m (mapWithKey f l) (mapWithKey f r)+      Tip k x     -> Tip k (f k x)+      Nil         -> Nil++{-# NOINLINE [1] mapWithKey #-}+{-# RULES+"mapWithKey/mapWithKey" forall f g xs . mapWithKey f (mapWithKey g xs) =+  mapWithKey (\k a -> f k (g k a)) xs+"mapWithKey/map" forall f g xs . mapWithKey f (map g xs) =+  mapWithKey (\k a -> f k (g a)) xs+"map/mapWithKey" forall f g xs . map f (mapWithKey g xs) =+  mapWithKey (\k a -> f (g k a)) xs+ #-}++-- | \(O(n)\).+-- @'traverseWithKey' f s == 'fromList' <$> 'traverse' (\(k, v) -> (,) k <$> f k v) ('toList' m)@+-- That is, behaves exactly like a regular 'traverse' except that the traversing+-- function also has access to the key associated with a value.+--+-- > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(1, 'a'), (5, 'e')]) == Just (fromList [(1, 'b'), (5, 'f')])+-- > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(2, 'c')])           == Nothing+traverseWithKey :: Applicative t => (Key -> a -> t b) -> Word64Map a -> t (Word64Map b)+traverseWithKey f = go+  where+    go Nil = pure Nil+    go (Tip k v) = Tip k <$> f k v+    go (Bin p m l r)+      | m < 0     = liftA2 (flip (Bin p m)) (go r) (go l)+      | otherwise = liftA2 (Bin p m) (go l) (go r)+{-# INLINE traverseWithKey #-}++-- | \(O(n)\). The function @'mapAccum'@ threads an accumulating+-- argument through the map in ascending order of keys.+--+-- > let f a b = (a ++ b, b ++ "X")+-- > mapAccum f "Everything: " (fromList [(5,"a"), (3,"b")]) == ("Everything: ba", fromList [(3, "bX"), (5, "aX")])++mapAccum :: (a -> b -> (a,c)) -> a -> Word64Map b -> (a,Word64Map c)+mapAccum f = mapAccumWithKey (\a' _ x -> f a' x)++-- | \(O(n)\). The function @'mapAccumWithKey'@ threads an accumulating+-- argument through the map in ascending order of keys.+--+-- > let f a k b = (a ++ " " ++ (show k) ++ "-" ++ b, b ++ "X")+-- > mapAccumWithKey f "Everything:" (fromList [(5,"a"), (3,"b")]) == ("Everything: 3-b 5-a", fromList [(3, "bX"), (5, "aX")])++mapAccumWithKey :: (a -> Key -> b -> (a,c)) -> a -> Word64Map b -> (a,Word64Map c)+mapAccumWithKey f a t+  = mapAccumL f a t++-- | \(O(n)\). The function @'mapAccumL'@ threads an accumulating+-- argument through the map in ascending order of keys.+mapAccumL :: (a -> Key -> b -> (a,c)) -> a -> Word64Map b -> (a,Word64Map c)+mapAccumL f a t+  = case t of+      Bin p m l r+        | m < 0 ->+            let (a1,r') = mapAccumL f a r+                (a2,l') = mapAccumL f a1 l+            in (a2,Bin p m l' r')+        | otherwise  ->+            let (a1,l') = mapAccumL f a l+                (a2,r') = mapAccumL f a1 r+            in (a2,Bin p m l' r')+      Tip k x     -> let (a',x') = f a k x in (a',Tip k x')+      Nil         -> (a,Nil)++-- | \(O(n)\). The function @'mapAccumRWithKey'@ threads an accumulating+-- argument through the map in descending order of keys.+mapAccumRWithKey :: (a -> Key -> b -> (a,c)) -> a -> Word64Map b -> (a,Word64Map c)+mapAccumRWithKey f a t+  = case t of+      Bin p m l r+        | m < 0 ->+            let (a1,l') = mapAccumRWithKey f a l+                (a2,r') = mapAccumRWithKey f a1 r+            in (a2,Bin p m l' r')+        | otherwise  ->+            let (a1,r') = mapAccumRWithKey f a r+                (a2,l') = mapAccumRWithKey f a1 l+            in (a2,Bin p m l' r')+      Tip k x     -> let (a',x') = f a k x in (a',Tip k x')+      Nil         -> (a,Nil)++-- | \(O(n \min(n,W))\).+-- @'mapKeys' f s@ is the map obtained by applying @f@ to each key of @s@.+--+-- The size of the result may be smaller if @f@ maps two or more distinct+-- keys to the same new key.  In this case the value at the greatest of the+-- original keys is retained.+--+-- > mapKeys (+ 1) (fromList [(5,"a"), (3,"b")])                        == fromList [(4, "b"), (6, "a")]+-- > mapKeys (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 1 "c"+-- > mapKeys (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 3 "c"++mapKeys :: (Key->Key) -> Word64Map a -> Word64Map a+mapKeys f = fromList . foldrWithKey (\k x xs -> (f k, x) : xs) []++-- | \(O(n \min(n,W))\).+-- @'mapKeysWith' c f s@ is the map obtained by applying @f@ to each key of @s@.+--+-- The size of the result may be smaller if @f@ maps two or more distinct+-- keys to the same new key.  In this case the associated values will be+-- combined using @c@.+--+-- > mapKeysWith (++) (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 1 "cdab"+-- > mapKeysWith (++) (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 3 "cdab"++mapKeysWith :: (a -> a -> a) -> (Key->Key) -> Word64Map a -> Word64Map a+mapKeysWith c f+  = fromListWith c . foldrWithKey (\k x xs -> (f k, x) : xs) []++-- | \(O(n \min(n,W))\).+-- @'mapKeysMonotonic' f s == 'mapKeys' f s@, but works only when @f@+-- is strictly monotonic.+-- That is, for any values @x@ and @y@, if @x@ < @y@ then @f x@ < @f y@.+-- /The precondition is not checked./+-- Semi-formally, we have:+--+-- > and [x < y ==> f x < f y | x <- ls, y <- ls]+-- >                     ==> mapKeysMonotonic f s == mapKeys f s+-- >     where ls = keys s+--+-- This means that @f@ maps distinct original keys to distinct resulting keys.+-- This function has slightly better performance than 'mapKeys'.+--+-- > mapKeysMonotonic (\ k -> k * 2) (fromList [(5,"a"), (3,"b")]) == fromList [(6, "b"), (10, "a")]++mapKeysMonotonic :: (Key->Key) -> Word64Map a -> Word64Map a+mapKeysMonotonic f+  = fromDistinctAscList . foldrWithKey (\k x xs -> (f k, x) : xs) []++{--------------------------------------------------------------------+  Filter+--------------------------------------------------------------------}+-- | \(O(n)\). Filter all values that satisfy some predicate.+--+-- > filter (> "a") (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"+-- > filter (> "x") (fromList [(5,"a"), (3,"b")]) == empty+-- > filter (< "a") (fromList [(5,"a"), (3,"b")]) == empty++filter :: (a -> Bool) -> Word64Map a -> Word64Map a+filter p m+  = filterWithKey (\_ x -> p x) m++-- | \(O(n)\). Filter all keys\/values that satisfy some predicate.+--+-- > filterWithKey (\k _ -> k > 4) (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"++filterWithKey :: (Key -> a -> Bool) -> Word64Map a -> Word64Map a+filterWithKey predicate = go+    where+    go Nil           = Nil+    go t@(Tip k x)   = if predicate k x then t else Nil+    go (Bin p m l r) = bin p m (go l) (go r)++-- | \(O(n)\). Partition the map according to some predicate. The first+-- map contains all elements that satisfy the predicate, the second all+-- elements that fail the predicate. See also 'split'.+--+-- > partition (> "a") (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", singleton 5 "a")+-- > partition (< "x") (fromList [(5,"a"), (3,"b")]) == (fromList [(3, "b"), (5, "a")], empty)+-- > partition (> "x") (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3, "b"), (5, "a")])++partition :: (a -> Bool) -> Word64Map a -> (Word64Map a,Word64Map a)+partition p m+  = partitionWithKey (\_ x -> p x) m++-- | \(O(n)\). Partition the map according to some predicate. The first+-- map contains all elements that satisfy the predicate, the second all+-- elements that fail the predicate. See also 'split'.+--+-- > partitionWithKey (\ k _ -> k > 3) (fromList [(5,"a"), (3,"b")]) == (singleton 5 "a", singleton 3 "b")+-- > partitionWithKey (\ k _ -> k < 7) (fromList [(5,"a"), (3,"b")]) == (fromList [(3, "b"), (5, "a")], empty)+-- > partitionWithKey (\ k _ -> k > 7) (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3, "b"), (5, "a")])++partitionWithKey :: (Key -> a -> Bool) -> Word64Map a -> (Word64Map a,Word64Map a)+partitionWithKey predicate0 t0 = toPair $ go predicate0 t0+  where+    go predicate t =+      case t of+        Bin p m l r ->+          let (l1 :*: l2) = go predicate l+              (r1 :*: r2) = go predicate r+          in bin p m l1 r1 :*: bin p m l2 r2+        Tip k x+          | predicate k x -> (t :*: Nil)+          | otherwise     -> (Nil :*: t)+        Nil -> (Nil :*: Nil)++-- | \(O(\min(n,W))\). Take while a predicate on the keys holds.+-- The user is responsible for ensuring that for all @Int@s, @j \< k ==\> p j \>= p k@.+-- See note at 'spanAntitone'.+--+-- @+-- takeWhileAntitone p = 'fromDistinctAscList' . 'Data.List.takeWhile' (p . fst) . 'toList'+-- takeWhileAntitone p = 'filterWithKey' (\\k _ -> p k)+-- @+--+-- @since 0.6.7+takeWhileAntitone :: (Key -> Bool) -> Word64Map a -> Word64Map a+takeWhileAntitone predicate t =+  case t of+    Bin p m l r+      | m < 0 ->+        if predicate 0 -- handle negative numbers.+        then bin p m (go predicate l) r+        else go predicate r+    _ -> go predicate t+  where+    go predicate' (Bin p m l r)+      | predicate' $! p+m = bin p m l (go predicate' r)+      | otherwise         = go predicate' l+    go predicate' t'@(Tip ky _)+      | predicate' ky = t'+      | otherwise     = Nil+    go _ Nil = Nil++-- | \(O(\min(n,W))\). Drop while a predicate on the keys holds.+-- The user is responsible for ensuring that for all @Int@s, @j \< k ==\> p j \>= p k@.+-- See note at 'spanAntitone'.+--+-- @+-- dropWhileAntitone p = 'fromDistinctAscList' . 'Data.List.dropWhile' (p . fst) . 'toList'+-- dropWhileAntitone p = 'filterWithKey' (\\k _ -> not (p k))+-- @+--+-- @since 0.6.7+dropWhileAntitone :: (Key -> Bool) -> Word64Map a -> Word64Map a+dropWhileAntitone predicate t =+  case t of+    Bin p m l r+      | m < 0 ->+        if predicate 0 -- handle negative numbers.+        then go predicate l+        else bin p m l (go predicate r)+    _ -> go predicate t+  where+    go predicate' (Bin p m l r)+      | predicate' $! p+m = go predicate' r+      | otherwise         = bin p m (go predicate' l) r+    go predicate' t'@(Tip ky _)+      | predicate' ky = Nil+      | otherwise     = t'+    go _ Nil = Nil++-- | \(O(\min(n,W))\). Divide a map at the point where a predicate on the keys stops holding.+-- The user is responsible for ensuring that for all @Int@s, @j \< k ==\> p j \>= p k@.+--+-- @+-- spanAntitone p xs = ('takeWhileAntitone' p xs, 'dropWhileAntitone' p xs)+-- spanAntitone p xs = 'partitionWithKey' (\\k _ -> p k) xs+-- @+--+-- Note: if @p@ is not actually antitone, then @spanAntitone@ will split the map+-- at some /unspecified/ point.+--+-- @since 0.6.7+spanAntitone :: (Key -> Bool) -> Word64Map a -> (Word64Map a, Word64Map a)+spanAntitone predicate t =+  case t of+    Bin p m l r+      | m < 0 ->+        if predicate 0 -- handle negative numbers.+        then+          case go predicate l of+            (lt :*: gt) ->+              let !lt' = bin p m lt r+              in (lt', gt)+        else+          case go predicate r of+            (lt :*: gt) ->+              let !gt' = bin p m l gt+              in (lt, gt')+    _ -> case go predicate t of+          (lt :*: gt) -> (lt, gt)+  where+    go predicate' (Bin p m l r)+      | predicate' $! p+m = case go predicate' r of (lt :*: gt) -> bin p m l lt :*: gt+      | otherwise         = case go predicate' l of (lt :*: gt) -> lt :*: bin p m gt r+    go predicate' t'@(Tip ky _)+      | predicate' ky = (t' :*: Nil)+      | otherwise     = (Nil :*: t')+    go _ Nil = (Nil :*: Nil)++-- | \(O(n)\). Map values and collect the 'Just' results.+--+-- > let f x = if x == "a" then Just "new a" else Nothing+-- > mapMaybe f (fromList [(5,"a"), (3,"b")]) == singleton 5 "new a"++mapMaybe :: (a -> Maybe b) -> Word64Map a -> Word64Map b+mapMaybe f = mapMaybeWithKey (\_ x -> f x)++-- | \(O(n)\). Map keys\/values and collect the 'Just' results.+--+-- > let f k _ = if k < 5 then Just ("key : " ++ (show k)) else Nothing+-- > mapMaybeWithKey f (fromList [(5,"a"), (3,"b")]) == singleton 3 "key : 3"++mapMaybeWithKey :: (Key -> a -> Maybe b) -> Word64Map a -> Word64Map b+mapMaybeWithKey f (Bin p m l r)+  = bin p m (mapMaybeWithKey f l) (mapMaybeWithKey f r)+mapMaybeWithKey f (Tip k x) = case f k x of+  Just y  -> Tip k y+  Nothing -> Nil+mapMaybeWithKey _ Nil = Nil++-- | \(O(n)\). Map values and separate the 'Left' and 'Right' results.+--+-- > let f a = if a < "c" then Left a else Right a+-- > mapEither f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])+-- >     == (fromList [(3,"b"), (5,"a")], fromList [(1,"x"), (7,"z")])+-- >+-- > mapEither (\ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])+-- >     == (empty, fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])++mapEither :: (a -> Either b c) -> Word64Map a -> (Word64Map b, Word64Map c)+mapEither f m+  = mapEitherWithKey (\_ x -> f x) m++-- | \(O(n)\). Map keys\/values and separate the 'Left' and 'Right' results.+--+-- > let f k a = if k < 5 then Left (k * 2) else Right (a ++ a)+-- > mapEitherWithKey f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])+-- >     == (fromList [(1,2), (3,6)], fromList [(5,"aa"), (7,"zz")])+-- >+-- > mapEitherWithKey (\_ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])+-- >     == (empty, fromList [(1,"x"), (3,"b"), (5,"a"), (7,"z")])++mapEitherWithKey :: (Key -> a -> Either b c) -> Word64Map a -> (Word64Map b, Word64Map c)+mapEitherWithKey f0 t0 = toPair $ go f0 t0+  where+    go f (Bin p m l r) =+      bin p m l1 r1 :*: bin p m l2 r2+      where+        (l1 :*: l2) = go f l+        (r1 :*: r2) = go f r+    go f (Tip k x) = case f k x of+      Left y  -> (Tip k y :*: Nil)+      Right z -> (Nil :*: Tip k z)+    go _ Nil = (Nil :*: Nil)++-- | \(O(\min(n,W))\). The expression (@'split' k map@) is a pair @(map1,map2)@+-- where all keys in @map1@ are lower than @k@ and all keys in+-- @map2@ larger than @k@. Any key equal to @k@ is found in neither @map1@ nor @map2@.+--+-- > split 2 (fromList [(5,"a"), (3,"b")]) == (empty, fromList [(3,"b"), (5,"a")])+-- > split 3 (fromList [(5,"a"), (3,"b")]) == (empty, singleton 5 "a")+-- > split 4 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", singleton 5 "a")+-- > split 5 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", empty)+-- > split 6 (fromList [(5,"a"), (3,"b")]) == (fromList [(3,"b"), (5,"a")], empty)++split :: Key -> Word64Map a -> (Word64Map a, Word64Map a)+split k t =+  case t of+    Bin p m l r+      | m < 0 ->+        if k >= 0 -- handle negative numbers.+        then+          case go k l of+            (lt :*: gt) ->+              let !lt' = bin p m lt r+              in (lt', gt)+        else+          case go k r of+            (lt :*: gt) ->+              let !gt' = bin p m l gt+              in (lt, gt')+    _ -> case go k t of+          (lt :*: gt) -> (lt, gt)+  where+    go k' t'@(Bin p m l r)+      | nomatch k' p m = if k' > p then t' :*: Nil else Nil :*: t'+      | zero k' m = case go k' l of (lt :*: gt) -> lt :*: bin p m gt r+      | otherwise = case go k' r of (lt :*: gt) -> bin p m l lt :*: gt+    go k' t'@(Tip ky _)+      | k' > ky   = (t' :*: Nil)+      | k' < ky   = (Nil :*: t')+      | otherwise = (Nil :*: Nil)+    go _ Nil = (Nil :*: Nil)+++data SplitLookup a = SplitLookup !(Word64Map a) !(Maybe a) !(Word64Map a)++mapLT :: (Word64Map a -> Word64Map a) -> SplitLookup a -> SplitLookup a+mapLT f (SplitLookup lt fnd gt) = SplitLookup (f lt) fnd gt+{-# INLINE mapLT #-}++mapGT :: (Word64Map a -> Word64Map a) -> SplitLookup a -> SplitLookup a+mapGT f (SplitLookup lt fnd gt) = SplitLookup lt fnd (f gt)+{-# INLINE mapGT #-}++-- | \(O(\min(n,W))\). Performs a 'split' but also returns whether the pivot+-- key was found in the original map.+--+-- > splitLookup 2 (fromList [(5,"a"), (3,"b")]) == (empty, Nothing, fromList [(3,"b"), (5,"a")])+-- > splitLookup 3 (fromList [(5,"a"), (3,"b")]) == (empty, Just "b", singleton 5 "a")+-- > splitLookup 4 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", Nothing, singleton 5 "a")+-- > splitLookup 5 (fromList [(5,"a"), (3,"b")]) == (singleton 3 "b", Just "a", empty)+-- > splitLookup 6 (fromList [(5,"a"), (3,"b")]) == (fromList [(3,"b"), (5,"a")], Nothing, empty)++splitLookup :: Key -> Word64Map a -> (Word64Map a, Maybe a, Word64Map a)+splitLookup k t =+  case+    case t of+      Bin p m l r+        | m < 0 ->+          if k >= 0 -- handle negative numbers.+          then mapLT (flip (bin p m) r) (go k l)+          else mapGT (bin p m l) (go k r)+      _ -> go k t+  of SplitLookup lt fnd gt -> (lt, fnd, gt)+  where+    go k' t'@(Bin p m l r)+      | nomatch k' p m =+          if k' > p+          then SplitLookup t' Nothing Nil+          else SplitLookup Nil Nothing t'+      | zero k' m = mapGT (flip (bin p m) r) (go k' l)+      | otherwise = mapLT (bin p m l) (go k' r)+    go k' t'@(Tip ky y)+      | k' > ky   = SplitLookup t'  Nothing  Nil+      | k' < ky   = SplitLookup Nil Nothing  t'+      | otherwise = SplitLookup Nil (Just y) Nil+    go _ Nil      = SplitLookup Nil Nothing  Nil++{--------------------------------------------------------------------+  Fold+--------------------------------------------------------------------}+-- | \(O(n)\). Fold the values in the map using the given right-associative+-- binary operator, such that @'foldr' f z == 'Prelude.foldr' f z . 'elems'@.+--+-- For example,+--+-- > elems map = foldr (:) [] map+--+-- > let f a len = len + (length a)+-- > foldr f 0 (fromList [(5,"a"), (3,"bbb")]) == 4+foldr :: (a -> b -> b) -> b -> Word64Map a -> b+foldr f z = \t ->      -- Use lambda t to be inlinable with two arguments only.+  case t of+    Bin _ m l r+      | m < 0 -> go (go z l) r -- put negative numbers before+      | otherwise -> go (go z r) l+    _ -> go z t+  where+    go z' Nil           = z'+    go z' (Tip _ x)     = f x z'+    go z' (Bin _ _ l r) = go (go z' r) l+{-# INLINE foldr #-}++-- | \(O(n)\). A strict version of 'foldr'. Each application of the operator is+-- evaluated before using the result in the next application. This+-- function is strict in the starting value.+foldr' :: (a -> b -> b) -> b -> Word64Map a -> b+foldr' f z = \t ->      -- Use lambda t to be inlinable with two arguments only.+  case t of+    Bin _ m l r+      | m < 0 -> go (go z l) r -- put negative numbers before+      | otherwise -> go (go z r) l+    _ -> go z t+  where+    go !z' Nil          = z'+    go z' (Tip _ x)     = f x z'+    go z' (Bin _ _ l r) = go (go z' r) l+{-# INLINE foldr' #-}++-- | \(O(n)\). Fold the values in the map using the given left-associative+-- binary operator, such that @'foldl' f z == 'Prelude.foldl' f z . 'elems'@.+--+-- For example,+--+-- > elems = reverse . foldl (flip (:)) []+--+-- > let f len a = len + (length a)+-- > foldl f 0 (fromList [(5,"a"), (3,"bbb")]) == 4+foldl :: (a -> b -> a) -> a -> Word64Map b -> a+foldl f z = \t ->      -- Use lambda t to be inlinable with two arguments only.+  case t of+    Bin _ m l r+      | m < 0 -> go (go z r) l -- put negative numbers before+      | otherwise -> go (go z l) r+    _ -> go z t+  where+    go z' Nil           = z'+    go z' (Tip _ x)     = f z' x+    go z' (Bin _ _ l r) = go (go z' l) r+{-# INLINE foldl #-}++-- | \(O(n)\). A strict version of 'foldl'. Each application of the operator is+-- evaluated before using the result in the next application. This+-- function is strict in the starting value.+foldl' :: (a -> b -> a) -> a -> Word64Map b -> a+foldl' f z = \t ->      -- Use lambda t to be inlinable with two arguments only.+  case t of+    Bin _ m l r+      | m < 0 -> go (go z r) l -- put negative numbers before+      | otherwise -> go (go z l) r+    _ -> go z t+  where+    go !z' Nil          = z'+    go z' (Tip _ x)     = f z' x+    go z' (Bin _ _ l r) = go (go z' l) r+{-# INLINE foldl' #-}++-- | \(O(n)\). Fold the keys and values in the map using the given right-associative+-- binary operator, such that+-- @'foldrWithKey' f z == 'Prelude.foldr' ('uncurry' f) z . 'toAscList'@.+--+-- For example,+--+-- > keys map = foldrWithKey (\k x ks -> k:ks) [] map+--+-- > let f k a result = result ++ "(" ++ (show k) ++ ":" ++ a ++ ")"+-- > foldrWithKey f "Map: " (fromList [(5,"a"), (3,"b")]) == "Map: (5:a)(3:b)"+foldrWithKey :: (Key -> a -> b -> b) -> b -> Word64Map a -> b+foldrWithKey f z = \t ->      -- Use lambda t to be inlinable with two arguments only.+  case t of+    Bin _ m l r+      | m < 0 -> go (go z l) r -- put negative numbers before+      | otherwise -> go (go z r) l+    _ -> go z t+  where+    go z' Nil           = z'+    go z' (Tip kx x)    = f kx x z'+    go z' (Bin _ _ l r) = go (go z' r) l+{-# INLINE foldrWithKey #-}++-- | \(O(n)\). A strict version of 'foldrWithKey'. Each application of the operator is+-- evaluated before using the result in the next application. This+-- function is strict in the starting value.+foldrWithKey' :: (Key -> a -> b -> b) -> b -> Word64Map a -> b+foldrWithKey' f z = \t ->      -- Use lambda t to be inlinable with two arguments only.+  case t of+    Bin _ m l r+      | m < 0 -> go (go z l) r -- put negative numbers before+      | otherwise -> go (go z r) l+    _ -> go z t+  where+    go !z' Nil          = z'+    go z' (Tip kx x)    = f kx x z'+    go z' (Bin _ _ l r) = go (go z' r) l+{-# INLINE foldrWithKey' #-}++-- | \(O(n)\). Fold the keys and values in the map using the given left-associative+-- binary operator, such that+-- @'foldlWithKey' f z == 'Prelude.foldl' (\\z' (kx, x) -> f z' kx x) z . 'toAscList'@.+--+-- For example,+--+-- > keys = reverse . foldlWithKey (\ks k x -> k:ks) []+--+-- > let f result k a = result ++ "(" ++ (show k) ++ ":" ++ a ++ ")"+-- > foldlWithKey f "Map: " (fromList [(5,"a"), (3,"b")]) == "Map: (3:b)(5:a)"+foldlWithKey :: (a -> Key -> b -> a) -> a -> Word64Map b -> a+foldlWithKey f z = \t ->      -- Use lambda t to be inlinable with two arguments only.+  case t of+    Bin _ m l r+      | m < 0 -> go (go z r) l -- put negative numbers before+      | otherwise -> go (go z l) r+    _ -> go z t+  where+    go z' Nil           = z'+    go z' (Tip kx x)    = f z' kx x+    go z' (Bin _ _ l r) = go (go z' l) r+{-# INLINE foldlWithKey #-}++-- | \(O(n)\). A strict version of 'foldlWithKey'. Each application of the operator is+-- evaluated before using the result in the next application. This+-- function is strict in the starting value.+foldlWithKey' :: (a -> Key -> b -> a) -> a -> Word64Map b -> a+foldlWithKey' f z = \t ->      -- Use lambda t to be inlinable with two arguments only.+  case t of+    Bin _ m l r+      | m < 0 -> go (go z r) l -- put negative numbers before+      | otherwise -> go (go z l) r+    _ -> go z t+  where+    go !z' Nil          = z'+    go z' (Tip kx x)    = f z' kx x+    go z' (Bin _ _ l r) = go (go z' l) r+{-# INLINE foldlWithKey' #-}++-- | \(O(n)\). Fold the keys and values in the map using the given monoid, such that+--+-- @'foldMapWithKey' f = 'Prelude.fold' . 'mapWithKey' f@+--+-- This can be an asymptotically faster than 'foldrWithKey' or 'foldlWithKey' for some monoids.+--+-- @since 0.5.4+foldMapWithKey :: Monoid m => (Key -> a -> m) -> Word64Map a -> m+foldMapWithKey f = go+  where+    go Nil           = mempty+    go (Tip kx x)    = f kx x+    go (Bin _ m l r)+      | m < 0     = go r `mappend` go l+      | otherwise = go l `mappend` go r+{-# INLINE foldMapWithKey #-}++{--------------------------------------------------------------------+  List variations+--------------------------------------------------------------------}+-- | \(O(n)\).+-- Return all elements of the map in the ascending order of their keys.+-- Subject to list fusion.+--+-- > elems (fromList [(5,"a"), (3,"b")]) == ["b","a"]+-- > elems empty == []++elems :: Word64Map a -> [a]+elems = foldr (:) []++-- | \(O(n)\). Return all keys of the map in ascending order. Subject to list+-- fusion.+--+-- > keys (fromList [(5,"a"), (3,"b")]) == [3,5]+-- > keys empty == []++keys  :: Word64Map a -> [Key]+keys = foldrWithKey (\k _ ks -> k : ks) []++-- | \(O(n)\). An alias for 'toAscList'. Returns all key\/value pairs in the+-- map in ascending key order. Subject to list fusion.+--+-- > assocs (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")]+-- > assocs empty == []++assocs :: Word64Map a -> [(Key,a)]+assocs = toAscList++-- | \(O(n \min(n,W))\). The set of all keys of the map.+--+-- > keysSet (fromList [(5,"a"), (3,"b")]) == Data.Word64Set.fromList [3,5]+-- > keysSet empty == Data.Word64Set.empty++keysSet :: Word64Map a -> Word64Set.Word64Set+keysSet Nil = Word64Set.Nil+keysSet (Tip kx _) = Word64Set.singleton kx+keysSet (Bin p m l r)+  | m .&. Word64Set.suffixBitMask == 0 = Word64Set.Bin p m (keysSet l) (keysSet r)+  | otherwise = Word64Set.Tip (p .&. Word64Set.prefixBitMask) (computeBm (computeBm 0 l) r)+  where computeBm !acc (Bin _ _ l' r') = computeBm (computeBm acc l') r'+        computeBm acc (Tip kx _) = acc .|. Word64Set.bitmapOf kx+        computeBm _   Nil = error "Data.Word64Set.keysSet: Nil"++-- | \(O(n)\). Build a map from a set of keys and a function which for each key+-- computes its value.+--+-- > fromSet (\k -> replicate k 'a') (Data.Word64Set.fromList [3, 5]) == fromList [(5,"aaaaa"), (3,"aaa")]+-- > fromSet undefined Data.Word64Set.empty == empty++fromSet :: (Key -> a) -> Word64Set.Word64Set -> Word64Map a+fromSet _ Word64Set.Nil = Nil+fromSet f (Word64Set.Bin p m l r) = Bin p m (fromSet f l) (fromSet f r)+fromSet f (Word64Set.Tip kx bm) = buildTree f kx bm (Word64Set.suffixBitMask + 1)+  where+    -- This is slightly complicated, as we to convert the dense+    -- representation of Word64Set into tree representation of Word64Map.+    --+    -- We are given a nonzero bit mask 'bmask' of 'bits' bits with+    -- prefix 'prefix'. We split bmask into halves corresponding+    -- to left and right subtree. If they are both nonempty, we+    -- create a Bin node, otherwise exactly one of them is nonempty+    -- and we construct the Word64Map from that half.+    buildTree g !prefix !bmask bits = case bits of+      0 -> Tip prefix (g prefix)+      _ -> case intFromNat ((natFromInt bits) `shiftRL` 1) of+        bits2+          | bmask .&. ((1 `shiftLL` fromIntegral bits2) - 1) == 0 ->+              buildTree g (prefix + bits2) (bmask `shiftRL` fromIntegral bits2) bits2+          | (bmask `shiftRL` fromIntegral bits2) .&. ((1 `shiftLL` fromIntegral bits2) - 1) == 0 ->+              buildTree g prefix bmask bits2+          | otherwise ->+              Bin prefix bits2+                (buildTree g prefix bmask bits2)+                (buildTree g (prefix + bits2) (bmask `shiftRL` fromIntegral bits2) bits2)++{--------------------------------------------------------------------+  Lists+--------------------------------------------------------------------}++-- | @since 0.5.6.2+instance GHCExts.IsList (Word64Map a) where+  type Item (Word64Map a) = (Key,a)+  fromList = fromList+  toList   = toList++-- | \(O(n)\). Convert the map to a list of key\/value pairs. Subject to list+-- fusion.+--+-- > toList (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")]+-- > toList empty == []++toList :: Word64Map a -> [(Key,a)]+toList = toAscList++-- | \(O(n)\). Convert the map to a list of key\/value pairs where the+-- keys are in ascending order. Subject to list fusion.+--+-- > toAscList (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")]++toAscList :: Word64Map a -> [(Key,a)]+toAscList = foldrWithKey (\k x xs -> (k,x):xs) []++-- | \(O(n)\). Convert the map to a list of key\/value pairs where the keys+-- are in descending order. Subject to list fusion.+--+-- > toDescList (fromList [(5,"a"), (3,"b")]) == [(5,"a"), (3,"b")]++toDescList :: Word64Map a -> [(Key,a)]+toDescList = foldlWithKey (\xs k x -> (k,x):xs) []++-- List fusion for the list generating functions.+-- The foldrFB and foldlFB are fold{r,l}WithKey equivalents, used for list fusion.+-- They are important to convert unfused methods back, see mapFB in prelude.+foldrFB :: (Key -> a -> b -> b) -> b -> Word64Map a -> b+foldrFB = foldrWithKey+{-# INLINE[0] foldrFB #-}+foldlFB :: (a -> Key -> b -> a) -> a -> Word64Map b -> a+foldlFB = foldlWithKey+{-# INLINE[0] foldlFB #-}++-- Inline assocs and toList, so that we need to fuse only toAscList.+{-# INLINE assocs #-}+{-# INLINE toList #-}++-- The fusion is enabled up to phase 2 included. If it does not succeed,+-- convert in phase 1 the expanded elems,keys,to{Asc,Desc}List calls back to+-- elems,keys,to{Asc,Desc}List.  In phase 0, we inline fold{lr}FB (which were+-- used in a list fusion, otherwise it would go away in phase 1), and let compiler+-- do whatever it wants with elems,keys,to{Asc,Desc}List -- it was forbidden to+-- inline it before phase 0, otherwise the fusion rules would not fire at all.+{-# NOINLINE[0] elems #-}+{-# NOINLINE[0] keys #-}+{-# NOINLINE[0] toAscList #-}+{-# NOINLINE[0] toDescList #-}+{-# RULES "Word64Map.elems" [~1] forall m . elems m = build (\c n -> foldrFB (\_ x xs -> c x xs) n m) #-}+{-# RULES "Word64Map.elemsBack" [1] foldrFB (\_ x xs -> x : xs) [] = elems #-}+{-# RULES "Word64Map.keys" [~1] forall m . keys m = build (\c n -> foldrFB (\k _ xs -> c k xs) n m) #-}+{-# RULES "Word64Map.keysBack" [1] foldrFB (\k _ xs -> k : xs) [] = keys #-}+{-# RULES "Word64Map.toAscList" [~1] forall m . toAscList m = build (\c n -> foldrFB (\k x xs -> c (k,x) xs) n m) #-}+{-# RULES "Word64Map.toAscListBack" [1] foldrFB (\k x xs -> (k, x) : xs) [] = toAscList #-}+{-# RULES "Word64Map.toDescList" [~1] forall m . toDescList m = build (\c n -> foldlFB (\xs k x -> c (k,x) xs) n m) #-}+{-# RULES "Word64Map.toDescListBack" [1] foldlFB (\xs k x -> (k, x) : xs) [] = toDescList #-}+++-- | \(O(n \min(n,W))\). Create a map from a list of key\/value pairs.+--+-- > fromList [] == empty+-- > fromList [(5,"a"), (3,"b"), (5, "c")] == fromList [(5,"c"), (3,"b")]+-- > fromList [(5,"c"), (3,"b"), (5, "a")] == fromList [(5,"a"), (3,"b")]++fromList :: [(Key,a)] -> Word64Map a+fromList xs+  = Foldable.foldl' ins empty xs+  where+    ins t (k,x)  = insert k x t++-- | \(O(n \min(n,W))\). Create a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'.+--+-- > fromListWith (++) [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"c")] == fromList [(3, "ab"), (5, "cba")]+-- > fromListWith (++) [] == empty++fromListWith :: (a -> a -> a) -> [(Key,a)] -> Word64Map a+fromListWith f xs+  = fromListWithKey (\_ x y -> f x y) xs++-- | \(O(n \min(n,W))\). Build a map from a list of key\/value pairs with a combining function. See also fromAscListWithKey'.+--+-- > let f key new_value old_value = show key ++ ":" ++ new_value ++ "|" ++ old_value+-- > fromListWithKey f [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"c")] == fromList [(3, "3:a|b"), (5, "5:c|5:b|a")]+-- > fromListWithKey f [] == empty++fromListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> Word64Map a+fromListWithKey f xs+  = Foldable.foldl' ins empty xs+  where+    ins t (k,x) = insertWithKey f k x t++-- | \(O(n)\). Build a map from a list of key\/value pairs where+-- the keys are in ascending order.+--+-- > fromAscList [(3,"b"), (5,"a")]          == fromList [(3, "b"), (5, "a")]+-- > fromAscList [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "b")]++fromAscList :: [(Key,a)] -> Word64Map a+fromAscList = fromMonoListWithKey Nondistinct (\_ x _ -> x)+{-# NOINLINE fromAscList #-}++-- | \(O(n)\). Build a map from a list of key\/value pairs where+-- the keys are in ascending order, with a combining function on equal keys.+-- /The precondition (input list is ascending) is not checked./+--+-- > fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "ba")]++fromAscListWith :: (a -> a -> a) -> [(Key,a)] -> Word64Map a+fromAscListWith f = fromMonoListWithKey Nondistinct (\_ x y -> f x y)+{-# NOINLINE fromAscListWith #-}++-- | \(O(n)\). Build a map from a list of key\/value pairs where+-- the keys are in ascending order, with a combining function on equal keys.+-- /The precondition (input list is ascending) is not checked./+--+-- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value+-- > fromAscListWithKey f [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "5:b|a")]++fromAscListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> Word64Map a+fromAscListWithKey f = fromMonoListWithKey Nondistinct f+{-# NOINLINE fromAscListWithKey #-}++-- | \(O(n)\). Build a map from a list of key\/value pairs where+-- the keys are in ascending order and all distinct.+-- /The precondition (input list is strictly ascending) is not checked./+--+-- > fromDistinctAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")]++fromDistinctAscList :: [(Key,a)] -> Word64Map a+fromDistinctAscList = fromMonoListWithKey Distinct (\_ x _ -> x)+{-# NOINLINE fromDistinctAscList #-}++-- | \(O(n)\). Build a map from a list of key\/value pairs with monotonic keys+-- and a combining function.+--+-- The precise conditions under which this function works are subtle:+-- For any branch mask, keys with the same prefix w.r.t. the branch+-- mask must occur consecutively in the list.++fromMonoListWithKey :: Distinct -> (Key -> a -> a -> a) -> [(Key,a)] -> Word64Map a+fromMonoListWithKey distinct f = go+  where+    go []              = Nil+    go ((kx,vx) : zs1) = addAll' kx vx zs1++    -- `addAll'` collects all keys equal to `kx` into a single value,+    -- and then proceeds with `addAll`.+    addAll' !kx vx []+        = Tip kx vx+    addAll' !kx vx ((ky,vy) : zs)+        | Nondistinct <- distinct, kx == ky+        = let v = f kx vy vx in addAll' ky v zs+        -- inlined: | otherwise = addAll kx (Tip kx vx) (ky : zs)+        | m <- branchMask kx ky+        , Inserted ty zs' <- addMany' m ky vy zs+        = addAll kx (linkWithMask m ky ty {-kx-} (Tip kx vx)) zs'++    -- for `addAll` and `addMany`, kx is /a/ key inside the tree `tx`+    -- `addAll` consumes the rest of the list, adding to the tree `tx`+    addAll !_kx !tx []+        = tx+    addAll !kx !tx ((ky,vy) : zs)+        | m <- branchMask kx ky+        , Inserted ty zs' <- addMany' m ky vy zs+        = addAll kx (linkWithMask m ky ty {-kx-} tx) zs'++    -- `addMany'` is similar to `addAll'`, but proceeds with `addMany'`.+    addMany' !_m !kx vx []+        = Inserted (Tip kx vx) []+    addMany' !m !kx vx zs0@((ky,vy) : zs)+        | Nondistinct <- distinct, kx == ky+        = let v = f kx vy vx in addMany' m ky v zs+        -- inlined: | otherwise = addMany m kx (Tip kx vx) (ky : zs)+        | mask kx m /= mask ky m+        = Inserted (Tip kx vx) zs0+        | mxy <- branchMask kx ky+        , Inserted ty zs' <- addMany' mxy ky vy zs+        = addMany m kx (linkWithMask mxy ky ty {-kx-} (Tip kx vx)) zs'++    -- `addAll` adds to `tx` all keys whose prefix w.r.t. `m` agrees with `kx`.+    addMany !_m !_kx tx []+        = Inserted tx []+    addMany !m !kx tx zs0@((ky,vy) : zs)+        | mask kx m /= mask ky m+        = Inserted tx zs0+        | mxy <- branchMask kx ky+        , Inserted ty zs' <- addMany' mxy ky vy zs+        = addMany m kx (linkWithMask mxy ky ty {-kx-} tx) zs'+{-# INLINE fromMonoListWithKey #-}++data Inserted a = Inserted !(Word64Map a) ![(Key,a)]++data Distinct = Distinct | Nondistinct++{--------------------------------------------------------------------+  Eq+--------------------------------------------------------------------}+instance Eq a => Eq (Word64Map a) where+  t1 == t2  = equal t1 t2+  t1 /= t2  = nequal t1 t2++equal :: Eq a => Word64Map a -> Word64Map a -> Bool+equal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)+  = (m1 == m2) && (p1 == p2) && (equal l1 l2) && (equal r1 r2)+equal (Tip kx x) (Tip ky y)+  = (kx == ky) && (x==y)+equal Nil Nil = True+equal _   _   = False++nequal :: Eq a => Word64Map a -> Word64Map a -> Bool+nequal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)+  = (m1 /= m2) || (p1 /= p2) || (nequal l1 l2) || (nequal r1 r2)+nequal (Tip kx x) (Tip ky y)+  = (kx /= ky) || (x/=y)+nequal Nil Nil = False+nequal _   _   = True++-- | @since 0.5.9+instance Eq1 Word64Map where+  liftEq eq (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)+    = (m1 == m2) && (p1 == p2) && (liftEq eq l1 l2) && (liftEq eq r1 r2)+  liftEq eq (Tip kx x) (Tip ky y)+    = (kx == ky) && (eq x y)+  liftEq _eq Nil Nil = True+  liftEq _eq _   _   = False++{--------------------------------------------------------------------+  Ord+--------------------------------------------------------------------}++instance Ord a => Ord (Word64Map a) where+    compare m1 m2 = compare (toList m1) (toList m2)++-- | @since 0.5.9+instance Ord1 Word64Map where+  liftCompare cmp m n =+    liftCompare (liftCompare cmp) (toList m) (toList n)++{--------------------------------------------------------------------+  Functor+--------------------------------------------------------------------}++instance Functor Word64Map where+    fmap = map++    a <$ Bin p m l r = Bin p m (a <$ l) (a <$ r)+    a <$ Tip k _     = Tip k a+    _ <$ Nil         = Nil++{--------------------------------------------------------------------+  Show+--------------------------------------------------------------------}++instance Show a => Show (Word64Map a) where+  showsPrec d m   = showParen (d > 10) $+    showString "fromList " . shows (toList m)++-- | @since 0.5.9+instance Show1 Word64Map where+    liftShowsPrec sp sl d m =+        showsUnaryWith (liftShowsPrec sp' sl') "fromList" d (toList m)+      where+        sp' = liftShowsPrec sp sl+        sl' = liftShowList sp sl++{--------------------------------------------------------------------+  Read+--------------------------------------------------------------------}+instance (Read e) => Read (Word64Map e) where+  readPrec = parens $ prec 10 $ do+    Ident "fromList" <- lexP+    xs <- readPrec+    return (fromList xs)++  readListPrec = readListPrecDefault++-- | @since 0.5.9+instance Read1 Word64Map where+    liftReadsPrec rp rl = readsData $+        readsUnaryWith (liftReadsPrec rp' rl') "fromList" fromList+      where+        rp' = liftReadsPrec rp rl+        rl' = liftReadList rp rl++{--------------------------------------------------------------------+  Helpers+--------------------------------------------------------------------}+{--------------------------------------------------------------------+  Link+--------------------------------------------------------------------}+link :: Prefix -> Word64Map a -> Prefix -> Word64Map a -> Word64Map a+link p1 t1 p2 t2 = linkWithMask (branchMask p1 p2) p1 t1 {-p2-} t2+{-# INLINE link #-}++-- `linkWithMask` is useful when the `branchMask` has already been computed+linkWithMask :: Mask -> Prefix -> Word64Map a -> Word64Map a -> Word64Map a+linkWithMask m p1 t1 {-p2-} t2+  | zero p1 m = Bin p m t1 t2+  | otherwise = Bin p m t2 t1+  where+    p = mask p1 m+{-# INLINE linkWithMask #-}++{--------------------------------------------------------------------+  @bin@ assures that we never have empty trees within a tree.+--------------------------------------------------------------------}+bin :: Prefix -> Mask -> Word64Map a -> Word64Map a -> Word64Map a+bin _ _ l Nil = l+bin _ _ Nil r = r+bin p m l r   = Bin p m l r+{-# INLINE bin #-}++-- binCheckLeft only checks that the left subtree is non-empty+binCheckLeft :: Prefix -> Mask -> Word64Map a -> Word64Map a -> Word64Map a+binCheckLeft _ _ Nil r = r+binCheckLeft p m l r   = Bin p m l r+{-# INLINE binCheckLeft #-}++-- binCheckRight only checks that the right subtree is non-empty+binCheckRight :: Prefix -> Mask -> Word64Map a -> Word64Map a -> Word64Map a+binCheckRight _ _ l Nil = l+binCheckRight p m l r   = Bin p m l r+{-# INLINE binCheckRight #-}++{--------------------------------------------------------------------+  Endian independent bit twiddling+--------------------------------------------------------------------}++-- | Should this key follow the left subtree of a 'Bin' with switching+-- bit @m@? N.B., the answer is only valid when @match i p m@ is true.+zero :: Key -> Mask -> Bool+zero i m+  = (natFromInt i) .&. (natFromInt m) == 0+{-# INLINE zero #-}++nomatch,match :: Key -> Prefix -> Mask -> Bool++-- | Does the key @i@ differ from the prefix @p@ before getting to+-- the switching bit @m@?+nomatch i p m+  = (mask i m) /= p+{-# INLINE nomatch #-}++-- | Does the key @i@ match the prefix @p@ (up to but not including+-- bit @m@)?+match i p m+  = (mask i m) == p+{-# INLINE match #-}+++-- | The prefix of key @i@ up to (but not including) the switching+-- bit @m@.+mask :: Key -> Mask -> Prefix+mask i m+  = maskW (natFromInt i) (natFromInt m)+{-# INLINE mask #-}+++{--------------------------------------------------------------------+  Big endian operations+--------------------------------------------------------------------}++-- | The prefix of key @i@ up to (but not including) the switching+-- bit @m@.+maskW :: Nat -> Nat -> Prefix+maskW i m+  = intFromNat (i .&. ((-m) `xor` m))+{-# INLINE maskW #-}++-- | Does the left switching bit specify a shorter prefix?+shorter :: Mask -> Mask -> Bool+shorter m1 m2+  = (natFromInt m1) > (natFromInt m2)+{-# INLINE shorter #-}++-- | The first switching bit where the two prefixes disagree.+branchMask :: Prefix -> Prefix -> Mask+branchMask p1 p2+  = intFromNat (highestBitMask (natFromInt p1 `xor` natFromInt p2))+{-# INLINE branchMask #-}++{--------------------------------------------------------------------+  Utilities+--------------------------------------------------------------------}++-- | \(O(1)\).  Decompose a map into pieces based on the structure+-- of the underlying tree. This function is useful for consuming a+-- map in parallel.+--+-- No guarantee is made as to the sizes of the pieces; an internal, but+-- deterministic process determines this.  However, it is guaranteed that the+-- pieces returned will be in ascending order (all elements in the first submap+-- less than all elements in the second, and so on).+--+-- Examples:+--+-- > splitRoot (fromList (zip [1..6::Int] ['a'..])) ==+-- >   [fromList [(1,'a'),(2,'b'),(3,'c')],fromList [(4,'d'),(5,'e'),(6,'f')]]+--+-- > splitRoot empty == []+--+--  Note that the current implementation does not return more than two submaps,+--  but you should not depend on this behaviour because it can change in the+--  future without notice.+splitRoot :: Word64Map a -> [Word64Map a]+splitRoot orig =+  case orig of+    Nil -> []+    x@(Tip _ _) -> [x]+    Bin _ m l r | m < 0 -> [r, l]+                | otherwise -> [l, r]+{-# INLINE splitRoot #-}+++{--------------------------------------------------------------------+  Debugging+--------------------------------------------------------------------}++-- | \(O(n \min(n,W))\). Show the tree that implements the map. The tree is shown+-- in a compressed, hanging format.+showTree :: Show a => Word64Map a -> String+showTree s+  = showTreeWith True False s+++{- | \(O(n \min(n,W))\). The expression (@'showTreeWith' hang wide map@) shows+ the tree that implements the map. If @hang@ is+ 'True', a /hanging/ tree is shown otherwise a rotated tree is shown. If+ @wide@ is 'True', an extra wide version is shown.+-}+showTreeWith :: Show a => Bool -> Bool -> Word64Map a -> String+showTreeWith hang wide t+  | hang      = (showsTreeHang wide [] t) ""+  | otherwise = (showsTree wide [] [] t) ""++showsTree :: Show a => Bool -> [String] -> [String] -> Word64Map a -> ShowS+showsTree wide lbars rbars t = case t of+  Bin p m l r ->+    showsTree wide (withBar rbars) (withEmpty rbars) r .+    showWide wide rbars .+    showsBars lbars . showString (showBin p m) . showString "\n" .+    showWide wide lbars .+    showsTree wide (withEmpty lbars) (withBar lbars) l+  Tip k x ->+    showsBars lbars .+    showString " " . shows k . showString ":=" . shows x . showString "\n"+  Nil -> showsBars lbars . showString "|\n"++showsTreeHang :: Show a => Bool -> [String] -> Word64Map a -> ShowS+showsTreeHang wide bars t = case t of+  Bin p m l r ->+    showsBars bars . showString (showBin p m) . showString "\n" .+    showWide wide bars .+    showsTreeHang wide (withBar bars) l .+    showWide wide bars .+    showsTreeHang wide (withEmpty bars) r+  Tip k x ->+    showsBars bars .+    showString " " . shows k . showString ":=" . shows x . showString "\n"+  Nil -> showsBars bars . showString "|\n"++showBin :: Prefix -> Mask -> String+showBin _ _+  = "*" -- ++ show (p,m)++showWide :: Bool -> [String] -> String -> String+showWide wide bars+  | wide      = showString (concat (reverse bars)) . showString "|\n"+  | otherwise = id++showsBars :: [String] -> ShowS+showsBars bars+  = case bars of+      [] -> id+      _ : tl -> showString (concat (reverse tl)) . showString node++node :: String+node = "+--"++withBar, withEmpty :: [String] -> [String]+withBar bars   = "|  ":bars+withEmpty bars = "   ":bars
+ GHC/Data/Word64Map/Lazy.hs view
@@ -0,0 +1,227 @@++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Word64Map.Lazy+-- Copyright   :  (c) Daan Leijen 2002+--                (c) Andriy Palamarchuk 2008+-- License     :  BSD-style+-- Maintainer  :  libraries@haskell.org+-- Portability :  portable+--+--+-- = Finite Word64 Maps (lazy interface)+--+-- The @'Word64Map' v@ type represents a finite map (sometimes called a dictionary)+-- from keys of type @Word64@ to values of type @v@.+--+-- The functions in "Data.Word64Map.Strict" are careful to force values before+-- installing them in an 'Word64Map'. This is usually more efficient in cases where+-- laziness is not essential. The functions in this module do not do so.+--+-- For a walkthrough of the most commonly used functions see the+-- <https://haskell-containers.readthedocs.io/en/latest/map.html maps introduction>.+--+-- This module is intended to be imported qualified, to avoid name clashes with+-- Prelude functions:+--+-- > import Data.Word64Map.Lazy (Word64Map)+-- > import qualified Data.Word64Map.Lazy as Word64Map+--+-- Note that the implementation is generally /left-biased/. Functions that take+-- two maps as arguments and combine them, such as `union` and `intersection`,+-- prefer the values in the first argument to those in the second.+--+--+-- == Detailed performance information+--+-- The amortized running time is given for each operation, with \(n\) referring to+-- the number of entries in the map and \(W\) referring to the number of bits in+-- an 'Word64' (64).+--+-- Benchmarks comparing "Data.Word64Map.Lazy" with other dictionary+-- implementations can be found at https://github.com/haskell-perf/dictionaries.+--+--+-- == Implementation+--+-- The implementation is based on /big-endian patricia trees/.  This data+-- structure performs especially well on binary operations like 'union' and+-- 'intersection'. Additionally, benchmarks show that it is also (much) faster+-- on insertions and deletions when compared to a generic size-balanced map+-- implementation (see "Data.Map").+--+--    * Chris Okasaki and Andy Gill,  \"/Fast Mergeable Integer Maps/\",+--      Workshop on ML, September 1998, pages 77-86,+--      <http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.37.5452>+--+--    * D.R. Morrison, \"/PATRICIA -- Practical Algorithm To Retrieve Information Coded In Alphanumeric/\",+--      Journal of the ACM, 15(4), October 1968, pages 514-534.+--+-----------------------------------------------------------------------------++module GHC.Data.Word64Map.Lazy (+    -- * Map type+    Word64Map, Key          -- instance Eq,Show++    -- * Construction+    , empty+    , singleton+    , fromSet++    -- ** From Unordered Lists+    , fromList+    , fromListWith+    , fromListWithKey++    -- ** From Ascending Lists+    , fromAscList+    , fromAscListWith+    , fromAscListWithKey+    , fromDistinctAscList++    -- * Insertion+    , insert+    , insertWith+    , insertWithKey+    , insertLookupWithKey++    -- * Deletion\/Update+    , delete+    , adjust+    , adjustWithKey+    , update+    , updateWithKey+    , updateLookupWithKey+    , alter+    , alterF++    -- * Query+    -- ** Lookup+    , WM.lookup+    , (!?)+    , (!)+    , findWithDefault+    , member+    , notMember+    , lookupLT+    , lookupGT+    , lookupLE+    , lookupGE++    -- ** Size+    , WM.null+    , size++    -- * Combine++    -- ** Union+    , union+    , unionWith+    , unionWithKey+    , unions+    , unionsWith++    -- ** Difference+    , difference+    , (\\)+    , differenceWith+    , differenceWithKey++    -- ** Intersection+    , intersection+    , intersectionWith+    , intersectionWithKey++    -- ** Disjoint+    , disjoint++    -- ** Compose+    , compose++    -- ** Universal combining function+    , mergeWithKey++    -- * Traversal+    -- ** Map+    , WM.map+    , mapWithKey+    , traverseWithKey+    , traverseMaybeWithKey+    , mapAccum+    , mapAccumWithKey+    , mapAccumRWithKey+    , mapKeys+    , mapKeysWith+    , mapKeysMonotonic++    -- * Folds+    , WM.foldr+    , WM.foldl+    , foldrWithKey+    , foldlWithKey+    , foldMapWithKey++    -- ** Strict folds+    , foldr'+    , foldl'+    , foldrWithKey'+    , foldlWithKey'++    -- * Conversion+    , elems+    , keys+    , assocs+    , keysSet++    -- ** Lists+    , toList++    -- ** Ordered lists+    , toAscList+    , toDescList++    -- * Filter+    , WM.filter+    , filterWithKey+    , restrictKeys+    , withoutKeys+    , partition+    , partitionWithKey++    , takeWhileAntitone+    , dropWhileAntitone+    , spanAntitone++    , mapMaybe+    , mapMaybeWithKey+    , mapEither+    , mapEitherWithKey++    , split+    , splitLookup+    , splitRoot++    -- * Submap+    , isSubmapOf, isSubmapOfBy+    , isProperSubmapOf, isProperSubmapOfBy++    -- * Min\/Max+    , lookupMin+    , lookupMax+    , findMin+    , findMax+    , deleteMin+    , deleteMax+    , deleteFindMin+    , deleteFindMax+    , updateMin+    , updateMax+    , updateMinWithKey+    , updateMaxWithKey+    , minView+    , maxView+    , minViewWithKey+    , maxViewWithKey+    ) where++import GHC.Data.Word64Map.Internal as WM
+ GHC/Data/Word64Map/Strict.hs view
@@ -0,0 +1,245 @@++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Word64Map.Strict+-- Copyright   :  (c) Daan Leijen 2002+--                (c) Andriy Palamarchuk 2008+-- License     :  BSD-style+-- Maintainer  :  libraries@haskell.org+-- Portability :  portable+--+--+-- = Finite Word64 Maps (strict interface)+--+-- The @'Word64Map' v@ type represents a finite map (sometimes called a dictionary)+-- from key of type @Word64@ to values of type @v@.+--+-- Each function in this module is careful to force values before installing+-- them in an 'Word64Map'. This is usually more efficient when laziness is not+-- necessary. When laziness /is/ required, use the functions in+-- "Data.Word64Map.Lazy".+--+-- In particular, the functions in this module obey the following law:+--+--  - If all values stored in all maps in the arguments are in WHNF, then all+--    values stored in all maps in the results will be in WHNF once those maps+--    are evaluated.+--+-- For a walkthrough of the most commonly used functions see the+-- <https://haskell-containers.readthedocs.io/en/latest/map.html maps introduction>.+--+-- This module is intended to be imported qualified, to avoid name clashes with+-- Prelude functions:+--+-- > import Data.Word64Map.Strict (Word64Map)+-- > import qualified Data.Word64Map.Strict as Word64Map+--+-- Note that the implementation is generally /left-biased/. Functions that take+-- two maps as arguments and combine them, such as `union` and `intersection`,+-- prefer the values in the first argument to those in the second.+--+--+-- == Detailed performance information+--+-- The amortized running time is given for each operation, with \(n\) referring to+-- the number of entries in the map and \(W\) referring to the number of bits in+-- an 'Word64' (64).+--+-- Benchmarks comparing "Data.Word64Map.Strict" with other dictionary+-- implementations can be found at https://github.com/haskell-perf/dictionaries.+--+--+-- == Warning+--+-- The 'Word64Map' type is shared between the lazy and strict modules, meaning that+-- the same 'Word64Map' value can be passed to functions in both modules. This+-- means that the 'Functor', 'Traversable' and 'Data.Data.Data' instances are+-- the same as for the "Data.Word64Map.Lazy" module, so if they are used the+-- resulting map may contain suspended values (thunks).+--+--+-- == Implementation+--+-- The implementation is based on /big-endian patricia trees/.  This data+-- structure performs especially well on binary operations like 'union' and+-- 'intersection'. Additionally, benchmarks show that it is also (much) faster+-- on insertions and deletions when compared to a generic size-balanced map+-- implementation (see "Data.Map").+--+--    * Chris Okasaki and Andy Gill,  \"/Fast Mergeable Integer Maps/\",+--      Workshop on ML, September 1998, pages 77-86,+--      <http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.37.5452>+--+--    * D.R. Morrison, \"/PATRICIA -- Practical Algorithm To Retrieve Information Coded In Alphanumeric/\",+--      Journal of the ACM, 15(4), October 1968, pages 514-534.+--+-----------------------------------------------------------------------------++-- See the notes at the beginning of Data.Word64Map.Internal.++module GHC.Data.Word64Map.Strict (+    -- * Map type+    Word64Map, Key          -- instance Eq,Show++    -- * Construction+    , empty+    , singleton+    , fromSet++    -- ** From Unordered Lists+    , fromList+    , fromListWith+    , fromListWithKey++    -- ** From Ascending Lists+    , fromAscList+    , fromAscListWith+    , fromAscListWithKey+    , fromDistinctAscList++    -- * Insertion+    , insert+    , insertWith+    , insertWithKey+    , insertLookupWithKey++    -- * Deletion\/Update+    , delete+    , adjust+    , adjustWithKey+    , update+    , updateWithKey+    , updateLookupWithKey+    , alter+    , alterF++    -- * Query+    -- ** Lookup+    , lookup+    , (!?)+    , (!)+    , findWithDefault+    , member+    , notMember+    , lookupLT+    , lookupGT+    , lookupLE+    , lookupGE++    -- ** Size+    , null+    , size++    -- * Combine++    -- ** Union+    , union+    , unionWith+    , unionWithKey+    , unions+    , unionsWith++    -- ** Difference+    , difference+    , (\\)+    , differenceWith+    , differenceWithKey++    -- ** Intersection+    , intersection+    , intersectionWith+    , intersectionWithKey++    -- ** Disjoint+    , disjoint++    -- ** Compose+    , compose++    -- ** Universal combining function+    , mergeWithKey++    -- * Traversal+    -- ** Map+    , map+    , mapWithKey+    , traverseWithKey+    , traverseMaybeWithKey+    , mapAccum+    , mapAccumWithKey+    , mapAccumRWithKey+    , mapKeys+    , mapKeysWith+    , mapKeysMonotonic++    -- * Folds+    , foldr+    , foldl+    , foldrWithKey+    , foldlWithKey+    , foldMapWithKey++    -- ** Strict folds+    , foldr'+    , foldl'+    , foldrWithKey'+    , foldlWithKey'++    -- * Conversion+    , elems+    , keys+    , assocs+    , keysSet++    -- ** Lists+    , toList++-- ** Ordered lists+    , toAscList+    , toDescList++    -- * Filter+    , filter+    , filterWithKey+    , restrictKeys+    , withoutKeys+    , partition+    , partitionWithKey++    , takeWhileAntitone+    , dropWhileAntitone+    , spanAntitone++    , mapMaybe+    , mapMaybeWithKey+    , mapEither+    , mapEitherWithKey++    , split+    , splitLookup+    , splitRoot++    -- * Submap+    , isSubmapOf, isSubmapOfBy+    , isProperSubmapOf, isProperSubmapOfBy++    -- * Min\/Max+    , lookupMin+    , lookupMax+    , findMin+    , findMax+    , deleteMin+    , deleteMax+    , deleteFindMin+    , deleteFindMax+    , updateMin+    , updateMax+    , updateMinWithKey+    , updateMaxWithKey+    , minView+    , maxView+    , minViewWithKey+    , maxViewWithKey+    ) where++import GHC.Data.Word64Map.Strict.Internal
+ GHC/Data/Word64Map/Strict/Internal.hs view
@@ -0,0 +1,1195 @@++{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Word64Map.Strict.Internal+-- Copyright   :  (c) Daan Leijen 2002+--                (c) Andriy Palamarchuk 2008+-- License     :  BSD-style+-- Maintainer  :  libraries@haskell.org+-- Portability :  portable+--+--+-- = Finite Int Maps (strict interface)+--+-- The @'Word64Map' v@ type represents a finite map (sometimes called a dictionary)+-- from key of type @Int@ to values of type @v@.+--+-- Each function in this module is careful to force values before installing+-- them in an 'Word64Map'. This is usually more efficient when laziness is not+-- necessary. When laziness /is/ required, use the functions in+-- "Data.Word64Map.Lazy".+--+-- In particular, the functions in this module obey the following law:+--+--  - If all values stored in all maps in the arguments are in WHNF, then all+--    values stored in all maps in the results will be in WHNF once those maps+--    are evaluated.+--+-- For a walkthrough of the most commonly used functions see the+-- <https://haskell-containers.readthedocs.io/en/latest/map.html maps introduction>.+--+-- This module is intended to be imported qualified, to avoid name clashes with+-- Prelude functions:+--+-- > import Data.Word64Map.Strict (Word64Map)+-- > import qualified Data.Word64Map.Strict as Word64Map+--+-- Note that the implementation is generally /left-biased/. Functions that take+-- two maps as arguments and combine them, such as `union` and `intersection`,+-- prefer the values in the first argument to those in the second.+--+--+-- == Detailed performance information+--+-- The amortized running time is given for each operation, with \(n\) referring to+-- the number of entries in the map and \(W\) referring to the number of bits in+-- an 'Int' (32 or 64).+--+-- Benchmarks comparing "Data.Word64Map.Strict" with other dictionary+-- implementations can be found at https://github.com/haskell-perf/dictionaries.+--+--+-- == Warning+--+-- The 'Word64Map' type is shared between the lazy and strict modules, meaning that+-- the same 'Word64Map' value can be passed to functions in both modules. This+-- means that the 'Functor', 'Traversable' and 'Data.Data.Data' instances are+-- the same as for the "Data.Word64Map.Lazy" module, so if they are used the+-- resulting map may contain suspended values (thunks).+--+--+-- == Implementation+--+-- The implementation is based on /big-endian patricia trees/.  This data+-- structure performs especially well on binary operations like 'union' and+-- 'intersection'. Additionally, benchmarks show that it is also (much) faster+-- on insertions and deletions when compared to a generic size-balanced map+-- implementation (see "Data.Map").+--+--    * Chris Okasaki and Andy Gill,  \"/Fast Mergeable Integer Maps/\",+--      Workshop on ML, September 1998, pages 77-86,+--      <http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.37.5452>+--+--    * D.R. Morrison, \"/PATRICIA -- Practical Algorithm To Retrieve Information Coded In Alphanumeric/\",+--      Journal of the ACM, 15(4), October 1968, pages 514-534.+--+-----------------------------------------------------------------------------++-- See the notes at the beginning of Data.Word64Map.Internal.++module GHC.Data.Word64Map.Strict.Internal (+    -- * Map type+    Word64Map, Key          -- instance Eq,Show++    -- * Construction+    , empty+    , singleton+    , fromSet++    -- ** From Unordered Lists+    , fromList+    , fromListWith+    , fromListWithKey++    -- ** From Ascending Lists+    , fromAscList+    , fromAscListWith+    , fromAscListWithKey+    , fromDistinctAscList++    -- * Insertion+    , insert+    , insertWith+    , insertWithKey+    , insertLookupWithKey++    -- * Deletion\/Update+    , delete+    , adjust+    , adjustWithKey+    , update+    , updateWithKey+    , updateLookupWithKey+    , alter+    , alterF++    -- * Query+    -- ** Lookup+    , lookup+    , (!?)+    , (!)+    , findWithDefault+    , member+    , notMember+    , lookupLT+    , lookupGT+    , lookupLE+    , lookupGE++    -- ** Size+    , null+    , size++    -- * Combine++    -- ** Union+    , union+    , unionWith+    , unionWithKey+    , unions+    , unionsWith++    -- ** Difference+    , difference+    , (\\)+    , differenceWith+    , differenceWithKey++    -- ** Intersection+    , intersection+    , intersectionWith+    , intersectionWithKey++    -- ** Disjoint+    , disjoint++    -- ** Compose+    , compose++    -- ** Universal combining function+    , mergeWithKey++    -- * Traversal+    -- ** Map+    , map+    , mapWithKey+    , traverseWithKey+    , traverseMaybeWithKey+    , mapAccum+    , mapAccumWithKey+    , mapAccumRWithKey+    , mapKeys+    , mapKeysWith+    , mapKeysMonotonic++    -- * Folds+    , foldr+    , foldl+    , foldrWithKey+    , foldlWithKey+    , foldMapWithKey++    -- ** Strict folds+    , foldr'+    , foldl'+    , foldrWithKey'+    , foldlWithKey'++    -- * Conversion+    , elems+    , keys+    , assocs+    , keysSet++    -- ** Lists+    , toList++-- ** Ordered lists+    , toAscList+    , toDescList++    -- * Filter+    , filter+    , filterWithKey+    , restrictKeys+    , withoutKeys+    , partition+    , partitionWithKey++    , takeWhileAntitone+    , dropWhileAntitone+    , spanAntitone++    , mapMaybe+    , mapMaybeWithKey+    , mapEither+    , mapEitherWithKey++    , split+    , splitLookup+    , splitRoot++    -- * Submap+    , isSubmapOf, isSubmapOfBy+    , isProperSubmapOf, isProperSubmapOfBy++    -- * Min\/Max+    , lookupMin+    , lookupMax+    , findMin+    , findMax+    , deleteMin+    , deleteMax+    , deleteFindMin+    , deleteFindMax+    , updateMin+    , updateMax+    , updateMinWithKey+    , updateMaxWithKey+    , minView+    , maxView+    , minViewWithKey+    , maxViewWithKey+    ) where++import GHC.Prelude.Basic hiding+  (lookup, filter, foldr, foldl, foldl', null, map)++import qualified GHC.Data.Word64Map.Internal as L+import GHC.Data.Word64Map.Internal+  ( Word64Map (..)+  , Key+  , mask+  , branchMask+  , nomatch+  , zero+  , natFromInt+  , intFromNat+  , bin+  , binCheckLeft+  , binCheckRight+  , link+  , linkWithMask++  , (\\)+  , (!)+  , (!?)+  , empty+  , assocs+  , filter+  , filterWithKey+  , findMin+  , findMax+  , foldMapWithKey+  , foldr+  , foldl+  , foldr'+  , foldl'+  , foldlWithKey+  , foldrWithKey+  , foldlWithKey'+  , foldrWithKey'+  , keysSet+  , mergeWithKey'+  , compose+  , delete+  , deleteMin+  , deleteMax+  , deleteFindMax+  , deleteFindMin+  , difference+  , elems+  , intersection+  , disjoint+  , isProperSubmapOf+  , isProperSubmapOfBy+  , isSubmapOf+  , isSubmapOfBy+  , lookup+  , lookupLE+  , lookupGE+  , lookupLT+  , lookupGT+  , lookupMin+  , lookupMax+  , minView+  , maxView+  , minViewWithKey+  , maxViewWithKey+  , keys+  , mapKeys+  , mapKeysMonotonic+  , member+  , notMember+  , null+  , partition+  , partitionWithKey+  , takeWhileAntitone+  , dropWhileAntitone+  , spanAntitone+  , restrictKeys+  , size+  , split+  , splitLookup+  , splitRoot+  , toAscList+  , toDescList+  , toList+  , union+  , unions+  , withoutKeys+  )+import qualified GHC.Data.Word64Set.Internal as Word64Set+import GHC.Utils.Containers.Internal.BitUtil+import GHC.Utils.Containers.Internal.StrictPair+import qualified Data.Foldable as Foldable++{--------------------------------------------------------------------+  Query+--------------------------------------------------------------------}++-- | \(O(\min(n,W))\). The expression @('findWithDefault' def k map)@+-- returns the value at key @k@ or returns @def@ when the key is not an+-- element of the map.+--+-- > findWithDefault 'x' 1 (fromList [(5,'a'), (3,'b')]) == 'x'+-- > findWithDefault 'x' 5 (fromList [(5,'a'), (3,'b')]) == 'a'++-- See Word64Map.Internal.Note: Local 'go' functions and capturing]+findWithDefault :: a -> Key -> Word64Map a -> a+findWithDefault def !k = go+  where+    go (Bin p m l r) | nomatch k p m = def+                     | zero k m  = go l+                     | otherwise = go r+    go (Tip kx x) | k == kx   = x+                  | otherwise = def+    go Nil = def++{--------------------------------------------------------------------+  Construction+--------------------------------------------------------------------}+-- | \(O(1)\). A map of one element.+--+-- > singleton 1 'a'        == fromList [(1, 'a')]+-- > size (singleton 1 'a') == 1++singleton :: Key -> a -> Word64Map a+singleton k !x+  = Tip k x+{-# INLINE singleton #-}++{--------------------------------------------------------------------+  Insert+--------------------------------------------------------------------}+-- | \(O(\min(n,W))\). Insert a new key\/value pair in the map.+-- If the key is already present in the map, the associated value is+-- replaced with the supplied value, i.e. 'insert' is equivalent to+-- @'insertWith' 'const'@.+--+-- > insert 5 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'x')]+-- > insert 7 'x' (fromList [(5,'a'), (3,'b')]) == fromList [(3, 'b'), (5, 'a'), (7, 'x')]+-- > insert 5 'x' empty                         == singleton 5 'x'++insert :: Key -> a -> Word64Map a -> Word64Map a+insert !k !x t =+  case t of+    Bin p m l r+      | nomatch k p m -> link k (Tip k x) p t+      | zero k m      -> Bin p m (insert k x l) r+      | otherwise     -> Bin p m l (insert k x r)+    Tip ky _+      | k==ky         -> Tip k x+      | otherwise     -> link k (Tip k x) ky t+    Nil -> Tip k x++-- right-biased insertion, used by 'union'+-- | \(O(\min(n,W))\). Insert with a combining function.+-- @'insertWith' f key value mp@+-- will insert the pair (key, value) into @mp@ if key does+-- not exist in the map. If the key does exist, the function will+-- insert @f new_value old_value@.+--+-- > insertWith (++) 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "xxxa")]+-- > insertWith (++) 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")]+-- > insertWith (++) 5 "xxx" empty                         == singleton 5 "xxx"++insertWith :: (a -> a -> a) -> Key -> a -> Word64Map a -> Word64Map a+insertWith f k x t+  = insertWithKey (\_ x' y' -> f x' y') k x t++-- | \(O(\min(n,W))\). Insert with a combining function.+-- @'insertWithKey' f key value mp@+-- will insert the pair (key, value) into @mp@ if key does+-- not exist in the map. If the key does exist, the function will+-- insert @f key new_value old_value@.+--+-- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value+-- > insertWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:xxx|a")]+-- > insertWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a"), (7, "xxx")]+-- > insertWithKey f 5 "xxx" empty                         == singleton 5 "xxx"+--+-- If the key exists in the map, this function is lazy in @value@ but strict+-- in the result of @f@.++insertWithKey :: (Key -> a -> a -> a) -> Key -> a -> Word64Map a -> Word64Map a+insertWithKey f !k x t =+  case t of+    Bin p m l r+      | nomatch k p m -> link k (singleton k x) p t+      | zero k m      -> Bin p m (insertWithKey f k x l) r+      | otherwise     -> Bin p m l (insertWithKey f k x r)+    Tip ky y+      | k==ky         -> Tip k $! f k x y+      | otherwise     -> link k (singleton k x) ky t+    Nil -> singleton k x++-- | \(O(\min(n,W))\). The expression (@'insertLookupWithKey' f k x map@)+-- is a pair where the first element is equal to (@'lookup' k map@)+-- and the second element equal to (@'insertWithKey' f k x map@).+--+-- > let f key new_value old_value = (show key) ++ ":" ++ new_value ++ "|" ++ old_value+-- > insertLookupWithKey f 5 "xxx" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "5:xxx|a")])+-- > insertLookupWithKey f 7 "xxx" (fromList [(5,"a"), (3,"b")]) == (Nothing,  fromList [(3, "b"), (5, "a"), (7, "xxx")])+-- > insertLookupWithKey f 5 "xxx" empty                         == (Nothing,  singleton 5 "xxx")+--+-- This is how to define @insertLookup@ using @insertLookupWithKey@:+--+-- > let insertLookup kx x t = insertLookupWithKey (\_ a _ -> a) kx x t+-- > insertLookup 5 "x" (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "x")])+-- > insertLookup 7 "x" (fromList [(5,"a"), (3,"b")]) == (Nothing,  fromList [(3, "b"), (5, "a"), (7, "x")])++insertLookupWithKey :: (Key -> a -> a -> a) -> Key -> a -> Word64Map a -> (Maybe a, Word64Map a)+insertLookupWithKey f0 !k0 x0 t0 = toPair $ go f0 k0 x0 t0+  where+    go f k x t =+      case t of+        Bin p m l r+          | nomatch k p m -> Nothing :*: link k (singleton k x) p t+          | zero k m      -> let (found :*: l') = go f k x l in (found :*: Bin p m l' r)+          | otherwise     -> let (found :*: r') = go f k x r in (found :*: Bin p m l r')+        Tip ky y+          | k==ky         -> (Just y :*: (Tip k $! f k x y))+          | otherwise     -> (Nothing :*: link k (singleton k x) ky t)+        Nil -> Nothing :*: (singleton k x)+++{--------------------------------------------------------------------+  Deletion+--------------------------------------------------------------------}+-- | \(O(\min(n,W))\). Adjust a value at a specific key. When the key is not+-- a member of the map, the original map is returned.+--+-- > adjust ("new " ++) 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")]+-- > adjust ("new " ++) 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]+-- > adjust ("new " ++) 7 empty                         == empty++adjust ::  (a -> a) -> Key -> Word64Map a -> Word64Map a+adjust f k m+  = adjustWithKey (\_ x -> f x) k m++-- | \(O(\min(n,W))\). Adjust a value at a specific key. When the key is not+-- a member of the map, the original map is returned.+--+-- > let f key x = (show key) ++ ":new " ++ x+-- > adjustWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")]+-- > adjustWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]+-- > adjustWithKey f 7 empty                         == empty++adjustWithKey ::  (Key -> a -> a) -> Key -> Word64Map a -> Word64Map a+adjustWithKey f !k t =+  case t of+    Bin p m l r+      | nomatch k p m -> t+      | zero k m      -> Bin p m (adjustWithKey f k l) r+      | otherwise     -> Bin p m l (adjustWithKey f k r)+    Tip ky y+      | k==ky         -> Tip ky $! f k y+      | otherwise     -> t+    Nil -> Nil++-- | \(O(\min(n,W))\). The expression (@'update' f k map@) updates the value @x@+-- at @k@ (if it is in the map). If (@f x@) is 'Nothing', the element is+-- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@.+--+-- > let f x = if x == "a" then Just "new a" else Nothing+-- > update f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "new a")]+-- > update f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]+-- > update f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"++update ::  (a -> Maybe a) -> Key -> Word64Map a -> Word64Map a+update f+  = updateWithKey (\_ x -> f x)++-- | \(O(\min(n,W))\). The expression (@'update' f k map@) updates the value @x@+-- at @k@ (if it is in the map). If (@f k x@) is 'Nothing', the element is+-- deleted. If it is (@'Just' y@), the key @k@ is bound to the new value @y@.+--+-- > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing+-- > updateWithKey f 5 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "5:new a")]+-- > updateWithKey f 7 (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "a")]+-- > updateWithKey f 3 (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"++updateWithKey ::  (Key -> a -> Maybe a) -> Key -> Word64Map a -> Word64Map a+updateWithKey f !k t =+  case t of+    Bin p m l r+      | nomatch k p m -> t+      | zero k m      -> binCheckLeft p m (updateWithKey f k l) r+      | otherwise     -> binCheckRight p m l (updateWithKey f k r)+    Tip ky y+      | k==ky         -> case f k y of+                           Just !y' -> Tip ky y'+                           Nothing -> Nil+      | otherwise     -> t+    Nil -> Nil++-- | \(O(\min(n,W))\). Lookup and update.+-- The function returns original value, if it is updated.+-- This is different behavior than 'Data.Map.updateLookupWithKey'.+-- Returns the original key value if the map entry is deleted.+--+-- > let f k x = if x == "a" then Just ((show k) ++ ":new a") else Nothing+-- > updateLookupWithKey f 5 (fromList [(5,"a"), (3,"b")]) == (Just "a", fromList [(3, "b"), (5, "5:new a")])+-- > updateLookupWithKey f 7 (fromList [(5,"a"), (3,"b")]) == (Nothing,  fromList [(3, "b"), (5, "a")])+-- > updateLookupWithKey f 3 (fromList [(5,"a"), (3,"b")]) == (Just "b", singleton 5 "a")++updateLookupWithKey ::  (Key -> a -> Maybe a) -> Key -> Word64Map a -> (Maybe a,Word64Map a)+updateLookupWithKey f0 !k0 t0 = toPair $ go f0 k0 t0+  where+    go f k t =+      case t of+        Bin p m l r+          | nomatch k p m -> (Nothing :*: t)+          | zero k m      -> let (found :*: l') = go f k l in (found :*: binCheckLeft p m l' r)+          | otherwise     -> let (found :*: r') = go f k r in (found :*: binCheckRight p m l r')+        Tip ky y+          | k==ky         -> case f k y of+                               Just !y' -> (Just y :*: Tip ky y')+                               Nothing  -> (Just y :*: Nil)+          | otherwise     -> (Nothing :*: t)+        Nil -> (Nothing :*: Nil)++++-- | \(O(\min(n,W))\). The expression (@'alter' f k map@) alters the value @x@ at @k@, or absence thereof.+-- 'alter' can be used to insert, delete, or update a value in an 'Word64Map'.+-- In short : @'lookup' k ('alter' f k m) = f ('lookup' k m)@.+alter :: (Maybe a -> Maybe a) -> Key -> Word64Map a -> Word64Map a+alter f !k t =+  case t of+    Bin p m l r+      | nomatch k p m -> case f Nothing of+                           Nothing -> t+                           Just !x  -> link k (Tip k x) p t+      | zero k m      -> binCheckLeft p m (alter f k l) r+      | otherwise     -> binCheckRight p m l (alter f k r)+    Tip ky y+      | k==ky         -> case f (Just y) of+                           Just !x -> Tip ky x+                           Nothing -> Nil+      | otherwise     -> case f Nothing of+                           Just !x -> link k (Tip k x) ky t+                           Nothing -> t+    Nil               -> case f Nothing of+                           Just !x -> Tip k x+                           Nothing -> Nil++-- | \(O(\log n)\). The expression (@'alterF' f k map@) alters the value @x@ at+-- @k@, or absence thereof.  'alterF' can be used to inspect, insert, delete,+-- or update a value in an 'Word64Map'.  In short : @'lookup' k <$> 'alterF' f k m = f+-- ('lookup' k m)@.+--+-- Example:+--+-- @+-- interactiveAlter :: Int -> Word64Map String -> IO (Word64Map String)+-- interactiveAlter k m = alterF f k m where+--   f Nothing = do+--      putStrLn $ show k +++--          " was not found in the map. Would you like to add it?"+--      getUserResponse1 :: IO (Maybe String)+--   f (Just old) = do+--      putStrLn $ "The key is currently bound to " ++ show old +++--          ". Would you like to change or delete it?"+--      getUserResponse2 :: IO (Maybe String)+-- @+--+-- 'alterF' is the most general operation for working with an individual+-- key that may or may not be in a given map.++-- Note: 'alterF' is a flipped version of the 'at' combinator from+-- 'Control.Lens.At'.+--+-- @since 0.5.8++alterF :: Functor f+       => (Maybe a -> f (Maybe a)) -> Key -> Word64Map a -> f (Word64Map a)+-- This implementation was modified from 'Control.Lens.At'.+alterF f k m = (<$> f mv) $ \fres ->+  case fres of+    Nothing -> maybe m (const (delete k m)) mv+    Just !v' -> insert k v' m+  where mv = lookup k m+++{--------------------------------------------------------------------+  Union+--------------------------------------------------------------------}+-- | The union of a list of maps, with a combining operation.+--+-- > unionsWith (++) [(fromList [(5, "a"), (3, "b")]), (fromList [(5, "A"), (7, "C")]), (fromList [(5, "A3"), (3, "B3")])]+-- >     == fromList [(3, "bB3"), (5, "aAA3"), (7, "C")]++unionsWith :: Foldable f => (a->a->a) -> f (Word64Map a) -> Word64Map a+unionsWith f ts+  = Foldable.foldl' (unionWith f) empty ts++-- | \(O(n+m)\). The union with a combining function.+--+-- > unionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "aA"), (7, "C")]++unionWith :: (a -> a -> a) -> Word64Map a -> Word64Map a -> Word64Map a+unionWith f m1 m2+  = unionWithKey (\_ x y -> f x y) m1 m2++-- | \(O(n+m)\). The union with a combining function.+--+-- > let f key left_value right_value = (show key) ++ ":" ++ left_value ++ "|" ++ right_value+-- > unionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == fromList [(3, "b"), (5, "5:a|A"), (7, "C")]++unionWithKey :: (Key -> a -> a -> a) -> Word64Map a -> Word64Map a -> Word64Map a+unionWithKey f m1 m2+  = mergeWithKey' Bin (\(Tip k1 x1) (Tip _k2 x2) -> Tip k1 $! f k1 x1 x2) id id m1 m2++{--------------------------------------------------------------------+  Difference+--------------------------------------------------------------------}++-- | \(O(n+m)\). Difference with a combining function.+--+-- > let f al ar = if al == "b" then Just (al ++ ":" ++ ar) else Nothing+-- > differenceWith f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (7, "C")])+-- >     == singleton 3 "b:B"++differenceWith :: (a -> b -> Maybe a) -> Word64Map a -> Word64Map b -> Word64Map a+differenceWith f m1 m2+  = differenceWithKey (\_ x y -> f x y) m1 m2++-- | \(O(n+m)\). Difference with a combining function. When two equal keys are+-- encountered, the combining function is applied to the key and both values.+-- If it returns 'Nothing', the element is discarded (proper set difference).+-- If it returns (@'Just' y@), the element is updated with a new value @y@.+--+-- > let f k al ar = if al == "b" then Just ((show k) ++ ":" ++ al ++ "|" ++ ar) else Nothing+-- > differenceWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (3, "B"), (10, "C")])+-- >     == singleton 3 "3:b|B"++differenceWithKey :: (Key -> a -> b -> Maybe a) -> Word64Map a -> Word64Map b -> Word64Map a+differenceWithKey f m1 m2+  = mergeWithKey f id (const Nil) m1 m2++{--------------------------------------------------------------------+  Intersection+--------------------------------------------------------------------}++-- | \(O(n+m)\). The intersection with a combining function.+--+-- > intersectionWith (++) (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "aA"++intersectionWith :: (a -> b -> c) -> Word64Map a -> Word64Map b -> Word64Map c+intersectionWith f m1 m2+  = intersectionWithKey (\_ x y -> f x y) m1 m2++-- | \(O(n+m)\). The intersection with a combining function.+--+-- > let f k al ar = (show k) ++ ":" ++ al ++ "|" ++ ar+-- > intersectionWithKey f (fromList [(5, "a"), (3, "b")]) (fromList [(5, "A"), (7, "C")]) == singleton 5 "5:a|A"++intersectionWithKey :: (Key -> a -> b -> c) -> Word64Map a -> Word64Map b -> Word64Map c+intersectionWithKey f m1 m2+  = mergeWithKey' bin (\(Tip k1 x1) (Tip _k2 x2) -> Tip k1 $! f k1 x1 x2) (const Nil) (const Nil) m1 m2++{--------------------------------------------------------------------+  MergeWithKey+--------------------------------------------------------------------}++-- | \(O(n+m)\). A high-performance universal combining function. Using+-- 'mergeWithKey', all combining functions can be defined without any loss of+-- efficiency (with exception of 'union', 'difference' and 'intersection',+-- where sharing of some nodes is lost with 'mergeWithKey').+--+-- Please make sure you know what is going on when using 'mergeWithKey',+-- otherwise you can be surprised by unexpected code growth or even+-- corruption of the data structure.+--+-- When 'mergeWithKey' is given three arguments, it is inlined to the call+-- site. You should therefore use 'mergeWithKey' only to define your custom+-- combining functions. For example, you could define 'unionWithKey',+-- 'differenceWithKey' and 'intersectionWithKey' as+--+-- > myUnionWithKey f m1 m2 = mergeWithKey (\k x1 x2 -> Just (f k x1 x2)) id id m1 m2+-- > myDifferenceWithKey f m1 m2 = mergeWithKey f id (const empty) m1 m2+-- > myIntersectionWithKey f m1 m2 = mergeWithKey (\k x1 x2 -> Just (f k x1 x2)) (const empty) (const empty) m1 m2+--+-- When calling @'mergeWithKey' combine only1 only2@, a function combining two+-- 'Word64Map's is created, such that+--+-- * if a key is present in both maps, it is passed with both corresponding+--   values to the @combine@ function. Depending on the result, the key is either+--   present in the result with specified value, or is left out;+--+-- * a nonempty subtree present only in the first map is passed to @only1@ and+--   the output is added to the result;+--+-- * a nonempty subtree present only in the second map is passed to @only2@ and+--   the output is added to the result.+--+-- The @only1@ and @only2@ methods /must return a map with a subset (possibly empty) of the keys of the given map/.+-- The values can be modified arbitrarily.  Most common variants of @only1@ and+-- @only2@ are 'id' and @'const' 'empty'@, but for example @'map' f@ or+-- @'filterWithKey' f@ could be used for any @f@.++mergeWithKey :: (Key -> a -> b -> Maybe c) -> (Word64Map a -> Word64Map c) -> (Word64Map b -> Word64Map c)+             -> Word64Map a -> Word64Map b -> Word64Map c+mergeWithKey f g1 g2 = mergeWithKey' bin combine g1 g2+  where -- We use the lambda form to avoid non-exhaustive pattern matches warning.+        combine = \(Tip k1 x1) (Tip _k2 x2) -> case f k1 x1 x2 of Nothing -> Nil+                                                                  Just !x -> Tip k1 x+        {-# INLINE combine #-}+{-# INLINE mergeWithKey #-}++{--------------------------------------------------------------------+  Min\/Max+--------------------------------------------------------------------}++-- | \(O(\log n)\). Update the value at the minimal key.+--+-- > updateMinWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"3:b"), (5,"a")]+-- > updateMinWithKey (\ _ _ -> Nothing)                     (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"++updateMinWithKey :: (Key -> a -> Maybe a) -> Word64Map a -> Word64Map a+updateMinWithKey f t =+  case t of Bin p m l r | m < 0 -> binCheckRight p m l (go f r)+            _ -> go f t+  where+    go f' (Bin p m l r) = binCheckLeft p m (go f' l) r+    go f' (Tip k y) = case f' k y of+                        Just !y' -> Tip k y'+                        Nothing -> Nil+    go _ Nil = error "updateMinWithKey Nil"++-- | \(O(\log n)\). Update the value at the maximal key.+--+-- > updateMaxWithKey (\ k a -> Just ((show k) ++ ":" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3,"b"), (5,"5:a")]+-- > updateMaxWithKey (\ _ _ -> Nothing)                     (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"++updateMaxWithKey :: (Key -> a -> Maybe a) -> Word64Map a -> Word64Map a+updateMaxWithKey f t =+  case t of Bin p m l r | m < 0 -> binCheckLeft p m (go f l) r+            _ -> go f t+  where+    go f' (Bin p m l r) = binCheckRight p m l (go f' r)+    go f' (Tip k y) = case f' k y of+                        Just !y' -> Tip k y'+                        Nothing -> Nil+    go _ Nil = error "updateMaxWithKey Nil"++-- | \(O(\log n)\). Update the value at the maximal key.+--+-- > updateMax (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "b"), (5, "Xa")]+-- > updateMax (\ _ -> Nothing)         (fromList [(5,"a"), (3,"b")]) == singleton 3 "b"++updateMax :: (a -> Maybe a) -> Word64Map a -> Word64Map a+updateMax f = updateMaxWithKey (const f)++-- | \(O(\log n)\). Update the value at the minimal key.+--+-- > updateMin (\ a -> Just ("X" ++ a)) (fromList [(5,"a"), (3,"b")]) == fromList [(3, "Xb"), (5, "a")]+-- > updateMin (\ _ -> Nothing)         (fromList [(5,"a"), (3,"b")]) == singleton 5 "a"++updateMin :: (a -> Maybe a) -> Word64Map a -> Word64Map a+updateMin f = updateMinWithKey (const f)+++{--------------------------------------------------------------------+  Mapping+--------------------------------------------------------------------}+-- | \(O(n)\). Map a function over all values in the map.+--+-- > map (++ "x") (fromList [(5,"a"), (3,"b")]) == fromList [(3, "bx"), (5, "ax")]++map :: (a -> b) -> Word64Map a -> Word64Map b+map f = go+  where+    go (Bin p m l r) = Bin p m (go l) (go r)+    go (Tip k x)     = Tip k $! f x+    go Nil           = Nil++{-# NOINLINE [1] map #-}+{-# RULES+"map/map" forall f g xs . map f (map g xs) = map (\x -> f $! g x) xs+"map/mapL" forall f g xs . map f (L.map g xs) = map (\x -> f (g x)) xs+ #-}++-- | \(O(n)\). Map a function over all values in the map.+--+-- > let f key x = (show key) ++ ":" ++ x+-- > mapWithKey f (fromList [(5,"a"), (3,"b")]) == fromList [(3, "3:b"), (5, "5:a")]++mapWithKey :: (Key -> a -> b) -> Word64Map a -> Word64Map b+mapWithKey f t+  = case t of+      Bin p m l r -> Bin p m (mapWithKey f l) (mapWithKey f r)+      Tip k x     -> Tip k $! f k x+      Nil         -> Nil++-- Pay close attention to strictness here. We need to force the+-- intermediate result for map f . map g, and we need to refrain+-- from forcing it for map f . L.map g, etc.+--+-- TODO Consider moving map and mapWithKey to Word64Map.Internal so we can write+-- non-orphan RULES for things like L.map f (map g xs). We'd need a new function+-- for this, and we'd have to pay attention to simplifier phases. Something like+--+-- lsmap :: (b -> c) -> (a -> b) -> Word64Map a -> Word64Map c+-- lsmap _ _ Nil = Nil+-- lsmap f g (Tip k x) = let !gx = g x in Tip k (f gx)+-- lsmap f g (Bin p m l r) = Bin p m (lsmap f g l) (lsmap f g r)+{-# NOINLINE [1] mapWithKey #-}+{-# RULES+"mapWithKey/mapWithKey" forall f g xs . mapWithKey f (mapWithKey g xs) =+  mapWithKey (\k a -> f k $! g k a) xs+"mapWithKey/mapWithKeyL" forall f g xs . mapWithKey f (L.mapWithKey g xs) =+  mapWithKey (\k a -> f k (g k a)) xs+"mapWithKey/map" forall f g xs . mapWithKey f (map g xs) =+  mapWithKey (\k a -> f k $! g a) xs+"mapWithKey/mapL" forall f g xs . mapWithKey f (L.map g xs) =+  mapWithKey (\k a -> f k (g a)) xs+"map/mapWithKey" forall f g xs . map f (mapWithKey g xs) =+  mapWithKey (\k a -> f $! g k a) xs+"map/mapWithKeyL" forall f g xs . map f (L.mapWithKey g xs) =+  mapWithKey (\k a -> f (g k a)) xs+ #-}++-- | \(O(n)\).+-- @'traverseWithKey' f s == 'fromList' <$> 'traverse' (\(k, v) -> (,) k <$> f k v) ('toList' m)@+-- That is, behaves exactly like a regular 'traverse' except that the traversing+-- function also has access to the key associated with a value.+--+-- > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(1, 'a'), (5, 'e')]) == Just (fromList [(1, 'b'), (5, 'f')])+-- > traverseWithKey (\k v -> if odd k then Just (succ v) else Nothing) (fromList [(2, 'c')])           == Nothing+traverseWithKey :: Applicative t => (Key -> a -> t b) -> Word64Map a -> t (Word64Map b)+traverseWithKey f = go+  where+    go Nil = pure Nil+    go (Tip k v) = (\ !v' -> Tip k v') <$> f k v+    go (Bin p m l r)+      | m < 0     = liftA2 (flip (Bin p m)) (go r) (go l)+      | otherwise = liftA2 (Bin p m) (go l) (go r)+{-# INLINE traverseWithKey #-}++-- | \(O(n)\). Traverse keys\/values and collect the 'Just' results.+--+-- @since 0.6.4+traverseMaybeWithKey+  :: Applicative f => (Key -> a -> f (Maybe b)) -> Word64Map a -> f (Word64Map b)+traverseMaybeWithKey f = go+    where+    go Nil           = pure Nil+    go (Tip k x)     = maybe Nil (Tip k $!) <$> f k x+    go (Bin p m l r)+      | m < 0     = liftA2 (flip (bin p m)) (go r) (go l)+      | otherwise = liftA2 (bin p m) (go l) (go r)++-- | \(O(n)\). The function @'mapAccum'@ threads an accumulating+-- argument through the map in ascending order of keys.+--+-- > let f a b = (a ++ b, b ++ "X")+-- > mapAccum f "Everything: " (fromList [(5,"a"), (3,"b")]) == ("Everything: ba", fromList [(3, "bX"), (5, "aX")])++mapAccum :: (a -> b -> (a,c)) -> a -> Word64Map b -> (a,Word64Map c)+mapAccum f = mapAccumWithKey (\a' _ x -> f a' x)++-- | \(O(n)\). The function @'mapAccumWithKey'@ threads an accumulating+-- argument through the map in ascending order of keys.+--+-- > let f a k b = (a ++ " " ++ (show k) ++ "-" ++ b, b ++ "X")+-- > mapAccumWithKey f "Everything:" (fromList [(5,"a"), (3,"b")]) == ("Everything: 3-b 5-a", fromList [(3, "bX"), (5, "aX")])++mapAccumWithKey :: (a -> Key -> b -> (a,c)) -> a -> Word64Map b -> (a,Word64Map c)+mapAccumWithKey f a t+  = mapAccumL f a t++-- | \(O(n)\). The function @'mapAccumL'@ threads an accumulating+-- argument through the map in ascending order of keys.  Strict in+-- the accumulating argument and the both elements of the+-- result of the function.+mapAccumL :: (a -> Key -> b -> (a,c)) -> a -> Word64Map b -> (a,Word64Map c)+mapAccumL f0 a0 t0 = toPair $ go f0 a0 t0+  where+    go f a t+      = case t of+          Bin p m l r+            | m < 0 ->+                let (a1 :*: r') = go f a r+                    (a2 :*: l') = go f a1 l+                in (a2 :*: Bin p m l' r')+            | otherwise ->+                let (a1 :*: l') = go f a l+                    (a2 :*: r') = go f a1 r+                in (a2 :*: Bin p m l' r')+          Tip k x     -> let !(a',!x') = f a k x in (a' :*: Tip k x')+          Nil         -> (a :*: Nil)++-- | \(O(n)\). The function @'mapAccumRWithKey'@ threads an accumulating+-- argument through the map in descending order of keys.+mapAccumRWithKey :: (a -> Key -> b -> (a,c)) -> a -> Word64Map b -> (a,Word64Map c)+mapAccumRWithKey f0 a0 t0 = toPair $ go f0 a0 t0+  where+    go f a t+      = case t of+          Bin p m l r+            | m < 0 ->+              let (a1 :*: l') = go f a l+                  (a2 :*: r') = go f a1 r+              in (a2 :*: Bin p m l' r')+            | otherwise ->+              let (a1 :*: r') = go f a r+                  (a2 :*: l') = go f a1 l+              in (a2 :*: Bin p m l' r')+          Tip k x     -> let !(a',!x') = f a k x in (a' :*: Tip k x')+          Nil         -> (a :*: Nil)++-- | \(O(n \log n)\).+-- @'mapKeysWith' c f s@ is the map obtained by applying @f@ to each key of @s@.+--+-- The size of the result may be smaller if @f@ maps two or more distinct+-- keys to the same new key.  In this case the associated values will be+-- combined using @c@.+--+-- > mapKeysWith (++) (\ _ -> 1) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 1 "cdab"+-- > mapKeysWith (++) (\ _ -> 3) (fromList [(1,"b"), (2,"a"), (3,"d"), (4,"c")]) == singleton 3 "cdab"++mapKeysWith :: (a -> a -> a) -> (Key->Key) -> Word64Map a -> Word64Map a+mapKeysWith c f = fromListWith c . foldrWithKey (\k x xs -> (f k, x) : xs) []++{--------------------------------------------------------------------+  Filter+--------------------------------------------------------------------}+-- | \(O(n)\). Map values and collect the 'Just' results.+--+-- > let f x = if x == "a" then Just "new a" else Nothing+-- > mapMaybe f (fromList [(5,"a"), (3,"b")]) == singleton 5 "new a"++mapMaybe :: (a -> Maybe b) -> Word64Map a -> Word64Map b+mapMaybe f = mapMaybeWithKey (\_ x -> f x)++-- | \(O(n)\). Map keys\/values and collect the 'Just' results.+--+-- > let f k _ = if k < 5 then Just ("key : " ++ (show k)) else Nothing+-- > mapMaybeWithKey f (fromList [(5,"a"), (3,"b")]) == singleton 3 "key : 3"++mapMaybeWithKey :: (Key -> a -> Maybe b) -> Word64Map a -> Word64Map b+mapMaybeWithKey f (Bin p m l r)+  = bin p m (mapMaybeWithKey f l) (mapMaybeWithKey f r)+mapMaybeWithKey f (Tip k x) = case f k x of+  Just !y  -> Tip k y+  Nothing -> Nil+mapMaybeWithKey _ Nil = Nil++-- | \(O(n)\). Map values and separate the 'Left' and 'Right' results.+--+-- > let f a = if a < "c" then Left a else Right a+-- > mapEither f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])+-- >     == (fromList [(3,"b"), (5,"a")], fromList [(1,"x"), (7,"z")])+-- >+-- > mapEither (\ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])+-- >     == (empty, fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])++mapEither :: (a -> Either b c) -> Word64Map a -> (Word64Map b, Word64Map c)+mapEither f m+  = mapEitherWithKey (\_ x -> f x) m++-- | \(O(n)\). Map keys\/values and separate the 'Left' and 'Right' results.+--+-- > let f k a = if k < 5 then Left (k * 2) else Right (a ++ a)+-- > mapEitherWithKey f (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])+-- >     == (fromList [(1,2), (3,6)], fromList [(5,"aa"), (7,"zz")])+-- >+-- > mapEitherWithKey (\_ a -> Right a) (fromList [(5,"a"), (3,"b"), (1,"x"), (7,"z")])+-- >     == (empty, fromList [(1,"x"), (3,"b"), (5,"a"), (7,"z")])++mapEitherWithKey :: (Key -> a -> Either b c) -> Word64Map a -> (Word64Map b, Word64Map c)+mapEitherWithKey f0 t0 = toPair $ go f0 t0+  where+    go f (Bin p m l r)+      = bin p m l1 r1 :*: bin p m l2 r2+      where+        (l1 :*: l2) = go f l+        (r1 :*: r2) = go f r+    go f (Tip k x) = case f k x of+      Left !y  -> (Tip k y :*: Nil)+      Right !z -> (Nil :*: Tip k z)+    go _ Nil = (Nil :*: Nil)++{--------------------------------------------------------------------+  Conversions+--------------------------------------------------------------------}++-- | \(O(n)\). Build a map from a set of keys and a function which for each key+-- computes its value.+--+-- > fromSet (\k -> replicate k 'a') (Data.Word64Set.fromList [3, 5]) == fromList [(5,"aaaaa"), (3,"aaa")]+-- > fromSet undefined Data.Word64Set.empty == empty++fromSet :: (Key -> a) -> Word64Set.Word64Set -> Word64Map a+fromSet _ Word64Set.Nil = Nil+fromSet f (Word64Set.Bin p m l r) = Bin p m (fromSet f l) (fromSet f r)+fromSet f (Word64Set.Tip kx bm) = buildTree f kx bm (Word64Set.suffixBitMask + 1)+  where -- This is slightly complicated, as we to convert the dense+        -- representation of Word64Set into tree representation of Word64Map.+        --+        -- We are given a nonzero bit mask 'bmask' of 'bits' bits with prefix 'prefix'.+        -- We split bmask into halves corresponding to left and right subtree.+        -- If they are both nonempty, we create a Bin node, otherwise exactly+        -- one of them is nonempty and we construct the Word64Map from that half.+        buildTree g !prefix !bmask bits = case bits of+          0 -> Tip prefix $! g prefix+          _ -> case intFromNat ((natFromInt bits) `shiftRL` 1) of+                 bits2 | bmask .&. ((1 `shiftLL` fromIntegral bits2) - 1) == 0 ->+                           buildTree g (prefix + bits2) (bmask `shiftRL` fromIntegral bits2) bits2+                       | (bmask `shiftRL` fromIntegral bits2) .&. ((1 `shiftLL` fromIntegral bits2) - 1) == 0 ->+                           buildTree g prefix bmask bits2+                       | otherwise ->+                           Bin prefix bits2 (buildTree g prefix bmask bits2) (buildTree g (prefix + bits2) (bmask `shiftRL` fromIntegral bits2) bits2)++{--------------------------------------------------------------------+  Lists+--------------------------------------------------------------------}+-- | \(O(n \min(n,W))\). Create a map from a list of key\/value pairs.+--+-- > fromList [] == empty+-- > fromList [(5,"a"), (3,"b"), (5, "c")] == fromList [(5,"c"), (3,"b")]+-- > fromList [(5,"c"), (3,"b"), (5, "a")] == fromList [(5,"a"), (3,"b")]++fromList :: [(Key,a)] -> Word64Map a+fromList xs+  = Foldable.foldl' ins empty xs+  where+    ins t (k,x)  = insert k x t++-- | \(O(n \min(n,W))\). Create a map from a list of key\/value pairs with a combining function. See also 'fromAscListWith'.+--+-- > fromListWith (++) [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"a")] == fromList [(3, "ab"), (5, "aba")]+-- > fromListWith (++) [] == empty++fromListWith :: (a -> a -> a) -> [(Key,a)] -> Word64Map a+fromListWith f xs+  = fromListWithKey (\_ x y -> f x y) xs++-- | \(O(n \min(n,W))\). Build a map from a list of key\/value pairs with a combining function. See also fromAscListWithKey'.+--+-- > let f key new_value old_value = show key ++ ":" ++ new_value ++ "|" ++ old_value+-- > fromListWithKey f [(5,"a"), (5,"b"), (3,"b"), (3,"a"), (5,"c")] == fromList [(3, "3:a|b"), (5, "5:c|5:b|a")]+-- > fromListWithKey f [] == empty++fromListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> Word64Map a+fromListWithKey f xs+  = Foldable.foldl' ins empty xs+  where+    ins t (k,x) = insertWithKey f k x t++-- | \(O(n)\). Build a map from a list of key\/value pairs where+-- the keys are in ascending order.+--+-- > fromAscList [(3,"b"), (5,"a")]          == fromList [(3, "b"), (5, "a")]+-- > fromAscList [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "b")]++fromAscList :: [(Key,a)] -> Word64Map a+fromAscList = fromMonoListWithKey Nondistinct (\_ x _ -> x)+{-# NOINLINE fromAscList #-}++-- | \(O(n)\). Build a map from a list of key\/value pairs where+-- the keys are in ascending order, with a combining function on equal keys.+-- /The precondition (input list is ascending) is not checked./+--+-- > fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "ba")]++fromAscListWith :: (a -> a -> a) -> [(Key,a)] -> Word64Map a+fromAscListWith f = fromMonoListWithKey Nondistinct (\_ x y -> f x y)+{-# NOINLINE fromAscListWith #-}++-- | \(O(n)\). Build a map from a list of key\/value pairs where+-- the keys are in ascending order, with a combining function on equal keys.+-- /The precondition (input list is ascending) is not checked./+--+-- > fromAscListWith (++) [(3,"b"), (5,"a"), (5,"b")] == fromList [(3, "b"), (5, "ba")]++fromAscListWithKey :: (Key -> a -> a -> a) -> [(Key,a)] -> Word64Map a+fromAscListWithKey f = fromMonoListWithKey Nondistinct f+{-# NOINLINE fromAscListWithKey #-}++-- | \(O(n)\). Build a map from a list of key\/value pairs where+-- the keys are in ascending order and all distinct.+-- /The precondition (input list is strictly ascending) is not checked./+--+-- > fromDistinctAscList [(3,"b"), (5,"a")] == fromList [(3, "b"), (5, "a")]++fromDistinctAscList :: [(Key,a)] -> Word64Map a+fromDistinctAscList = fromMonoListWithKey Distinct (\_ x _ -> x)+{-# NOINLINE fromDistinctAscList #-}++-- | \(O(n)\). Build a map from a list of key\/value pairs with monotonic keys+-- and a combining function.+--+-- The precise conditions under which this function works are subtle:+-- For any branch mask, keys with the same prefix w.r.t. the branch+-- mask must occur consecutively in the list.++fromMonoListWithKey :: Distinct -> (Key -> a -> a -> a) -> [(Key,a)] -> Word64Map a+fromMonoListWithKey distinct f = go+  where+    go []              = Nil+    go ((kx,vx) : zs1) = addAll' kx vx zs1++    -- `addAll'` collects all keys equal to `kx` into a single value,+    -- and then proceeds with `addAll`.+    addAll' !kx vx []+        = Tip kx $! vx+    addAll' !kx vx ((ky,vy) : zs)+        | Nondistinct <- distinct, kx == ky+        = let !v = f kx vy vx in addAll' ky v zs+        -- inlined: | otherwise = addAll kx (Tip kx $! vx) (ky : zs)+        | m <- branchMask kx ky+        , Inserted ty zs' <- addMany' m ky vy zs+        = addAll kx (linkWithMask m ky ty {-kx-} (Tip kx $! vx)) zs'++    -- for `addAll` and `addMany`, kx is /a/ key inside the tree `tx`+    -- `addAll` consumes the rest of the list, adding to the tree `tx`+    addAll !_kx !tx []+        = tx+    addAll !kx !tx ((ky,vy) : zs)+        | m <- branchMask kx ky+        , Inserted ty zs' <- addMany' m ky vy zs+        = addAll kx (linkWithMask m ky ty {-kx-} tx) zs'++    -- `addMany'` is similar to `addAll'`, but proceeds with `addMany'`.+    addMany' !_m !kx vx []+        = Inserted (Tip kx $! vx) []+    addMany' !m !kx vx zs0@((ky,vy) : zs)+        | Nondistinct <- distinct, kx == ky+        = let !v = f kx vy vx in addMany' m ky v zs+        -- inlined: | otherwise = addMany m kx (Tip kx $! vx) (ky : zs)+        | mask kx m /= mask ky m+        = Inserted (Tip kx $! vx) zs0+        | mxy <- branchMask kx ky+        , Inserted ty zs' <- addMany' mxy ky vy zs+        = addMany m kx (linkWithMask mxy ky ty {-kx-} (Tip kx $! vx)) zs'++    -- `addAll` adds to `tx` all keys whose prefix w.r.t. `m` agrees with `kx`.+    addMany !_m !_kx tx []+        = Inserted tx []+    addMany !m !kx tx zs0@((ky,vy) : zs)+        | mask kx m /= mask ky m+        = Inserted tx zs0+        | mxy <- branchMask kx ky+        , Inserted ty zs' <- addMany' mxy ky vy zs+        = addMany m kx (linkWithMask mxy ky ty {-kx-} tx) zs'+{-# INLINE fromMonoListWithKey #-}++data Inserted a = Inserted !(Word64Map a) ![(Key,a)]++data Distinct = Distinct | Nondistinct
+ GHC/Data/Word64Set.hs view
@@ -0,0 +1,160 @@++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Word64Set+-- Copyright   :  (c) Daan Leijen 2002+--                (c) Joachim Breitner 2011+-- License     :  BSD-style+-- Maintainer  :  libraries@haskell.org+-- Portability :  portable+--+--+-- = Finite Int Sets+--+-- The @'Word64Set'@ type represents a set of elements of type @Int@.+--+-- For a walkthrough of the most commonly used functions see their+-- <https://haskell-containers.readthedocs.io/en/latest/set.html sets introduction>.+--+-- These modules are intended to be imported qualified, to avoid name+-- clashes with Prelude functions, e.g.+--+-- >  import Data.Word64Set (Word64Set)+-- >  import qualified Data.Word64Set as Word64Set+--+--+-- == Performance information+--+-- Many operations have a worst-case complexity of \(O(\min(n,W))\).+-- This means that the operation can become linear in the number of+-- elements with a maximum of \(W\) -- the number of bits in an 'Int'+-- (32 or 64).+--+--+-- == Implementation+--+-- The implementation is based on /big-endian patricia trees/.  This data+-- structure performs especially well on binary operations like 'union'+-- and 'intersection'.  However, my benchmarks show that it is also+-- (much) faster on insertions and deletions when compared to a generic+-- size-balanced set implementation (see "Data.Set").+--+--    * Chris Okasaki and Andy Gill,  \"/Fast Mergeable Integer Maps/\",+--      Workshop on ML, September 1998, pages 77-86,+--      <http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.37.5452>+--+--    * D.R. Morrison, \"/PATRICIA -- Practical Algorithm To Retrieve Information Coded In Alphanumeric/\",+--      Journal of the ACM, 15(4), October 1968, pages 514-534.+--+-- Additionally, this implementation places bitmaps in the leaves of the tree.+-- Their size is the natural size of a machine word (32 or 64 bits) and greatly+-- reduces the memory footprint and execution times for dense sets, e.g. sets+-- where it is likely that many values lie close to each other. The asymptotics+-- are not affected by this optimization.+--+-----------------------------------------------------------------------------++module GHC.Data.Word64Set (+            -- * Strictness properties+            -- $strictness++            -- * Set type+              Word64Set          -- instance Eq,Show+            , Key++            -- * Construction+            , empty+            , singleton+            , fromList+            , fromAscList+            , fromDistinctAscList++            -- * Insertion+            , insert++            -- * Deletion+            , delete++            -- * Generalized insertion/deletion+            , alterF++            -- * Query+            , member+            , notMember+            , lookupLT+            , lookupGT+            , lookupLE+            , lookupGE+            , WS.null+            , size+            , isSubsetOf+            , isProperSubsetOf+            , disjoint++            -- * Combine+            , union+            , unions+            , difference+            , (\\)+            , intersection++            -- * Filter+            , WS.filter+            , partition++            , takeWhileAntitone+            , dropWhileAntitone+            , spanAntitone++            , split+            , splitMember+            , splitRoot++            -- * Map+            , WS.map+            , mapMonotonic++            -- * Folds+            , WS.foldr+            , WS.foldl+            -- ** Strict folds+            , foldr'+            , foldl'+            -- ** Legacy folds+            , fold++            -- * Min\/Max+            , findMin+            , findMax+            , deleteMin+            , deleteMax+            , deleteFindMin+            , deleteFindMax+            , maxView+            , minView++            -- * Conversion++            -- ** List+            , elems+            , toList+            , toAscList+            , toDescList++            -- * Debugging+            , showTree+            , showTreeWith++            ) where++import GHC.Data.Word64Set.Internal as WS++-- $strictness+--+-- This module satisfies the following strictness property:+--+-- * Key arguments are evaluated to WHNF+--+-- Here are some examples that illustrate the property:+--+-- > delete undefined s  ==  undefined
+ GHC/Data/Word64Set/Internal.hs view
@@ -0,0 +1,1613 @@+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE TypeFamilies #-}++{-# OPTIONS_HADDOCK not-home #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Data.Word64Set.Internal+-- Copyright   :  (c) Daan Leijen 2002+--                (c) Joachim Breitner 2011+-- License     :  BSD-style+-- Maintainer  :  libraries@haskell.org+-- Portability :  portable+--+-- = WARNING+--+-- This module is considered __internal__.+--+-- The Package Versioning Policy __does not apply__.+--+-- The contents of this module may change __in any way whatsoever__+-- and __without any warning__ between minor versions of this package.+--+-- Authors importing this module are expected to track development+-- closely.+--+-- = Description+--+-- An efficient implementation of integer sets.+--+-- These modules are intended to be imported qualified, to avoid name+-- clashes with Prelude functions, e.g.+--+-- >  import Data.Word64Set (Word64Set)+-- >  import qualified Data.Word64Set as Word64Set+--+-- The implementation is based on /big-endian patricia trees/.  This data+-- structure performs especially well on binary operations like 'union'+-- and 'intersection'.  However, my benchmarks show that it is also+-- (much) faster on insertions and deletions when compared to a generic+-- size-balanced set implementation (see "Data.Set").+--+--    * Chris Okasaki and Andy Gill,  \"/Fast Mergeable Integer Maps/\",+--      Workshop on ML, September 1998, pages 77-86,+--      <http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.37.5452>+--+--    * D.R. Morrison, \"/PATRICIA -- Practical Algorithm To Retrieve Information Coded In Alphanumeric/\",+--      Journal of the ACM, 15(4), October 1968, pages 514-534.+--+-- Additionally, this implementation places bitmaps in the leaves of the tree.+-- Their size is the natural size of a machine word (32 or 64 bits) and greatly+-- reduce memory footprint and execution times for dense sets, e.g. sets where+-- it is likely that many values lie close to each other. The asymptotics are+-- not affected by this optimization.+--+-- Many operations have a worst-case complexity of \(O(\min(n,W))\).+-- This means that the operation can become linear in the number of+-- elements with a maximum of \(W\) -- the number of bits in an 'Int'+-- (32 or 64).+--+-- @since 0.5.9+-----------------------------------------------------------------------------++-- [Note: INLINE bit fiddling]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- It is essential that the bit fiddling functions like mask, zero, branchMask+-- etc are inlined. If they do not, the memory allocation skyrockets. The GHC+-- usually gets it right, but it is disastrous if it does not. Therefore we+-- explicitly mark these functions INLINE.+++-- [Note: Local 'go' functions and capturing]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- Care must be taken when using 'go' function which captures an argument.+-- Sometimes (for example when the argument is passed to a data constructor,+-- as in insert), GHC heap-allocates more than necessary. Therefore C-- code+-- must be checked for increased allocation when creating and modifying such+-- functions.+++-- [Note: Order of constructors]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- The order of constructors of Word64Set matters when considering performance.+-- Currently in GHC 7.0, when type has 3 constructors, they are matched from+-- the first to the last -- the best performance is achieved when the+-- constructors are ordered by frequency.+-- On GHC 7.0, reordering constructors from Nil | Tip | Bin to Bin | Tip | Nil+-- improves the benchmark by circa 10%.++module GHC.Data.Word64Set.Internal (+    -- * Set type+      Word64Set(..), Key -- instance Eq,Show+    , Prefix, Mask, BitMap++    -- * Operators+    , (\\)++    -- * Query+    , null+    , size+    , member+    , notMember+    , lookupLT+    , lookupGT+    , lookupLE+    , lookupGE+    , isSubsetOf+    , isProperSubsetOf+    , disjoint++    -- * Construction+    , empty+    , singleton+    , insert+    , delete+    , alterF++    -- * Combine+    , union+    , unions+    , difference+    , intersection++    -- * Filter+    , filter+    , partition++    , takeWhileAntitone+    , dropWhileAntitone+    , spanAntitone++    , split+    , splitMember+    , splitRoot++    -- * Map+    , map+    , mapMonotonic++    -- * Folds+    , foldr+    , foldl+    -- ** Strict folds+    , foldr'+    , foldl'+    -- ** Legacy folds+    , fold++    -- * Min\/Max+    , findMin+    , findMax+    , deleteMin+    , deleteMax+    , deleteFindMin+    , deleteFindMax+    , maxView+    , minView++    -- * Conversion++    -- ** List+    , elems+    , toList+    , fromList++    -- ** Ordered list+    , toAscList+    , toDescList+    , fromAscList+    , fromDistinctAscList++    -- * Debugging+    , showTree+    , showTreeWith++    -- * Internals+    , match+    , suffixBitMask+    , prefixBitMask+    , bitmapOf+    , zero+    ) where++import Control.Applicative (Const(..))+import Control.DeepSeq (NFData(rnf))+import Data.Bits+import qualified Data.List as List+import Data.Maybe (fromMaybe)+import Data.Semigroup (Semigroup(stimes, (<>)), stimesIdempotentMonoid)+import GHC.Prelude.Basic hiding+  (filter, foldr, foldl, foldl', null, map)+import Data.Word ( Word64 )++import GHC.Utils.Containers.Internal.BitUtil+import GHC.Utils.Containers.Internal.StrictPair++import Data.Data (Data(..), Constr, mkConstr, constrIndex, DataType, mkDataType)+import qualified Data.Data+import Text.Read++import qualified GHC.Exts++import Data.Functor.Identity (Identity(..))++infixl 9 \\{-This comment teaches CPP correct behaviour -}++-- A "Nat" is a 64 bit machine word+type Nat = Word64++natFromInt :: Word64 -> Nat+natFromInt = id+{-# INLINE natFromInt #-}++intFromNat :: Nat -> Word64+intFromNat = id+{-# INLINE intFromNat #-}++{--------------------------------------------------------------------+  Operators+--------------------------------------------------------------------}+-- | \(O(n+m)\). See 'difference'.+(\\) :: Word64Set -> Word64Set -> Word64Set+m1 \\ m2 = difference m1 m2++{--------------------------------------------------------------------+  Types+--------------------------------------------------------------------}++-- | A set of integers.++-- See Note: Order of constructors+data Word64Set = Bin {-# UNPACK #-} !Prefix {-# UNPACK #-} !Mask !Word64Set !Word64Set+-- Invariant: Nil is never found as a child of Bin.+-- Invariant: The Mask is a power of 2.  It is the largest bit position at which+--            two elements of the set differ.+-- Invariant: Prefix is the common high-order bits that all elements share to+--            the left of the Mask bit.+-- Invariant: In Bin prefix mask left right, left consists of the elements that+--            don't have the mask bit set; right is all the elements that do.+            | Tip {-# UNPACK #-} !Prefix {-# UNPACK #-} !BitMap+-- Invariant: The Prefix is zero for the last 6 bits. The values of the set+--            represented by a tip are the prefix plus the indices of the set+--            bits in the bit map.+            | Nil++-- A number stored in a set is stored as+-- * Prefix (all but last 6 bits) and+-- * BitMap (last 6 bits stored as a bitmask)+--   Last 6 bits are called a Suffix.++type Prefix = Word64+type Mask   = Word64+type BitMap = Word64+type Key    = Word64++instance Monoid Word64Set where+    mempty  = empty+    mconcat = unions+    mappend = (<>)++-- | @since 0.5.7+instance Semigroup Word64Set where+    (<>)    = union+    stimes  = stimesIdempotentMonoid+++{--------------------------------------------------------------------+  A Data instance+--------------------------------------------------------------------}++-- This instance preserves data abstraction at the cost of inefficiency.+-- We provide limited reflection services for the sake of data abstraction.++instance Data Word64Set where+  gfoldl f z is = z fromList `f` (toList is)+  toConstr _     = fromListConstr+  gunfold k z c  = case constrIndex c of+    1 -> k (z fromList)+    _ -> error "gunfold"+  dataTypeOf _   = intSetDataType++fromListConstr :: Constr+fromListConstr = mkConstr intSetDataType "fromList" [] Data.Data.Prefix++intSetDataType :: DataType+intSetDataType = mkDataType "Data.Word64Set.Internal.Word64Set" [fromListConstr]+++{--------------------------------------------------------------------+  Query+--------------------------------------------------------------------}+-- | \(O(1)\). Is the set empty?+null :: Word64Set -> Bool+null Nil = True+null _   = False+{-# INLINE null #-}++-- | \(O(n)\). Cardinality of the set.+size :: Word64Set -> Int+size = go 0+  where+    go !acc (Bin _ _ l r) = go (go acc l) r+    go acc (Tip _ bm) = acc + bitcount 0 bm+    go acc Nil = acc++-- | \(O(\min(n,W))\). Is the value a member of the set?++-- See Note: Local 'go' functions and capturing.+member :: Key -> Word64Set -> Bool+member !x = go+  where+    go (Bin p m l r)+      | nomatch x p m = False+      | zero x m      = go l+      | otherwise     = go r+    go (Tip y bm) = prefixOf x == y && bitmapOf x .&. bm /= 0+    go Nil = False++-- | \(O(\min(n,W))\). Is the element not in the set?+notMember :: Key -> Word64Set -> Bool+notMember k = not . member k++-- | \(O(\min(n,W))\). Find largest element smaller than the given one.+--+-- > lookupLT 3 (fromList [3, 5]) == Nothing+-- > lookupLT 5 (fromList [3, 5]) == Just 3++-- See Note: Local 'go' functions and capturing.+lookupLT :: Key -> Word64Set -> Maybe Key+lookupLT !x t = case t of+    Bin _ m l r | m < 0 -> if x >= 0 then go r l else go Nil r+    _ -> go Nil t+  where+    go def (Bin p m l r) | nomatch x p m = if x < p then unsafeFindMax def else unsafeFindMax r+                         | zero x m  = go def l+                         | otherwise = go l r+    go def (Tip kx bm) | prefixOf x > kx = Just $ kx + highestBitSet bm+                       | prefixOf x == kx && maskLT /= 0 = Just $ kx + highestBitSet maskLT+                       | otherwise = unsafeFindMax def+                       where maskLT = (bitmapOf x - 1) .&. bm+    go def Nil = unsafeFindMax def+++-- | \(O(\min(n,W))\). Find smallest element greater than the given one.+--+-- > lookupGT 4 (fromList [3, 5]) == Just 5+-- > lookupGT 5 (fromList [3, 5]) == Nothing++-- See Note: Local 'go' functions and capturing.+lookupGT :: Key -> Word64Set -> Maybe Key+lookupGT !x t = case t of+    Bin _ m l r | m < 0 -> if x >= 0 then go Nil l else go l r+    _ -> go Nil t+  where+    go def (Bin p m l r) | nomatch x p m = if x < p then unsafeFindMin l else unsafeFindMin def+                         | zero x m  = go r l+                         | otherwise = go def r+    go def (Tip kx bm) | prefixOf x < kx = Just $ kx + lowestBitSet bm+                       | prefixOf x == kx && maskGT /= 0 = Just $ kx + lowestBitSet maskGT+                       | otherwise = unsafeFindMin def+                       where maskGT = (- ((bitmapOf x) `shiftLL` 1)) .&. bm+    go def Nil = unsafeFindMin def+++-- | \(O(\min(n,W))\). Find largest element smaller or equal to the given one.+--+-- > lookupLE 2 (fromList [3, 5]) == Nothing+-- > lookupLE 4 (fromList [3, 5]) == Just 3+-- > lookupLE 5 (fromList [3, 5]) == Just 5++-- See Note: Local 'go' functions and capturing.+lookupLE :: Key -> Word64Set -> Maybe Key+lookupLE !x t = case t of+    Bin _ m l r | m < 0 -> if x >= 0 then go r l else go Nil r+    _ -> go Nil t+  where+    go def (Bin p m l r) | nomatch x p m = if x < p then unsafeFindMax def else unsafeFindMax r+                         | zero x m  = go def l+                         | otherwise = go l r+    go def (Tip kx bm) | prefixOf x > kx = Just $ kx + highestBitSet bm+                       | prefixOf x == kx && maskLE /= 0 = Just $ kx + highestBitSet maskLE+                       | otherwise = unsafeFindMax def+                       where maskLE = (((bitmapOf x) `shiftLL` 1) - 1) .&. bm+    go def Nil = unsafeFindMax def+++-- | \(O(\min(n,W))\). Find smallest element greater or equal to the given one.+--+-- > lookupGE 3 (fromList [3, 5]) == Just 3+-- > lookupGE 4 (fromList [3, 5]) == Just 5+-- > lookupGE 6 (fromList [3, 5]) == Nothing++-- See Note: Local 'go' functions and capturing.+lookupGE :: Key -> Word64Set -> Maybe Key+lookupGE !x t = case t of+    Bin _ m l r | m < 0 -> if x >= 0 then go Nil l else go l r+    _ -> go Nil t+  where+    go def (Bin p m l r) | nomatch x p m = if x < p then unsafeFindMin l else unsafeFindMin def+                         | zero x m  = go r l+                         | otherwise = go def r+    go def (Tip kx bm) | prefixOf x < kx = Just $ kx + lowestBitSet bm+                       | prefixOf x == kx && maskGE /= 0 = Just $ kx + lowestBitSet maskGE+                       | otherwise = unsafeFindMin def+                       where maskGE = (- (bitmapOf x)) .&. bm+    go def Nil = unsafeFindMin def++++-- Helper function for lookupGE and lookupGT. It assumes that if a Bin node is+-- given, it has m > 0.+unsafeFindMin :: Word64Set -> Maybe Key+unsafeFindMin Nil = Nothing+unsafeFindMin (Tip kx bm) = Just $ kx + lowestBitSet bm+unsafeFindMin (Bin _ _ l _) = unsafeFindMin l++-- Helper function for lookupLE and lookupLT. It assumes that if a Bin node is+-- given, it has m > 0.+unsafeFindMax :: Word64Set -> Maybe Key+unsafeFindMax Nil = Nothing+unsafeFindMax (Tip kx bm) = Just $ kx + highestBitSet bm+unsafeFindMax (Bin _ _ _ r) = unsafeFindMax r++{--------------------------------------------------------------------+  Construction+--------------------------------------------------------------------}+-- | \(O(1)\). The empty set.+empty :: Word64Set+empty+  = Nil+{-# INLINE empty #-}++-- | \(O(1)\). A set of one element.+singleton :: Key -> Word64Set+singleton x+  = Tip (prefixOf x) (bitmapOf x)+{-# INLINE singleton #-}++{--------------------------------------------------------------------+  Insert+--------------------------------------------------------------------}+-- | \(O(\min(n,W))\). Add a value to the set. There is no left- or right bias for+-- Word64Sets.+insert :: Key -> Word64Set -> Word64Set+insert !x = insertBM (prefixOf x) (bitmapOf x)++-- Helper function for insert and union.+insertBM :: Prefix -> BitMap -> Word64Set -> Word64Set+insertBM !kx !bm t@(Bin p m l r)+  | nomatch kx p m = link kx (Tip kx bm) p t+  | zero kx m      = Bin p m (insertBM kx bm l) r+  | otherwise      = Bin p m l (insertBM kx bm r)+insertBM kx bm t@(Tip kx' bm')+  | kx' == kx = Tip kx' (bm .|. bm')+  | otherwise = link kx (Tip kx bm) kx' t+insertBM kx bm Nil = Tip kx bm++-- | \(O(\min(n,W))\). Delete a value in the set. Returns the+-- original set when the value was not present.+delete :: Key -> Word64Set -> Word64Set+delete !x = deleteBM (prefixOf x) (bitmapOf x)++-- Deletes all values mentioned in the BitMap from the set.+-- Helper function for delete and difference.+deleteBM :: Prefix -> BitMap -> Word64Set -> Word64Set+deleteBM !kx !bm t@(Bin p m l r)+  | nomatch kx p m = t+  | zero kx m      = bin p m (deleteBM kx bm l) r+  | otherwise      = bin p m l (deleteBM kx bm r)+deleteBM kx bm t@(Tip kx' bm')+  | kx' == kx = tip kx (bm' .&. complement bm)+  | otherwise = t+deleteBM _ _ Nil = Nil++-- | \(O(\min(n,W))\). @('alterF' f x s)@ can delete or insert @x@ in @s@ depending+-- on whether it is already present in @s@.+--+-- In short:+--+-- @+-- 'member' x \<$\> 'alterF' f x s = f ('member' x s)+-- @+--+-- Note: 'alterF' is a variant of the @at@ combinator from "Control.Lens.At".+--+-- @since 0.6.3.1+alterF :: Functor f => (Bool -> f Bool) -> Key -> Word64Set -> f Word64Set+alterF f k s = fmap choose (f member_)+  where+    member_ = member k s++    (inserted, deleted)+      | member_   = (s         , delete k s)+      | otherwise = (insert k s, s         )++    choose True  = inserted+    choose False = deleted+{-# INLINABLE [2] alterF #-}++{-# RULES+"alterF/Const" forall k (f :: Bool -> Const a Bool) . alterF f k = \s -> Const . getConst . f $ member k s+ #-}++{-# SPECIALIZE alterF :: (Bool -> Identity Bool) -> Key -> Word64Set -> Identity Word64Set #-}++{--------------------------------------------------------------------+  Union+--------------------------------------------------------------------}+-- | The union of a list of sets.++{-# INLINABLE unions #-}+unions :: [Word64Set] -> Word64Set+unions = List.foldl' union empty++-- | \(O(n+m)\). The union of two sets.+union :: Word64Set -> Word64Set -> Word64Set+union t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)+  | shorter m1 m2  = union1+  | shorter m2 m1  = union2+  | p1 == p2       = Bin p1 m1 (union l1 l2) (union r1 r2)+  | otherwise      = link p1 t1 p2 t2+  where+    union1  | nomatch p2 p1 m1  = link p1 t1 p2 t2+            | zero p2 m1        = Bin p1 m1 (union l1 t2) r1+            | otherwise         = Bin p1 m1 l1 (union r1 t2)++    union2  | nomatch p1 p2 m2  = link p1 t1 p2 t2+            | zero p1 m2        = Bin p2 m2 (union t1 l2) r2+            | otherwise         = Bin p2 m2 l2 (union t1 r2)++union t@(Bin _ _ _ _) (Tip kx bm) = insertBM kx bm t+union t@(Bin _ _ _ _) Nil = t+union (Tip kx bm) t = insertBM kx bm t+union Nil t = t+++{--------------------------------------------------------------------+  Difference+--------------------------------------------------------------------}+-- | \(O(n+m)\). Difference between two sets.+difference :: Word64Set -> Word64Set -> Word64Set+difference t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)+  | shorter m1 m2  = difference1+  | shorter m2 m1  = difference2+  | p1 == p2       = bin p1 m1 (difference l1 l2) (difference r1 r2)+  | otherwise      = t1+  where+    difference1 | nomatch p2 p1 m1  = t1+                | zero p2 m1        = bin p1 m1 (difference l1 t2) r1+                | otherwise         = bin p1 m1 l1 (difference r1 t2)++    difference2 | nomatch p1 p2 m2  = t1+                | zero p1 m2        = difference t1 l2+                | otherwise         = difference t1 r2++difference t@(Bin _ _ _ _) (Tip kx bm) = deleteBM kx bm t+difference t@(Bin _ _ _ _) Nil = t++difference t1@(Tip kx bm) t2 = differenceTip t2+  where differenceTip (Bin p2 m2 l2 r2) | nomatch kx p2 m2 = t1+                                        | zero kx m2 = differenceTip l2+                                        | otherwise = differenceTip r2+        differenceTip (Tip kx2 bm2) | kx == kx2 = tip kx (bm .&. complement bm2)+                                    | otherwise = t1+        differenceTip Nil = t1++difference Nil _     = Nil++++{--------------------------------------------------------------------+  Intersection+--------------------------------------------------------------------}+-- | \(O(n+m)\). The intersection of two sets.+intersection :: Word64Set -> Word64Set -> Word64Set+intersection t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)+  | shorter m1 m2  = intersection1+  | shorter m2 m1  = intersection2+  | p1 == p2       = bin p1 m1 (intersection l1 l2) (intersection r1 r2)+  | otherwise      = Nil+  where+    intersection1 | nomatch p2 p1 m1  = Nil+                  | zero p2 m1        = intersection l1 t2+                  | otherwise         = intersection r1 t2++    intersection2 | nomatch p1 p2 m2  = Nil+                  | zero p1 m2        = intersection t1 l2+                  | otherwise         = intersection t1 r2++intersection t1@(Bin _ _ _ _) (Tip kx2 bm2) = intersectBM t1+  where intersectBM (Bin p1 m1 l1 r1) | nomatch kx2 p1 m1 = Nil+                                      | zero kx2 m1       = intersectBM l1+                                      | otherwise         = intersectBM r1+        intersectBM (Tip kx1 bm1) | kx1 == kx2 = tip kx1 (bm1 .&. bm2)+                                  | otherwise = Nil+        intersectBM Nil = Nil++intersection (Bin _ _ _ _) Nil = Nil++intersection (Tip kx1 bm1) t2 = intersectBM t2+  where intersectBM (Bin p2 m2 l2 r2) | nomatch kx1 p2 m2 = Nil+                                      | zero kx1 m2       = intersectBM l2+                                      | otherwise         = intersectBM r2+        intersectBM (Tip kx2 bm2) | kx1 == kx2 = tip kx1 (bm1 .&. bm2)+                                  | otherwise = Nil+        intersectBM Nil = Nil++intersection Nil _ = Nil++{--------------------------------------------------------------------+  Subset+--------------------------------------------------------------------}+-- | \(O(n+m)\). Is this a proper subset? (ie. a subset but not equal).+isProperSubsetOf :: Word64Set -> Word64Set -> Bool+isProperSubsetOf t1 t2+  = case subsetCmp t1 t2 of+      LT -> True+      _  -> False++subsetCmp :: Word64Set -> Word64Set -> Ordering+subsetCmp t1@(Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)+  | shorter m1 m2  = GT+  | shorter m2 m1  = case subsetCmpLt of+                       GT -> GT+                       _  -> LT+  | p1 == p2       = subsetCmpEq+  | otherwise      = GT  -- disjoint+  where+    subsetCmpLt | nomatch p1 p2 m2  = GT+                | zero p1 m2        = subsetCmp t1 l2+                | otherwise         = subsetCmp t1 r2+    subsetCmpEq = case (subsetCmp l1 l2, subsetCmp r1 r2) of+                    (GT,_ ) -> GT+                    (_ ,GT) -> GT+                    (EQ,EQ) -> EQ+                    _       -> LT++subsetCmp (Bin _ _ _ _) _  = GT+subsetCmp (Tip kx1 bm1) (Tip kx2 bm2)+  | kx1 /= kx2                  = GT -- disjoint+  | bm1 == bm2                  = EQ+  | bm1 .&. complement bm2 == 0 = LT+  | otherwise                   = GT+subsetCmp t1@(Tip kx _) (Bin p m l r)+  | nomatch kx p m = GT+  | zero kx m      = case subsetCmp t1 l of GT -> GT ; _ -> LT+  | otherwise      = case subsetCmp t1 r of GT -> GT ; _ -> LT+subsetCmp (Tip _ _) Nil = GT -- disjoint+subsetCmp Nil Nil = EQ+subsetCmp Nil _   = LT++-- | \(O(n+m)\). Is this a subset?+-- @(s1 \`isSubsetOf\` s2)@ tells whether @s1@ is a subset of @s2@.++isSubsetOf :: Word64Set -> Word64Set -> Bool+isSubsetOf t1@(Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)+  | shorter m1 m2  = False+  | shorter m2 m1  = match p1 p2 m2 && (if zero p1 m2 then isSubsetOf t1 l2+                                                      else isSubsetOf t1 r2)+  | otherwise      = (p1==p2) && isSubsetOf l1 l2 && isSubsetOf r1 r2+isSubsetOf (Bin _ _ _ _) _  = False+isSubsetOf (Tip kx1 bm1) (Tip kx2 bm2) = kx1 == kx2 && bm1 .&. complement bm2 == 0+isSubsetOf t1@(Tip kx _) (Bin p m l r)+  | nomatch kx p m = False+  | zero kx m      = isSubsetOf t1 l+  | otherwise      = isSubsetOf t1 r+isSubsetOf (Tip _ _) Nil = False+isSubsetOf Nil _         = True+++{--------------------------------------------------------------------+  Disjoint+--------------------------------------------------------------------}+-- | \(O(n+m)\). Check whether two sets are disjoint (i.e. their intersection+--   is empty).+--+-- > disjoint (fromList [2,4,6])   (fromList [1,3])     == True+-- > disjoint (fromList [2,4,6,8]) (fromList [2,3,5,7]) == False+-- > disjoint (fromList [1,2])     (fromList [1,2,3,4]) == False+-- > disjoint (fromList [])        (fromList [])        == True+--+-- @since 0.5.11+disjoint :: Word64Set -> Word64Set -> Bool+disjoint t1@(Bin p1 m1 l1 r1) t2@(Bin p2 m2 l2 r2)+  | shorter m1 m2  = disjoint1+  | shorter m2 m1  = disjoint2+  | p1 == p2       = disjoint l1 l2 && disjoint r1 r2+  | otherwise      = True+  where+    disjoint1 | nomatch p2 p1 m1  = True+              | zero p2 m1        = disjoint l1 t2+              | otherwise         = disjoint r1 t2++    disjoint2 | nomatch p1 p2 m2  = True+              | zero p1 m2        = disjoint t1 l2+              | otherwise         = disjoint t1 r2++disjoint t1@(Bin _ _ _ _) (Tip kx2 bm2) = disjointBM t1+  where disjointBM (Bin p1 m1 l1 r1) | nomatch kx2 p1 m1 = True+                                     | zero kx2 m1       = disjointBM l1+                                     | otherwise         = disjointBM r1+        disjointBM (Tip kx1 bm1) | kx1 == kx2 = (bm1 .&. bm2) == 0+                                 | otherwise = True+        disjointBM Nil = True++disjoint (Bin _ _ _ _) Nil = True++disjoint (Tip kx1 bm1) t2 = disjointBM t2+  where disjointBM (Bin p2 m2 l2 r2) | nomatch kx1 p2 m2 = True+                                     | zero kx1 m2       = disjointBM l2+                                     | otherwise         = disjointBM r2+        disjointBM (Tip kx2 bm2) | kx1 == kx2 = (bm1 .&. bm2) == 0+                                 | otherwise = True+        disjointBM Nil = True++disjoint Nil _ = True+++{--------------------------------------------------------------------+  Filter+--------------------------------------------------------------------}+-- | \(O(n)\). Filter all elements that satisfy some predicate.+filter :: (Key -> Bool) -> Word64Set -> Word64Set+filter predicate t+  = case t of+      Bin p m l r+        -> bin p m (filter predicate l) (filter predicate r)+      Tip kx bm+        -> tip kx (foldl'Bits 0 (bitPred kx) 0 bm)+      Nil -> Nil+  where bitPred kx bm bi | predicate (kx + bi) = bm .|. bitmapOfSuffix bi+                         | otherwise           = bm+        {-# INLINE bitPred #-}++-- | \(O(n)\). partition the set according to some predicate.+partition :: (Key -> Bool) -> Word64Set -> (Word64Set,Word64Set)+partition predicate0 t0 = toPair $ go predicate0 t0+  where+    go predicate t+      = case t of+          Bin p m l r+            -> let (l1 :*: l2) = go predicate l+                   (r1 :*: r2) = go predicate r+               in bin p m l1 r1 :*: bin p m l2 r2+          Tip kx bm+            -> let bm1 = foldl'Bits 0 (bitPred kx) 0 bm+               in  tip kx bm1 :*: tip kx (bm `xor` bm1)+          Nil -> (Nil :*: Nil)+      where bitPred kx bm bi | predicate (kx + bi) = bm .|. bitmapOfSuffix bi+                             | otherwise           = bm+            {-# INLINE bitPred #-}++-- | \(O(\min(n,W))\). Take while a predicate on the elements holds.+-- The user is responsible for ensuring that for all @Int@s, @j \< k ==\> p j \>= p k@.+-- See note at 'spanAntitone'.+--+-- @+-- takeWhileAntitone p = 'fromDistinctAscList' . 'Data.List.takeWhile' p . 'toList'+-- takeWhileAntitone p = 'filter' p+-- @+--+-- @since 0.6.7+takeWhileAntitone :: (Key -> Bool) -> Word64Set -> Word64Set+takeWhileAntitone predicate t =+  case t of+    Bin p m l r+      | m < 0 ->+        if predicate 0 -- handle negative numbers.+        then bin p m (go predicate l) r+        else go predicate r+    _ -> go predicate t+  where+    go predicate' (Bin p m l r)+      | predicate' $! p+m = bin p m l (go predicate' r)+      | otherwise         = go predicate' l+    go predicate' (Tip kx bm) = tip kx (takeWhileAntitoneBits kx predicate' bm)+    go _ Nil = Nil++-- | \(O(\min(n,W))\). Drop while a predicate on the elements holds.+-- The user is responsible for ensuring that for all @Int@s, @j \< k ==\> p j \>= p k@.+-- See note at 'spanAntitone'.+--+-- @+-- dropWhileAntitone p = 'fromDistinctAscList' . 'Data.List.dropWhile' p . 'toList'+-- dropWhileAntitone p = 'filter' (not . p)+-- @+--+-- @since 0.6.7+dropWhileAntitone :: (Key -> Bool) -> Word64Set -> Word64Set+dropWhileAntitone predicate t =+  case t of+    Bin p m l r+      | m < 0 ->+        if predicate 0 -- handle negative numbers.+        then go predicate l+        else bin p m l (go predicate r)+    _ -> go predicate t+  where+    go predicate' (Bin p m l r)+      | predicate' $! p+m = go predicate' r+      | otherwise         = bin p m (go predicate' l) r+    go predicate' (Tip kx bm) = tip kx (bm `xor` takeWhileAntitoneBits kx predicate' bm)+    go _ Nil = Nil++-- | \(O(\min(n,W))\). Divide a set at the point where a predicate on the elements stops holding.+-- The user is responsible for ensuring that for all @Int@s, @j \< k ==\> p j \>= p k@.+--+-- @+-- spanAntitone p xs = ('takeWhileAntitone' p xs, 'dropWhileAntitone' p xs)+-- spanAntitone p xs = 'partition' p xs+-- @+--+-- Note: if @p@ is not actually antitone, then @spanAntitone@ will split the set+-- at some /unspecified/ point.+--+-- @since 0.6.7+spanAntitone :: (Key -> Bool) -> Word64Set -> (Word64Set, Word64Set)+spanAntitone predicate t =+  case t of+    Bin p m l r+      | m < 0 ->+        if predicate 0 -- handle negative numbers.+        then+          case go predicate l of+            (lt :*: gt) ->+              let !lt' = bin p m lt r+              in (lt', gt)+        else+          case go predicate r of+            (lt :*: gt) ->+              let !gt' = bin p m l gt+              in (lt, gt')+    _ -> case go predicate t of+          (lt :*: gt) -> (lt, gt)+  where+    go predicate' (Bin p m l r)+      | predicate' $! p+m = case go predicate' r of (lt :*: gt) -> bin p m l lt :*: gt+      | otherwise         = case go predicate' l of (lt :*: gt) -> lt :*: bin p m gt r+    go predicate' (Tip kx bm) = let bm' = takeWhileAntitoneBits kx predicate' bm+                                in (tip kx bm' :*: tip kx (bm `xor` bm'))+    go _ Nil = (Nil :*: Nil)++-- | \(O(\min(n,W))\). The expression (@'split' x set@) is a pair @(set1,set2)@+-- where @set1@ comprises the elements of @set@ less than @x@ and @set2@+-- comprises the elements of @set@ greater than @x@.+--+-- > split 3 (fromList [1..5]) == (fromList [1,2], fromList [4,5])+split :: Key -> Word64Set -> (Word64Set,Word64Set)+split x t =+  case t of+    Bin p m l r+      | m < 0 ->+        if x >= 0  -- handle negative numbers.+        then+          case go x l of+            (lt :*: gt) ->+              let !lt' = bin p m lt r+              in (lt', gt)+        else+          case go x r of+            (lt :*: gt) ->+              let !gt' = bin p m l gt+              in (lt, gt')+    _ -> case go x t of+          (lt :*: gt) -> (lt, gt)+  where+    go !x' t'@(Bin p m l r)+        | nomatch x' p m = if x' < p then (Nil :*: t') else (t' :*: Nil)+        | zero x' m      = case go x' l of (lt :*: gt) -> lt :*: bin p m gt r+        | otherwise      = case go x' r of (lt :*: gt) -> bin p m l lt :*: gt+    go x' t'@(Tip kx' bm)+        | kx' > x'          = (Nil :*: t')+          -- equivalent to kx' > prefixOf x'+        | kx' < prefixOf x' = (t' :*: Nil)+        | otherwise = tip kx' (bm .&. lowerBitmap) :*: tip kx' (bm .&. higherBitmap)+            where lowerBitmap = bitmapOf x' - 1+                  higherBitmap = complement (lowerBitmap + bitmapOf x')+    go _ Nil = (Nil :*: Nil)++-- | \(O(\min(n,W))\). Performs a 'split' but also returns whether the pivot+-- element was found in the original set.+splitMember :: Key -> Word64Set -> (Word64Set,Bool,Word64Set)+splitMember x t =+  case t of+    Bin p m l r+      | m < 0 ->+        if x >= 0 -- handle negative numbers.+        then+          case go x l of+            (lt, fnd, gt) ->+              let !lt' = bin p m lt r+              in (lt', fnd, gt)+        else+          case go x r of+            (lt, fnd, gt) ->+              let !gt' = bin p m l gt+              in (lt, fnd, gt')+    _ -> go x t+  where+    go x' t'@(Bin p m l r)+        | nomatch x' p m = if x' < p then (Nil, False, t') else (t', False, Nil)+        | zero x' m =+          case go x' l of+            (lt, fnd, gt) ->+              let !gt' = bin p m gt r+              in (lt, fnd, gt')+        | otherwise =+          case go x' r of+            (lt, fnd, gt) ->+              let !lt' = bin p m l lt+              in (lt', fnd, gt)+    go x' t'@(Tip kx' bm)+        | kx' > x'          = (Nil, False, t')+          -- equivalent to kx' > prefixOf x'+        | kx' < prefixOf x' = (t', False, Nil)+        | otherwise = let !lt = tip kx' (bm .&. lowerBitmap)+                          !found = (bm .&. bitmapOfx') /= 0+                          !gt = tip kx' (bm .&. higherBitmap)+                      in (lt, found, gt)+            where bitmapOfx' = bitmapOf x'+                  lowerBitmap = bitmapOfx' - 1+                  higherBitmap = complement (lowerBitmap + bitmapOfx')+    go _ Nil = (Nil, False, Nil)++{----------------------------------------------------------------------+  Min/Max+----------------------------------------------------------------------}++-- | \(O(\min(n,W))\). Retrieves the maximal key of the set, and the set+-- stripped of that element, or 'Nothing' if passed an empty set.+maxView :: Word64Set -> Maybe (Key, Word64Set)+maxView t =+  case t of Nil -> Nothing+            Bin p m l r | m < 0 -> case go l of (result, l') -> Just (result, bin p m l' r)+            _ -> Just (go t)+  where+    go (Bin p m l r) = case go r of (result, r') -> (result, bin p m l r')+    go (Tip kx bm) = case highestBitSet bm of bi -> (kx + bi, tip kx (bm .&. complement (bitmapOfSuffix bi)))+    go Nil = error "maxView Nil"++-- | \(O(\min(n,W))\). Retrieves the minimal key of the set, and the set+-- stripped of that element, or 'Nothing' if passed an empty set.+minView :: Word64Set -> Maybe (Key, Word64Set)+minView t =+  case t of Nil -> Nothing+            Bin p m l r | m < 0 -> case go r of (result, r') -> Just (result, bin p m l r')+            _ -> Just (go t)+  where+    go (Bin p m l r) = case go l of (result, l') -> (result, bin p m l' r)+    go (Tip kx bm) = case lowestBitSet bm of bi -> (kx + bi, tip kx (bm .&. complement (bitmapOfSuffix bi)))+    go Nil = error "minView Nil"++-- | \(O(\min(n,W))\). Delete and find the minimal element.+--+-- > deleteFindMin set = (findMin set, deleteMin set)+deleteFindMin :: Word64Set -> (Key, Word64Set)+deleteFindMin = fromMaybe (error "deleteFindMin: empty set has no minimal element") . minView++-- | \(O(\min(n,W))\). Delete and find the maximal element.+--+-- > deleteFindMax set = (findMax set, deleteMax set)+deleteFindMax :: Word64Set -> (Key, Word64Set)+deleteFindMax = fromMaybe (error "deleteFindMax: empty set has no maximal element") . maxView+++-- | \(O(\min(n,W))\). The minimal element of the set.+findMin :: Word64Set -> Key+findMin Nil = error "findMin: empty set has no minimal element"+findMin (Tip kx bm) = kx + lowestBitSet bm+findMin (Bin _ m l r)+  |   m < 0   = find r+  | otherwise = find l+    where find (Tip kx bm) = kx + lowestBitSet bm+          find (Bin _ _ l' _) = find l'+          find Nil            = error "findMin Nil"++-- | \(O(\min(n,W))\). The maximal element of a set.+findMax :: Word64Set -> Key+findMax Nil = error "findMax: empty set has no maximal element"+findMax (Tip kx bm) = kx + highestBitSet bm+findMax (Bin _ m l r)+  |   m < 0   = find l+  | otherwise = find r+    where find (Tip kx bm) = kx + highestBitSet bm+          find (Bin _ _ _ r') = find r'+          find Nil            = error "findMax Nil"+++-- | \(O(\min(n,W))\). Delete the minimal element. Returns an empty set if the set is empty.+--+-- Note that this is a change of behaviour for consistency with 'Data.Set.Set' &#8211;+-- versions prior to 0.5 threw an error if the 'Word64Set' was already empty.+deleteMin :: Word64Set -> Word64Set+deleteMin = maybe Nil snd . minView++-- | \(O(\min(n,W))\). Delete the maximal element. Returns an empty set if the set is empty.+--+-- Note that this is a change of behaviour for consistency with 'Data.Set.Set' &#8211;+-- versions prior to 0.5 threw an error if the 'Word64Set' was already empty.+deleteMax :: Word64Set -> Word64Set+deleteMax = maybe Nil snd . maxView++{----------------------------------------------------------------------+  Map+----------------------------------------------------------------------}++-- | \(O(n \min(n,W))\).+-- @'map' f s@ is the set obtained by applying @f@ to each element of @s@.+--+-- It's worth noting that the size of the result may be smaller if,+-- for some @(x,y)@, @x \/= y && f x == f y@++map :: (Key -> Key) -> Word64Set -> Word64Set+map f = fromList . List.map f . toList++-- | \(O(n)\). The+--+-- @'mapMonotonic' f s == 'map' f s@, but works only when @f@ is strictly increasing.+-- /The precondition is not checked./+-- Semi-formally, we have:+--+-- > and [x < y ==> f x < f y | x <- ls, y <- ls]+-- >                     ==> mapMonotonic f s == map f s+-- >     where ls = toList s+--+-- @since 0.6.3.1++-- Note that for now the test is insufficient to support any fancier implementation.+mapMonotonic :: (Key -> Key) -> Word64Set -> Word64Set+mapMonotonic f = fromDistinctAscList . List.map f . toAscList+++{--------------------------------------------------------------------+  Fold+--------------------------------------------------------------------}+-- | \(O(n)\). Fold the elements in the set using the given right-associative+-- binary operator. This function is an equivalent of 'foldr' and is present+-- for compatibility only.+--+-- /Please note that fold will be deprecated in the future and removed./+fold :: (Key -> b -> b) -> b -> Word64Set -> b+fold = foldr+{-# INLINE fold #-}++-- | \(O(n)\). Fold the elements in the set using the given right-associative+-- binary operator, such that @'foldr' f z == 'Prelude.foldr' f z . 'toAscList'@.+--+-- For example,+--+-- > toAscList set = foldr (:) [] set+foldr :: (Key -> b -> b) -> b -> Word64Set -> b+foldr f z = \t ->      -- Use lambda t to be inlinable with two arguments only.+  case t of Bin _ m l r | m < 0 -> go (go z l) r -- put negative numbers before+                        | otherwise -> go (go z r) l+            _ -> go z t+  where+    go z' Nil           = z'+    go z' (Tip kx bm)   = foldrBits kx f z' bm+    go z' (Bin _ _ l r) = go (go z' r) l+{-# INLINE foldr #-}++-- | \(O(n)\). A strict version of 'foldr'. Each application of the operator is+-- evaluated before using the result in the next application. This+-- function is strict in the starting value.+foldr' :: (Key -> b -> b) -> b -> Word64Set -> b+foldr' f z = \t ->      -- Use lambda t to be inlinable with two arguments only.+  case t of Bin _ m l r | m < 0 -> go (go z l) r -- put negative numbers before+                        | otherwise -> go (go z r) l+            _ -> go z t+  where+    go !z' Nil           = z'+    go z' (Tip kx bm)   = foldr'Bits kx f z' bm+    go z' (Bin _ _ l r) = go (go z' r) l+{-# INLINE foldr' #-}++-- | \(O(n)\). Fold the elements in the set using the given left-associative+-- binary operator, such that @'foldl' f z == 'Prelude.foldl' f z . 'toAscList'@.+--+-- For example,+--+-- > toDescList set = foldl (flip (:)) [] set+foldl :: (a -> Key -> a) -> a -> Word64Set -> a+foldl f z = \t ->      -- Use lambda t to be inlinable with two arguments only.+  case t of Bin _ m l r | m < 0 -> go (go z r) l -- put negative numbers before+                        | otherwise -> go (go z l) r+            _ -> go z t+  where+    go z' Nil           = z'+    go z' (Tip kx bm)   = foldlBits kx f z' bm+    go z' (Bin _ _ l r) = go (go z' l) r+{-# INLINE foldl #-}++-- | \(O(n)\). A strict version of 'foldl'. Each application of the operator is+-- evaluated before using the result in the next application. This+-- function is strict in the starting value.+foldl' :: (a -> Key -> a) -> a -> Word64Set -> a+foldl' f z = \t ->      -- Use lambda t to be inlinable with two arguments only.+  case t of Bin _ m l r | m < 0 -> go (go z r) l -- put negative numbers before+                        | otherwise -> go (go z l) r+            _ -> go z t+  where+    go !z' Nil           = z'+    go z' (Tip kx bm)   = foldl'Bits kx f z' bm+    go z' (Bin _ _ l r) = go (go z' l) r+{-# INLINE foldl' #-}++{--------------------------------------------------------------------+  List variations+--------------------------------------------------------------------}+-- | \(O(n)\). An alias of 'toAscList'. The elements of a set in ascending order.+-- Subject to list fusion.+elems :: Word64Set -> [Key]+elems+  = toAscList++{--------------------------------------------------------------------+  Lists+--------------------------------------------------------------------}++-- | @since 0.5.6.2+instance GHC.Exts.IsList Word64Set where+  type Item Word64Set = Key+  fromList = fromList+  toList   = toList++-- | \(O(n)\). Convert the set to a list of elements. Subject to list fusion.+toList :: Word64Set -> [Key]+toList+  = toAscList++-- | \(O(n)\). Convert the set to an ascending list of elements. Subject to list+-- fusion.+toAscList :: Word64Set -> [Key]+toAscList = foldr (:) []++-- | \(O(n)\). Convert the set to a descending list of elements. Subject to list+-- fusion.+toDescList :: Word64Set -> [Key]+toDescList = foldl (flip (:)) []++-- List fusion for the list generating functions.+-- The foldrFB and foldlFB are foldr and foldl equivalents, used for list fusion.+-- They are important to convert unfused to{Asc,Desc}List back, see mapFB in prelude.+foldrFB :: (Key -> b -> b) -> b -> Word64Set -> b+foldrFB = foldr+{-# INLINE[0] foldrFB #-}+foldlFB :: (a -> Key -> a) -> a -> Word64Set -> a+foldlFB = foldl+{-# INLINE[0] foldlFB #-}++-- Inline elems and toList, so that we need to fuse only toAscList.+{-# INLINE elems #-}+{-# INLINE toList #-}++-- The fusion is enabled up to phase 2 included. If it does not succeed,+-- convert in phase 1 the expanded to{Asc,Desc}List calls back to+-- to{Asc,Desc}List.  In phase 0, we inline fold{lr}FB (which were used in+-- a list fusion, otherwise it would go away in phase 1), and let compiler do+-- whatever it wants with to{Asc,Desc}List -- it was forbidden to inline it+-- before phase 0, otherwise the fusion rules would not fire at all.+{-# NOINLINE[0] toAscList #-}+{-# NOINLINE[0] toDescList #-}+{-# RULES "Word64Set.toAscList" [~1] forall s . toAscList s = GHC.Exts.build (\c n -> foldrFB c n s) #-}+{-# RULES "Word64Set.toAscListBack" [1] foldrFB (:) [] = toAscList #-}+{-# RULES "Word64Set.toDescList" [~1] forall s . toDescList s = GHC.Exts.build (\c n -> foldlFB (\xs x -> c x xs) n s) #-}+{-# RULES "Word64Set.toDescListBack" [1] foldlFB (\xs x -> x : xs) [] = toDescList #-}+++-- | \(O(n \min(n,W))\). Create a set from a list of integers.+{-# INLINABLE fromList #-}+fromList :: [Key] -> Word64Set+fromList = List.foldl' ins empty+  where+    ins t x  = insert x t++-- | \(O(n)\). Build a set from an ascending list of elements.+-- /The precondition (input list is ascending) is not checked./+fromAscList :: [Key] -> Word64Set+fromAscList = fromMonoList+{-# NOINLINE fromAscList #-}++-- | \(O(n)\). Build a set from an ascending list of distinct elements.+-- /The precondition (input list is strictly ascending) is not checked./+fromDistinctAscList :: [Key] -> Word64Set+fromDistinctAscList = fromAscList+{-# INLINE fromDistinctAscList #-}++-- | \(O(n)\). Build a set from a monotonic list of elements.+--+-- The precise conditions under which this function works are subtle:+-- For any branch mask, keys with the same prefix w.r.t. the branch+-- mask must occur consecutively in the list.+fromMonoList :: [Key] -> Word64Set+fromMonoList []         = Nil+fromMonoList (kx : zs1) = addAll' (prefixOf kx) (bitmapOf kx) zs1+  where+    -- `addAll'` collects all keys with the prefix `px` into a single+    -- bitmap, and then proceeds with `addAll`.+    addAll' !px !bm []+        = Tip px bm+    addAll' !px !bm (ky : zs)+        | px == prefixOf ky+        = addAll' px (bm .|. bitmapOf ky) zs+        -- inlined: | otherwise = addAll px (Tip px bm) (ky : zs)+        | py <- prefixOf ky+        , m <- branchMask px py+        , Inserted ty zs' <- addMany' m py (bitmapOf ky) zs+        = addAll px (linkWithMask m py ty {-px-} (Tip px bm)) zs'++    -- for `addAll` and `addMany`, px is /a/ prefix inside the tree `tx`+    -- `addAll` consumes the rest of the list, adding to the tree `tx`+    addAll !_px !tx []+        = tx+    addAll !px !tx (ky : zs)+        | py <- prefixOf ky+        , m <- branchMask px py+        , Inserted ty zs' <- addMany' m py (bitmapOf ky) zs+        = addAll px (linkWithMask m py ty {-px-} tx) zs'++    -- `addMany'` is similar to `addAll'`, but proceeds with `addMany'`.+    addMany' !_m !px !bm []+        = Inserted (Tip px bm) []+    addMany' !m !px !bm zs0@(ky : zs)+        | px == prefixOf ky+        = addMany' m px (bm .|. bitmapOf ky) zs+        -- inlined: | otherwise = addMany m px (Tip px bm) (ky : zs)+        | mask px m /= mask ky m+        = Inserted (Tip (prefixOf px) bm) zs0+        | py <- prefixOf ky+        , mxy <- branchMask px py+        , Inserted ty zs' <- addMany' mxy py (bitmapOf ky) zs+        = addMany m px (linkWithMask mxy py ty {-px-} (Tip px bm)) zs'++    -- `addAll` adds to `tx` all keys whose prefix w.r.t. `m` agrees with `px`.+    addMany !_m !_px tx []+        = Inserted tx []+    addMany !m !px tx zs0@(ky : zs)+        | mask px m /= mask ky m+        = Inserted tx zs0+        | py <- prefixOf ky+        , mxy <- branchMask px py+        , Inserted ty zs' <- addMany' mxy py (bitmapOf ky) zs+        = addMany m px (linkWithMask mxy py ty {-px-} tx) zs'+{-# INLINE fromMonoList #-}++data Inserted = Inserted !Word64Set ![Key]++{--------------------------------------------------------------------+  Eq+--------------------------------------------------------------------}+instance Eq Word64Set where+  t1 == t2  = equal t1 t2+  t1 /= t2  = nequal t1 t2++equal :: Word64Set -> Word64Set -> Bool+equal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)+  = (m1 == m2) && (p1 == p2) && (equal l1 l2) && (equal r1 r2)+equal (Tip kx1 bm1) (Tip kx2 bm2)+  = kx1 == kx2 && bm1 == bm2+equal Nil Nil = True+equal _   _   = False++nequal :: Word64Set -> Word64Set -> Bool+nequal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2)+  = (m1 /= m2) || (p1 /= p2) || (nequal l1 l2) || (nequal r1 r2)+nequal (Tip kx1 bm1) (Tip kx2 bm2)+  = kx1 /= kx2 || bm1 /= bm2+nequal Nil Nil = False+nequal _   _   = True++{--------------------------------------------------------------------+  Ord+--------------------------------------------------------------------}++instance Ord Word64Set where+    compare s1 s2 = compare (toAscList s1) (toAscList s2)+    -- tentative implementation. See if more efficient exists.++{--------------------------------------------------------------------+  Show+--------------------------------------------------------------------}+instance Show Word64Set where+  showsPrec p xs = showParen (p > 10) $+    showString "fromList " . shows (toList xs)++{--------------------------------------------------------------------+  Read+--------------------------------------------------------------------}+instance Read Word64Set where+  readPrec = parens $ prec 10 $ do+    Ident "fromList" <- lexP+    xs <- readPrec+    return (fromList xs)++  readListPrec = readListPrecDefault++{--------------------------------------------------------------------+  NFData+--------------------------------------------------------------------}++-- The Word64Set constructors consist only of strict fields of Ints and+-- Word64Sets, thus the default NFData instance which evaluates to whnf+-- should suffice+instance NFData Word64Set where rnf x = seq x ()++{--------------------------------------------------------------------+  Debugging+--------------------------------------------------------------------}+-- | \(O(n \min(n,W))\). Show the tree that implements the set. The tree is shown+-- in a compressed, hanging format.+showTree :: Word64Set -> String+showTree s+  = showTreeWith True False s+++{- | \(O(n \min(n,W))\). The expression (@'showTreeWith' hang wide map@) shows+ the tree that implements the set. If @hang@ is+ 'True', a /hanging/ tree is shown otherwise a rotated tree is shown. If+ @wide@ is 'True', an extra wide version is shown.+-}+showTreeWith :: Bool -> Bool -> Word64Set -> String+showTreeWith hang wide t+  | hang      = (showsTreeHang wide [] t) ""+  | otherwise = (showsTree wide [] [] t) ""++showsTree :: Bool -> [String] -> [String] -> Word64Set -> ShowS+showsTree wide lbars rbars t+  = case t of+      Bin p m l r+          -> showsTree wide (withBar rbars) (withEmpty rbars) r .+             showWide wide rbars .+             showsBars lbars . showString (showBin p m) . showString "\n" .+             showWide wide lbars .+             showsTree wide (withEmpty lbars) (withBar lbars) l+      Tip kx bm+          -> showsBars lbars . showString " " . shows kx . showString " + " .+                                                showsBitMap bm . showString "\n"+      Nil -> showsBars lbars . showString "|\n"++showsTreeHang :: Bool -> [String] -> Word64Set -> ShowS+showsTreeHang wide bars t+  = case t of+      Bin p m l r+          -> showsBars bars . showString (showBin p m) . showString "\n" .+             showWide wide bars .+             showsTreeHang wide (withBar bars) l .+             showWide wide bars .+             showsTreeHang wide (withEmpty bars) r+      Tip kx bm+          -> showsBars bars . showString " " . shows kx . showString " + " .+                                               showsBitMap bm . showString "\n"+      Nil -> showsBars bars . showString "|\n"++showBin :: Prefix -> Mask -> String+showBin _ _+  = "*" -- ++ show (p,m)++showWide :: Bool -> [String] -> String -> String+showWide wide bars+  | wide      = showString (concat (reverse bars)) . showString "|\n"+  | otherwise = id++showsBars :: [String] -> ShowS+showsBars [] = id+showsBars (_ : tl) = showString (concat (reverse tl)) . showString node++showsBitMap :: Word64 -> ShowS+showsBitMap = showString . showBitMap++showBitMap :: Word64 -> String+showBitMap w = show $ foldrBits 0 (:) [] w++node :: String+node           = "+--"++withBar, withEmpty :: [String] -> [String]+withBar bars   = "|  ":bars+withEmpty bars = "   ":bars+++{--------------------------------------------------------------------+  Helpers+--------------------------------------------------------------------}+{--------------------------------------------------------------------+  Link+--------------------------------------------------------------------}+link :: Prefix -> Word64Set -> Prefix -> Word64Set -> Word64Set+link p1 t1 p2 t2 = linkWithMask (branchMask p1 p2) p1 t1 {-p2-} t2+{-# INLINE link #-}++-- `linkWithMask` is useful when the `branchMask` has already been computed+linkWithMask :: Mask -> Prefix -> Word64Set -> Word64Set -> Word64Set+linkWithMask m p1 t1 {-p2-} t2+  | zero p1 m = Bin p m t1 t2+  | otherwise = Bin p m t2 t1+  where+    p = mask p1 m+{-# INLINE linkWithMask #-}++{--------------------------------------------------------------------+  @bin@ assures that we never have empty trees within a tree.+--------------------------------------------------------------------}+bin :: Prefix -> Mask -> Word64Set -> Word64Set -> Word64Set+bin _ _ l Nil = l+bin _ _ Nil r = r+bin p m l r   = Bin p m l r+{-# INLINE bin #-}++{--------------------------------------------------------------------+  @tip@ assures that we never have empty bitmaps within a tree.+--------------------------------------------------------------------}+tip :: Prefix -> BitMap -> Word64Set+tip _ 0 = Nil+tip kx bm = Tip kx bm+{-# INLINE tip #-}+++{----------------------------------------------------------------------+  Functions that generate Prefix and BitMap of a Key or a Suffix.+----------------------------------------------------------------------}++suffixBitMask :: Word64+suffixBitMask = fromIntegral (finiteBitSize (undefined::Word64)) - 1+{-# INLINE suffixBitMask #-}++prefixBitMask :: Word64+prefixBitMask = complement suffixBitMask+{-# INLINE prefixBitMask #-}++prefixOf :: Word64 -> Prefix+prefixOf x = x .&. prefixBitMask+{-# INLINE prefixOf #-}++suffixOf :: Word64 -> Word64+suffixOf x = x .&. suffixBitMask+{-# INLINE suffixOf #-}++bitmapOfSuffix :: Word64 -> BitMap+bitmapOfSuffix s = 1 `shiftLL` fromIntegral s+{-# INLINE bitmapOfSuffix #-}++bitmapOf :: Word64 -> BitMap+bitmapOf x = bitmapOfSuffix (suffixOf x)+{-# INLINE bitmapOf #-}+++{--------------------------------------------------------------------+  Endian independent bit twiddling+--------------------------------------------------------------------}+-- Returns True iff the bits set in i and the Mask m are disjoint.+zero :: Word64 -> Mask -> Bool+zero i m+  = (natFromInt i) .&. (natFromInt m) == 0+{-# INLINE zero #-}++nomatch,match :: Word64 -> Prefix -> Mask -> Bool+nomatch i p m+  = (mask i m) /= p+{-# INLINE nomatch #-}++match i p m+  = (mask i m) == p+{-# INLINE match #-}++-- Suppose a is largest such that 2^a divides 2*m.+-- Then mask i m is i with the low a bits zeroed out.+mask :: Word64 -> Mask -> Prefix+mask i m+  = maskW (natFromInt i) (natFromInt m)+{-# INLINE mask #-}++{--------------------------------------------------------------------+  Big endian operations+--------------------------------------------------------------------}+maskW :: Nat -> Nat -> Prefix+maskW i m+  = intFromNat (i .&. (complement (m-1) `xor` m))+{-# INLINE maskW #-}++shorter :: Mask -> Mask -> Bool+shorter m1 m2+  = (natFromInt m1) > (natFromInt m2)+{-# INLINE shorter #-}++branchMask :: Prefix -> Prefix -> Mask+branchMask p1 p2+  = intFromNat (highestBitMask (natFromInt p1 `xor` natFromInt p2))+{-# INLINE branchMask #-}++{----------------------------------------------------------------------+  To get best performance, we provide fast implementations of+  lowestBitSet, highestBitSet and fold[lr][l]Bits for GHC.+  If the intel bsf and bsr instructions ever become GHC primops,+  this code should be reimplemented using these.++  Performance of this code is crucial for folds, toList, filter, partition.++  The signatures of methods in question are placed after this comment.+----------------------------------------------------------------------}++lowestBitSet :: Nat -> Word64+highestBitSet :: Nat -> Word64+foldlBits :: Word64 -> (a -> Word64 -> a) -> a -> Nat -> a+foldl'Bits :: Word64 -> (a -> Word64 -> a) -> a -> Nat -> a+foldrBits :: Word64 -> (Word64 -> a -> a) -> a -> Nat -> a+foldr'Bits :: Word64 -> (Word64 -> a -> a) -> a -> Nat -> a+takeWhileAntitoneBits :: Word64 -> (Word64 -> Bool) -> Nat -> Nat++{-# INLINE lowestBitSet #-}+{-# INLINE highestBitSet #-}+{-# INLINE foldlBits #-}+{-# INLINE foldl'Bits #-}+{-# INLINE foldrBits #-}+{-# INLINE foldr'Bits #-}+{-# INLINE takeWhileAntitoneBits #-}++indexOfTheOnlyBit :: Nat -> Word64+{-# INLINE indexOfTheOnlyBit #-}+indexOfTheOnlyBit bitmask = fromIntegral $ countTrailingZeros bitmask++lowestBitSet x = fromIntegral $ countTrailingZeros x++highestBitSet x = fromIntegral $ 63 - countLeadingZeros x++lowestBitMask :: Nat -> Nat+lowestBitMask x = x .&. negate x+{-# INLINE lowestBitMask #-}++-- Reverse the order of bits in the Nat.+revNat :: Nat -> Nat+revNat x1 = case ((x1 `shiftRL` 1) .&. 0x5555555555555555) .|. ((x1 .&. 0x5555555555555555) `shiftLL` 1) of+              x2 -> case ((x2 `shiftRL` 2) .&. 0x3333333333333333) .|. ((x2 .&. 0x3333333333333333) `shiftLL` 2) of+                 x3 -> case ((x3 `shiftRL` 4) .&. 0x0F0F0F0F0F0F0F0F) .|. ((x3 .&. 0x0F0F0F0F0F0F0F0F) `shiftLL` 4) of+                   x4 -> case ((x4 `shiftRL` 8) .&. 0x00FF00FF00FF00FF) .|. ((x4 .&. 0x00FF00FF00FF00FF) `shiftLL` 8) of+                     x5 -> case ((x5 `shiftRL` 16) .&. 0x0000FFFF0000FFFF) .|. ((x5 .&. 0x0000FFFF0000FFFF) `shiftLL` 16) of+                       x6 -> ( x6 `shiftRL` 32             ) .|. ( x6               `shiftLL` 32);++foldlBits prefix f z bitmap = go bitmap z+  where go 0 acc = acc+        go bm acc = go (bm `xor` bitmask) ((f acc) $! (prefix+bi))+          where+            !bitmask = lowestBitMask bm+            !bi = indexOfTheOnlyBit bitmask++foldl'Bits prefix f z bitmap = go bitmap z+  where go 0 acc = acc+        go bm !acc = go (bm `xor` bitmask) ((f acc) $! (prefix+bi))+          where !bitmask = lowestBitMask bm+                !bi = indexOfTheOnlyBit bitmask++foldrBits prefix f z bitmap = go (revNat bitmap) z+  where go 0 acc = acc+        go bm acc = go (bm `xor` bitmask) ((f $! (prefix+63-bi)) acc)+          where !bitmask = lowestBitMask bm+                !bi = indexOfTheOnlyBit bitmask+++foldr'Bits prefix f z bitmap = go (revNat bitmap) z+  where go 0 acc = acc+        go bm !acc = go (bm `xor` bitmask) ((f $! (prefix+63-bi)) acc)+          where !bitmask = lowestBitMask bm+                !bi = indexOfTheOnlyBit bitmask++takeWhileAntitoneBits prefix predicate bitmap =+  -- Binary search for the first index where the predicate returns false, but skip a predicate+  -- call if the high half of the current range is empty. This ensures+  -- min (log2 64 + 1 = 7) (popcount bitmap) predicate calls.+  let next d h (n',b') =+        if n' .&. h /= 0 && (predicate $! prefix + fromIntegral (b'+d)) then (n' `shiftRL` d, b'+d) else (n',b')+      {-# INLINE next #-}+      (_,b) = next 1  0x2 $+              next 2  0xC $+              next 4  0xF0 $+              next 8  0xFF00 $+              next 16 0xFFFF0000 $+              next 32 0xFFFFFFFF00000000 $+              (bitmap,0)+      m = if b /= 0 || (bitmap .&. 0x1 /= 0 && predicate prefix)+          then ((2 `shiftLL` b) - 1)+          else ((1 `shiftLL` b) - 1)+  in bitmap .&. m++++{--------------------------------------------------------------------+  Utilities+--------------------------------------------------------------------}++-- | \(O(1)\).  Decompose a set into pieces based on the structure of the underlying+-- tree.  This function is useful for consuming a set in parallel.+--+-- No guarantee is made as to the sizes of the pieces; an internal, but+-- deterministic process determines this.  However, it is guaranteed that the+-- pieces returned will be in ascending order (all elements in the first submap+-- less than all elements in the second, and so on).+--+-- Examples:+--+-- > splitRoot (fromList [1..120]) == [fromList [1..63],fromList [64..120]]+-- > splitRoot empty == []+--+--  Note that the current implementation does not return more than two subsets,+--  but you should not depend on this behaviour because it can change in the+--  future without notice. Also, the current version does not continue+--  splitting all the way to individual singleton sets -- it stops at some+--  point.+splitRoot :: Word64Set -> [Word64Set]+splitRoot Nil = []+-- NOTE: we don't currently split below Tip, but we could.+splitRoot x@(Tip _ _) = [x]+splitRoot (Bin _ m l r) | m < 0 = [r, l]+                        | otherwise = [l, r]+{-# INLINE splitRoot #-}
GHC/Driver/Backend.hs view
@@ -1,95 +1,203 @@-{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE MultiWayIf, LambdaCase #-} --- | Code generation backends+{-|+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-   ( 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-   , backendProducesObject-   , backendRetainsAllBindings    )+ where + import GHC.Prelude-import GHC.Platform --- | Code generation backends.------ GHC supports several code generation backends serving different purposes--- (producing machine code, producing ByteCode for the interpreter) and--- supporting different platforms.----data Backend-   = NCG           -- ^ Native code generator backend.-                   ---                   -- 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".+import GHC.Driver.Backend.Internal (BackendName(..))+import GHC.Driver.Phases  -   | LLVM          -- ^ 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).-                   ---                   -- Support a few platforms (X86, AArch64, s390x, ARM).-                   ---                   -- See "GHC.CmmToLlvm"-+import GHC.Utils.Error+import GHC.Utils.Panic -   | ViaC          -- ^ Via-C 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"+import GHC.Driver.Pipeline.Monad+import GHC.Platform  -   | Interpreter   -- ^ 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"+---------------------------------------------------------------------------------+--+--   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"+--+---------------------------------------------------------------------------------  -   | NoBackend     -- ^ No code generated.-                   ---                   -- Use this 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.--   deriving (Eq,Ord,Show,Read)---- | Default backend to use for the given platform. platformDefaultBackend :: Platform -> Backend platformDefaultBackend platform = if-      | platformUnregisterised platform -> ViaC-      | platformNcgSupported platform   -> NCG-      | otherwise                       -> LLVM-+      | platformUnregisterised platform -> viaCBackend+      | platformNcgSupported platform   -> ncgBackend+      | platformJSSupported platform    -> jsBackend+      | otherwise                       -> llvmBackend  -- | Is the platform supported by the Native Code Generator? platformNcgSupported :: Platform -> Bool@@ -104,28 +212,701 @@          ArchPPC       -> True          ArchPPC_64 {} -> True          ArchAArch64   -> True+         ArchWasm32    -> True+         ArchRISCV64   -> True+         ArchLoongArch64 -> True          _             -> False --- | Will this backend produce an object file on the disk?-backendProducesObject :: Backend -> Bool-backendProducesObject ViaC        = True-backendProducesObject NCG         = True-backendProducesObject LLVM        = True-backendProducesObject Interpreter = False-backendProducesObject NoBackend   = False+-- | Is the platform supported by the JS backend?+platformJSSupported :: Platform -> Bool+platformJSSupported platform+  | platformArch platform == ArchJavaScript = True+  | otherwise                               = False --- | Does this backend retain *all* top-level bindings for a module,--- rather than just the exported bindings, in the TypeEnv and compiled--- code (if any)?++-- | 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. ----- Interpreter backend does this, so that GHCi can call functions inside a--- 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. ----- When no backend is used we also do it, so that Haddock can get access to the--- GlobalRdrEnv for a module after typechecking it.-backendRetainsAllBindings :: Backend -> Bool-backendRetainsAllBindings Interpreter = True-backendRetainsAllBindings NoBackend   = True-backendRetainsAllBindings ViaC        = False-backendRetainsAllBindings NCG         = False-backendRetainsAllBindings LLVM        = False+-- The issue of abstraction is discussed at great length in #20927 and !7442.+++newtype Backend = Named BackendName+  -- Must be a newtype so that it has no `Eq` instance and+  -- a different `Show` instance.++-- | The Show instance is for messages /only/.  If code depends on+-- what's in the string, you deserve what happens to you.++instance Show Backend where+  show = backendDescription+++ncgBackend, llvmBackend, viaCBackend, interpreterBackend, jsBackend, noBackend+    :: Backend++-- | The native code generator.+-- Compiles Cmm code into textual assembler, then relies on+-- an external assembler toolchain to produce machine code.+--+-- Only supports a few platforms (X86, PowerPC, SPARC).+--+-- See "GHC.CmmToAsm".+ncgBackend = Named NCG++-- | The LLVM backend.+--+-- Compiles Cmm code into LLVM textual IR, then relies on+-- LLVM toolchain to produce machine code.+--+-- It relies on LLVM support for the calling convention used+-- by the NCG backend to produce code objects ABI compatible+-- with it (see "cc 10" or "ghccc" calling convention in+-- https://llvm.org/docs/LangRef.html#calling-conventions).+--+-- Supports a few platforms (X86, AArch64, s390x, ARM).+--+-- See "GHC.CmmToLlvm"+llvmBackend = Named LLVM++-- | The JavaScript Backend+--+-- See documentation in GHC.StgToJS+jsBackend = Named JavaScript++-- | Via-C ("unregisterised") backend.+--+-- Compiles Cmm code into C code, then relies on a C compiler+-- to produce machine code.+--+-- It produces code objects that are /not/ ABI compatible+-- with those produced by NCG and LLVM backends.+--+-- Produced code is expected to be less efficient than the+-- one produced by NCG and LLVM backends because STG+-- registers are not pinned into real registers.  On the+-- other hand, it supports more target platforms (those+-- having a valid C toolchain).+--+-- See "GHC.CmmToC"+viaCBackend = Named ViaC++-- | The ByteCode interpreter.+--+-- Produce ByteCode objects (BCO, see "GHC.ByteCode") that+-- can be interpreted. It is used by GHCi.+--+-- Currently some extensions are not supported+-- (foreign primops).+--+-- See "GHC.StgToByteCode"+interpreterBackend = Named Interpreter++-- | A dummy back end that generates no code.+--+-- Use this back end to disable code generation. It is particularly+-- useful when GHC is used as a library for other purpose than+-- generating code (e.g. to generate documentation with Haddock) or+-- when the user requested it (via `-fno-code`) for some reason.+noBackend = Named NoBackend++---------------------------------------------------------------------------------+++++-- | This enumeration type specifies how the back end wishes GHC's+-- primitives to be implemented.  (Module "GHC.StgToCmm.Prim" provides+-- a generic implementation of every primitive, but some primitives,+-- like `IntQuotRemOp`, can be implemented more efficiently by+-- certain back ends on certain platforms.  For example, by using a+-- machine instruction that simultaneously computes quotient and remainder.)+--+-- For the meaning of each alternative, consult+-- "GHC.StgToCmm.Config".  (In a perfect world, type+-- `PrimitiveImplementation` would be defined there, in the module+-- that determines its meaning.  But I could not figure out how to do+-- it without mutual recursion across module boundaries.)++data PrimitiveImplementation+    = LlvmPrimitives    -- ^ Primitives supported by LLVM+    | NcgPrimitives     -- ^ Primitives supported by the native code generator+    | JSPrimitives      -- ^ Primitives supported by JS backend+    | GenericPrimitives -- ^ Primitives supported by all back ends+  deriving Show+++-- | Names a function that generates code and writes the results to a+--  file, of this type:+--+--  >    Logger+--  > -> DynFlags+--  > -> Module -- ^ module being compiled+--  > -> ModLocation+--  > -> FilePath -- ^ Where to write output+--  > -> Set UnitId -- ^ dependencies+--  > -> Stream IO RawCmmGroup a -- results from `StgToCmm`+--  > -> IO a+--+-- The functions so named are defined in "GHC.Driver.CodeOutput".+--+-- We expect one function per back end—or more precisely, one function+-- for each back end that writes code to a file.  (The interpreter+-- does not write to files; its output lives only in memory.)++data DefunctionalizedCodeOutput+  = NcgCodeOutput+  | ViaCCodeOutput+  | LlvmCodeOutput+  | JSCodeOutput+++-- | Names a function that tells the driver what should happen after+-- assembly code is written.  This might include running a C compiler,+-- running LLVM, running an assembler, or various similar activities.+-- The function named normally has this type:+--+-- >    TPipelineClass TPhase m+-- > => PipeEnv+-- > -> HscEnv+-- > -> Maybe ModLocation+-- > -> FilePath+-- > -> m (Maybe FilePath)+--+-- The functions so named are defined in "GHC.Driver.Pipeline".++data DefunctionalizedPostHscPipeline+  = NcgPostHscPipeline+  | ViaCPostHscPipeline+  | LlvmPostHscPipeline+  | JSPostHscPipeline+  | NoPostHscPipeline -- ^ After code generation, nothing else need happen.++-- | Names a function that tells the driver what command-line options+-- to include when invoking a C compiler.  It's meant for @-D@ options that+-- define symbols for the C preprocessor.  Because the exact symbols+-- defined might depend on versions of tools located in the file+-- system (/cough/ LLVM /cough/), the function requires an `IO` action.+-- The function named has this type:+--+-- > Logger -> DynFlags -> IO [String]++data DefunctionalizedCDefs+  = NoCDefs   -- ^ No additional command-line options are needed++  | LlvmCDefs -- ^ Return command-line options that tell GHC about the+              -- LLVM version.++---------------------------------------------------------------------------------++++-- | An informal description of the back end, for use in+-- issuing warning messages /only/.  If code depends on+-- what's in the string, you deserve what happens to you.+backendDescription :: Backend -> String+backendDescription (Named NCG)         = "native code generator"+backendDescription (Named LLVM)        = "LLVM"+backendDescription (Named ViaC)        = "compiling via C"+backendDescription (Named JavaScript)  = "compiling to JavaScript"+backendDescription (Named Interpreter) = "byte-code interpreter"+backendDescription (Named NoBackend)   = "no code generated"++-- | This flag tells the compiler driver whether the back+-- end will write files: interface files and object files.+-- It is typically true for "real" back ends that generate+-- code into the filesystem.  (That means, not the interpreter.)+backendWritesFiles :: Backend -> Bool+backendWritesFiles (Named NCG)         = True+backendWritesFiles (Named LLVM)        = True+backendWritesFiles (Named ViaC)        = True+backendWritesFiles (Named JavaScript)  = True+backendWritesFiles (Named Interpreter) = False+backendWritesFiles (Named NoBackend)   = False++-- | When the back end does write files, this value tells+-- the compiler in what manner of file the output should go:+-- temporary, persistent, or specific.+backendPipelineOutput :: Backend -> PipelineOutput+backendPipelineOutput (Named NCG)  = Persistent+backendPipelineOutput (Named LLVM) = Persistent+backendPipelineOutput (Named ViaC) = Persistent+backendPipelineOutput (Named JavaScript)  = Persistent+backendPipelineOutput (Named Interpreter) = NoOutputFile+backendPipelineOutput (Named NoBackend)   = NoOutputFile++-- | This flag tells the driver whether the back end can+-- reuse code (bytecode or object code) that has been+-- loaded dynamically.  Likely true only of the interpreter.+backendCanReuseLoadedCode :: Backend -> Bool+backendCanReuseLoadedCode (Named NCG)         = False+backendCanReuseLoadedCode (Named LLVM)        = False+backendCanReuseLoadedCode (Named ViaC)        = False+backendCanReuseLoadedCode (Named JavaScript)  = False+backendCanReuseLoadedCode (Named Interpreter) = True+backendCanReuseLoadedCode (Named NoBackend)   = False++-- | It is is true of every back end except @-fno-code@+-- that it "generates code."  Surprisingly, this property+-- influences the driver in a ton of ways.  Some examples:+--+--   * If the back end does not generate code, then the+--     driver needs to turn on code generation for+--     Template Haskell (because that code needs to be+--     generated and run at compile time).+--+--   * If the back end does not generate code, then the+--     driver does not need to deal with an output file.+--+--   * If the back end /does/ generated code, then the+--     driver supports `HscRecomp`.  If not, recompilation+--     does not need a linkable (and is automatically up+--     to date).+--+backendGeneratesCode :: Backend -> Bool+backendGeneratesCode (Named NCG)         = True+backendGeneratesCode (Named LLVM)        = True+backendGeneratesCode (Named ViaC)        = True+backendGeneratesCode (Named JavaScript)  = True+backendGeneratesCode (Named Interpreter) = True+backendGeneratesCode (Named NoBackend)   = False++backendGeneratesCodeForHsBoot :: Backend -> Bool+backendGeneratesCodeForHsBoot (Named NCG)         = True+backendGeneratesCodeForHsBoot (Named LLVM)        = True+backendGeneratesCodeForHsBoot (Named ViaC)        = True+backendGeneratesCodeForHsBoot (Named JavaScript)  = True+backendGeneratesCodeForHsBoot (Named Interpreter) = False+backendGeneratesCodeForHsBoot (Named NoBackend)   = False++-- | When set, this flag turns on interface writing for+-- Backpack.  It should probably be the same as+-- `backendGeneratesCode`, but it is kept distinct for+-- reasons described in Note [-fno-code mode].+backendSupportsInterfaceWriting :: Backend -> Bool+backendSupportsInterfaceWriting (Named NCG)         = True+backendSupportsInterfaceWriting (Named LLVM)        = True+backendSupportsInterfaceWriting (Named ViaC)        = True+backendSupportsInterfaceWriting (Named JavaScript)  = True+backendSupportsInterfaceWriting (Named Interpreter) = True+backendSupportsInterfaceWriting (Named NoBackend)   = False++-- | When preparing code for this back end, the type+-- checker should pay attention to SPECIALISE pragmas.  If+-- this flag is `False`, then the type checker ignores+-- SPECIALISE pragmas (for imported things?).+backendRespectsSpecialise :: Backend -> Bool+backendRespectsSpecialise (Named NCG)         = True+backendRespectsSpecialise (Named LLVM)        = True+backendRespectsSpecialise (Named ViaC)        = True+backendRespectsSpecialise (Named JavaScript)  = True+backendRespectsSpecialise (Named Interpreter) = False+backendRespectsSpecialise (Named NoBackend)   = False++-- | This back end wants the `mi_top_env` field of a+-- `ModIface` to be populated (with the top-level bindings+-- of the original source).  Only true for the interpreter.+backendWantsGlobalBindings :: Backend -> Bool+backendWantsGlobalBindings (Named NCG)         = False+backendWantsGlobalBindings (Named LLVM)        = False+backendWantsGlobalBindings (Named ViaC)        = False+backendWantsGlobalBindings (Named JavaScript)  = False+backendWantsGlobalBindings (Named NoBackend)   = False+backendWantsGlobalBindings (Named Interpreter) = True++-- | The back end targets a technology that implements+-- `switch` natively.  (For example, LLVM or C.) Therefore+-- it is not necessary for GHC to ccompile a Cmm `Switch`+-- form into a decision tree with jump tables at the+-- leaves.+backendHasNativeSwitch :: Backend -> Bool+backendHasNativeSwitch (Named NCG)         = False+backendHasNativeSwitch (Named LLVM)        = True+backendHasNativeSwitch (Named ViaC)        = True+backendHasNativeSwitch (Named JavaScript)  = True+backendHasNativeSwitch (Named Interpreter) = False+backendHasNativeSwitch (Named NoBackend)   = False++-- | As noted in the documentation for+-- `PrimitiveImplementation`, certain primitives have+-- multiple implementations, depending on the capabilities+-- of the back end.  This field signals to module+-- "GHC.StgToCmm.Prim" what implementations to use with+-- this back end.+backendPrimitiveImplementation :: Backend -> PrimitiveImplementation+backendPrimitiveImplementation (Named NCG)         = NcgPrimitives+backendPrimitiveImplementation (Named LLVM)        = LlvmPrimitives+backendPrimitiveImplementation (Named JavaScript)  = JSPrimitives+backendPrimitiveImplementation (Named ViaC)        = GenericPrimitives+backendPrimitiveImplementation (Named Interpreter) = GenericPrimitives+backendPrimitiveImplementation (Named NoBackend)   = GenericPrimitives++-- | When this value is `IsValid`, the back end is+-- compatible with vector instructions.  When it is+-- `NotValid`, it carries a message that is shown to+-- users.+backendSimdValidity :: Backend -> Validity' String+backendSimdValidity (Named NCG)         = IsValid+backendSimdValidity (Named LLVM)        = IsValid+backendSimdValidity (Named ViaC)        = NotValid $ unlines ["SIMD vector instructions require using the NCG or the LLVM backend."]+backendSimdValidity (Named JavaScript)  = NotValid $ unlines ["SIMD vector instructions require using the NCG or the LLVM backend."]+backendSimdValidity (Named Interpreter) = NotValid $ unlines ["SIMD vector instructions require using the NCG or the LLVM backend."]+backendSimdValidity (Named NoBackend)   = NotValid $ unlines ["SIMD vector instructions require using the NCG or the LLVM backend."]++-- | This flag says whether the back end supports large+-- binary blobs.  See Note [Embedding large binary blobs]+-- in "GHC.CmmToAsm.Ppr".+backendSupportsEmbeddedBlobs :: Backend -> Bool+backendSupportsEmbeddedBlobs (Named NCG)         = True+backendSupportsEmbeddedBlobs (Named LLVM)        = False+backendSupportsEmbeddedBlobs (Named ViaC)        = False+backendSupportsEmbeddedBlobs (Named JavaScript)  = False+backendSupportsEmbeddedBlobs (Named Interpreter) = False+backendSupportsEmbeddedBlobs (Named NoBackend)   = False++-- | This flag tells the compiler driver that the back end+-- does not support every target platform; it supports+-- only platforms that claim NCG support.  (It's set only+-- for the native code generator.)  Crufty.  If the driver+-- tries to use the native code generator /without/+-- platform support, the driver fails over to the LLVM+-- back end.+backendNeedsPlatformNcgSupport :: Backend -> Bool+backendNeedsPlatformNcgSupport (Named NCG)         = True+backendNeedsPlatformNcgSupport (Named LLVM)        = False+backendNeedsPlatformNcgSupport (Named ViaC)        = False+backendNeedsPlatformNcgSupport (Named JavaScript)  = False+backendNeedsPlatformNcgSupport (Named Interpreter) = False+backendNeedsPlatformNcgSupport (Named NoBackend)   = False++-- | This flag is set if the back end can generate code+-- for proc points.  If the flag is not set, then a Cmm+-- pass needs to split proc points (that is, turn each+-- proc point into a standalone procedure).+backendSupportsUnsplitProcPoints :: Backend -> Bool+backendSupportsUnsplitProcPoints (Named NCG)         = True+backendSupportsUnsplitProcPoints (Named LLVM)        = False+backendSupportsUnsplitProcPoints (Named ViaC)        = False+backendSupportsUnsplitProcPoints (Named JavaScript)  = False+backendSupportsUnsplitProcPoints (Named Interpreter) = False+backendSupportsUnsplitProcPoints (Named NoBackend)   = False++-- | This flag guides the driver in resolving issues about+-- API support on the target platform. If the flag is set,+-- then these things are true:+--+--    * When the target platform supports /only/ an unregisterised API,+--      this backend can be replaced with compilation via C.+--+--    * When the target does /not/ support an unregisterised API,+--      this back end can replace compilation via C.+--+backendSwappableWithViaC :: Backend -> Bool+backendSwappableWithViaC (Named NCG)         = True+backendSwappableWithViaC (Named LLVM)        = True+backendSwappableWithViaC (Named ViaC)        = False+backendSwappableWithViaC (Named JavaScript)  = False+backendSwappableWithViaC (Named Interpreter) = False+backendSwappableWithViaC (Named NoBackend)   = False++-- | This flag is true if the back end works *only* with+-- the unregisterised ABI.+backendUnregisterisedAbiOnly :: Backend -> Bool+backendUnregisterisedAbiOnly (Named NCG)         = False+backendUnregisterisedAbiOnly (Named LLVM)        = False+backendUnregisterisedAbiOnly (Named ViaC)        = True+backendUnregisterisedAbiOnly (Named JavaScript)  = False+backendUnregisterisedAbiOnly (Named Interpreter) = False+backendUnregisterisedAbiOnly (Named NoBackend)   = False++-- | This flag is set if the back end generates C code in+-- a @.hc@ file.  The flag lets the compiler driver know+-- if the command-line flag @-C@ is meaningful.+backendGeneratesHc :: Backend -> Bool+backendGeneratesHc (Named NCG)         = False+backendGeneratesHc (Named LLVM)        = False+backendGeneratesHc (Named ViaC)        = True+backendGeneratesHc (Named JavaScript)  = False+backendGeneratesHc (Named Interpreter) = False+backendGeneratesHc (Named NoBackend)   = False++-- | This flag says whether SPT (static pointer table)+-- entries will be inserted dynamically if needed.  If+-- this flag is `False`, then "GHC.Iface.Tidy" should emit C+-- stubs that initialize the SPT entries.+backendSptIsDynamic :: Backend -> Bool+backendSptIsDynamic (Named NCG)         = False+backendSptIsDynamic (Named LLVM)        = False+backendSptIsDynamic (Named ViaC)        = False+backendSptIsDynamic (Named JavaScript)  = False+backendSptIsDynamic (Named Interpreter) = True+backendSptIsDynamic (Named NoBackend)   = False++-- | If this flag is unset, then the driver ignores the flag @-fbreak-points@,+-- since backends other than the interpreter tend to panic on breakpoints.+backendSupportsBreakpoints :: Backend -> Bool+backendSupportsBreakpoints = \case+  Named NCG         -> False+  Named LLVM        -> False+  Named ViaC        -> False+  Named JavaScript  -> False+  Named Interpreter -> True+  Named NoBackend   -> False++-- | If this flag is set, then the driver forces the+-- optimization level to 0, issuing a warning message if+-- the command line requested a higher optimization level.+backendForcesOptimization0 :: Backend -> Bool+backendForcesOptimization0 (Named NCG)         = False+backendForcesOptimization0 (Named LLVM)        = False+backendForcesOptimization0 (Named ViaC)        = False+backendForcesOptimization0 (Named JavaScript)  = False+backendForcesOptimization0 (Named Interpreter) = True+backendForcesOptimization0 (Named NoBackend)   = False++-- | I don't understand exactly how this works.  But if+-- this flag is set *and* another condition is met, then+-- @ghc/Main.hs@ will alter the `DynFlags` so that all the+-- `hostFullWays` are asked for.  It is set only for the interpreter.+backendNeedsFullWays :: Backend -> Bool+backendNeedsFullWays (Named NCG)         = False+backendNeedsFullWays (Named LLVM)        = False+backendNeedsFullWays (Named ViaC)        = False+backendNeedsFullWays (Named JavaScript)  = False+backendNeedsFullWays (Named Interpreter) = True+backendNeedsFullWays (Named NoBackend)   = False++-- | This flag is also special for the interpreter: if a+-- message about a module needs to be shown, do we know+-- anything special about where the module came from?  The+-- Boolean argument is a `recomp` flag.+backendSpecialModuleSource :: Backend -> Bool -> Maybe String+backendSpecialModuleSource (Named NCG)         = const Nothing+backendSpecialModuleSource (Named LLVM)        = const Nothing+backendSpecialModuleSource (Named ViaC)        = const Nothing+backendSpecialModuleSource (Named JavaScript)  = const Nothing+backendSpecialModuleSource (Named Interpreter) = \b -> if b then Just "interpreted" else Nothing+backendSpecialModuleSource (Named NoBackend)   = const (Just "nothing")++-- | This flag says whether the back end supports Haskell+-- Program Coverage (HPC). If not, the compiler driver+-- will ignore the `-fhpc` option (and will issue a+-- warning message if it is used).+backendSupportsHpc :: Backend -> Bool+backendSupportsHpc (Named NCG)         = True+backendSupportsHpc (Named LLVM)        = True+backendSupportsHpc (Named ViaC)        = True+backendSupportsHpc (Named JavaScript)  = False+backendSupportsHpc (Named Interpreter) = False+backendSupportsHpc (Named NoBackend)   = True++-- | This flag says whether the back end supports foreign+-- import of C functions.  ("Supports" means "does not+-- barf on," so @-fno-code@ supports foreign C imports.)+backendSupportsCImport :: Backend -> Bool+backendSupportsCImport (Named NCG)         = True+backendSupportsCImport (Named LLVM)        = True+backendSupportsCImport (Named ViaC)        = True+backendSupportsCImport (Named JavaScript)  = True+backendSupportsCImport (Named Interpreter) = True+backendSupportsCImport (Named NoBackend)   = True++-- | This flag says whether the back end supports foreign+-- export of Haskell functions to C.+backendSupportsCExport :: Backend -> Bool+backendSupportsCExport (Named NCG)         = True+backendSupportsCExport (Named LLVM)        = True+backendSupportsCExport (Named ViaC)        = True+backendSupportsCExport (Named JavaScript)  = True+backendSupportsCExport (Named Interpreter) = False+backendSupportsCExport (Named NoBackend)   = True++-- | When using this back end, it may be necessary or+-- advisable to pass some `-D` options to a C compiler.+-- This (defunctionalized) function produces those+-- options, if any.  An IO action may be necessary in+-- order to interrogate external tools about what version+-- they are, for example.+--+-- The function's type is+-- @+-- Logger -> DynFlags -> IO [String]+-- @+--+-- This field is usually defaulted.+backendCDefs :: Backend -> DefunctionalizedCDefs+backendCDefs (Named NCG)         = NoCDefs+backendCDefs (Named LLVM)        = LlvmCDefs+backendCDefs (Named ViaC)        = NoCDefs+backendCDefs (Named JavaScript)  = NoCDefs+backendCDefs (Named Interpreter) = NoCDefs+backendCDefs (Named NoBackend)   = NoCDefs++-- | This (defunctionalized) function generates code and+-- writes it to a file.  The type of the function is+--+-- >    Logger+-- > -> DynFlags+-- > -> Module -- ^ module being compiled+-- > -> ModLocation+-- > -> FilePath -- ^ Where to write output+-- > -> Set UnitId -- ^ dependencies+-- > -> Stream IO RawCmmGroup a -- results from `StgToCmm`+-- > -> IO a+backendCodeOutput :: Backend -> DefunctionalizedCodeOutput+backendCodeOutput (Named NCG)         = NcgCodeOutput+backendCodeOutput (Named LLVM)        = LlvmCodeOutput+backendCodeOutput (Named ViaC)        = ViaCCodeOutput+backendCodeOutput (Named JavaScript)  = JSCodeOutput+backendCodeOutput (Named Interpreter) = panic "backendCodeOutput: interpreterBackend"+backendCodeOutput (Named NoBackend)   = panic "backendCodeOutput: noBackend"++backendUseJSLinker :: Backend -> Bool+backendUseJSLinker (Named NCG)         = False+backendUseJSLinker (Named LLVM)        = False+backendUseJSLinker (Named ViaC)        = False+backendUseJSLinker (Named JavaScript)  = True+backendUseJSLinker (Named Interpreter) = False+backendUseJSLinker (Named NoBackend)   = False++-- | This (defunctionalized) function tells the compiler+-- driver what else has to be run after code output.+-- The type of the function is+--+-- >+-- >    TPipelineClass TPhase m+-- > => PipeEnv+-- > -> HscEnv+-- > -> Maybe ModLocation+-- > -> FilePath+-- > -> m (Maybe FilePath)+backendPostHscPipeline :: Backend -> DefunctionalizedPostHscPipeline+backendPostHscPipeline (Named NCG)  = NcgPostHscPipeline+backendPostHscPipeline (Named LLVM) = LlvmPostHscPipeline+backendPostHscPipeline (Named ViaC) = ViaCPostHscPipeline+backendPostHscPipeline (Named JavaScript)  = JSPostHscPipeline+backendPostHscPipeline (Named Interpreter) = NoPostHscPipeline+backendPostHscPipeline (Named NoBackend) = NoPostHscPipeline++-- | Somewhere in the compiler driver, when compiling+-- Haskell source (as opposed to a boot file or a sig+-- file), it needs to know what to do with the code that+-- the `backendCodeOutput` writes to a file.  This `Phase`+-- value gives instructions like "run the C compiler",+-- "run the assembler," or "run the LLVM Optimizer."+backendNormalSuccessorPhase :: Backend -> Phase+backendNormalSuccessorPhase (Named NCG)  = As False+backendNormalSuccessorPhase (Named LLVM) = LlvmOpt+backendNormalSuccessorPhase (Named ViaC) = HCc+backendNormalSuccessorPhase (Named JavaScript)  = StopLn+backendNormalSuccessorPhase (Named Interpreter) = StopLn+backendNormalSuccessorPhase (Named NoBackend)   = StopLn++-- | Name of the back end, if any.  Used to migrate legacy+-- clients of the GHC API.  Code within the GHC source+-- tree should not refer to a back end's name.+backendName :: Backend -> BackendName+backendName (Named NCG)  = NCG+backendName (Named LLVM) = LLVM+backendName (Named ViaC) = ViaC+backendName (Named JavaScript)  = JavaScript+backendName (Named Interpreter) = Interpreter+backendName (Named NoBackend)   = NoBackend++++-- | A list of all back ends.  They are ordered as we wish them to+-- appear when they are enumerated in error messages.++allBackends :: [Backend]+allBackends = [ ncgBackend+              , llvmBackend+              , viaCBackend+              , jsBackend+              , interpreterBackend+              , noBackend+              ]++-- | When foreign C import or export is invalid, the carried value+-- enumerates the /valid/ back ends.++backendValidityOfCImport, backendValidityOfCExport :: Backend -> Validity' [Backend]++backendValidityOfCImport backend =+    if backendSupportsCImport backend then+        IsValid+    else+        NotValid $ filter backendSupportsCImport allBackends++backendValidityOfCExport backend =+    if backendSupportsCExport backend then+        IsValid+    else+        NotValid $ filter backendSupportsCExport allBackends+++++{-+Note [Backend Defunctionalization]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+I had hoped to include code-output and post-hsc-pipeline functions+directly in the `Backend` record itself.  But this agenda was derailed+by mutual recursion in the types:++  - A `DynFlags` record contains a back end of type `Backend`.+  - A `Backend` contains a code-output function.+  - A code-output function takes Cmm as input.+  - Cmm can include a `CLabel`.+  - A `CLabel` can have elements that are defined in+    `GHC.Driver.Session`, where `DynFlags` is defined.++There is also a nasty issue in the values: a typical post-backend+pipeline function both depends on and is depended upon by functions in+"GHC.Driver.Pipeline".++I'm cut the Gordian not by removing the function types from the+`Backend` record.  Instead, a function is represented by its /name/.+This representation is an example of an old trick called+/defunctionalization/, which has been used in both compilers and+interpreters for languages with first-class, nested functions.  Here,+a function's name is a value of an algebraic data type.  For example,+a code-output function is represented by a value of this type:++    data DefunctionalizedCodeOutput+      = NcgCodeOutput+      | ViaCCodeOutput+      | LlvmCodeOutput++Such a function may be applied in one of two ways:++  - In this particular example, a `case` expression in module+    "GHC.Driver.CodeOutput" discriminates on the value and calls the+    designated function.++  - In another example, a function of type `DefunctionalizedCDefs` is+    applied by calling function `applyCDefs`, which has this type:++    @+    applyCDefs :: DefunctionalizedCDefs -> Logger -> DynFlags -> IO [String]+    @++    Function `applyCDefs` is defined in module "GHC.SysTools.Cpp".++I don't love this solution, but defunctionalization is a standard+thing, and it makes the meanings of the enumeration values clear.++Anyone defining a new back end will need to extend both the+`DefunctionalizedCodeOutput` type and the corresponding apply+function.+-}
+ GHC/Driver/Backend/Internal.hs view
@@ -0,0 +1,33 @@+{-|+Module      : GHC.Driver.Backend.Internal+Description : Interface for migrating legacy clients of the GHC API++In versions of GHC up through 9.2, a `Backend` was represented only by+its name.  This module is meant to aid clients written against the GHC+API, versions 9.2 and older.  The module provides an alternative way+to name any back end found in GHC 9.2.  /Code within the GHC source+tree should not import this module./ (#20927).++Only back ends found in version 9.2 have names.++-}++module GHC.Driver.Backend.Internal+   ( -- * Name of a back end+     BackendName(..)+   )++where++++import GHC.Prelude++data BackendName+   = NCG           -- ^ Names the native code generator backend.+   | LLVM          -- ^ Names the LLVM backend.+   | ViaC          -- ^ Names the Via-C backend.+   | JavaScript    -- ^ Names the JS backend.+   | Interpreter   -- ^ Names the ByteCode interpreter.+   | NoBackend     -- ^ Names the `-fno-code` backend.+ deriving (Eq, Show)
GHC/Driver/Backpack.hs view
@@ -20,10 +20,11 @@  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 (initParserOpts)+import GHC.Driver.Config.Parser import GHC.Driver.Config.Diagnostic import GHC.Driver.Monad import GHC.Driver.Session@@ -44,14 +45,13 @@ import GHC hiding (Failed, Succeeded) import GHC.Tc.Utils.Monad import GHC.Iface.Recomp-import GHC.Builtin.Names  import GHC.Types.SrcLoc import GHC.Types.SourceError import GHC.Types.SourceFile import GHC.Types.Unique.FM-import GHC.Types.Unique.DFM import GHC.Types.Unique.DSet+import GHC.Types.Basic (convImportLevel)  import GHC.Utils.Outputable import GHC.Utils.Fingerprint@@ -66,13 +66,13 @@ import GHC.Unit.Finder import GHC.Unit.Module.Graph import GHC.Unit.Module.ModSummary-import GHC.Unit.Home.ModInfo  import GHC.Linker.Types  import qualified GHC.LanguageExtensions as LangExt  import GHC.Data.Maybe+import GHC.Data.OsPath (unsafeEncodeUtf, os) import GHC.Data.StringBuffer import GHC.Data.FastString import qualified GHC.Data.EnumSet as EnumSet@@ -89,6 +89,10 @@ 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 ()@@ -97,16 +101,18 @@     dflags0 <- getDynFlags     let dflags1 = dflags0     let parser_opts1 = initParserOpts dflags1-    (p_warns, src_opts) <- liftIO $ getOptionsFromFile parser_opts1 src_filename-    (dflags, unhandled_flags, warns) <- liftIO $ parseDynamicFilePragma dflags1 src_opts+    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-    liftIO $ printOrThrowDiagnostics logger (initDiagOpts dflags) (GhcPsMessage <$> p_warns)-    liftIO $ handleFlagWarnings logger (initDiagOpts dflags) warns+    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@@ -137,9 +143,9 @@   where     cid = hsComponentId (unLoc (hsunitName unit))     reqs = uniqDSetToList (unionManyUniqDSets (map (get_reqs . unLoc) (hsunitBody unit)))-    get_reqs (DeclD HsigFile (L _ modname) _) = unitUniqDSet modname     get_reqs (DeclD HsSrcFile _ _) = emptyUniqDSet     get_reqs (DeclD HsBootFile _ _) = emptyUniqDSet+    get_reqs (DeclD HsigFile (L _ modname) _) = unitUniqDSet modname     get_reqs (IncludeD (IncludeDecl (L _ hsuid) _ _)) =         unitFreeModuleHoles (convertHsComponentId hsuid) @@ -188,7 +194,7 @@           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+                            TcSession -> noBackend                             _         -> backend dflags             , ghcLink = case session_type of                             TcSession -> NoLink@@ -214,7 +220,7 @@                 -- Make sure to write interfaces when we are type-checking                 -- indefinite packages.                 TcSession-                  | backend dflags /= NoBackend+                  | backendSupportsInterfaceWriting $ backend dflags                   -> EnumSet.insert Opt_WriteInterface (generalFlags dflags)                 _ -> generalFlags dflags @@ -327,10 +333,10 @@         mod_graph <- hsunitModuleGraph False (unLoc lunit)          msg <- mkBackpackMsg-        ok <- load' noIfaceCache LoadAllTargets (Just msg) mod_graph+        ok <- load' noIfaceCache LoadAllTargets mkUnknownDiagnostic (Just msg) mod_graph         when (failed ok) (liftIO $ exitWith (ExitFailure 1)) -        let hi_dir = expectJust (panic "hiDir Backpack") $ hiDir dflags+        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@@ -338,15 +344,17 @@          -- Compile relevant only         hsc_env <- getSession-        let home_mod_infos = eltsUDFM (hsc_HPT hsc_env)-            linkables = map (expectJust "bkp link" . hm_linkable)-                      . filter ((==HsSrcFile) . mi_hsc_src . hm_iface)-                      $ home_mod_infos-            getOfiles LM{ linkableUnlinked = us } = map nameOfObject (filter isObject us)-            obj_files = concatMap getOfiles linkables+        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 -        let compat_fs = unitIdFS cid+            compat_fs = unitIdFS cid             compat_pn = PackageName compat_fs             unit_id   = homeUnitId (hsc_home_unit hsc_env) @@ -416,7 +424,7 @@     withBkpExeSession deps_w_rns $ do         mod_graph <- hsunitModuleGraph True (unLoc lunit)         msg <- mkBackpackMsg-        ok <- load' noIfaceCache LoadAllTargets (Just msg) mod_graph+        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@@ -439,16 +447,17 @@     -- update platform constants     dflags <- liftIO $ updatePlatformConstants dflags0 mconstants -    let unit_env = ue_setUnits unit_state $ ue_setUnitDbs (Just dbs) $ UnitEnv+    let unit_env = UnitEnv           { ue_platform  = targetPlatform dflags           , ue_namever   = ghcNameVersion dflags           , ue_current_unit = homeUnitId home_unit            , ue_home_unit_graph =-                unitEnv_singleton+                HUG.unitEnv_singleton                     (homeUnitId home_unit)-                    (mkHomeUnitEnv dflags (ue_hpt old_unit_env) (Just 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 } @@ -577,7 +586,7 @@             NeedsRecompile reason0 -> showMsg (text "Instantiating ") $ case reason0 of               MustCompile -> empty               RecompBecause reason -> text " [" <> pprWithUnitState state (ppr reason) <> text "]"-        ModuleNode _ _ ->+        ModuleNode {} ->           case recomp of             UpToDate               | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg (text "Skipping  ") empty@@ -586,6 +595,7 @@               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@@ -595,7 +605,9 @@     mkUserStyle         (QueryQualify neverQualifyNames                       alwaysQualifyModules-                      neverQualifyPackages) AllTheWay+                      neverQualifyPackages+                      alwaysPrintPromTick)+        AllTheWay  -- | Message when we initially process a Backpack unit. msgTopPackage :: (Int,Int) -> HsComponentId -> BkpM ()@@ -736,16 +748,19 @@     --  create an "empty" hsig file to induce compilation for the     --  requirement.     let hsig_set = Set.fromList-          [ ms_mod_name ms+          [ moduleNodeInfoModuleName ms           | ModuleNode _ ms <- nodes-          , ms_hsc_src ms == HsigFile+          , 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 graph_nodes = nodes ++ req_nodes ++ (instantiationNodes (homeUnitId $ hsc_home_unit hsc_env) (hsc_units hsc_env))+    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@@ -767,7 +782,7 @@      let PackageName pn_fs = pn     let location = mkHomeModLocation2 fopts mod_name-                    (unpackFS pn_fs </> moduleNameSlashes mod_name) "hsig"+                    (unsafeEncodeUtf $ unpackFS pn_fs </> moduleNameSlashes mod_name) (os "hsig")      env <- getBkpEnv     src_hash <- liftIO $ getFileHash (bkp_filename env)@@ -776,7 +791,7 @@     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+    mod <- liftIO $ addHomeModuleToFinder fc home_unit mod_name location HsigFile      extra_sig_imports <- liftIO $ findExtraSigImports hsc_env HsigFile mod_name @@ -790,18 +805,19 @@         ms_iface_date = hi_timestamp,         ms_hie_date = hie_timestamp,         ms_srcimps = [],-        ms_textual_imps = ((,) NoPkgQual . noLoc) <$> extra_sig_imports,-        ms_ghc_prim_import = False,+        ms_textual_imps = ((,,) NormalLevel NoPkgQual . noLoc) <$> extra_sig_imports,         ms_parsed_mod = Just (HsParsedModule {                 hpm_module = L loc (HsModule {-                        hsmodAnn = noAnn,-                        hsmodLayout = NoLayoutInfo,+                        hsmodExt = XModulePs {+                            hsmodAnn = noAnn,+                            hsmodLayout = EpNoLayout,+                            hsmodDeprecMessage = Nothing,+                            hsmodHaddockModHeader = Nothing+                                             },                         hsmodName = Just (L (noAnnSrcSpan loc) mod_name),                         hsmodExports = Nothing,                         hsmodImports = [],-                        hsmodDecls = [],-                        hsmodDeprecMessage = Nothing,-                        hsmodHaddockModHeader = Nothing+                        hsmodDecls = []                     }),                 hpm_src_files = []             }),@@ -809,13 +825,13 @@         ms_hspp_opts = dflags,         ms_hspp_buf = Nothing         }-    let nodes = [NodeKey_Module (ModNodeKeyWithUid (GWIB mn NotBoot) (homeUnitId home_unit)) | mn <- extra_sig_imports ]-    return (ModuleNode nodes ms)+    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+              -> Located (HsModule GhcPs)               -> [NodeKey]               -> BkpM ModuleGraphNode summariseDecl pn hsc_src (L _ modname) hsmod home_keys = hsModuleToModSummary home_keys pn hsc_src modname hsmod@@ -829,7 +845,7 @@                      -> PackageName                      -> HscSource                      -> ModuleName-                     -> Located HsModule+                     -> Located (HsModule GhcPs)                      -> BkpM ModuleGraphNode hsModuleToModSummary home_keys pn hsc_src modname                      hsmod = do@@ -847,17 +863,14 @@     -- To add insult to injury, we don't even actually use     -- these filenames to figure out where the hi files go.     -- A travesty!-    let location0 = mkHomeModLocation2 fopts modname-                             (unpackFS unit_fs </>+    let location = mkHomeModLocation fopts modname+                             (unsafeEncodeUtf $ unpackFS unit_fs </>                               moduleNameSlashes modname)-                              (case hsc_src of-                                HsigFile -> "hsig"-                                HsBootFile -> "hs-boot"-                                HsSrcFile -> "hs")-    -- DANGEROUS: bootifying can POISON the module finder cache-    let location = case hsc_src of-                        HsBootFile -> addBootSuffixLocnOut location0-                        _ -> location0+                             (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)@@ -865,28 +878,23 @@     -- Also copied from 'getImports'     let (src_idecls, ord_idecls) = partition ((== IsBoot) . ideclSource . unLoc) imps -             -- GHC.Prim doesn't exist physically, so don't go looking for it.-        (ordinary_imps, ghc_prim_import)-          = partition ((/= moduleName gHC_PRIM) . unLoc . ideclName . unLoc)-              ord_idecls-         implicit_prelude = xopt LangExt.ImplicitPrelude dflags         implicit_imports = mkPrelImports modname loc                                          implicit_prelude imps          rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env) modname-        convImport (L _ i) = (rn_pkg_qual (ideclPkgQual i), reLoc $ ideclName i)+        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 ++ ordinary_imps)+    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+      addHomeModuleToFinder fc home_unit modname location hsc_src     let ms = ModSummary {             ms_mod = this_mod,             ms_hsc_src = hsc_src,@@ -896,14 +904,13 @@                             Just d -> d) </> ".." </> moduleNameSlashes modname <.> "hi",             ms_hspp_opts = dflags,             ms_hspp_buf = Nothing,-            ms_srcimps = map convImport src_idecls,-            ms_ghc_prim_import = not (null ghc_prim_import),+            ms_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-                           ++ ((,) NoPkgQual . noLoc <$> extra_sig_imports)-                           ++ ((,) NoPkgQual . noLoc <$> implicit_sigs),+                           ++ ((,,) 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,@@ -923,16 +930,16 @@     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 ] +++          [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]+          [k | (_, _,  mnwib) <- msDeps ms, let k = NodeKey_Module (ModNodeKeyWithUid (fmap unLoc mnwib) (moduleUnitId this_mod)), k `elem` home_keys]  -    return (ModuleNode (mod_nodes ++ inst_nodes) ms)+    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 (unitIdFS uid `appendFS` mkFastString "+" `appendFS` hash)+   Just hash -> UnitId (concatFS [unitIdFS uid, fsLit "+", hash])
GHC/Driver/Backpack/Syntax.hs view
@@ -23,7 +23,6 @@ import GHC.Types.SrcLoc import GHC.Types.SourceFile -import GHC.Unit.Module.Name import GHC.Unit.Types import GHC.Unit.Info @@ -65,7 +64,7 @@ -- | A declaration in a package, e.g. a module or signature definition, -- or an include. data HsUnitDecl n-    = DeclD   HscSource (Located ModuleName) (Located HsModule)+    = DeclD   HscSource (Located ModuleName) (Located (HsModule GhcPs))     | IncludeD   (IncludeDecl n) type LHsUnitDecl n = Located (HsUnitDecl n)
GHC/Driver/CmdLine.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE RankNTypes #-}  -------------------------------------------------------------------------------@@ -16,7 +17,7 @@       Flag(..), defFlag, defGhcFlag, defGhciFlag, defHiddenFlag, hoistFlag,       errorsToGhcException, -      Err(..), Warn(..), WarnReason(..),+      Err(..), Warn, warnsToMessages,        EwM, runEwM, addErr, addWarn, addFlagWarn, getArg, getCurLoc, liftEwM     ) where@@ -24,21 +25,22 @@ import GHC.Prelude  import GHC.Utils.Misc-import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Utils.Panic.Plain import GHC.Data.Bag import GHC.Types.SrcLoc-import GHC.Utils.Json--import GHC.Types.Error ( DiagnosticReason(..) )+import 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 (liftM, ap)+import Control.Monad (ap) import Control.Monad.IO.Class  --------------------------------------------------------@@ -73,7 +75,7 @@       go (OptPrefix k) = OptPrefix (\s -> go2 (k s))       go (OptIntSuffix k) = OptIntSuffix (\n -> go2 (k n))       go (IntSuffix k) = IntSuffix (\n -> go2 (k n))-      go (WordSuffix k) = WordSuffix (\s -> go2 (k s))+      go (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))@@ -96,7 +98,7 @@     | 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-    | WordSuffix (Word -> 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@@ -106,41 +108,23 @@ --         The EwM monad -------------------------------------------------------- --- | Used when filtering warnings: if a reason is given--- it can be filtered out when displaying.-data WarnReason-  = NoReason-  | ReasonDeprecatedFlag-  | ReasonUnrecognisedFlag-  deriving (Eq, Show)--instance Outputable WarnReason where-  ppr = text . show--instance ToJson WarnReason where-  json NoReason = JSNull-  json reason   = JSString $ show reason- -- | A command-line error message newtype Err  = Err { errMsg :: Located String }  -- | A command-line warning message and the reason it arose-data Warn = Warn-  {   warnReason :: DiagnosticReason,-      warnMsg    :: Located String-  }+--+-- This used to be own type, but now it's just @'MsgEnvelope' 'DriverMessage'@.+type Warn = Located DriverMessage  type Errs  = Bag Err-type Warns = Bag Warn+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) }--instance Monad m => Functor (EwM m) where-    fmap = liftM+  deriving (Functor)  instance Monad m => Applicative (EwM m) where     pure v = EwM (\_ e w -> return (e, w, v))@@ -153,7 +137,7 @@     liftIO = liftEwM . liftIO  runEwM :: EwM m a -> m (Errs, Warns, a)-runEwM action = unEwM action (panic "processArgs: no arg yet") emptyBag emptyBag+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)@@ -162,11 +146,12 @@ addErr e = EwM (\(L loc _) es ws -> return (es `snocBag` Err (L loc e), ws, ()))  addWarn :: Monad m => String -> EwM m ()-addWarn = addFlagWarn WarningWithoutFlag+addWarn msg = addFlagWarn $ DriverUnknownMessage $ mkSimpleUnknownDiagnostic $+  mkPlainDiagnostic WarningWithoutFlag noHints $ text msg -addFlagWarn :: Monad m => DiagnosticReason -> String -> EwM m ()-addFlagWarn reason msg = EwM $-  (\(L loc _) es ws -> return (es, ws `snocBag` Warn reason (L loc 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))@@ -177,6 +162,10 @@ 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@@ -188,10 +177,10 @@             -> (FilePath -> EwM m [Located String]) -- ^ response file handler             -> m ( [Located String],  -- spare args                    [Err],  -- errors-                   [Warn] ) -- warnings+                   Warns ) -- warnings processArgs spec args handleRespFile = do     (errs, warns, spare) <- runEwM action-    return (spare, bagToList errs, bagToList warns)+    return (spare, bagToList errs, warns)   where     action = process args [] @@ -251,7 +240,7 @@         IntSuffix f | Just n <- parseInt rest_no_eq -> Right (f n, args)                     | otherwise -> Left ("malformed integer argument in " ++ dash_arg) -        WordSuffix f | Just n <- parseWord rest_no_eq -> Right (f n, args)+        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)@@ -280,7 +269,7 @@                                             -- to improve error message (#12625) arg_ok (OptIntSuffix    _)  _    _   = True arg_ok (IntSuffix       _)  _    _   = True-arg_ok (WordSuffix      _)  _    _   = True+arg_ok (Word64Suffix    _)  _    _   = True arg_ok (FloatSuffix     _)  _    _   = True arg_ok (OptPrefix       _)  _    _   = True arg_ok (PassFlag        _)  rest _   = null rest@@ -296,8 +285,8 @@                  ((n,""):_) -> Just n                  _          -> Nothing -parseWord :: String -> Maybe Word-parseWord s = case reads s of+parseWord64 :: String -> Maybe Word64+parseWord64 s = case reads s of                  ((n,""):_) -> Just n                  _          -> Nothing
GHC/Driver/CodeOutput.hs view
@@ -17,6 +17,7 @@ import GHC.Prelude import GHC.Platform import GHC.ForeignSrcLang+import GHC.Data.FastString  import GHC.CmmToAsm     ( nativeCodeGen ) import GHC.CmmToLlvm    ( llvmCodeGen )@@ -26,15 +27,19 @@ import GHC.Cmm import GHC.Cmm.CLabel -import GHC.Driver.Session-import GHC.Driver.Config.Finder    (initFinderOpts)-import GHC.Driver.Config.CmmToAsm  (initNCGConfig)-import GHC.Driver.Config.CmmToLlvm (initLlvmCgConfig)+import GHC.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           ( Stream )+import GHC.Data.Stream           ( liftIO ) import qualified GHC.Data.Stream as Stream  import GHC.Utils.TmpFs@@ -42,10 +47,10 @@  import GHC.Utils.Error import GHC.Utils.Outputable-import GHC.Utils.Panic import GHC.Utils.Logger-import GHC.Utils.Exception (bracket)+import GHC.Utils.Exception ( bracket ) import GHC.Utils.Ppr (Mode(..))+import GHC.Utils.Panic.Plain ( pgmError )  import GHC.Unit import GHC.Unit.Finder      ( mkStubPaths )@@ -53,7 +58,7 @@ import GHC.Types.SrcLoc import GHC.Types.CostCentre import GHC.Types.ForeignStubs-import GHC.Types.Unique.Supply ( mkSplitUniqSupply )+import GHC.Types.Unique.DSM  import System.Directory import System.FilePath@@ -73,6 +78,7 @@     :: forall a.        Logger     -> TmpFs+    -> LlvmConfigCache     -> DynFlags     -> UnitState     -> Module@@ -82,19 +88,21 @@     -> [(ForeignSrcLang, FilePath)]     -- ^ additional files to be compiled with the C compiler     -> Set UnitId -- ^ Dependencies-    -> Stream IO RawCmmGroup a                       -- Compiled C--+    -> 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 dflags unit_state this_mod filenm location genForeignStubs foreign_fps pkg_deps+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 do_lint cmm_stream+                    then Stream.mapM (liftIO . do_lint) cmm_stream                     else cmm_stream                do_lint cmm = withTimingSilent logger@@ -102,7 +110,7 @@                   (const ()) $ do                 { case cmmLint (targetPlatform dflags) cmm of                         Just err -> do { logMsg logger-                                                   MCDump+                                                   MCInfo -- See Note [MCInfo for Lint] in "GHC.Core.Lint"                                                    noSrcSpan                                                    $ withPprStyle defaultDumpStyle err                                        ; ghcExit logger 1@@ -111,26 +119,26 @@                 ; return cmm                 } -        ; let final_stream :: Stream IO RawCmmGroup (ForeignStubs, a)+        ; 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) } -        ; (stubs, a) <- case backend dflags of-                 NCG         -> outputAsm logger dflags this_mod location filenm-                                          final_stream-                 ViaC        -> outputC logger dflags filenm final_stream pkg_deps-                 LLVM        -> outputLlvm logger dflags filenm final_stream-                 Interpreter -> panic "codeOutput: Interpreter"-                 NoBackend   -> panic "codeOutput: NoBackend"+        ; let 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 -> Stream IO RawCmmGroup ()+emitInitializerDecls :: Module -> ForeignStubs -> CgStream RawCmmGroup () emitInitializerDecls this_mod (ForeignStubs _ cstub)   | initializers <- getInitializers cstub   , not $ null initializers =@@ -158,15 +166,18 @@ outputC :: Logger         -> DynFlags         -> FilePath-        -> Stream IO RawCmmGroup a+        -> 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 cmm_stream unit_deps =+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 -> do-      hPutStr h ("/* GHC_PACKAGES " ++ unwords pkg_names ++ "\n*/\n")-      hPutStr h "#include \"Stg.h\"\n"+    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@@ -174,9 +185,9 @@                           "C backend output"                           FormatC                           doc-            let ctx = initSDocContext dflags (PprCode CStyle)+            let ctx = initSDocContext dflags PprCode             printSDocLn ctx LeftMode h doc-      Stream.consume cmm_stream id writeC+      Stream.consume cmm_stream id (liftIO . writeC)  {- ************************************************************************@@ -191,15 +202,19 @@           -> Module           -> ModLocation           -> FilePath-          -> Stream IO RawCmmGroup a+          -> 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 cmm_stream = do-  ncg_uniqs <- mkSplitUniqSupply 'n'+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" #-}-      nativeCodeGen logger ncg_config location h ncg_uniqs cmm_stream+      fmap fst $+      runUDSMT dus $ setTagUDSMT 'n' $+      nativeCodeGen logger (toolSettings dflags) ncg_config location h cmm_stream  {- ************************************************************************@@ -209,16 +224,31 @@ ************************************************************************ -} -outputLlvm :: Logger -> DynFlags -> FilePath -> Stream IO RawCmmGroup a -> IO a-outputLlvm logger dflags filenm cmm_stream = do-  lcg_config <- initLlvmCgConfig logger dflags+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 cmm_stream+      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} *                                                                      * ************************************************************************@@ -245,7 +275,6 @@            Maybe FilePath) -- C file created outputForeignStubs logger tmpfs dflags unit_state mod location stubs  = do-   let stub_h = mkStubPaths (initFinderOpts dflags) (moduleName mod) location    stub_c <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "c"     case stubs of@@ -254,15 +283,13 @@       ForeignStubs (CHeader h_code) (CStub c_code _ _) -> do         let-            stub_c_output_d = pprCode CStyle c_code+            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 CStyle h_code+            stub_h_output_d = pprCode h_code             stub_h_output_w = showSDoc dflags stub_h_output_d -        createDirectoryIfMissing True (takeDirectory stub_h)-         putDumpFileMaybe logger Opt_D_dump_foreign                       "Foreign export header file"                       FormatC@@ -281,12 +308,26 @@              -- wrapper code mentions the ffi_arg type, which comes from ffi.h             ffi_includes-              | platformMisc_libFFI $ platformMisc dflags = "#include <ffi.h>\n"+              | platformMisc_libFFI $ platformMisc dflags = "#include \"rts/ghc_ffi.h\"\n"               | otherwise = "" -        stub_h_file_exists-           <- outputForeignStubs_help stub_h stub_h_output_w-                ("#include <HsFFI.h>\n" ++ cplusplus_hdr) cplusplus_ftr+        -- The header path is computed from the module source path, which+        -- does not exist when loading interface core bindings for Template+        -- Haskell for non-home modules (e.g. when compiling in separate+        -- invocations of oneshot mode).+        -- Stub headers are only generated for foreign exports.+        -- Since those aren't supported for TH with bytecode at the moment,+        -- it doesn't make much of a difference.+        -- In any case, if a stub dir was specified explicitly by the user, it+        -- would be used nonetheless.+        stub_h_file_exists <-+          case mkStubPaths (initFinderOpts dflags) (moduleName mod) location of+            Nothing -> pure False+            Just path -> do+              let stub_h = unsafeDecodeUtf path+              createDirectoryIfMissing True (takeDirectory stub_h)+              outputForeignStubs_help stub_h stub_h_output_w+                    ("#include <HsFFI.h>\n" ++ cplusplus_hdr) cplusplus_ftr          putDumpFileMaybe logger Opt_D_dump_foreign                       "Foreign export stubs" FormatC stub_c_output_d@@ -311,8 +352,7 @@    cplusplus_ftr = "#if defined(__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+-- 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@@ -332,7 +372,8 @@  = {-# SCC profilingInitCode #-}    initializerCStub platform fn_name decls body  where-   fn_name = mkInitializerStubLabel this_mod "prof_init"+   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@@ -344,22 +385,22 @@         ]    emit_cc_decl cc =        text "extern CostCentre" <+> cc_lbl <> text "[];"-     where cc_lbl = pdoc platform (mkCCLabel cc)+     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 $ [ pdoc platform (mkCCLabel cc) <> comma+      <+> braces (vcat $ [ pdocC (mkCCLabel cc) <> comma                          | cc <- ccs                          ] ++ [text "NULL"])       <> semi     emit_ccs_decl ccs =        text "extern CostCentreStack" <+> ccs_lbl <> text "[];"-     where ccs_lbl = pdoc platform (mkCCSLabel ccs)+     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 $ [ pdoc platform (mkCCSLabel cc) <> comma+      <+> braces (vcat $ [ pdocC (mkCCSLabel cc) <> comma                          | cc <- ccs                          ] ++ [text "NULL"])       <> semi@@ -370,26 +411,16 @@   :: Bool            -- is Opt_InfoTableMap enabled or not   -> Platform   -> Module-  -> [InfoProvEnt]   -> CStub-ipInitCode do_info_table platform this_mod ents+ipInitCode do_info_table platform this_mod   | not do_info_table = mempty-  | otherwise = initializerCStub platform fn_nm decls body+  | otherwise = initializerCStub platform fn_nm ipe_buffer_decl body  where-   fn_nm = mkInitializerStubLabel this_mod "ip_init"-   decls = vcat-        $  map emit_ipe_decl ents-        ++ [emit_ipe_list ents]-   body = text "registerInfoProvList" <> parens local_ipe_list_label <> semi-   emit_ipe_decl ipe =-       text "extern InfoProvEnt" <+> ipe_lbl <> text "[];"-     where ipe_lbl = pprCLabel platform CStyle (mkIPELabel ipe)-   local_ipe_list_label = text "local_ipe_" <> ppr this_mod-   emit_ipe_list ipes =-      text "static InfoProvEnt *" <> local_ipe_list_label <> text "[] ="-      <+> braces (vcat $ [ pprCLabel platform CStyle (mkIPELabel ipe) <> comma-                         | ipe <- ipes-                         ] ++ [text "NULL"])-      <> semi+   fn_nm = mkInitializerStubLabel this_mod (fsLit "ip_init") +   body = text "registerInfoProvList" <> parens (text "&" <> ipe_buffer_label) <> semi +   ipe_buffer_label = pprCLabel platform (mkIPELabel this_mod)++   ipe_buffer_decl =+       text "extern IpeBufferListNode" <+> ipe_buffer_label <> text ";"
GHC/Driver/Config.hs view
@@ -2,22 +2,18 @@ module GHC.Driver.Config    ( initOptCoercionOpts    , initSimpleOpts-   , initBCOOpts    , initEvalOpts+   , EvalStep(..)    ) where  import GHC.Prelude -import GHC.Driver.Session+import GHC.Driver.DynFlags import GHC.Core.SimpleOpt import GHC.Core.Coercion.Opt-import GHC.Runtime.Interpreter (BCOOpts(..)) import GHCi.Message (EvalOpts(..)) -import GHC.Conc (getNumProcessors)-import Control.Monad.IO.Class- -- | Initialise coercion optimiser configuration from DynFlags initOptCoercionOpts :: DynFlags -> OptCoercionOpts initOptCoercionOpts dflags = OptCoercionOpts@@ -29,25 +25,33 @@ initSimpleOpts dflags = SimpleOpts    { so_uf_opts = unfoldingOpts dflags    , so_co_opts = initOptCoercionOpts dflags+   , so_eta_red = gopt Opt_DoEtaReduction dflags+   , so_inline  = True    } --- | Extract BCO options from DynFlags-initBCOOpts :: DynFlags -> IO BCOOpts-initBCOOpts dflags = do-  -- Serializing ResolvedBCO is expensive, so if we're in parallel mode-  -- (-j<n>) parallelise the serialization.-  n_jobs <- case parMakeCount dflags of-              Nothing -> liftIO getNumProcessors-              Just n  -> return n-  return $ BCOOpts n_jobs+-- | 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 -> Bool -> EvalOpts+initEvalOpts :: DynFlags -> EvalStep -> EvalOpts initEvalOpts dflags step =   EvalOpts     { useSandboxThread = gopt Opt_GhciSandbox dflags-    , singleStep       = step+    , singleStep       = singleStep+    , stepOut          = stepOut     , breakOnException = gopt Opt_BreakOnException dflags     , breakOnError     = gopt Opt_BreakOnError dflags     }+  where+    (singleStep, stepOut) = case step of+      EvalStepSingle -> (True,  False)+      EvalStepOut    -> (False, True)+      EvalStepNone   -> (False, False)
GHC/Driver/Config/Cmm.hs view
@@ -3,9 +3,8 @@   ) where  import GHC.Cmm.Config-import GHC.Cmm.Switch (backendSupportsSwitch) -import GHC.Driver.Session+import GHC.Driver.DynFlags import GHC.Driver.Backend  import GHC.Platform@@ -19,15 +18,11 @@   , 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 . backendSupportsSwitch . backend $ dflags-  , cmmSplitProcPoints     = (backend dflags /= NCG)+  , cmmDoCmmSwitchPlans    = not (backendHasNativeSwitch (backend dflags))+  , cmmSplitProcPoints     = not (backendSupportsUnsplitProcPoints (backend dflags))                              || not (platformTablesNextToCode platform)-                             || usingInconsistentPicReg   }   where platform                = targetPlatform dflags-        usingInconsistentPicReg =-          case (platformArch platform, platformOS platform, positionIndependent dflags)-          of   (ArchX86, OSDarwin, pic) -> pic-               _                        -> False
+ GHC/Driver/Config/Cmm/Parser.hs view
@@ -0,0 +1,25 @@+module GHC.Driver.Config.Cmm.Parser+  ( initCmmParserConfig+  ) where++import GHC.Cmm.Parser.Config++import GHC.Driver.Config.Parser+import GHC.Driver.Config.StgToCmm+import GHC.Driver.DynFlags++import GHC.Utils.Panic++initPDConfig :: DynFlags -> PDConfig+initPDConfig dflags = PDConfig+  { pdProfile = targetProfile dflags+  , pdSanitizeAlignment = gopt Opt_AlignmentSanitisation dflags+  }++initCmmParserConfig :: DynFlags -> CmmParserConfig+initCmmParserConfig dflags = CmmParserConfig+  { cmmpParserOpts = initParserOpts dflags+  , cmmpPDConfig = initPDConfig dflags+  , cmmpStgToCmmConfig = initStgToCmmConfig dflags (panic "initCmmParserConfig: no module")+  }+
GHC/Driver/Config/CmmToAsm.hs view
@@ -5,7 +5,7 @@  import GHC.Prelude -import GHC.Driver.Session+import GHC.Driver.DynFlags  import GHC.Platform import GHC.Unit.Types (Module)@@ -18,7 +18,7 @@ initNCGConfig dflags this_mod = NCGConfig    { ncgPlatform              = targetPlatform dflags    , ncgThisModule            = this_mod-   , ncgAsmContext            = initSDocContext dflags (PprCode AsmStyle)+   , ncgAsmContext            = initSDocContext dflags PprCode    , ncgProcAlignment         = cmmProcAlignment dflags    , ncgExternalDynamicRefs   = gopt Opt_ExternalDynamicRefs dflags    , ncgPIC                   = positionIndependent dflags@@ -59,6 +59,9 @@             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@@ -67,6 +70,7 @@    , 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)
GHC/Driver/Config/CmmToLlvm.hs view
@@ -1,24 +1,29 @@ module GHC.Driver.Config.CmmToLlvm   ( initLlvmCgConfig-  ) where+  )+where  import GHC.Prelude-import GHC.Driver.Session+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 -> DynFlags -> IO LlvmCgConfig-initLlvmCgConfig logger dflags = do+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 CStyle)+    , 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@@ -26,5 +31,5 @@     , llvmCgLlvmVersion          = version     , llvmCgDoWarn               = wopt Opt_WarnUnsupportedLlvmVersion dflags     , llvmCgLlvmTarget           = platformMisc_llvmTarget $! platformMisc dflags-    , llvmCgLlvmConfig           = llvmConfig dflags+    , llvmCgLlvmConfig           = llvm_config     }
+ GHC/Driver/Config/Core/Lint.hs view
@@ -0,0 +1,181 @@+module GHC.Driver.Config.Core.Lint+  ( endPass+  , endPassHscEnvIO+  , lintCoreBindings+  , initEndPassConfig+  , initLintPassResultConfig+  , initLintConfig+  ) where++import GHC.Prelude++import qualified GHC.LanguageExtensions as LangExt++import GHC.Driver.Env+import GHC.Driver.DynFlags+import GHC.Driver.Config.Diagnostic++import GHC.Core+import GHC.Core.Lint+import GHC.Core.Lint.Interactive+import GHC.Core.Opt.Pipeline.Types+import GHC.Core.Opt.Simplify ( SimplifyOpts(..) )+import GHC.Core.Opt.Simplify.Env ( SimplMode(..) )+import GHC.Core.Opt.Monad+import GHC.Core.Coercion++import GHC.Types.Basic ( CompilerPhase(..) )++import GHC.Utils.Outputable as Outputable++{-+These functions are not CoreM monad stuff, but they probably ought to+be, and it makes a convenient place for them.  They print out stuff+before and after core passes, and do Core Lint when necessary.+-}++endPass :: CoreToDo -> CoreProgram -> [CoreRule] -> CoreM ()+endPass pass binds rules+  = do { hsc_env <- getHscEnv+       ; name_ppr_ctx <- getNamePprCtx+       ; liftIO $ endPassHscEnvIO hsc_env+           name_ppr_ctx pass binds rules+       }++endPassHscEnvIO :: HscEnv -> NamePprCtx+          -> CoreToDo -> CoreProgram -> [CoreRule] -> IO ()+endPassHscEnvIO hsc_env name_ppr_ctx pass binds rules+  = do { let dflags  = hsc_dflags hsc_env+       ; endPassIO+           (hsc_logger hsc_env)+           (initEndPassConfig dflags (interactiveInScope $ hsc_IC hsc_env) name_ppr_ctx pass)+           binds rules+       }++-- | Type-check a 'CoreProgram'. See Note [Core Lint guarantee].+lintCoreBindings :: DynFlags -> CoreToDo -> [Var] -> CoreProgram -> WarnsAndErrs+lintCoreBindings dflags coreToDo vars -- binds+  = lintCoreBindings' $ LintConfig+      { l_diagOpts = initDiagOpts dflags+      , l_platform = targetPlatform dflags+      , l_flags    = perPassFlags dflags coreToDo+      , l_vars     = vars+      }++initEndPassConfig :: DynFlags -> [Var] -> NamePprCtx -> CoreToDo -> EndPassConfig+initEndPassConfig dflags extra_vars name_ppr_ctx pass = EndPassConfig+  { ep_dumpCoreSizes = not (gopt Opt_SuppressCoreSizes dflags)+  , ep_lintPassResult = if gopt Opt_DoCoreLinting dflags+      then Just $ initLintPassResultConfig dflags extra_vars pass+      else Nothing+  , ep_namePprCtx = name_ppr_ctx+  , ep_dumpFlag = coreDumpFlag pass+  , ep_prettyPass = ppr pass+  , ep_passDetails = pprPassDetails pass+  }++coreDumpFlag :: CoreToDo -> Maybe DumpFlag+coreDumpFlag (CoreDoSimplify {})      = Just Opt_D_verbose_core2core+coreDumpFlag (CoreDoPluginPass {})    = Just Opt_D_verbose_core2core+coreDumpFlag CoreDoFloatInwards       = Just Opt_D_dump_float_in+coreDumpFlag (CoreDoFloatOutwards {}) = Just Opt_D_dump_float_out+coreDumpFlag CoreLiberateCase         = Just Opt_D_dump_liberate_case+coreDumpFlag CoreDoStaticArgs         = Just Opt_D_dump_static_argument_transformation+coreDumpFlag CoreDoCallArity          = Just Opt_D_dump_call_arity+coreDumpFlag CoreDoExitify            = Just Opt_D_dump_exitify+coreDumpFlag (CoreDoDemand {})        = Just Opt_D_dump_dmdanal+coreDumpFlag CoreDoCpr                = Just Opt_D_dump_cpranal+coreDumpFlag CoreDoWorkerWrapper      = Just Opt_D_dump_worker_wrapper+coreDumpFlag CoreDoSpecialising       = Just Opt_D_dump_spec+coreDumpFlag CoreDoSpecConstr         = Just Opt_D_dump_spec_constr+coreDumpFlag CoreCSE                  = Just Opt_D_dump_cse+coreDumpFlag CoreDesugar              = Just Opt_D_dump_ds_preopt+coreDumpFlag CoreDesugarOpt           = Just Opt_D_dump_ds+coreDumpFlag CoreTidy                 = Just Opt_D_dump_simpl+coreDumpFlag CorePrep                 = Just Opt_D_dump_prep++coreDumpFlag CoreAddCallerCcs         = Nothing+coreDumpFlag CoreAddLateCcs           = Nothing+coreDumpFlag CoreDoPrintCore          = Nothing+coreDumpFlag (CoreDoRuleCheck {})     = Nothing+coreDumpFlag CoreDoNothing            = Nothing+coreDumpFlag (CoreDoPasses {})        = Nothing++initLintPassResultConfig :: DynFlags -> [Var] -> CoreToDo -> LintPassResultConfig+initLintPassResultConfig dflags extra_vars pass = LintPassResultConfig+  { lpr_diagOpts      = initDiagOpts dflags+  , lpr_platform      = targetPlatform dflags+  , lpr_makeLintFlags = perPassFlags dflags pass+  , lpr_showLintWarnings = showLintWarnings pass+  , lpr_passPpr = ppr pass+  , lpr_localsInScope = extra_vars+  }++showLintWarnings :: CoreToDo -> Bool+-- Disable Lint warnings on the first simplifier pass, because+-- there may be some INLINE knots still tied, which is tiresomely noisy+showLintWarnings (CoreDoSimplify cfg) = case sm_phase (so_mode cfg) of+  InitialPhase -> False+  _ -> True+showLintWarnings _ = True++perPassFlags :: DynFlags -> CoreToDo -> LintFlags+perPassFlags dflags pass+  = (defaultLintFlags dflags)+               { lf_check_global_ids = check_globals+               , lf_check_inline_loop_breakers = check_lbs+               , lf_check_static_ptrs = check_static_ptrs+               , lf_check_linearity = check_linearity+               , lf_check_fixed_rep = check_fixed_rep }+  where+    -- In the output of the desugarer, before optimisation,+    -- we have eta-expanded data constructors with representation-polymorphic+    -- bindings; so we switch off the representation-polymorphism checks.+    -- The very simple optimiser will beta-reduce them away.+    -- See Note [Representation-polymorphism checking built-ins] in GHC.Tc.Utils.Concrete+    check_fixed_rep = case pass of+                        CoreDesugar -> False+                        _           -> True++    -- See Note [Checking for global Ids]+    check_globals = case pass of+                      CoreTidy -> False+                      CorePrep -> False+                      _        -> True++    -- See Note [Checking for INLINE loop breakers]+    check_lbs = case pass of+                      CoreDesugar    -> False+                      CoreDesugarOpt -> False+                      _              -> True++    -- See Note [Checking StaticPtrs]+    check_static_ptrs | not (xopt LangExt.StaticPointers dflags) = AllowAnywhere+                      | otherwise = case pass of+                          CoreDoFloatOutwards _ -> AllowAtTopLevel+                          CoreTidy              -> RejectEverywhere+                          CorePrep              -> AllowAtTopLevel+                          _                     -> AllowAnywhere++    -- See Note [Linting linearity]+    check_linearity = gopt Opt_DoLinearCoreLinting dflags || (+                        case pass of+                          CoreDesugar -> True+                          _ -> False)++initLintConfig :: DynFlags -> [Var] -> LintConfig+initLintConfig dflags vars =LintConfig+  { l_diagOpts = initDiagOpts dflags+  , l_platform = targetPlatform dflags+  , l_flags    = defaultLintFlags dflags+  , l_vars     = vars+  }++defaultLintFlags :: DynFlags -> LintFlags+defaultLintFlags dflags = LF { lf_check_global_ids = False+                             , lf_check_inline_loop_breakers = True+                             , lf_check_static_ptrs = AllowAnywhere+                             , lf_check_linearity = gopt Opt_DoLinearCoreLinting dflags+                             , lf_report_unsat_syns = True+                             , lf_check_fixed_rep = True+                             }
+ GHC/Driver/Config/Core/Lint/Interactive.hs view
@@ -0,0 +1,35 @@+module GHC.Driver.Config.Core.Lint.Interactive+  ( lintInteractiveExpr+  ) where++import GHC.Prelude++import GHC.Driver.Env+import GHC.Driver.DynFlags+import GHC.Driver.Config.Core.Lint++import GHC.Core+import GHC.Core.Ppr++import GHC.Core.Lint+import GHC.Core.Lint.Interactive++--import GHC.Runtime.Context++import GHC.Data.Bag++import GHC.Utils.Outputable as Outputable++lintInteractiveExpr :: SDoc -- ^ The source of the linted expression+                    -> HscEnv+                    -> CoreExpr -> IO ()+lintInteractiveExpr what hsc_env expr+  | not (gopt Opt_DoCoreLinting dflags)+  = return ()+  | Just err <- lintExpr (initLintConfig dflags $ interactiveInScope $ hsc_IC hsc_env) expr+  = displayLintResults logger False what (pprCoreExpr expr) (emptyBag, err)+  | otherwise+  = return ()+  where+    dflags = hsc_dflags hsc_env+    logger = hsc_logger hsc_env
+ GHC/Driver/Config/Core/Opt/Arity.hs view
@@ -0,0 +1,15 @@+module GHC.Driver.Config.Core.Opt.Arity+  ( initArityOpts+  ) where++import GHC.Prelude ()++import GHC.Driver.DynFlags++import GHC.Core.Opt.Arity++initArityOpts :: DynFlags -> ArityOpts+initArityOpts dflags = ArityOpts+  { ao_ped_bot = gopt Opt_PedanticBottoms dflags+  , ao_dicts_cheap = gopt Opt_DictsCheap dflags+  }
+ GHC/Driver/Config/Core/Opt/LiberateCase.hs view
@@ -0,0 +1,15 @@+module GHC.Driver.Config.Core.Opt.LiberateCase+  ( initLiberateCaseOpts+  ) where++import GHC.Driver.DynFlags++import GHC.Core.Opt.LiberateCase ( LibCaseOpts(..) )++-- | Initialize configuration for the liberate case Core optimization+-- pass.+initLiberateCaseOpts :: DynFlags -> LibCaseOpts+initLiberateCaseOpts dflags = LibCaseOpts+  { lco_threshold = liberateCaseThreshold dflags+  , lco_unfolding_opts = unfoldingOpts dflags+  }
+ GHC/Driver/Config/Core/Opt/Simplify.hs view
@@ -0,0 +1,126 @@+module GHC.Driver.Config.Core.Opt.Simplify+  ( initSimplifyExprOpts+  , initSimplifyOpts+  , initSimplMode+  , initGentleSimplMode+  ) where++import GHC.Prelude++import GHC.Core.Rules ( RuleBase )+import GHC.Core.Opt.Pipeline.Types ( CoreToDo(..) )+import GHC.Core.Opt.Simplify ( SimplifyExprOpts(..), SimplifyOpts(..) )+import GHC.Core.Opt.Simplify.Env ( FloatEnable(..), SimplMode(..) )+import GHC.Core.Opt.Simplify.Monad ( TopEnvConfig(..) )++import GHC.Driver.Config ( initOptCoercionOpts )+import GHC.Driver.Config.Core.Lint ( initLintPassResultConfig )+import GHC.Driver.Config.Core.Rules ( initRuleOpts )+import GHC.Driver.Config.Core.Opt.Arity ( initArityOpts )+import GHC.Driver.DynFlags ( DynFlags(..), GeneralFlag(..), gopt )++import GHC.Runtime.Context ( InteractiveContext(..) )++import GHC.Types.Basic ( CompilerPhase(..) )+import GHC.Types.Var ( Var )++initSimplifyExprOpts :: DynFlags -> InteractiveContext -> SimplifyExprOpts+initSimplifyExprOpts dflags ic = SimplifyExprOpts+  { se_fam_inst = snd $ ic_instances ic+  , se_mode = (initSimplMode dflags InitialPhase "GHCi")+    { sm_inline = False+      -- Do not do any inlining, in case we expose some+      -- unboxed tuple stuff that confuses the bytecode+      -- interpreter+    }+  , se_top_env_cfg = TopEnvConfig+    { te_history_size = historySize dflags+    , te_tick_factor = simplTickFactor dflags+    }+  }++initSimplifyOpts :: DynFlags -> [Var] -> Int -> SimplMode -> RuleBase -> SimplifyOpts+initSimplifyOpts dflags extra_vars iterations mode hpt_rule_base = let+  -- This is a particularly ugly construction, but we will get rid of it in !8341.+  opts = SimplifyOpts+    { so_dump_core_sizes = not $ gopt Opt_SuppressCoreSizes dflags+    , so_iterations      = iterations+    , so_mode            = mode+    , so_pass_result_cfg = if gopt Opt_DoCoreLinting dflags+                           then Just $ initLintPassResultConfig dflags extra_vars+                                                            (CoreDoSimplify opts)+                           else Nothing+    , so_hpt_rules       = hpt_rule_base+    , so_top_env_cfg     = TopEnvConfig { te_history_size = historySize dflags+                                        , te_tick_factor = simplTickFactor dflags }+    }+  in opts++initSimplMode :: DynFlags -> CompilerPhase -> String -> SimplMode+initSimplMode dflags phase name = SimplMode+  { sm_names = [name]+  , sm_phase = phase+  , sm_rules = gopt Opt_EnableRewriteRules dflags+  , sm_eta_expand = gopt Opt_DoLambdaEtaExpansion dflags+  , sm_cast_swizzle = True+  , sm_inline = True+  , sm_uf_opts = unfoldingOpts dflags+  , sm_case_case = True+  , sm_pre_inline = gopt Opt_SimplPreInlining dflags+  , sm_float_enable = floatEnable dflags+  , sm_do_eta_reduction = gopt Opt_DoEtaReduction dflags+  , sm_arity_opts = initArityOpts dflags+  , sm_rule_opts = initRuleOpts dflags+  , sm_case_folding = gopt Opt_CaseFolding dflags+  , sm_case_merge = gopt Opt_CaseMerge dflags+  , sm_co_opt_opts = initOptCoercionOpts dflags+  }++initGentleSimplMode :: DynFlags -> SimplMode+initGentleSimplMode dflags = (initSimplMode dflags InitialPhase "Gentle")+  { -- Don't do case-of-case transformations.+    -- This makes full laziness work better+    -- See Note [Case-of-case and full laziness]+    sm_case_case = False+  }++floatEnable :: DynFlags -> FloatEnable+floatEnable dflags =+  case (gopt Opt_LocalFloatOut dflags, gopt Opt_LocalFloatOutTopLevel dflags) of+    (True, True) -> FloatEnabled+    (True, False)-> FloatNestedOnly+    (False, _)   -> FloatDisabled+++{- Note [Case-of-case and full laziness]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Case-of-case can hide opportunities for let-floating (full laziness).+For example+   rec { f = \y. case (expensive x) of (a,b) -> blah }+We might hope to float the (expensive x) out of the \y-loop.+But if we inline `expensive` we might get+   \y. case (case x of I# x' -> body) of (a,b) -> blah+Now if we do case-of-case we get+   \y. case x if I# x2 ->+       case body of (a,b) -> blah++Sadly, at this point `body` mentions `x2`, so we can't float it out of the+\y-loop.++Solution: don't do case-of-case in the "gentle" simplification phase that+precedes the first float-out transformation.  Implementation:++  * `sm_case_case` field in SimplMode++  * Consult `sm_case_case` (via `seCaseCase`) before doing case-of-case+    in GHC.Core.Opt.Simplify.Iteration.rebuildCall.++Wrinkles++* This applies equally to the case-of-runRW# transformation:+    case (runRW# (\s. body)) of (a,b) -> blah+    --->+    runRW# (\s. case body of (a,b) -> blah)+  Again, don't do this when `sm_case_case` is off.  See #25055 for+  a motivating example.+-}
+ GHC/Driver/Config/Core/Opt/WorkWrap.hs view
@@ -0,0 +1,21 @@+module GHC.Driver.Config.Core.Opt.WorkWrap+  ( initWorkWrapOpts+  ) where++import GHC.Prelude ()++import GHC.Driver.Config (initSimpleOpts)+import GHC.Driver.DynFlags++import GHC.Core.FamInstEnv+import GHC.Core.Opt.WorkWrap+import GHC.Unit.Types++initWorkWrapOpts :: Module -> DynFlags -> FamInstEnvs -> WwOpts+initWorkWrapOpts this_mod dflags fam_envs = MkWwOpts+  { wo_fam_envs          = fam_envs+  , wo_simple_opts       = initSimpleOpts dflags+  , wo_cpr_anal          = gopt Opt_CprAnal dflags+  , wo_module            = this_mod+  , wo_unlift_strict     = gopt Opt_WorkerWrapperUnlift dflags+  }
+ GHC/Driver/Config/Core/Rules.hs view
@@ -0,0 +1,19 @@+module GHC.Driver.Config.Core.Rules+  ( initRuleOpts+  ) where++import GHC.Prelude++import GHC.Driver.Flags+import GHC.Driver.DynFlags ( DynFlags, gopt, targetPlatform )++import GHC.Core.Rules.Config++-- | Initialize RuleOpts from DynFlags+initRuleOpts :: DynFlags -> RuleOpts+initRuleOpts dflags = RuleOpts+  { roPlatform                = targetPlatform dflags+  , roNumConstantFolding      = gopt Opt_NumConstantFolding dflags+  , roExcessRationalPrecision = gopt Opt_ExcessPrecision dflags+  , roBignumRules             = True+  }
+ GHC/Driver/Config/CoreToStg.hs view
@@ -0,0 +1,16 @@+module GHC.Driver.Config.CoreToStg where++import GHC.Driver.Config.Stg.Debug+import GHC.Driver.DynFlags++import GHC.CoreToStg++initCoreToStgOpts :: DynFlags -> CoreToStgOpts+initCoreToStgOpts dflags = CoreToStgOpts+  { coreToStg_platform = targetPlatform dflags+  , coreToStg_ways = ways dflags+  , coreToStg_AutoSccsOnIndividualCafs = gopt Opt_AutoSccsOnIndividualCafs dflags+  , coreToStg_InfoTableMap = gopt Opt_InfoTableMap dflags+  , coreToStg_ExternalDynamicRefs = gopt Opt_ExternalDynamicRefs dflags+  , coreToStg_stgDebugOpts = initStgDebugOpts dflags+  }
+ GHC/Driver/Config/CoreToStg/Prep.hs view
@@ -0,0 +1,35 @@+module GHC.Driver.Config.CoreToStg.Prep+  ( initCorePrepConfig+  , initCorePrepPgmConfig+  ) where++import GHC.Prelude++import GHC.Core.Opt.Pipeline.Types ( CoreToDo(..) )+import GHC.Driver.Env+import GHC.Driver.Session+import GHC.Driver.Config.Core.Lint+import GHC.Driver.Config.Core.Opt.Arity+import GHC.Types.Var+import GHC.Utils.Outputable ( alwaysQualify )++import GHC.CoreToStg.Prep++initCorePrepConfig :: HscEnv -> IO CorePrepConfig+initCorePrepConfig hsc_env = do+   let dflags = hsc_dflags hsc_env+   return $ CorePrepConfig+      { cp_catchNonexhaustiveCases = gopt Opt_CatchNonexhaustiveCases dflags+      , cp_platform  = targetPlatform dflags+      , cp_arityOpts = if gopt Opt_DoCleverArgEtaExpansion dflags+                       then Just (initArityOpts dflags)+                       else Nothing+      , cp_specEval  = gopt Opt_SpecEval dflags+      , cp_specEvalDFun = gopt Opt_SpecEvalDictFun dflags+      }++initCorePrepPgmConfig :: DynFlags -> [Var] -> CorePrepPgmConfig+initCorePrepPgmConfig dflags extra_vars = CorePrepPgmConfig+  { cpPgm_endPassConfig     = initEndPassConfig dflags extra_vars alwaysQualify CorePrep+  , cpPgm_generateDebugInfo = needSourceNotes dflags+  }
GHC/Driver/Config/Diagnostic.hs view
@@ -1,21 +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.Session+import GHC.Driver.DynFlags+import GHC.Prelude  import GHC.Utils.Outputable import GHC.Utils.Error (DiagOpts (..))+import GHC.Driver.Errors.Types (GhcMessage, GhcMessageOpts (..), PsMessage, DriverMessage, DriverMessageOpts (..), checkBuildingCabalPackage)+import GHC.Driver.Errors.Ppr () -- Diagnostic instances+import GHC.Tc.Errors.Types+import GHC.HsToCore.Errors.Types+import GHC.Types.Error+import GHC.Iface.Errors.Types +-- | Initialise the general configuration for printing diagnostic messages+-- For example, this configuration controls things like whether warnings are+-- treated like errors. initDiagOpts :: DynFlags -> DiagOpts initDiagOpts dflags = DiagOpts   { diag_warning_flags       = warningFlags dflags   , diag_fatal_warning_flags = fatalWarningFlags dflags+  , diag_custom_warning_categories = customWarningCategories dflags+  , diag_fatal_custom_warning_categories = fatalCustomWarningCategories dflags   , diag_warn_is_error       = gopt Opt_WarnIsError dflags   , diag_reverse_errors      = reverseErrors dflags   , diag_max_errors          = maxErrors dflags   , diag_ppr_ctx             = initSDocContext dflags defaultErrStyle   }++-- | Initialise the configuration for printing specific diagnostic messages+initPrintConfig :: DynFlags -> DiagnosticOpts GhcMessage+initPrintConfig dflags =+  GhcMessageOpts { psMessageOpts = initPsMessageOpts dflags+                 , tcMessageOpts = initTcMessageOpts dflags+                 , dsMessageOpts = initDsMessageOpts dflags+                 , driverMessageOpts= initDriverMessageOpts dflags }++initPsMessageOpts :: DynFlags -> DiagnosticOpts PsMessage+initPsMessageOpts _ = NoDiagnosticOpts++initTcMessageOpts :: DynFlags -> DiagnosticOpts TcRnMessage+initTcMessageOpts dflags =+  TcRnMessageOpts { tcOptsShowContext    = gopt Opt_ShowErrorContext dflags+                  , tcOptsIfaceOpts      = initIfaceMessageOpts dflags }++initDsMessageOpts :: DynFlags -> DiagnosticOpts DsMessage+initDsMessageOpts _ = NoDiagnosticOpts++initIfaceMessageOpts :: DynFlags -> DiagnosticOpts IfaceMessage+initIfaceMessageOpts dflags =+                  IfaceMessageOpts { ifaceShowTriedFiles = verbosity dflags >= 3+                                   , ifaceBuildingCabalPackage = checkBuildingCabalPackage dflags }++initDriverMessageOpts :: DynFlags -> DiagnosticOpts DriverMessage+initDriverMessageOpts dflags = DriverMessageOpts (initPsMessageOpts dflags) (initIfaceMessageOpts dflags)
GHC/Driver/Config/Finder.hs view
@@ -5,30 +5,31 @@  import GHC.Prelude -import GHC.Driver.Session+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 = importPaths flags+  { 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 = workingDirectory flags+  , finder_workingDirectory = fmap unsafeEncodeUtf $ workingDirectory flags   , finder_thisPackageName  = mkFastString <$> thisPackageName flags   , finder_hiddenModules = hiddenModules flags-  , finder_reexportedModules = reexportedModules flags-  , finder_hieDir = hieDir flags-  , finder_hieSuf = hieSuf flags-  , finder_hiDir = hiDir flags-  , finder_hiSuf = hiSuf_ flags-  , finder_dynHiSuf = dynHiSuf_ flags-  , finder_objectDir = objectDir flags-  , finder_objectSuf = objectSuf_ flags-  , finder_dynObjectSuf = dynObjectSuf_ flags-  , finder_stubDir = stubDir flags+  , finder_reexportedModules = Map.fromList [(known_as, is_as) | ReexportedModule is_as known_as <- reverse (reexportedModules flags)]+  , finder_hieDir = fmap unsafeEncodeUtf $ hieDir flags+  , finder_hieSuf = unsafeEncodeUtf $ hieSuf flags+  , finder_hiDir = fmap unsafeEncodeUtf $ hiDir flags+  , finder_hiSuf = unsafeEncodeUtf $ hiSuf_ flags+  , finder_dynHiSuf = unsafeEncodeUtf $ dynHiSuf_ flags+  , finder_objectDir = fmap unsafeEncodeUtf $ objectDir flags+  , finder_objectSuf = unsafeEncodeUtf $ objectSuf_ flags+  , finder_dynObjectSuf = unsafeEncodeUtf $ dynObjectSuf_ flags+  , finder_stubDir = fmap unsafeEncodeUtf $ stubDir flags   }
GHC/Driver/Config/HsToCore.hs view
@@ -4,7 +4,7 @@ where  import GHC.Types.Id.Make-import GHC.Driver.Session+import GHC.Driver.DynFlags import qualified GHC.LanguageExtensions as LangExt  initBangOpts :: DynFlags -> BangOpts@@ -12,7 +12,7 @@   { bang_opt_strict_data   = xopt LangExt.StrictData dflags   , bang_opt_unbox_disable = gopt Opt_OmitInterfacePragmas dflags       -- Don't unbox if we aren't optimising; rather arbitrarily,-      -- we use -fomit-iface-pragmas as the indication+      -- we use -fomit-interface-pragmas as the indication   , bang_opt_unbox_strict  = gopt Opt_UnboxStrictFields dflags   , bang_opt_unbox_small   = gopt Opt_UnboxSmallStrictFields dflags   }
+ GHC/Driver/Config/HsToCore/Ticks.hs view
@@ -0,0 +1,34 @@+module GHC.Driver.Config.HsToCore.Ticks+  ( initTicksConfig+  , breakpointsAllowed+  )+where++import GHC.Prelude++import Data.Maybe (catMaybes)++import GHC.Driver.Backend+import GHC.Driver.Session+import GHC.HsToCore.Ticks++initTicksConfig :: DynFlags -> TicksConfig+initTicksConfig dflags = TicksConfig+  { ticks_passes       = coveragePasses dflags+  , ticks_profAuto     = profAuto dflags+  , ticks_countEntries = gopt Opt_ProfCountEntries dflags+  }++breakpointsAllowed :: DynFlags -> Bool+breakpointsAllowed dflags =+  gopt Opt_InsertBreakpoints dflags &&+  backendSupportsBreakpoints (backend dflags)++coveragePasses :: DynFlags -> [TickishType]+coveragePasses dflags = catMaybes+  [ ifA Breakpoints $ breakpointsAllowed dflags+  , ifA HpcTicks $ gopt Opt_Hpc dflags+  , ifA ProfNotes $ sccProfilingEnabled dflags && profAuto dflags /= NoProfAuto+  , ifA SourceNotes $ needSourceNotes dflags+  ]+  where ifA x cond = if cond then Just x else Nothing
+ GHC/Driver/Config/HsToCore/Usage.hs view
@@ -0,0 +1,14 @@+module GHC.Driver.Config.HsToCore.Usage+  ( initUsageConfig+  )+where++import GHC.Driver.Env.Types+import GHC.Driver.Session++import GHC.HsToCore.Usage++initUsageConfig :: HscEnv -> UsageConfig+initUsageConfig hsc_env = UsageConfig+  { uc_safe_implicit_imps_req = safeImplicitImpsReq (hsc_dflags hsc_env)+  }
+ GHC/Driver/Config/Linker.hs view
@@ -0,0 +1,92 @@+module GHC.Driver.Config.Linker+  ( initFrameworkOpts+  , initLinkerConfig+  )+where++import GHC.Prelude+import GHC.Platform+import GHC.Linker.Config++import GHC.Driver.DynFlags+import GHC.Driver.Session++import Data.List (isPrefixOf)++initFrameworkOpts :: DynFlags -> FrameworkOpts+initFrameworkOpts dflags = FrameworkOpts+  { foFrameworkPaths    = frameworkPaths    dflags+  , foCmdlineFrameworks = cmdlineFrameworks dflags+  }++-- | Initialize linker configuration from DynFlags+initLinkerConfig :: DynFlags -> LinkerConfig+initLinkerConfig dflags =+  let+    -- see Note [Solaris linker]+    ld_filter = case platformOS (targetPlatform dflags) of+                  OSSolaris2 -> sunos_ld_filter+                  _          -> id+    sunos_ld_filter :: [String] -> [String]+    sunos_ld_filter x = if (undefined_found x && ld_warning_found x)+                          then (ld_prefix x) ++ (ld_postfix x)+                          else x+    breakStartsWith x y = break (isPrefixOf x) y+    ld_prefix = fst . breakStartsWith "Undefined"+    undefined_found = not . null . snd . breakStartsWith "Undefined"+    ld_warn_break = breakStartsWith "ld: warning: symbol referencing errors"+    ld_postfix = tail . snd . ld_warn_break+    ld_warning_found = not . null . snd . ld_warn_break++    -- program and arguments+    --+    -- `-optl` args come at the end, so that later `-l` options+    -- given there manually can fill in symbols needed by+    -- Haskell libraries coming in via `args`.+    (p,pre_args) = pgm_l dflags+    post_args    = map Option (getOpts dflags opt_l)++  in LinkerConfig+    { linkerProgram     = p+    , linkerOptionsPre  = pre_args+    , linkerOptionsPost = post_args+    , linkerTempDir     = tmpDir dflags+    , linkerFilter      = ld_filter+    }++{- Note [Solaris linker]+   ~~~~~~~~~~~~~~~~~~~~~+  SunOS/Solaris ld emits harmless warning messages about unresolved+  symbols in case of compiling into shared library when we do not+  link against all the required libs. That is the case of GHC which+  does not link against RTS library explicitly in order to be able to+  choose the library later based on binary application linking+  parameters. The warnings look like:++Undefined                       first referenced+  symbol                             in file+stg_ap_n_fast                       ./T2386_Lib.o+stg_upd_frame_info                  ./T2386_Lib.o+templatezmhaskell_LanguageziHaskellziTHziLib_litE_closure ./T2386_Lib.o+templatezmhaskell_LanguageziHaskellziTHziLib_appE_closure ./T2386_Lib.o+templatezmhaskell_LanguageziHaskellziTHziLib_conE_closure ./T2386_Lib.o+templatezmhaskell_LanguageziHaskellziTHziSyntax_mkNameGzud_closure ./T2386_Lib.o+newCAF                              ./T2386_Lib.o+stg_bh_upd_frame_info               ./T2386_Lib.o+stg_ap_ppp_fast                     ./T2386_Lib.o+templatezmhaskell_LanguageziHaskellziTHziLib_stringL_closure ./T2386_Lib.o+stg_ap_p_fast                       ./T2386_Lib.o+stg_ap_pp_fast                      ./T2386_Lib.o+ld: warning: symbol referencing errors++  this is actually coming from T2386 testcase. The emitting of those+  warnings is also a reason why so many TH testcases fail on Solaris.++  Following filter code is SunOS/Solaris linker specific and should+  filter out only linker warnings. Please note that the logic is a+  little bit more complex due to the simple reason that we need to preserve+  any other linker emitted messages. If there are any. Simply speaking+  if we see "Undefined" and later "ld: warning:..." then we omit all+  text between (including) the marks. Otherwise we copy the whole output.+-}+
GHC/Driver/Config/Logger.hs view
@@ -5,7 +5,7 @@  import GHC.Prelude -import GHC.Driver.Session+import GHC.Driver.DynFlags  import GHC.Utils.Logger (LogFlags (..)) import GHC.Utils.Outputable@@ -17,13 +17,16 @@   , log_default_dump_context = initSDocContext dflags defaultDumpStyle   , log_dump_flags           = dumpFlags dflags   , log_show_caret           = gopt Opt_DiagnosticsShowCaret dflags+  , log_diagnostics_as_json  = gopt Opt_DiagnosticsAsJSON dflags   , log_show_warn_groups     = gopt Opt_ShowWarnGroups dflags   , log_enable_timestamps    = not (gopt Opt_SuppressTimestamps dflags)   , log_dump_to_file         = gopt Opt_DumpToFile dflags   , log_dump_dir             = dumpDir dflags   , log_dump_prefix          = dumpPrefix dflags   , log_dump_prefix_override = dumpPrefixForce dflags+  , log_with_ways            = gopt Opt_DumpWithWays dflags   , log_enable_debug         = not (hasNoDebugOutput dflags)   , log_verbosity            = verbosity dflags+  , log_ways                 = Just $ ways dflags   }
GHC/Driver/Config/Parser.hs view
@@ -1,5 +1,6 @@ module GHC.Driver.Config.Parser   ( initParserOpts+  , supportedLanguagePragmas   ) where @@ -17,9 +18,10 @@   mkParserOpts     <$> extensionFlags     <*> initDiagOpts-    <*> (supportedLanguagesAndExtensions . platformArchOS . targetPlatform)     <*> safeImportsOn     <*> gopt Opt_Haddock     <*> gopt Opt_KeepRawTokenStream     <*> const True -- use LINE/COLUMN to update the internal location +supportedLanguagePragmas :: DynFlags -> [String]+supportedLanguagePragmas = supportedLanguagesAndExtensions . platformArchOS . targetPlatform
GHC/Driver/Config/Stg/Debug.hs view
@@ -4,7 +4,7 @@  import GHC.Stg.Debug -import GHC.Driver.Session+import GHC.Driver.DynFlags  -- | Initialize STG pretty-printing options from DynFlags initStgDebugOpts :: DynFlags -> StgDebugOpts
GHC/Driver/Config/Stg/Lift.hs view
@@ -4,7 +4,7 @@  import GHC.Stg.Lift.Config -import GHC.Driver.Session+import GHC.Driver.DynFlags  initStgLiftConfig :: DynFlags -> StgLiftConfig initStgLiftConfig dflags = StgLiftConfig
GHC/Driver/Config/Stg/Pipeline.hs view
@@ -7,22 +7,28 @@ 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.Session+import GHC.Driver.DynFlags  -- | Initialize STG pretty-printing options from DynFlags initStgPipelineOpts :: DynFlags -> Bool -> StgPipelineOpts-initStgPipelineOpts dflags for_bytecode = StgPipelineOpts-  { stgPipeline_lint = do-      guard $ gopt Opt_DoStgLinting dflags-      Just $ initDiagOpts dflags-  , stgPipeline_pprOpts = initStgPprOpts dflags-  , stgPipeline_phases = getStgToDo for_bytecode dflags-  , stgPlatform = targetPlatform dflags-  }+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
GHC/Driver/Config/StgToCmm.hs view
@@ -1,19 +1,24 @@+{-# 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 -import Data.Maybe-import Prelude- initStgToCmmConfig :: DynFlags -> Module -> StgToCmmConfig initStgToCmmConfig dflags mod = StgToCmmConfig   -- settings@@ -21,7 +26,7 @@   , stgToCmmThisModule    = mod   , stgToCmmTmpDir        = tmpDir          dflags   , stgToCmmContext       = initSDocContext dflags defaultDumpStyle-  , stgToCmmDebugLevel    = debugLevel      dflags+  , stgToCmmEmitDebugInfo = debugLevel      dflags > 0   , stgToCmmBinBlobThresh = b_blob   , stgToCmmMaxInlAllocSize = maxInlineAllocSize           dflags   -- ticky options@@ -33,11 +38,13 @@   -- flags   , stgToCmmLoopification = gopt Opt_Loopification         dflags   , stgToCmmAlignCheck    = gopt Opt_AlignmentSanitisation dflags-  , stgToCmmOptHpc        = gopt Opt_Hpc                   dflags   , stgToCmmFastPAPCalls  = gopt Opt_FastPAPCalls          dflags   , stgToCmmSCCProfiling  = sccProfilingEnabled            dflags   , stgToCmmEagerBlackHole = gopt Opt_EagerBlackHoling     dflags+  , 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@@ -45,25 +52,58 @@   , stgToCmmExtDynRefs    = gopt Opt_ExternalDynamicRefs   dflags   , stgToCmmDoBoundsCheck = gopt Opt_DoBoundsChecking      dflags   , stgToCmmDoTagCheck    = gopt Opt_DoTagInferenceChecks  dflags-  -- backend flags-  , stgToCmmAllowBigArith             = not ncg+  , 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-  , stgToCmmAllowIntMul2Instr         = (ncg && x86ish) || llvm-  , stgToCmmAllowFabsInstrs           = (ncg && (x86ish || ppc || aarch64)) || 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-          ncg     = bk_end == NCG-          llvm    = bk_end == LLVM+          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@@ -72,7 +112,6 @@                       ArchPPC      -> True                       ArchPPC_64 _ -> True                       _            -> False-          aarch64 = platformArch platform == ArchAArch64-          vec_err = case backend dflags of-                      LLVM -> Nothing-                      _    -> Just (unlines ["SIMD vector instructions require the LLVM back-end.", "Please use -fllvm."])+          vec_err = case backendSimdValidity (backend dflags) of+                      IsValid -> Nothing+                      NotValid msg -> Just msg
+ GHC/Driver/Config/StgToJS.hs view
@@ -0,0 +1,52 @@+module GHC.Driver.Config.StgToJS+  ( initStgToJSConfig+  , initJSLinkConfig+  )+where++import GHC.StgToJS.Types+import GHC.StgToJS.Linker.Types++import GHC.Driver.DynFlags+import GHC.Driver.Config.Linker++import GHC.Platform.Ways+import GHC.Utils.Outputable++import GHC.Prelude++-- | Initialize StgToJS settings from DynFlags+initStgToJSConfig :: DynFlags -> StgToJSConfig+initStgToJSConfig dflags = StgToJSConfig+  -- flags+  { csInlinePush      = False+  , csInlineBlackhole = False+  , csInlineLoadRegs  = False+  , csInlineEnter     = False+  , csInlineAlloc     = False+  , csPrettyRender    = gopt Opt_DisableJsMinifier dflags+  , csTraceRts        = False+  , csAssertRts       = False+  , csBoundsCheck     = gopt Opt_DoBoundsChecking dflags+  , csDebugAlloc      = False+  , csTraceForeign    = False+  , csProf            = ways dflags `hasWay` WayProf+  , csRuntimeAssert   = False+  -- settings+  , csContext         = initSDocContext dflags defaultDumpStyle+  , csLinkerConfig    = initLinkerConfig dflags+  }++-- | Default linker configuration+initJSLinkConfig :: DynFlags -> JSLinkConfig+initJSLinkConfig dflags = JSLinkConfig+  { lcNoJSExecutables = False+  , lcNoHsMain        = False+  , lcNoRts           = False+  , lcNoStats         = False+  , lcCombineAll      = True+  , lcForeignRefs     = True+  , lcForceEmccRts    = False+  , lcLinkCsources    = not (gopt Opt_DisableJsCsources dflags)+  }+
GHC/Driver/Config/Tidy.hs view
@@ -12,16 +12,13 @@ import GHC.Iface.Tidy import GHC.Iface.Tidy.StaticPtrTable -import GHC.Driver.Session+import GHC.Driver.DynFlags import GHC.Driver.Env import GHC.Driver.Backend  import GHC.Core.Make (getMkStringIds)-import GHC.Data.Maybe-import GHC.Utils.Panic-import GHC.Utils.Outputable import GHC.Builtin.Names-import GHC.Tc.Utils.Env (lookupGlobal_maybe)+import GHC.Tc.Utils.Env (lookupGlobal) import GHC.Types.TyThing import GHC.Platform.Ways @@ -39,35 +36,29 @@     , 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 -  let lookupM n = lookupGlobal_maybe hsc_env n >>= \case-        Succeeded r -> pure r-        Failed err  -> pprPanic "initStaticPtrOpts: couldn't find" (ppr (err,n))--  mk_string <- getMkStringIds (fmap tyThingId . lookupM)-  static_ptr_info_datacon <- tyThingDataCon <$> lookupM staticPtrInfoDataConName-  static_ptr_datacon      <- tyThingDataCon <$> lookupM staticPtrDataConName+  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 = case backend dflags of-                        Interpreter -> False-                        _           -> True-+    , opt_gen_cstub = backendWritesFiles (backend dflags)     , opt_mk_string = mk_string     , opt_static_ptr_info_datacon = static_ptr_info_datacon     , opt_static_ptr_datacon      = static_ptr_datacon     }-
+ GHC/Driver/Downsweep.hs view
@@ -0,0 +1,1547 @@+{-# LANGUAGE NondecreasingIndentation #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE ViewPatterns #-}+module GHC.Driver.Downsweep+  ( downsweep+  , downsweepThunk+  , downsweepInstalledModules+  , downsweepFromRootNodes+  , downsweepInteractiveImports+  , DownsweepMode(..)+   -- * Summary functions+  , summariseModule+  , summariseFile+  , summariseModuleInterface+  , SummariseResult(..)+  -- * Helper functions+  , instantiationNodes+  , checkHomeUnitsClosed+  ) where++import GHC.Prelude++import GHC.Platform.Ways++import GHC.Driver.Config.Finder (initFinderOpts)+import GHC.Driver.Config.Parser (initParserOpts)+import GHC.Driver.Phases+import {-# SOURCE #-} GHC.Driver.Pipeline (preprocess)+import GHC.Driver.Session+import GHC.Driver.Backend+import GHC.Driver.Monad+import GHC.Driver.Env+import GHC.Driver.Errors+import GHC.Driver.Errors.Types+import GHC.Driver.Messager+import GHC.Driver.MakeSem+import GHC.Driver.MakeAction+import GHC.Driver.Config.Diagnostic+import GHC.Driver.Ppr++import GHC.Iface.Load++import GHC.Parser.Header+import GHC.Rename.Names+import GHC.Tc.Utils.Backpack+import GHC.Runtime.Context++import Language.Haskell.Syntax.ImpExp++import GHC.Data.Graph.Directed+import GHC.Data.FastString+import GHC.Data.Maybe      ( expectJust )+import qualified GHC.Data.Maybe as M+import GHC.Data.OsPath     ( unsafeEncodeUtf )+import GHC.Data.StringBuffer+import GHC.Data.Graph.Directed.Reachability+import qualified GHC.LanguageExtensions as LangExt++import GHC.Utils.Exception ( throwIO, SomeAsyncException )+import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Utils.Misc+import GHC.Utils.Error+import GHC.Utils.Logger+import GHC.Utils.Fingerprint+import GHC.Utils.TmpFs+import GHC.Utils.Constants++import GHC.Types.Error+import GHC.Types.Target+import GHC.Types.SourceFile+import GHC.Types.SourceError+import GHC.Types.SrcLoc+import GHC.Types.Unique.Map+import GHC.Types.PkgQual+import GHC.Types.Basic+++import GHC.Unit+import GHC.Unit.Env+import GHC.Unit.Finder+import GHC.Unit.Module.ModSummary+import GHC.Unit.Module.ModIface+import GHC.Unit.Module.Graph+import GHC.Unit.Module.Deps+import qualified GHC.Unit.Home.Graph as HUG+import GHC.Unit.Module.Stage++import Data.Either ( rights, partitionEithers, lefts )+import qualified Data.Map as Map+import qualified Data.Set as Set++import Control.Concurrent.MVar+import Control.Monad+import Control.Monad.Trans.Except ( ExceptT(..), runExceptT, throwE )+import qualified Control.Monad.Catch as MC+import Data.Maybe+import Data.List (partition)+import Data.Time+import Data.List (unfoldr)+import Data.Bifunctor (first, bimap)+import System.Directory+import System.FilePath++import Control.Monad.Trans.Reader+import qualified Data.Map.Strict as M+import Control.Monad.Trans.Class+import System.IO.Unsafe (unsafeInterleaveIO)++{-+Note [Downsweep and the ModuleGraph]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++The ModuleGraph stores the relationship between all the modules, units, and+instantiations in the current session.++When we do downsweep, we build up a new ModuleGraph, starting from the root+modules. By following all the dependencies we construct a graph which allows+us to answer questions about the transitive closure of the imports.++The module graph is accessible in the HscEnv.++When is this graph constructed?++1. In `--make` mode, we construct the graph before starting to do any compilation.++2. In `-c` (oneshot) mode, we construct the graph when we have calculated the+   ModSummary for the module we are compiling. The `ModuleGraph` is stored in a+   thunk, so it is only constructed when it is needed. This avoids reading+   the interface files of the whole transitive closure unless they are needed.++3. In some situations (such as loading plugins) we may need to construct the+   graph without having a ModSummary. In this case we use the `downsweepInstalledModules`+   function.++The result is having a uniform graph available for the whole compilation pipeline.++-}++-- This caches the answer to the question, if we are in this unit, what does+-- an import of this module mean.+type DownsweepCache = M.Map (UnitId, PkgQual, ModuleNameWithIsBoot) [Either DriverMessages ModuleNodeInfo]++-----------------------------------------------------------------------------+--+-- | Downsweep (dependency analysis) for --make mode+--+-- Chase downwards from the specified root set, returning summaries+-- for all home modules encountered.  Only follow source-import+-- links.+--+-- We pass in the previous collection of summaries, which is used as a+-- cache to avoid recalculating a module summary if the source is+-- unchanged.+--+-- The returned ModuleGraph has one node for each home-package+-- module, plus one for any hs-boot files.  The imports of these nodes+-- are all there, including the imports of non-home-package modules.+--+-- This function is intendned for use by --make mode and will also insert+-- LinkNodes and InstantiationNodes for any home units.+--+-- It will also turn on code generation for any modules that need it by calling+-- 'enableCodeGenForTH'.+downsweep :: HscEnv+          -> (GhcMessage -> AnyGhcDiagnostic)+          -> Maybe Messager+          -> [ModSummary]+          -- ^ Old summaries+          -> [ModuleName]       -- Ignore dependencies on these; treat+                                -- them as if they were package modules+          -> Bool               -- True <=> allow multiple targets to have+                                --          the same module name; this is+                                --          very useful for ghc -M+          -> IO ([DriverMessages], ModuleGraph)+                -- The non-error elements of the returned list all have distinct+                -- (Modules, IsBoot) identifiers, unless the Bool is true in+                -- which case there can be repeats+downsweep hsc_env diag_wrapper msg old_summaries excl_mods allow_dup_roots = do+  n_jobs <- mkWorkerLimit (hsc_dflags hsc_env)+  (root_errs, root_summaries) <- rootSummariesParallel n_jobs hsc_env diag_wrapper msg summary+  let closure_errs = checkHomeUnitsClosed unit_env+      unit_env = hsc_unit_env hsc_env++      all_errs = closure_errs ++ root_errs++  case all_errs of+    [] -> do+       (downsweep_errs, downsweep_nodes) <- downsweepFromRootNodes hsc_env old_summary_map excl_mods allow_dup_roots DownsweepUseCompile (map ModuleNodeCompile root_summaries) []++       let (other_errs, unit_nodes) = partitionEithers $ HUG.unitEnv_foldWithKey (\nodes uid hue -> nodes ++ unitModuleNodes downsweep_nodes uid hue) [] (hsc_HUG hsc_env)++       let all_nodes = downsweep_nodes ++ unit_nodes+       let all_errs = downsweep_errs ++ other_errs++       let logger = hsc_logger hsc_env+           tmpfs = hsc_tmpfs hsc_env+       -- if we have been passed -fno-code, we enable code generation+       -- for dependencies of modules that have -XTemplateHaskell,+       -- otherwise those modules will fail to compile.+       -- See Note [-fno-code mode] #8025+       th_configured_nodes <- enableCodeGenForTH logger tmpfs unit_env all_nodes++       return (all_errs, th_configured_nodes)+    _  -> return (all_errs, emptyMG)+  where+    summary = getRootSummary excl_mods old_summary_map++    -- A cache from file paths to the already summarised modules. The same file+    -- can be used in multiple units so the map is also keyed by which unit the+    -- file was used in.+    -- Reuse these if we can because the most expensive part of downsweep is+    -- reading the headers.+    old_summary_map :: M.Map (UnitId, FilePath) ModSummary+    old_summary_map =+      M.fromList [((ms_unitid ms, msHsFilePath ms), ms) | ms <- old_summaries]++    -- Dependencies arising on a unit (backpack and module linking deps)+    unitModuleNodes :: [ModuleGraphNode] -> UnitId -> HomeUnitEnv -> [Either (Messages DriverMessage) ModuleGraphNode]+    unitModuleNodes summaries uid hue =+      maybeToList (linkNodes summaries uid hue)++-- | Calculate the module graph starting from a single ModSummary. The result is a+-- thunk, which when forced will perform the downsweep. This is useful in oneshot+-- mode where the module graph may never be needed.+-- If downsweep fails, then the resulting errors are just thrown.+downsweepThunk :: HscEnv -> ModSummary -> IO ModuleGraph+downsweepThunk hsc_env mod_summary = unsafeInterleaveIO $ do+  debugTraceMsg (hsc_logger hsc_env) 3 $ text "Computing Module Graph thunk..."+  ~(errs, mg) <- downsweepFromRootNodes hsc_env mempty [] True DownsweepUseFixed [ModuleNodeCompile mod_summary] []+  let dflags = hsc_dflags hsc_env+  liftIO $ printOrThrowDiagnostics (hsc_logger hsc_env)+                                   (initPrintConfig dflags)+                                   (initDiagOpts dflags)+                                   (GhcDriverMessage <$> unionManyMessages errs)+  return (mkModuleGraph mg)++-- | Construct a module graph starting from the interactive context.+-- Produces, a thunk, which when forced will perform the downsweep.+-- This graph contains the current interactive module, and its dependencies.+--+--  Invariant: The hsc_mod_graph already contains the relevant home modules which+--  might be imported by the interactive imports.+--+-- This is a first approximation for this function. There probably should also+-- be edges linking the interactive modules together. (Ie Ghci7 importing Ghci6+-- and so on)+-- See Note [runTcInteractive module graph]+downsweepInteractiveImports :: HscEnv -> InteractiveContext -> IO ModuleGraph+downsweepInteractiveImports hsc_env ic = unsafeInterleaveIO $ do+  debugTraceMsg (hsc_logger hsc_env) 3 $ (text "Computing Interactive Module Graph thunk...")+  let imps = ic_imports (hsc_IC hsc_env)++  let interactive_mn = icInteractiveModule ic+  -- No sensible value for ModLocation.. if you hit this panic then you probably+  -- need to add proper support for modules without any source files to the driver.+  let ml = pprPanic "modLocation" (ppr interactive_mn <+> ppr imps)+  let key = moduleToMnk interactive_mn NotBoot+  let node_type = ModuleNodeFixed key ml++  -- The existing nodes in the module graph. This will be populated when GHCi runs+  -- :load. Any home package modules need to already be in here.+  let cached_nodes = Map.fromList [ (mkNodeKey n, n) | n <- mg_mss (hsc_mod_graph hsc_env) ]++  (module_edges, graph) <- loopFromInteractive hsc_env (map mkEdge imps) cached_nodes+  let interactive_node = ModuleNode module_edges node_type++  let all_nodes  = M.elems graph+  return $ mkModuleGraph (interactive_node : all_nodes)++  where+ --+    mkEdge :: InteractiveImport -> Either ModuleNodeEdge (UnitId, ImportLevel, PkgQual, GenWithIsBoot (Located ModuleName))+    -- A simple edge to a module from the same home unit+    mkEdge (IIModule n) =+      let+        mod_node_key = ModNodeKeyWithUid+          { mnkModuleName = GWIB (moduleName n) NotBoot+          , mnkUnitId =+              -- 'toUnitId' is safe here, as we can't import modules that+              -- don't have a 'UnitId'.+              toUnitId (moduleUnit n)+          }+        mod_node_edge =+          ModuleNodeEdge NormalLevel (NodeKey_Module mod_node_key)+      in Left mod_node_edge+    -- A complete import statement+    mkEdge (IIDecl i) =+      let lvl = convImportLevel (ideclLevelSpec i)+          wanted_mod = unLoc (ideclName i)+          is_boot = ideclSource i+          mb_pkg = renameRawPkgQual (hsc_unit_env hsc_env) (unLoc $ ideclName i) (ideclPkgQual i)+          unitId = homeUnitId $ hsc_home_unit hsc_env+      in Right (unitId, lvl, mb_pkg, GWIB (noLoc wanted_mod) is_boot)++loopFromInteractive :: HscEnv+                    -> [Either ModuleNodeEdge (UnitId, ImportLevel, PkgQual, GenWithIsBoot (Located ModuleName))]+                    -> M.Map NodeKey ModuleGraphNode+                    -> IO ([ModuleNodeEdge],M.Map NodeKey ModuleGraphNode)+loopFromInteractive _ [] cached_nodes = return ([], cached_nodes)+loopFromInteractive hsc_env (edge:edges) cached_nodes =+  case edge of+    Left edge -> do+        (edges, cached_nodes') <- loopFromInteractive hsc_env edges cached_nodes+        return (edge : edges, cached_nodes')+    Right (unitId, lvl, mb_pkg, GWIB wanted_mod is_boot) -> do+      let home_unit = ue_unitHomeUnit unitId (hsc_unit_env hsc_env)+      let k _ loc mod =+            let key = moduleToMnk mod is_boot+            in return $ FoundHome (ModuleNodeFixed key loc)+      found <- liftIO $ summariseModuleDispatch k hsc_env home_unit is_boot wanted_mod mb_pkg []+      case found of+        -- Case 1: Home modules have to already be in the cache.+        FoundHome (ModuleNodeFixed mod _) -> do+          let edge = ModuleNodeEdge lvl (NodeKey_Module mod)+          -- Note: Does not perform any further downsweep as the module must already be in the cache.+          (edges, cached_nodes') <- loopFromInteractive hsc_env edges cached_nodes+          return (edge : edges, cached_nodes')+        -- Case 2: External units may not be in the cache, if we haven't already initialised the+        -- module graph. We can construct the module graph for those here by calling loopUnit.+        External uid -> do+          let hsc_env' = hscSetActiveHomeUnit home_unit hsc_env+              cached_nodes' = loopUnit hsc_env' cached_nodes [uid]+              edge = ModuleNodeEdge lvl (NodeKey_ExternalUnit uid)+          (edges, cached_nodes') <- loopFromInteractive hsc_env edges cached_nodes'+          return (edge : edges, cached_nodes')+        -- And if it's not found.. just carry on and hope.+        _ -> loopFromInteractive hsc_env edges cached_nodes+++-- | Create a module graph from a list of installed modules.+-- This is used by the loader when we need to load modules but there+-- isn't already an existing module graph. For example, when loading plugins+-- during initialisation.+--+-- If you call this function, then if the `Module` you request to downsweep can't+-- be found then this function will throw errors.+-- If you need to use this function elsewhere, then it would make sense to make it+-- return [DriverMessages] and [ModuleGraph] so that the caller can handle the errors as it sees fit.+-- At the moment, it is overfitted for what `get_reachable_nodes` needs.+downsweepInstalledModules :: HscEnv -> [Module] -> IO ModuleGraph+downsweepInstalledModules hsc_env mods = do+    let+        (home_mods, external_mods) = partition (\u -> moduleUnitId u `elem` hsc_all_home_unit_ids hsc_env) mods+        installed_mods = map (fst . getModuleInstantiation) home_mods+        external_uids = map moduleUnitId external_mods++        process :: InstalledModule -> IO ModuleNodeInfo+        process i = do+          res <- findExactModule hsc_env i NotBoot+          case res of+            InstalledFound loc -> return $ ModuleNodeFixed (installedModuleToMnk i) loc+            -- It is an internal-ish error if this happens, since we any call to this function should+            -- already know that we can find the modules we need to load.+            _ -> throwGhcException $ ProgramError $ showSDoc (hsc_dflags hsc_env) $ text "downsweepInstalledModules: Could not find installed module" <+> ppr i++    nodes <- mapM process installed_mods+    (errs, mg) <- downsweepFromRootNodes hsc_env mempty [] True DownsweepUseFixed nodes external_uids++    -- Similarly here, we should really not get any errors, but print them out if we do.+    let dflags = hsc_dflags hsc_env+    liftIO $ printOrThrowDiagnostics (hsc_logger hsc_env)+                                     (initPrintConfig dflags)+                                     (initDiagOpts dflags)+                                     (GhcDriverMessage <$> unionManyMessages errs)++    return (mkModuleGraph mg)++++-- | Whether downsweep should use compiler or fixed nodes. Compile nodes are used+-- by --make mode, and fixed nodes by oneshot mode.+--+-- See Note [Module Types in the ModuleGraph] for the difference between the two.+data DownsweepMode = DownsweepUseCompile | DownsweepUseFixed++-- | Perform downsweep, starting from the given root 'ModuleNodeInfo's and root+-- 'UnitId's.+-- This function will start at the given roots, and traverse downwards to find+-- all the dependencies, all the way to the leaf units.+downsweepFromRootNodes :: HscEnv+                  -> M.Map (UnitId, FilePath) ModSummary+                  -> [ModuleName]+                  -> Bool+                  -> DownsweepMode -- ^ Whether to create fixed or compile nodes for dependencies+                  -> [ModuleNodeInfo] -- ^ The starting ModuleNodeInfo+                  -> [UnitId] -- ^ The starting units+                  -> IO ([DriverMessages], [ModuleGraphNode])+downsweepFromRootNodes hsc_env old_summaries excl_mods allow_dup_roots mode root_nodes root_uids+   = do+       let root_map = mkRootMap root_nodes+       checkDuplicates root_map+       let env = DownsweepEnv hsc_env mode old_summaries excl_mods+       (deps', map0) <- runDownsweepM env  $ do+                    (module_deps, map0) <- loopModuleNodeInfos root_nodes (M.empty, root_map)+                    let all_deps = loopUnit hsc_env module_deps root_uids+                    let all_instantiations =  getHomeUnitInstantiations hsc_env+                    deps' <- loopInstantiations all_instantiations all_deps+                    return (deps', map0)+++       let downsweep_errs = lefts $ concat $ M.elems map0+           downsweep_nodes = M.elems deps'++       return (downsweep_errs, downsweep_nodes)+     where+        getHomeUnitInstantiations :: HscEnv -> [(UnitId, InstantiatedUnit)]+        getHomeUnitInstantiations hsc_env = HUG.unitEnv_foldWithKey (\nodes uid hue -> nodes ++  instantiationNodes uid (homeUnitEnv_units hue)) [] (hsc_HUG hsc_env)++        -- In a root module, the filename is allowed to diverge from the module+        -- name, so we have to check that there aren't multiple root files+        -- defining the same module (otherwise the duplicates will be silently+        -- ignored, leading to confusing behaviour).+        checkDuplicates+          :: DownsweepCache+          -> IO ()+        checkDuplicates root_map+           | not allow_dup_roots+           , dup_root:_ <- dup_roots = liftIO $ multiRootsErr dup_root+           | otherwise = pure ()+           where+             dup_roots :: [[ModuleNodeInfo]]        -- Each at least of length 2+             dup_roots = filterOut isSingleton $ map rights (M.elems root_map)+++calcDeps :: ModSummary -> [(UnitId, ImportLevel, PkgQual, GenWithIsBoot (Located ModuleName))]+calcDeps ms =+  -- Add a dependency on the HsBoot file if it exists+  -- This gets passed to the loopImports function which just ignores it if it+  -- can't be found.+  [(ms_unitid ms, NormalLevel, NoPkgQual, GWIB (noLoc $ ms_mod_name ms) IsBoot) | NotBoot <- [isBootSummary ms] ] +++  [(ms_unitid ms, lvl, b, c) | (lvl, b, c) <- msDeps ms ]+++type DownsweepM a = ReaderT DownsweepEnv IO a+data DownsweepEnv = DownsweepEnv {+      downsweep_hsc_env :: HscEnv+    , _downsweep_mode :: DownsweepMode+    , _downsweep_old_summaries :: M.Map (UnitId, FilePath) ModSummary+    , _downsweep_excl_mods :: [ModuleName]+}++runDownsweepM :: DownsweepEnv -> DownsweepM a -> IO a+runDownsweepM env act = runReaderT act env+++loopInstantiations :: [(UnitId, InstantiatedUnit)]+                   -> M.Map NodeKey ModuleGraphNode+                   -> DownsweepM (M.Map NodeKey ModuleGraphNode)+loopInstantiations [] done = pure done+loopInstantiations ((home_uid, iud) :xs) done = do+  hsc_env <- asks downsweep_hsc_env+  let home_unit = ue_unitHomeUnit home_uid (hsc_unit_env hsc_env)+  let hsc_env' = hscSetActiveHomeUnit home_unit hsc_env+      done' = loopUnit hsc_env' done [instUnitInstanceOf iud]+      payload = InstantiationNode home_uid iud+  loopInstantiations xs (M.insert (mkNodeKey payload) payload done')+++-- This loops over all the mod summaries in the dependency graph, accumulates the actual dependencies for each module/unit+loopSummaries :: [ModSummary]+      -> (M.Map NodeKey ModuleGraphNode,+            DownsweepCache)+      -> DownsweepM ((M.Map NodeKey ModuleGraphNode), DownsweepCache)+loopSummaries [] done = pure done+loopSummaries (ms:next) (done, summarised)+  | Just {} <- M.lookup k done+  = loopSummaries next (done, summarised)+  -- Didn't work out what the imports mean yet, now do that.+  | otherwise = do+     (final_deps, done', summarised') <- loopImports (calcDeps ms) done summarised+     -- This has the effect of finding a .hs file if we are looking at the .hs-boot file.+     (_, done'', summarised'') <- loopImports (maybeToList hs_file_for_boot) done' summarised'+     loopSummaries next (M.insert k (ModuleNode final_deps (ModuleNodeCompile ms)) done'', summarised'')+  where+    k = NodeKey_Module (msKey ms)++    hs_file_for_boot+      | HsBootFile <- ms_hsc_src ms+      = Just $ ((ms_unitid ms), NormalLevel, NoPkgQual, (GWIB (noLoc $ ms_mod_name ms) NotBoot))+      | otherwise+      = Nothing++loopModuleNodeInfos :: [ModuleNodeInfo] -> (M.Map NodeKey ModuleGraphNode, DownsweepCache) -> DownsweepM (M.Map NodeKey ModuleGraphNode, DownsweepCache)+loopModuleNodeInfos is cache = foldM (flip loopModuleNodeInfo) cache is++loopModuleNodeInfo :: ModuleNodeInfo -> (M.Map NodeKey ModuleGraphNode, DownsweepCache) -> DownsweepM (M.Map NodeKey ModuleGraphNode, DownsweepCache)+loopModuleNodeInfo mod_node_info (done, summarised) = do+  case mod_node_info of+    ModuleNodeCompile ms -> do+      loopSummaries [ms] (done, summarised)+    ModuleNodeFixed mod ml -> do+      done' <- loopFixedModule mod ml done+      return (done', summarised)++-- NB: loopFixedModule does not take a downsweep cache, because if you+-- ever reach a Fixed node, everything under that also must be fixed.+loopFixedModule :: ModNodeKeyWithUid -> ModLocation+                -> M.Map NodeKey ModuleGraphNode+                -> DownsweepM (M.Map NodeKey ModuleGraphNode)+loopFixedModule key loc done = do+  let nk = NodeKey_Module key+  hsc_env <- asks downsweep_hsc_env+  case M.lookup nk done of+    Just {} -> return done+    Nothing -> do+      -- MP: TODO, we should just read the dependency info from the interface rather than either+      -- a. Loading the whole thing into the EPS (this might never nececssary and causes lots of things to be permanently loaded into memory)+      -- b. Loading the whole interface into a buffer before discarding it. (wasted allocation and deserialisation)+      read_result <- liftIO $+        -- 1. Check if the interface is already loaded into the EPS by some other+        -- part of the compiler.+        lookupIfaceByModuleHsc hsc_env (mnkToModule key) >>= \case+          Just iface -> return (M.Succeeded iface)+          Nothing -> readIface (hsc_hooks hsc_env) (hsc_logger hsc_env) (hsc_dflags hsc_env) (hsc_NC hsc_env) (mnkToModule key) (ml_hi_file loc)+      case read_result of+        M.Succeeded iface -> do+          -- Computer information about this node+          let node_deps = ifaceDeps (mi_deps iface)+              edges = map mkFixedEdge node_deps+              node = ModuleNode edges (ModuleNodeFixed key loc)+          foldM (loopFixedNodeKey (mnkUnitId key)) (M.insert nk node done) (bimap snd snd <$> node_deps)+        -- Ignore any failure, we might try to read a .hi-boot file for+        -- example, even if there is not one.+        M.Failed {} ->+          return done++loopFixedNodeKey :: UnitId -> M.Map NodeKey ModuleGraphNode -> Either ModNodeKeyWithUid UnitId -> DownsweepM  (M.Map NodeKey ModuleGraphNode)+loopFixedNodeKey _ done (Left key) = do+  loopFixedImports [key] done+loopFixedNodeKey home_uid done (Right uid) = do+  -- Set active unit so that looking loopUnit finds the correct+  -- -package flags in the unit state.+  hsc_env <- asks downsweep_hsc_env+  let hsc_env' = hscSetActiveUnitId home_uid hsc_env+  return $ loopUnit hsc_env' done [uid]++mkFixedEdge :: Either (ImportLevel, ModNodeKeyWithUid) (ImportLevel, UnitId) -> ModuleNodeEdge+mkFixedEdge (Left (lvl, key)) = mkModuleEdge lvl (NodeKey_Module key)+mkFixedEdge (Right (lvl, uid)) = mkModuleEdge lvl (NodeKey_ExternalUnit uid)++ifaceDeps :: Dependencies -> [Either (ImportLevel, ModNodeKeyWithUid) (ImportLevel, UnitId)]+ifaceDeps deps =+  [ Left (tcImportLevel lvl, ModNodeKeyWithUid dep uid)+  | (lvl, uid, dep) <- Set.toList (dep_direct_mods deps)+  ] +++  [ Right (tcImportLevel lvl, uid)+  | (lvl, uid) <- Set.toList (dep_direct_pkgs deps)+  ]++-- Like loopImports, but we already know exactly which module we are looking for.+loopFixedImports :: [ModNodeKeyWithUid]+                 -> M.Map NodeKey ModuleGraphNode+                 -> DownsweepM (M.Map NodeKey ModuleGraphNode)+loopFixedImports [] done = pure done+loopFixedImports (key:keys) done = do+  let nk = NodeKey_Module key+  hsc_env <- asks downsweep_hsc_env+  case M.lookup nk done of+    Just {} -> loopFixedImports keys done+    Nothing -> do+      read_result <- liftIO $ findExactModule hsc_env (mnkToInstalledModule key) (mnkIsBoot key)+      case read_result of+        InstalledFound loc -> do+          done' <- loopFixedModule key loc done+          loopFixedImports keys done'+        _otherwise ->+          -- If the finder fails, just keep going, there will be another+          -- error later.+          loopFixedImports keys done++downsweepSummarise :: HomeUnit+                   -> IsBootInterface+                   -> Located ModuleName+                   -> PkgQual+                   -> Maybe (StringBuffer, UTCTime)+                   -> DownsweepM SummariseResult+downsweepSummarise home_unit is_boot wanted_mod mb_pkg maybe_buf = do+  DownsweepEnv hsc_env mode old_summaries excl_mods <- ask+  case mode of+    DownsweepUseCompile -> liftIO $ summariseModule hsc_env home_unit old_summaries is_boot wanted_mod mb_pkg maybe_buf excl_mods+    DownsweepUseFixed -> liftIO $ summariseModuleInterface hsc_env home_unit is_boot wanted_mod mb_pkg excl_mods+++-- This loops over each import in each summary. It is mutually recursive with loopSummaries if we discover+-- a new module by doing this.+loopImports :: [(UnitId, ImportLevel, PkgQual, GenWithIsBoot (Located ModuleName))]+                -- Work list: process these modules+     -> M.Map NodeKey ModuleGraphNode+     -> DownsweepCache+                -- Visited set; the range is a list because+                -- the roots can have the same module names+                -- if allow_dup_roots is True+     -> DownsweepM ([ModuleNodeEdge],+          M.Map NodeKey ModuleGraphNode, DownsweepCache)+                -- The result is the completed NodeMap+loopImports [] done summarised = return ([], done, summarised)+loopImports ((home_uid, imp, mb_pkg, gwib) : ss) done summarised+  | Just summs <- M.lookup cache_key summarised+  = case summs of+      [Right ms] -> do+        let nk = mkModuleEdge imp (NodeKey_Module (mnKey ms))+        (rest, summarised', done') <- loopImports ss done summarised+        return (nk: rest, summarised', done')+      [Left _err] ->+        loopImports ss done summarised+      _errs ->  do+        loopImports ss done summarised+  | otherwise+  = do+       hsc_env <- asks downsweep_hsc_env+       let home_unit = ue_unitHomeUnit home_uid (hsc_unit_env hsc_env)+       mb_s <- downsweepSummarise home_unit+                               is_boot wanted_mod mb_pkg+                               Nothing+       case mb_s of+           NotThere -> loopImports ss done summarised+           External uid -> do+            -- Pass an updated hsc_env to loopUnit, as each unit might+            -- have a different visible package database.+            let hsc_env' = hscSetActiveHomeUnit home_unit hsc_env+            let done' = loopUnit hsc_env' done [uid]+            (other_deps, done'', summarised') <- loopImports ss done' summarised+            return (mkModuleEdge imp (NodeKey_ExternalUnit uid) : other_deps, done'', summarised')+           FoundInstantiation iud -> do+            (other_deps, done', summarised') <- loopImports ss done summarised+            return (mkModuleEdge imp (NodeKey_Unit iud) : other_deps, done', summarised')+           FoundHomeWithError (_uid, e) ->  loopImports ss done (Map.insert cache_key [(Left e)] summarised)+           FoundHome s -> do+             (done', summarised') <-+               loopModuleNodeInfo s (done, Map.insert cache_key [Right s] summarised)+             (other_deps, final_done, final_summarised) <- loopImports ss done' summarised'++             -- MP: This assumes that we can only instantiate non home units, which is probably fair enough for now.+             return (mkModuleEdge imp (NodeKey_Module (mnKey s)) : other_deps, final_done, final_summarised)+  where+    cache_key = (home_uid, mb_pkg, unLoc <$> gwib)+    GWIB { gwib_mod = L loc mod, gwib_isBoot = is_boot } = gwib+    wanted_mod = L loc mod++loopUnit :: HscEnv -> Map.Map NodeKey ModuleGraphNode -> [UnitId] -> Map.Map NodeKey ModuleGraphNode+loopUnit _ cache [] = cache+loopUnit lcl_hsc_env cache (u:uxs) = do+   let nk = (NodeKey_ExternalUnit u)+   case Map.lookup nk cache of+     Just {} -> loopUnit lcl_hsc_env cache uxs+     Nothing -> case unitDepends <$> lookupUnitId (hsc_units lcl_hsc_env) u of+                 Just us -> loopUnit lcl_hsc_env (loopUnit lcl_hsc_env (Map.insert nk (UnitNode us u) cache) us) uxs+                 Nothing -> pprPanic "loopUnit" (text "Malformed package database, missing " <+> ppr u)++multiRootsErr :: [ModuleNodeInfo] -> IO ()+multiRootsErr [] = panic "multiRootsErr"+multiRootsErr summs@(summ1:_)+  = throwOneError $ fmap GhcDriverMessage $+    mkPlainErrorMsgEnvelope noSrcSpan $ DriverDuplicatedModuleDeclaration mod files+  where+    mod = moduleNodeInfoModule summ1+    files = mapMaybe (ml_hs_file . moduleNodeInfoLocation) summs++moduleNotFoundErr :: UnitId -> ModuleName -> DriverMessages+moduleNotFoundErr uid mod = singleMessage $ mkPlainErrorMsgEnvelope noSrcSpan (DriverModuleNotFound uid mod)++-- | Collect the instantiations of dependencies to create 'InstantiationNode' work graph nodes.+-- These are used to represent the type checking that is done after+-- all the free holes (sigs in current package) relevant to that instantiation+-- are compiled. This is necessary to catch some instantiation errors.+instantiationNodes :: UnitId -> UnitState -> [(UnitId, InstantiatedUnit)]+instantiationNodes uid unit_state = map (uid,) iuids_to_check+  where+    iuids_to_check :: [InstantiatedUnit]+    iuids_to_check =+      nubSort $ concatMap (goUnitId . fst) (explicitUnits unit_state)+     where+      goUnitId uid =+        [ recur+        | VirtUnit indef <- [uid]+        , inst <- instUnitInsts indef+        , recur <- (indef :) $ goUnitId $ moduleUnit $ snd inst+        ]++-- The linking plan for each module. If we need to do linking for a home unit+-- then this function returns a graph node which depends on all the modules in the home unit.++-- At the moment nothing can depend on these LinkNodes.+linkNodes :: [ModuleGraphNode] -> UnitId -> HomeUnitEnv -> Maybe (Either (Messages DriverMessage) ModuleGraphNode)+linkNodes summaries uid hue =+  let dflags = homeUnitEnv_dflags hue+      ofile = outputFile_ dflags++      unit_nodes :: [NodeKey]+      unit_nodes = map mkNodeKey (filter ((== uid) . mgNodeUnitId) summaries)+  -- Issue a warning for the confusing case where the user+  -- said '-o foo' but we're not going to do any linking.+  -- We attempt linking if either (a) one of the modules is+  -- called Main, or (b) the user said -no-hs-main, indicating+  -- that main() is going to come from somewhere else.+  --+      no_hs_main = gopt Opt_NoHsMain dflags++      main_sum = any (== NodeKey_Module (ModNodeKeyWithUid (GWIB (mainModuleNameIs dflags) NotBoot) uid)) unit_nodes++      do_linking =  main_sum || no_hs_main || ghcLink dflags == LinkDynLib || ghcLink dflags == LinkStaticLib++  in if | ghcLink dflags == LinkBinary && isJust ofile && not do_linking ->+            Just (Left $ singleMessage $ mkPlainErrorMsgEnvelope noSrcSpan (DriverRedirectedNoMain $ mainModuleNameIs dflags))+        -- This should be an error, not a warning (#10895).+        | ghcLink dflags /= NoLink, do_linking -> Just (Right (LinkNode unit_nodes uid))+        | otherwise  -> Nothing++getRootSummary ::+  [ModuleName] ->+  M.Map (UnitId, FilePath) ModSummary ->+  HscEnv ->+  Target ->+  IO (Either DriverMessages ModSummary)+getRootSummary excl_mods old_summary_map hsc_env target+  | TargetFile file mb_phase <- targetId+  = do+    let offset_file = augmentByWorkingDirectory dflags file+    exists <- liftIO $ doesFileExist offset_file+    if exists || isJust maybe_buf+    then summariseFile hsc_env home_unit old_summary_map offset_file mb_phase+         maybe_buf+    else+      return $ Left $ singleMessage $+      mkPlainErrorMsgEnvelope noSrcSpan (DriverFileNotFound offset_file)+  | TargetModule modl <- targetId+  = do+    maybe_summary <- summariseModule hsc_env home_unit old_summary_map NotBoot+                     (L rootLoc modl) (ThisPkg (homeUnitId home_unit))+                     maybe_buf excl_mods+    pure case maybe_summary of+      FoundHome (ModuleNodeCompile s)  -> Right s+      FoundHomeWithError err -> Left (snd err)+      _ -> Left (moduleNotFoundErr uid modl)+    where+      Target {targetId, targetContents = maybe_buf, targetUnitId = uid} = target+      home_unit = ue_unitHomeUnit uid (hsc_unit_env hsc_env)+      rootLoc = mkGeneralSrcSpan (fsLit "<command line>")+      dflags = homeUnitEnv_dflags (ue_findHomeUnitEnv uid (hsc_unit_env hsc_env))++-- | Execute 'getRootSummary' for the 'Target's using the parallelism pipeline+-- system.+-- Create bundles of 'Target's wrapped in a 'MakeAction' that uses+-- 'withAbstractSem' to wait for a free slot, limiting the number of+-- concurrently computed summaries to the value of the @-j@ option or the slots+-- allocated by the job server, if that is used.+--+-- The 'MakeAction' returns 'Maybe', which is not handled as an error, because+-- 'runLoop' only sets it to 'Nothing' when an exception was thrown, so the+-- result won't be read anyway here.+--+-- To emulate the current behavior, we funnel exceptions past the concurrency+-- barrier and rethrow the first one afterwards.+rootSummariesParallel ::+  WorkerLimit ->+  HscEnv ->+  (GhcMessage -> AnyGhcDiagnostic) ->+  Maybe Messager ->+  (HscEnv -> Target -> IO (Either DriverMessages ModSummary)) ->+  IO ([DriverMessages], [ModSummary])+rootSummariesParallel n_jobs hsc_env diag_wrapper msg get_summary = do+  (actions, get_results) <- unzip <$> mapM action_and_result (zip [1..] bundles)+  runPipelines n_jobs hsc_env diag_wrapper msg actions+  (sequence . catMaybes <$> sequence get_results) >>= \case+    Right results -> pure (partitionEithers (concat results))+    Left exc -> throwIO exc+  where+    bundles = mk_bundles targets++    mk_bundles = unfoldr \case+      [] -> Nothing+      ts -> Just (splitAt bundle_size ts)++    bundle_size = 20++    targets = hsc_targets hsc_env++    action_and_result (log_queue_id, ts) = do+      res_var <- liftIO newEmptyMVar+      pure $! (MakeAction (action log_queue_id ts) res_var, readMVar res_var)++    action log_queue_id target_bundle = do+      env@MakeEnv {compile_sem} <- ask+      lift $ lift $+        withAbstractSem compile_sem $+        withLoggerHsc log_queue_id env \ lcl_hsc_env ->+          MC.try (mapM (get_summary lcl_hsc_env) target_bundle) >>= \case+            Left e | Just (_ :: SomeAsyncException) <- fromException e ->+              throwIO e+            a -> pure a++-- | This function checks then important property that if both p and q are home units+-- then any dependency of p, which transitively depends on q is also a home unit.+--+-- See Note [Multiple Home Units], section 'Closure Property'.+checkHomeUnitsClosed ::  UnitEnv -> [DriverMessages]+checkHomeUnitsClosed ue+    | Set.null bad_unit_ids = []+    | otherwise = [singleMessage $ mkPlainErrorMsgEnvelope rootLoc $ DriverHomePackagesNotClosed (Set.toList bad_unit_ids)]+  where+    home_id_set = HUG.allUnits $ ue_home_unit_graph ue+    bad_unit_ids = upwards_closure Set.\\ home_id_set {- Remove all home units reached, keep only bad nodes -}+    rootLoc = mkGeneralSrcSpan (fsLit "<command line>")++    downwards_closure :: Graph (Node UnitId UnitId)+    downwards_closure = graphFromEdgedVerticesUniq graphNodes++    inverse_closure = graphReachability $ transposeG downwards_closure++    upwards_closure = Set.fromList $ map node_key $ allReachableMany inverse_closure [DigraphNode uid uid [] | uid <- Set.toList home_id_set]++    all_unit_direct_deps :: UniqMap UnitId (Set.Set UnitId)+    all_unit_direct_deps+      = HUG.unitEnv_foldWithKey go emptyUniqMap $ ue_home_unit_graph ue+      where+        go rest this this_uis =+           plusUniqMap_C Set.union+             (addToUniqMap_C Set.union external_depends this (Set.fromList $ this_deps))+             rest+           where+             external_depends = mapUniqMap (Set.fromList . unitDepends) (unitInfoMap this_units)+             this_units = homeUnitEnv_units this_uis+             this_deps = [ toUnitId unit | (unit,Just _) <- explicitUnits this_units]++    graphNodes :: [Node UnitId UnitId]+    graphNodes = go Set.empty home_id_set+      where+        go done todo+          = case Set.minView todo of+              Nothing -> []+              Just (uid, todo')+                | Set.member uid done -> go done todo'+                | otherwise -> case lookupUniqMap all_unit_direct_deps uid of+                    Nothing -> pprPanic "uid not found" (ppr (uid, all_unit_direct_deps))+                    Just depends ->+                      let todo'' = (depends Set.\\ done) `Set.union` todo'+                      in DigraphNode uid uid (Set.toList depends) : go (Set.insert uid done) todo''++-- | Update the every ModSummary that is depended on+-- by a module that needs template haskell. We enable codegen to+-- the specified target, disable optimization and change the .hi+-- and .o file locations to be temporary files.+-- See Note [-fno-code mode]+enableCodeGenForTH+  :: Logger+  -> TmpFs+  -> UnitEnv+  -> [ModuleGraphNode]+  -> IO ModuleGraph+enableCodeGenForTH logger tmpfs unit_env =+  enableCodeGenWhen logger tmpfs TFL_CurrentModule TFL_GhcSession unit_env+++data CodeGenEnable = EnableByteCode | EnableObject | EnableByteCodeAndObject deriving (Eq, Show, Ord)++instance Outputable CodeGenEnable where+  ppr = text . show++-- | Helper used to implement 'enableCodeGenForTH'.+-- In particular, this enables+-- unoptimized code generation for all modules that meet some+-- condition (first parameter), or are dependencies of those+-- modules. The second parameter is a condition to check before+-- marking modules for code generation.+enableCodeGenWhen+  :: Logger+  -> TmpFs+  -> TempFileLifetime+  -> TempFileLifetime+  -> UnitEnv+  -> [ModuleGraphNode]+  -> IO ModuleGraph+enableCodeGenWhen logger tmpfs staticLife dynLife unit_env mod_graph = do+  mgMapM enable_code_gen mg+  where+    defaultBackendOf ms = platformDefaultBackend (targetPlatform $ ue_unitFlags (ms_unitid ms) unit_env)++    enable_code_gen :: ModuleNodeInfo -> IO ModuleNodeInfo+    enable_code_gen (ModuleNodeCompile ms) = ModuleNodeCompile <$> enable_code_gen_ms ms+    enable_code_gen m@(ModuleNodeFixed {}) = return m++    -- FIXME: Strong resemblance and some duplication between this and `makeDynFlagsConsistent`.+    -- It would be good to consider how to make these checks more uniform and not duplicated.+    enable_code_gen_ms :: ModSummary -> IO ModSummary+    enable_code_gen_ms ms+      | ModSummary+        { ms_location = ms_location+        , ms_hsc_src = HsSrcFile+        , ms_hspp_opts = dflags+        } <- ms+      , Just enable_spec <- needs_codegen_map ms =+      if | nocode_enable ms -> do+               let new_temp_file suf dynsuf = do+                     tn <- newTempName logger tmpfs (tmpDir dflags) staticLife suf+                     let dyn_tn = tn -<.> dynsuf+                     addFilesToClean tmpfs dynLife [dyn_tn]+                     return (unsafeEncodeUtf tn, unsafeEncodeUtf dyn_tn)+                 -- We don't want to create .o or .hi files unless we have been asked+                 -- to by the user. But we need them, so we patch their locations in+                 -- the ModSummary with temporary files.+                 --+               ((hi_file, dyn_hi_file), (o_file, dyn_o_file)) <-+                 -- If ``-fwrite-interface` is specified, then the .o and .hi files+                 -- are written into `-odir` and `-hidir` respectively.  #16670+                 if gopt Opt_WriteInterface dflags+                   then return ((ml_hi_file_ospath ms_location, ml_dyn_hi_file_ospath ms_location)+                               , (ml_obj_file_ospath ms_location, ml_dyn_obj_file_ospath ms_location))+                   else (,) <$> (new_temp_file (hiSuf_ dflags) (dynHiSuf_ dflags))+                            <*> (new_temp_file (objectSuf_ dflags) (dynObjectSuf_ dflags))+               let new_dflags = case enable_spec of+                                  EnableByteCode -> dflags { backend = interpreterBackend }+                                  EnableObject   -> dflags { backend = defaultBackendOf ms }+                                  EnableByteCodeAndObject -> (gopt_set dflags Opt_ByteCodeAndObjectCode) { backend = defaultBackendOf ms}+               let ms' = ms+                     { ms_location =+                         ms_location { ml_hi_file_ospath = hi_file+                                     , ml_obj_file_ospath = o_file+                                     , ml_dyn_hi_file_ospath = dyn_hi_file+                                     , ml_dyn_obj_file_ospath = dyn_o_file }+                     , ms_hspp_opts = updOptLevel 0 $ new_dflags+                     }+               -- Recursive call to catch the other cases+               enable_code_gen_ms ms'++         -- If -fprefer-byte-code then satisfy dependency by enabling bytecode (if normal object not enough)+         -- we only get to this case if the default backend is already generating object files, but we need dynamic+         -- objects+         | bytecode_and_enable enable_spec ms -> do+               let ms' = ms+                     { ms_hspp_opts = gopt_set (ms_hspp_opts ms) Opt_ByteCodeAndObjectCode+                     }+               -- Recursive call to catch the other cases+               enable_code_gen_ms ms'+         | dynamic_too_enable enable_spec ms -> do+               let ms' = ms+                     { ms_hspp_opts = gopt_set (ms_hspp_opts ms) Opt_BuildDynamicToo+                     }+               -- Recursive call to catch the other cases+               enable_code_gen_ms ms'+         | ext_interp_enable ms -> do+               let ms' = ms+                     { ms_hspp_opts = gopt_set (ms_hspp_opts ms) Opt_ExternalInterpreter+                     }+               -- Recursive call to catch the other cases+               enable_code_gen_ms ms'++         | needs_full_ways dflags -> do+               let ms' = ms { ms_hspp_opts = set_full_ways dflags }+               -- Recursive call to catch the other cases+               enable_code_gen_ms ms'++         | otherwise -> return ms++    enable_code_gen_ms ms = return ms++    nocode_enable ms@(ModSummary { ms_hspp_opts = dflags }) =+      not (backendGeneratesCode (backend dflags)) &&+      -- Don't enable codegen for TH on indefinite packages; we+      -- can't compile anything anyway! See #16219.+      isHomeUnitDefinite (ue_unitHomeUnit (ms_unitid ms) unit_env)++    bytecode_and_enable enable_spec ms =+      -- In the situation where we **would** need to enable dynamic-too+      -- IF we had decided we needed objects+      dynamic_too_enable EnableObject ms+        -- but we prefer to use bytecode rather than objects+        && prefer_bytecode+        -- and we haven't already turned it on+        && not generate_both+      where+        lcl_dflags   = ms_hspp_opts ms+        prefer_bytecode = case enable_spec of+                            EnableByteCodeAndObject -> True+                            EnableByteCode -> True+                            EnableObject -> False++        generate_both   = gopt Opt_ByteCodeAndObjectCode lcl_dflags++    -- #8180 - when using TemplateHaskell, switch on -dynamic-too so+    -- the linker can correctly load the object files.  This isn't necessary+    -- when using -fexternal-interpreter.+    -- FIXME: Duplicated from makeDynFlagsConsistent+    dynamic_too_enable enable_spec ms+      | sTargetRTSLinkerOnlySupportsSharedLibs $ settings lcl_dflags =+          not isDynWay && not dyn_too_enabled+            && enable_object+      | otherwise =+          hostIsDynamic && not hostIsProfiled && internalInterpreter &&+            not isDynWay && not isProfWay &&  not dyn_too_enabled+              && enable_object+      where+       lcl_dflags   = ms_hspp_opts ms+       internalInterpreter = not (gopt Opt_ExternalInterpreter lcl_dflags)+       dyn_too_enabled = gopt Opt_BuildDynamicToo lcl_dflags+       isDynWay    = hasWay (ways lcl_dflags) WayDyn+       isProfWay   = hasWay (ways lcl_dflags) WayProf+       enable_object = case enable_spec of+                            EnableByteCode -> False+                            EnableByteCodeAndObject -> True+                            EnableObject -> True++    -- #16331 - when no "internal interpreter" is available but we+    -- need to process some TemplateHaskell or QuasiQuotes, we automatically+    -- turn on -fexternal-interpreter.+    ext_interp_enable ms = not ghciSupported && internalInterpreter+      where+       lcl_dflags   = ms_hspp_opts ms+       internalInterpreter = not (gopt Opt_ExternalInterpreter lcl_dflags)+++    mg = mkModuleGraph mod_graph++    (td_map, lookup_node) = mkStageDeps mod_graph++    queryReachable ns = isReachableMany td_map (mapMaybe lookup_node ns)++    -- NB: Do not inline these, it is very important to share them across all calls+    -- to needs_obj_set and needs_bc_set.+    !query_obj =+      let !deps = queryReachable need_obj_set+      in \k -> deps (expectJust $ lookup_node k)++    !query_bc  =+      let !deps = queryReachable need_bc_set+      in \k -> deps (expectJust $ lookup_node k)++    -- The direct dependencies of modules which require object code+    need_obj_set =++        -- Note we don't need object code for a module if it uses TemplateHaskell itself. Only+        -- it's dependencies.+        [ (mkNodeKey m, RunStage)+        | m@(ModuleNode _deps (ModuleNodeCompile ms)) <- mod_graph+        , isTemplateHaskellOrQQNonBoot ms+        , not (gopt Opt_UseBytecodeRatherThanObjects (ms_hspp_opts ms))+        ]++    -- The direct dependencies of modules which require byte code+    need_bc_set =+        [ (mkNodeKey m, RunStage)+        | m@(ModuleNode _deps (ModuleNodeCompile ms)) <- mod_graph+        , isTemplateHaskellOrQQNonBoot ms+        , gopt Opt_UseBytecodeRatherThanObjects (ms_hspp_opts ms)+        ]++    needs_obj_set, needs_bc_set :: ModNodeKeyWithUid -> Bool+    needs_obj_set k = query_obj (NodeKey_Module k, CompileStage)++    needs_bc_set k = query_bc  (NodeKey_Module k, CompileStage)++    -- A map which tells us how to enable code generation for a NodeKey+    needs_codegen_map :: ModSummary -> Maybe CodeGenEnable+    needs_codegen_map ms =+      let nk = msKey ms+++      -- Another option here would be to just produce object code, rather than both object and+      -- byte code+      in case (needs_obj_set nk, needs_bc_set nk) of+        (True, True)   -> Just EnableByteCodeAndObject+        (True, False)  -> Just EnableObject+        (False, True)  -> Just EnableByteCode+        (False, False) -> Nothing++    -- FIXME: Duplicated from makeDynFlagsConsistent+    needs_full_ways dflags+      = ghcLink dflags == LinkInMemory &&+        not (gopt Opt_ExternalInterpreter dflags) &&+        targetWays_ dflags /= hostFullWays+    set_full_ways dflags =+        let platform = targetPlatform dflags+            dflags_a = dflags { targetWays_ = hostFullWays }+            dflags_b = foldl gopt_set dflags_a+                     $ concatMap (wayGeneralFlags platform)+                                 hostFullWays+            dflags_c = foldl gopt_unset dflags_b+                     $ concatMap (wayUnsetGeneralFlags platform)+                                 hostFullWays+        in dflags_c++{- Note [-fno-code mode]+~~~~~~~~~~~~~~~~~~~~~~~~+GHC offers the flag -fno-code for the purpose of parsing and typechecking a+program without generating object files. This is intended to be used by tooling+and IDEs to provide quick feedback on any parser or type errors as cheaply as+possible.++When GHC is invoked with -fno-code, no object files or linked output will be+generated. As many errors and warnings as possible will be generated, as if+-fno-code had not been passed. The session DynFlags will have+backend == NoBackend.++-fwrite-interface+~~~~~~~~~~~~~~~~+Whether interface files are generated in -fno-code mode is controlled by the+-fwrite-interface flag. The -fwrite-interface flag is a no-op if -fno-code is+not also passed. Recompilation avoidance requires interface files, so passing+-fno-code without -fwrite-interface should be avoided. If -fno-code were+re-implemented today, there would be no need for -fwrite-interface as it+would considered always on; this behaviour is as it is for backwards compatibility.++================================================================+IN SUMMARY: ALWAYS PASS -fno-code AND -fwrite-interface TOGETHER+================================================================++Template Haskell+~~~~~~~~~~~~~~~~+A module using Template Haskell may invoke an imported function from inside a+splice. This will cause the type-checker to attempt to execute that code, which+would fail if no object files had been generated. See #8025. To rectify this,+during the downsweep we patch the DynFlags in the ModSummary of any home module+that is imported by a module that uses Template Haskell to generate object+code.++The flavour of the generated code depends on whether `-fprefer-byte-code` is enabled+or not in the module which needs the code generation. If the module requires byte-code then+dependencies will generate byte-code, otherwise they will generate object files.+In the case where some modules require byte-code and some object files, both are+generated by enabling `-fbyte-code-and-object-code`, the test "fat015" tests these+configurations.++The object files (and interface files if -fwrite-interface is disabled) produced+for Template Haskell are written to temporary files.++Note that since Template Haskell can run arbitrary IO actions, -fno-code mode+is no more secure than running without it.++Explicit Level Imports+~~~~~~~~~~~~~~~~~~~~~~+When `-XExplicitLevelImports` is enabled, code is only generated for modules+needed for the compile stage. The ReachabilityIndex created by `mkStageDeps` answers+the question, if I compile a module for a specific stage, then which modules at+other stages do I need. The roots of this query are the modules which use `TemplateHaskell`+at the runtime stage, and modules we need code generation for are those which+are needed at the compile time stage. All the logic about how ExplicitLevelImports+and TemplateHaskell affect the needed stages of a module is encoded in mkStageDeps.++Potential TODOS:+~~~~~+* Remove -fwrite-interface and have interface files always written in -fno-code+  mode+* Both .o and .dyn_o files are generated for template haskell, but we only need+  .dyn_o (for dynamically linked compilers) Fix it. (The needed way is 'hostFullWays')+* In make mode, a message like+  Compiling A (A.hs, /tmp/ghc_123.o)+  is shown if downsweep enabled object code generation for A. Perhaps we should+  show "nothing" or "temporary object file" instead. Note that one+  can currently use -keep-tmp-files and inspect the generated file with the+  current behaviour.+* Offer a -no-codedir command line option, and write what were temporary+  object files there. This would speed up recompilation.+* Use existing object files (if they are up to date) instead of always+  generating temporary ones.+-}++-- | Populate the Downsweep cache with the root modules.+mkRootMap+  :: [ModuleNodeInfo]+  -> DownsweepCache+mkRootMap summaries = Map.fromListWith (flip (++))+  [ ((moduleNodeInfoUnitId s, NoPkgQual, moduleNodeInfoMnwib s), [Right s]) | s <- summaries ]++-----------------------------------------------------------------------------+-- Summarising modules++-- We have two types of summarisation:+--+--    * Summarise a file.  This is used for the root module(s) passed to+--      cmLoadModules.  The file is read, and used to determine the root+--      module name.  The module name may differ from the filename.+--+--    * Summarise a module.  We are given a module name, and must provide+--      a summary.  The finder is used to locate the file in which the module+--      resides.++summariseFile+        :: HscEnv+        -> HomeUnit+        -> M.Map (UnitId, FilePath) ModSummary    -- old summaries+        -> FilePath                     -- source file name+        -> Maybe Phase                  -- start phase+        -> Maybe (StringBuffer,UTCTime)+        -> IO (Either DriverMessages ModSummary)++summariseFile hsc_env' home_unit old_summaries src_fn mb_phase maybe_buf+        -- we can use a cached summary if one is available and the+        -- source file hasn't changed,+   | Just old_summary <- M.lookup (homeUnitId home_unit, src_fn) old_summaries+   = do+        let location = ms_location $ old_summary++        src_hash <- get_src_hash+                -- The file exists; we checked in getRootSummary above.+                -- If it gets removed subsequently, then this+                -- getFileHash may fail, but that's the right+                -- behaviour.++                -- return the cached summary if the source didn't change+        checkSummaryHash+            hsc_env (new_summary src_fn)+            old_summary location src_hash++   | otherwise+   = do src_hash <- get_src_hash+        new_summary src_fn src_hash+  where+    -- change the main active unit so all operations happen relative to the given unit+    hsc_env = hscSetActiveHomeUnit home_unit hsc_env'+    -- src_fn does not necessarily exist on the filesystem, so we need to+    -- check what kind of target we are dealing with+    get_src_hash = case maybe_buf of+                      Just (buf,_) -> return $ fingerprintStringBuffer buf+                      Nothing -> liftIO $ getFileHash src_fn++    new_summary src_fn src_hash = runExceptT $ do+        preimps@PreprocessedImports {..}+            <- getPreprocessedImports hsc_env src_fn mb_phase maybe_buf++        let fopts = initFinderOpts (hsc_dflags hsc_env)+            (basename, extension) = splitExtension src_fn++            hsc_src+              | isHaskellSigSuffix (drop 1 extension) = HsigFile+              | isHaskellBootSuffix (drop 1 extension) = HsBootFile+              | otherwise = HsSrcFile++            -- Make a ModLocation for this file, adding the @-boot@ suffix to+            -- all paths if the original was a boot file.+            location = mkHomeModLocation fopts pi_mod_name (unsafeEncodeUtf basename) (unsafeEncodeUtf extension) hsc_src++        -- Tell the Finder cache where it is, so that subsequent calls+        -- to findModule will find it, even if it's not on any search path+        mod <- liftIO $ do+          let home_unit = hsc_home_unit hsc_env+          let fc        = hsc_FC hsc_env+          addHomeModuleToFinder fc home_unit pi_mod_name location hsc_src++        liftIO $ makeNewModSummary hsc_env $ MakeNewModSummary+            { nms_src_fn = src_fn+            , nms_src_hash = src_hash+            , nms_hsc_src = hsc_src+            , nms_location = location+            , nms_mod = mod+            , nms_preimps = preimps+            }++checkSummaryHash+    :: HscEnv+    -> (Fingerprint -> IO (Either e ModSummary))+    -> ModSummary -> ModLocation -> Fingerprint+    -> IO (Either e ModSummary)+checkSummaryHash+  hsc_env new_summary+  old_summary+  location src_hash+  | ms_hs_hash old_summary == src_hash &&+      not (gopt Opt_ForceRecomp (hsc_dflags hsc_env)) = do+           -- update the object-file timestamp+           obj_timestamp <- modificationTimeIfExists (ml_obj_file location)++           -- We have to repopulate the Finder's cache for file targets+           -- because the file might not even be on the regular search path+           -- and it was likely flushed in depanal. This is not technically+           -- needed when we're called from sumariseModule but it shouldn't+           -- hurt.+           let fc      = hsc_FC hsc_env+               mod     = ms_mod old_summary+               hsc_src = ms_hsc_src old_summary+           addModuleToFinder fc mod location hsc_src++           hi_timestamp <- modificationTimeIfExists (ml_hi_file location)+           hie_timestamp <- modificationTimeIfExists (ml_hie_file location)++           return $ Right+             ( old_summary+                     { ms_obj_date = obj_timestamp+                     , ms_iface_date = hi_timestamp+                     , ms_hie_date = hie_timestamp+                     }+             )++   | otherwise =+           -- source changed: re-summarise.+           new_summary src_hash++data SummariseResult =+        FoundInstantiation InstantiatedUnit+      | FoundHomeWithError (UnitId, DriverMessages)+      | FoundHome ModuleNodeInfo+      | External UnitId+      | NotThere++-- | summariseModule finds the location of the source file for the given module.+-- This version always returns a ModuleNodeCompile node, it is useful for+-- --make mode.+summariseModule :: HscEnv+                -> HomeUnit+                -> M.Map (UnitId, FilePath) ModSummary+                -> IsBootInterface+                -> Located ModuleName+                -> PkgQual+                -> Maybe (StringBuffer, UTCTime)+                -> [ModuleName]+                -> IO SummariseResult+summariseModule hsc_env home_unit old_summaries is_boot wanted_mod mb_pkg maybe_buf excl_mods =+  summariseModuleDispatch k hsc_env home_unit is_boot wanted_mod mb_pkg excl_mods+  where+    k = summariseModuleWithSource home_unit old_summaries is_boot maybe_buf+++-- | Like summariseModule but for interface files that we don't want to compile.+-- This version always returns a ModuleNodeFixed node.+summariseModuleInterface :: HscEnv+                        -> HomeUnit+                        -> IsBootInterface+                        -> Located ModuleName+                        -> PkgQual+                        -> [ModuleName]+                        -> IO SummariseResult+summariseModuleInterface hsc_env home_unit is_boot wanted_mod mb_pkg excl_mods =+  summariseModuleDispatch k hsc_env home_unit is_boot wanted_mod mb_pkg excl_mods+  where+    k _hsc_env loc mod = do+      -- The finder will return a path to the .hi-boot even if it doesn't actually+      -- exist. So check if it exists first before concluding it's there.+      does_exist <- doesFileExist (ml_hi_file loc)+      if does_exist+        then let key = moduleToMnk mod is_boot+             in return $ FoundHome (ModuleNodeFixed key loc)+        else return NotThere++++-- Summarise a module, and pick up source and timestamp.+summariseModuleDispatch+          :: (HscEnv -> ModLocation -> Module -> IO SummariseResult) -- ^ Continuation about how to summarise a home module.+          -> HscEnv+          -> HomeUnit+          -> IsBootInterface    -- True <=> a {-# SOURCE #-} import+          -> Located ModuleName -- Imported module to be summarised+          -> PkgQual+          -> [ModuleName]               -- Modules to exclude+          -> IO SummariseResult+++summariseModuleDispatch k hsc_env' home_unit is_boot (L _ wanted_mod) mb_pkg excl_mods+  | wanted_mod `elem` excl_mods+  = return NotThere+  | otherwise  = find_it+  where+    -- Temporarily change the currently active home unit so all operations+    -- happen relative to it+    hsc_env   = hscSetActiveHomeUnit home_unit hsc_env'++    find_it :: IO SummariseResult++    find_it = do+        found <- findImportedModuleWithIsBoot hsc_env wanted_mod is_boot mb_pkg+        case found of+             Found location mod+                | moduleUnitId mod `Set.member` hsc_all_home_unit_ids hsc_env ->+                        -- Home package+                         k hsc_env location mod+                | VirtUnit iud <- moduleUnit mod+                , not (isHomeModule home_unit mod)+                  -> return $ FoundInstantiation iud+                | otherwise -> return $ External (moduleUnitId mod)+             _ -> return NotThere+                        -- Not found+                        -- (If it is TRULY not found at all, we'll+                        -- error when we actually try to compile)+++-- | The continuation to summarise a home module if we want to find the source file+-- for it and potentially compile it.+summariseModuleWithSource+          :: HomeUnit+          -> M.Map (UnitId, FilePath) ModSummary+          -- ^ Map of old summaries+          -> IsBootInterface    -- True <=> a {-# SOURCE #-} import+          -> Maybe (StringBuffer, UTCTime)+          -> HscEnv+          -> ModLocation+          -> Module+          -> IO SummariseResult+summariseModuleWithSource home_unit old_summary_map is_boot maybe_buf hsc_env location mod = do+        -- Adjust location to point to the hs-boot source file,+        -- hi file, object file, when is_boot says so+        let src_fn = expectJust (ml_hs_file location)++                -- Check that it exists+                -- It might have been deleted since the Finder last found it+        maybe_h <- fileHashIfExists src_fn+        case maybe_h of+          -- This situation can also happen if we have found the .hs file but the+          -- .hs-boot file doesn't exist.+          Nothing -> return NotThere+          Just h  -> do+            fresult <- new_summary_cache_check location mod src_fn h+            return $ case fresult of+              Left err -> FoundHomeWithError (moduleUnitId mod, err)+              Right ms -> FoundHome (ModuleNodeCompile ms)++  where+    dflags    = hsc_dflags hsc_env+    new_summary_cache_check loc mod src_fn h+      | Just old_summary <- Map.lookup ((toUnitId (moduleUnit mod), src_fn)) old_summary_map =++         -- check the hash on the source file, and+         -- return the cached summary if it hasn't changed.  If the+         -- file has changed then need to resummarise.+        case maybe_buf of+           Just (buf,_) ->+               checkSummaryHash hsc_env (new_summary loc mod src_fn) old_summary loc (fingerprintStringBuffer buf)+           Nothing    ->+               checkSummaryHash hsc_env (new_summary loc mod src_fn) old_summary loc h+      | otherwise = new_summary loc mod src_fn h++    new_summary :: ModLocation+                  -> Module+                  -> FilePath+                  -> Fingerprint+                  -> IO (Either DriverMessages ModSummary)+    new_summary location mod src_fn src_hash+      = runExceptT $ do+        preimps@PreprocessedImports {..}+            -- Remember to set the active unit here, otherwise the wrong include paths are passed to CPP+            -- See multiHomeUnits_cpp2 test+            <- getPreprocessedImports (hscSetActiveUnitId (moduleUnitId mod) hsc_env) src_fn Nothing maybe_buf++        -- NB: Despite the fact that is_boot is a top-level parameter, we+        -- don't actually know coming into this function what the HscSource+        -- of the module in question is.  This is because we may be processing+        -- this module because another module in the graph imported it: in this+        -- case, we know if it's a boot or not because of the {-# SOURCE #-}+        -- annotation, but we don't know if it's a signature or a regular+        -- module until we actually look it up on the filesystem.+        let hsc_src+              | is_boot == IsBoot           = HsBootFile+              | isHaskellSigFilename src_fn = HsigFile+              | otherwise                   = HsSrcFile++        when (pi_mod_name /= moduleName mod) $+                throwE $ singleMessage $ mkPlainErrorMsgEnvelope pi_mod_name_loc+                       $ DriverFileModuleNameMismatch pi_mod_name (moduleName mod)++        let instantiations = homeUnitInstantiations home_unit+        when (hsc_src == HsigFile && isNothing (lookup pi_mod_name instantiations)) $+            throwE $ singleMessage $ mkPlainErrorMsgEnvelope pi_mod_name_loc+                   $ DriverUnexpectedSignature pi_mod_name (checkBuildingCabalPackage dflags) instantiations++        liftIO $ makeNewModSummary hsc_env $ MakeNewModSummary+            { nms_src_fn = src_fn+            , nms_src_hash = src_hash+            , nms_hsc_src = hsc_src+            , nms_location = location+            , nms_mod = mod+            , nms_preimps = preimps+            }++-- | Convenience named arguments for 'makeNewModSummary' only used to make+-- code more readable, not exported.+data MakeNewModSummary+  = MakeNewModSummary+      { nms_src_fn :: FilePath+      , nms_src_hash :: Fingerprint+      , nms_hsc_src :: HscSource+      , nms_location :: ModLocation+      , nms_mod :: Module+      , nms_preimps :: PreprocessedImports+      }++makeNewModSummary :: HscEnv -> MakeNewModSummary -> IO ModSummary+makeNewModSummary hsc_env MakeNewModSummary{..} = do+  let PreprocessedImports{..} = nms_preimps+  obj_timestamp <- modificationTimeIfExists (ml_obj_file nms_location)+  dyn_obj_timestamp <- modificationTimeIfExists (ml_dyn_obj_file nms_location)+  hi_timestamp <- modificationTimeIfExists (ml_hi_file nms_location)+  hie_timestamp <- modificationTimeIfExists (ml_hie_file nms_location)++  extra_sig_imports <- findExtraSigImports hsc_env nms_hsc_src pi_mod_name+  (implicit_sigs, _inst_deps) <- implicitRequirementsShallow (hscSetActiveUnitId (moduleUnitId nms_mod) hsc_env) pi_theimps++  return $+        ModSummary+        { ms_mod = nms_mod+        , ms_hsc_src = nms_hsc_src+        , ms_location = nms_location+        , ms_hspp_file = pi_hspp_fn+        , ms_hspp_opts = pi_local_dflags+        , ms_hspp_buf  = Just pi_hspp_buf+        , ms_parsed_mod = Nothing+        , ms_srcimps = pi_srcimps+        , ms_textual_imps =+            ((,,) NormalLevel NoPkgQual . noLoc <$> extra_sig_imports) +++            ((,,) NormalLevel NoPkgQual . noLoc <$> implicit_sigs) +++            pi_theimps+        , ms_hs_hash = nms_src_hash+        , ms_iface_date = hi_timestamp+        , ms_hie_date = hie_timestamp+        , ms_obj_date = obj_timestamp+        , ms_dyn_obj_date = dyn_obj_timestamp+        }++data PreprocessedImports+  = PreprocessedImports+      { pi_local_dflags :: DynFlags+      , pi_srcimps  :: [Located ModuleName]+      , pi_theimps  :: [(ImportLevel, PkgQual, Located ModuleName)]+      , pi_hspp_fn  :: FilePath+      , pi_hspp_buf :: StringBuffer+      , pi_mod_name_loc :: SrcSpan+      , pi_mod_name :: ModuleName+      }++-- Preprocess the source file and get its imports+-- The pi_local_dflags contains the OPTIONS pragmas+getPreprocessedImports+    :: HscEnv+    -> FilePath+    -> Maybe Phase+    -> Maybe (StringBuffer, UTCTime)+    -- ^ optional source code buffer and modification time+    -> ExceptT DriverMessages IO PreprocessedImports+getPreprocessedImports hsc_env src_fn mb_phase maybe_buf = do+  (pi_local_dflags, pi_hspp_fn)+      <- ExceptT $ preprocess hsc_env src_fn (fst <$> maybe_buf) mb_phase+  pi_hspp_buf <- liftIO $ hGetStringBuffer pi_hspp_fn+  (pi_srcimps', pi_theimps', L pi_mod_name_loc pi_mod_name)+      <- ExceptT $ do+          let imp_prelude = xopt LangExt.ImplicitPrelude pi_local_dflags+              popts = initParserOpts pi_local_dflags+          mimps <- getImports popts imp_prelude pi_hspp_buf pi_hspp_fn src_fn+          return (first (mkMessages . fmap mkDriverPsHeaderMessage . getMessages) mimps)+  let rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env)+  let rn_imps = fmap (\(sp, pk, lmn@(L _ mn)) -> (sp, rn_pkg_qual mn pk, lmn))+  let pi_srcimps = pi_srcimps'+  let pi_theimps = rn_imps pi_theimps'+  return PreprocessedImports {..}
+ GHC/Driver/DynFlags.hs view
@@ -0,0 +1,1581 @@+{-# LANGUAGE LambdaCase #-}+module GHC.Driver.DynFlags (+        -- * Dynamic flags and associated configuration types+        DumpFlag(..),+        GeneralFlag(..),+        WarningFlag(..), DiagnosticReason(..),+        Language(..),+        FatalMessager, FlushOut(..),+        ProfAuto(..),+        hasPprDebug, hasNoDebugOutput, hasNoStateHack, hasNoOptCoercion,+        dopt, dopt_set, dopt_unset,+        gopt, gopt_set, gopt_unset,+        wopt, wopt_set, wopt_unset,+        wopt_fatal, wopt_set_fatal, wopt_unset_fatal,+        wopt_set_all_custom, wopt_unset_all_custom,+        wopt_set_all_fatal_custom, wopt_unset_all_fatal_custom,+        wopt_set_custom, wopt_unset_custom,+        wopt_set_fatal_custom, wopt_unset_fatal_custom,+        wopt_any_custom,+        xopt, xopt_set, xopt_unset,+        xopt_set_unlessExplSpec,+        xopt_DuplicateRecordFields,+        xopt_FieldSelectors,+        lang_set,+        DynamicTooState(..), dynamicTooState, setDynamicNow,+        OnOff(..),+        DynFlags(..),+        ParMakeCount(..),+        ways,+        HasDynFlags(..), ContainsDynFlags(..),+        RtsOptsEnabled(..),+        GhcMode(..), isOneShot,+        GhcLink(..), isNoLink,+        PackageFlag(..), PackageArg(..), ModRenaming(..),+        packageFlagsChanged,+        IgnorePackageFlag(..), TrustFlag(..),+        PackageDBFlag(..), PkgDbRef(..),+        Option(..), showOpt,+        DynLibLoader(..),+        positionIndependent,+        optimisationFlags,++        targetProfile,++        ReexportedModule(..),++        -- ** Manipulating DynFlags+        defaultDynFlags,                -- Settings -> DynFlags+        initDynFlags,                   -- DynFlags -> IO DynFlags+        defaultFatalMessager,+        defaultFlushOut,+        optLevelFlags,+        languageExtensions,++        TurnOnFlag,+        turnOn,+        turnOff,++        -- ** System tool settings and locations+        programName, projectVersion,+        ghcUsagePath, ghciUsagePath, topDir, toolDir,+        versionedAppDir, versionedFilePath,+        extraGccViaCFlags, globalPackageDatabasePath,++        --+        baseUnitId,+++        -- * Include specifications+        IncludeSpecs(..), addGlobalInclude, addQuoteInclude, flattenIncludes,+        addImplicitQuoteInclude,++        -- * SDoc+        initSDocContext, initDefaultSDocContext,+        initPromotionTickContext,++        -- * Platform features+        isSse3Enabled,+        isSsse3Enabled,+        isSse4_1Enabled,+        isSse4_2Enabled,+        isAvxEnabled,+        isAvx2Enabled,+        isAvx512cdEnabled,+        isAvx512erEnabled,+        isAvx512fEnabled,+        isAvx512pfEnabled,+        isFmaEnabled,+        isBmiEnabled,+        isBmi2Enabled+) where++import GHC.Prelude++import GHC.Platform+import GHC.Platform.Ways+import GHC.Platform.Profile++import GHC.CmmToAsm.CFG.Weight+import GHC.Core.Unfold+import GHC.Data.Bool+import GHC.Data.EnumSet (EnumSet)+import GHC.Data.Maybe+import GHC.Builtin.Names ( mAIN_NAME )+import GHC.Driver.Backend+import GHC.Driver.Flags+import GHC.Driver.IncludeSpecs+import GHC.Driver.Phases ( Phase(..), phaseInputExt )+import GHC.Driver.Plugins.External+import GHC.Settings+import GHC.Settings.Constants+import GHC.Types.Basic ( IntWithInf, treatZeroAsInf )+import GHC.Types.Error (DiagnosticReason(..))+import GHC.Types.ProfAuto+import GHC.Types.SafeHaskell+import GHC.Types.SrcLoc+import GHC.Unit.Module+import GHC.Unit.Module.Warnings+import GHC.Utils.CliOption+import GHC.SysTools.Terminal ( stderrSupportsAnsiColors )+import GHC.UniqueSubdir (uniqueSubdir)+import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Utils.TmpFs++import qualified GHC.Types.FieldLabel as FieldLabel+import qualified GHC.Utils.Ppr.Colour as Col+import qualified GHC.Data.EnumSet as EnumSet++import GHC.Core.Opt.CallerCC.Types++import Control.Monad (msum, (<=<))+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Except (ExceptT)+import Control.Monad.Trans.Reader (ReaderT)+import Control.Monad.Trans.Writer (WriterT)+import Data.Word+import System.IO+import System.IO.Error (catchIOError)+import System.Environment (lookupEnv)+import System.FilePath (normalise, (</>))+import System.Directory+import GHC.Foreign (withCString, peekCString)++import qualified Data.Set as Set++import qualified GHC.LanguageExtensions as LangExt++-- -----------------------------------------------------------------------------+-- DynFlags++-- | Contains not only a collection of 'GeneralFlag's but also a plethora of+-- information relating to the compilation of a single file or GHC session+data DynFlags = DynFlags {+  ghcMode               :: GhcMode,+  ghcLink               :: GhcLink,+  backend               :: !Backend,+   -- ^ The backend to use (if any).+   --+   -- Whenever you change the backend, also make sure to set 'ghcLink' to+   -- something sensible.+   --+   -- 'NoBackend' can be used to avoid generating any output, however, note that:+   --+   --  * If a program uses Template Haskell the typechecker may need to run code+   --    from an imported module.  To facilitate this, code generation is enabled+   --    for modules imported by modules that use template haskell, using the+   --    default backend for the platform.+   --    See Note [-fno-code mode].+++  -- formerly Settings+  ghcNameVersion    :: {-# UNPACK #-} !GhcNameVersion,+  fileSettings      :: {-# UNPACK #-} !FileSettings,+  unitSettings      :: {-# UNPACK #-} !UnitSettings,++  targetPlatform    :: Platform,       -- Filled in by SysTools+  toolSettings      :: {-# UNPACK #-} !ToolSettings,+  platformMisc      :: {-# UNPACK #-} !PlatformMisc,+  rawSettings       :: [(String, String)],+  tmpDir            :: TempDir,++  llvmOptLevel          :: Int,         -- ^ LLVM optimisation level+  verbosity             :: Int,         -- ^ Verbosity level: see Note [Verbosity levels]+  debugLevel            :: Int,         -- ^ How much debug information to produce+  simplPhases           :: Int,         -- ^ Number of simplifier phases+  maxSimplIterations    :: Int,         -- ^ Max simplifier iterations+  ruleCheck             :: Maybe String,+  strictnessBefore      :: [Int],       -- ^ Additional demand analysis++  parMakeCount          :: Maybe ParMakeCount,+    -- ^ The number of modules to compile in parallel+    --   If unspecified, compile with a single job.++  enableTimeStats       :: Bool,        -- ^ Enable RTS timing statistics?+  ghcHeapSize           :: Maybe Int,   -- ^ The heap size to set.++  maxRelevantBinds      :: Maybe Int,   -- ^ Maximum number of bindings from the type envt+                                        --   to show in type error messages+  maxValidHoleFits      :: Maybe Int,   -- ^ Maximum number of hole fits to show+                                        --   in typed hole error messages+  maxRefHoleFits        :: Maybe Int,   -- ^ Maximum number of refinement hole+                                        --   fits to show in typed hole error+                                        --   messages+  refLevelHoleFits      :: Maybe Int,   -- ^ Maximum level of refinement for+                                        --   refinement hole fits in typed hole+                                        --   error messages+  maxUncoveredPatterns  :: Int,         -- ^ Maximum number of unmatched patterns to show+                                        --   in non-exhaustiveness warnings+  maxPmCheckModels      :: Int,         -- ^ Soft limit on the number of models+                                        --   the pattern match checker checks+                                        --   a pattern against. A safe guard+                                        --   against exponential blow-up.+  simplTickFactor       :: Int,         -- ^ Multiplier for simplifier ticks+  dmdUnboxWidth         :: !Int,        -- ^ Whether DmdAnal should optimistically put an+                                        --   Unboxed demand on returned products with at most+                                        --   this number of fields+  ifCompression         :: Int,+  specConstrThreshold   :: Maybe Int,   -- ^ Threshold for SpecConstr+  specConstrCount       :: Maybe Int,   -- ^ Max number of specialisations for any one function+  specConstrRecursive   :: Int,         -- ^ Max number of specialisations for recursive types+                                        --   Not optional; otherwise ForceSpecConstr can diverge.+  binBlobThreshold      :: Maybe Word,  -- ^ Binary literals (e.g. strings) whose size is above+                                        --   this threshold will be dumped in a binary file+                                        --   by the assembler code generator. 0 and Nothing disables+                                        --   this feature. See 'GHC.StgToCmm.Config'.+  liberateCaseThreshold :: Maybe Int,   -- ^ Threshold for LiberateCase+  floatLamArgs          :: Maybe Int,   -- ^ Arg count for lambda floating+                                        --   See 'GHC.Core.Opt.Monad.FloatOutSwitches'++  liftLamsRecArgs       :: Maybe Int,   -- ^ Maximum number of arguments after lambda lifting a+                                        --   recursive function.+  liftLamsNonRecArgs    :: Maybe Int,   -- ^ Maximum number of arguments after lambda lifting a+                                        --   non-recursive function.+  liftLamsKnown         :: Bool,        -- ^ Lambda lift even when this turns a known call+                                        --   into an unknown call.++  cmmProcAlignment      :: Maybe Int,   -- ^ Align Cmm functions at this boundary or use default.++  historySize           :: Int,         -- ^ Simplification history size++  importPaths           :: [FilePath],+  mainModuleNameIs      :: ModuleName,+  mainFunIs             :: Maybe String,+  reductionDepth        :: IntWithInf,   -- ^ Typechecker maximum stack depth+  solverIterations      :: IntWithInf,   -- ^ Number of iterations in the constraints solver+                                         --   Typically only 1 is needed+  givensFuel            :: Int,          -- ^ Number of layers of superclass expansion for givens+                                         --   Should be < solverIterations+                                         --   See Note [Expanding Recursive Superclasses and ExpansionFuel]+  wantedsFuel           :: Int,          -- ^ Number of layers of superclass expansion for wanteds+                                         --   Should be < givensFuel+                                         --   See Note [Expanding Recursive Superclasses and ExpansionFuel]+  qcsFuel                :: Int,          -- ^ Number of layers of superclass expansion for quantified constraints+                                         --   Should be < givensFuel+                                         --   See Note [Expanding Recursive Superclasses and ExpansionFuel]+  homeUnitId_             :: UnitId,                 -- ^ Target home unit-id+  homeUnitInstanceOf_     :: Maybe UnitId,           -- ^ Id of the unit to instantiate+  homeUnitInstantiations_ :: [(ModuleName, Module)], -- ^ Module instantiations++  -- Note [Filepaths and Multiple Home Units]+  workingDirectory      :: Maybe FilePath,+  thisPackageName       :: Maybe String, -- ^ What the package is called, use with multiple home units+  hiddenModules         :: Set.Set ModuleName,+  reexportedModules     :: [ReexportedModule],++  -- ways+  targetWays_           :: Ways,         -- ^ Target way flags from the command line++  -- For object splitting+  splitInfo             :: Maybe (String,Int),++  -- paths etc.+  objectDir             :: Maybe String,+  dylibInstallName      :: Maybe String,+  hiDir                 :: Maybe String,+  hieDir                :: Maybe String,+  stubDir               :: Maybe String,+  dumpDir               :: Maybe String,++  objectSuf_            :: String,+  hcSuf                 :: String,+  hiSuf_                :: String,+  hieSuf                :: String,++  dynObjectSuf_         :: String,+  dynHiSuf_             :: String,++  outputFile_           :: Maybe String,+  dynOutputFile_        :: Maybe String,+  outputHi              :: Maybe String,+  dynOutputHi           :: Maybe String,+  dynLibLoader          :: DynLibLoader,++  dynamicNow            :: !Bool, -- ^ Indicate if we are now generating dynamic output+                                  -- because of -dynamic-too. This predicate is+                                  -- used to query the appropriate fields+                                  -- (outputFile/dynOutputFile, ways, etc.)++  -- | This defaults to 'non-module'. It can be set by+  -- 'GHC.Driver.Pipeline.setDumpPrefix' or 'ghc.GHCi.UI.runStmt' based on+  -- where its output is going.+  dumpPrefix            :: FilePath,++  -- | Override the 'dumpPrefix' set by 'GHC.Driver.Pipeline.setDumpPrefix'+  --    or 'ghc.GHCi.UI.runStmt'.+  --    Set by @-ddump-file-prefix@+  dumpPrefixForce       :: Maybe FilePath,++  ldInputs              :: [Option],++  includePaths          :: IncludeSpecs,+  libraryPaths          :: [String],+  frameworkPaths        :: [String],    -- used on darwin only+  cmdlineFrameworks     :: [String],    -- ditto++  rtsOpts               :: Maybe String,+  rtsOptsEnabled        :: RtsOptsEnabled,+  rtsOptsSuggestions    :: Bool,++  hpcDir                :: String,      -- ^ Path to store the .mix files++  -- Plugins+  pluginModNames        :: [ModuleName],+    -- ^ the @-fplugin@ flags given on the command line, in *reverse*+    -- order that they're specified on the command line.+  pluginModNameOpts     :: [(ModuleName,String)],+  frontendPluginOpts    :: [String],+    -- ^ the @-ffrontend-opt@ flags given on the command line, in *reverse*+    -- order that they're specified on the command line.++  externalPluginSpecs   :: [ExternalPluginSpec],+    -- ^ External plugins loaded from shared libraries++  --  For ghc -M+  depMakefile           :: FilePath,+  depIncludePkgDeps     :: Bool,+  depIncludeCppDeps     :: Bool,+  depExcludeMods        :: [ModuleName],+  depSuffixes           :: [String],++  --  Package flags+  packageDBFlags        :: [PackageDBFlag],+        -- ^ The @-package-db@ flags given on the command line, In+        -- *reverse* order that they're specified on the command line.+        -- This is intended to be applied with the list of "initial"+        -- package databases derived from @GHC_PACKAGE_PATH@; see+        -- 'getUnitDbRefs'.++  ignorePackageFlags    :: [IgnorePackageFlag],+        -- ^ The @-ignore-package@ flags from the command line.+        -- In *reverse* order that they're specified on the command line.+  packageFlags          :: [PackageFlag],+        -- ^ The @-package@ and @-hide-package@ flags from the command-line.+        -- In *reverse* order that they're specified on the command line.+  pluginPackageFlags    :: [PackageFlag],+        -- ^ The @-plugin-package-id@ flags from command line.+        -- In *reverse* order that they're specified on the command line.+  trustFlags            :: [TrustFlag],+        -- ^ The @-trust@ and @-distrust@ flags.+        -- In *reverse* order that they're specified on the command line.+  packageEnv            :: Maybe FilePath,+        -- ^ Filepath to the package environment file (if overriding default)+++  -- hsc dynamic flags+  dumpFlags             :: EnumSet DumpFlag,+  generalFlags          :: EnumSet GeneralFlag,+  warningFlags          :: EnumSet WarningFlag,+  fatalWarningFlags     :: EnumSet WarningFlag,+  customWarningCategories      :: WarningCategorySet, -- See Note [Warning categories]+  fatalCustomWarningCategories :: WarningCategorySet, -- in GHC.Unit.Module.Warnings+  -- Don't change this without updating extensionFlags:+  language              :: Maybe Language,+  -- | Safe Haskell mode+  safeHaskell           :: SafeHaskellMode,+  safeInfer             :: Bool,+  safeInferred          :: Bool,+  -- We store the location of where some extension and flags were turned on so+  -- we can produce accurate error messages when Safe Haskell fails due to+  -- them.+  thOnLoc               :: SrcSpan,+  newDerivOnLoc         :: SrcSpan,+  deriveViaOnLoc        :: SrcSpan,+  overlapInstLoc        :: SrcSpan,+  incoherentOnLoc       :: SrcSpan,+  pkgTrustOnLoc         :: SrcSpan,+  warnSafeOnLoc         :: SrcSpan,+  warnUnsafeOnLoc       :: SrcSpan,+  trustworthyOnLoc      :: SrcSpan,+  -- Don't change this without updating extensionFlags:+  -- Here we collect the settings of the language extensions+  -- from the command line, the ghci config file and+  -- from interactive :set / :seti commands.+  extensions            :: [OnOff LangExt.Extension],+  -- extensionFlags should always be equal to+  --     flattenExtensionFlags language extensions+  -- LangExt.Extension is defined in libraries/ghc-boot so that it can be used+  -- by template-haskell+  extensionFlags        :: EnumSet LangExt.Extension,++  -- | Unfolding control+  -- See Note [Discounts and thresholds] in GHC.Core.Unfold+  unfoldingOpts         :: !UnfoldingOpts,++  maxWorkerArgs         :: Int,+  maxForcedSpecArgs     :: Int,++  ghciHistSize          :: Int,++  -- wasm ghci browser mode+  ghciBrowserHost                  :: !String,+  ghciBrowserPort                  :: !Int,+  ghciBrowserPuppeteerLaunchOpts   :: !(Maybe String),+  ghciBrowserPlaywrightBrowserType :: !(Maybe String),+  ghciBrowserPlaywrightLaunchOpts  :: !(Maybe String),++  flushOut              :: FlushOut,++  ghcVersionFile        :: Maybe FilePath,+  haddockOptions        :: Maybe String,++  -- | GHCi scripts specified by -ghci-script, in reverse order+  ghciScripts           :: [String],++  -- Output style options+  pprUserLength         :: Int,+  pprCols               :: Int,++  useUnicode            :: Bool,+  useColor              :: OverridingBool,+  canUseColor           :: Bool,+  useErrorLinks         :: OverridingBool,+  canUseErrorLinks      :: Bool,+  colScheme             :: Col.Scheme,++  -- | what kind of {-# SCC #-} to add automatically+  profAuto              :: ProfAuto,+  callerCcFilters       :: [CallerCcFilter],++  interactivePrint      :: Maybe String,++  -- | Machine dependent flags (-m\<blah> stuff)+  sseVersion            :: Maybe SseVersion,+  bmiVersion            :: Maybe BmiVersion,+  avx                   :: Bool,+  avx2                  :: Bool,+  avx512cd              :: Bool, -- Enable AVX-512 Conflict Detection Instructions.+  avx512er              :: Bool, -- Enable AVX-512 Exponential and Reciprocal Instructions.+  avx512f               :: Bool, -- Enable AVX-512 instructions.+  avx512pf              :: Bool, -- Enable AVX-512 PreFetch Instructions.+  fma                   :: Bool, -- ^ Enable FMA instructions.++  -- Constants used to control the amount of optimization done.++  -- | Max size, in bytes, of inline array allocations.+  maxInlineAllocSize    :: Int,++  -- | Only inline memcpy if it generates no more than this many+  -- pseudo (roughly: Cmm) instructions.+  maxInlineMemcpyInsns  :: Int,++  -- | Only inline memset if it generates no more than this many+  -- pseudo (roughly: Cmm) instructions.+  maxInlineMemsetInsns  :: Int,++  -- | Reverse the order of error messages in GHC/GHCi+  reverseErrors         :: Bool,++  -- | Limit the maximum number of errors to show+  maxErrors             :: Maybe Int,++  -- | Unique supply configuration for testing build determinism+  initialUnique         :: Word64,+  uniqueIncrement       :: Int,+    -- 'Int' because it can be used to test uniques in decreasing order.++  -- | Temporary: CFG Edge weights for fast iterations+  cfgWeights            :: Weights+}++class HasDynFlags m where+    getDynFlags :: m DynFlags++{- It would be desirable to have the more generalised++  instance (MonadTrans t, Monad m, HasDynFlags m) => HasDynFlags (t m) where+      getDynFlags = lift getDynFlags++instance definition. However, that definition would overlap with the+`HasDynFlags (GhcT m)` instance. Instead we define instances for a+couple of common Monad transformers explicitly. -}++instance (Monoid a, Monad m, HasDynFlags m) => HasDynFlags (WriterT a m) where+    getDynFlags = lift getDynFlags++instance (Monad m, HasDynFlags m) => HasDynFlags (ReaderT a m) where+    getDynFlags = lift getDynFlags++instance (Monad m, HasDynFlags m) => HasDynFlags (MaybeT m) where+    getDynFlags = lift getDynFlags++instance (Monad m, HasDynFlags m) => HasDynFlags (ExceptT e m) where+    getDynFlags = lift getDynFlags++class ContainsDynFlags t where+    extractDynFlags :: t -> DynFlags++-----------------------------------------------------------------------------++-- | Used by 'GHC.runGhc' to partially initialize a new 'DynFlags' value+initDynFlags :: DynFlags -> IO DynFlags+initDynFlags dflags = do+ let+ -- This is not bulletproof: we test that 'localeEncoding' is Unicode-capable,+ -- but potentially 'hGetEncoding' 'stdout' might be different. Still good enough.+ canUseUnicode <- do let enc = localeEncoding+                         str = "‘’"+                     (withCString enc str $ \cstr ->+                          do str' <- peekCString enc cstr+                             return (str == str'))+                         `catchIOError` \_ -> return False+ ghcNoUnicodeEnv <- lookupEnv "GHC_NO_UNICODE"+ let useUnicode' = isNothing ghcNoUnicodeEnv && canUseUnicode+ maybeGhcColorsEnv  <- lookupEnv "GHC_COLORS"+ maybeGhcColoursEnv <- lookupEnv "GHC_COLOURS"+ let adjustCols (Just env) = Col.parseScheme env+     adjustCols Nothing    = id+ let (useColor', colScheme') =+       (adjustCols maybeGhcColoursEnv . adjustCols maybeGhcColorsEnv)+       (useColor dflags, colScheme dflags)+ tmp_dir <- normalise <$> getTemporaryDirectory+ return dflags{+        useUnicode    = useUnicode',+        useColor      = useColor',+        canUseColor   = stderrSupportsAnsiColors,+        -- if the terminal supports color, we assume it supports links as well+        canUseErrorLinks = stderrSupportsAnsiColors,+        colScheme     = colScheme',+        tmpDir        = TempDir tmp_dir+        }++-- | The normal 'DynFlags'. Note that they are not suitable for use in this form+-- and must be fully initialized by 'GHC.runGhc' first.+defaultDynFlags :: Settings -> DynFlags+defaultDynFlags mySettings =+-- See Note [Updating flag description in the User's Guide]+     DynFlags {+        ghcMode                 = CompManager,+        ghcLink                 = LinkBinary,+        backend                 = platformDefaultBackend (sTargetPlatform mySettings),+        verbosity               = 0,+        debugLevel              = 0,+        simplPhases             = 2,+        maxSimplIterations      = 4,+        ruleCheck               = Nothing,+        binBlobThreshold        = Just 500000, -- 500K is a good default (see #16190)+        maxRelevantBinds        = Just 6,+        maxValidHoleFits   = Just 6,+        maxRefHoleFits     = Just 6,+        refLevelHoleFits   = Nothing,+        maxUncoveredPatterns    = 4,+        maxPmCheckModels        = 30,+        simplTickFactor         = 100,+        dmdUnboxWidth           = 3,      -- Default: Assume an unboxed demand on function bodies returning a triple+        ifCompression           = 2,      -- Default: Apply safe compressions+        specConstrThreshold     = Just 2000,+        specConstrCount         = Just 3,+        specConstrRecursive     = 3,+        liberateCaseThreshold   = Just 2000,+        floatLamArgs            = Just 0, -- Default: float only if no fvs+        liftLamsRecArgs         = Just 5, -- Default: the number of available argument hardware registers on x86_64+        liftLamsNonRecArgs      = Just 5, -- Default: the number of available argument hardware registers on x86_64+        liftLamsKnown           = False,  -- Default: don't turn known calls into unknown ones+        cmmProcAlignment        = Nothing,++        historySize             = 20,+        strictnessBefore        = [],++        parMakeCount            = Nothing,++        enableTimeStats         = False,+        ghcHeapSize             = Nothing,++        importPaths             = ["."],+        mainModuleNameIs        = mAIN_NAME,+        mainFunIs               = Nothing,+        reductionDepth          = treatZeroAsInf mAX_REDUCTION_DEPTH,+        solverIterations        = treatZeroAsInf mAX_SOLVER_ITERATIONS,+        givensFuel              = mAX_GIVENS_FUEL,+        wantedsFuel             = mAX_WANTEDS_FUEL,+        qcsFuel                 = mAX_QC_FUEL,++        homeUnitId_             = mainUnitId,+        homeUnitInstanceOf_     = Nothing,+        homeUnitInstantiations_ = [],++        workingDirectory        = Nothing,+        thisPackageName         = Nothing,+        hiddenModules           = Set.empty,+        reexportedModules       = [],++        objectDir               = Nothing,+        dylibInstallName        = Nothing,+        hiDir                   = Nothing,+        hieDir                  = Nothing,+        stubDir                 = Nothing,+        dumpDir                 = Nothing,++        objectSuf_              = phaseInputExt StopLn,+        hcSuf                   = phaseInputExt HCc,+        hiSuf_                  = "hi",+        hieSuf                  = "hie",++        dynObjectSuf_           = "dyn_" ++ phaseInputExt StopLn,+        dynHiSuf_               = "dyn_hi",+        dynamicNow              = False,++        pluginModNames          = [],+        pluginModNameOpts       = [],+        frontendPluginOpts      = [],++        externalPluginSpecs     = [],++        outputFile_             = Nothing,+        dynOutputFile_          = Nothing,+        outputHi                = Nothing,+        dynOutputHi             = Nothing,+        dynLibLoader            = SystemDependent,+        dumpPrefix              = "non-module.",+        dumpPrefixForce         = Nothing,+        ldInputs                = [],+        includePaths            = IncludeSpecs [] [] [],+        libraryPaths            = [],+        frameworkPaths          = [],+        cmdlineFrameworks       = [],+        rtsOpts                 = Nothing,+        rtsOptsEnabled          = RtsOptsSafeOnly,+        rtsOptsSuggestions      = True,++        hpcDir                  = ".hpc",++        packageDBFlags          = [],+        packageFlags            = [],+        pluginPackageFlags      = [],+        ignorePackageFlags      = [],+        trustFlags              = [],+        packageEnv              = Nothing,+        targetWays_             = Set.empty,+        splitInfo               = Nothing,++        ghcNameVersion = sGhcNameVersion mySettings,+        unitSettings   = sUnitSettings mySettings,+        fileSettings = sFileSettings mySettings,+        toolSettings = sToolSettings mySettings,+        targetPlatform = sTargetPlatform mySettings,+        platformMisc = sPlatformMisc mySettings,+        rawSettings = sRawSettings mySettings,++        tmpDir                  = panic "defaultDynFlags: uninitialized tmpDir",++        llvmOptLevel            = 0,++        -- ghc -M values+        depMakefile       = "Makefile",+        depIncludePkgDeps = False,+        depIncludeCppDeps = False,+        depExcludeMods    = [],+        depSuffixes       = [],+        -- end of ghc -M values+        ghcVersionFile = Nothing,+        haddockOptions = Nothing,+        dumpFlags = EnumSet.empty,+        generalFlags = EnumSet.fromList (defaultFlags mySettings),+        warningFlags = EnumSet.fromList standardWarnings,+        fatalWarningFlags = EnumSet.empty,+        customWarningCategories = completeWarningCategorySet,+        fatalCustomWarningCategories = emptyWarningCategorySet,+        ghciScripts = [],+        language = Nothing,+        safeHaskell = Sf_None,+        safeInfer   = True,+        safeInferred = True,+        thOnLoc = noSrcSpan,+        newDerivOnLoc = noSrcSpan,+        deriveViaOnLoc = noSrcSpan,+        overlapInstLoc = noSrcSpan,+        incoherentOnLoc = noSrcSpan,+        pkgTrustOnLoc = noSrcSpan,+        warnSafeOnLoc = noSrcSpan,+        warnUnsafeOnLoc = noSrcSpan,+        trustworthyOnLoc = noSrcSpan,+        extensions = [],+        extensionFlags = flattenExtensionFlags Nothing [],++        unfoldingOpts = defaultUnfoldingOpts,+        maxWorkerArgs = 10,+        maxForcedSpecArgs = 333,+        -- 333 is fairly arbitrary, see Note [Forcing specialisation]:FS5++        ghciHistSize = 50, -- keep a log of length 50 by default++        ghciBrowserHost = "127.0.0.1",+        ghciBrowserPort = 0,+        ghciBrowserPuppeteerLaunchOpts = Nothing,+        ghciBrowserPlaywrightBrowserType = Nothing,+        ghciBrowserPlaywrightLaunchOpts = Nothing,++        flushOut = defaultFlushOut,+        pprUserLength = 5,+        pprCols = 100,+        useUnicode = False,+        useColor = Auto,+        canUseColor = False,+        useErrorLinks = Auto,+        canUseErrorLinks = False,+        colScheme = Col.defaultScheme,+        profAuto = NoProfAuto,+        callerCcFilters = [],+        interactivePrint = Nothing,+        sseVersion = Nothing,+        bmiVersion = Nothing,+        avx = False,+        avx2 = False,+        avx512cd = False,+        avx512er = False,+        avx512f = False,+        avx512pf = False,+        -- Use FMA by default on AArch64+        fma = (platformArch . sTargetPlatform $ mySettings) == ArchAArch64,++        maxInlineAllocSize = 128,+        maxInlineMemcpyInsns = 32,+        maxInlineMemsetInsns = 32,++        initialUnique = 0,+        uniqueIncrement = 1,++        reverseErrors = False,+        maxErrors     = Nothing,+        cfgWeights    = defaultWeights+      }++type FatalMessager = String -> IO ()++defaultFatalMessager :: FatalMessager+defaultFatalMessager = hPutStrLn stderr+++newtype FlushOut = FlushOut (IO ())++defaultFlushOut :: FlushOut+defaultFlushOut = FlushOut $ hFlush stdout++-- OnOffs accumulate in reverse order, so we use foldr in order to+-- process them in the right order+flattenExtensionFlags :: Maybe Language -> [OnOff LangExt.Extension] -> EnumSet LangExt.Extension+flattenExtensionFlags ml = foldr g defaultExtensionFlags+    where g (On f)  flags = EnumSet.insert f flags+          g (Off f) flags = EnumSet.delete f flags+          defaultExtensionFlags = EnumSet.fromList (languageExtensions ml)++-- -----------------------------------------------------------------------------+-- -jN++-- | The type for the -jN argument, specifying that -j on its own represents+-- using the number of machine processors.+data ParMakeCount+  -- | Use this many processors (@-j<n>@ flag).+  = ParMakeThisMany Int+  -- | Use parallelism with as many processors as possible (@-j@ flag without an argument).+  | ParMakeNumProcessors+  -- | Use the specific semaphore @<sem>@ to control parallelism (@-jsem <sem>@ flag).+  | ParMakeSemaphore FilePath++-- | The 'GhcMode' tells us whether we're doing multi-module+-- compilation (controlled via the "GHC" API) or one-shot+-- (single-module) compilation.  This makes a difference primarily to+-- the "GHC.Unit.Finder": in one-shot mode we look for interface files for+-- imported modules, but in multi-module mode we look for source files+-- in order to check whether they need to be recompiled.+data GhcMode+  = CompManager         -- ^ @\-\-make@, GHCi, etc.+  | OneShot             -- ^ @ghc -c Foo.hs@+  | MkDepend            -- ^ @ghc -M@, see "GHC.Unit.Finder" for why we need this+  deriving Eq++instance Outputable GhcMode where+  ppr CompManager = text "CompManager"+  ppr OneShot     = text "OneShot"+  ppr MkDepend    = text "MkDepend"++isOneShot :: GhcMode -> Bool+isOneShot OneShot = True+isOneShot _other  = False++-- | What to do in the link step, if there is one.+data GhcLink+  = NoLink              -- ^ Don't link at all+  | LinkBinary          -- ^ Link object code into a binary+  | LinkInMemory        -- ^ Use the in-memory dynamic linker (works for both+                        --   bytecode and object code).+  | LinkDynLib          -- ^ Link objects into a dynamic lib (DLL on Windows, DSO on ELF platforms)+  | LinkStaticLib       -- ^ Link objects into a static lib+  | LinkMergedObj       -- ^ Link objects into a merged "GHCi object"+  deriving (Eq, Show)++isNoLink :: GhcLink -> Bool+isNoLink NoLink = True+isNoLink _      = False++-- | We accept flags which make packages visible, but how they select+-- the package varies; this data type reflects what selection criterion+-- is used.+data PackageArg =+      PackageArg String    -- ^ @-package@, by 'PackageName'+    | UnitIdArg Unit       -- ^ @-package-id@, by 'Unit'+  deriving (Eq, Show)++instance Outputable PackageArg where+    ppr (PackageArg pn) = text "package" <+> text pn+    ppr (UnitIdArg uid) = text "unit" <+> ppr uid++-- | Represents the renaming that may be associated with an exposed+-- package, e.g. the @rns@ part of @-package "foo (rns)"@.+--+-- Here are some example parsings of the package flags (where+-- a string literal is punned to be a 'ModuleName':+--+--      * @-package foo@ is @ModRenaming True []@+--      * @-package foo ()@ is @ModRenaming False []@+--      * @-package foo (A)@ is @ModRenaming False [("A", "A")]@+--      * @-package foo (A as B)@ is @ModRenaming False [("A", "B")]@+--      * @-package foo with (A as B)@ is @ModRenaming True [("A", "B")]@+data ModRenaming = ModRenaming {+    modRenamingWithImplicit :: Bool, -- ^ Bring all exposed modules into scope?+    modRenamings :: [(ModuleName, ModuleName)] -- ^ Bring module @m@ into scope+                                               --   under name @n@.+  } deriving (Eq)+instance Outputable ModRenaming where+    ppr (ModRenaming b rns) = ppr b <+> parens (ppr rns)++-- | Flags for manipulating the set of non-broken packages.+newtype IgnorePackageFlag = IgnorePackage String -- ^ @-ignore-package@+  deriving (Eq)++-- | Flags for manipulating package trust.+data TrustFlag+  = TrustPackage    String -- ^ @-trust@+  | DistrustPackage String -- ^ @-distrust@+  deriving (Eq)++-- | Flags for manipulating packages visibility.+data PackageFlag+  = ExposePackage   String PackageArg ModRenaming -- ^ @-package@, @-package-id@+  | HidePackage     String -- ^ @-hide-package@+  deriving (Eq) -- NB: equality instance is used by packageFlagsChanged++data PackageDBFlag+  = PackageDB PkgDbRef+  | NoUserPackageDB+  | NoGlobalPackageDB+  | ClearPackageDBs+  deriving (Eq)++packageFlagsChanged :: DynFlags -> DynFlags -> Bool+packageFlagsChanged idflags1 idflags0 =+  packageFlags idflags1 /= packageFlags idflags0 ||+  ignorePackageFlags idflags1 /= ignorePackageFlags idflags0 ||+  pluginPackageFlags idflags1 /= pluginPackageFlags idflags0 ||+  trustFlags idflags1 /= trustFlags idflags0 ||+  packageDBFlags idflags1 /= packageDBFlags idflags0 ||+  packageGFlags idflags1 /= packageGFlags idflags0+ where+   packageGFlags dflags = map (`gopt` dflags)+     [ Opt_HideAllPackages+     , Opt_HideAllPluginPackages+     , Opt_AutoLinkPackages ]++instance Outputable PackageFlag where+    ppr (ExposePackage n arg rn) = text n <> braces (ppr arg <+> ppr rn)+    ppr (HidePackage str) = text "-hide-package" <+> text str++data DynLibLoader+  = Deployable+  | SystemDependent+  deriving Eq++data RtsOptsEnabled+  = RtsOptsNone | RtsOptsIgnore | RtsOptsIgnoreAll | RtsOptsSafeOnly+  | RtsOptsAll+  deriving (Show)++-- | Are we building with @-fPIE@ or @-fPIC@ enabled?+positionIndependent :: DynFlags -> Bool+positionIndependent dflags = gopt Opt_PIC dflags || gopt Opt_PIE dflags++-- Note [-dynamic-too business]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- With -dynamic-too flag, we try to build both the non-dynamic and dynamic+-- objects in a single run of the compiler: the pipeline is the same down to+-- Core optimisation, then the backend (from Core to object code) is executed+-- twice.+--+-- The implementation is currently rather hacky, for example, we don't clearly separate non-dynamic+-- and dynamic loaded interfaces (#9176).+--+-- To make matters worse, we automatically enable -dynamic-too when some modules+-- need Template-Haskell and GHC is dynamically linked (cf+-- GHC.Driver.Pipeline.compileOne').+--+-- We used to try and fall back from a dynamic-too failure but this feature+-- didn't work as expected (#20446) so it was removed to simplify the+-- implementation and not obscure latent bugs.++data DynamicTooState+   = DT_Dont    -- ^ Don't try to build dynamic objects too+   | DT_OK      -- ^ Will still try to generate dynamic objects+   | DT_Dyn     -- ^ Currently generating dynamic objects (in the backend)+   deriving (Eq,Show,Ord)++dynamicTooState :: DynFlags -> DynamicTooState+dynamicTooState dflags+   | not (gopt Opt_BuildDynamicToo dflags) = DT_Dont+   | dynamicNow dflags = DT_Dyn+   | otherwise = DT_OK++setDynamicNow :: DynFlags -> DynFlags+setDynamicNow dflags0 =+   dflags0+      { dynamicNow = True+      }++data PkgDbRef+  = GlobalPkgDb+  | UserPkgDb+  | PkgDbPath FilePath+  deriving Eq++++-- An argument to --reexported-module which can optionally specify a module renaming.+data ReexportedModule = ReexportedModule { reexportFrom :: ModuleName+                                         , reexportTo   :: ModuleName+                                         }++instance Outputable ReexportedModule where+  ppr (ReexportedModule from to) =+    if from == to then ppr from+                  else ppr from <+> text "as" <+> ppr to++{- Note [Implicit include paths]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+  The compile driver adds the path to the folder containing the source file being+  compiled to the 'IncludeSpecs', and this change gets recorded in the 'DynFlags'+  that are used later to compute the interface file. Because of this,+  the flags fingerprint derived from these 'DynFlags' and recorded in the+  interface file will end up containing the absolute path to the source folder.++  Build systems with a remote cache like Bazel or Buck (or Shake, see #16956)+  store the build artifacts produced by a build BA for reuse in subsequent builds.++  Embedding source paths in interface fingerprints will thwart these attempts and+  lead to unnecessary recompilations when the source paths in BA differ from the+  source paths in subsequent builds.+ -}++hasPprDebug :: DynFlags -> Bool+hasPprDebug = dopt Opt_D_ppr_debug++hasNoDebugOutput :: DynFlags -> Bool+hasNoDebugOutput = dopt Opt_D_no_debug_output++hasNoStateHack :: DynFlags -> Bool+hasNoStateHack = gopt Opt_G_NoStateHack++hasNoOptCoercion :: DynFlags -> Bool+hasNoOptCoercion = gopt Opt_G_NoOptCoercion++-- | Test whether a 'DumpFlag' is set+dopt :: DumpFlag -> DynFlags -> Bool+dopt = getDumpFlagFrom verbosity dumpFlags++-- | Set a 'DumpFlag'+dopt_set :: DynFlags -> DumpFlag -> DynFlags+dopt_set dfs f = dfs{ dumpFlags = EnumSet.insert f (dumpFlags dfs) }++-- | Unset a 'DumpFlag'+dopt_unset :: DynFlags -> DumpFlag -> DynFlags+dopt_unset dfs f = dfs{ dumpFlags = EnumSet.delete f (dumpFlags dfs) }++-- | Test whether a 'GeneralFlag' is set+--+-- Note that `dynamicNow` (i.e., dynamic objects built with `-dynamic-too`)+-- always implicitly enables Opt_PIC, Opt_ExternalDynamicRefs, and disables+-- Opt_SplitSections.+--+gopt :: GeneralFlag -> DynFlags -> Bool+gopt Opt_PIC dflags+   | dynamicNow dflags = True+gopt Opt_ExternalDynamicRefs dflags+   | dynamicNow dflags = True+gopt Opt_SplitSections dflags+   | dynamicNow dflags = False+gopt f dflags = f `EnumSet.member` generalFlags dflags++-- | Set a 'GeneralFlag'+gopt_set :: DynFlags -> GeneralFlag -> DynFlags+gopt_set dfs f = dfs{ generalFlags = EnumSet.insert f (generalFlags dfs) }++-- | Unset a 'GeneralFlag'+gopt_unset :: DynFlags -> GeneralFlag -> DynFlags+gopt_unset dfs f = dfs{ generalFlags = EnumSet.delete f (generalFlags dfs) }++-- | Test whether a 'WarningFlag' is set+wopt :: WarningFlag -> DynFlags -> Bool+wopt f dflags  = f `EnumSet.member` warningFlags dflags++-- | Set a 'WarningFlag'+wopt_set :: DynFlags -> WarningFlag -> DynFlags+wopt_set dfs f = dfs{ warningFlags = EnumSet.insert f (warningFlags dfs) }++-- | Unset a 'WarningFlag'+wopt_unset :: DynFlags -> WarningFlag -> DynFlags+wopt_unset dfs f = dfs{ warningFlags = EnumSet.delete f (warningFlags dfs) }++-- | Test whether a 'WarningFlag' is set as fatal+wopt_fatal :: WarningFlag -> DynFlags -> Bool+wopt_fatal f dflags = f `EnumSet.member` fatalWarningFlags dflags++-- | Mark a 'WarningFlag' as fatal (do not set the flag)+wopt_set_fatal :: DynFlags -> WarningFlag -> DynFlags+wopt_set_fatal dfs f+    = dfs { fatalWarningFlags = EnumSet.insert f (fatalWarningFlags dfs) }++-- | Mark a 'WarningFlag' as not fatal+wopt_unset_fatal :: DynFlags -> WarningFlag -> DynFlags+wopt_unset_fatal dfs f+    = dfs { fatalWarningFlags = EnumSet.delete f (fatalWarningFlags dfs) }+++-- | Enable all custom warning categories.+wopt_set_all_custom :: DynFlags -> DynFlags+wopt_set_all_custom dfs+    = dfs{ customWarningCategories = completeWarningCategorySet }++-- | Disable all custom warning categories.+wopt_unset_all_custom :: DynFlags -> DynFlags+wopt_unset_all_custom dfs+    = dfs{ customWarningCategories = emptyWarningCategorySet }++-- | Mark all custom warning categories as fatal (do not set the flags).+wopt_set_all_fatal_custom :: DynFlags -> DynFlags+wopt_set_all_fatal_custom dfs+    = dfs { fatalCustomWarningCategories = completeWarningCategorySet }++-- | Mark all custom warning categories as non-fatal.+wopt_unset_all_fatal_custom :: DynFlags -> DynFlags+wopt_unset_all_fatal_custom dfs+    = dfs { fatalCustomWarningCategories = emptyWarningCategorySet }++-- | Set a custom 'WarningCategory'+wopt_set_custom :: DynFlags -> WarningCategory -> DynFlags+wopt_set_custom dfs f = dfs{ customWarningCategories = insertWarningCategorySet f (customWarningCategories dfs) }++-- | Unset a custom 'WarningCategory'+wopt_unset_custom :: DynFlags -> WarningCategory -> DynFlags+wopt_unset_custom dfs f = dfs{ customWarningCategories = deleteWarningCategorySet f (customWarningCategories dfs) }++-- | Mark a custom 'WarningCategory' as fatal (do not set the flag)+wopt_set_fatal_custom :: DynFlags -> WarningCategory -> DynFlags+wopt_set_fatal_custom dfs f+    = dfs { fatalCustomWarningCategories = insertWarningCategorySet f (fatalCustomWarningCategories dfs) }++-- | Mark a custom 'WarningCategory' as not fatal+wopt_unset_fatal_custom :: DynFlags -> WarningCategory -> DynFlags+wopt_unset_fatal_custom dfs f+    = dfs { fatalCustomWarningCategories = deleteWarningCategorySet f (fatalCustomWarningCategories dfs) }++-- | Are there any custom warning categories enabled?+wopt_any_custom :: DynFlags -> Bool+wopt_any_custom dfs = not (nullWarningCategorySet (customWarningCategories dfs))+++-- | Test whether a 'LangExt.Extension' is set+xopt :: LangExt.Extension -> DynFlags -> Bool+xopt f dflags = f `EnumSet.member` extensionFlags dflags++-- | Set a 'LangExt.Extension'+xopt_set :: DynFlags -> LangExt.Extension -> DynFlags+xopt_set dfs f+    = let onoffs = On f : extensions dfs+      in dfs { extensions = onoffs,+               extensionFlags = flattenExtensionFlags (language dfs) onoffs }++-- | Unset a 'LangExt.Extension'+xopt_unset :: DynFlags -> LangExt.Extension -> DynFlags+xopt_unset dfs f+    = let onoffs = Off f : extensions dfs+      in dfs { extensions = onoffs,+               extensionFlags = flattenExtensionFlags (language dfs) onoffs }++-- | Set or unset a 'LangExt.Extension', unless it has been explicitly+--   set or unset before.+xopt_set_unlessExplSpec+        :: LangExt.Extension+        -> (DynFlags -> LangExt.Extension -> DynFlags)+        -> DynFlags -> DynFlags+xopt_set_unlessExplSpec ext setUnset dflags =+    let referedExts = stripOnOff <$> extensions dflags+        stripOnOff (On x)  = x+        stripOnOff (Off x) = x+    in+        if ext `elem` referedExts then dflags else setUnset dflags ext++xopt_DuplicateRecordFields :: DynFlags -> FieldLabel.DuplicateRecordFields+xopt_DuplicateRecordFields dfs+  | xopt LangExt.DuplicateRecordFields dfs = FieldLabel.DuplicateRecordFields+  | otherwise                              = FieldLabel.NoDuplicateRecordFields++xopt_FieldSelectors :: DynFlags -> FieldLabel.FieldSelectors+xopt_FieldSelectors dfs+  | xopt LangExt.FieldSelectors dfs = FieldLabel.FieldSelectors+  | otherwise                       = FieldLabel.NoFieldSelectors++lang_set :: DynFlags -> Maybe Language -> DynFlags+lang_set dflags lang =+   dflags {+            language = lang,+            extensionFlags = flattenExtensionFlags lang (extensions dflags)+          }++defaultFlags :: Settings -> [GeneralFlag]+defaultFlags settings+-- See Note [Updating flag description in the User's Guide]+  = [ Opt_AutoLinkPackages,+      Opt_DiagnosticsShowCaret,+      Opt_EmbedManifest,+      Opt_FamAppCache,+      Opt_GenManifest,+      Opt_GhciHistory,+      Opt_GhciSandbox,+      Opt_GhciDoLoadTargets,+      Opt_HelpfulErrors,+      Opt_KeepHiFiles,+      Opt_KeepOFiles,+      Opt_OmitYields,+      Opt_PrintBindContents,+      Opt_ProfCountEntries,+      Opt_SharedImplib,+      Opt_SimplPreInlining,+      Opt_VersionMacros,+      Opt_RPath,+      Opt_DumpWithWays,+      Opt_CompactUnwind,+      Opt_ShowErrorContext,+      Opt_SuppressStgReps,+      Opt_UnoptimizedCoreForInterpreter,+      Opt_SpecialiseIncoherents,+      Opt_WriteSelfRecompInfo+    ]++    ++ [f | (ns,f) <- optLevelFlags, 0 `elem` ns]+             -- The default -O0 options++    -- Default floating flags (see Note [RHS Floating])+    ++ [ Opt_LocalFloatOut, Opt_LocalFloatOutTopLevel ]++    ++ default_PIC platform++    ++ validHoleFitDefaults++    where platform = sTargetPlatform settings++-- | These are the default settings for the display and sorting of valid hole+--  fits in typed-hole error messages. See Note [Valid hole fits include ...]+ -- in the "GHC.Tc.Errors.Hole" module.+validHoleFitDefaults :: [GeneralFlag]+validHoleFitDefaults+  =  [ Opt_ShowTypeAppOfHoleFits+     , Opt_ShowTypeOfHoleFits+     , Opt_ShowProvOfHoleFits+     , Opt_ShowMatchesOfHoleFits+     , Opt_ShowValidHoleFits+     , Opt_SortValidHoleFits+     , Opt_SortBySizeHoleFits+     , Opt_ShowHoleConstraints ]++-- Note [When is StarIsType enabled]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- The StarIsType extension determines whether to treat '*' as a regular type+-- operator or as a synonym for 'Data.Kind.Type'. Many existing pre-TypeInType+-- programs expect '*' to be synonymous with 'Type', so by default StarIsType is+-- enabled.+--+-- Programs that use TypeOperators might expect to repurpose '*' for+-- multiplication or another binary operation, but making TypeOperators imply+-- NoStarIsType caused too much breakage on Hackage.+--++--+-- Note [Documenting optimisation flags]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- If you change the list of flags enabled for particular optimisation levels+-- please remember to update the User's Guide. The relevant file is:+--+--   docs/users_guide/using-optimisation.rst+--+-- Make sure to note whether a flag is implied by -O0, -O or -O2.++optLevelFlags :: [([Int], GeneralFlag)]+-- Default settings of flags, before any command-line overrides+optLevelFlags -- see Note [Documenting optimisation flags]+  = [ ([0,1,2], Opt_DoLambdaEtaExpansion)+    , ([1,2],   Opt_DoCleverArgEtaExpansion) -- See Note [Eta expansion of arguments in CorePrep]+    , ([0,1,2], Opt_DoEtaReduction)          -- See Note [Eta-reduction in -O0]+    , ([0,1,2], Opt_ProfManualCcs )+    , ([2], Opt_DictsStrict)++    , ([0],     Opt_IgnoreInterfacePragmas)+    , ([0],     Opt_OmitInterfacePragmas)++    , ([1,2],   Opt_CoreConstantFolding)++    , ([1,2],   Opt_CallArity)+    , ([1,2],   Opt_Exitification)+    , ([1,2],   Opt_CaseMerge)+    , ([1,2],   Opt_CaseFolding)+    , ([1,2],   Opt_CmmElimCommonBlocks)+    , ([2],     Opt_AsmShortcutting)+    , ([1,2],   Opt_CmmSink)+    , ([1,2],   Opt_CmmStaticPred)+    , ([1,2],   Opt_CSE)+    , ([1,2],   Opt_StgCSE)+    , ([2],     Opt_StgLiftLams)+    , ([1,2],   Opt_CmmControlFlow)++    , ([1,2],   Opt_EnableRewriteRules)+          -- Off for -O0.   Otherwise we desugar list literals+          -- to 'build' but don't run the simplifier passes that+          -- would rewrite them back to cons cells!  This seems+          -- silly, and matters for the GHCi debugger.++    , ([1,2],   Opt_FloatIn)+    , ([1,2],   Opt_FullLaziness)+    , ([1,2],   Opt_IgnoreAsserts)+    , ([1,2],   Opt_Loopification)+    , ([1,2],   Opt_CfgBlocklayout)      -- Experimental++    , ([1,2],   Opt_Specialise)+    , ([1,2],   Opt_CrossModuleSpecialise)+    , ([1,2],   Opt_InlineGenerics)+    , ([1,2],   Opt_Strictness)+    , ([1,2],   Opt_UnboxSmallStrictFields)+    , ([1,2],   Opt_CprAnal)+    , ([1,2],   Opt_WorkerWrapper)+    , ([1,2],   Opt_SolveConstantDicts)+    , ([1,2],   Opt_NumConstantFolding)++    , ([2],     Opt_LiberateCase)+    , ([2],     Opt_SpecConstr)+    , ([2],     Opt_FastPAPCalls)+--  , ([2],     Opt_RegsGraph)+--   RegsGraph suffers performance regression. See #7679+--  , ([2],     Opt_StaticArgumentTransformation)+--   Static Argument Transformation needs investigation. See #9374+    , ([0,1,2], Opt_SpecEval)+    , ([],      Opt_SpecEvalDictFun)+    ]+++default_PIC :: Platform -> [GeneralFlag]+default_PIC platform =+  case (platformOS platform, platformArch platform) of+    -- Darwin always requires PIC.  Especially on more recent macOS releases+    -- there will be a 4GB __ZEROPAGE that prevents us from using 32bit addresses+    -- while we could work around this on x86_64 (like WINE does), we won't be+    -- able on aarch64, where this is enforced.+    (OSDarwin,  ArchX86_64)  -> [Opt_PIC]+    -- For AArch64, we need to always have PIC enabled.  The relocation model+    -- on AArch64 does not permit arbitrary relocations.  Under ASLR, we can't+    -- control much how far apart symbols are in memory for our in-memory static+    -- linker;  and thus need to ensure we get sufficiently capable relocations.+    -- This requires PIC on AArch64, and ExternalDynamicRefs on Linux as on top+    -- of that.  Subsequently we expect all code on aarch64/linux (and macOS) to+    -- be built with -fPIC.+    (OSDarwin,  ArchAArch64) -> [Opt_PIC]+    (OSLinux,   ArchAArch64) -> [Opt_PIC, Opt_ExternalDynamicRefs]+    (OSLinux,   ArchARM {})  -> [Opt_PIC, Opt_ExternalDynamicRefs]+    (OSLinux,   ArchRISCV64 {}) -> [Opt_PIC, Opt_ExternalDynamicRefs]+    (OSOpenBSD, ArchX86_64)  -> [Opt_PIC] -- Due to PIE support in+                                         -- OpenBSD since 5.3 release+                                         -- (1 May 2013) we need to+                                         -- always generate PIC. See+                                         -- #10597 for more+                                         -- information.+    (OSLinux,   ArchLoongArch64) -> [Opt_PIC, Opt_ExternalDynamicRefs]+    _                      -> []++-- | The language extensions implied by the various language variants.+-- When updating this be sure to update the flag documentation in+-- @docs/users_guide/exts@.+languageExtensions :: Maybe Language -> [LangExt.Extension]++-- Nothing: the default case+languageExtensions Nothing = languageExtensions (Just defaultLanguage)++languageExtensions (Just Haskell98)+    = [LangExt.ImplicitPrelude,+       -- See Note [When is StarIsType enabled]+       LangExt.StarIsType,+       LangExt.CUSKs,+       LangExt.MonomorphismRestriction,+       LangExt.NPlusKPatterns,+       LangExt.DatatypeContexts,+       LangExt.TraditionalRecordSyntax,+       LangExt.FieldSelectors,+       LangExt.NondecreasingIndentation,+           -- strictly speaking non-standard, but we always had this+           -- on implicitly before the option was added in 7.1, and+           -- turning it off breaks code, so we're keeping it on for+           -- backwards compatibility.  Cabal uses -XHaskell98 by+           -- default unless you specify another language.+       LangExt.DeepSubsumption,+       -- Non-standard but enabled for backwards compatability (see GHC proposal #511)+       LangExt.ListTuplePuns,+       LangExt.ImplicitStagePersistence+      ]++languageExtensions (Just Haskell2010)+    = [LangExt.ImplicitPrelude,+       -- See Note [When is StarIsType enabled]+       LangExt.StarIsType,+       LangExt.CUSKs,+       LangExt.MonomorphismRestriction,+       LangExt.DatatypeContexts,+       LangExt.TraditionalRecordSyntax,+       LangExt.EmptyDataDecls,+       LangExt.ForeignFunctionInterface,+       LangExt.PatternGuards,+       LangExt.DoAndIfThenElse,+       LangExt.FieldSelectors,+       LangExt.RelaxedPolyRec,+       LangExt.DeepSubsumption,+       LangExt.ListTuplePuns,+       LangExt.ImplicitStagePersistence+       ]++languageExtensions (Just GHC2021)+    = [LangExt.ImplicitPrelude,+       -- See Note [When is StarIsType enabled]+       LangExt.StarIsType,+       LangExt.MonomorphismRestriction,+       LangExt.TraditionalRecordSyntax,+       LangExt.EmptyDataDecls,+       LangExt.ForeignFunctionInterface,+       LangExt.PatternGuards,+       LangExt.DoAndIfThenElse,+       LangExt.FieldSelectors,+       LangExt.RelaxedPolyRec,+       LangExt.ListTuplePuns,+       -- Now the new extensions (not in Haskell2010)+       LangExt.BangPatterns,+       LangExt.BinaryLiterals,+       LangExt.ConstrainedClassMethods,+       LangExt.ConstraintKinds,+       LangExt.DeriveDataTypeable,+       LangExt.DeriveFoldable,+       LangExt.DeriveFunctor,+       LangExt.DeriveGeneric,+       LangExt.DeriveLift,+       LangExt.DeriveTraversable,+       LangExt.EmptyCase,+       LangExt.EmptyDataDeriving,+       LangExt.ExistentialQuantification,+       LangExt.ExplicitForAll,+       LangExt.FlexibleContexts,+       LangExt.FlexibleInstances,+       LangExt.GADTSyntax,+       LangExt.GeneralizedNewtypeDeriving,+       LangExt.HexFloatLiterals,+       LangExt.ImportQualifiedPost,+       LangExt.InstanceSigs,+       LangExt.KindSignatures,+       LangExt.MultiParamTypeClasses,+       LangExt.NamedFieldPuns,+       LangExt.NamedWildCards,+       LangExt.NumericUnderscores,+       LangExt.PolyKinds,+       LangExt.PostfixOperators,+       LangExt.RankNTypes,+       LangExt.ScopedTypeVariables,+       LangExt.StandaloneDeriving,+       LangExt.StandaloneKindSignatures,+       LangExt.TupleSections,+       LangExt.TypeApplications,+       LangExt.TypeOperators,+       LangExt.TypeSynonymInstances,+       LangExt.ImplicitStagePersistence+       ]++languageExtensions (Just GHC2024)+    = languageExtensions (Just GHC2021) +++      [LangExt.DataKinds,+       LangExt.DerivingStrategies,+       LangExt.DisambiguateRecordFields,+       LangExt.ExplicitNamespaces,+       LangExt.GADTs,+       LangExt.MonoLocalBinds,+       LangExt.LambdaCase,+       LangExt.RoleAnnotations]++ways :: DynFlags -> Ways+ways dflags+   | dynamicNow dflags = addWay WayDyn (targetWays_ dflags)+   | otherwise         = targetWays_ dflags++-- | Get target profile+targetProfile :: DynFlags -> Profile+targetProfile dflags = Profile (targetPlatform dflags) (ways dflags)++--+-- System tool settings and locations++programName :: DynFlags -> String+programName dflags = ghcNameVersion_programName $ ghcNameVersion dflags+projectVersion :: DynFlags -> String+projectVersion dflags = ghcNameVersion_projectVersion (ghcNameVersion dflags)+ghcUsagePath          :: DynFlags -> FilePath+ghcUsagePath dflags = fileSettings_ghcUsagePath $ fileSettings dflags+ghciUsagePath         :: DynFlags -> FilePath+ghciUsagePath dflags = fileSettings_ghciUsagePath $ fileSettings dflags+topDir                :: DynFlags -> FilePath+topDir dflags = fileSettings_topDir $ fileSettings dflags+toolDir               :: DynFlags -> Maybe FilePath+toolDir dflags = fileSettings_toolDir $ fileSettings dflags+extraGccViaCFlags     :: DynFlags -> [String]+extraGccViaCFlags dflags = toolSettings_extraGccViaCFlags $ toolSettings dflags+globalPackageDatabasePath   :: DynFlags -> FilePath+globalPackageDatabasePath dflags = fileSettings_globalPackageDatabase $ fileSettings dflags++-- | The directory for this version of ghc in the user's app directory+-- The appdir used to be in ~/.ghc but to respect the XDG specification+-- we want to move it under $XDG_DATA_HOME/+-- However, old tooling (like cabal) might still write package environments+-- to the old directory, so we prefer that if a subdirectory of ~/.ghc+-- with the correct target and GHC version suffix exists.+--+-- i.e. if ~/.ghc/$UNIQUE_SUBDIR exists we use that+-- otherwise we use $XDG_DATA_HOME/$UNIQUE_SUBDIR+--+-- UNIQUE_SUBDIR is typically a combination of the target platform and GHC version+versionedAppDir :: String -> ArchOS -> MaybeT IO FilePath+versionedAppDir appname platform = do+  -- Make sure we handle the case the HOME isn't set (see #11678)+  -- We need to fallback to the old scheme if the subdirectory exists.+  msum $ map (checkIfExists <=< fmap (</> versionedFilePath platform))+       [ tryMaybeT $ getAppUserDataDirectory appname  -- this is ~/.ghc/+       , tryMaybeT $ getXdgDirectory XdgData appname -- this is $XDG_DATA_HOME/+       ]+  where+    checkIfExists dir = tryMaybeT (doesDirectoryExist dir) >>= \case+      True -> pure dir+      False -> MaybeT (pure Nothing)++versionedFilePath :: ArchOS -> FilePath+versionedFilePath platform = uniqueSubdir platform++-- | Access the unit-id of the version of `base` which we will automatically link+-- against.+baseUnitId :: DynFlags -> UnitId+baseUnitId dflags = unitSettings_baseUnitId (unitSettings dflags)++-- SDoc+-------------------------------------------+-- | Initialize the pretty-printing options+initSDocContext :: DynFlags -> PprStyle -> SDocContext+initSDocContext dflags style = SDC+  { sdocStyle                       = style+  , sdocColScheme                   = colScheme dflags+  , sdocLastColour                  = Col.colReset+  , sdocShouldUseColor              = overrideWith (canUseColor dflags) (useColor dflags)+  , sdocDefaultDepth                = pprUserLength dflags+  , sdocLineLength                  = pprCols dflags+  , sdocCanUseUnicode               = useUnicode dflags+  , sdocPrintErrIndexLinks          = overrideWith (canUseErrorLinks dflags) (useErrorLinks dflags)+  , sdocHexWordLiterals             = gopt Opt_HexWordLiterals dflags+  , sdocPprDebug                    = dopt Opt_D_ppr_debug dflags+  , sdocPrintUnicodeSyntax          = gopt Opt_PrintUnicodeSyntax dflags+  , sdocPrintCaseAsLet              = gopt Opt_PprCaseAsLet dflags+  , sdocPrintTypecheckerElaboration = gopt Opt_PrintTypecheckerElaboration dflags+  , sdocPrintAxiomIncomps           = gopt Opt_PrintAxiomIncomps dflags+  , sdocPrintExplicitKinds          = gopt Opt_PrintExplicitKinds dflags+  , sdocPrintExplicitCoercions      = gopt Opt_PrintExplicitCoercions dflags+  , sdocPrintExplicitRuntimeReps    = gopt Opt_PrintExplicitRuntimeReps dflags+  , sdocPrintExplicitForalls        = gopt Opt_PrintExplicitForalls dflags+  , sdocPrintPotentialInstances     = gopt Opt_PrintPotentialInstances dflags+  , sdocPrintEqualityRelations      = gopt Opt_PrintEqualityRelations dflags+  , sdocSuppressTicks               = gopt Opt_SuppressTicks dflags+  , sdocSuppressTypeSignatures      = gopt Opt_SuppressTypeSignatures dflags+  , sdocSuppressTypeApplications    = gopt Opt_SuppressTypeApplications dflags+  , sdocSuppressIdInfo              = gopt Opt_SuppressIdInfo dflags+  , sdocSuppressCoercions           = gopt Opt_SuppressCoercions dflags+  , sdocSuppressCoercionTypes       = gopt Opt_SuppressCoercionTypes dflags+  , sdocSuppressUnfoldings          = gopt Opt_SuppressUnfoldings dflags+  , sdocSuppressVarKinds            = gopt Opt_SuppressVarKinds dflags+  , sdocSuppressUniques             = gopt Opt_SuppressUniques dflags+  , sdocSuppressModulePrefixes      = gopt Opt_SuppressModulePrefixes dflags+  , sdocSuppressStgExts             = gopt Opt_SuppressStgExts dflags+  , sdocSuppressStgReps             = gopt Opt_SuppressStgReps dflags+  , sdocErrorSpans                  = gopt Opt_ErrorSpans dflags+  , sdocStarIsType                  = xopt LangExt.StarIsType dflags+  , sdocLinearTypes                 = xopt LangExt.LinearTypes dflags+  , sdocListTuplePuns               = xopt LangExt.ListTuplePuns dflags+  , sdocPrintTypeAbbreviations      = True+  , sdocUnitIdForUser               = ftext+  }++-- | Initialize the pretty-printing options using the default user style+initDefaultSDocContext :: DynFlags -> SDocContext+initDefaultSDocContext dflags = initSDocContext dflags defaultUserStyle++initPromotionTickContext :: DynFlags -> PromotionTickContext+initPromotionTickContext dflags =+  PromTickCtx {+    ptcListTuplePuns = xopt LangExt.ListTuplePuns dflags,+    ptcPrintRedundantPromTicks = gopt Opt_PrintRedundantPromotionTicks dflags+  }++-- -----------------------------------------------------------------------------+-- SSE, AVX, FMA++isSse3Enabled :: DynFlags -> Bool+isSse3Enabled dflags = sseVersion dflags >= Just SSE3++isSsse3Enabled :: DynFlags -> Bool+isSsse3Enabled dflags = sseVersion dflags >= Just SSSE3++isSse4_1Enabled :: DynFlags -> Bool+isSse4_1Enabled dflags = sseVersion dflags >= Just SSE4++isSse4_2Enabled :: DynFlags -> Bool+isSse4_2Enabled dflags = sseVersion dflags >= Just SSE42++isAvxEnabled :: DynFlags -> Bool+isAvxEnabled dflags = avx dflags || avx2 dflags || avx512f dflags++isAvx2Enabled :: DynFlags -> Bool+isAvx2Enabled dflags = avx2 dflags || avx512f dflags++isAvx512cdEnabled :: DynFlags -> Bool+isAvx512cdEnabled dflags = avx512cd dflags++isAvx512erEnabled :: DynFlags -> Bool+isAvx512erEnabled dflags = avx512er dflags++isAvx512fEnabled :: DynFlags -> Bool+isAvx512fEnabled dflags = avx512f dflags++isAvx512pfEnabled :: DynFlags -> Bool+isAvx512pfEnabled dflags = avx512pf dflags++isFmaEnabled :: DynFlags -> Bool+isFmaEnabled dflags = fma dflags++-- -----------------------------------------------------------------------------+-- BMI2++isBmiEnabled :: DynFlags -> Bool+isBmiEnabled dflags = case platformArch (targetPlatform dflags) of+    ArchX86_64 -> bmiVersion dflags >= Just BMI1+    ArchX86    -> bmiVersion dflags >= Just BMI1+    _          -> False++isBmi2Enabled :: DynFlags -> Bool+isBmi2Enabled dflags = case platformArch (targetPlatform dflags) of+    ArchX86_64 -> bmiVersion dflags >= Just BMI2+    ArchX86    -> bmiVersion dflags >= Just BMI2+    _          -> False
GHC/Driver/Env.hs view
@@ -1,8 +1,9 @@ {-# LANGUAGE LambdaCase #-}- module GHC.Driver.Env    ( Hsc(..)    , HscEnv (..)+   , hsc_mod_graph+   , setModuleGraph    , hscUpdateFlags    , hscSetFlags    , hsc_home_unit@@ -14,7 +15,7 @@    , hsc_all_home_unit_ids    , hscUpdateLoggerFlags    , hscUpdateHUG-   , hscUpdateHPT+   , hscInsertHPT    , hscSetActiveHomeUnit    , hscSetActiveUnitId    , hscActiveUnitId@@ -24,28 +25,30 @@    , runInteractiveHsc    , hscEPS    , hscInterp-   , hptCompleteSigs-   , hptAllInstances-   , hptInstancesBelow-   , hptAnns-   , hptAllThings-   , hptSomeThingsBelowUs-   , hptRules    , prepareAnnotations    , discardIC    , lookupType    , lookupIfaceByModule+   , lookupIfaceByModuleHsc    , mainModIs++   , hugRulesBelow+   , hugInstancesBelow+   , hugAnnsBelow+   , hugCompleteSigsBelow++    -- * Legacy API+   , hscUpdateHPT    ) where  import GHC.Prelude -import GHC.Driver.Session+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)+import GHC.Driver.Config.Diagnostic (initDiagOpts, initPrintConfig) import GHC.Driver.Env.Types ( Hsc(..), HscEnv(..) )  import GHC.Runtime.Context@@ -56,22 +59,18 @@ import GHC.Unit.Module.ModIface import GHC.Unit.Module.ModDetails import GHC.Unit.Home.ModInfo-import GHC.Unit.Env+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.Core         ( CoreRule )-import GHC.Core.FamInstEnv-import GHC.Core.InstEnv--import GHC.Types.Annotations ( Annotation, AnnEnv, mkAnnEnv, plusAnnEnv )-import GHC.Types.CompleteMatch import GHC.Types.Error ( emptyMessages, Messages ) import GHC.Types.Name import GHC.Types.Name.Env import GHC.Types.TyThing -import GHC.Builtin.Names ( gHC_PRIM )- import GHC.Data.Maybe  import GHC.Utils.Exception as Ex@@ -80,21 +79,24 @@ import GHC.Utils.Panic import GHC.Utils.Misc import GHC.Utils.Logger-import GHC.Utils.Trace +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-import Data.Set (Set)-import GHC.Unit.Module.Graph-import Data.List (sort)-import qualified Data.Map as Map  runHsc :: HscEnv -> Hsc a -> IO a-runHsc hsc_env (Hsc hsc) = do-    (a, w) <- hsc hsc_env emptyMessages+runHsc hsc_env hsc = do+    (a, w) <- runHsc' hsc_env hsc     let dflags = hsc_dflags hsc_env     let !diag_opts = initDiagOpts dflags-    printOrThrowDiagnostics (hsc_logger hsc_env) diag_opts w+        !print_config = initPrintConfig dflags+    printOrThrowDiagnostics (hsc_logger hsc_env) print_config diag_opts w     return a  runHsc' :: HscEnv -> Hsc a -> IO (a, Messages GhcMessage)@@ -113,13 +115,13 @@ runInteractiveHsc hsc_env = runHsc (mkInteractiveHscEnv hsc_env)  hsc_home_unit :: HscEnv -> HomeUnit-hsc_home_unit = unsafeGetHomeUnit . hsc_unit_env+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_units . hsc_unit_env+hsc_units = ue_homeUnitState . hsc_unit_env  hsc_HPT :: HscEnv -> HomePackageTable hsc_HPT = ue_hpt . hsc_unit_env@@ -130,15 +132,21 @@ 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 = unitEnv_keys . hsc_HUG+hsc_all_home_unit_ids = HUG.allUnits . hsc_HUG -hscUpdateHPT :: (HomePackageTable -> HomePackageTable) -> HscEnv -> HscEnv-hscUpdateHPT f hsc_env = hsc_env { hsc_unit_env = updateHpt f (hsc_unit_env hsc_env) }+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]@@ -162,7 +170,7 @@ 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.setSessionDynFlags`).+configured via command-line flags (in `GHC.setTopSessionDynFlags`).   -}@@ -213,94 +221,68 @@ hscEPS :: HscEnv -> IO ExternalPackageState hscEPS hsc_env = readIORef (euc_eps (ue_eps (hsc_unit_env hsc_env))) -hptCompleteSigs :: HscEnv -> [CompleteMatch]-hptCompleteSigs = hptAllThings  (md_complete_matches . 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.-hptAllInstances :: HscEnv -> (InstEnv, [FamInst])-hptAllInstances hsc_env-  = let (insts, famInsts) = unzip $ flip hptAllThings hsc_env $ \mod_info -> do-                let details = hm_details mod_info-                return (md_insts details, md_fam_insts details)-    in (foldl' unionInstEnv emptyInstEnv insts, concat famInsts)---- | Find instances visible from the given set of imports-hptInstancesBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> (InstEnv, [FamInst])-hptInstancesBelow hsc_env uid mnwib =-  let-    mn = gwib_mod mnwib-    (insts, famInsts) =-        unzip $ hptSomeThingsBelowUs (\mod_info ->-                                     let details = hm_details mod_info-                                     -- Don't include instances for the current module-                                     in if moduleName (mi_module (hm_iface mod_info)) == mn-                                          then []-                                          else [(md_insts details, md_fam_insts details)])-                             True -- Include -hi-boot-                             hsc_env-                             uid-                             mnwib-  in (foldl' unionInstEnv emptyInstEnv insts, concat famInsts)---- | Get rules from modules "below" this one (in the dependency sense)-hptRules :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> [CoreRule]-hptRules = hptSomeThingsBelowUs (md_rules . hm_details) False----- | Get annotations from modules "below" this one (in the dependency sense)-hptAnns :: HscEnv -> Maybe (UnitId, ModuleNameWithIsBoot) -> [Annotation]-hptAnns hsc_env (Just (uid, mn)) = hptSomeThingsBelowUs (md_anns . hm_details) False hsc_env uid mn-hptAnns hsc_env Nothing = hptAllThings (md_anns . hm_details) hsc_env--hptAllThings :: (HomeModInfo -> [a]) -> HscEnv -> [a]-hptAllThings extract hsc_env = concatMap (concatMap extract . eltsHpt . homeUnitEnv_hpt . snd)-                                (hugElts (hsc_HUG hsc_env))---- | This function returns all the modules belonging to the home-unit that can--- be reached by following the given dependencies. Additionally, if both the--- boot module and the non-boot module can be reached, it only returns the--- non-boot one.-hptModulesBelow :: HscEnv -> UnitId -> ModuleNameWithIsBoot -> Set ModNodeKeyWithUid-hptModulesBelow hsc_env uid mn = filtered_mods $ [ mn |  NodeKey_Module mn <- modules_below]-  where-    td_map = mgTransDeps (hsc_mod_graph hsc_env)--    modules_below = maybe [] Set.toList $ Map.lookup (NodeKey_Module (ModNodeKeyWithUid mn uid)) td_map--    filtered_mods = Set.fromDistinctAscList . filter_mods . sort+--------------------------------------------------------------------------------+-- * Queries on Transitive Closure+-------------------------------------------------------------------------------- -    -- 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+-- | 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 --- | Get things from modules "below" this one (in the dependency sense)--- C.f Inst.hptInstances-hptSomeThingsBelowUs :: (HomeModInfo -> [a]) -> Bool -> HscEnv -> UnitId -> ModuleNameWithIsBoot -> [a]-hptSomeThingsBelowUs extract include_hi_boot hsc_env uid mn-  | isOneShot (ghcMode (hsc_dflags hsc_env)) = []+-- | 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) -  | otherwise+-- | 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-    [ thing-    |-    -- Find each non-hi-boot module below me-      (ModNodeKeyWithUid (GWIB { gwib_mod = mod, gwib_isBoot = is_boot }) mod_uid) <- Set.toList (hptModulesBelow hsc_env uid mn)+    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@@ -310,20 +292,17 @@     , mod /= moduleName gHC_PRIM     , not (mod == gwib_mod mn && uid == mod_uid) -        -- Look it up in the HPT-    , let things = case lookupHug hug mod_uid mod of-                    Just info -> extract info-                    Nothing -> pprTrace "WARNING in hptSomeThingsBelowUs" msg mempty+        -- 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 (hptModulesBelow hsc_env uid mn),+                     text "below:" <+> ppr (moduleGraphModulesBelow mg uid mn),                       text "Probable cause: out-of-date interface files"]                         -- This really shouldn't happen, but see #962-    , thing <- things     ] -- -- | Deal with gathering annotations in from all possible places --   and combining them into a single 'AnnEnv' prepareAnnotations :: HscEnv -> Maybe ModGuts -> IO AnnEnv@@ -335,11 +314,13 @@         -- 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  = (mkAnnEnv . hptAnns hsc_env) $ fmap get_mod mb_guts+    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        = foldl1' plusAnnEnv $ catMaybes [mb_this_module_anns,-                                                         Just home_pkg_anns,-                                                         Just other_pkg_anns]+        !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@@ -351,20 +332,23 @@ lookupType hsc_env name = do    eps <- liftIO $ hscEPS hsc_env    let pte = eps_PTE eps-       hpt = hsc_HUG hsc_env+   lookupTypeInPTE hsc_env pte name -       mod = assertPpr (isExternalName name) (ppr name) $-             if isHoleName name-               then mkHomeModule (hsc_home_unit hsc_env) (moduleName (nameModule name))-               else nameModule 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 lookupNameEnv pte name-               else case lookupHugByModule mod hpt of-                Just hm -> lookupNameEnv (md_types (hm_details hm)) name-                Nothing -> lookupNameEnv pte name-   pure ty+    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@@ -372,9 +356,9 @@         :: HomeUnitGraph         -> PackageIfaceTable         -> Module-        -> Maybe ModIface+        -> IO (Maybe ModIface) lookupIfaceByModule hug pit mod-  = case lookupHugByModule mod hug of+  = 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?@@ -384,8 +368,13 @@    -- 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 "mainModIs" $ homeUnitEnv_home_unit  hue) (mainModuleNameIs (homeUnitEnv_dflags hue))+mainModIs hue = mkHomeModule (expectJust $ homeUnitEnv_home_unit hue) (mainModuleNameIs (homeUnitEnv_dflags hue))  -- | Retrieve the target code interpreter --@@ -446,3 +435,19 @@     where     home_unit = hsc_home_unit hsc_env     old_name = ic_name old_ic+++--------------------------------------------------------------------------------+-- * The Legacy API, should be removed after enough deprecation cycles+--------------------------------------------------------------------------------++{-# DEPRECATED hscUpdateHPT "Updating the HPT directly is no longer a supported \+   \ operation. Instead, the HPT is an insert-only data structure. If you want to \+   \ overwrite an existing entry, just use 'hscInsertHPT' to insert it again (it \+   \ will override the existing entry if there is one). See 'GHC.Unit.Home.PackageTable' for more details." #-}+hscUpdateHPT :: (HomePackageTable -> HomePackageTable) -> HscEnv -> HscEnv+hscUpdateHPT f hsc_env = hsc_env { hsc_unit_env = updateHug (HUG.unitEnv_adjust upd (ue_currentUnit $ hsc_unit_env hsc_env)) ue }+  where+    ue = hsc_unit_env hsc_env+    upd hue = hue { homeUnitEnv_hpt = f (homeUnitEnv_hpt hue) }+
GHC/Driver/Env/KnotVars.hs view
@@ -57,7 +57,7 @@ the data structure in 'mkDsEnvs' which required this generalised structure.  In interactive mode the TypeEnvs from all the previous statements are merged-togethed into one big TypeEnv. 'dsLookupVar' relies on `tcIfaceVar'. The normal+together into one big TypeEnv. 'dsLookupVar' relies on `tcIfaceVar'. The normal lookup functions either look in the HPT or EPS but there is no entry for the `Ghci<N>` modules in either, so the whole merged TypeEnv for all previous Ghci* is stored in the `if_rec_types` variable and then lookup checks there in the case of any interactive module.@@ -71,7 +71,7 @@  Normally there's a 'Module' at hand to tell us which 'TypeEnv' we want to interrogate at a particular time, apart from one case, when constructing the in-scope set-when linting an unfolding. In this case the whole environemnt is needed to tell us+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. @@ -89,7 +89,7 @@ This invariant is difficult to test but easy to check using ghc-debug. The usage of NoKnotVars is intended to make this invariant easier to check. -The most common situation where a KnotVars is retained accidently is if a HscEnv+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
GHC/Driver/Env/Types.hs view
@@ -7,7 +7,9 @@  import GHC.Driver.Errors.Types ( GhcMessage ) import {-# SOURCE #-} GHC.Driver.Hooks-import GHC.Driver.Session ( ContainsDynFlags(..), HasDynFlags(..), DynFlags )+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 )@@ -16,7 +18,6 @@ import GHC.Types.Target import GHC.Types.TypeEnv import GHC.Unit.Finder.Types-import GHC.Unit.Module.Graph import GHC.Unit.Env import GHC.Utils.Logger import GHC.Utils.TmpFs@@ -63,9 +64,6 @@         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 @@ -106,4 +104,8 @@          , hsc_tmpfs :: !TmpFs                 -- ^ Temporary files++        , hsc_llvm_config :: !LlvmConfigCache+                -- ^ LLVM configuration cache.  }+
GHC/Driver/Errors.hs view
@@ -1,62 +1,51 @@+{-# LANGUAGE ScopedTypeVariables #-} module GHC.Driver.Errors (     printOrThrowDiagnostics   , printMessages-  , handleFlagWarnings   , mkDriverPsHeaderMessage   ) where  import GHC.Driver.Errors.Types-import GHC.Data.Bag import GHC.Prelude-import GHC.Types.SrcLoc import GHC.Types.SourceError import GHC.Types.Error import GHC.Utils.Error-import GHC.Utils.Outputable (hang, ppr, ($$), SDocContext,  text, withPprStyle, mkErrStyle, sdocStyle )+import GHC.Utils.Outputable (hang, ppr, ($$),  text, mkErrStyle, sdocStyle, updSDocContext ) import GHC.Utils.Logger-import qualified GHC.Driver.CmdLine as CmdLine -printMessages :: Diagnostic a => Logger -> DiagOpts -> Messages a -> IO ()-printMessages logger opts msgs-  = sequence_ [ let style = mkErrStyle unqual+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 logMsg logger (MCDiagnostic sev . diagnosticReason $ dia) s $-                   withPprStyle style (messageWithHints ctx dia)-              | MsgEnvelope { errMsgSpan      = s,-                              errMsgDiagnostic = dia,-                              errMsgSeverity = sev,-                              errMsgContext   = unqual } <- sortMsgBag (Just opts)-                                                                       (getMessages msgs) ]+                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 :: Diagnostic a => SDocContext -> a -> SDoc-    messageWithHints ctx e =-      let main_msg = formatBulleted ctx $ diagnosticMessage e+    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 ctx . mkDecorated . map ppr $ hs)--handleFlagWarnings :: Logger -> DiagOpts -> [CmdLine.Warn] -> IO ()-handleFlagWarnings logger opts warns = do-  let -- It would be nicer if warns :: [Located SDoc], but that-      -- has circular import problems.-      bag = listToBag [ mkPlainMsgEnvelope opts loc $-                        GhcDriverMessage $-                        DriverUnknownMessage $-                        mkPlainDiagnostic reason noHints $ text warn-                      | CmdLine.Warn reason (L loc warn) <- warns ]--  printOrThrowDiagnostics logger opts (mkMessages bag)+                                       (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 -> DiagOpts -> Messages GhcMessage -> IO ()-printOrThrowDiagnostics logger opts msgs+printOrThrowDiagnostics :: Logger -> GhcMessageOpts -> DiagOpts -> Messages GhcMessage -> IO ()+printOrThrowDiagnostics logger print_config opts msgs   | errorsOrFatalWarningsFound msgs   = throwErrors msgs   | otherwise-  = printMessages logger opts msgs+  = 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.
GHC/Driver/Errors/Ppr.hs view
@@ -1,27 +1,40 @@+{-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- instance Diagnostic {DriverMessage, GhcMessage} -module GHC.Driver.Errors.Ppr where+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.Session-import GHC.HsToCore.Errors.Ppr ()-import GHC.Parser.Errors.Ppr ()-import GHC.Tc.Errors.Ppr ()+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@@ -32,19 +45,25 @@ 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-  diagnosticMessage = \case+  type DiagnosticOpts GhcMessage = GhcMessageOpts+  diagnosticMessage opts = \case     GhcPsMessage m-      -> diagnosticMessage m+      -> diagnosticMessage (psMessageOpts opts) m     GhcTcRnMessage m-      -> diagnosticMessage m+      -> diagnosticMessage (tcMessageOpts opts) m     GhcDsMessage m-      -> diagnosticMessage m+      -> diagnosticMessage (dsMessageOpts opts) m     GhcDriverMessage m-      -> diagnosticMessage m-    GhcUnknownMessage m-      -> diagnosticMessage m+      -> diagnosticMessage (driverMessageOpts opts) m+    GhcUnknownMessage (UnknownDiagnostic f _ m)+      -> diagnosticMessage (f opts) m    diagnosticReason = \case     GhcPsMessage m@@ -70,34 +89,41 @@     GhcUnknownMessage m       -> diagnosticHints m +  diagnosticCode = constructorCode @GHC++instance HasDefaultDiagnosticOpts DriverMessageOpts where+  defaultOpts = DriverMessageOpts (defaultDiagnosticOpts @PsMessage) (defaultDiagnosticOpts @IfaceMessage)+ instance Diagnostic DriverMessage where-  diagnosticMessage = \case-    DriverUnknownMessage m-      -> diagnosticMessage m+  type DiagnosticOpts DriverMessage = DriverMessageOpts+  diagnosticMessage opts = \case+    DriverUnknownMessage (UnknownDiagnostic f _ m)+      -> diagnosticMessage (f opts) m     DriverPsHeaderMessage m-      -> diagnosticMessage m-    DriverMissingHomeModules missing buildingCabalPackage+      -> 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: ")+                     (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 command line but needed for compilation: ")+                     (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 missing+    DriverUnknownHiddenModules uid missing       -> let msg = hang-                     (text "Modules are listened as hidden but not part of the unit: ")+                     (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 missing+    DriverUnknownReexportedModules uid missing       -> let msg = hang-                     (text "Modules are listened as reexported but can't be found in any dependency: ")+                     (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@@ -129,7 +155,7 @@            text "module" <+> quotes (ppr mod) <+>            text "is defined in multiple files:" <+>            sep (map text files)-    DriverModuleNotFound mod+    DriverModuleNotFound _uid mod       -> mkSimpleDecorated (text "module" <+> quotes (ppr mod) <+> text "cannot be found locally")     DriverFileModuleNameMismatch actual expected       -> mkSimpleDecorated $@@ -147,8 +173,8 @@       -> mkSimpleDecorated (text "module" <+> ppr modname <+> text "was not found")     DriverUserDefinedRuleIgnored (HsRule { rd_name = n })       -> mkSimpleDecorated $-            text "Rule \"" <> ftext (snd $ unLoc n) <> text "\" ignored" $+$-            text "User defined rules are disabled under Safe Haskell"+            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!")@@ -201,7 +227,62 @@       -> 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@@ -255,6 +336,23 @@       -> 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@@ -311,3 +409,22 @@       -> noHints     DriverHomePackagesNotClosed {}       -> noHints+    DriverInterfaceError reason -> diagnosticHints reason+    DriverInconsistentDynFlags {}+      -> noHints+    DriverSafeHaskellIgnoredExtension {}+      -> noHints+    DriverPackageTrustIgnored {}+      -> noHints+    DriverUnrecognisedFlag {}+      -> noHints+    DriverDeprecatedFlag {}+      -> noHints+    DriverModuleGraphCycle {}+      -> noHints+    DriverInstantiationNodeInDependencyGeneration {}+      -> noHints+    DriverNoConfiguredLLVMToolchain+      -> noHints++  diagnosticCode = constructorCode @GHC
GHC/Driver/Errors/Types.hs view
@@ -1,9 +1,14 @@+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE GADTs #-}+{-# LANGUAGE StandaloneDeriving #-}  module GHC.Driver.Errors.Types (     GhcMessage(..)-  , DriverMessage(..), DriverMessages, PsMessage(PsHeaderMessage)-  , BuildingCabalPackage(..)+  , AnyGhcDiagnostic+  , GhcMessageOpts(..)+  , DriverMessage(..)+  , DriverMessageOpts(..)+  , DriverMessages, PsMessage(PsHeaderMessage)   , WarningMessages   , ErrorMessages   , WarnMsg@@ -20,18 +25,25 @@ import Data.Bifunctor import Data.Typeable -import GHC.Driver.Session+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.Tc.Errors.Types     ( TcRnMessage ) 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@@ -83,16 +95,26 @@   -- 'Diagnostic' constraint ensures that worst case scenario we can still   -- render this into something which can be eventually converted into a   -- 'DecoratedSDoc'.-  GhcUnknownMessage :: forall a. (Diagnostic a, Typeable a) => a -> GhcMessage+  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 :: (Diagnostic a, Typeable a) => a -> GhcMessage-ghcUnknownMessage = GhcUnknownMessage+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)'.@@ -110,7 +132,8 @@ -- | A message from the driver. data DriverMessage where   -- | Simply wraps a generic 'Diagnostic' message @a@.-  DriverUnknownMessage :: (Diagnostic a, Typeable a) => a -> DriverMessage+  DriverUnknownMessage :: UnknownDiagnosticFor DriverMessage -> DriverMessage+   -- | A parse error in parsing a Haskell file header during dependency   -- analysis   DriverPsHeaderMessage :: !PsMessage -> DriverMessage@@ -126,17 +149,17 @@       Test case: warnings/should_compile/MissingMod    -}-  DriverMissingHomeModules :: [ModuleName] -> !BuildingCabalPackage -> DriverMessage+  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 :: [ModuleName] -> DriverMessage+  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 :: [ModuleName] -> DriverMessage+  DriverUnknownHiddenModules :: UnitId -> [ModuleName] -> DriverMessage    {-| DriverUnusedPackages occurs when when package is requested on command line,       but was never needed during compilation. Activated by -Wunused-packages.@@ -164,7 +187,7 @@       Test cases: None.   -}-  DriverModuleNotFound :: !ModuleName -> DriverMessage+  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@@ -351,12 +374,50 @@    DriverHomePackagesNotClosed :: ![UnitId] -> DriverMessage --- | Pass to a 'DriverMessage' the information whether or not the--- '-fbuilding-cabal-package' flag is set.-data BuildingCabalPackage-  = YesBuildingCabalPackage-  | NoBuildingCabalPackage-  deriving Eq+  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
GHC/Driver/Flags.hs view
@@ -1,21 +1,50 @@+{-# 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 @@ -24,13 +53,21 @@ 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) -data Language = Haskell98 | Haskell2010 | GHC2021+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 @@ -38,9 +75,354 @@   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]+-- See Note [Updating flag description in the User's Guide] in GHC.Driver.Session     -- debugging flags    = Opt_D_dump_cmm@@ -51,7 +433,7 @@    -- 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+   -- ^ 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@@ -64,6 +446,7 @@    | 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@@ -75,6 +458,7 @@    | 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@@ -93,6 +477,7 @@    | 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)@@ -100,10 +485,11 @@    | 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_stranal-   | Opt_D_dump_str_signatures+   | Opt_D_dump_dmdanal+   | Opt_D_dump_dmd_signatures    | Opt_D_dump_cpranal    | Opt_D_dump_cpr_signatures    | Opt_D_dump_tc@@ -112,14 +498,18 @@    | 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_cs_trace -- ^ Constraint solver in type checker    | Opt_D_dump_tc_trace-   | Opt_D_dump_ec_trace -- Pattern match exhaustiveness checker+   | Opt_D_dump_ec_trace -- ^ Pattern match exhaustiveness checker    | Opt_D_dump_if_trace    | Opt_D_dump_splices    | Opt_D_th_dec_file@@ -141,13 +531,55 @@    | 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]+-- See Note [Updating flag description in the User's Guide] in GHC.Driver.Session     = Opt_DumpToFile                     -- ^ Append dump output to files instead of stdout.+   | Opt_DumpWithWays                   -- ^ Use foo.ways.<dumpFlag> instead of foo.<dumpFlag>    | Opt_D_dump_minimal_imports    | Opt_DoCoreLinting    | Opt_DoLinearCoreLinting@@ -156,16 +588,23 @@    | 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 warnings fatal-   | Opt_ShowWarnGroups                 -- Show the group a warning belongs to-   | Opt_HideSourcePaths                -- Hide module source/object paths+   | 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@@ -176,6 +615,7 @@    | Opt_PrintUnicodeSyntax    | Opt_PrintExpandedSynonyms    | Opt_PrintPotentialInstances+   | Opt_PrintRedundantPromotionTicks    | Opt_PrintTypecheckerElaboration     -- optimisation opts@@ -187,10 +627,16 @@    | 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@@ -200,20 +646,21 @@    | 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_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_LlvmTBAA                       -- Use LLVM TBAA infrastructure for improving AA (hidden flag)+   | 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@@ -221,28 +668,32 @@    | Opt_CmmElimCommonBlocks    | Opt_CmmControlFlow    | Opt_AsmShortcutting+   | Opt_InterModuleFarJumps    | Opt_OmitYields-   | Opt_FunToThunk               -- deprecated-   | Opt_DictsStrict                     -- be strict in argument dictionaries+   | 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_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+   | 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+   -- | PreInlining is on by default. The option is there just to see how    -- bad things get if you turn it off!    | Opt_SimplPreInlining @@ -250,14 +701,24 @@    | Opt_IgnoreInterfacePragmas    | Opt_OmitInterfacePragmas    | Opt_ExposeAllUnfoldings-   | Opt_WriteInterface -- forces .hi files to be written even with -fno-code-   | Opt_WriteHie -- generate .hie files+   | 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@@ -267,6 +728,7 @@    | Opt_IgnoreHpcChanges    | Opt_ExcessPrecision    | Opt_EagerBlackHoling+   | Opt_OrigThunkInfo    | Opt_NoHsMain    | Opt_SplitSections    | Opt_StgStats@@ -285,11 +747,20 @@    | 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@@ -304,6 +775,7 @@    | 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@@@ -314,7 +786,7 @@    | Opt_VersionMacros    | Opt_WholeArchiveHsLibs    -- copy all libs into a single folder prior to linking binaries-   -- this should elivate the excessive command line limit restrictions+   -- 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@@ -324,13 +796,16 @@    | Opt_KeepCAFs    | Opt_KeepGoing    | Opt_ByteCode+   | Opt_ByteCodeAndObjectCode+   | Opt_UnoptimizedCoreForInterpreter    | Opt_LinkRts     -- output style opts-   | Opt_ErrorSpans -- Include full span info in error messages,+   | Opt_ErrorSpans -- ^ Include full span info in error messages,                     -- instead of just the start position.    | Opt_DeferDiagnostics-   | Opt_DiagnosticsShowCaret -- Show snippets of offending code+   | Opt_DiagnosticsAsJSON  -- ^ Dump diagnostics as JSON+   | Opt_DiagnosticsShowCaret -- ^ Show snippets of offending code    | Opt_PprCaseAsLet    | Opt_PprShowTicks    | Opt_ShowHoleConstraints@@ -353,29 +828,38 @@    | Opt_ShowLoadedModules    | Opt_HexWordLiterals -- See Note [Print Hexadecimal Literals] -   -- Suppress all coercions, them replacing with '...'+   -- | 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.+   -- | Suppress module id prefixes on variables.    | Opt_SuppressModulePrefixes-   -- Suppress type applications.+   -- | Suppress type applications.    | Opt_SuppressTypeApplications-   -- Suppress info such as arity and unfoldings on identifiers.+   -- | Suppress info such as arity and unfoldings on identifiers.    | Opt_SuppressIdInfo-   -- Suppress separate type signatures in core, but leave types on+   -- | Suppress separate type signatures in core, but leave types on    -- lambda bound vars    | Opt_SuppressUnfoldings-   -- Suppress the details of even stable unfoldings+   -- | Suppress the details of even stable unfoldings    | Opt_SuppressTypeSignatures-   -- Suppress unique ids on variables.+   -- | 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_SuppressTicks     -- Replaces Opt_PprShowTicks+   | 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@@ -392,6 +876,8 @@    | Opt_KeepOFiles     | Opt_BuildDynamicToo+   | Opt_WriteIfSimplifiedCore+   | Opt_UseBytecodeRatherThanObjects     -- safe haskell flags    | Opt_DistrustAllPackages@@ -402,15 +888,11 @@    | Opt_G_NoOptCoercion    deriving (Eq, Show, Enum) --- Check whether a flag should be considered an "optimisation flag"--- for purposes of recompilation avoidance (see--- Note [Ignoring some flag changes] in GHC.Iface.Recomp.Flags). Being listed here is--- not a guarantee that the flag has no other effect. We could, and--- perhaps should, separate out the flags that have some minor impact on--- program semantics and/or error behavior (e.g., assertions), but--- then we'd need to go to extra trouble (and an additional flag)--- to allow users to ignore the optimisation level even though that--- means ignoring some change.+-- | 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@@ -442,16 +924,12 @@    , Opt_EnableRewriteRules    , Opt_RegsGraph    , Opt_RegsIterative-   , Opt_PedanticBottoms-   , Opt_LlvmTBAA-   , Opt_LlvmFillUndefWithGarbage    , Opt_IrrefutableTuples    , Opt_CmmSink    , Opt_CmmElimCommonBlocks    , Opt_AsmShortcutting-   , Opt_OmitYields+   , Opt_InterModuleFarJumps    , Opt_FunToThunk-   , Opt_DictsStrict    , Opt_DmdTxDictSel    , Opt_Loopification    , Opt_CfgBlocklayout@@ -460,12 +938,59 @@    , 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_IgnoreAsserts+   , 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]+-- See Note [Updating flag description in the User's Guide] in GHC.Driver.Session      Opt_WarnDuplicateExports    | Opt_WarnDuplicateConstraints    | Opt_WarnRedundantConstraints@@ -495,10 +1020,9 @@    | Opt_WarnUnusedRecordWildcards    | Opt_WarnRedundantBangPatterns    | Opt_WarnRedundantRecordWildcards-   | Opt_WarnWarningsDeprecations    | Opt_WarnDeprecatedFlags    | Opt_WarnMissingMonadFailInstances               -- since 8.0, has no effect since 8.8-   | Opt_WarnSemigroup                               -- since 8.0+   | Opt_WarnSemigroup                               -- since 8.0, has no effect since 9.8    | Opt_WarnDodgyExports    | Opt_WarnDodgyImports    | Opt_WarnOrphans@@ -527,43 +1051,63 @@    | Opt_WarnDerivingTypeable    | Opt_WarnDeferredTypeErrors    | Opt_WarnDeferredOutOfScopeVariables-   | Opt_WarnNonCanonicalMonadInstances              -- since 8.0-   | Opt_WarnNonCanonicalMonadFailInstances          -- since 8.0, removed 8.8-   | Opt_WarnNonCanonicalMonoidInstances             -- since 8.0-   | Opt_WarnMissingPatternSynonymSignatures         -- since 8.0-   | Opt_WarnUnrecognisedWarningFlags                -- since 8.0-   | Opt_WarnSimplifiableClassConstraints            -- Since 8.2-   | Opt_WarnCPPUndef                                -- Since 8.2-   | Opt_WarnUnbangedStrictPatterns                  -- Since 8.2-   | Opt_WarnMissingHomeModules                      -- Since 8.2-   | Opt_WarnPartialFields                           -- Since 8.4+   | Opt_WarnNonCanonicalMonadInstances              -- ^ @since 8.0+   | Opt_WarnNonCanonicalMonadFailInstances          -- ^ @since 8.0, 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_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_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_WarnMissingExportedPatternSynonymSignatures -- since 9.2-   | Opt_WarnRedundantStrictnessFlags                -- Since 9.4-   | Opt_WarnForallIdentifier                        -- Since 9.4-   | Opt_WarnUnicodeBidirectionalFormatCharacters    -- Since 9.0.2-   | Opt_WarnGADTMonoLocalBinds                      -- Since 9.4-   | Opt_WarnTypeEqualityOutOfScope                  -- Since 9.4-   | Opt_WarnTypeEqualityRequiresOperators           -- Since 9.4-   deriving (Eq, Ord, Show, Enum)+   | 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 --@@ -574,11 +1118,11 @@   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_WarnWarningsDeprecations                    -> "deprecations" :| ["warnings-deprecations"]   Opt_WarnDeprecatedFlags                         -> "deprecated-flags" :| []   Opt_WarnDerivingDefaults                        -> "deriving-defaults" :| []   Opt_WarnDerivingTypeable                        -> "deriving-typeable" :| []@@ -607,6 +1151,7 @@   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" :| []@@ -667,7 +1212,22 @@   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@@ -675,24 +1235,62 @@ -- Note [Documenting warning flags] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ----- If you change the list of warning enabled by default+-- 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 Weverything set, it is ignored when+-- As all warnings are in the 'W_everything' 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)-    ]+warningGroups :: [WarningGroup]+warningGroups = [minBound..maxBound]  -- | Warning group hierarchies, where there is an explicit inclusion -- relation.@@ -704,32 +1302,35 @@ -- 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]]+-- The special-case 'W_everything' group is not included.+warningHierarchies :: [[WarningGroup]] warningHierarchies = hierarchies ++ map (:[]) rest   where-    hierarchies = [["default", "extra", "all"]]-    rest = filter (`notElem` "everything" : concat hierarchies) $-           map fst warningGroups+    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 -> [String]+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-        flags <- lookup group warningGroups-        guard (flag `elem` flags)+        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_WarnWarningsDeprecations,         Opt_WarnDeprecatedFlags,         Opt_WarnDeferredTypeErrors,         Opt_WarnTypedHoles,@@ -755,18 +1356,27 @@         Opt_WarnUnrecognisedWarningFlags,         Opt_WarnSimplifiableClassConstraints,         Opt_WarnStarBinder,+        Opt_WarnStarIsType,         Opt_WarnInaccessibleCode,         Opt_WarnSpaceAfterBang,         Opt_WarnNonCanonicalMonadInstances,         Opt_WarnNonCanonicalMonoidInstances,         Opt_WarnOperatorWhitespaceExtConflict,-        Opt_WarnForallIdentifier,         Opt_WarnUnicodeBidirectionalFormatCharacters,         Opt_WarnGADTMonoLocalBinds,-        Opt_WarnTypeEqualityRequiresOperators+        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+-- | Things you get with @-W@. minusWOpts :: [WarningFlag] minusWOpts     = standardWarnings ++@@ -782,7 +1392,7 @@         Opt_WarnUnbangedStrictPatterns       ] --- | Things you get with -Wall+-- | Things you get with @-Wall@. minusWallOpts :: [WarningFlag] minusWallOpts     = minusWOpts ++@@ -796,30 +1406,28 @@         Opt_WarnMissingPatternSynonymSignatures,         Opt_WarnUnusedRecordWildcards,         Opt_WarnRedundantRecordWildcards,-        Opt_WarnStarIsType,         Opt_WarnIncompleteUniPatterns,-        Opt_WarnIncompletePatternsRecUpd+        Opt_WarnIncompletePatternsRecUpd,+        Opt_WarnIncompleteExportWarnings,+        Opt_WarnIncompleteRecordSelectors,+        Opt_WarnDerivingTypeable       ] --- | Things you get with -Weverything, i.e. *all* known warnings flags+-- | Things you get with @-Weverything@, i.e. *all* known warnings flags. minusWeverythingOpts :: [WarningFlag] minusWeverythingOpts = [ toEnum 0 .. ] --- | Things you get with -Wcompat.+-- | Things you get with @-Wcompat@. -- -- This is intended to group together warnings that will be enabled by default -- at some point in the future, so that library authors eager to make their -- code future compatible to fix issues before they even generate warnings. minusWcompatOpts :: [WarningFlag] minusWcompatOpts-    = [ Opt_WarnSemigroup-      , Opt_WarnNonCanonicalMonoidInstances-      , Opt_WarnStarIsType-      , Opt_WarnCompatUnqualifiedImports-      , Opt_WarnTypeEqualityOutOfScope+    = [ Opt_WarnPatternNamespaceSpecifier       ] --- | Things you get with -Wunused-binds+-- | Things you get with @-Wunused-binds@. unusedBindsFlags :: [WarningFlag] unusedBindsFlags = [ Opt_WarnUnusedTopBinds                    , Opt_WarnUnusedLocalBinds
GHC/Driver/GenerateCgIPEStub.hs view
@@ -1,37 +1,42 @@-{-# LANGUAGE GADTs #-}+{-# LANGUAGE GADTs         #-}+{-# LANGUAGE TupleSections #-} -module GHC.Driver.GenerateCgIPEStub (generateCgIPEStub) where+module GHC.Driver.GenerateCgIPEStub (generateCgIPEStub, lookupEstimatedTicks) where +import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map-import Data.Maybe (catMaybes, listToMaybe)+import Data.Semigroup ((<>)) import GHC.Cmm-import GHC.Cmm.CLabel (CLabel)-import GHC.Cmm.Dataflow (Block, C, O)+import GHC.Cmm.CLabel (CLabel, mkAsmTempLabel)+import GHC.Cmm.Dataflow (O) import GHC.Cmm.Dataflow.Block (blockSplit, blockToList)-import GHC.Cmm.Dataflow.Collections (mapToList)-import GHC.Cmm.Dataflow.Label (Label)+import GHC.Cmm.Dataflow.Label import GHC.Cmm.Info.Build (emptySRT) import GHC.Cmm.Pipeline (cmmPipeline)-import GHC.Cmm.Utils (toBlockList)-import GHC.Data.Maybe (firstJusts)-import GHC.Data.Stream (Stream, liftIO)+import GHC.Data.Stream (liftIO, liftEff) import qualified GHC.Data.Stream as Stream-import GHC.Driver.Env (hsc_dflags)+import GHC.Driver.Env (hsc_dflags, hsc_logger) import GHC.Driver.Env.Types (HscEnv)-import GHC.Driver.Flags (GeneralFlag (Opt_InfoTableMap))-import GHC.Driver.Session (gopt, targetPlatform)+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 (Platform, platformUnregisterised)+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)-import GHC.Utils.Misc+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)]@@ -41,7 +46,7 @@ But to make them readable / meaningful, one needs to know the source location of each return frame.  Every return frame has a distinct info table and thus a distinct code pointer (for tables next to-code) or at least a distict address itself. Info Table Provernance Entries (IPE) are searchable by+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:@@ -52,14 +57,20 @@  This leads to the question: How to figure out the source location of a return frame? -While the lookup algorithms for registerised and unregisterised builds differ in details, they have in-common that we want to lookup the `CmmNode.CmmTick` (containing a `SourceNote`) that is nearest-(before) the usage of the return frame's label. (Which label and label type is used differs between-these two use cases.)+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. -Registerised-~~~~~~~~~~~~~+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]@@ -107,20 +118,20 @@ Here we use the fact, that calls (represented by `CmmNode.CmmCall`) are always closed on exit (`CmmNode O C`, `O` means open, `C` closed). In other words, they are always at the end of a block. -So, given a stack represented info table (likely representing a return frame, but this isn't completely-sure as there are e.g. update frames, too) with it's label (`c18g` in the example above) and a `CmmGraph`:-  - Look at the end of every block, if it's a `CmmNode.CmmCall` returning to the continuation with the-    label of the return frame.-  - If there's such a call, lookup the nearest `CmmNode.CmmTick` by traversing the middle part of the block-    backwards (from end to beginning).-  - Take the first `CmmNode.CmmTick` that contains a `Tickish.SourceNote` and return it's payload as-    `IpeSourceLocation`. (There are other `Tickish` constructors like `ProfNote` or `HpcTick`, these are-    ignored.)+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.) -Unregisterised-~~~~~~~~~~~~~+See `labelsToSourcesWithTNTC` for the implementation of this algorithm. -In unregisterised builds there is no return frame / continuation label in calls. The continuation (i.e. return+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.  ```@@ -170,98 +181,209 @@ Notice, that this cannot be done with the `Label` `c18M`, but with the `CLabel` `block_c18M_info` (`label: block_c18M_info` is actually a `CLabel`). -The find the tick:-  - Every `Block` is checked from top (first) to bottom (last) node for an assignment like-   `I64[Sp - 24] = block_c18M_info;`. The lefthand side is actually ignored.-  - If such an assignment is found the search is over, because the payload (content of-    `Tickish.SourceNote`, represented as `IpeSourceLocation`) of last visited tick is always-    remembered in a `Maybe`.+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 -> Stream IO CmmGroupSRTs (NonCaffySet, ModuleLFInfos) -> Stream IO CmmGroupSRTs CmmCgInfos-generateCgIPEStub hsc_env this_mod denv s = do+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 -  -- Collect info tables, but only if -finfo-table-map is enabled, otherwise labeledInfoTablesWithTickishes is empty.-  let collectFun = if gopt Opt_InfoTableMap dflags then collect platform else collectNothing-  (labeledInfoTablesWithTickishes, (nonCaffySet, moduleLFInfos)) <- Stream.mapAccumL_ collectFun [] s+  -- 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.fromList (map (\(_, i, t) -> (cit_lbl i, t)) labeledInfoTablesWithTickishes)}-      ((ipeStub, ipeCmmGroup), _) = runC (initStgToCmmConfig dflags this_mod) fstate cgState $ getCmm (initInfoTableProv (map sndOf3 labeledInfoTablesWithTickishes) denv')+    -- 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) -  (_, ipeCmmGroupSRTs) <- liftIO $ cmmPipeline hsc_env (emptySRT this_mod) ipeCmmGroup+    return ((mIpeStub, ipeCmmGroup), dus')++  (_, ipeCmmGroupSRTs) <- liftEff $ withDUS $ cmmPipeline logger cmm_cfg (emptySRT this_mod) (removeDeterm ipeCmmGroup)   Stream.yield ipeCmmGroupSRTs -  return CmmCgInfos {cgNonCafs = nonCaffySet, cgLFInfos = moduleLFInfos, cgIPEStub = ipeStub}-  where-    collect :: Platform -> [(Label, CmmInfoTable, Maybe IpeSourceLocation)] -> CmmGroupSRTs -> IO ([(Label, CmmInfoTable, Maybe IpeSourceLocation)], CmmGroupSRTs)-    collect platform acc cmmGroupSRTs = do-      let labelsToInfoTables = collectInfoTables cmmGroupSRTs-          labelsToInfoTablesToTickishes = map (\(l, i) -> (l, i, lookupEstimatedTick platform cmmGroupSRTs l i)) labelsToInfoTables-      return (acc ++ labelsToInfoTablesToTickishes, cmmGroupSRTs)+  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 -    collectNothing :: [a] -> CmmGroupSRTs -> IO ([a], CmmGroupSRTs)-    collectNothing _ cmmGroupSRTs = pure ([], cmmGroupSRTs)+  return CmmCgInfos {cgNonCafs = nonCaffySet, cgLFInfos = moduleLFInfos, cgIPEStub = ipeStub} -    collectInfoTables :: CmmGroupSRTs -> [(Label, CmmInfoTable)]-    collectInfoTables cmmGroup = concat $ catMaybes $ map extractInfoTables cmmGroup+-- | 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 -    extractInfoTables :: GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph -> Maybe [(Label, CmmInfoTable)]-    extractInfoTables (CmmProc h _ _ _) = Just $ mapToList (info_tbls h)-    extractInfoTables _ = Nothing+    -- 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 -    lookupEstimatedTick :: Platform -> CmmGroupSRTs -> Label -> CmmInfoTable -> Maybe IpeSourceLocation-    lookupEstimatedTick platform cmmGroup infoTableLabel infoTable = do-      -- All return frame info tables are stack represented, though not all stack represented info-      -- tables have to be return frames.-      if (isStackRep . cit_rep) infoTable-        then do-          let findFun =-                if platformUnregisterised platform-                  then findCmmTickishForForUnregistered (cit_lbl infoTable)-                  else findCmmTickishForRegistered infoTableLabel-              blocks = concatMap toBlockList (graphs cmmGroup)-          firstJusts $ map findFun blocks-        else Nothing-    graphs :: CmmGroupSRTs -> [CmmGraph]-    graphs = foldl' go []+    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 :: [CmmGraph] -> GenCmmDecl d h CmmGraph -> [CmmGraph]-        go acc (CmmProc _ _ _ g) = g : acc-        go acc _ = acc--    findCmmTickishForRegistered :: Label -> Block CmmNode C C -> Maybe IpeSourceLocation-    findCmmTickishForRegistered label block = do-      let (_, middleBlock, endBlock) = blockSplit block+        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) -      isCallWithReturnFrameLabel endBlock label-      lastTickInBlock middleBlock+-- | 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-        isCallWithReturnFrameLabel :: CmmNode O C -> Label -> Maybe ()-        isCallWithReturnFrameLabel (CmmCall _ (Just l) _ _ _ _) clabel | l == clabel = Just ()-        isCallWithReturnFrameLabel _ _ = Nothing+        (_, middleBlock, endBlock) = blockSplit block -        lastTickInBlock block =-          listToMaybe $-            catMaybes $-              map maybeTick $ (reverse . blockToList) block+        returnFrameLabel :: Maybe CLabel+        returnFrameLabel =+          case endBlock of+            (CmmCall _ (Just l) _ _ _ _) -> Just $ mkAsmTempLabel l+            _ -> Nothing -        maybeTick :: CmmNode O O -> Maybe IpeSourceLocation-        maybeTick (CmmTick (SourceNote span name)) = Just (span, name)-        maybeTick _ = Nothing+        lastTickInBlock = foldr maybeTick Nothing (blockToList middleBlock) -    findCmmTickishForForUnregistered :: CLabel -> Block CmmNode C C -> Maybe IpeSourceLocation-    findCmmTickishForForUnregistered cLabel block = do-      let (_, middleBlock, _) = blockSplit block-      find cLabel (blockToList middleBlock) Nothing+        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-        find :: CLabel -> [CmmNode O O] -> Maybe IpeSourceLocation -> Maybe IpeSourceLocation-        find label (b : blocks) lastTick = case b of-          (CmmStore _ (CmmLit (CmmLabel l)) _) -> if label == l then lastTick else find label blocks lastTick-          (CmmTick (SourceNote span name)) -> find label blocks $ Just (span, name)-          _ -> find label blocks lastTick-        find _ [] _ = Nothing+        (_, middleBlock, _) = blockSplit block++        collectLabels+          :: (Map CLabel IpeSourceLocation, Maybe IpeSourceLocation)+          -> CmmNode O O+          -> (Map CLabel IpeSourceLocation, Maybe IpeSourceLocation)+        collectLabels (!acc, lastTick) b =+          case (b, lastTick) of+            (CmmStore _ (CmmLit (CmmLabel l)) _, Just src_loc) ->+              (Map.insert l src_loc acc, Nothing)+            (CmmTick (SourceNote span name), _) ->+              (acc, Just (span, name))+            _ -> (acc, lastTick)+labelsToSourcesSansTNTC acc _ = acc
GHC/Driver/Hooks.hs view
@@ -32,7 +32,7 @@ import GHC.Prelude  import GHC.Driver.Env-import GHC.Driver.Session+import GHC.Driver.DynFlags import GHC.Driver.Pipeline.Phases  import GHC.Hs.Decls@@ -48,12 +48,11 @@ import GHC.Types.CostCentre import GHC.Types.IPE import GHC.Types.Meta-import GHC.Types.HpcInfo  import GHC.Unit.Module import GHC.Unit.Module.ModSummary import GHC.Unit.Module.ModIface-import GHC.Unit.Home.ModInfo+import GHC.Unit.Home.PackageTable  import GHC.Core import GHC.Core.TyCon@@ -61,13 +60,13 @@  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.Stream import GHC.Data.Bag  import qualified Data.Kind@@ -121,6 +120,9 @@ 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]@@ -141,14 +143,14 @@   , runMetaHook            :: !(Maybe (MetaHook TcM))   , linkHook               :: !(Maybe (GhcLink -> DynFlags -> Bool                                          -> HomePackageTable -> IO SuccessFlag))-  , runRnSpliceHook        :: !(Maybe (HsSplice GhcRn -> RnM (HsSplice GhcRn)))+  , 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] -> HpcInfo -> Stream IO CmmGroup ModuleLFInfos))-  , cmmToRawCmmHook        :: !(forall a . Maybe (DynFlags -> Maybe Module -> Stream IO CmmGroupSRTs a-                                 -> IO (Stream IO RawCmmGroup a)))+                                 -> [CgStgTopBinding] -> CgStream CmmGroup ModuleLFInfos))+  , cmmToRawCmmHook        :: !(forall a . Maybe (DynFlags -> Maybe Module -> CgStream CmmGroupSRTs a+                                 -> IO (CgStream RawCmmGroup a)))   }  class HasHooks m where
+ GHC/Driver/IncludeSpecs.hs view
@@ -0,0 +1,48 @@+module GHC.Driver.IncludeSpecs+  ( IncludeSpecs(..)+  , addGlobalInclude+  , addQuoteInclude+  , addImplicitQuoteInclude+  , flattenIncludes+  ) where++import GHC.Prelude++-- | Used to differentiate the scope an include needs to apply to.+-- We have to split the include paths to avoid accidentally forcing recursive+-- includes since -I overrides the system search paths. See #14312.+data IncludeSpecs+  = IncludeSpecs { includePathsQuote  :: [String]+                 , includePathsGlobal :: [String]+                 -- | See Note [Implicit include paths]+                 , includePathsQuoteImplicit :: [String]+                 }+  deriving Show++-- | Append to the list of includes a path that shall be included using `-I`+-- when the C compiler is called. These paths override system search paths.+addGlobalInclude :: IncludeSpecs -> [String] -> IncludeSpecs+addGlobalInclude spec paths  = let f = includePathsGlobal spec+                               in spec { includePathsGlobal = f ++ paths }++-- | Append to the list of includes a path that shall be included using+-- `-iquote` when the C compiler is called. These paths only apply when quoted+-- includes are used. e.g. #include "foo.h"+addQuoteInclude :: IncludeSpecs -> [String] -> IncludeSpecs+addQuoteInclude spec paths  = let f = includePathsQuote spec+                              in spec { includePathsQuote = f ++ paths }++-- | These includes are not considered while fingerprinting the flags for iface+-- | See Note [Implicit include paths]+addImplicitQuoteInclude :: IncludeSpecs -> [String] -> IncludeSpecs+addImplicitQuoteInclude spec paths  = let f = includePathsQuoteImplicit spec+                              in spec { includePathsQuoteImplicit = f ++ paths }+++-- | Concatenate and flatten the list of global and quoted includes returning+-- just a flat list of paths.+flattenIncludes :: IncludeSpecs -> [String]+flattenIncludes specs =+    includePathsQuote specs +++    includePathsQuoteImplicit specs +++    includePathsGlobal specs
+ GHC/Driver/LlvmConfigCache.hs view
@@ -0,0 +1,26 @@+-- | LLVM config cache+module GHC.Driver.LlvmConfigCache+  ( LlvmConfigCache+  , initLlvmConfigCache+  , readLlvmConfigCache+  )+where++import GHC.Prelude+import GHC.CmmToLlvm.Config++import System.IO.Unsafe++-- | Cache LLVM configuration read from files in top_dir+--+-- See Note [LLVM configuration] in GHC.CmmToLlvm.Config+--+-- Currently implemented with unsafe lazy IO. But it could be implemented with+-- an IORef as the exposed interface is in IO.+data LlvmConfigCache = LlvmConfigCache LlvmConfig++initLlvmConfigCache :: FilePath -> IO LlvmConfigCache+initLlvmConfigCache top_dir = pure $ LlvmConfigCache (unsafePerformIO $ initLlvmConfig top_dir)++readLlvmConfigCache :: LlvmConfigCache -> IO LlvmConfig+readLlvmConfigCache (LlvmConfigCache !config) = pure config
GHC/Driver/Main.hs view
@@ -1,2364 +1,2917 @@-{-# LANGUAGE BangPatterns #-}--{-# LANGUAGE NondecreasingIndentation #-}-{-# LANGUAGE GADTs #-}--{-# OPTIONS_GHC -fprof-auto-top #-}--------------------------------------------------------------------------------------- | Main API for compiling plain Haskell source code.------ This module implements compilation of a Haskell source. It is--- /not/ concerned with preprocessing of source files; this is handled--- in "GHC.Driver.Pipeline"------ There are various entry points depending on what mode we're in:--- "batch" mode (@--make@), "one-shot" mode (@-c@, @-S@ etc.), and--- "interactive" mode (GHCi). There are also entry points for--- individual passes: parsing, typechecking/renaming, desugaring, and--- simplification.------ All the functions here take an 'HscEnv' as a parameter, but none of--- them return a new one: 'HscEnv' is treated as an immutable value--- from here on in (although it has mutable components, for the--- caches).------ We use the Hsc monad to deal with warning messages consistently:--- specifically, while executing within an Hsc monad, warnings are--- collected. When a Hsc monad returns to an IO monad, the--- warnings are printed, or compilation aborts if the @-Werror@--- flag is enabled.------ (c) The GRASP/AQUA Project, Glasgow University, 1993-2000-------------------------------------------------------------------------------------module GHC.Driver.Main-    (-    -- * Making an HscEnv-      newHscEnv-    , newHscEnvWithHUG--    -- * Compiling complete source files-    , Messager, batchMsg, batchMultiMsg-    , HscBackendAction (..), HscRecompStatus (..)-    , initModDetails-    , hscMaybeWriteIface-    , hscCompileCmmFile--    , hscGenHardCode-    , hscInteractive--    -- * Running passes separately-    , hscRecompStatus-    , hscParse-    , hscTypecheckRename-    , hscTypecheckAndGetWarnings-    , hscDesugar-    , makeSimpleDetails-    , hscSimplify -- ToDo, shouldn't really export this-    , hscDesugarAndSimplify--    -- * Safe Haskell-    , hscCheckSafe-    , hscGetSafe--    -- * Support for interactive evaluation-    , hscParseIdentifier-    , hscTcRcLookupName-    , hscTcRnGetInfo-    , hscIsGHCiMonad-    , hscGetModuleInterface-    , hscRnImportDecls-    , hscTcRnLookupRdrName-    , hscStmt, hscParseStmtWithLocation, hscStmtWithLocation, hscParsedStmt-    , hscDecls, hscParseDeclsWithLocation, hscDeclsWithLocation, hscParsedDecls-    , hscParseModuleWithLocation-    , hscTcExpr, TcRnExprMode(..), hscImport, hscKcType-    , hscParseExpr-    , hscParseType-    , hscCompileCoreExpr-    , hscTidy---    -- * Low-level exports for hooks-    , hscCompileCoreExpr'-      -- We want to make sure that we export enough to be able to redefine-      -- hsc_typecheck in client code-    , hscParse', hscSimplify', hscDesugar', tcRnModule', doCodeGen-    , getHscEnv-    , hscSimpleIface'-    , oneShotMsg-    , dumpIfaceStats-    , ioMsgMaybe-    , showModuleIndex-    , hscAddSptEntries-    , writeInterfaceOnlyMode-    ) where--import GHC.Prelude--import GHC.Driver.Plugins-import GHC.Driver.Session-import GHC.Driver.Backend-import GHC.Driver.Env-import GHC.Driver.Errors-import GHC.Driver.Errors.Types-import GHC.Driver.CodeOutput-import GHC.Driver.Config.Logger   (initLogFlags)-import GHC.Driver.Config.Parser   (initParserOpts)-import GHC.Driver.Config.Stg.Ppr  (initStgPprOpts)-import GHC.Driver.Config.Stg.Pipeline (initStgPipelineOpts)-import GHC.Driver.Config.StgToCmm (initStgToCmmConfig)-import GHC.Driver.Config.Diagnostic-import GHC.Driver.Config.Tidy-import GHC.Driver.Hooks--import GHC.Runtime.Context-import GHC.Runtime.Interpreter ( addSptEntry )-import GHC.Runtime.Loader      ( initializePlugins )-import GHCi.RemoteTypes        ( ForeignHValue )-import GHC.ByteCode.Types--import GHC.Linker.Loader-import GHC.Linker.Types--import GHC.Hs-import GHC.Hs.Dump-import GHC.Hs.Stats         ( ppSourceStats )--import GHC.HsToCore--import GHC.StgToByteCode    ( byteCodeGen )--import GHC.IfaceToCore  ( typecheckIface )--import GHC.Iface.Load   ( ifaceStats, writeIface )-import GHC.Iface.Make-import GHC.Iface.Recomp-import GHC.Iface.Tidy-import GHC.Iface.Ext.Ast    ( mkHieFile )-import GHC.Iface.Ext.Types  ( getAsts, hie_asts, hie_module )-import GHC.Iface.Ext.Binary ( readHieFile, writeHieFile , hie_file_result)-import GHC.Iface.Ext.Debug  ( diffFile, validateScopes )--import GHC.Core-import GHC.Core.Tidy           ( tidyExpr )-import GHC.Core.Type           ( Type, Kind )-import GHC.Core.Lint           ( lintInteractiveExpr, endPassIO )-import GHC.Core.Multiplicity-import GHC.Core.Utils          ( exprType )-import GHC.Core.ConLike-import GHC.Core.Opt.Monad      ( CoreToDo (..))-import GHC.Core.Opt.Pipeline-import GHC.Core.TyCon-import GHC.Core.InstEnv-import GHC.Core.FamInstEnv-import GHC.Core.Rules-import GHC.Core.Stats-import GHC.Core.LateCC (addLateCostCentresPgm)---import GHC.CoreToStg.Prep-import GHC.CoreToStg    ( coreToStg )--import GHC.Parser.Errors.Types-import GHC.Parser-import GHC.Parser.Lexer as Lexer--import GHC.Tc.Module-import GHC.Tc.Utils.Monad-import GHC.Tc.Utils.Zonk    ( ZonkFlexi (DefaultFlexi) )--import GHC.Stg.Syntax-import GHC.Stg.Pipeline ( stg2stg, StgCgInfos )--import GHC.Builtin.Utils-import GHC.Builtin.Names-import GHC.Builtin.Uniques ( mkPseudoUniqueE )--import qualified GHC.StgToCmm as StgToCmm ( codeGen )-import GHC.StgToCmm.Types (CmmCgInfos (..), ModuleLFInfos)--import GHC.Cmm-import GHC.Cmm.Parser       ( parseCmmFile )-import GHC.Cmm.Info.Build-import GHC.Cmm.Pipeline-import GHC.Cmm.Info--import GHC.Unit-import GHC.Unit.Env-import GHC.Unit.Finder-import GHC.Unit.External-import GHC.Unit.Module.ModDetails-import GHC.Unit.Module.ModGuts-import GHC.Unit.Module.ModIface-import GHC.Unit.Module.ModSummary-import GHC.Unit.Module.Graph-import GHC.Unit.Module.Imported-import GHC.Unit.Module.Deps-import GHC.Unit.Module.Status-import GHC.Unit.Home.ModInfo--import GHC.Types.Id-import GHC.Types.SourceError-import GHC.Types.SafeHaskell-import GHC.Types.ForeignStubs-import GHC.Types.Var.Env       ( emptyTidyEnv )-import GHC.Types.Error-import GHC.Types.Fixity.Env-import GHC.Types.CostCentre-import GHC.Types.IPE-import GHC.Types.SourceFile-import GHC.Types.SrcLoc-import GHC.Types.Name-import GHC.Types.Name.Cache ( initNameCache )-import GHC.Types.Name.Reader-import GHC.Types.Name.Ppr-import GHC.Types.TyThing-import GHC.Types.HpcInfo--import GHC.Utils.Fingerprint ( Fingerprint )-import GHC.Utils.Panic-import GHC.Utils.Panic.Plain-import GHC.Utils.Error-import GHC.Utils.Outputable-import GHC.Utils.Misc-import GHC.Utils.Logger-import GHC.Utils.TmpFs--import GHC.Data.FastString-import GHC.Data.Bag-import GHC.Data.StringBuffer-import qualified GHC.Data.Stream as Stream-import GHC.Data.Stream (Stream)-import qualified GHC.SysTools--import Data.Data hiding (Fixity, TyCon)-import Data.List        ( nub, isPrefixOf, partition )-import Control.Monad-import Data.IORef-import System.FilePath as FilePath-import System.Directory-import System.IO (fixIO)-import qualified Data.Set as S-import Data.Set (Set)-import Data.Functor-import Control.DeepSeq (force)-import Data.Bifunctor (first)-import GHC.Data.Maybe-import GHC.Driver.Env.KnotVars-import GHC.Types.Name.Set (NonCaffySet)-import GHC.Driver.GenerateCgIPEStub (generateCgIPEStub)-import Data.List.NonEmpty (NonEmpty ((:|)))-import GHC.Stg.InferTags.TagSig (seqTagSig)-import GHC.Types.Unique.FM---{- **********************************************************************-%*                                                                      *-                Initialisation-%*                                                                      *-%********************************************************************* -}--newHscEnv :: DynFlags -> IO HscEnv-newHscEnv dflags = newHscEnvWithHUG dflags (homeUnitId_ dflags) home_unit_graph-  where-    home_unit_graph = unitEnv_singleton-                        (homeUnitId_ dflags)-                        (mkHomeUnitEnv dflags emptyHomePackageTable Nothing)--newHscEnvWithHUG :: DynFlags -> UnitId -> HomeUnitGraph -> IO HscEnv-newHscEnvWithHUG top_dynflags cur_unit home_unit_graph = do-    nc_var  <- initNameCache 'r' knownKeyNames-    fc_var  <- initFinderCache-    logger  <- initLogger-    tmpfs   <- initTmpFs-    let dflags = homeUnitEnv_dflags $ unitEnv_lookup cur_unit home_unit_graph-    unit_env <- initUnitEnv cur_unit home_unit_graph (ghcNameVersion dflags) (targetPlatform dflags)-    return HscEnv { hsc_dflags = top_dynflags-                  , hsc_logger         = setLogFlags logger (initLogFlags top_dynflags)-                  ,  hsc_targets        = []-                  ,  hsc_mod_graph      = emptyMG-                  ,  hsc_IC             = emptyInteractiveContext dflags-                  ,  hsc_NC             = nc_var-                  ,  hsc_FC             = fc_var-                  ,  hsc_type_env_vars  = emptyKnotVars-                  ,  hsc_interp         = Nothing-                  ,  hsc_unit_env       = unit_env-                  ,  hsc_plugins        = emptyPlugins-                  ,  hsc_hooks          = emptyHooks-                  ,  hsc_tmpfs          = tmpfs-                  }---- -------------------------------------------------------------------------------getDiagnostics :: Hsc (Messages GhcMessage)-getDiagnostics = Hsc $ \_ w -> return (w, w)--clearDiagnostics :: Hsc ()-clearDiagnostics = Hsc $ \_ _ -> return ((), emptyMessages)--logDiagnostics :: Messages GhcMessage -> Hsc ()-logDiagnostics w = Hsc $ \_ w0 -> return ((), w0 `unionMessages` w)--getHscEnv :: Hsc HscEnv-getHscEnv = Hsc $ \e w -> return (e, w)--handleWarnings :: Hsc ()-handleWarnings = do-    diag_opts <- initDiagOpts <$> getDynFlags-    logger <- getLogger-    w <- getDiagnostics-    liftIO $ printOrThrowDiagnostics logger diag_opts w-    clearDiagnostics---- | log warning in the monad, and if there are errors then--- throw a SourceError exception.-logWarningsReportErrors :: (Messages PsWarning, Messages PsError) -> Hsc ()-logWarningsReportErrors (warnings,errors) = do-    logDiagnostics (GhcPsMessage <$> warnings)-    when (not $ isEmptyMessages errors) $ throwErrors (GhcPsMessage <$> errors)---- | Log warnings and throw errors, assuming the messages--- contain at least one error (e.g. coming from PFailed)-handleWarningsThrowErrors :: (Messages PsWarning, Messages PsError) -> Hsc a-handleWarningsThrowErrors (warnings, errors) = do-    diag_opts <- initDiagOpts <$> getDynFlags-    logDiagnostics (GhcPsMessage <$> warnings)-    logger <- getLogger-    let (wWarns, wErrs) = partitionMessages warnings-    liftIO $ printMessages logger diag_opts wWarns-    throwErrors $ fmap GhcPsMessage $ errors `unionMessages` wErrs---- | Deal with errors and warnings returned by a compilation step------ In order to reduce dependencies to other parts of the compiler, functions--- outside the "main" parts of GHC return warnings and errors as a parameter--- and signal success via by wrapping the result in a 'Maybe' type. This--- function logs the returned warnings and propagates errors as exceptions--- (of type 'SourceError').------ This function assumes the following invariants:------  1. If the second result indicates success (is of the form 'Just x'),---     there must be no error messages in the first result.------  2. If there are no error messages, but the second result indicates failure---     there should be warnings in the first result. That is, if the action---     failed, it must have been due to the warnings (i.e., @-Werror@).-ioMsgMaybe :: IO (Messages GhcMessage, Maybe a) -> Hsc a-ioMsgMaybe ioA = do-    (msgs, mb_r) <- liftIO ioA-    let (warns, errs) = partitionMessages msgs-    logDiagnostics warns-    case mb_r of-        Nothing -> throwErrors errs-        Just r  -> assert (isEmptyMessages errs ) return r---- | like ioMsgMaybe, except that we ignore error messages and return--- 'Nothing' instead.-ioMsgMaybe' :: IO (Messages GhcMessage, Maybe a) -> Hsc (Maybe a)-ioMsgMaybe' ioA = do-    (msgs, mb_r) <- liftIO $ ioA-    logDiagnostics (mkMessages $ getWarningMessages msgs)-    return mb_r---- -------------------------------------------------------------------------------- | Lookup things in the compiler's environment--hscTcRnLookupRdrName :: HscEnv -> LocatedN RdrName -> IO [Name]-hscTcRnLookupRdrName hsc_env0 rdr_name-  = runInteractiveHsc hsc_env0 $-    do { hsc_env <- getHscEnv-       ; ioMsgMaybe $ hoistTcRnMessage $ tcRnLookupRdrName hsc_env rdr_name }--hscTcRcLookupName :: HscEnv -> Name -> IO (Maybe TyThing)-hscTcRcLookupName hsc_env0 name = runInteractiveHsc hsc_env0 $ do-  hsc_env <- getHscEnv-  ioMsgMaybe' $ hoistTcRnMessage $ tcRnLookupName hsc_env name-      -- ignore errors: the only error we're likely to get is-      -- "name not found", and the Maybe in the return type-      -- is used to indicate that.--hscTcRnGetInfo :: HscEnv -> Name-               -> IO (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))-hscTcRnGetInfo hsc_env0 name-  = runInteractiveHsc hsc_env0 $-    do { hsc_env <- getHscEnv-       ; ioMsgMaybe' $ hoistTcRnMessage $ tcRnGetInfo hsc_env name }--hscIsGHCiMonad :: HscEnv -> String -> IO Name-hscIsGHCiMonad hsc_env name-  = runHsc hsc_env $ ioMsgMaybe $ hoistTcRnMessage $ isGHCiMonad hsc_env name--hscGetModuleInterface :: HscEnv -> Module -> IO ModIface-hscGetModuleInterface hsc_env0 mod = runInteractiveHsc hsc_env0 $ do-  hsc_env <- getHscEnv-  ioMsgMaybe $ hoistTcRnMessage $ getModuleInterface hsc_env mod---- -------------------------------------------------------------------------------- | Rename some import declarations-hscRnImportDecls :: HscEnv -> [LImportDecl GhcPs] -> IO GlobalRdrEnv-hscRnImportDecls hsc_env0 import_decls = runInteractiveHsc hsc_env0 $ do-  hsc_env <- getHscEnv-  ioMsgMaybe $ hoistTcRnMessage $ tcRnImportDecls hsc_env import_decls---- -------------------------------------------------------------------------------- | parse a file, returning the abstract syntax--hscParse :: HscEnv -> ModSummary -> IO HsParsedModule-hscParse hsc_env mod_summary = runHsc hsc_env $ hscParse' mod_summary---- internal version, that doesn't fail due to -Werror-hscParse' :: ModSummary -> Hsc HsParsedModule-hscParse' mod_summary- | Just r <- ms_parsed_mod mod_summary = return r- | otherwise = do-    dflags <- getDynFlags-    logger <- getLogger-    {-# SCC "Parser" #-} withTiming logger-                (text "Parser"<+>brackets (ppr $ ms_mod mod_summary))-                (const ()) $ do-    let src_filename  = ms_hspp_file mod_summary-        maybe_src_buf = ms_hspp_buf  mod_summary--    --------------------------  Parser  -----------------    -- sometimes we already have the buffer in memory, perhaps-    -- because we needed to parse the imports out of it, or get the-    -- module name.-    buf <- case maybe_src_buf of-               Just b  -> return b-               Nothing -> liftIO $ hGetStringBuffer src_filename--    let loc = mkRealSrcLoc (mkFastString src_filename) 1 1--    let diag_opts = initDiagOpts dflags-    when (wopt Opt_WarnUnicodeBidirectionalFormatCharacters dflags) $ do-      case checkBidirectionFormatChars (PsLoc loc (BufPos 0)) buf of-        Nothing -> pure ()-        Just chars@((eloc,chr,_) :| _) ->-          let span = mkSrcSpanPs $ mkPsSpan eloc (advancePsLoc eloc chr)-          in logDiagnostics $ singleMessage $-               mkPlainMsgEnvelope diag_opts span $-               GhcPsMessage $ PsWarnBidirectionalFormatChars chars--    let parseMod | HsigFile == ms_hsc_src mod_summary-                 = parseSignature-                 | otherwise = parseModule--    case unP parseMod (initParserState (initParserOpts dflags) buf loc) of-        PFailed pst ->-            handleWarningsThrowErrors (getPsMessages pst)-        POk pst rdr_module -> do-            liftIO $ putDumpFileMaybe logger Opt_D_dump_parsed "Parser"-                        FormatHaskell (ppr rdr_module)-            liftIO $ putDumpFileMaybe logger Opt_D_dump_parsed_ast "Parser AST"-                        FormatHaskell (showAstData NoBlankSrcSpan-                                                   NoBlankEpAnnotations-                                                   rdr_module)-            liftIO $ putDumpFileMaybe logger Opt_D_source_stats "Source Statistics"-                        FormatText (ppSourceStats False rdr_module)--            -- To get the list of extra source files, we take the list-            -- that the parser gave us,-            --   - eliminate files beginning with '<'.  gcc likes to use-            --     pseudo-filenames like "<built-in>" and "<command-line>"-            --   - normalise them (eliminate differences between ./f and f)-            --   - filter out the preprocessed source file-            --   - filter out anything beginning with tmpdir-            --   - remove duplicates-            --   - filter out the .hs/.lhs source filename if we have one-            ---            let n_hspp  = FilePath.normalise src_filename-                TempDir tmp_dir = tmpDir dflags-                srcs0 = nub $ filter (not . (tmp_dir `isPrefixOf`))-                            $ filter (not . (== n_hspp))-                            $ map FilePath.normalise-                            $ filter (not . isPrefixOf "<")-                            $ map unpackFS-                            $ srcfiles pst-                srcs1 = case ml_hs_file (ms_location mod_summary) of-                          Just f  -> filter (/= FilePath.normalise f) srcs0-                          Nothing -> srcs0--            -- sometimes we see source files from earlier-            -- preprocessing stages that cannot be found, so just-            -- filter them out:-            srcs2 <- liftIO $ filterM doesFileExist srcs1--            let res = HsParsedModule {-                      hpm_module    = rdr_module,-                      hpm_src_files = srcs2-                   }--            -- apply parse transformation of plugins-            let applyPluginAction p opts-                  = parsedResultAction p opts mod_summary-            hsc_env <- getHscEnv-            (ParsedResult transformed (PsMessages warns errs)) <--              withPlugins (hsc_plugins hsc_env) applyPluginAction-                (ParsedResult res (uncurry PsMessages $ getPsMessages pst))--            logDiagnostics (GhcPsMessage <$> warns)-            unless (isEmptyMessages errs) $ throwErrors (GhcPsMessage <$> errs)--            return transformed--checkBidirectionFormatChars :: PsLoc -> StringBuffer -> Maybe (NonEmpty (PsLoc, Char, String))-checkBidirectionFormatChars start_loc sb-  | containsBidirectionalFormatChar sb = Just $ go start_loc sb-  | otherwise = Nothing-  where-    go :: PsLoc -> StringBuffer -> NonEmpty (PsLoc, Char, String)-    go loc sb-      | atEnd sb = panic "checkBidirectionFormatChars: no char found"-      | otherwise = case nextChar sb of-          (chr, sb)-            | Just desc <- lookup chr bidirectionalFormatChars ->-                (loc, chr, desc) :| go1 (advancePsLoc loc chr) sb-            | otherwise -> go (advancePsLoc loc chr) sb--    go1 :: PsLoc -> StringBuffer -> [(PsLoc, Char, String)]-    go1 loc sb-      | atEnd sb = []-      | otherwise = case nextChar sb of-          (chr, sb)-            | Just desc <- lookup chr bidirectionalFormatChars ->-                (loc, chr, desc) : go1 (advancePsLoc loc chr) sb-            | otherwise -> go1 (advancePsLoc loc chr) sb----- -------------------------------------------------------------------------------- | If the renamed source has been kept, extract it. Dump it if requested.---extract_renamed_stuff :: ModSummary -> TcGblEnv -> Hsc RenamedStuff-extract_renamed_stuff mod_summary tc_result = do-    let rn_info = getRenamedStuff tc_result--    dflags <- getDynFlags-    logger <- getLogger-    liftIO $ putDumpFileMaybe logger Opt_D_dump_rn_ast "Renamer"-                FormatHaskell (showAstData NoBlankSrcSpan NoBlankEpAnnotations rn_info)--    -- Create HIE files-    when (gopt Opt_WriteHie dflags) $ do-        -- I assume this fromJust is safe because `-fwrite-hie-file`-        -- enables the option which keeps the renamed source.-        hieFile <- mkHieFile mod_summary tc_result (fromJust rn_info)-        let out_file = ml_hie_file $ ms_location mod_summary-        liftIO $ writeHieFile out_file hieFile-        liftIO $ putDumpFileMaybe logger Opt_D_dump_hie "HIE AST" FormatHaskell (ppr $ hie_asts hieFile)--        -- Validate HIE files-        when (gopt Opt_ValidateHie dflags) $ do-            hs_env <- Hsc $ \e w -> return (e, w)-            liftIO $ do-              -- Validate Scopes-              case validateScopes (hie_module hieFile) $ getAsts $ hie_asts hieFile of-                  [] -> putMsg logger $ text "Got valid scopes"-                  xs -> do-                    putMsg logger $ text "Got invalid scopes"-                    mapM_ (putMsg logger) xs-              -- Roundtrip testing-              file' <- readHieFile (hsc_NC hs_env) out_file-              case diffFile hieFile (hie_file_result file') of-                [] ->-                  putMsg logger $ text "Got no roundtrip errors"-                xs -> do-                  putMsg logger $ text "Got roundtrip errors"-                  let logger' = updateLogFlags logger (log_set_dopt Opt_D_ppr_debug)-                  mapM_ (putMsg logger') xs-    return rn_info----- -------------------------------------------------------------------------------- | Rename and typecheck a module, additionally returning the renamed syntax-hscTypecheckRename :: HscEnv -> ModSummary -> HsParsedModule-                   -> IO (TcGblEnv, RenamedStuff)-hscTypecheckRename hsc_env mod_summary rdr_module = runHsc hsc_env $-    hsc_typecheck True mod_summary (Just rdr_module)---- | Do Typechecking without throwing SourceError exception with -Werror-hscTypecheckAndGetWarnings :: HscEnv ->  ModSummary -> IO (FrontendResult, WarningMessages)-hscTypecheckAndGetWarnings hsc_env summary = runHsc' hsc_env $ do-  case hscFrontendHook (hsc_hooks hsc_env) of-    Nothing -> FrontendTypecheck . fst <$> hsc_typecheck False summary Nothing-    Just h  -> h summary---- | A bunch of logic piled around @tcRnModule'@, concerning a) backpack--- b) concerning dumping rename info and hie files. It would be nice to further--- separate this stuff out, probably in conjunction better separating renaming--- and type checking (#17781).-hsc_typecheck :: Bool -- ^ Keep renamed source?-              -> ModSummary -> Maybe HsParsedModule-              -> Hsc (TcGblEnv, RenamedStuff)-hsc_typecheck keep_rn mod_summary mb_rdr_module = do-    hsc_env <- getHscEnv-    let hsc_src = ms_hsc_src mod_summary-        dflags = hsc_dflags hsc_env-        home_unit = hsc_home_unit hsc_env-        outer_mod = ms_mod mod_summary-        mod_name = moduleName outer_mod-        outer_mod' = mkHomeModule home_unit mod_name-        inner_mod = homeModuleNameInstantiation home_unit mod_name-        src_filename  = ms_hspp_file mod_summary-        real_loc = realSrcLocSpan $ mkRealSrcLoc (mkFastString src_filename) 1 1-        keep_rn' = gopt Opt_WriteHie dflags || keep_rn-    massert (isHomeModule home_unit outer_mod)-    tc_result <- if hsc_src == HsigFile && not (isHoleModule inner_mod)-        then ioMsgMaybe $ hoistTcRnMessage $ tcRnInstantiateSignature hsc_env outer_mod' real_loc-        else-         do hpm <- case mb_rdr_module of-                    Just hpm -> return hpm-                    Nothing -> hscParse' mod_summary-            tc_result0 <- tcRnModule' mod_summary keep_rn' hpm-            if hsc_src == HsigFile-                then do (iface, _) <- liftIO $ hscSimpleIface hsc_env tc_result0 mod_summary-                        ioMsgMaybe $ hoistTcRnMessage $-                            tcRnMergeSignatures hsc_env hpm tc_result0 iface-                else return tc_result0-    -- TODO are we extracting anything when we merely instantiate a signature?-    -- If not, try to move this into the "else" case above.-    rn_info <- extract_renamed_stuff mod_summary tc_result-    return (tc_result, rn_info)---- wrapper around tcRnModule to handle safe haskell extras-tcRnModule' :: ModSummary -> Bool -> HsParsedModule-            -> Hsc TcGblEnv-tcRnModule' sum save_rn_syntax mod = do-    hsc_env <- getHscEnv-    dflags  <- getDynFlags--    let diag_opts = initDiagOpts dflags-    -- -Wmissing-safe-haskell-mode-    when (not (safeHaskellModeEnabled dflags)-          && wopt Opt_WarnMissingSafeHaskellMode dflags) $-        logDiagnostics $ singleMessage $-        mkPlainMsgEnvelope diag_opts (getLoc (hpm_module mod)) $-        GhcDriverMessage $ DriverMissingSafeHaskellMode (ms_mod sum)--    tcg_res <- {-# SCC "Typecheck-Rename" #-}-               ioMsgMaybe $ hoistTcRnMessage $-                   tcRnModule hsc_env sum-                     save_rn_syntax mod--    -- See Note [Safe Haskell Overlapping Instances Implementation]-    -- although this is used for more than just that failure case.-    tcSafeOK <- liftIO $ readIORef (tcg_safe_infer tcg_res)-    whyUnsafe <- liftIO $ readIORef (tcg_safe_infer_reasons tcg_res)-    let allSafeOK = safeInferred dflags && tcSafeOK--    -- end of the safe haskell line, how to respond to user?-    if not (safeHaskellOn dflags)-         || (safeInferOn dflags && not allSafeOK)-      -- if safe Haskell off or safe infer failed, mark unsafe-      then markUnsafeInfer tcg_res whyUnsafe--      -- module (could be) safe, throw warning if needed-      else do-          tcg_res' <- hscCheckSafeImports tcg_res-          safe <- liftIO $ readIORef (tcg_safe_infer tcg_res')-          when safe $-            case wopt Opt_WarnSafe dflags of-              True-                | safeHaskell dflags == Sf_Safe -> return ()-                | otherwise -> (logDiagnostics $ singleMessage $-                       mkPlainMsgEnvelope diag_opts (warnSafeOnLoc dflags) $-                       GhcDriverMessage $ DriverInferredSafeModule (tcg_mod tcg_res'))-              False | safeHaskell dflags == Sf_Trustworthy &&-                      wopt Opt_WarnTrustworthySafe dflags ->-                      (logDiagnostics $ singleMessage $-                       mkPlainMsgEnvelope diag_opts (trustworthyOnLoc dflags) $-                       GhcDriverMessage $ DriverMarkedTrustworthyButInferredSafe (tcg_mod tcg_res'))-              False -> return ()-          return tcg_res'---- | Convert a typechecked module to Core-hscDesugar :: HscEnv -> ModSummary -> TcGblEnv -> IO ModGuts-hscDesugar hsc_env mod_summary tc_result =-    runHsc hsc_env $ hscDesugar' (ms_location mod_summary) tc_result--hscDesugar' :: ModLocation -> TcGblEnv -> Hsc ModGuts-hscDesugar' mod_location tc_result = do-    hsc_env <- getHscEnv-    ioMsgMaybe $ hoistDsMessage $-      {-# SCC "deSugar" #-}-      deSugar hsc_env mod_location tc_result---- | Make a 'ModDetails' from the results of typechecking. Used when--- typechecking only, as opposed to full compilation.-makeSimpleDetails :: Logger -> TcGblEnv -> IO ModDetails-makeSimpleDetails logger tc_result = mkBootModDetailsTc logger tc_result---{- **********************************************************************-%*                                                                      *-                The main compiler pipeline-%*                                                                      *-%********************************************************************* -}--{--                   ---------------------------------                        The compilation proper-                   ----------------------------------It's the task of the compilation proper to compile Haskell, hs-boot and core-files to either byte-code, hard-code (C, asm, LLVM, etc.) or to nothing at all-(the module is still parsed and type-checked. This feature is mostly used by-IDE's and the likes). Compilation can happen in either 'one-shot', 'batch',-'nothing', or 'interactive' mode. 'One-shot' mode targets hard-code, 'batch'-mode targets hard-code, 'nothing' mode targets nothing and 'interactive' mode-targets byte-code.--The modes are kept separate because of their different types and meanings:-- * In 'one-shot' mode, we're only compiling a single file and can therefore- discard the new ModIface and ModDetails. This is also the reason it only- targets hard-code; compiling to byte-code or nothing doesn't make sense when- we discard the result.-- * 'Batch' mode is like 'one-shot' except that we keep the resulting ModIface- and ModDetails. 'Batch' mode doesn't target byte-code since that require us to- return the newly compiled byte-code.-- * 'Nothing' mode has exactly the same type as 'batch' mode but they're still- kept separate. This is because compiling to nothing is fairly special: We- don't output any interface files, we don't run the simplifier and we don't- generate any code.-- * 'Interactive' mode is similar to 'batch' mode except that we return the- compiled byte-code together with the ModIface and ModDetails.--Trying to compile a hs-boot file to byte-code will result in a run-time error.-This is the only thing that isn't caught by the type-system.--}---type Messager = HscEnv -> (Int,Int) -> RecompileRequired -> ModuleGraphNode -> IO ()---- | Do the recompilation avoidance checks for both one-shot and --make modes--- This function is the *only* place in the compiler where we decide whether to--- recompile a module or not!-hscRecompStatus :: Maybe Messager-                -> HscEnv-                -> ModSummary-                -> Maybe ModIface-                -> Maybe Linkable-                -> (Int,Int)-                -> IO HscRecompStatus-hscRecompStatus-    mHscMessage hsc_env mod_summary mb_old_iface old_linkable mod_index-  = do-    let-        msg what = case mHscMessage of-          Just hscMessage -> hscMessage hsc_env mod_index what (ModuleNode [] mod_summary)-          Nothing -> return ()--    -- First check to see if the interface file agrees with the-    -- source file.-    ---    -- Save the interface that comes back from checkOldIface.-    -- In one-shot mode we don't have the old iface until this-    -- point, when checkOldIface reads it from the disk.-    recomp_if_result-          <- {-# SCC "checkOldIface" #-}-             liftIO $ checkOldIface hsc_env mod_summary mb_old_iface-    case recomp_if_result of-      OutOfDateItem reason mb_checked_iface -> do-        msg $ NeedsRecompile reason-        return $ HscRecompNeeded $ fmap (mi_iface_hash . mi_final_exts) mb_checked_iface-      UpToDateItem checked_iface -> do-        let lcl_dflags = ms_hspp_opts mod_summary-        case backend lcl_dflags of-          -- No need for a linkable, we're good to go-          NoBackend -> do-            msg $ UpToDate-            return $ HscUpToDate checked_iface Nothing-          -- Do need linkable-          _ -> do-            -- Check to see whether the expected build products already exist.-            -- If they don't exists then we trigger recompilation.-            recomp_linkable_result <- case () of-               -- Interpreter can use either already loaded bytecode or loaded object code-               _ | Interpreter <- backend lcl_dflags -> do-                     let res = checkByteCode old_linkable-                     case res of-                       UpToDateItem _ -> pure res-                       _ -> liftIO $ checkObjects lcl_dflags old_linkable mod_summary-                 -- Need object files for making object files-                 | backendProducesObject (backend lcl_dflags) -> liftIO $ checkObjects lcl_dflags old_linkable mod_summary-                 | otherwise -> pprPanic "hscRecompStatus" (text $ show $ backend lcl_dflags)-            case recomp_linkable_result of-              UpToDateItem linkable -> do-                msg $ UpToDate-                return $ HscUpToDate checked_iface $ Just linkable-              OutOfDateItem reason _ -> do-                msg $ NeedsRecompile reason-                return $ HscRecompNeeded $ Just $ mi_iface_hash $ mi_final_exts $ checked_iface---- | Check that the .o files produced by compilation are already up-to-date--- or not.-checkObjects :: DynFlags -> Maybe Linkable -> ModSummary -> IO (MaybeValidated Linkable)-checkObjects dflags mb_old_linkable summary = do-  let-    dt_enabled  = gopt Opt_BuildDynamicToo dflags-    this_mod    = ms_mod summary-    mb_obj_date = ms_obj_date summary-    mb_dyn_obj_date = ms_dyn_obj_date summary-    mb_if_date  = ms_iface_date summary-    obj_fn      = ml_obj_file (ms_location summary)-    -- dynamic-too *also* produces the dyn_o_file, so have to check-    -- that's there, and if it's not, regenerate both .o and-    -- .dyn_o-    checkDynamicObj k = if dt_enabled-      then case (>=) <$> mb_dyn_obj_date <*> mb_if_date of-        Just True -> k-        _ -> return $ outOfDateItemBecause MissingDynObjectFile Nothing-      -- Not in dynamic-too mode-      else k--  checkDynamicObj $-    case (,) <$> mb_obj_date <*> mb_if_date of-      Just (obj_date, if_date)-        | obj_date >= if_date ->-            case mb_old_linkable of-              Just old_linkable-                | isObjectLinkable old_linkable, linkableTime old_linkable == obj_date-                -> return $ UpToDateItem old_linkable-              _ -> UpToDateItem <$> findObjectLinkable this_mod obj_fn obj_date-      _ -> return $ outOfDateItemBecause MissingObjectFile Nothing---- | Check to see if we can reuse the old linkable, by this point we will--- have just checked that the old interface matches up with the source hash, so--- no need to check that again here-checkByteCode :: Maybe Linkable -> MaybeValidated Linkable-checkByteCode mb_old_linkable =-  case mb_old_linkable of-    Just old_linkable-      | not (isObjectLinkable old_linkable)-      -> UpToDateItem old_linkable-    _ -> outOfDateItemBecause MissingBytecode Nothing------------------------------------------------------------------- Compilers-------------------------------------------------------------------- Knot tying!  See Note [Knot-tying typecheckIface]--- See Note [ModDetails and --make mode]-initModDetails :: HscEnv -> ModSummary -> ModIface -> IO ModDetails-initModDetails hsc_env mod_summary iface =-  fixIO $ \details' -> do-    let act hpt  = addToHpt hpt (ms_mod_name mod_summary)-                                (HomeModInfo iface details' Nothing)-    let hsc_env' = hscUpdateHPT act hsc_env-    -- NB: This result is actually not that useful-    -- in one-shot mode, since we're not going to do-    -- any further typechecking.  It's much more useful-    -- in make mode, since this HMI will go into the HPT.-    genModDetails hsc_env' iface---{--Note [ModDetails and --make mode]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-An interface file consists of two parts--* The `ModIface` which ends up getting written to disk.-  The `ModIface` is a completely acyclic tree, which can be serialised-  and de-serialised completely straightforwardly.  The `ModIface` is-  also the structure that is finger-printed for recompilation control.--* The `ModDetails` which provides a more structured view that is suitable-  for usage during compilation.  The `ModDetails` is heavily cyclic:-  An `Id` contains a `Type`, which mentions a `TyCon` that contains kind-  that mentions other `TyCons`; the `Id` also includes an unfolding that-  in turn mentions more `Id`s;  And so on.--The `ModIface` can be created from the `ModDetails` and the `ModDetails` from-a `ModIface`.--During tidying, just before interfaces are written to disk,-the ModDetails is calculated and then converted into a ModIface (see GHC.Iface.Make.mkIface_).-Then when GHC needs to restart typechecking from a certain point it can read the-interface file, and regenerate the ModDetails from the ModIface (see GHC.IfaceToCore.typecheckIface).-The key part about the loading is that the ModDetails is regenerated lazily-from the ModIface, so that there's only a detailed in-memory representation-for declarations which are actually used from the interface. This mode is-also used when reading interface files from external packages.--In the old --make mode implementation, the interface was written after compiling a module-but the in-memory ModDetails which was used to compute the ModIface was retained.-The result was that --make mode used much more memory than `-c` mode, because a large amount of-information about a module would be kept in the ModDetails but never used.--The new idea is that even in `--make` mode, when there is an in-memory `ModDetails`-at hand, we re-create the `ModDetails` from the `ModIface`. Doing this means that-we only have to keep the `ModIface` decls in memory and then lazily load-detailed representations if needed. It turns out this makes a really big difference-to memory usage, halving maximum memory used in some cases.--See !5492 and #13586--}---- Runs the post-typechecking frontend (desugar and simplify). We want to--- generate most of the interface as late as possible. This gets us up-to-date--- and good unfoldings and other info in the interface file.------ We might create a interface right away, in which case we also return the--- updated HomeModInfo. But we might also need to run the backend first. In the--- later case Status will be HscRecomp and we return a function from ModIface ->--- HomeModInfo.------ HscRecomp in turn will carry the information required to compute a interface--- when passed the result of the code generator. So all this can and is done at--- the call site of the backend code gen if it is run.-hscDesugarAndSimplify :: ModSummary-       -> FrontendResult-       -> Messages GhcMessage-       -> Maybe Fingerprint-       -> Hsc HscBackendAction-hscDesugarAndSimplify summary (FrontendTypecheck tc_result) tc_warnings mb_old_hash = do-  hsc_env <- getHscEnv-  dflags <- getDynFlags-  logger <- getLogger-  let bcknd  = backend dflags-      hsc_src = ms_hsc_src summary-      diag_opts = initDiagOpts dflags--  -- Desugar, if appropriate-  ---  -- We usually desugar even when we are not generating code, otherwise we-  -- would miss errors thrown by the desugaring (see #10600). The only-  -- exceptions are when the Module is Ghc.Prim or when it is not a-  -- HsSrcFile Module.-  mb_desugar <--      if ms_mod summary /= gHC_PRIM && hsc_src == HsSrcFile-      then Just <$> hscDesugar' (ms_location summary) tc_result-      else pure Nothing--  -- Report the warnings from both typechecking and desugar together-  w <- getDiagnostics-  liftIO $ printOrThrowDiagnostics logger diag_opts (unionMessages tc_warnings w)-  clearDiagnostics--  -- Simplify, if appropriate, and (whether we simplified or not) generate an-  -- interface file.-  case mb_desugar of-      -- Just cause we desugared doesn't mean we are generating code, see above.-      Just desugared_guts | bcknd /= NoBackend -> do-          plugins <- liftIO $ readIORef (tcg_th_coreplugins tc_result)-          simplified_guts <- hscSimplify' plugins desugared_guts--          (cg_guts, details) <--              liftIO $ hscTidy hsc_env simplified_guts--          let !partial_iface =-                {-# SCC "GHC.Driver.Main.mkPartialIface" #-}-                -- This `force` saves 2M residency in test T10370-                -- See Note [Avoiding space leaks in toIface*] for details.-                force (mkPartialIface hsc_env details summary simplified_guts)--          return HscRecomp { hscs_guts = cg_guts,-                             hscs_mod_location = ms_location summary,-                             hscs_partial_iface = partial_iface,-                             hscs_old_iface_hash = mb_old_hash-                           }--      -- We are not generating code, so we can skip simplification-      -- and generate a simple interface.-      _ -> do-        (iface, _details) <- liftIO $-          hscSimpleIface hsc_env tc_result summary--        liftIO $ hscMaybeWriteIface logger dflags True iface mb_old_hash (ms_location summary)--        return $ HscUpdate iface--{--Note [Writing interface files]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We write one interface file per module and per compilation, except with--dynamic-too where we write two interface files (non-dynamic and dynamic).--We can write two kinds of interfaces (see Note [Interface file stages] in-"GHC.Driver.Types"):--   * simple interface: interface generated after the core pipeline--   * full interface: simple interface completed with information from the-     backend--Depending on the situation, we write one or the other (using-`hscMaybeWriteIface`). We must be careful with `-dynamic-too` because only the-backend is run twice, so if we write a simple interface we need to write both-the non-dynamic and the dynamic interfaces at the same time (with the same-contents).--Cases for which we generate simple interfaces:--   * GHC.Driver.Main.hscDesugarAndSimplify: when a compilation does NOT require (re)compilation-   of the hard code--   * GHC.Driver.Pipeline.compileOne': when we run in One Shot mode and target-   bytecode (if interface writing is forced).--   * GHC.Driver.Backpack uses simple interfaces for indefinite units-   (units with module holes). It writes them indirectly by forcing the-   -fwrite-interface flag while setting backend to NoBackend.--Cases for which we generate full interfaces:--   * GHC.Driver.Pipeline.runPhase: when we must be compiling to regular hard-   code and/or require recompilation.--By default interface file names are derived from module file names by adding-suffixes. The interface file name can be overloaded with "-ohi", except when-`-dynamic-too` is used.---}---- | Write interface files-hscMaybeWriteIface-  :: Logger-  -> DynFlags-  -> Bool-  -- ^ Is this a simple interface generated after the core pipeline, or one-  -- with information from the backend? See: Note [Writing interface files]-  -> ModIface-  -> Maybe Fingerprint-  -- ^ The old interface hash, used to decide if we need to actually write the-  -- new interface.-  -> ModLocation-  -> IO ()-hscMaybeWriteIface logger dflags is_simple iface old_iface mod_location = do-    let force_write_interface = gopt Opt_WriteInterface dflags-        write_interface = case backend dflags of-                            NoBackend    -> False-                            Interpreter  -> False-                            _            -> True--        write_iface dflags' iface =-          let !iface_name = if dynamicNow dflags' then ml_dyn_hi_file mod_location else ml_hi_file mod_location-              profile     = targetProfile dflags'-          in-          {-# SCC "writeIface" #-}-          withTiming logger-              (text "WriteIface"<+>brackets (text iface_name))-              (const ())-              (writeIface logger profile iface_name iface)--    if (write_interface || force_write_interface) then do--      -- FIXME: with -dynamic-too, "change" is only meaningful for the-      -- non-dynamic interface, not for the dynamic one. We should have another-      -- flag for the dynamic interface. In the meantime:-      ---      --    * when we write a single full interface, we check if we are-      --    currently writing the dynamic interface due to -dynamic-too, in-      --    which case we ignore "change".-      ---      --    * when we write two simple interfaces at once because of-      --    dynamic-too, we use "change" both for the non-dynamic and the-      --    dynamic interfaces. Hopefully both the dynamic and the non-dynamic-      --    interfaces stay in sync...-      ---      let change = old_iface /= Just (mi_iface_hash (mi_final_exts iface))--      let dt = dynamicTooState dflags--      when (logHasDumpFlag logger Opt_D_dump_if_trace) $ putMsg logger $-        hang (text "Writing interface(s):") 2 $ vcat-         [ text "Kind:" <+> if is_simple then text "simple" else text "full"-         , text "Hash change:" <+> ppr change-         , text "DynamicToo state:" <+> text (show dt)-         ]--      if is_simple-         then when change $ do -- FIXME: see 'change' comment above-            write_iface dflags iface-            case dt of-               DT_Dont   -> return ()-               DT_Dyn    -> panic "Unexpected DT_Dyn state when writing simple interface"-               DT_OK     -> write_iface (setDynamicNow dflags) iface-         else case dt of-               DT_Dont | change                    -> write_iface dflags iface-               DT_OK   | change                    -> write_iface dflags iface-               -- FIXME: see change' comment above-               DT_Dyn                              -> write_iface dflags iface-               _                                   -> return ()--      when (gopt Opt_WriteHie dflags) $ do-          -- This is slightly hacky. A hie file is considered to be up to date-          -- if its modification time on disk is greater than or equal to that-          -- of the .hi file (since we should always write a .hi file if we are-          -- writing a .hie file). However, with the way this code is-          -- structured at the moment, the .hie file is often written before-          -- the .hi file; by touching the file here, we ensure that it is-          -- correctly considered up-to-date.-          ---          -- The file should exist by the time we get here, but we check for-          -- existence just in case, so that we don't accidentally create empty-          -- .hie files.-          let hie_file = ml_hie_file mod_location-          whenM (doesFileExist hie_file) $-            GHC.SysTools.touch logger dflags "Touching hie file" hie_file-    else-        -- See Note [Strictness in ModIface]-        forceModIface iface------------------------------------------------------------------- NoRecomp handlers-------------------------------------------------------------------- | genModDetails is used to initialise 'ModDetails' at the end of compilation.--- This has two main effects:--- 1. Increases memory usage by unloading a lot of the TypeEnv--- 2. Globalising certain parts (DFunIds) in the TypeEnv (which used to be achieved using UpdateIdInfos)--- For the second part to work, it's critical that we use 'initIfaceLoadModule' here rather than--- 'initIfaceCheck' as 'initIfaceLoadModule' removes the module from the KnotVars, otherwise name lookups--- succeed by hitting the old TypeEnv, which missing out the critical globalisation step for DFuns.---- After the DFunIds are globalised, it's critical to overwrite the old TypeEnv with the new--- more compact and more correct version. This reduces memory usage whilst compiling the rest of--- the module loop.-genModDetails :: HscEnv -> ModIface -> IO ModDetails-genModDetails hsc_env old_iface-  = do-    -- CRITICAL: To use initIfaceLoadModule as that removes the current module from the KnotVars and-    -- hence properly globalises DFunIds.-    new_details <- {-# SCC "tcRnIface" #-}-                  initIfaceLoadModule hsc_env (mi_module old_iface) (typecheckIface old_iface)-    case lookupKnotVars (hsc_type_env_vars hsc_env) (mi_module old_iface) of-      Nothing -> return ()-      Just te_var -> writeIORef te_var (md_types new_details)-    dumpIfaceStats hsc_env-    return new_details------------------------------------------------------------------- Progress displayers.-----------------------------------------------------------------oneShotMsg :: Logger -> RecompileRequired -> IO ()-oneShotMsg logger recomp =-    case recomp of-        UpToDate -> compilationProgressMsg logger $ text "compilation IS NOT required"-        NeedsRecompile _ -> return ()--batchMsg :: Messager-batchMsg = batchMsgWith (\_ _ _ _ -> empty)-batchMultiMsg :: Messager-batchMultiMsg = batchMsgWith (\_ _ _ node -> brackets (ppr (moduleGraphNodeUnitId node)))--batchMsgWith :: (HscEnv -> (Int, Int) -> RecompileRequired -> ModuleGraphNode -> SDoc) -> Messager-batchMsgWith extra hsc_env_start mod_index recomp node =-      case recomp of-        UpToDate-          | logVerbAtLeast logger 2 -> showMsg (text "Skipping") empty-          | otherwise -> return ()-        NeedsRecompile reason0 -> showMsg (text herald) $ case reason0 of-          MustCompile            -> empty-          (RecompBecause reason) -> text " [" <> pprWithUnitState state (ppr reason) <> text "]"-    where-        herald = case node of-                    LinkNode {} -> "Linking"-                    InstantiationNode {} -> "Instantiating"-                    ModuleNode {} -> "Compiling"-        hsc_env = hscSetActiveUnitId (moduleGraphNodeUnitId node) hsc_env_start-        dflags = hsc_dflags hsc_env-        logger = hsc_logger hsc_env-        state  = hsc_units hsc_env-        showMsg msg reason =-            compilationProgressMsg logger $-            (showModuleIndex mod_index <>-            msg <+> showModMsg dflags (recompileRequired recomp) node)-                <> extra hsc_env mod_index recomp node-                <> reason------------------------------------------------------------------- Safe Haskell------------------------------------------------------------------- Note [Safe Haskell Trust Check]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- Safe Haskell checks that an import is trusted according to the following--- rules for an import of module M that resides in Package P:------   * If M is recorded as Safe and all its trust dependencies are OK---     then M is considered safe.---   * If M is recorded as Trustworthy and P is considered trusted and---     all M's trust dependencies are OK then M is considered safe.------ By trust dependencies we mean that the check is transitive. So if--- a module M that is Safe relies on a module N that is trustworthy,--- importing module M will first check (according to the second case)--- that N is trusted before checking M is trusted.------ This is a minimal description, so please refer to the user guide--- for more details. The user guide is also considered the authoritative--- source in this matter, not the comments or code.----- Note [Safe Haskell Inference]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- Safe Haskell does Safe inference on modules that don't have any specific--- safe haskell mode flag. The basic approach to this is:---   * When deciding if we need to do a Safe language check, treat---     an unmarked module as having -XSafe mode specified.---   * For checks, don't throw errors but return them to the caller.---   * Caller checks if there are errors:---     * For modules explicitly marked -XSafe, we throw the errors.---     * For unmarked modules (inference mode), we drop the errors---       and mark the module as being Unsafe.------ It used to be that we only did safe inference on modules that had no Safe--- Haskell flags, but now we perform safe inference on all modules as we want--- to allow users to set the `-Wsafe`, `-Wunsafe` and--- `-Wtrustworthy-safe` flags on Trustworthy and Unsafe modules so that a--- user can ensure their assumptions are correct and see reasons for why a--- module is safe or unsafe.------ This is tricky as we must be careful when we should throw an error compared--- to just warnings. For checking safe imports we manage it as two steps. First--- we check any imports that are required to be safe, then we check all other--- imports to see if we can infer them to be safe.----- | Check that the safe imports of the module being compiled are valid.--- If not we either issue a compilation error if the module is explicitly--- using Safe Haskell, or mark the module as unsafe if we're in safe--- inference mode.-hscCheckSafeImports :: TcGblEnv -> Hsc TcGblEnv-hscCheckSafeImports tcg_env = do-    dflags   <- getDynFlags-    tcg_env' <- checkSafeImports tcg_env-    checkRULES dflags tcg_env'--  where-    checkRULES dflags tcg_env' =-      let diag_opts = initDiagOpts dflags-      in case safeLanguageOn dflags of-          True -> do-              -- XSafe: we nuke user written RULES-              logDiagnostics $ fmap GhcDriverMessage $ warns diag_opts (tcg_rules tcg_env')-              return tcg_env' { tcg_rules = [] }-          False-                -- SafeInferred: user defined RULES, so not safe-              | safeInferOn dflags && not (null $ tcg_rules tcg_env')-              -> markUnsafeInfer tcg_env' $ warns diag_opts (tcg_rules tcg_env')--                -- Trustworthy OR SafeInferred: with no RULES-              | otherwise-              -> return tcg_env'--    warns diag_opts rules = mkMessages $ listToBag $ map (warnRules diag_opts) rules--    warnRules :: DiagOpts -> LRuleDecl GhcTc -> MsgEnvelope DriverMessage-    warnRules diag_opts (L loc rule) =-        mkPlainMsgEnvelope diag_opts (locA loc) $ DriverUserDefinedRuleIgnored rule---- | Validate that safe imported modules are actually safe.  For modules in the--- HomePackage (the package the module we are compiling in resides) this just--- involves checking its trust type is 'Safe' or 'Trustworthy'. For modules--- that reside in another package we also must check that the external package--- is trusted. See the Note [Safe Haskell Trust Check] above for more--- information.------ The code for this is quite tricky as the whole algorithm is done in a few--- distinct phases in different parts of the code base. See--- 'GHC.Rename.Names.rnImportDecl' for where package trust dependencies for a--- module are collected and unioned.  Specifically see the Note [Tracking Trust--- Transitively] in "GHC.Rename.Names" and the Note [Trust Own Package] in--- "GHC.Rename.Names".-checkSafeImports :: TcGblEnv -> Hsc TcGblEnv-checkSafeImports tcg_env-    = do-        dflags <- getDynFlags-        imps <- mapM condense imports'-        let (safeImps, regImps) = partition (\(_,_,s) -> s) imps--        -- We want to use the warning state specifically for detecting if safe-        -- inference has failed, so store and clear any existing warnings.-        oldErrs <- getDiagnostics-        clearDiagnostics--        -- Check safe imports are correct-        safePkgs <- S.fromList <$> mapMaybeM checkSafe safeImps-        safeErrs <- getDiagnostics-        clearDiagnostics--        -- Check non-safe imports are correct if inferring safety-        -- See the Note [Safe Haskell Inference]-        (infErrs, infPkgs) <- case (safeInferOn dflags) of-          False -> return (emptyMessages, S.empty)-          True -> do infPkgs <- S.fromList <$> mapMaybeM checkSafe regImps-                     infErrs <- getDiagnostics-                     clearDiagnostics-                     return (infErrs, infPkgs)--        -- restore old errors-        logDiagnostics oldErrs--        case (isEmptyMessages safeErrs) of-          -- Failed safe check-          False -> liftIO . throwErrors $ safeErrs--          -- Passed safe check-          True -> do-            let infPassed = isEmptyMessages infErrs-            tcg_env' <- case (not infPassed) of-              True  -> markUnsafeInfer tcg_env infErrs-              False -> return tcg_env-            when (packageTrustOn dflags) $ checkPkgTrust pkgReqs-            let newTrust = pkgTrustReqs dflags safePkgs infPkgs infPassed-            return tcg_env' { tcg_imports = impInfo `plusImportAvails` newTrust }--  where-    impInfo  = tcg_imports tcg_env     -- ImportAvails-    imports  = imp_mods impInfo        -- ImportedMods-    imports1 = moduleEnvToList imports -- (Module, [ImportedBy])-    imports' = map (fmap importedByUser) imports1 -- (Module, [ImportedModsVal])-    pkgReqs  = imp_trust_pkgs impInfo  -- [Unit]--    condense :: (Module, [ImportedModsVal]) -> Hsc (Module, SrcSpan, IsSafeImport)-    condense (_, [])   = panic "GHC.Driver.Main.condense: Pattern match failure!"-    condense (m, x:xs) = do imv <- foldlM cond' x xs-                            return (m, imv_span imv, imv_is_safe imv)--    -- ImportedModsVal = (ModuleName, Bool, SrcSpan, IsSafeImport)-    cond' :: ImportedModsVal -> ImportedModsVal -> Hsc ImportedModsVal-    cond' v1 v2-        | imv_is_safe v1 /= imv_is_safe v2-        = throwOneError $-            mkPlainErrorMsgEnvelope (imv_span v1) $-            GhcDriverMessage $ DriverMixedSafetyImport (imv_name v1)-        | otherwise-        = return v1--    -- easier interface to work with-    checkSafe :: (Module, SrcSpan, a) -> Hsc (Maybe UnitId)-    checkSafe (m, l, _) = fst `fmap` hscCheckSafe' m l--    -- what pkg's to add to our trust requirements-    pkgTrustReqs :: DynFlags -> Set UnitId -> Set UnitId ->-          Bool -> ImportAvails-    pkgTrustReqs dflags req inf infPassed | safeInferOn dflags-                                  && not (safeHaskellModeEnabled dflags) && infPassed-                                   = emptyImportAvails {-                                       imp_trust_pkgs = req `S.union` inf-                                   }-    pkgTrustReqs dflags _   _ _ | safeHaskell dflags == Sf_Unsafe-                         = emptyImportAvails-    pkgTrustReqs _ req _ _ = emptyImportAvails { imp_trust_pkgs = req }---- | Check that a module is safe to import.------ We return True to indicate the import is safe and False otherwise--- although in the False case an exception may be thrown first.-hscCheckSafe :: HscEnv -> Module -> SrcSpan -> IO Bool-hscCheckSafe hsc_env m l = runHsc hsc_env $ do-    dflags <- getDynFlags-    pkgs <- snd `fmap` hscCheckSafe' m l-    when (packageTrustOn dflags) $ checkPkgTrust pkgs-    errs <- getDiagnostics-    return $ isEmptyMessages errs---- | Return if a module is trusted and the pkgs it depends on to be trusted.-hscGetSafe :: HscEnv -> Module -> SrcSpan -> IO (Bool, Set UnitId)-hscGetSafe hsc_env m l = runHsc hsc_env $ do-    (self, pkgs) <- hscCheckSafe' m l-    good         <- isEmptyMessages `fmap` getDiagnostics-    clearDiagnostics -- don't want them printed...-    let pkgs' | Just p <- self = S.insert p pkgs-              | otherwise      = pkgs-    return (good, pkgs')---- | Is a module trusted? If not, throw or log errors depending on the type.--- Return (regardless of trusted or not) if the trust type requires the modules--- own package be trusted and a list of other packages required to be trusted--- (these later ones haven't been checked) but the own package trust has been.-hscCheckSafe' :: Module -> SrcSpan-  -> Hsc (Maybe UnitId, Set UnitId)-hscCheckSafe' m l = do-    hsc_env <- getHscEnv-    let home_unit = hsc_home_unit hsc_env-    (tw, pkgs) <- isModSafe home_unit m l-    case tw of-        False                           -> return (Nothing, pkgs)-        True | isHomeModule home_unit m -> return (Nothing, pkgs)-             -- TODO: do we also have to check the trust of the instantiation?-             -- Not necessary if that is reflected in dependencies-             | otherwise   -> return (Just $ toUnitId (moduleUnit m), pkgs)-  where-    isModSafe :: HomeUnit -> Module -> SrcSpan -> Hsc (Bool, Set UnitId)-    isModSafe home_unit m l = do-        hsc_env <- getHscEnv-        dflags <- getDynFlags-        iface <- lookup' m-        let diag_opts = initDiagOpts dflags-        case iface of-            -- can't load iface to check trust!-            Nothing -> throwOneError $-                         mkPlainErrorMsgEnvelope l $-                         GhcDriverMessage $ DriverCannotLoadInterfaceFile m--            -- got iface, check trust-            Just iface' ->-                let trust = getSafeMode $ mi_trust iface'-                    trust_own_pkg = mi_trust_pkg iface'-                    -- check module is trusted-                    safeM = trust `elem` [Sf_Safe, Sf_SafeInferred, Sf_Trustworthy]-                    -- check package is trusted-                    safeP = packageTrusted dflags (hsc_units hsc_env) home_unit trust trust_own_pkg m-                    -- pkg trust reqs-                    pkgRs = dep_trusted_pkgs $ mi_deps iface'-                    -- warn if Safe module imports Safe-Inferred module.-                    warns = if wopt Opt_WarnInferredSafeImports dflags-                                && safeLanguageOn dflags-                                && trust == Sf_SafeInferred-                                then inferredImportWarn diag_opts-                                else emptyMessages-                    -- General errors we throw but Safe errors we log-                    errs = case (safeM, safeP) of-                        (True, True ) -> emptyMessages-                        (True, False) -> pkgTrustErr-                        (False, _   ) -> modTrustErr-                in do-                    logDiagnostics warns-                    logDiagnostics errs-                    return (trust == Sf_Trustworthy, pkgRs)--                where-                    state = hsc_units hsc_env-                    inferredImportWarn diag_opts = singleMessage-                        $ mkMsgEnvelope diag_opts l (pkgQual state)-                        $ GhcDriverMessage $ DriverInferredSafeImport m-                    pkgTrustErr = singleMessage-                      $ mkErrorMsgEnvelope l (pkgQual state)-                      $ GhcDriverMessage $ DriverCannotImportFromUntrustedPackage state m-                    modTrustErr = singleMessage-                      $ mkErrorMsgEnvelope l (pkgQual state)-                      $ GhcDriverMessage $ DriverCannotImportUnsafeModule m--    -- Check the package a module resides in is trusted. Safe compiled-    -- modules are trusted without requiring that their package is trusted. For-    -- trustworthy modules, modules in the home package are trusted but-    -- otherwise we check the package trust flag.-    packageTrusted :: DynFlags -> UnitState -> HomeUnit -> SafeHaskellMode -> Bool -> Module -> Bool-    packageTrusted dflags unit_state home_unit safe_mode trust_own_pkg mod =-        case safe_mode of-            Sf_None      -> False -- shouldn't hit these cases-            Sf_Ignore    -> False -- shouldn't hit these cases-            Sf_Unsafe    -> False -- prefer for completeness.-            _ | not (packageTrustOn dflags)     -> True-            Sf_Safe | not trust_own_pkg         -> True-            Sf_SafeInferred | not trust_own_pkg -> True-            _ | isHomeModule home_unit mod      -> True-            _ -> unitIsTrusted $ unsafeLookupUnit unit_state (moduleUnit m)--    lookup' :: Module -> Hsc (Maybe ModIface)-    lookup' m = do-        hsc_env <- getHscEnv-        hsc_eps <- liftIO $ hscEPS hsc_env-        let pkgIfaceT = eps_PIT hsc_eps-            hug       = hsc_HUG hsc_env-            iface     = lookupIfaceByModule hug pkgIfaceT m-        -- the 'lookupIfaceByModule' method will always fail when calling from GHCi-        -- as the compiler hasn't filled in the various module tables-        -- so we need to call 'getModuleInterface' to load from disk-        case iface of-            Just _  -> return iface-            Nothing -> snd `fmap` (liftIO $ getModuleInterface hsc_env m)----- | Check the list of packages are trusted.-checkPkgTrust :: Set UnitId -> Hsc ()-checkPkgTrust pkgs = do-    hsc_env <- getHscEnv-    let errors = S.foldr go emptyBag pkgs-        state  = hsc_units hsc_env-        go pkg acc-            | unitIsTrusted $ unsafeLookupUnitId state pkg-            = acc-            | otherwise-            = (`consBag` acc)-                     $ mkErrorMsgEnvelope noSrcSpan (pkgQual state)-                     $ GhcDriverMessage-                     $ DriverPackageNotTrusted state pkg-    if isEmptyBag errors-      then return ()-      else liftIO $ throwErrors $ mkMessages errors---- | Set module to unsafe and (potentially) wipe trust information.------ Make sure to call this method to set a module to inferred unsafe, it should--- be a central and single failure method. We only wipe the trust information--- when we aren't in a specific Safe Haskell mode.------ While we only use this for recording that a module was inferred unsafe, we--- may call it on modules using Trustworthy or Unsafe flags so as to allow--- warning flags for safety to function correctly. See Note [Safe Haskell--- Inference].-markUnsafeInfer :: Diagnostic e => TcGblEnv -> Messages e -> Hsc TcGblEnv-markUnsafeInfer tcg_env whyUnsafe = do-    dflags <- getDynFlags--    let reason = WarningWithFlag Opt_WarnUnsafe-    let diag_opts = initDiagOpts dflags-    when (diag_wopt Opt_WarnUnsafe diag_opts)-         (logDiagnostics $ singleMessage $-             mkPlainMsgEnvelope diag_opts (warnUnsafeOnLoc dflags) $-             GhcDriverMessage $ DriverUnknownMessage $-             mkPlainDiagnostic reason noHints $-             whyUnsafe' dflags)--    liftIO $ writeIORef (tcg_safe_infer tcg_env) False-    liftIO $ writeIORef (tcg_safe_infer_reasons tcg_env) emptyMessages-    -- NOTE: Only wipe trust when not in an explicitly safe haskell mode. Other-    -- times inference may be on but we are in Trustworthy mode -- so we want-    -- to record safe-inference failed but not wipe the trust dependencies.-    case not (safeHaskellModeEnabled dflags) of-      True  -> return $ tcg_env { tcg_imports = wiped_trust }-      False -> return tcg_env--  where-    wiped_trust   = (tcg_imports tcg_env) { imp_trust_pkgs = S.empty }-    pprMod        = ppr $ moduleName $ tcg_mod tcg_env-    whyUnsafe' df = vcat [ quotes pprMod <+> text "has been inferred as unsafe!"-                         , text "Reason:"-                         , nest 4 $ (vcat $ badFlags df) $+$-                                    (vcat $ pprMsgEnvelopeBagWithLoc (getMessages whyUnsafe)) $+$-                                    (vcat $ badInsts $ tcg_insts tcg_env)-                         ]-    badFlags df   = concatMap (badFlag df) unsafeFlagsForInfer-    badFlag df (str,loc,on,_)-        | on df     = [mkLocMessage MCOutput (loc df) $-                            text str <+> text "is not allowed in Safe Haskell"]-        | otherwise = []-    badInsts insts = concatMap badInst insts--    checkOverlap (NoOverlap _) = False-    checkOverlap _             = True--    badInst ins | checkOverlap (overlapMode (is_flag ins))-                = [mkLocMessage MCOutput (nameSrcSpan $ getName $ is_dfun ins) $-                      ppr (overlapMode $ is_flag ins) <+>-                      text "overlap mode isn't allowed in Safe Haskell"]-                | otherwise = []---- | Figure out the final correct safe haskell mode-hscGetSafeMode :: TcGblEnv -> Hsc SafeHaskellMode-hscGetSafeMode tcg_env = do-    dflags  <- getDynFlags-    liftIO $ finalSafeMode dflags tcg_env------------------------------------------------------------------- Simplifiers------------------------------------------------------------------- | Run Core2Core simplifier. The list of String is a list of (Core) plugin--- module names added via TH (cf 'addCorePlugin').-hscSimplify :: HscEnv -> [String] -> ModGuts -> IO ModGuts-hscSimplify hsc_env plugins modguts =-    runHsc hsc_env $ hscSimplify' plugins modguts---- | Run Core2Core simplifier. The list of String is a list of (Core) plugin--- module names added via TH (cf 'addCorePlugin').-hscSimplify' :: [String] -> ModGuts -> Hsc ModGuts-hscSimplify' plugins ds_result = do-    hsc_env <- getHscEnv-    hsc_env_with_plugins <- if null plugins -- fast path-        then return hsc_env-        else liftIO $ initializePlugins-                    $ hscUpdateFlags (\dflags -> foldr addPluginModuleName dflags plugins)-                      hsc_env-    {-# SCC "Core2Core" #-}-      liftIO $ core2core hsc_env_with_plugins ds_result------------------------------------------------------------------- Interface generators------------------------------------------------------------------- | Generate a striped down interface file, e.g. for boot files or when ghci--- generates interface files. See Note [simpleTidyPgm - mkBootModDetailsTc]-hscSimpleIface :: HscEnv-               -> TcGblEnv-               -> ModSummary-               -> IO (ModIface, ModDetails)-hscSimpleIface hsc_env tc_result summary-    = runHsc hsc_env $ hscSimpleIface' tc_result summary--hscSimpleIface' :: TcGblEnv-                -> ModSummary-                -> Hsc (ModIface, ModDetails)-hscSimpleIface' tc_result summary = do-    hsc_env   <- getHscEnv-    logger    <- getLogger-    details   <- liftIO $ mkBootModDetailsTc logger tc_result-    safe_mode <- hscGetSafeMode tc_result-    new_iface-        <- {-# SCC "MkFinalIface" #-}-           liftIO $-               mkIfaceTc hsc_env safe_mode details summary tc_result-    -- And the answer is ...-    liftIO $ dumpIfaceStats hsc_env-    return (new_iface, details)------------------------------------------------------------------- BackEnd combinators------------------------------------------------------------------- | Compile to hard-code.-hscGenHardCode :: HscEnv -> CgGuts -> ModLocation -> FilePath-               -> IO (FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)], Maybe StgCgInfos, Maybe CmmCgInfos )-                -- ^ @Just f@ <=> _stub.c is f-hscGenHardCode hsc_env cgguts location output_filename = do-        let CgGuts{ -- This is the last use of the ModGuts in a compilation.-                    -- From now on, we just use the bits we need.-                    cg_module   = this_mod,-                    cg_binds    = core_binds,-                    cg_ccs      = local_ccs,-                    cg_tycons   = tycons,-                    cg_foreign  = foreign_stubs0,-                    cg_foreign_files = foreign_files,-                    cg_dep_pkgs = dependencies,-                    cg_hpc_info = hpc_info } = cgguts-            dflags = hsc_dflags hsc_env-            logger = hsc_logger hsc_env-            hooks  = hsc_hooks hsc_env-            tmpfs  = hsc_tmpfs hsc_env-            profile = targetProfile dflags-            data_tycons = filter isDataTyCon tycons-            -- cg_tycons includes newtypes, for the benefit of External Core,-            -- but we don't generate any code for newtypes--        --------------------        -- Insert late cost centres if enabled.-        -- If `-fprof-late-inline` is enabled we can skip this, as it will have added-        -- a superset of cost centres we would add here already.--        (late_cc_binds, late_local_ccs) <--              if gopt Opt_ProfLateCcs dflags && not (gopt Opt_ProfLateInlineCcs dflags)-                  then  {-# SCC lateCC #-} do-                    (binds,late_ccs) <- addLateCostCentresPgm dflags logger this_mod core_binds-                    return ( binds, (S.toList late_ccs `mappend` local_ccs ))-                  else-                    return (core_binds, local_ccs)----        --------------------        -- PREPARE FOR CODE GENERATION-        -- Do saturation and convert to A-normal form-        (prepd_binds) <- {-# SCC "CorePrep" #-}-                       corePrepPgm hsc_env this_mod location-                                   late_cc_binds data_tycons--        -----------------  Convert to STG -------------------        (stg_binds, denv, (caf_ccs, caf_cc_stacks), 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 (hsc_IC hsc_env) False this_mod location prepd_binds)--        let cost_centre_info =-              (late_local_ccs ++ caf_ccs, caf_cc_stacks)-            platform = targetPlatform dflags-            prof_init-              | sccProfilingEnabled dflags = profilingInitCode platform this_mod cost_centre_info-              | otherwise = mempty--        ------------------  Code generation -------------------        -- The back-end is streamed: each top-level function goes-        -- from Stg all the way to asm before dealing with the next-        -- top-level function, so showPass isn't very useful here.-        -- Hence we have one showPass for the whole backend, the-        -- next showPass after this will be "Assembler".-        withTiming logger-                   (text "CodeGen"<+>brackets (ppr this_mod))-                   (const ()) $ do-            cmms <- {-# SCC "StgToCmm" #-}-                            doCodeGen hsc_env this_mod denv data_tycons-                                cost_centre_info-                                stg_binds hpc_info--            ------------------  Code output ------------------------            rawcmms0 <- {-# SCC "cmmToRawCmm" #-}-                        case cmmToRawCmmHook hooks of-                            Nothing -> cmmToRawCmm logger profile cmms-                            Just h  -> h dflags (Just this_mod) cmms--            let dump a = do-                  unless (null a) $-                    putDumpFileMaybe logger Opt_D_dump_cmm_raw "Raw Cmm" FormatCMM (pdoc platform a)-                  return a-                rawcmms1 = Stream.mapM dump rawcmms0--            let foreign_stubs st = foreign_stubs0 `appendStubC` prof_init-                                                  `appendStubC` cgIPEStub st--            (output_filename, (_stub_h_exists, stub_c_exists), foreign_fps, cmm_cg_infos)-                <- {-# SCC "codeOutput" #-}-                  codeOutput logger tmpfs dflags (hsc_units hsc_env) this_mod output_filename location-                  foreign_stubs foreign_files dependencies rawcmms1-            return  ( output_filename, stub_c_exists, foreign_fps-                    , Just stg_cg_infos, Just cmm_cg_infos)---hscInteractive :: HscEnv-               -> CgGuts-               -> ModLocation-               -> IO (Maybe FilePath, CompiledByteCode, [SptEntry])-hscInteractive hsc_env cgguts location = do-    let dflags = hsc_dflags hsc_env-    let logger = hsc_logger hsc_env-    let tmpfs  = hsc_tmpfs hsc_env-    let CgGuts{ -- This is the last use of the ModGuts in a compilation.-                -- From now on, we just use the bits we need.-               cg_module   = this_mod,-               cg_binds    = core_binds,-               cg_tycons   = tycons,-               cg_foreign  = foreign_stubs,-               cg_modBreaks = mod_breaks,-               cg_spt_entries = spt_entries } = cgguts--        data_tycons = filter isDataTyCon tycons-        -- cg_tycons includes newtypes, for the benefit of External Core,-        -- but we don't generate any code for newtypes--    --------------------    -- PREPARE FOR CODE GENERATION-    -- Do saturation and convert to A-normal form-    prepd_binds <- {-# SCC "CorePrep" #-}-                   corePrepPgm hsc_env this_mod location core_binds data_tycons--    -- The stg cg info only provides a runtime benfit, but is not requires so we just-    -- omit it here-    (stg_binds, _infotable_prov, _caf_ccs__caf_cc_stacks, _ignore_stg_cg_infos)-      <- {-# SCC "CoreToStg" #-}-          myCoreToStg logger dflags (hsc_IC hsc_env) True this_mod location prepd_binds-    -----------------  Generate byte code -------------------    comp_bc <- byteCodeGen hsc_env this_mod stg_binds data_tycons mod_breaks-    ------------------ Create f-x-dynamic C-side stuff ------    (_istub_h_exists, istub_c_exists)-        <- outputForeignStubs logger tmpfs dflags (hsc_units hsc_env) this_mod location foreign_stubs-    return (istub_c_exists, comp_bc, spt_entries)----------------------------------hscCompileCmmFile :: HscEnv -> FilePath -> FilePath -> FilePath -> IO (Maybe FilePath)-hscCompileCmmFile hsc_env original_filename filename output_filename = runHsc hsc_env $ do-    let dflags   = hsc_dflags hsc_env-        logger   = hsc_logger hsc_env-        hooks    = hsc_hooks hsc_env-        tmpfs    = hsc_tmpfs hsc_env-        profile  = targetProfile dflags-        home_unit = hsc_home_unit hsc_env-        platform  = targetPlatform dflags-        do_info_table = gopt Opt_InfoTableMap dflags-        -- Make up a module name to give the NCG. We can't pass bottom here-        -- lest we reproduce #11784.-        mod_name = mkModuleName $ "Cmm$" ++ original_filename-        cmm_mod = mkHomeModule home_unit mod_name-    (cmm, ents) <- ioMsgMaybe-               $ do-                  (warns,errs,cmm) <- withTiming logger (text "ParseCmm"<+>brackets (text filename)) (\_ -> ())-                                       $ parseCmmFile dflags cmm_mod home_unit filename-                  let msgs = warns `unionMessages` errs-                  return (GhcPsMessage <$> msgs, cmm)-    liftIO $ do-        putDumpFileMaybe logger Opt_D_dump_cmm_verbose_by_proc "Parsed Cmm" FormatCMM (pdoc platform cmm)--        -- Compile decls in Cmm files one decl at a time, to avoid re-ordering-        -- them in SRT analysis.-        ---        -- Re-ordering here causes breakage when booting with C backend because-        -- in C we must declare before use, but SRT algorithm is free to-        -- re-order [A, B] (B refers to A) when A is not CAFFY and return [B, A]-        cmmgroup <--          concatMapM (\cmm -> snd <$> cmmPipeline hsc_env (emptySRT cmm_mod) [cmm]) cmm--        unless (null cmmgroup) $-          putDumpFileMaybe logger Opt_D_dump_cmm "Output Cmm"-            FormatCMM (pdoc platform cmmgroup)--        rawCmms <- case cmmToRawCmmHook hooks of-          Nothing -> cmmToRawCmm logger profile (Stream.yield cmmgroup)-          Just h  -> h           dflags Nothing (Stream.yield cmmgroup)--        let foreign_stubs _ =-              let ip_init   = ipInitCode do_info_table platform cmm_mod ents-              in NoStubs `appendStubC` ip_init--        (_output_filename, (_stub_h_exists, stub_c_exists), _foreign_fps, _caf_infos)-          <- codeOutput logger tmpfs dflags (hsc_units hsc_env) cmm_mod output_filename no_loc foreign_stubs [] S.empty-             rawCmms-        return stub_c_exists-  where-    no_loc = ModLocation{ ml_hs_file  = Just filename,-                          ml_hi_file  = panic "hscCompileCmmFile: no hi file",-                          ml_obj_file = panic "hscCompileCmmFile: no obj file",-                          ml_dyn_obj_file = panic "hscCompileCmmFile: no dyn obj file",-                          ml_dyn_hi_file  = panic "hscCompileCmmFile: no dyn obj file",-                          ml_hie_file = panic "hscCompileCmmFile: no hie file"}---------------------- Stuff for new code gen -----------------------{--Note [Forcing of stg_binds]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-The two last steps in the STG pipeline are:--* Sorting the bindings in dependency order.-* Annotating them with free variables.--We want to make sure we do not keep references to unannotated STG bindings-alive, nor references to bindings which have already been compiled to Cmm.--We explicitly force the bindings to avoid this.--This reduces residency towards the end of the CodeGen phase significantly-(5-10%).--}--doCodeGen :: HscEnv -> Module -> InfoTableProvMap -> [TyCon]-          -> CollectedCCs-          -> [CgStgTopBinding] -- ^ Bindings come already annotated with fvs-          -> HpcInfo-          -> IO (Stream IO CmmGroupSRTs 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 data_tycons-              cost_centre_info stg_binds_w_fvs hpc_info = do-    let dflags     = hsc_dflags hsc_env-        logger     = hsc_logger hsc_env-        hooks      = hsc_hooks  hsc_env-        tmpfs      = hsc_tmpfs  hsc_env-        platform   = targetPlatform dflags-        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 = case stgToCmmHook hooks of-                        Nothing -> StgToCmm.codeGen logger tmpfs (initStgToCmmConfig dflags mod)-                        Just h  -> h                             (initStgToCmmConfig dflags mod)--    let cmm_stream :: Stream IO CmmGroup ModuleLFInfos-        -- See Note [Forcing of stg_binds]-        cmm_stream = stg_binds_w_fvs `seqList` {-# SCC "StgToCmm" #-}-            stg_to_cmm dflags this_mod denv data_tycons cost_centre_info stg_binds_w_fvs hpc_info--        -- codegen consumes a stream of CmmGroup, and produces a new-        -- stream of CmmGroup (not necessarily synchronised: one-        -- CmmGroup on input may produce many CmmGroups on output due-        -- to proc-point splitting).--    let dump1 a = do-          unless (null a) $-            putDumpFileMaybe logger Opt_D_dump_cmm_from_stg-              "Cmm produced by codegen" FormatCMM (pdoc platform a)-          return a--        ppr_stream1 = Stream.mapM dump1 cmm_stream--        pipeline_stream :: Stream IO CmmGroupSRTs (NonCaffySet, ModuleLFInfos)-        pipeline_stream = do-          (non_cafs,  lf_infos) <--            {-# SCC "cmmPipeline" #-}-            Stream.mapAccumL_ (cmmPipeline hsc_env) (emptySRT this_mod) ppr_stream1-              <&> first (srtMapNonCAFs . moduleSRTMap)--          return (non_cafs, lf_infos)--        dump2 a = do-          unless (null a) $-            putDumpFileMaybe logger Opt_D_dump_cmm "Output Cmm" FormatCMM (pdoc platform a)-          return a--    return $ Stream.mapM dump2 $ generateCgIPEStub hsc_env this_mod denv pipeline_stream--myCoreToStgExpr :: Logger -> DynFlags -> InteractiveContext-                -> Bool-                -> Module -> ModLocation -> CoreExpr-                -> IO ( Id-                      , [CgStgTopBinding]-                      , InfoTableProvMap-                      , CollectedCCs-                      , StgCgInfos )-myCoreToStgExpr logger dflags ictxt for_bytecode this_mod ml prepd_expr = do-    {- Create a temporary binding (just because myCoreToStg needs a-       binding for the stg2stg step) -}-    let bco_tmp_id = mkSysLocal (fsLit "BCO_toplevel")-                                (mkPseudoUniqueE 0)-                                Many-                                (exprType prepd_expr)-    (stg_binds, prov_map, collected_ccs, stg_cg_infos) <--       myCoreToStg logger-                   dflags-                   ictxt-                   for_bytecode-                   this_mod-                   ml-                   [NonRec bco_tmp_id prepd_expr]-    return (bco_tmp_id, stg_binds, prov_map, collected_ccs, stg_cg_infos)--myCoreToStg :: Logger -> DynFlags -> InteractiveContext-            -> Bool-            -> Module -> ModLocation -> CoreProgram-            -> IO ( [CgStgTopBinding] -- output program-                  , InfoTableProvMap-                  , CollectedCCs -- CAF cost centre info (declared and used)-                  , StgCgInfos )-myCoreToStg logger dflags ictxt for_bytecode this_mod ml prepd_binds = do-    let (stg_binds, denv, cost_centre_info)-         = {-# SCC "Core2Stg" #-}-           coreToStg dflags this_mod ml prepd_binds--    (stg_binds_with_fvs,stg_cg_info)-        <- {-# SCC "Stg2Stg" #-}-           stg2stg logger ictxt (initStgPipelineOpts dflags for_bytecode)-                   this_mod stg_binds--    putDumpFileMaybe logger Opt_D_dump_stg_cg "CodeGenInput STG:" FormatSTG-        (pprGenStgTopBindings (initStgPprOpts dflags) stg_binds_with_fvs)--    return (stg_binds_with_fvs, denv, cost_centre_info, stg_cg_info)--{- **********************************************************************-%*                                                                      *-\subsection{Compiling a do-statement}-%*                                                                      *-%********************************************************************* -}--{--When the UnlinkedBCOExpr is linked you get an HValue of type *IO [HValue]* When-you run it you get a list of HValues that should be the same length as the list-of names; add them to the ClosureEnv.--A naked expression returns a singleton Name [it]. The stmt is lifted into the-IO monad as explained in Note [Interactively-bound Ids in GHCi] in GHC.Runtime.Context--}---- | Compile a stmt all the way to an HValue, but don't run it------ We return Nothing to indicate an empty statement (or comment only), not a--- parse error.-hscStmt :: HscEnv -> String -> IO (Maybe ([Id], ForeignHValue, FixityEnv))-hscStmt hsc_env stmt = hscStmtWithLocation hsc_env stmt "<interactive>" 1---- | Compile a stmt all the way to an HValue, but don't run it------ We return Nothing to indicate an empty statement (or comment only), not a--- parse error.-hscStmtWithLocation :: HscEnv-                    -> String -- ^ The statement-                    -> String -- ^ The source-                    -> Int    -- ^ Starting line-                    -> IO ( Maybe ([Id]-                          , ForeignHValue {- IO [HValue] -}-                          , FixityEnv))-hscStmtWithLocation hsc_env0 stmt source linenumber =-  runInteractiveHsc hsc_env0 $ do-    maybe_stmt <- hscParseStmtWithLocation source linenumber stmt-    case maybe_stmt of-      Nothing -> return Nothing--      Just parsed_stmt -> do-        hsc_env <- getHscEnv-        liftIO $ hscParsedStmt hsc_env parsed_stmt--hscParsedStmt :: HscEnv-              -> GhciLStmt GhcPs  -- ^ The parsed statement-              -> IO ( Maybe ([Id]-                    , ForeignHValue {- IO [HValue] -}-                    , FixityEnv))-hscParsedStmt hsc_env stmt = runInteractiveHsc hsc_env $ do-  -- Rename and typecheck it-  (ids, tc_expr, fix_env) <- ioMsgMaybe $ hoistTcRnMessage $ tcRnStmt hsc_env stmt--  -- Desugar it-  ds_expr <- ioMsgMaybe $ hoistDsMessage $ deSugarExpr hsc_env tc_expr-  liftIO (lintInteractiveExpr (text "desugar expression") hsc_env ds_expr)-  handleWarnings--  -- Then code-gen, and link it-  -- It's important NOT to have package 'interactive' as thisUnitId-  -- for linking, else we try to link 'main' and can't find it.-  -- Whereas the linker already knows to ignore 'interactive'-  let src_span = srcLocSpan interactiveSrcLoc-  (hval,_,_) <- liftIO $ hscCompileCoreExpr hsc_env src_span ds_expr--  return $ Just (ids, hval, fix_env)---- | Compile a decls-hscDecls :: HscEnv-         -> String -- ^ The statement-         -> IO ([TyThing], InteractiveContext)-hscDecls hsc_env str = hscDeclsWithLocation hsc_env str "<interactive>" 1--hscParseModuleWithLocation :: HscEnv -> String -> Int -> String -> IO HsModule-hscParseModuleWithLocation hsc_env source line_num str = do-    L _ mod <--      runInteractiveHsc hsc_env $-        hscParseThingWithLocation source line_num parseModule str-    return mod--hscParseDeclsWithLocation :: HscEnv -> String -> Int -> String -> IO [LHsDecl GhcPs]-hscParseDeclsWithLocation hsc_env source line_num str = do-  HsModule { hsmodDecls = decls } <- hscParseModuleWithLocation hsc_env source line_num str-  return decls---- | Compile a decls-hscDeclsWithLocation :: HscEnv-                     -> String -- ^ The statement-                     -> String -- ^ The source-                     -> Int    -- ^ Starting line-                     -> IO ([TyThing], InteractiveContext)-hscDeclsWithLocation hsc_env str source linenumber = do-    L _ (HsModule{ hsmodDecls = decls }) <--      runInteractiveHsc hsc_env $-        hscParseThingWithLocation source linenumber parseModule str-    hscParsedDecls hsc_env decls--hscParsedDecls :: HscEnv -> [LHsDecl GhcPs] -> IO ([TyThing], InteractiveContext)-hscParsedDecls hsc_env decls = runInteractiveHsc hsc_env $ do-    hsc_env <- getHscEnv-    let interp = hscInterp hsc_env--    {- Rename and typecheck it -}-    tc_gblenv <- ioMsgMaybe $ hoistTcRnMessage $ tcRnDeclsi hsc_env decls--    {- Grab the new instances -}-    -- We grab the whole environment because of the overlapping that may have-    -- been done. See the notes at the definition of InteractiveContext-    -- (ic_instances) for more details.-    let defaults = tcg_default tc_gblenv--    {- Desugar it -}-    -- We use a basically null location for iNTERACTIVE-    let iNTERACTIVELoc = ModLocation{ ml_hs_file   = Nothing,-                                      ml_hi_file   = panic "hsDeclsWithLocation:ml_hi_file",-                                      ml_obj_file  = panic "hsDeclsWithLocation:ml_obj_file",-                                      ml_dyn_obj_file = panic "hsDeclsWithLocation:ml_dyn_obj_file",-                                      ml_dyn_hi_file = panic "hsDeclsWithLocation:ml_dyn_hi_file",-                                      ml_hie_file  = panic "hsDeclsWithLocation:ml_hie_file" }-    ds_result <- hscDesugar' iNTERACTIVELoc tc_gblenv--    {- Simplify -}-    simpl_mg <- liftIO $ do-      plugins <- readIORef (tcg_th_coreplugins tc_gblenv)-      hscSimplify hsc_env plugins ds_result--    {- Tidy -}-    (tidy_cg, mod_details) <- liftIO $ hscTidy hsc_env simpl_mg--    let !CgGuts{ cg_module    = this_mod,-                 cg_binds     = core_binds,-                 cg_tycons    = tycons,-                 cg_modBreaks = mod_breaks } = tidy_cg--        !ModDetails { md_insts     = cls_insts-                    , md_fam_insts = fam_insts } = mod_details-            -- Get the *tidied* cls_insts and fam_insts--        data_tycons = filter isDataTyCon tycons--    {- Prepare For Code Generation -}-    -- Do saturation and convert to A-normal form-    prepd_binds <- {-# SCC "CorePrep" #-}-      liftIO $ corePrepPgm hsc_env this_mod iNTERACTIVELoc core_binds data_tycons--    (stg_binds, _infotable_prov, _caf_ccs__caf_cc_stacks, _stg_cg_info)-        <- {-# SCC "CoreToStg" #-}-           liftIO $ myCoreToStg (hsc_logger hsc_env)-                                (hsc_dflags hsc_env)-                                (hsc_IC hsc_env)-                                True-                                this_mod-                                iNTERACTIVELoc-                                prepd_binds--    {- Generate byte code -}-    cbc <- liftIO $ byteCodeGen hsc_env this_mod-                                stg_binds data_tycons mod_breaks--    let src_span = srcLocSpan interactiveSrcLoc-    _ <- liftIO $ loadDecls interp hsc_env src_span cbc--    {- Load static pointer table entries -}-    liftIO $ hscAddSptEntries hsc_env (cg_spt_entries tidy_cg)--    let tcs = filterOut isImplicitTyCon (mg_tcs simpl_mg)-        patsyns = mg_patsyns simpl_mg--        ext_ids = [ id | id <- bindersOfBinds core_binds-                       , isExternalName (idName id)-                       , not (isDFunId id || isImplicitId id) ]-            -- We only need to keep around the external bindings-            -- (as decided by GHC.Iface.Tidy), since those are the only ones-            -- that might later be looked up by name.  But we can exclude-            --    - DFunIds, which are in 'cls_insts' (see Note [ic_tythings] in GHC.Runtime.Context-            --    - Implicit Ids, which are implicit in tcs-            -- c.f. GHC.Tc.Module.runTcInteractive, which reconstructs the TypeEnv--        new_tythings = map AnId ext_ids ++ map ATyCon tcs ++ map (AConLike . PatSynCon) patsyns-        ictxt        = hsc_IC hsc_env-        -- See Note [Fixity declarations in GHCi]-        fix_env      = tcg_fix_env tc_gblenv-        new_ictxt    = extendInteractiveContext ictxt new_tythings cls_insts-                                                fam_insts defaults fix_env-    return (new_tythings, new_ictxt)---- | Load the given static-pointer table entries into the interpreter.--- See Note [Grand plan for static forms] in "GHC.Iface.Tidy.StaticPtrTable".-hscAddSptEntries :: HscEnv -> [SptEntry] -> IO ()-hscAddSptEntries hsc_env entries = do-    let interp = hscInterp hsc_env-    let add_spt_entry :: SptEntry -> IO ()-        add_spt_entry (SptEntry i fpr) = do-            -- These are only names from the current module-            (val, _, _) <- loadName interp hsc_env (idName i)-            addSptEntry interp fpr val-    mapM_ add_spt_entry entries--{--  Note [Fixity declarations in GHCi]-  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-  To support fixity declarations on types defined within GHCi (as requested-  in #10018) we record the fixity environment in InteractiveContext.-  When we want to evaluate something GHC.Tc.Module.runTcInteractive pulls out this-  fixity environment and uses it to initialize the global typechecker environment.-  After the typechecker has finished its business, an updated fixity environment-  (reflecting whatever fixity declarations were present in the statements we-  passed it) will be returned from hscParsedStmt. This is passed to-  updateFixityEnv, which will stuff it back into InteractiveContext, to be-  used in evaluating the next statement.---}--hscImport :: HscEnv -> String -> IO (ImportDecl GhcPs)-hscImport hsc_env str = runInteractiveHsc hsc_env $ do-    (L _ (HsModule{hsmodImports=is})) <--       hscParseThing parseModule str-    case is of-        [L _ i] -> return i-        _ -> liftIO $ throwOneError $-                 mkPlainErrorMsgEnvelope noSrcSpan $-                 GhcPsMessage $ PsUnknownMessage $ mkPlainError noHints $-                     text "parse error in import declaration"---- | Typecheck an expression (but don't run it)-hscTcExpr :: HscEnv-          -> TcRnExprMode-          -> String -- ^ The expression-          -> IO Type-hscTcExpr hsc_env0 mode expr = runInteractiveHsc hsc_env0 $ do-  hsc_env <- getHscEnv-  parsed_expr <- hscParseExpr expr-  ioMsgMaybe $ hoistTcRnMessage $ tcRnExpr hsc_env mode parsed_expr---- | Find the kind of a type, after generalisation-hscKcType-  :: HscEnv-  -> Bool            -- ^ Normalise the type-  -> String          -- ^ The type as a string-  -> IO (Type, Kind) -- ^ Resulting type (possibly normalised) and kind-hscKcType hsc_env0 normalise str = runInteractiveHsc hsc_env0 $ do-    hsc_env <- getHscEnv-    ty <- hscParseType str-    ioMsgMaybe $ hoistTcRnMessage $ tcRnType hsc_env DefaultFlexi normalise ty--hscParseExpr :: String -> Hsc (LHsExpr GhcPs)-hscParseExpr expr = do-  maybe_stmt <- hscParseStmt expr-  case maybe_stmt of-    Just (L _ (BodyStmt _ expr _ _)) -> return expr-    _ -> throwOneError $-           mkPlainErrorMsgEnvelope noSrcSpan $-           GhcPsMessage $ PsUnknownMessage $ mkPlainError noHints $-             text "not an expression:" <+> quotes (text expr)--hscParseStmt :: String -> Hsc (Maybe (GhciLStmt GhcPs))-hscParseStmt = hscParseThing parseStmt--hscParseStmtWithLocation :: String -> Int -> String-                         -> Hsc (Maybe (GhciLStmt GhcPs))-hscParseStmtWithLocation source linenumber stmt =-    hscParseThingWithLocation source linenumber parseStmt stmt--hscParseType :: String -> Hsc (LHsType GhcPs)-hscParseType = hscParseThing parseType--hscParseIdentifier :: HscEnv -> String -> IO (LocatedN RdrName)-hscParseIdentifier hsc_env str =-    runInteractiveHsc hsc_env $ hscParseThing parseIdentifier str--hscParseThing :: (Outputable thing, Data thing)-              => Lexer.P thing -> String -> Hsc thing-hscParseThing = hscParseThingWithLocation "<interactive>" 1--hscParseThingWithLocation :: (Outputable thing, Data thing) => String -> Int-                          -> Lexer.P thing -> String -> Hsc thing-hscParseThingWithLocation source linenumber parser str = do-    dflags <- getDynFlags-    logger <- getLogger-    withTiming logger-               (text "Parser [source]")-               (const ()) $ {-# SCC "Parser" #-} do--        let buf = stringToStringBuffer str-            loc = mkRealSrcLoc (fsLit source) linenumber 1--        case unP parser (initParserState (initParserOpts dflags) buf loc) of-            PFailed pst ->-                handleWarningsThrowErrors (getPsMessages pst)-            POk pst thing -> do-                logWarningsReportErrors (getPsMessages pst)-                liftIO $ putDumpFileMaybe logger Opt_D_dump_parsed "Parser"-                            FormatHaskell (ppr thing)-                liftIO $ putDumpFileMaybe logger Opt_D_dump_parsed_ast "Parser AST"-                            FormatHaskell (showAstData NoBlankSrcSpan NoBlankEpAnnotations thing)-                return thing--hscTidy :: HscEnv -> ModGuts -> IO (CgGuts, ModDetails)-hscTidy hsc_env guts = do-  let logger   = hsc_logger hsc_env-  let this_mod = mg_module guts--  opts <- initTidyOpts hsc_env-  (cgguts, details) <- withTiming logger-    (text "CoreTidy"<+>brackets (ppr this_mod))-    (const ())-    $! {-# SCC "CoreTidy" #-} tidyProgram opts guts--  -- post tidy pretty-printing and linting...-  let tidy_rules     = md_rules details-  let all_tidy_binds = cg_binds cgguts-  let print_unqual   = mkPrintUnqualified (hsc_unit_env hsc_env) (mg_rdr_env guts)--  endPassIO hsc_env print_unqual CoreTidy all_tidy_binds tidy_rules--  -- If the endPass didn't print the rules, but ddump-rules is-  -- on, print now-  unless (logHasDumpFlag logger Opt_D_dump_simpl) $-    putDumpFileMaybe logger Opt_D_dump_rules-      (renderWithContext defaultSDocContext (ppr CoreTidy <+> text "rules"))-      FormatText-      (pprRulesForUser tidy_rules)--  -- Print one-line size info-  let cs = coreBindsStats all_tidy_binds-  putDumpFileMaybe logger Opt_D_dump_core_stats "Core Stats"-    FormatText-    (text "Tidy size (terms,types,coercions)"-     <+> ppr (moduleName this_mod) <> colon-     <+> int (cs_tm cs)-     <+> int (cs_ty cs)-     <+> int (cs_co cs))--  pure (cgguts, details)---{- **********************************************************************-%*                                                                      *-        Desugar, simplify, convert to bytecode, and link an expression-%*                                                                      *-%********************************************************************* -}--hscCompileCoreExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO (ForeignHValue, [Linkable], PkgsLoaded)-hscCompileCoreExpr hsc_env loc expr =-  case hscCompileCoreExprHook (hsc_hooks hsc_env) of-      Nothing -> hscCompileCoreExpr' hsc_env loc expr-      Just h  -> h                   hsc_env loc expr--hscCompileCoreExpr' :: HscEnv -> SrcSpan -> CoreExpr -> IO (ForeignHValue, [Linkable], PkgsLoaded)-hscCompileCoreExpr' hsc_env srcspan ds_expr-    = do { {- Simplify it -}-           -- Question: should we call SimpleOpt.simpleOptExpr here instead?-           -- It is, well, simpler, and does less inlining etc.-           simpl_expr <- simplifyExpr hsc_env ds_expr--           {- Tidy it (temporary, until coreSat does cloning) -}-         ; let tidy_expr = tidyExpr emptyTidyEnv simpl_expr--           {- Prepare for codegen -}-         ; prepd_expr <- corePrepExpr hsc_env tidy_expr--           {- Lint if necessary -}-         ; lintInteractiveExpr (text "hscCompileExpr") hsc_env prepd_expr-         ; let iNTERACTIVELoc = ModLocation{ ml_hs_file   = Nothing,-                                      ml_hi_file   = panic "hscCompileCoreExpr':ml_hi_file",-                                      ml_obj_file  = panic "hscCompileCoreExpr':ml_obj_file",-                                      ml_dyn_obj_file = panic "hscCompileCoreExpr': ml_obj_file",-                                      ml_dyn_hi_file  = panic "hscCompileCoreExpr': ml_dyn_hi_file",-                                      ml_hie_file  = panic "hscCompileCoreExpr':ml_hie_file" }--         ; let ictxt = hsc_IC hsc_env-         ; (binding_id, stg_expr, _, _, _stg_cg_info) <--             myCoreToStgExpr (hsc_logger hsc_env)-                             (hsc_dflags hsc_env)-                             ictxt-                             True-                             (icInteractiveModule ictxt)-                             iNTERACTIVELoc-                             prepd_expr--           {- Convert to BCOs -}-         ; bcos <- byteCodeGen hsc_env-                     (icInteractiveModule ictxt)-                     stg_expr-                     [] Nothing--           {- load it -}-         ; (fv_hvs, mods_needed, units_needed) <- loadDecls (hscInterp hsc_env) hsc_env srcspan bcos-           {- Get the HValue for the root -}-         ; return (expectJust "hscCompileCoreExpr'"-              $ lookup (idName binding_id) fv_hvs, mods_needed, units_needed) }---{- **********************************************************************-%*                                                                      *-        Statistics on reading interfaces-%*                                                                      *-%********************************************************************* -}--dumpIfaceStats :: HscEnv -> IO ()-dumpIfaceStats hsc_env = do-  eps <- hscEPS hsc_env-  let-    logger = hsc_logger hsc_env-    dump_rn_stats = logHasDumpFlag logger Opt_D_dump_rn_stats-    dump_if_trace = logHasDumpFlag logger Opt_D_dump_if_trace-  when (dump_if_trace || dump_rn_stats) $-    logDumpMsg logger "Interface statistics" (ifaceStats eps)---{- **********************************************************************-%*                                                                      *-        Progress Messages: Module i of n-%*                                                                      *-%********************************************************************* -}--showModuleIndex :: (Int, Int) -> SDoc-showModuleIndex (i,n) = text "[" <> pad <> int i <> text " of " <> int n <> text "] "-  where-    -- compute the length of x > 0 in base 10-    len x = ceiling (logBase 10 (fromIntegral x+1) :: Float)-    pad = text (replicate (len n - len i) ' ') -- TODO: use GHC.Utils.Ppr.RStr--writeInterfaceOnlyMode :: DynFlags -> Bool-writeInterfaceOnlyMode dflags =- gopt Opt_WriteInterface dflags &&- NoBackend == backend dflags+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NondecreasingIndentation #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiWayIf #-}++{-# OPTIONS_GHC -fprof-auto-top #-}++-------------------------------------------------------------------------------+--+-- | Main API for compiling plain Haskell source code.+--+-- This module implements compilation of a Haskell source. It is+-- /not/ concerned with preprocessing of source files; this is handled+-- in "GHC.Driver.Pipeline"+--+-- There are various entry points depending on what mode we're in:+-- "batch" mode (@--make@), "one-shot" mode (@-c@, @-S@ etc.), and+-- "interactive" mode (GHCi). There are also entry points for+-- individual passes: parsing, typechecking/renaming, desugaring, and+-- simplification.+--+-- All the functions here take an 'HscEnv' as a parameter, but none of+-- them return a new one: 'HscEnv' is treated as an immutable value+-- from here on in (although it has mutable components, for the+-- caches).+--+-- We use the Hsc monad to deal with warning messages consistently:+-- specifically, while executing within an Hsc monad, warnings are+-- collected. When a Hsc monad returns to an IO monad, the+-- warnings are printed, or compilation aborts if the @-Werror@+-- flag is enabled.+--+-- (c) The GRASP/AQUA Project, Glasgow University, 1993-2000+--+-------------------------------------------------------------------------------++module GHC.Driver.Main+    (+    -- * Making an HscEnv+      newHscEnv+    , newHscEnvWithHUG+    , initHscEnv++    -- * Compiling complete source files+    , Messager, batchMsg, batchMultiMsg+    , HscBackendAction (..), HscRecompStatus (..)+    , initModDetails+    , initWholeCoreBindings+    , loadIfaceByteCode+    , loadIfaceByteCodeLazy+    , hscMaybeWriteIface+    , hscCompileCmmFile++    , hscGenHardCode+    , hscInteractive+    , mkCgInteractiveGuts+    , CgInteractiveGuts+    , generateByteCode+    , generateFreshByteCode++    -- * Running passes separately+    , hscRecompStatus+    , hscParse+    , hscTypecheckRename+    , hscTypecheckRenameWithDiagnostics+    , hscTypecheckAndGetWarnings+    , hscDesugar+    , makeSimpleDetails+    , hscSimplify -- ToDo, shouldn't really export this+    , hscDesugarAndSimplify++    -- * Safe Haskell+    , hscCheckSafe+    , hscGetSafe++    -- * Support for interactive evaluation+    , hscParseIdentifier+    , hscTcRcLookupName+    , hscTcRnGetInfo+    , hscIsGHCiMonad+    , hscGetModuleInterface+    , hscRnImportDecls+    , hscTcRnLookupRdrName+    , hscStmt, hscParseStmtWithLocation, hscStmtWithLocation, hscParsedStmt+    , hscParseDeclsWithLocation, hscParsedDecls+    , hscParseModuleWithLocation+    , hscTcExpr, TcRnExprMode(..), hscImport, hscKcType+    , hscParseExpr+    , hscParseType+    , hscCompileCoreExpr+    , hscTidy+++    -- * Low-level exports for hooks+    , hscCompileCoreExpr'+      -- We want to make sure that we export enough to be able to redefine+      -- hsc_typecheck in client code+    , hscParse', hscSimplify', hscDesugar', tcRnModule', doCodeGen+    , getHscEnv+    , hscSimpleIface'+    , oneShotMsg+    , dumpIfaceStats+    , ioMsgMaybe+    , showModuleIndex+    , hscAddSptEntries+    , writeInterfaceOnlyMode+    , loadByteCode+    , genModDetails+    ) where++import GHC.Prelude++import GHC.Platform++import GHC.Driver.Plugins+import GHC.Driver.Session+import GHC.Driver.Backend+import GHC.Driver.Env+import GHC.Driver.Env.KnotVars+import GHC.Driver.Errors+import GHC.Driver.Messager+import GHC.Driver.Errors.Types+import GHC.Driver.CodeOutput+import GHC.Driver.Config.Cmm.Parser (initCmmParserConfig)+import GHC.Driver.Config.Core.Opt.Simplify ( initSimplifyExprOpts )+import GHC.Driver.Config.Core.Lint ( endPassHscEnvIO )+import GHC.Driver.Config.Core.Lint.Interactive ( lintInteractiveExpr )+import GHC.Driver.Config.CoreToStg+import GHC.Driver.Config.CoreToStg.Prep+import GHC.Driver.Config.Logger   (initLogFlags)+import GHC.Driver.Config.Parser   (initParserOpts)+import GHC.Driver.Config.Stg.Ppr  (initStgPprOpts)+import GHC.Driver.Config.Stg.Pipeline (initStgPipelineOpts)+import GHC.Driver.Config.StgToCmm  (initStgToCmmConfig)+import GHC.Driver.Config.Cmm       (initCmmConfig)+import GHC.Driver.LlvmConfigCache  (initLlvmConfigCache)+import GHC.Driver.Config.StgToJS  (initStgToJSConfig)+import GHC.Driver.Config.Diagnostic+import GHC.Driver.Config.Tidy+import GHC.Driver.Hooks+import GHC.Driver.GenerateCgIPEStub (generateCgIPEStub, lookupEstimatedTicks)++import GHC.Runtime.Context+import GHC.Runtime.Interpreter+import GHC.Runtime.Interpreter.JS+import GHC.Runtime.Loader      ( initializePlugins )+import GHCi.RemoteTypes+import GHC.ByteCode.Types++import GHC.Linker.Loader+import GHC.Linker.Types+import GHC.Linker.Deps++import GHC.Hs+import GHC.Hs.Dump+import GHC.Hs.Stats         ( ppSourceStats )++import GHC.HsToCore++import GHC.StgToByteCode    ( byteCodeGen )+import GHC.StgToJS          ( stgToJS )+import GHC.StgToJS.Ids+import GHC.StgToJS.Types+import GHC.JS.Syntax++import GHC.IfaceToCore  ( typecheckIface, typecheckWholeCoreBindings )++import GHC.Iface.Load   ( ifaceStats, writeIface, flagsToIfCompression, getGhcPrimIface )+import GHC.Iface.Make+import GHC.Iface.Recomp+import GHC.Iface.Tidy+import GHC.Iface.Ext.Ast    ( mkHieFile )+import GHC.Iface.Ext.Types  ( getAsts, hie_asts, hie_module )+import GHC.Iface.Ext.Binary ( readHieFile, writeHieFile , hie_file_result)+import GHC.Iface.Ext.Debug  ( diffFile, validateScopes )++import GHC.Core+import GHC.Core.Lint.Interactive ( interactiveInScope )+import GHC.Core.Tidy           ( tidyExpr )+import GHC.Core.Utils          ( exprType )+import GHC.Core.ConLike+import GHC.Core.Opt.Pipeline+import GHC.Core.Opt.Pipeline.Types      ( CoreToDo (..))+import GHC.Core.TyCon+import GHC.Core.InstEnv+import GHC.Core.FamInstEnv+import GHC.Core.Rules+import GHC.Core.Stats+import GHC.Core.LateCC+import GHC.Core.LateCC.Types+++import GHC.CoreToStg.Prep( CorePrepPgmConfig, corePrepPgm, corePrepExpr )+import GHC.CoreToStg.AddImplicitBinds( addImplicitBinds )+import GHC.CoreToStg    ( coreToStg )++import GHC.Parser.Errors.Types+import GHC.Parser+import GHC.Parser.Lexer as Lexer++import GHC.Tc.Module+import GHC.Tc.Utils.Monad+import GHC.Tc.Utils.TcType+import GHC.Tc.Zonk.Env ( ZonkFlexi (DefaultFlexi) )++import GHC.Stg.Syntax+import GHC.Stg.Pipeline ( stg2stg, StgCgInfos )++import GHC.Builtin.Names++import qualified GHC.StgToCmm as StgToCmm ( codeGen )+import GHC.StgToCmm.Types (CmmCgInfos (..), ModuleLFInfos, LambdaFormInfo(..))+import GHC.StgToCmm.CgUtils (CgStream)++import GHC.Cmm+import GHC.Cmm.Info.Build+import GHC.Cmm.Pipeline+import GHC.Cmm.Info+import GHC.Cmm.Parser+import GHC.Cmm.UniqueRenamer++import GHC.Unit+import GHC.Unit.Env+import GHC.Unit.Finder+import GHC.Unit.Module.ModDetails+import GHC.Unit.Module.ModGuts+import GHC.Unit.Module.ModIface+import GHC.Unit.Module.ModSummary+import GHC.Unit.Module.Graph+import GHC.Unit.Module.Imported+import GHC.Unit.Module.Deps+import GHC.Unit.Module.Status+import GHC.Unit.Home.ModInfo++import GHC.Types.Id+import GHC.Types.SourceError+import GHC.Types.SafeHaskell+import GHC.Types.ForeignStubs+import GHC.Types.Name.Env      ( mkNameEnv )+import GHC.Types.Var.Env       ( mkEmptyTidyEnv )+import GHC.Types.Var.Set+import GHC.Types.Error+import GHC.Types.Fixity.Env+import GHC.Types.CostCentre+import GHC.Types.IPE+import GHC.Types.SourceFile+import GHC.Types.SrcLoc+import GHC.Types.Name+import GHC.Types.Name.Cache ( newNameCache )+import GHC.Types.Name.Reader+import GHC.Types.Name.Ppr+import GHC.Types.TyThing+import GHC.Types.Unique.Supply (uniqFromTag)+import GHC.Types.Unique.Set++import GHC.Utils.Fingerprint ( Fingerprint )+import GHC.Utils.Panic+import GHC.Utils.Error+import GHC.Utils.Outputable+import GHC.Utils.Misc+import GHC.Utils.Logger+import GHC.Utils.TmpFs+import GHC.Utils.Touch++import qualified GHC.LanguageExtensions as LangExt++import GHC.Data.FastString+import GHC.Data.Bag+import GHC.Data.OsPath (unsafeEncodeUtf)+import GHC.Data.StringBuffer+import qualified GHC.Data.Stream as Stream+import GHC.Data.Maybe++import GHC.SysTools (initSysTools)+import GHC.SysTools.BaseDir (findTopDir)++import Data.Data hiding (Fixity, TyCon)+import Data.Functor ((<&>))+import Data.List ( nub, isPrefixOf, partition )+import qualified Data.List.NonEmpty as NE+import Control.Monad+import Data.IORef+import System.FilePath as FilePath+import System.Directory+import qualified Data.Map as M+import Data.Map (Map)+import qualified Data.Set as S+import Data.Set (Set)+import Control.DeepSeq (force)+import Data.List.NonEmpty (NonEmpty ((:|)))+import GHC.Unit.Module.WholeCoreBindings+import GHC.Types.TypeEnv+import System.IO+import {-# SOURCE #-} GHC.Driver.Pipeline+import Data.Time++import System.IO.Unsafe ( unsafeInterleaveIO )+import GHC.Iface.Env ( trace_if )+import GHC.Platform.Ways+import GHC.Stg.EnforceEpt.TagSig (seqTagSig)+import GHC.StgToCmm.Utils (IPEStats)+import GHC.Types.Unique.FM+import GHC.Types.Unique.DFM+import GHC.Cmm.Config (CmmConfig)+import Data.Bifunctor+import qualified GHC.Unit.Home.Graph as HUG+import GHC.Unit.Home.PackageTable++{- **********************************************************************+%*                                                                      *+                Initialisation+%*                                                                      *+%********************************************************************* -}++newHscEnv :: FilePath -> DynFlags -> IO HscEnv+newHscEnv top_dir dflags = do+  hpt <- emptyHomePackageTable+  newHscEnvWithHUG top_dir dflags (homeUnitId_ dflags) (home_unit_graph hpt)+  where+    home_unit_graph hpt = HUG.unitEnv_singleton+                        (homeUnitId_ dflags)+                        (HUG.mkHomeUnitEnv emptyUnitState Nothing dflags hpt Nothing)++newHscEnvWithHUG :: FilePath -> DynFlags -> UnitId -> HomeUnitGraph -> IO HscEnv+newHscEnvWithHUG top_dir top_dynflags cur_unit home_unit_graph = do+    nc_var  <- newNameCache+    fc_var  <- initFinderCache+    logger  <- initLogger+    tmpfs   <- initTmpFs+    let dflags = homeUnitEnv_dflags $ HUG.unitEnv_lookup cur_unit home_unit_graph+    unit_env <- initUnitEnv cur_unit home_unit_graph (ghcNameVersion dflags) (targetPlatform dflags)+    llvm_config <- initLlvmConfigCache top_dir+    return HscEnv { hsc_dflags         = top_dynflags+                  , hsc_logger         = setLogFlags logger (initLogFlags top_dynflags)+                  , hsc_targets        = []+                  , hsc_IC             = emptyInteractiveContext dflags+                  , hsc_NC             = nc_var+                  , hsc_FC             = fc_var+                  , hsc_type_env_vars  = emptyKnotVars+                  , hsc_interp         = Nothing+                  , hsc_unit_env       = unit_env+                  , hsc_plugins        = emptyPlugins+                  , hsc_hooks          = emptyHooks+                  , hsc_tmpfs          = tmpfs+                  , hsc_llvm_config    = llvm_config+                  }++-- | Initialize HscEnv from an optional top_dir path+initHscEnv :: Maybe FilePath -> IO HscEnv+initHscEnv mb_top_dir = do+  top_dir <- findTopDir mb_top_dir+  mySettings <- initSysTools top_dir+  dflags <- initDynFlags (defaultDynFlags mySettings)+  hsc_env <- newHscEnv top_dir dflags+  setUnsafeGlobalDynFlags dflags+   -- c.f. DynFlags.parseDynamicFlagsFull, which+   -- creates DynFlags and sets the UnsafeGlobalDynFlags+  return hsc_env++-- -----------------------------------------------------------------------------++getDiagnostics :: Hsc (Messages GhcMessage)+getDiagnostics = Hsc $ \_ w -> return (w, w)++clearDiagnostics :: Hsc ()+clearDiagnostics = Hsc $ \_ _ -> return ((), emptyMessages)++logDiagnostics :: Messages GhcMessage -> Hsc ()+logDiagnostics w = Hsc $ \_ w0 -> return ((), w0 `unionMessages` w)++getHscEnv :: Hsc HscEnv+getHscEnv = Hsc $ \e w -> return (e, w)++handleWarnings :: Hsc ()+handleWarnings = do+    diag_opts <- initDiagOpts <$> getDynFlags+    print_config <- initPrintConfig <$> getDynFlags+    logger <- getLogger+    w <- getDiagnostics+    liftIO $ printOrThrowDiagnostics logger print_config diag_opts w+    clearDiagnostics++-- | log warning in the monad, and if there are errors then+-- throw a SourceError exception.+logWarningsReportErrors :: (Messages PsWarning, Messages PsError) -> Hsc ()+logWarningsReportErrors (warnings,errors) = do+    logDiagnostics (GhcPsMessage <$> warnings)+    when (not $ isEmptyMessages errors) $ throwErrors (GhcPsMessage <$> errors)++-- | Log warnings and throw errors, assuming the messages+-- contain at least one error (e.g. coming from PFailed)+handleWarningsThrowErrors :: (Messages PsWarning, Messages PsError) -> Hsc a+handleWarningsThrowErrors (warnings, errors) = do+    diag_opts <- initDiagOpts <$> getDynFlags+    logDiagnostics (GhcPsMessage <$> warnings)+    logger <- getLogger+    let (wWarns, wErrs) = partitionMessages warnings+    liftIO $ printMessages logger NoDiagnosticOpts diag_opts wWarns+    throwErrors $ fmap GhcPsMessage $ errors `unionMessages` wErrs++-- | Deal with errors and warnings returned by a compilation step+--+-- In order to reduce dependencies to other parts of the compiler, functions+-- outside the "main" parts of GHC return warnings and errors as a parameter+-- and signal success via by wrapping the result in a 'Maybe' type. This+-- function logs the returned warnings and propagates errors as exceptions+-- (of type 'SourceError').+--+-- This function assumes the following invariants:+--+--  1. If the second result indicates success (is of the form 'Just x'),+--     there must be no error messages in the first result.+--+--  2. If there are no error messages, but the second result indicates failure+--     there should be warnings in the first result. That is, if the action+--     failed, it must have been due to the warnings (i.e., @-Werror@).+ioMsgMaybe :: IO (Messages GhcMessage, Maybe a) -> Hsc a+ioMsgMaybe ioA = do+    (msgs, mb_r) <- liftIO ioA+    let (warns, errs) = partitionMessages msgs+    logDiagnostics warns+    case mb_r of+        Nothing -> throwErrors errs+        Just r  -> assert (isEmptyMessages errs ) return r++-- | like ioMsgMaybe, except that we ignore error messages and return+-- 'Nothing' instead.+ioMsgMaybe' :: IO (Messages GhcMessage, Maybe a) -> Hsc (Maybe a)+ioMsgMaybe' ioA = do+    (msgs, mb_r) <- liftIO $ ioA+    logDiagnostics (mkMessages $ getWarningMessages msgs)+    return mb_r++-- -----------------------------------------------------------------------------+-- | Lookup things in the compiler's environment++hscTcRnLookupRdrName :: HscEnv -> LocatedN RdrName -> IO (NonEmpty Name)+hscTcRnLookupRdrName hsc_env0 rdr_name+  = runInteractiveHsc hsc_env0 $+    do { hsc_env <- getHscEnv+       -- tcRnLookupRdrName can return empty list only together with TcRnUnknownMessage.+       -- Once errors has been dealt with in hoistTcRnMessage, we can enforce+       -- this invariant in types by converting to NonEmpty.+       ; ioMsgMaybe $ fmap (fmap (>>= NE.nonEmpty)) $ hoistTcRnMessage $+          tcRnLookupRdrName hsc_env rdr_name }++hscTcRcLookupName :: HscEnv -> Name -> IO (Maybe TyThing)+hscTcRcLookupName hsc_env0 name = runInteractiveHsc hsc_env0 $ do+  hsc_env <- getHscEnv+  ioMsgMaybe' $ hoistTcRnMessage $ tcRnLookupName hsc_env name+      -- ignore errors: the only error we're likely to get is+      -- "name not found", and the Maybe in the return type+      -- is used to indicate that.++hscTcRnGetInfo :: HscEnv -> Name+               -> IO (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))+hscTcRnGetInfo hsc_env0 name+  = runInteractiveHsc hsc_env0 $+    do { hsc_env <- getHscEnv+       ; ioMsgMaybe' $ hoistTcRnMessage $ tcRnGetInfo hsc_env name }++hscIsGHCiMonad :: HscEnv -> String -> IO Name+hscIsGHCiMonad hsc_env name+  = runHsc hsc_env $ ioMsgMaybe $ hoistTcRnMessage $ isGHCiMonad hsc_env name++hscGetModuleInterface :: HscEnv -> Module -> IO ModIface+hscGetModuleInterface hsc_env0 mod = runInteractiveHsc hsc_env0 $ do+  hsc_env <- getHscEnv+  ioMsgMaybe $ hoistTcRnMessage $ getModuleInterface hsc_env mod++-- -----------------------------------------------------------------------------+-- | Rename some import declarations+hscRnImportDecls :: HscEnv -> [LImportDecl GhcPs] -> IO GlobalRdrEnv+hscRnImportDecls hsc_env0 import_decls = runInteractiveHsc hsc_env0 $ do+  hsc_env <- getHscEnv+  ioMsgMaybe $ hoistTcRnMessage $ tcRnImportDecls hsc_env import_decls++-- -----------------------------------------------------------------------------+-- | parse a file, returning the abstract syntax++hscParse :: HscEnv -> ModSummary -> IO HsParsedModule+hscParse hsc_env mod_summary = runHsc hsc_env $ hscParse' mod_summary++-- internal version, that doesn't fail due to -Werror+hscParse' :: ModSummary -> Hsc HsParsedModule+hscParse' mod_summary+ | Just r <- ms_parsed_mod mod_summary = return r+ | otherwise = do+    dflags <- getDynFlags+    logger <- getLogger+    {-# SCC "Parser" #-} withTiming logger+                (text "Parser"<+>brackets (ppr $ ms_mod mod_summary))+                (const ()) $ do+    let src_filename  = ms_hspp_file mod_summary+        maybe_src_buf = ms_hspp_buf  mod_summary++    --------------------------  Parser  ----------------+    -- sometimes we already have the buffer in memory, perhaps+    -- because we needed to parse the imports out of it, or get the+    -- module name.+    buf <- case maybe_src_buf of+               Just b  -> return b+               Nothing -> liftIO $ hGetStringBuffer src_filename++    let loc = mkRealSrcLoc (mkFastString src_filename) 1 1++    let diag_opts = initDiagOpts dflags+    when (wopt Opt_WarnUnicodeBidirectionalFormatCharacters dflags) $ do+      case checkBidirectionFormatChars (PsLoc loc (BufPos 0)) buf of+        Nothing -> pure ()+        Just chars@((eloc,chr,_) :| _) ->+          let span = mkSrcSpanPs $ mkPsSpan eloc (advancePsLoc eloc chr)+          in logDiagnostics $ singleMessage $+               mkPlainMsgEnvelope diag_opts span $+               GhcPsMessage $ PsWarnBidirectionalFormatChars chars++    let parseMod | HsigFile == ms_hsc_src mod_summary+                 = parseSignature+                 | otherwise = parseModule++    case unP parseMod (initParserState (initParserOpts dflags) buf loc) of+        PFailed pst ->+            handleWarningsThrowErrors (getPsMessages pst)+        POk pst rdr_module -> do+            liftIO $ putDumpFileMaybe logger Opt_D_dump_parsed "Parser"+                        FormatHaskell (ppr rdr_module)+            liftIO $ putDumpFileMaybe logger Opt_D_dump_parsed_ast "Parser AST"+                        FormatHaskell (showAstData NoBlankSrcSpan+                                                   NoBlankEpAnnotations+                                                   rdr_module)+            liftIO $ putDumpFileMaybe logger Opt_D_source_stats "Source Statistics"+                        FormatText (ppSourceStats False rdr_module)++            -- To get the list of extra source files, we take the list+            -- that the parser gave us,+            --   - eliminate files beginning with '<'.  gcc likes to use+            --     pseudo-filenames like "<built-in>" and "<command-line>"+            --   - normalise them (eliminate differences between ./f and f)+            --   - filter out the preprocessed source file+            --   - filter out anything beginning with tmpdir+            --   - remove duplicates+            --   - filter out the .hs/.lhs source filename if we have one+            --+            let n_hspp  = FilePath.normalise src_filename+                TempDir tmp_dir = tmpDir dflags+                srcs0 = nub $ filter (not . (tmp_dir `isPrefixOf`))+                            $ filter (not . (== n_hspp))+                            $ map FilePath.normalise+                            $ filter (not . isPrefixOf "<")+                            $ map unpackFS+                            $ srcfiles pst+                srcs1 = case ml_hs_file (ms_location mod_summary) of+                          Just f  -> filter (/= FilePath.normalise f) srcs0+                          Nothing -> srcs0++            -- sometimes we see source files from earlier+            -- preprocessing stages that cannot be found, so just+            -- filter them out:+            srcs2 <- liftIO $ filterM doesFileExist srcs1++            let res = HsParsedModule {+                      hpm_module    = rdr_module,+                      hpm_src_files = srcs2+                   }++            -- apply parse transformation of plugins+            let applyPluginAction p opts+                  = parsedResultAction p opts mod_summary+            hsc_env <- getHscEnv+            (ParsedResult transformed (PsMessages warns errs)) <-+              withPlugins (hsc_plugins hsc_env) applyPluginAction+                (ParsedResult res (uncurry PsMessages $ getPsMessages pst))++            logDiagnostics (GhcPsMessage <$> warns)+            unless (isEmptyMessages errs) $ throwErrors (GhcPsMessage <$> errs)++            return transformed++checkBidirectionFormatChars :: PsLoc -> StringBuffer -> Maybe (NonEmpty (PsLoc, Char, String))+checkBidirectionFormatChars start_loc sb+  | containsBidirectionalFormatChar sb = Just $ go start_loc sb+  | otherwise = Nothing+  where+    go :: PsLoc -> StringBuffer -> NonEmpty (PsLoc, Char, String)+    go loc sb+      | atEnd sb = panic "checkBidirectionFormatChars: no char found"+      | otherwise = case nextChar sb of+          (chr, sb)+            | Just desc <- lookup chr bidirectionalFormatChars ->+                (loc, chr, desc) :| go1 (advancePsLoc loc chr) sb+            | otherwise -> go (advancePsLoc loc chr) sb++    go1 :: PsLoc -> StringBuffer -> [(PsLoc, Char, String)]+    go1 loc sb+      | atEnd sb = []+      | otherwise = case nextChar sb of+          (chr, sb)+            | Just desc <- lookup chr bidirectionalFormatChars ->+                (loc, chr, desc) : go1 (advancePsLoc loc chr) sb+            | otherwise -> go1 (advancePsLoc loc chr) sb+++-- -----------------------------------------------------------------------------+-- | If the renamed source has been kept, extract it. Dump it if requested.+++extract_renamed_stuff :: ModSummary -> TcGblEnv -> Hsc RenamedStuff+extract_renamed_stuff mod_summary tc_result = do+    let rn_info = getRenamedStuff tc_result++    dflags <- getDynFlags+    logger <- getLogger+    liftIO $ putDumpFileMaybe logger Opt_D_dump_rn_ast "Renamer"+                FormatHaskell (showAstData NoBlankSrcSpan NoBlankEpAnnotations rn_info)++    -- Create HIE files+    when (gopt Opt_WriteHie dflags) $ do+        -- I assume this fromJust is safe because `-fwrite-hie-file`+        -- enables the option which keeps the renamed source.+        hieFile <- mkHieFile mod_summary tc_result (fromJust rn_info)+        let out_file = ml_hie_file $ ms_location mod_summary+        liftIO $ writeHieFile out_file hieFile+        liftIO $ putDumpFileMaybe logger Opt_D_dump_hie "HIE AST" FormatHaskell (ppr $ hie_asts hieFile)++        -- Validate HIE files+        when (gopt Opt_ValidateHie dflags) $ do+            hs_env <- getHscEnv+            liftIO $ do+              -- Validate Scopes+              case validateScopes (hie_module hieFile) $ getAsts $ hie_asts hieFile of+                  [] -> putMsg logger $ text "Got valid scopes"+                  xs -> do+                    putMsg logger $ text "Got invalid scopes"+                    mapM_ (putMsg logger) xs+              -- Roundtrip testing+              file' <- readHieFile (hsc_NC hs_env) out_file+              case diffFile hieFile (hie_file_result file') of+                [] ->+                  putMsg logger $ text "Got no roundtrip errors"+                xs -> do+                  putMsg logger $ text "Got roundtrip errors"+                  let logger' = updateLogFlags logger (log_set_dopt Opt_D_ppr_debug)+                  mapM_ (putMsg logger') xs+    return rn_info+++-- -----------------------------------------------------------------------------+-- | Rename and typecheck a module, additionally returning the renamed syntax+hscTypecheckRename :: HscEnv -> ModSummary -> HsParsedModule+                   -> IO (TcGblEnv, RenamedStuff)+hscTypecheckRename hsc_env mod_summary rdr_module =+    fst <$> hscTypecheckRenameWithDiagnostics hsc_env mod_summary rdr_module++-- | Rename and typecheck a module, additionally returning the renamed syntax+-- and the diagnostics produced.+hscTypecheckRenameWithDiagnostics :: HscEnv -> ModSummary -> HsParsedModule+                                  -> IO ((TcGblEnv, RenamedStuff), Messages GhcMessage)+hscTypecheckRenameWithDiagnostics hsc_env mod_summary rdr_module = runHsc' hsc_env $+    hsc_typecheck True mod_summary (Just rdr_module)++-- | Do Typechecking without throwing SourceError exception with -Werror+hscTypecheckAndGetWarnings :: HscEnv ->  ModSummary -> IO (FrontendResult, WarningMessages)+hscTypecheckAndGetWarnings hsc_env summary = runHsc' hsc_env $ do+  case hscFrontendHook (hsc_hooks hsc_env) of+    Nothing -> FrontendTypecheck . fst <$> hsc_typecheck False summary Nothing+    Just h  -> h summary++-- | A bunch of logic piled around @tcRnModule'@, concerning a) backpack+-- b) concerning dumping rename info and hie files. It would be nice to further+-- separate this stuff out, probably in conjunction better separating renaming+-- and type checking (#17781).+hsc_typecheck :: Bool -- ^ Keep renamed source?+              -> ModSummary -> Maybe HsParsedModule+              -> Hsc (TcGblEnv, RenamedStuff)+hsc_typecheck keep_rn mod_summary mb_rdr_module = do+    hsc_env <- getHscEnv+    let hsc_src = ms_hsc_src mod_summary+        dflags = hsc_dflags hsc_env+        home_unit = hsc_home_unit hsc_env+        outer_mod = ms_mod mod_summary+        mod_name = moduleName outer_mod+        outer_mod' = mkHomeModule home_unit mod_name+        inner_mod = homeModuleNameInstantiation home_unit mod_name+        src_filename  = ms_hspp_file mod_summary+        real_loc = realSrcLocSpan $ mkRealSrcLoc (mkFastString src_filename) 1 1+        keep_rn' = gopt Opt_WriteHie dflags || keep_rn+    massert (isHomeModule home_unit outer_mod)+    tc_result <- if hsc_src == HsigFile && not (isHoleModule inner_mod)+        then ioMsgMaybe $ hoistTcRnMessage $ tcRnInstantiateSignature hsc_env outer_mod' real_loc+        else+         do hpm <- case mb_rdr_module of+                    Just hpm -> return hpm+                    Nothing -> hscParse' mod_summary+            tc_result0 <- tcRnModule' mod_summary keep_rn' hpm+            if hsc_src == HsigFile+                then do (iface, _) <- liftIO $ hscSimpleIface hsc_env Nothing tc_result0 mod_summary+                        ioMsgMaybe $ hoistTcRnMessage $+                            tcRnMergeSignatures hsc_env hpm tc_result0 iface+                else return tc_result0+    -- TODO are we extracting anything when we merely instantiate a signature?+    -- If not, try to move this into the "else" case above.+    rn_info <- extract_renamed_stuff mod_summary tc_result+    return (tc_result, rn_info)++-- wrapper around tcRnModule to handle safe haskell extras+tcRnModule' :: ModSummary -> Bool -> HsParsedModule+            -> Hsc TcGblEnv+tcRnModule' sum save_rn_syntax mod = do+    hsc_env <- getHscEnv+    dflags  <- getDynFlags++    let diag_opts = initDiagOpts dflags+    -- -Wmissing-safe-haskell-mode+    when (not (safeHaskellModeEnabled dflags)+          && wopt Opt_WarnMissingSafeHaskellMode dflags) $+        logDiagnostics $ singleMessage $+        mkPlainMsgEnvelope diag_opts (getLoc (hpm_module mod)) $+        GhcDriverMessage $ DriverMissingSafeHaskellMode (ms_mod sum)++    tcg_res <- {-# SCC "Typecheck-Rename" #-}+               ioMsgMaybe $ hoistTcRnMessage $+                   tcRnModule hsc_env sum+                     save_rn_syntax mod++    -- See Note [Safe Haskell Overlapping Instances Implementation]+    -- although this is used for more than just that failure case.+    tcSafeOK <- liftIO $ readIORef (tcg_safe_infer tcg_res)+    whyUnsafe <- liftIO $ readIORef (tcg_safe_infer_reasons tcg_res)+    let allSafeOK = safeInferred dflags && tcSafeOK++    -- end of the safe haskell line, how to respond to user?+    if not (safeHaskellOn dflags)+         || (safeInferOn dflags && not allSafeOK)+      -- if safe Haskell off or safe infer failed, mark unsafe+      then markUnsafeInfer tcg_res whyUnsafe++      -- module (could be) safe, throw warning if needed+      else do+          tcg_res' <- hscCheckSafeImports tcg_res+          safe <- liftIO $ readIORef (tcg_safe_infer tcg_res')+          when safe $+            case wopt Opt_WarnSafe dflags of+              True+                | safeHaskell dflags == Sf_Safe -> return ()+                | otherwise -> (logDiagnostics $ singleMessage $+                       mkPlainMsgEnvelope diag_opts (warnSafeOnLoc dflags) $+                       GhcDriverMessage $ DriverInferredSafeModule (tcg_mod tcg_res'))+              False | safeHaskell dflags == Sf_Trustworthy &&+                      wopt Opt_WarnTrustworthySafe dflags ->+                      (logDiagnostics $ singleMessage $+                       mkPlainMsgEnvelope diag_opts (trustworthyOnLoc dflags) $+                       GhcDriverMessage $ DriverMarkedTrustworthyButInferredSafe (tcg_mod tcg_res'))+              False -> return ()+          return tcg_res'++-- | Convert a typechecked module to Core+hscDesugar :: HscEnv -> ModSummary -> TcGblEnv -> IO ModGuts+hscDesugar hsc_env mod_summary tc_result =+    runHsc hsc_env $ hscDesugar' (ms_location mod_summary) tc_result++hscDesugar' :: ModLocation -> TcGblEnv -> Hsc ModGuts+hscDesugar' mod_location tc_result = do+    hsc_env <- getHscEnv+    ioMsgMaybe $ hoistDsMessage $+      {-# SCC "deSugar" #-}+      deSugar hsc_env mod_location tc_result++-- | Make a 'ModDetails' from the results of typechecking. Used when+-- typechecking only, as opposed to full compilation.+makeSimpleDetails :: Logger -> TcGblEnv -> IO ModDetails+makeSimpleDetails logger tc_result = mkBootModDetailsTc logger tc_result+++{- **********************************************************************+%*                                                                      *+                The main compiler pipeline+%*                                                                      *+%********************************************************************* -}++{-+                   --------------------------------+                        The compilation proper+                   --------------------------------++It's the task of the compilation proper to compile Haskell, hs-boot and core+files to either byte-code, hard-code (C, asm, LLVM, etc.) or to nothing at all+(the module is still parsed and type-checked. This feature is mostly used by+IDE's and the likes). Compilation can happen in either 'one-shot', 'batch',+'nothing', or 'interactive' mode. 'One-shot' mode targets hard-code, 'batch'+mode targets hard-code, 'nothing' mode targets nothing and 'interactive' mode+targets byte-code.++The modes are kept separate because of their different types and meanings:++ * In 'one-shot' mode, we're only compiling a single file and can therefore+ discard the new ModIface and ModDetails. This is also the reason it only+ targets hard-code; compiling to byte-code or nothing doesn't make sense when+ we discard the result.++ * 'Batch' mode is like 'one-shot' except that we keep the resulting ModIface+ and ModDetails. 'Batch' mode doesn't target byte-code since that require us to+ return the newly compiled byte-code.++ * 'Nothing' mode has exactly the same type as 'batch' mode but they're still+ kept separate. This is because compiling to nothing is fairly special: We+ don't output any interface files, we don't run the simplifier and we don't+ generate any code.++ * 'Interactive' mode is similar to 'batch' mode except that we return the+ compiled byte-code together with the ModIface and ModDetails.++Trying to compile a hs-boot file to byte-code will result in a run-time error.+This is the only thing that isn't caught by the type-system.+-}++++-- | Do the recompilation avoidance checks for both one-shot and --make modes+-- This function is the *only* place in the compiler where we decide whether to+-- recompile a module or not!+hscRecompStatus :: Maybe Messager+                -> HscEnv+                -> ModSummary+                -> Maybe ModIface+                -> HomeModLinkable+                -> (Int,Int)+                -> IO HscRecompStatus+hscRecompStatus+    mHscMessage hsc_env mod_summary mb_old_iface old_linkable mod_index+  = do+    let+        msg what = case mHscMessage of+          Just hscMessage -> hscMessage hsc_env mod_index what (ModuleNode [] (ModuleNodeCompile mod_summary))+          Nothing -> return ()++    -- First check to see if the interface file agrees with the+    -- source file.+    --+    -- Save the interface that comes back from checkOldIface.+    -- In one-shot mode we don't have the old iface until this+    -- point, when checkOldIface reads it from the disk.+    recomp_if_result+          <- {-# SCC "checkOldIface" #-}+             liftIO $ checkOldIface hsc_env mod_summary mb_old_iface+    case recomp_if_result of+      OutOfDateItem reason mb_checked_iface -> do+        msg $ NeedsRecompile reason+        return $ HscRecompNeeded $ fmap mi_iface_hash mb_checked_iface+      UpToDateItem checked_iface -> do+        let lcl_dflags = ms_hspp_opts mod_summary+        if | not (backendGeneratesCode (backend lcl_dflags)) -> do+               -- No need for a linkable, we're good to go+               msg UpToDate+               return $ HscUpToDate checked_iface emptyHomeModInfoLinkable+           | not (backendGeneratesCodeForHsBoot (backend lcl_dflags))+           , IsBoot <- isBootSummary mod_summary -> do+               msg UpToDate+               return $ HscUpToDate checked_iface emptyHomeModInfoLinkable++           -- Always recompile with the JS backend when TH is enabled until+           -- #23013 is fixed.+           | ArchJavaScript <- platformArch (targetPlatform lcl_dflags)+           , xopt LangExt.TemplateHaskell lcl_dflags+           -> do+              msg $ needsRecompileBecause THWithJS+              return $ HscRecompNeeded $ Just $ mi_iface_hash $ checked_iface++           | otherwise -> do+               -- Do need linkable+               -- 1. Just check whether we have bytecode/object linkables and then+               -- we will decide if we need them or not.+               bc_linkable <- checkByteCode checked_iface mod_summary (homeMod_bytecode old_linkable)+               obj_linkable <- liftIO $ checkObjects lcl_dflags (homeMod_object old_linkable) mod_summary+               trace_if (hsc_logger hsc_env) (vcat [text "BCO linkable", nest 2 (ppr bc_linkable), text "Object Linkable", ppr obj_linkable])++               let just_bc = justBytecode <$> bc_linkable+                   just_o  = justObjects  <$> obj_linkable+                   _maybe_both_os = case (bc_linkable, obj_linkable) of+                               (UpToDateItem bc, UpToDateItem o) -> UpToDateItem (bytecodeAndObjects bc o)+                               -- If missing object code, just say we need to recompile because of object code.+                               (_, OutOfDateItem reason _) -> OutOfDateItem reason Nothing+                               -- If just missing byte code, just use the object code+                               -- so you should use -fprefer-byte-code with -fwrite-if-simplified-core or you'll+                               -- end up using bytecode on recompilation+                               (_, UpToDateItem {} ) -> just_o++                   definitely_both_os = case (bc_linkable, obj_linkable) of+                               (UpToDateItem bc, UpToDateItem o) -> UpToDateItem (bytecodeAndObjects bc o)+                               -- If missing object code, just say we need to recompile because of object code.+                               (_, OutOfDateItem reason _) -> OutOfDateItem reason Nothing+                               -- If just missing byte code, just use the object code+                               -- so you should use -fprefer-byte-code with -fwrite-if-simplified-core or you'll+                               -- end up using bytecode on recompilation+                               (OutOfDateItem reason _,  _ ) -> OutOfDateItem reason Nothing++--               pprTraceM "recomp" (ppr just_bc <+> ppr just_o)+               -- 2. Decide which of the products we will need+               let recomp_linkable_result = case () of+                     _ | backendCanReuseLoadedCode (backend lcl_dflags) ->+                           case bc_linkable of+                             -- If bytecode is available for Interactive then don't load object code+                             UpToDateItem _ -> just_bc+                             _ -> case obj_linkable of+                                     -- If o is availabe, then just use that+                                     UpToDateItem _ -> just_o+                                     _ -> outOfDateItemBecause MissingBytecode Nothing+                        -- Need object files for making object files+                        | backendWritesFiles (backend lcl_dflags) ->+                           if gopt Opt_ByteCodeAndObjectCode lcl_dflags+                             -- We say we are going to write both, so recompile unless we have both+                             then definitely_both_os+                             -- Only load the object file unless we are saying we need to produce both.+                             -- Unless we do this then you can end up using byte-code for a module you specify -fobject-code for.+                             else just_o+                        | otherwise -> pprPanic "hscRecompStatus" (text $ show $ backend lcl_dflags)+               case recomp_linkable_result of+                 UpToDateItem linkable -> do+                   msg $ UpToDate+                   return $ HscUpToDate checked_iface $ linkable+                 OutOfDateItem reason _ -> do+                   msg $ NeedsRecompile reason+                   return $ HscRecompNeeded $ Just $ mi_iface_hash $ checked_iface++-- | Check that the .o files produced by compilation are already up-to-date+-- or not.+checkObjects :: DynFlags -> Maybe Linkable -> ModSummary -> IO (MaybeValidated Linkable)+checkObjects dflags mb_old_linkable summary = do+  let+    dt_enabled  = gopt Opt_BuildDynamicToo dflags+    this_mod    = ms_mod summary+    mb_obj_date = ms_obj_date summary+    mb_dyn_obj_date = ms_dyn_obj_date summary+    mb_if_date  = ms_iface_date summary+    obj_fn      = ml_obj_file (ms_location summary)+    -- dynamic-too *also* produces the dyn_o_file, so have to check+    -- that's there, and if it's not, regenerate both .o and+    -- .dyn_o+    checkDynamicObj k = if dt_enabled+      then case (>=) <$> mb_dyn_obj_date <*> mb_if_date of+        Just True -> k+        _ -> return $ outOfDateItemBecause MissingDynObjectFile Nothing+      -- Not in dynamic-too mode+      else k++  checkDynamicObj $+    case (,) <$> mb_obj_date <*> mb_if_date of+      Just (obj_date, if_date)+        | obj_date >= if_date ->+            case mb_old_linkable of+              Just old_linkable+                | linkableIsNativeCodeOnly old_linkable, linkableTime old_linkable == obj_date+                -> return $ UpToDateItem old_linkable+              _ -> UpToDateItem <$> findObjectLinkable this_mod obj_fn obj_date+      _ -> return $ outOfDateItemBecause MissingObjectFile Nothing++-- | Check to see if we can reuse the old linkable, by this point we will+-- have just checked that the old interface matches up with the source hash, so+-- no need to check that again here+checkByteCode :: ModIface -> ModSummary -> Maybe Linkable -> IO (MaybeValidated Linkable)+checkByteCode iface mod_sum mb_old_linkable =+  case mb_old_linkable of+    Just old_linkable+      | not (linkableIsNativeCodeOnly old_linkable)+      -> return $ (UpToDateItem old_linkable)+    _ -> loadByteCode iface mod_sum++loadByteCode :: ModIface -> ModSummary -> IO (MaybeValidated Linkable)+loadByteCode iface mod_sum = do+    let+      this_mod   = ms_mod mod_sum+      if_date    = fromJust $ ms_iface_date mod_sum+    case iface_core_bindings iface (ms_location mod_sum) of+      Just fi -> do+          return (UpToDateItem (Linkable if_date this_mod (NE.singleton (CoreBindings fi))))+      _ -> return $ outOfDateItemBecause MissingBytecode Nothing++--------------------------------------------------------------+-- Compilers+--------------------------------------------------------------++add_iface_to_hpt :: ModIface -> ModDetails -> HscEnv -> IO ()+add_iface_to_hpt iface details =+  hscInsertHPT (HomeModInfo iface details emptyHomeModInfoLinkable)++-- Knot tying!  See Note [Knot-tying typecheckIface]+-- See Note [ModDetails and --make mode]+initModDetails :: HscEnv -> ModIface -> IO ModDetails+initModDetails hsc_env iface =+  fixIO $ \details' -> do+    add_iface_to_hpt iface details' hsc_env+    -- NB: This result is actually not that useful+    -- in one-shot mode, since we're not going to do+    -- any further typechecking.  It's much more useful+    -- in make mode, since this HMI will go into the HPT.+    genModDetails hsc_env iface++-- | Modify flags such that objects are compiled for the interpreter's way.+-- This is necessary when building foreign objects for Template Haskell, since+-- those are object code built outside of the pipeline, which means they aren't+-- subject to the mechanism in 'enableCodeGenWhen' that requests dynamic build+-- outputs for dependencies when the interpreter used for TH is dynamic but the+-- main outputs aren't.+-- Furthermore, the HPT only stores one set of objects with different names for+-- bytecode linking in 'HomeModLinkable', so the usual hack for switching+-- between ways in 'get_link_deps' doesn't work.+compile_for_interpreter :: HscEnv -> (HscEnv -> IO a) -> IO a+compile_for_interpreter hsc_env use =+  use (hscUpdateFlags update hsc_env)+  where+    update dflags = dflags {+      targetWays_ = adapt_way interpreterDynamic WayDyn $+                    adapt_way interpreterProfiled WayProf $+                    targetWays_ dflags+      }++    adapt_way want = if want (hscInterp hsc_env) then addWay else removeWay++-- | Assemble 'WholeCoreBindings' if the interface contains Core bindings.+iface_core_bindings :: ModIface -> ModLocation -> Maybe WholeCoreBindings+iface_core_bindings iface wcb_mod_location =+  mi_simplified_core <&> \(IfaceSimplifiedCore bindings foreign') ->+    WholeCoreBindings {+      wcb_bindings = bindings,+      wcb_module = mi_module,+      wcb_mod_location,+      wcb_foreign = foreign'+    }+  where+    ModIface {mi_module, mi_simplified_core} = iface++-- | Return an 'IO' that hydrates Core bindings and compiles them to bytecode if+-- the interface contains any, using the supplied type env for typechecking.+--+-- Unlike 'initWholeCoreBindings', this does not use lazy IO.+-- Instead, the 'IO' is only evaluated (in @get_link_deps@) when it is clear+-- that it will be used immediately (because we're linking TH with+-- @-fprefer-byte-code@ in oneshot mode), and the result is cached in+-- 'LoaderState'.+--+-- 'initWholeCoreBindings' needs the laziness because it is used to populate+-- 'HomeModInfo', which is done preemptively, in anticipation of downstream+-- modules using the bytecode for TH in make mode, which might never happen.+loadIfaceByteCode ::+  HscEnv ->+  ModIface ->+  ModLocation ->+  TypeEnv ->+  Maybe (IO Linkable)+loadIfaceByteCode hsc_env iface location type_env =+  compile <$> iface_core_bindings iface location+  where+    compile decls = do+      (bcos, fos) <- compileWholeCoreBindings hsc_env type_env decls+      linkable $ BCOs bcos :| [DotO fo ForeignObject | fo <- fos]++    linkable parts = do+      if_time <- modificationTimeIfExists (ml_hi_file location)+      time <- maybe getCurrentTime pure if_time+      return $! Linkable time (mi_module iface) parts++loadIfaceByteCodeLazy ::+  HscEnv ->+  ModIface ->+  ModLocation ->+  TypeEnv ->+  IO (Maybe Linkable)+loadIfaceByteCodeLazy hsc_env iface location type_env =+  case iface_core_bindings iface location of+    Nothing -> return Nothing+    Just wcb -> do+      Just <$> compile wcb+  where+    compile decls = do+      ~(bcos, fos) <- unsafeInterleaveIO $ compileWholeCoreBindings hsc_env type_env decls+      linkable $ NE.singleton (LazyBCOs bcos fos)++    linkable parts = do+      if_time <- modificationTimeIfExists (ml_hi_file location)+      time <- maybe getCurrentTime pure if_time+      return $!Linkable time (mi_module iface) parts++-- | If the 'Linkable' contains Core bindings loaded from an interface, replace+-- them with a lazy IO thunk that compiles them to bytecode and foreign objects,+-- using the supplied environment for type checking.+--+-- The laziness is necessary because this value is stored purely in a+-- 'HomeModLinkable' in the home package table, rather than some dedicated+-- mutable state that would generate bytecode on demand, so we have to call this+-- function even when we don't know that we'll need the bytecode.+--+-- In addition, the laziness has to be hidden inside 'LazyBCOs' because+-- 'Linkable' is used too generally, so that looking at the constructor to+-- decide whether to discard it when linking native code would force the thunk+-- otherwise, incurring a significant performance penalty.+--+-- This is sound because generateByteCode just depends on things already loaded+-- in the interface file.++-- TODO: We should just use loadIfaceByteCodeLazy instead of the two stage process with+-- loadByteCode and initWholeCoreBindings. The main reason it is like this is because+-- initWholeCoreBindings requires a ModDetails, which we don't have during recompilation+-- checking. We should modify recompilation checking to return a HomeModInfo directly.++initWholeCoreBindings ::+  HscEnv ->+  ModIface ->+  ModDetails ->+  Linkable ->+  IO Linkable+initWholeCoreBindings hsc_env iface details (Linkable utc_time this_mod uls) = do+  Linkable utc_time this_mod <$> mapM (go hsc_env) uls+  where+    go hsc_env' = \case+      CoreBindings wcb -> do+        add_iface_to_hpt iface details hsc_env+        ~(bco, fos) <- unsafeInterleaveIO $+                       compileWholeCoreBindings hsc_env' type_env wcb+        pure (LazyBCOs bco fos)+      l -> pure l++    type_env = md_types details++-- | Hydrate interface Core bindings and compile them to bytecode.+--+-- This consists of:+--+-- 1. Running a typechecking step to insert the global names that were removed+--    when the interface was written or were unavailable due to boot import+--    cycles, converting the bindings to 'CoreBind'.+--+-- 2. Restoring the foreign build inputs from their serialized format, resulting+--    in a set of foreign import stubs and source files added via+--    'qAddForeignFilePath'.+--+-- 3. Generating bytecode and foreign objects from the results of the previous+--    steps using the usual pipeline actions.+compileWholeCoreBindings ::+  HscEnv ->+  TypeEnv ->+  WholeCoreBindings ->+  IO (CompiledByteCode, [FilePath])+compileWholeCoreBindings hsc_env type_env wcb = do+  core_binds <- typecheck+  (stubs, foreign_files) <- decode_foreign+  gen_bytecode core_binds stubs foreign_files+  where+    typecheck = do+      types_var <- newIORef type_env+      let+        tc_env = hsc_env {+          hsc_type_env_vars =+            knotVarsFromModuleEnv (mkModuleEnv [(wcb_module, types_var)])+        }+      initIfaceCheck (text "l") tc_env $+        typecheckWholeCoreBindings types_var wcb++    decode_foreign =+      decodeIfaceForeign logger (hsc_tmpfs hsc_env)+      (tmpDir (hsc_dflags hsc_env)) wcb_foreign++    gen_bytecode core_binds stubs foreign_files = do+      let cgi_guts = CgInteractiveGuts wcb_module core_binds+                      (typeEnvTyCons type_env) stubs foreign_files+                      Nothing []+      trace_if logger (text "Generating ByteCode for" <+> ppr wcb_module)+      generateByteCode hsc_env cgi_guts wcb_mod_location++    WholeCoreBindings {wcb_module, wcb_mod_location, wcb_foreign} = wcb++    logger = hsc_logger hsc_env++{-+Note [ModDetails and --make mode]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+An interface file consists of two parts++* The `ModIface` which ends up getting written to disk.+  The `ModIface` is a completely acyclic tree, which can be serialised+  and de-serialised completely straightforwardly.  The `ModIface` is+  also the structure that is finger-printed for recompilation control.++* The `ModDetails` which provides a more structured view that is suitable+  for usage during compilation.  The `ModDetails` is heavily cyclic:+  An `Id` contains a `Type`, which mentions a `TyCon` that contains kind+  that mentions other `TyCons`; the `Id` also includes an unfolding that+  in turn mentions more `Id`s;  And so on.++The `ModIface` can be created from the `ModDetails` and the `ModDetails` from+a `ModIface`.++During tidying, just before interfaces are written to disk,+the ModDetails is calculated and then converted into a ModIface (see GHC.Iface.Make.mkIface_).+Then when GHC needs to restart typechecking from a certain point it can read the+interface file, and regenerate the ModDetails from the ModIface (see GHC.IfaceToCore.typecheckIface).+The key part about the loading is that the ModDetails is regenerated lazily+from the ModIface, so that there's only a detailed in-memory representation+for declarations which are actually used from the interface. This mode is+also used when reading interface files from external packages.++In the old --make mode implementation, the interface was written after compiling a module+but the in-memory ModDetails which was used to compute the ModIface was retained.+The result was that --make mode used much more memory than `-c` mode, because a large amount of+information about a module would be kept in the ModDetails but never used.++The new idea is that even in `--make` mode, when there is an in-memory `ModDetails`+at hand, we re-create the `ModDetails` from the `ModIface`. Doing this means that+we only have to keep the `ModIface` decls in memory and then lazily load+detailed representations if needed. It turns out this makes a really big difference+to memory usage, halving maximum memory used in some cases.++See !5492 and #13586+-}++-- Runs the post-typechecking frontend (desugar and simplify). We want to+-- generate most of the interface as late as possible. This gets us up-to-date+-- and good unfoldings and other info in the interface file.+--+-- We might create a interface right away, in which case we also return the+-- updated HomeModInfo. But we might also need to run the backend first. In the+-- later case Status will be HscRecomp and we return a function from ModIface ->+-- HomeModInfo.+--+-- HscRecomp in turn will carry the information required to compute a interface+-- when passed the result of the code generator. So all this can and is done at+-- the call site of the backend code gen if it is run.+hscDesugarAndSimplify :: ModSummary+       -> FrontendResult+       -> Messages GhcMessage+       -> Maybe Fingerprint+       -> Hsc HscBackendAction+hscDesugarAndSimplify summary (FrontendTypecheck tc_result) tc_warnings mb_old_hash = do+  hsc_env <- getHscEnv+  dflags <- getDynFlags+  logger <- getLogger+  let bcknd  = backend dflags+      hsc_src = ms_hsc_src summary+      diag_opts = initDiagOpts dflags+      print_config = initPrintConfig dflags++  -- Desugar, if appropriate+  --+  -- We usually desugar even when we are not generating code, otherwise we+  -- would miss errors thrown by the desugaring (see #10600). The only+  -- exception is when it is not a HsSrcFile module.+  mb_desugar <- if+    | hsc_src /= HsSrcFile       -> pure Nothing+    -- Desugar an empty ghc-prim:GHC.Prim module by filtering out all its+    -- bindings: the reason is that some of them are invalid (such as top-level+    -- unlifted ones like void# or proxy#) and cause HsToCore failures.+    --+    -- We still need to desugar *something* because the driver and the linkers+    -- expect a valid object file (.o) to be generated for this module.+    | ms_mod summary == gHC_PRIM -> Just <$> hscDesugar' (ms_location summary) (tc_result { tcg_binds = [] })+    | otherwise                  -> Just <$> hscDesugar' (ms_location summary) tc_result++  -- Report the warnings from both typechecking and desugar together+  w <- getDiagnostics+  liftIO $ printOrThrowDiagnostics logger print_config diag_opts (unionMessages tc_warnings w)+  clearDiagnostics++  -- Simplify, if appropriate, and (whether we simplified or not) generate an+  -- interface file.+  case mb_desugar of+      -- Just cause we desugared doesn't mean we are generating code, see above.+      Just desugared_guts | backendGeneratesCode bcknd -> do+          plugins <- liftIO $ readIORef (tcg_th_coreplugins tc_result)+          simplified_guts <- hscSimplify' plugins desugared_guts++          (cg_guts, details) <-+              liftIO $ hscTidy hsc_env simplified_guts++          !partial_iface <- liftIO $+                {-# SCC "GHC.Driver.Main.mkPartialIface" #-}+                -- This `force` saves 2M residency in test T10370+                -- See Note [Avoiding space leaks in toIface*] for details.+                fmap force (mkPartialIface hsc_env (cg_binds cg_guts) details summary (tcg_import_decls tc_result) simplified_guts)++          return HscRecomp { hscs_guts = cg_guts,+                             hscs_mod_location = ms_location summary,+                             hscs_partial_iface = partial_iface,+                             hscs_old_iface_hash = mb_old_hash+                           }++      Just desugared_guts | gopt Opt_WriteIfSimplifiedCore dflags -> do+          -- If -fno-code is enabled (hence we fall through to this case)+          -- Running the simplifier once is necessary before doing byte code generation+          -- in order to inline data con wrappers but we honour whatever level of simplificication the+          -- user requested. See #22008 for some discussion.+          plugins <- liftIO $ readIORef (tcg_th_coreplugins tc_result)+          simplified_guts <- hscSimplify' plugins desugared_guts+          (cg_guts, _) <-+              liftIO $ hscTidy hsc_env simplified_guts++          (iface, _details) <- liftIO $+            hscSimpleIface hsc_env (Just $ cg_binds cg_guts) tc_result summary++          liftIO $ hscMaybeWriteIface logger dflags True iface mb_old_hash (ms_location summary)++          -- when compiling gHC_PRIM without generating code (e.g. with+          -- Haddock), we still want the virtual interface in the cache+          if ms_mod summary == gHC_PRIM+            then return $ HscUpdate (getGhcPrimIface (hsc_hooks hsc_env))+            else return $ HscUpdate iface+++      -- We are not generating code or writing an interface with simplified core so we can skip simplification+      -- and generate a simple interface.+      _ -> do+        (iface, _details) <- liftIO $+          hscSimpleIface hsc_env Nothing tc_result summary++        liftIO $ hscMaybeWriteIface logger dflags True iface mb_old_hash (ms_location summary)++        -- when compiling gHC_PRIM without generating code (e.g. with+        -- Haddock), we still want the virtual interface in the cache+        if ms_mod summary == gHC_PRIM+          then return $ HscUpdate (getGhcPrimIface (hsc_hooks hsc_env))+          else return $ HscUpdate iface++{-+Note [Writing interface files]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We write one interface file per module and per compilation, except with+-dynamic-too where we write two interface files (non-dynamic and dynamic).++We can write two kinds of interfaces (see Note [Interface file stages] in+"GHC.Driver.Types"):++   * simple interface: interface generated after the core pipeline++   * full interface: simple interface completed with information from the+     backend++Depending on the situation, we write one or the other (using+`hscMaybeWriteIface`). We must be careful with `-dynamic-too` because only the+backend is run twice, so if we write a simple interface we need to write both+the non-dynamic and the dynamic interfaces at the same time (with the same+contents).++Cases for which we generate simple interfaces:++   * GHC.Driver.Main.hscDesugarAndSimplify: when a compilation does NOT require (re)compilation+   of the hard code++   * GHC.Driver.Pipeline.compileOne': when we run in One Shot mode and target+   bytecode (if interface writing is forced).++   * GHC.Driver.Backpack uses simple interfaces for indefinite units+   (units with module holes). It writes them indirectly by forcing the+   -fwrite-interface flag while setting backend to NoBackend.++Cases for which we generate full interfaces:++   * GHC.Driver.Pipeline.runPhase: when we must be compiling to regular hard+   code and/or require recompilation.++By default interface file names are derived from module file names by adding+suffixes. The interface file name can be overloaded with "-ohi", except when+`-dynamic-too` is used.++-}++-- | Write interface files+hscMaybeWriteIface+  :: Logger+  -> DynFlags+  -> Bool+  -- ^ Is this a simple interface generated after the core pipeline, or one+  -- with information from the backend? See: Note [Writing interface files]+  -> ModIface+  -> Maybe Fingerprint+  -- ^ The old interface hash, used to decide if we need to actually write the+  -- new interface.+  -> ModLocation+  -> IO ()+hscMaybeWriteIface logger dflags is_simple iface old_iface mod_location = do+    let force_write_interface = gopt Opt_WriteInterface dflags+        write_interface = backendWritesFiles (backend dflags)++        write_iface dflags' iface =+          let !iface_name = if dynamicNow dflags' then ml_dyn_hi_file mod_location else ml_hi_file mod_location+              profile     = targetProfile dflags'+          in+          {-# SCC "writeIface" #-}+          withTiming logger+              (text "WriteIface"<+>brackets (text iface_name))+              (const ())+              (writeIface logger profile (flagsToIfCompression dflags) iface_name iface)++    if (write_interface || force_write_interface) then do++      -- FIXME: with -dynamic-too, "change" is only meaningful for the+      -- non-dynamic interface, not for the dynamic one. We should have another+      -- flag for the dynamic interface. In the meantime:+      --+      --    * when we write a single full interface, we check if we are+      --    currently writing the dynamic interface due to -dynamic-too, in+      --    which case we ignore "change".+      --+      --    * when we write two simple interfaces at once because of+      --    dynamic-too, we use "change" both for the non-dynamic and the+      --    dynamic interfaces. Hopefully both the dynamic and the non-dynamic+      --    interfaces stay in sync...+      --+      let change = old_iface /= Just (mi_iface_hash iface)++      let dt = dynamicTooState dflags++      when (logHasDumpFlag logger Opt_D_dump_if_trace) $ putMsg logger $+        hang (text "Writing interface(s):") 2 $ vcat+         [ text "Kind:" <+> if is_simple then text "simple" else text "full"+         , text "Hash change:" <+> ppr change+         , text "DynamicToo state:" <+> text (show dt)+         ]++      if is_simple+         then when change $ do -- FIXME: see 'change' comment above+            write_iface dflags iface+            case dt of+               DT_Dont   -> return ()+               DT_Dyn    -> panic "Unexpected DT_Dyn state when writing simple interface"+               DT_OK     -> write_iface (setDynamicNow dflags) iface+         else case dt of+               DT_Dont | change                    -> write_iface dflags iface+               DT_OK   | change                    -> write_iface dflags iface+               -- FIXME: see change' comment above+               DT_Dyn                              -> write_iface dflags iface+               _                                   -> return ()++      when (gopt Opt_WriteHie dflags) $ do+          -- This is slightly hacky. A hie file is considered to be up to date+          -- if its modification time on disk is greater than or equal to that+          -- of the .hi file (since we should always write a .hi file if we are+          -- writing a .hie file). However, with the way this code is+          -- structured at the moment, the .hie file is often written before+          -- the .hi file; by touching the file here, we ensure that it is+          -- correctly considered up-to-date.+          --+          -- The file should exist by the time we get here, but we check for+          -- existence just in case, so that we don't accidentally create empty+          -- .hie files.+          let hie_file = ml_hie_file mod_location+          whenM (doesFileExist hie_file) $+            GHC.Utils.Touch.touch hie_file+    else+        -- See Note [Strictness in ModIface]+        forceModIface iface++--------------------------------------------------------------+-- NoRecomp handlers+--------------------------------------------------------------+++-- | genModDetails is used to initialise 'ModDetails' at the end of compilation.+-- This has two main effects:+-- 1. Increases memory usage by unloading a lot of the TypeEnv+-- 2. Globalising certain parts (DFunIds) in the TypeEnv (which used to be achieved using UpdateIdInfos)+-- For the second part to work, it's critical that we use 'initIfaceLoadModule' here rather than+-- 'initIfaceCheck' as 'initIfaceLoadModule' removes the module from the KnotVars, otherwise name lookups+-- succeed by hitting the old TypeEnv, which missing out the critical globalisation step for DFuns.++-- After the DFunIds are globalised, it's critical to overwrite the old TypeEnv with the new+-- more compact and more correct version. This reduces memory usage whilst compiling the rest of+-- the module loop.+genModDetails :: HscEnv -> ModIface -> IO ModDetails+genModDetails hsc_env old_iface+  = do+    -- CRITICAL: To use initIfaceLoadModule as that removes the current module from the KnotVars and+    -- hence properly globalises DFunIds.+    new_details <- {-# SCC "tcRnIface" #-}+                  initIfaceLoadModule hsc_env (mi_module old_iface) (typecheckIface old_iface)+    case lookupKnotVars (hsc_type_env_vars hsc_env) (mi_module old_iface) of+      Nothing -> return ()+      Just te_var -> writeIORef te_var (md_types new_details)+    dumpIfaceStats hsc_env+    return new_details+++--------------------------------------------------------------+-- Safe Haskell+--------------------------------------------------------------++-- Note [Safe Haskell Trust Check]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- Safe Haskell checks that an import is trusted according to the following+-- rules for an import of module M that resides in Package P:+--+--   * If M is recorded as Safe and all its trust dependencies are OK+--     then M is considered safe.+--   * If M is recorded as Trustworthy and P is considered trusted and+--     all M's trust dependencies are OK then M is considered safe.+--+-- By trust dependencies we mean that the check is transitive. So if+-- a module M that is Safe relies on a module N that is trustworthy,+-- importing module M will first check (according to the second case)+-- that N is trusted before checking M is trusted.+--+-- This is a minimal description, so please refer to the user guide+-- for more details. The user guide is also considered the authoritative+-- source in this matter, not the comments or code.+++-- Note [Safe Haskell Inference]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- Safe Haskell does Safe inference on modules that don't have any specific+-- safe haskell mode flag. The basic approach to this is:+--   * When deciding if we need to do a Safe language check, treat+--     an unmarked module as having -XSafe mode specified.+--   * For checks, don't throw errors but return them to the caller.+--   * Caller checks if there are errors:+--     * For modules explicitly marked -XSafe, we throw the errors.+--     * For unmarked modules (inference mode), we drop the errors+--       and mark the module as being Unsafe.+--+-- It used to be that we only did safe inference on modules that had no Safe+-- Haskell flags, but now we perform safe inference on all modules as we want+-- to allow users to set the `-Wsafe`, `-Wunsafe` and+-- `-Wtrustworthy-safe` flags on Trustworthy and Unsafe modules so that a+-- user can ensure their assumptions are correct and see reasons for why a+-- module is safe or unsafe.+--+-- This is tricky as we must be careful when we should throw an error compared+-- to just warnings. For checking safe imports we manage it as two steps. First+-- we check any imports that are required to be safe, then we check all other+-- imports to see if we can infer them to be safe.+++-- | Check that the safe imports of the module being compiled are valid.+-- If not we either issue a compilation error if the module is explicitly+-- using Safe Haskell, or mark the module as unsafe if we're in safe+-- inference mode.+hscCheckSafeImports :: TcGblEnv -> Hsc TcGblEnv+hscCheckSafeImports tcg_env = do+    dflags   <- getDynFlags+    tcg_env' <- checkSafeImports tcg_env+    checkRULES dflags tcg_env'++  where+    checkRULES dflags tcg_env' =+      let diag_opts = initDiagOpts dflags+      in case safeLanguageOn dflags of+          True -> do+              -- XSafe: we nuke user written RULES+              logDiagnostics $ fmap GhcDriverMessage $ warns diag_opts (tcg_rules tcg_env')+              return tcg_env' { tcg_rules = [] }+          False+                -- SafeInferred: user defined RULES, so not safe+              | safeInferOn dflags && not (null $ tcg_rules tcg_env')+              -> markUnsafeInfer tcg_env' $ warns diag_opts (tcg_rules tcg_env')++                -- Trustworthy OR SafeInferred: with no RULES+              | otherwise+              -> return tcg_env'++    warns diag_opts rules = mkMessages $ listToBag $ map (warnRules diag_opts) rules++    warnRules :: DiagOpts -> LRuleDecl GhcTc -> MsgEnvelope DriverMessage+    warnRules diag_opts (L loc rule) =+        mkPlainMsgEnvelope diag_opts (locA loc) $ DriverUserDefinedRuleIgnored rule++-- | Validate that safe imported modules are actually safe.  For modules in the+-- HomePackage (the package the module we are compiling in resides) this just+-- involves checking its trust type is 'Safe' or 'Trustworthy'. For modules+-- that reside in another package we also must check that the external package+-- is trusted. See the Note [Safe Haskell Trust Check] above for more+-- information.+--+-- The code for this is quite tricky as the whole algorithm is done in a few+-- distinct phases in different parts of the code base. See+-- 'GHC.Rename.Names.rnImportDecl' for where package trust dependencies for a+-- module are collected and unioned.  Specifically see the Note [Tracking Trust+-- Transitively] in "GHC.Rename.Names" and the Note [Trust Own Package] in+-- "GHC.Rename.Names".+checkSafeImports :: TcGblEnv -> Hsc TcGblEnv+checkSafeImports tcg_env+    = do+        dflags <- getDynFlags+        imps <- mapM condense imports'+        let (safeImps, regImps) = partition (\(_,_,s) -> s) imps++        -- We want to use the warning state specifically for detecting if safe+        -- inference has failed, so store and clear any existing warnings.+        oldErrs <- getDiagnostics+        clearDiagnostics++        -- Check safe imports are correct+        safePkgs <- S.fromList <$> mapMaybeM checkSafe safeImps+        safeErrs <- getDiagnostics+        clearDiagnostics++        -- Check non-safe imports are correct if inferring safety+        -- See the Note [Safe Haskell Inference]+        (infErrs, infPkgs) <- case (safeInferOn dflags) of+          False -> return (emptyMessages, S.empty)+          True -> do infPkgs <- S.fromList <$> mapMaybeM checkSafe regImps+                     infErrs <- getDiagnostics+                     clearDiagnostics+                     return (infErrs, infPkgs)++        -- restore old errors+        logDiagnostics oldErrs++        diag_opts <- initDiagOpts <$> getDynFlags+        print_config <- initPrintConfig <$> getDynFlags+        logger <- getLogger++        -- Will throw if failed safe check+        liftIO $ printOrThrowDiagnostics logger print_config diag_opts safeErrs++        -- No fatal warnings or errors: passed safe check+        let infPassed = isEmptyMessages infErrs+        tcg_env' <- case (not infPassed) of+          True  -> markUnsafeInfer tcg_env infErrs+          False -> return tcg_env+        when (packageTrustOn dflags) $ checkPkgTrust pkgReqs+        let newTrust = pkgTrustReqs dflags safePkgs infPkgs infPassed+        return tcg_env' { tcg_imports = impInfo `plusImportAvails` newTrust }++  where+    impInfo  = tcg_imports tcg_env     -- ImportAvails+    imports  = imp_mods impInfo        -- ImportedMods+    imports1 = M.toList imports -- (Module, [ImportedBy])+    imports' = map (fmap importedByUser) imports1 -- (Module, [ImportedModsVal])+    pkgReqs  = imp_trust_pkgs impInfo  -- [Unit]++    condense :: (Module, [ImportedModsVal]) -> Hsc (Module, SrcSpan, IsSafeImport)+    condense (_, [])   = panic "GHC.Driver.Main.condense: Pattern match failure!"+    condense (m, x:xs) = do imv <- foldlM cond' x xs+                            return (m, imv_span imv, imv_is_safe imv)++    -- ImportedModsVal = (ModuleName, Bool, SrcSpan, IsSafeImport)+    cond' :: ImportedModsVal -> ImportedModsVal -> Hsc ImportedModsVal+    cond' v1 v2+        | imv_is_safe v1 /= imv_is_safe v2+        = throwOneError $+            mkPlainErrorMsgEnvelope (imv_span v1) $+            GhcDriverMessage $ DriverMixedSafetyImport (imv_name v1)+        | otherwise+        = return v1++    -- easier interface to work with+    checkSafe :: (Module, SrcSpan, a) -> Hsc (Maybe UnitId)+    checkSafe (m, l, _) = fst `fmap` hscCheckSafe' m l++    -- what pkg's to add to our trust requirements+    pkgTrustReqs :: DynFlags -> Set UnitId -> Set UnitId ->+          Bool -> ImportAvails+    pkgTrustReqs dflags req inf infPassed | safeInferOn dflags+                                  && not (safeHaskellModeEnabled dflags) && infPassed+                                   = emptyImportAvails {+                                       imp_trust_pkgs = req `S.union` inf+                                   }+    pkgTrustReqs dflags _   _ _ | safeHaskell dflags == Sf_Unsafe+                         = emptyImportAvails+    pkgTrustReqs _ req _ _ = emptyImportAvails { imp_trust_pkgs = req }++-- | Check that a module is safe to import.+--+-- We return True to indicate the import is safe and False otherwise+-- although in the False case an exception may be thrown first.+hscCheckSafe :: HscEnv -> Module -> SrcSpan -> IO Bool+hscCheckSafe hsc_env m l = runHsc hsc_env $ do+    dflags <- getDynFlags+    pkgs <- snd `fmap` hscCheckSafe' m l+    when (packageTrustOn dflags) $ checkPkgTrust pkgs+    errs <- getDiagnostics+    return $ isEmptyMessages errs++-- | Return if a module is trusted and the pkgs it depends on to be trusted.+hscGetSafe :: HscEnv -> Module -> SrcSpan -> IO (Bool, Set UnitId)+hscGetSafe hsc_env m l = runHsc hsc_env $ do+    (self, pkgs) <- hscCheckSafe' m l+    good         <- isEmptyMessages `fmap` getDiagnostics+    clearDiagnostics -- don't want them printed...+    let pkgs' | Just p <- self = S.insert p pkgs+              | otherwise      = pkgs+    return (good, pkgs')++-- | Is a module trusted? If not, throw or log errors depending on the type.+-- Return (regardless of trusted or not) if the trust type requires the modules+-- own package be trusted and a list of other packages required to be trusted+-- (these later ones haven't been checked) but the own package trust has been.+hscCheckSafe' :: Module -> SrcSpan+  -> Hsc (Maybe UnitId, Set UnitId)+hscCheckSafe' m l = do+    hsc_env <- getHscEnv+    let home_unit = hsc_home_unit hsc_env+    (tw, pkgs) <- isModSafe home_unit m l+    case tw of+        False                           -> return (Nothing, pkgs)+        True | isHomeModule home_unit m -> return (Nothing, pkgs)+             -- TODO: do we also have to check the trust of the instantiation?+             -- Not necessary if that is reflected in dependencies+             | otherwise   -> return (Just $ toUnitId (moduleUnit m), pkgs)+  where+    isModSafe :: HomeUnit -> Module -> SrcSpan -> Hsc (Bool, Set UnitId)+    isModSafe home_unit m l = do+        hsc_env <- getHscEnv+        dflags <- getDynFlags+        iface <- lookup' m+        let diag_opts = initDiagOpts dflags+        case iface of+            -- can't load iface to check trust!+            Nothing -> throwOneError $+                         mkPlainErrorMsgEnvelope l $+                         GhcDriverMessage $ DriverCannotLoadInterfaceFile m++            -- got iface, check trust+            Just iface' ->+                let trust = getSafeMode $ mi_trust iface'+                    trust_own_pkg = mi_trust_pkg iface'+                    -- check module is trusted+                    safeM = trust `elem` [Sf_Safe, Sf_SafeInferred, Sf_Trustworthy]+                    -- check package is trusted+                    safeP = packageTrusted dflags (hsc_units hsc_env) home_unit trust trust_own_pkg m+                    -- pkg trust reqs+                    pkgRs = dep_trusted_pkgs $ mi_deps iface'+                    -- warn if Safe module imports Safe-Inferred module.+                    warns = if wopt Opt_WarnInferredSafeImports dflags+                                && safeLanguageOn dflags+                                && trust == Sf_SafeInferred+                                then inferredImportWarn diag_opts+                                else emptyMessages+                    -- General errors we throw but Safe errors we log+                    errs = case (safeM, safeP) of+                        (True, True ) -> emptyMessages+                        (True, False) -> pkgTrustErr+                        (False, _   ) -> modTrustErr+                in do+                    logDiagnostics warns+                    logDiagnostics errs+                    return (trust == Sf_Trustworthy, pkgRs)++                where+                    state = hsc_units hsc_env+                    inferredImportWarn diag_opts = singleMessage+                        $ mkMsgEnvelope diag_opts l (pkgQual state)+                        $ GhcDriverMessage $ DriverInferredSafeImport m+                    pkgTrustErr = singleMessage+                      $ mkErrorMsgEnvelope l (pkgQual state)+                      $ GhcDriverMessage $ DriverCannotImportFromUntrustedPackage state m+                    modTrustErr = singleMessage+                      $ mkErrorMsgEnvelope l (pkgQual state)+                      $ GhcDriverMessage $ DriverCannotImportUnsafeModule m++    -- Check the package a module resides in is trusted. Safe compiled+    -- modules are trusted without requiring that their package is trusted. For+    -- trustworthy modules, modules in the home package are trusted but+    -- otherwise we check the package trust flag.+    packageTrusted :: DynFlags -> UnitState -> HomeUnit -> SafeHaskellMode -> Bool -> Module -> Bool+    packageTrusted dflags unit_state home_unit safe_mode trust_own_pkg mod =+        case safe_mode of+            Sf_None      -> False -- shouldn't hit these cases+            Sf_Ignore    -> False -- shouldn't hit these cases+            Sf_Unsafe    -> False -- prefer for completeness.+            _ | not (packageTrustOn dflags)     -> True+            Sf_Safe | not trust_own_pkg         -> True+            Sf_SafeInferred | not trust_own_pkg -> True+            _ | isHomeModule home_unit mod      -> True+            _ -> unitIsTrusted $ unsafeLookupUnit unit_state (moduleUnit m)++    lookup' :: Module -> Hsc (Maybe ModIface)+    lookup' m = do+        hsc_env <- getHscEnv+        iface <- liftIO $ lookupIfaceByModuleHsc hsc_env m+        -- the 'lookupIfaceByModule' method will always fail when calling from GHCi+        -- as the compiler hasn't filled in the various module tables+        -- so we need to call 'getModuleInterface' to load from disk+        case iface of+            Just _  -> return iface+            Nothing -> snd `fmap` (liftIO $ getModuleInterface hsc_env m)+++-- | Check the list of packages are trusted.+checkPkgTrust :: Set UnitId -> Hsc ()+checkPkgTrust pkgs = do+    hsc_env <- getHscEnv+    let errors = S.foldr go emptyBag pkgs+        state  = hsc_units hsc_env+        go pkg acc+            | unitIsTrusted $ unsafeLookupUnitId state pkg+            = acc+            | otherwise+            = (`consBag` acc)+                     $ mkErrorMsgEnvelope noSrcSpan (pkgQual state)+                     $ GhcDriverMessage+                     $ DriverPackageNotTrusted state pkg+    if isEmptyBag errors+      then return ()+      else liftIO $ throwErrors $ mkMessages errors++-- | Set module to unsafe and (potentially) wipe trust information.+--+-- Make sure to call this method to set a module to inferred unsafe, it should+-- be a central and single failure method. We only wipe the trust information+-- when we aren't in a specific Safe Haskell mode.+--+-- While we only use this for recording that a module was inferred unsafe, we+-- may call it on modules using Trustworthy or Unsafe flags so as to allow+-- warning flags for safety to function correctly. See Note [Safe Haskell+-- Inference].+markUnsafeInfer :: forall e . Diagnostic e => TcGblEnv -> Messages e -> Hsc TcGblEnv+markUnsafeInfer tcg_env whyUnsafe = do+    dflags <- getDynFlags++    let reason = WarningWithFlag Opt_WarnUnsafe+    let diag_opts = initDiagOpts dflags+    when (diag_wopt Opt_WarnUnsafe diag_opts)+         (logDiagnostics $ singleMessage $+             mkPlainMsgEnvelope diag_opts (warnUnsafeOnLoc dflags) $+             GhcDriverMessage $ DriverUnknownMessage $+             mkSimpleUnknownDiagnostic $+             mkPlainDiagnostic reason noHints $+             whyUnsafe' dflags)++    liftIO $ writeIORef (tcg_safe_infer tcg_env) False+    liftIO $ writeIORef (tcg_safe_infer_reasons tcg_env) emptyMessages+    -- NOTE: Only wipe trust when not in an explicitly safe haskell mode. Other+    -- times inference may be on but we are in Trustworthy mode -- so we want+    -- to record safe-inference failed but not wipe the trust dependencies.+    case not (safeHaskellModeEnabled dflags) of+      True  -> return $ tcg_env { tcg_imports = wiped_trust }+      False -> return tcg_env++  where+    wiped_trust   = (tcg_imports tcg_env) { imp_trust_pkgs = S.empty }+    pprMod        = ppr $ moduleName $ tcg_mod tcg_env+    whyUnsafe' df = vcat [ quotes pprMod <+> text "has been inferred as unsafe!"+                         , text "Reason:"+                         , nest 4 $ (vcat $ badFlags df) $+$+                                    -- MP: Using defaultDiagnosticOpts here is not right but it's also not right to handle these+                                    -- unsafety error messages in an unstructured manner.+                                    (vcat $ pprMsgEnvelopeBagWithLoc (defaultDiagnosticOpts @e) (getMessages whyUnsafe)) $+$+                                    (vcat $ badInsts $ tcg_insts tcg_env)+                         ]+    badFlags df   = concatMap (badFlag df) unsafeFlagsForInfer+    badFlag df (ext,loc,on,_)+        | on df     = [mkLocMessage MCOutput (loc df) $+                            text "-X" <> ppr ext <+> text "is not allowed in Safe Haskell"]+        | otherwise = []+    badInsts insts = concatMap badInst insts++    checkOverlap (NoOverlap _) = False+    checkOverlap _             = True++    badInst ins | checkOverlap (overlapMode (is_flag ins))+                = [mkLocMessage MCOutput (nameSrcSpan $ getName $ is_dfun ins) $+                      ppr (overlapMode $ is_flag ins) <+>+                      text "overlap mode isn't allowed in Safe Haskell"]+                | otherwise = []++-- | Figure out the final correct safe haskell mode+hscGetSafeMode :: TcGblEnv -> Hsc SafeHaskellMode+hscGetSafeMode tcg_env = do+    dflags  <- getDynFlags+    liftIO $ finalSafeMode dflags tcg_env++--------------------------------------------------------------+-- Simplifiers+--------------------------------------------------------------++-- | Run Core2Core simplifier. The list of String is a list of (Core) plugin+-- module names added via TH (cf 'addCorePlugin').+hscSimplify :: HscEnv -> [String] -> ModGuts -> IO ModGuts+hscSimplify hsc_env plugins modguts =+    runHsc hsc_env $ hscSimplify' plugins modguts++-- | Run Core2Core simplifier. The list of String is a list of (Core) plugin+-- module names added via TH (cf 'addCorePlugin').+hscSimplify' :: [String] -> ModGuts -> Hsc ModGuts+hscSimplify' plugins ds_result = do+    hsc_env <- getHscEnv+    hsc_env_with_plugins <- if null plugins -- fast path+        then return hsc_env+        else liftIO $ initializePlugins+                    $ hscUpdateFlags (\dflags -> foldr addPluginModuleName dflags plugins)+                      hsc_env+    {-# SCC "Core2Core" #-}+      liftIO $ core2core hsc_env_with_plugins ds_result++--------------------------------------------------------------+-- Interface generators+--------------------------------------------------------------++-- | Generate a stripped down interface file, e.g. for boot files or when ghci+-- generates interface files. See Note [simpleTidyPgm - mkBootModDetailsTc]+hscSimpleIface :: HscEnv+               -> Maybe CoreProgram+               -> TcGblEnv+               -> ModSummary+               -> IO (ModIface, ModDetails)+hscSimpleIface hsc_env mb_core_program tc_result summary+    = runHsc hsc_env $ hscSimpleIface' mb_core_program tc_result summary++hscSimpleIface' :: Maybe CoreProgram+                -> TcGblEnv+                -> ModSummary+                -> Hsc (ModIface, ModDetails)+hscSimpleIface' mb_core_program tc_result summary = do+    hsc_env   <- getHscEnv+    logger    <- getLogger+    details   <- liftIO $ mkBootModDetailsTc logger tc_result+    safe_mode <- hscGetSafeMode tc_result+    new_iface+        <- {-# SCC "MkFinalIface" #-}+           liftIO $+               mkIfaceTc hsc_env safe_mode details summary mb_core_program tc_result+    -- And the answer is ...+    liftIO $ dumpIfaceStats hsc_env+    return (new_iface, details)++--------------------------------------------------------------+-- BackEnd combinators+--------------------------------------------------------------++-- | Compile to hard-code.+hscGenHardCode :: HscEnv -> CgGuts -> ModLocation -> FilePath+               -> IO (FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)], Maybe StgCgInfos, Maybe CmmCgInfos )+                -- ^ @Just f@ <=> _stub.c is f+hscGenHardCode hsc_env cgguts mod_loc output_filename = do+        let CgGuts{ cg_module   = this_mod,+                    cg_binds    = core_binds,+                    cg_ccs      = local_ccs+                    } = cgguts+            dflags = hsc_dflags hsc_env+            logger = hsc_logger hsc_env++        -------------------+        -- ADD IMPLICIT BINDINGS+        -- NB: we must feed mkImplicitBinds through corePrep too+        -- so that they are suitably cloned and eta-expanded+        let cp_pgm_cfg :: CorePrepPgmConfig+            cp_pgm_cfg = initCorePrepPgmConfig (hsc_dflags hsc_env)+                                               (interactiveInScope $ hsc_IC hsc_env)+        binds_with_implicits <- addImplicitBinds cp_pgm_cfg mod_loc (cg_tycons cgguts) core_binds++        -------------------+        -- INSERT LATE COST CENTRES, based on the provided flags.+        --+        -- If -fprof-late-inline is enabled, we will skip adding CCs on any+        -- top-level bindings here (via shortcut in `addLateCostCenters`), since+        -- it will have already added a superset of the CCs we would add here.+        let+          late_cc_config :: LateCCConfig+          late_cc_config =+            LateCCConfig+              { lateCCConfig_whichBinds =+                  if gopt Opt_ProfLateInlineCcs dflags then+                    LateCCNone+                  else if gopt Opt_ProfLateCcs dflags then+                    LateCCBinds+                  else if gopt Opt_ProfLateOverloadedCcs dflags then+                    LateCCOverloadedBinds+                  else+                    LateCCNone+              , lateCCConfig_overloadedCalls =+                  gopt Opt_ProfLateoverloadedCallsCCs dflags+              , lateCCConfig_env =+                  LateCCEnv+                    { lateCCEnv_module = this_mod+                    , lateCCEnv_file = fsLit <$> ml_hs_file mod_loc+                    , lateCCEnv_countEntries= gopt Opt_ProfCountEntries dflags+                    , lateCCEnv_collectCCs = True+                    }+              }++        (late_cc_binds, late_cc_state) <-+          addLateCostCenters logger late_cc_config binds_with_implicits++        when (dopt Opt_D_dump_late_cc dflags || dopt Opt_D_verbose_core2core dflags) $+          putDumpFileMaybe logger Opt_D_dump_late_cc "LateCC" FormatCore (vcat (map ppr late_cc_binds))++        -------------------+        -- RUN LATE PLUGINS+        -- This is the last use of the CgGuts in a compilation.+        -- From now on, we just use the bits we need.+        ( CgGuts+            { cg_tycons        = tycons,+              cg_foreign       = foreign_stubs0,+              cg_foreign_files = foreign_files,+              cg_dep_pkgs      = dependencies,+              cg_spt_entries   = spt_entries,+              cg_binds         = binds_to_prep,+              cg_ccs           = late_local_ccs+            }+          , _+          ) <-+          {-# SCC latePlugins #-}+          withTiming+            logger+            (text "LatePlugins"<+>brackets (ppr this_mod))+            (const ()) $+            withPlugins (hsc_plugins hsc_env)+              (($ hsc_env) . latePlugin)+                ( cgguts+                    { cg_binds = late_cc_binds+                    , cg_ccs = S.toList (lateCCState_ccs late_cc_state) ++ local_ccs+                    }+                , lateCCState_ccState late_cc_state+                )++        let+          hooks  = hsc_hooks hsc_env+          tmpfs  = hsc_tmpfs hsc_env+          llvm_config = hsc_llvm_config hsc_env+          profile = targetProfile dflags++        -------------------+        -- PREPARE FOR CODE GENERATION+        -- Do saturation and convert to A-normal form+        cp_cfg <- initCorePrepConfig hsc_env+        (prepd_binds) <- {-# SCC "CorePrep" #-}+                         corePrepPgm+                           (hsc_logger hsc_env) cp_cfg cp_pgm_cfg+                           this_mod binds_to_prep++        -----------------  Convert to STG ------------------+        (stg_binds_with_deps, denv, (caf_ccs, caf_cc_stacks), stg_cg_infos)+            <- {-# SCC "CoreToStg" #-}+               withTiming logger+                   (text "CoreToStg"<+>brackets (ppr this_mod))+                   (\(a, b, (c,d), tag_env) ->+                        a `seqList`+                        b `seq`+                        c `seqList`+                        d `seqList`+                        (seqEltsUFM (seqTagSig) tag_env))+                   (myCoreToStg logger dflags (interactiveInScope (hsc_IC hsc_env)) False this_mod mod_loc prepd_binds)++        let (stg_binds,_stg_deps) = unzip stg_binds_with_deps++        let cost_centre_info =+              (late_local_ccs ++ caf_ccs, caf_cc_stacks)+            platform = targetPlatform dflags+            prof_init+              | sccProfilingEnabled dflags = profilingInitCode platform this_mod cost_centre_info+              | otherwise = mempty++        ------------------  Code generation ------------------+        -- The back-end is streamed: each top-level function goes+        -- from Stg all the way to asm before dealing with the next+        -- top-level function, so withTiming isn't very useful here.+        -- Hence we have one withTiming for the whole backend, the+        -- next withTiming after this will be "Assembler" (hard code only).+        withTiming logger (text "CodeGen"<+>brackets (ppr this_mod)) (const ())+         $ case backendCodeOutput (backend dflags) of+            JSCodeOutput ->+              do+              let js_config = initStgToJSConfig dflags++                  -- The JavaScript backend does not create CmmCgInfos like the Cmm backend,+                  -- but it is needed for writing the interface file. Here we compute a very+                  -- conservative but correct value.+                  lf_infos (StgTopLifted (StgNonRec b _)) = [(idName b, LFUnknown True)]+                  lf_infos (StgTopLifted (StgRec bs))     = map (\(b,_) -> (idName b, LFUnknown True)) bs+                  lf_infos (StgTopStringLit b _)          = [(idName b, LFUnlifted)]++                  cmm_cg_infos  = CmmCgInfos+                    { cgNonCafs = mempty+                    , cgLFInfos = mkNameEnv (concatMap lf_infos stg_binds)+                    , cgIPEStub = mempty+                    }+                  stub_c_exists = Nothing+                  foreign_fps   = []++              putDumpFileMaybe logger Opt_D_dump_stg_final "Final STG:" FormatSTG+                  (pprGenStgTopBindings (initStgPprOpts dflags) stg_binds)++              -- do the unfortunately effectual business+              stgToJS logger js_config stg_binds this_mod spt_entries foreign_stubs0 cost_centre_info output_filename+              return (output_filename, stub_c_exists, foreign_fps, Just stg_cg_infos, Just cmm_cg_infos)++            _          ->+              do+              cmms <- {-# SCC "StgToCmm" #-}+                doCodeGen hsc_env this_mod denv tycons+                cost_centre_info+                stg_binds++              ------------------  Code output -----------------------+              rawcmms0 <- {-# SCC "cmmToRawCmm" #-}+                case cmmToRawCmmHook hooks of+                  Nothing -> cmmToRawCmm logger profile cmms+                  Just h  -> h dflags (Just this_mod) cmms++              let dump a = do+                    unless (null a) $ putDumpFileMaybe logger Opt_D_dump_cmm_raw "Raw Cmm" FormatCMM (pdoc platform a)+                    return a+                  rawcmms1 = Stream.mapM (liftIO . dump) rawcmms0++              let foreign_stubs st = foreign_stubs0+                                     `appendStubC` prof_init+                                     `appendStubC` cgIPEStub st++              (output_filename, (_stub_h_exists, stub_c_exists), foreign_fps, cmm_cg_infos)+                  <- {-# SCC "codeOutput" #-}+                    codeOutput logger tmpfs llvm_config dflags (hsc_units hsc_env) this_mod output_filename mod_loc+                    foreign_stubs foreign_files dependencies (initDUniqSupply 'n' 0) rawcmms1+              return  ( output_filename, stub_c_exists, foreign_fps+                      , Just stg_cg_infos, Just cmm_cg_infos)+++-- The part of CgGuts that we need for HscInteractive+data CgInteractiveGuts = CgInteractiveGuts { cgi_module :: Module+                                           , cgi_binds  :: CoreProgram+                                           , cgi_tycons :: [TyCon]+                                           , cgi_foreign :: ForeignStubs+                                           , cgi_foreign_files :: [(ForeignSrcLang, FilePath)]+                                           , cgi_modBreaks ::  Maybe ModBreaks+                                           , cgi_spt_entries :: [SptEntry]+                                           }++mkCgInteractiveGuts :: CgGuts -> CgInteractiveGuts+mkCgInteractiveGuts CgGuts{cg_module, cg_binds, cg_tycons, cg_foreign, cg_foreign_files, cg_modBreaks, cg_spt_entries}+  = CgInteractiveGuts cg_module cg_binds cg_tycons cg_foreign cg_foreign_files cg_modBreaks cg_spt_entries++hscInteractive :: HscEnv+               -> CgInteractiveGuts+               -> ModLocation+               -> IO (Maybe FilePath, CompiledByteCode) -- ^ .c stub path (if any) and ByteCode+hscInteractive hsc_env cgguts mod_loc = do+    let dflags = hsc_dflags hsc_env+    let logger = hsc_logger hsc_env+    let tmpfs  = hsc_tmpfs hsc_env+    let CgInteractiveGuts{ -- This is the last use of the ModGuts in a compilation.+                -- From now on, we just use the bits we need.+               cgi_module   = this_mod,+               cgi_binds    = core_binds,+               cgi_tycons   = tycons,+               cgi_foreign  = foreign_stubs,+               cgi_modBreaks = mod_breaks,+               cgi_spt_entries = spt_entries } = cgguts++    -------------------+    -- ADD IMPLICIT BINDINGS+    let cp_pgm_cfg :: CorePrepPgmConfig+        cp_pgm_cfg = initCorePrepPgmConfig (hsc_dflags hsc_env)+                                           (interactiveInScope $ hsc_IC hsc_env)+    binds_to_prep <- addImplicitBinds cp_pgm_cfg mod_loc tycons core_binds++    -------------------+    -- PREPARE FOR CODE GENERATION+    -- Do saturation and convert to A-normal form+    cp_cfg <- initCorePrepConfig hsc_env+    prepd_binds <- {-# SCC "CorePrep" #-}+                   corePrepPgm (hsc_logger hsc_env) cp_cfg cp_pgm_cfg+                               this_mod binds_to_prep++    -- The stg cg info only provides a runtime benfit, but is not requires so we just+    -- omit it here+    (stg_binds_with_deps, _infotable_prov, _caf_ccs__caf_cc_stacks, _ignore_stg_cg_infos)+      <- {-# SCC "CoreToStg" #-}+          myCoreToStg logger dflags (interactiveInScope (hsc_IC hsc_env)) True this_mod mod_loc prepd_binds++    let (stg_binds,_stg_deps) = unzip stg_binds_with_deps++    -----------------  Generate byte code ------------------+    comp_bc <- byteCodeGen hsc_env this_mod stg_binds tycons mod_breaks spt_entries++    ------------------ Create f-x-dynamic C-side stuff -----+    (_istub_h_exists, istub_c_exists)+        <- outputForeignStubs logger tmpfs dflags (hsc_units hsc_env) this_mod mod_loc foreign_stubs+    return (istub_c_exists, comp_bc)++-- | Compile Core bindings and foreign inputs that were loaded from an+-- interface, to produce bytecode and potential foreign objects for the purpose+-- of linking splices.+generateByteCode :: HscEnv+  -> CgInteractiveGuts+  -> ModLocation+  -> IO (CompiledByteCode, [FilePath])+generateByteCode hsc_env cgguts mod_location = do+  (hasStub, comp_bc) <- hscInteractive hsc_env cgguts mod_location+  compile_for_interpreter hsc_env $ \ i_env -> do+    stub_o <- traverse (compileForeign i_env LangC) hasStub+    foreign_files_o <- traverse (uncurry (compileForeign i_env)) (cgi_foreign_files cgguts)+    pure (comp_bc, maybeToList stub_o ++ foreign_files_o)++generateFreshByteCode :: HscEnv+  -> ModuleName+  -> CgInteractiveGuts+  -> ModLocation+  -> IO Linkable+generateFreshByteCode hsc_env mod_name cgguts mod_location = do+  bco_time <- getCurrentTime+  (bcos, fos) <- generateByteCode hsc_env cgguts mod_location+  return $!+    Linkable bco_time+    (mkHomeModule (hsc_home_unit hsc_env) mod_name)+    (BCOs bcos :| [DotO fo ForeignObject | fo <- fos])+------------------------------++hscCompileCmmFile :: HscEnv -> FilePath -> FilePath -> FilePath -> IO (Maybe FilePath)+hscCompileCmmFile hsc_env original_filename filename output_filename = runHsc hsc_env $ do+    let dflags   = hsc_dflags hsc_env+        logger   = hsc_logger hsc_env+        hooks    = hsc_hooks hsc_env+        tmpfs    = hsc_tmpfs hsc_env+        profile  = targetProfile dflags+        home_unit = hsc_home_unit hsc_env+        platform  = targetPlatform dflags+        llvm_config = hsc_llvm_config hsc_env+        cmm_config = initCmmConfig dflags+        do_info_table = gopt Opt_InfoTableMap dflags+        -- Make up a module name to give the NCG. We can't pass bottom here+        -- lest we reproduce #11784.+        mod_name = mkModuleName $ "Cmm$" ++ original_filename+        cmm_mod = mkHomeModule home_unit mod_name+        cmmpConfig = initCmmParserConfig dflags+    (dcmm, ipe_ents) <- ioMsgMaybe+               $ do+                  (warns,errs,cmm) <- withTiming logger (text "ParseCmm"<+>brackets (text filename)) (\_ -> ())+                                       $ parseCmmFile cmmpConfig cmm_mod home_unit filename+                  let msgs = warns `unionMessages` errs+                  return (GhcPsMessage <$> msgs, cmm)+    -- Probably need to rename cmm here+    let cmm = removeDeterm dcmm+    liftIO $ do+        putDumpFileMaybe logger Opt_D_dump_cmm_verbose_by_proc "Parsed Cmm" FormatCMM (pdoc platform cmm)++        -- Compile decls in Cmm files one decl at a time, to avoid re-ordering+        -- them in SRT analysis.+        --+        -- Re-ordering here causes breakage when booting with C backend because+        -- in C we must declare before use, but SRT algorithm is free to+        -- re-order [A, B] (B refers to A) when A is not CAFFY and return [B, A]+        ((_,dus1), cmmgroup) <- second concat <$>+          mapAccumLM (\(msrt0, dus0) cmm -> do+            ((msrt1, cmm'), dus1) <- cmmPipeline logger cmm_config msrt0 [cmm] dus0+            return ((msrt1, dus1), cmm')) (emptySRT cmm_mod, initDUniqSupply 'u' 0) cmm++        unless (null cmmgroup) $+          putDumpFileMaybe logger Opt_D_dump_cmm "Output Cmm"+            FormatCMM (pdoc platform cmmgroup)++        rawCmms0 <- case cmmToRawCmmHook hooks of+          Nothing -> cmmToRawCmm logger profile (Stream.yield cmmgroup)+          Just h  -> h           dflags Nothing (Stream.yield cmmgroup)++        let dump a = do+              unless (null a) $ putDumpFileMaybe logger Opt_D_dump_cmm_raw "Raw Cmm" FormatCMM (pdoc platform a)+              return a+            rawCmms = Stream.mapM (liftIO . dump) rawCmms0++        let foreign_stubs _+              | not $ null ipe_ents =+                  let ip_init = ipInitCode do_info_table platform cmm_mod+                  in NoStubs `appendStubC` ip_init+              | otherwise     = NoStubs+        (_output_filename, (_stub_h_exists, stub_c_exists), _foreign_fps, _caf_infos)+          <- codeOutput logger tmpfs llvm_config dflags (hsc_units hsc_env) cmm_mod output_filename no_loc foreign_stubs [] S.empty+             dus1 rawCmms+        return stub_c_exists+  where+    no_loc = OsPathModLocation+        { ml_hs_file_ospath  = Just $ unsafeEncodeUtf original_filename,+          ml_hi_file_ospath  = panic "hscCompileCmmFile: no hi file",+          ml_obj_file_ospath = panic "hscCompileCmmFile: no obj file",+          ml_dyn_obj_file_ospath = panic "hscCompileCmmFile: no dyn obj file",+          ml_dyn_hi_file_ospath  = panic "hscCompileCmmFile: no dyn obj file",+          ml_hie_file_ospath = panic "hscCompileCmmFile: no hie file"}++-------------------- Stuff for new code gen ---------------------++{-+Note [Forcing of stg_binds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+The two last steps in the STG pipeline are:++* Sorting the bindings in dependency order.+* Annotating them with free variables.++We want to make sure we do not keep references to unannotated STG bindings+alive, nor references to bindings which have already been compiled to Cmm.++We explicitly force the bindings to avoid this.++This reduces residency towards the end of the CodeGen phase significantly+(5-10%).+-}++doCodeGen :: HscEnv -> Module -> InfoTableProvMap -> [TyCon]+          -> CollectedCCs+          -> [CgStgTopBinding] -- ^ Bindings come already annotated with fvs+          -> IO (CgStream CmmGroupSRTs CmmCgInfos)+         -- Note we produce a 'Stream' of CmmGroups, so that the+         -- backend can be run incrementally.  Otherwise it generates all+         -- the C-- up front, which has a significant space cost.+doCodeGen hsc_env this_mod denv tycons+              cost_centre_info stg_binds_w_fvs = do+    let dflags     = hsc_dflags hsc_env+        logger     = hsc_logger hsc_env+        hooks      = hsc_hooks  hsc_env+        tmpfs      = hsc_tmpfs  hsc_env+        platform   = targetPlatform dflags+        stg_ppr_opts = (initStgPprOpts dflags)++    putDumpFileMaybe logger Opt_D_dump_stg_final "Final STG:" FormatSTG+        (pprGenStgTopBindings stg_ppr_opts stg_binds_w_fvs)++    let stg_to_cmm dflags mod a b c d = case stgToCmmHook hooks of+          Nothing -> StgToCmm.codeGen logger tmpfs (initStgToCmmConfig dflags mod) a b c d+          Just h  -> (,emptyDetUFM) <$> h          (initStgToCmmConfig dflags mod) a b c d++    let cmm_stream :: CgStream CmmGroup (ModuleLFInfos, DetUniqFM)+        -- See Note [Forcing of stg_binds]+        cmm_stream = stg_binds_w_fvs `seqList` {-# SCC "StgToCmm" #-}+            stg_to_cmm dflags this_mod denv tycons cost_centre_info stg_binds_w_fvs++        -- codegen consumes a stream of CmmGroup, and produces a new+        -- stream of CmmGroup (not necessarily synchronised: one+        -- CmmGroup on input may produce many CmmGroups on output due+        -- to proc-point splitting).++    let dump1 a = do+          unless (null a) $+            putDumpFileMaybe logger Opt_D_dump_cmm_from_stg+              "Cmm produced by codegen" FormatCMM (pdoc platform a)+          return a++        ppr_stream1 = Stream.mapM (liftIO . dump1) cmm_stream++        cmm_config = initCmmConfig dflags++        pipeline_stream :: CgStream CmmGroupSRTs CmmCgInfos+        pipeline_stream = do+          ((mod_srt_info, ipes, ipe_stats), (lf_infos, detRnEnv)) <-+            {-# SCC "cmmPipeline" #-}+            Stream.mapAccumL_ (pipeline_action logger cmm_config) (emptySRT this_mod, M.empty, mempty) ppr_stream1++          let nonCaffySet = srtMapNonCAFs (moduleSRTMap mod_srt_info)++              -- denv::InfoTableProvMap refers to symbols that no longer exist+              -- if -fobject-determinism is on, since it was created before the+              -- Cmm was renamed. Update all the symbols by renaming them with+              -- the renaming map in that case.+              (_drn, rn_denv)+                | gopt Opt_ObjectDeterminism dflags = detRenameIPEMap detRnEnv denv+                | otherwise = (detRnEnv, denv)++          cmmCgInfos <- generateCgIPEStub hsc_env this_mod rn_denv (nonCaffySet, lf_infos, ipes, ipe_stats)+          return cmmCgInfos++        pipeline_action+          :: Logger+          -> CmmConfig+          -> (ModuleSRTInfo, Map CmmInfoTable (Maybe IpeSourceLocation), IPEStats)+          -> CmmGroup+          -> UniqDSMT IO ((ModuleSRTInfo, Map CmmInfoTable (Maybe IpeSourceLocation), IPEStats), CmmGroupSRTs)+        pipeline_action logger cmm_config (mod_srt_info, ipes, stats) cmm_group = do+          (mod_srt_info', cmm_srts) <- withDUS $ cmmPipeline logger cmm_config mod_srt_info cmm_group++          -- If -finfo-table-map is enabled, we precompute a map from info+          -- tables to source locations. See Note [Mapping Info Tables to Source+          -- Positions] in GHC.Stg.Debug.+          (ipes', stats') <-+            if (gopt Opt_InfoTableMap dflags) then+              liftIO $ lookupEstimatedTicks hsc_env ipes stats cmm_srts+            else+              return (ipes, stats)++          return ((mod_srt_info', ipes', stats'), cmm_srts)++        dump2 a = do+          unless (null a) $+            putDumpFileMaybe logger Opt_D_dump_cmm "Output Cmm" FormatCMM (pdoc platform a)+          return a++    return $ Stream.mapM (liftIO . dump2) pipeline_stream++myCoreToStg :: Logger -> DynFlags -> [Var]+            -> Bool+            -> Module -> ModLocation -> CoreProgram+            -> IO ( [(CgStgTopBinding,IdSet)] -- output program and its dependencies+                  , InfoTableProvMap+                  , CollectedCCs -- CAF cost centre info (declared and used)+                  , StgCgInfos )+myCoreToStg logger dflags ic_inscope for_bytecode this_mod ml prepd_binds = do+    let (stg_binds, denv, cost_centre_info)+         = {-# SCC "Core2Stg" #-}+           coreToStg (initCoreToStgOpts dflags) this_mod ml prepd_binds++    (stg_binds_with_fvs,stg_cg_info)+        <- {-# SCC "Stg2Stg" #-}+           stg2stg logger ic_inscope (initStgPipelineOpts dflags for_bytecode)+                   this_mod stg_binds++    putDumpFileMaybe logger Opt_D_dump_stg_cg "CodeGenInput STG:" FormatSTG+        (pprGenStgTopBindings (initStgPprOpts dflags) (fmap fst stg_binds_with_fvs))++    return (stg_binds_with_fvs, denv, cost_centre_info, stg_cg_info)++{- **********************************************************************+%*                                                                      *+\subsection{Compiling a do-statement}+%*                                                                      *+%********************************************************************* -}++{-+When the UnlinkedBCOExpr is linked you get an HValue of type *IO [HValue]* When+you run it you get a list of HValues that should be the same length as the list+of names; add them to the ClosureEnv.++A naked expression returns a singleton Name [it]. The stmt is lifted into the+IO monad as explained in Note [Interactively-bound Ids in GHCi] in GHC.Runtime.Context+-}++-- | Compile a stmt all the way to an HValue, but don't run it+--+-- We return Nothing to indicate an empty statement (or comment only), not a+-- parse error.+hscStmt :: HscEnv -> String -> IO (Maybe ([Id], ForeignHValue, FixityEnv))+hscStmt hsc_env stmt = hscStmtWithLocation hsc_env stmt "<interactive>" 1++-- | Compile a stmt all the way to an HValue, but don't run it+--+-- We return Nothing to indicate an empty statement (or comment only), not a+-- parse error.+hscStmtWithLocation :: HscEnv+                    -> String -- ^ The statement+                    -> String -- ^ The source+                    -> Int    -- ^ Starting line+                    -> IO ( Maybe ([Id]+                          , ForeignHValue {- IO [HValue] -}+                          , FixityEnv))+hscStmtWithLocation hsc_env0 stmt source linenumber =+  runInteractiveHsc hsc_env0 $ do+    maybe_stmt <- hscParseStmtWithLocation source linenumber stmt+    case maybe_stmt of+      Nothing -> return Nothing++      Just parsed_stmt -> do+        hsc_env <- getHscEnv+        liftIO $ hscParsedStmt hsc_env parsed_stmt++hscParsedStmt :: HscEnv+              -> GhciLStmt GhcPs  -- ^ The parsed statement+              -> IO ( Maybe ([Id]+                    , ForeignHValue {- IO [HValue] -}+                    , FixityEnv))+hscParsedStmt hsc_env stmt = runInteractiveHsc hsc_env $ do+  -- Rename and typecheck it+  (ids, tc_expr, fix_env) <- ioMsgMaybe $ hoistTcRnMessage $ tcRnStmt hsc_env stmt++  -- Desugar it+  ds_expr <- ioMsgMaybe $ hoistDsMessage $ deSugarExpr hsc_env tc_expr+  liftIO (lintInteractiveExpr (text "desugar expression") hsc_env ds_expr)+  handleWarnings++  -- Then code-gen, and link it+  -- It's important NOT to have package 'interactive' as thisUnitId+  -- for linking, else we try to link 'main' and can't find it.+  -- Whereas the linker already knows to ignore 'interactive'+  let src_span = srcLocSpan interactiveSrcLoc+  (hval,_,_) <- liftIO $ hscCompileCoreExpr hsc_env src_span ds_expr++  return $ Just (ids, hval, fix_env)++hscParseModuleWithLocation :: HscEnv -> String -> Int -> String -> IO (HsModule GhcPs)+hscParseModuleWithLocation hsc_env source line_num str = do+    L _ mod <-+      runInteractiveHsc hsc_env $+        hscParseThingWithLocation source line_num parseModule str+    return mod++hscParseDeclsWithLocation :: HscEnv -> String -> Int -> String -> IO [LHsDecl GhcPs]+hscParseDeclsWithLocation hsc_env source line_num str = do+  HsModule { hsmodDecls = decls } <- hscParseModuleWithLocation hsc_env source line_num str+  return decls++hscParsedDecls :: HscEnv -> [LHsDecl GhcPs] -> IO ([TyThing], InteractiveContext)+hscParsedDecls hsc_env decls = runInteractiveHsc hsc_env $ do+    hsc_env <- getHscEnv+    let interp = hscInterp hsc_env++    {- Rename and typecheck it -}+    tc_gblenv <- ioMsgMaybe $ hoistTcRnMessage $ tcRnDeclsi hsc_env decls++    {- Grab the new instances -}+    -- We grab the whole environment because of the overlapping that may have+    -- been done. See the notes at the definition of InteractiveContext+    -- (ic_instances) for more details.+    let defaults = tcg_default tc_gblenv++    {- Desugar it -}+    -- We use a basically null location for iNTERACTIVE+    let iNTERACTIVELoc = OsPathModLocation+            { ml_hs_file_ospath   = Nothing,+              ml_hi_file_ospath   = panic "hsDeclsWithLocation:ml_hi_file_ospath",+              ml_obj_file_ospath  = panic "hsDeclsWithLocation:ml_obj_file_ospath",+              ml_dyn_obj_file_ospath = panic "hsDeclsWithLocation:ml_dyn_obj_file_ospath",+              ml_dyn_hi_file_ospath = panic "hsDeclsWithLocation:ml_dyn_hi_file_ospath",+              ml_hie_file_ospath  = panic "hsDeclsWithLocation:ml_hie_file_ospath" }+    ds_result <- hscDesugar' iNTERACTIVELoc tc_gblenv++    {- Simplify -}+    simpl_mg <- liftIO $ do+      plugins <- readIORef (tcg_th_coreplugins tc_gblenv)+      hscSimplify hsc_env plugins ds_result++    {- Tidy -}+    (tidy_cg, mod_details) <- liftIO $ hscTidy hsc_env simpl_mg++    let !CgGuts{ cg_module    = this_mod,+                 cg_binds     = core_binds+                 } = tidy_cg++        !ModDetails { md_insts     = cls_insts+                    , md_fam_insts = fam_insts } = mod_details+            -- Get the *tidied* cls_insts and fam_insts++    {- Generate byte code & foreign stubs -}+    linkable <- liftIO $ generateFreshByteCode hsc_env+      (moduleName this_mod)+      (mkCgInteractiveGuts tidy_cg)+      iNTERACTIVELoc++    let src_span = srcLocSpan interactiveSrcLoc+    _ <- liftIO $ loadDecls interp hsc_env src_span linkable++    {- Load static pointer table entries -}+    liftIO $ hscAddSptEntries hsc_env (cg_spt_entries tidy_cg)++    let tcs = filterOut isImplicitTyCon (mg_tcs simpl_mg)+        patsyns = mg_patsyns simpl_mg++        ext_ids = [ id | id <- bindersOfBinds core_binds+                       , isExternalName (idName id)+                       , not (isDFunId id || isImplicitId id) ]+            -- We only need to keep around the external bindings+            -- (as decided by GHC.Iface.Tidy), since those are the only ones+            -- that might later be looked up by name.  But we can exclude+            --    - DFunIds, which are in 'cls_insts' (see Note [ic_tythings] in GHC.Runtime.Context+            --    - Implicit Ids, which are implicit in tcs+            -- c.f. GHC.Tc.Module.runTcInteractive, which reconstructs the TypeEnv++        new_tythings = map AnId ext_ids ++ map ATyCon tcs ++ map (AConLike . PatSynCon) patsyns+        ictxt        = hsc_IC hsc_env+        -- See Note [Fixity declarations in GHCi]+        fix_env      = tcg_fix_env tc_gblenv+        new_ictxt    = extendInteractiveContext ictxt new_tythings cls_insts+                                                fam_insts defaults fix_env+    return (new_tythings, new_ictxt)++-- | Load the given static-pointer table entries into the interpreter.+-- See Note [Grand plan for static forms] in "GHC.Iface.Tidy.StaticPtrTable".+hscAddSptEntries :: HscEnv -> [SptEntry] -> IO ()+hscAddSptEntries hsc_env entries = do+    let interp = hscInterp hsc_env+    let add_spt_entry :: SptEntry -> IO ()+        add_spt_entry (SptEntry i fpr) = do+            -- These are only names from the current module+            (val, _, _) <- loadName interp hsc_env (idName i)+            addSptEntry interp fpr val+    mapM_ add_spt_entry entries++{-+  Note [Fixity declarations in GHCi]+  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+  To support fixity declarations on types defined within GHCi (as requested+  in #10018) we record the fixity environment in InteractiveContext.+  When we want to evaluate something GHC.Tc.Module.runTcInteractive pulls out this+  fixity environment and uses it to initialize the global typechecker environment.+  After the typechecker has finished its business, an updated fixity environment+  (reflecting whatever fixity declarations were present in the statements we+  passed it) will be returned from hscParsedStmt. This is passed to+  updateFixityEnv, which will stuff it back into InteractiveContext, to be+  used in evaluating the next statement.++-}++hscImport :: HscEnv -> String -> IO (ImportDecl GhcPs)+hscImport hsc_env str = runInteractiveHsc hsc_env $ do+    -- Use >>= \case instead of MonadFail desugaring to take into+    -- consideration `instance XXModule p = DataConCantHappen`.+    -- Tracked in #15681+    hscParseThing parseModule str >>= \case+      (L _ (HsModule{hsmodImports=is})) ->+        case is of+            [L _ i] -> return i+            _ -> liftIO $ throwOneError $+                     mkPlainErrorMsgEnvelope noSrcSpan $+                     GhcPsMessage $ PsUnknownMessage $+                     mkSimpleUnknownDiagnostic $+                      mkPlainError noHints $+                         text "parse error in import declaration"++-- | Typecheck an expression (but don't run it)+hscTcExpr :: HscEnv+          -> TcRnExprMode+          -> String -- ^ The expression+          -> IO Type+hscTcExpr hsc_env0 mode expr = runInteractiveHsc hsc_env0 $ do+  hsc_env <- getHscEnv+  parsed_expr <- hscParseExpr expr+  ioMsgMaybe $ hoistTcRnMessage $ tcRnExpr hsc_env mode parsed_expr++-- | Find the kind of a type, after generalisation+hscKcType+  :: HscEnv+  -> Bool            -- ^ Normalise the type+  -> String          -- ^ The type as a string+  -> IO (Type, Kind) -- ^ Resulting type (possibly normalised) and kind+hscKcType hsc_env0 normalise str = runInteractiveHsc hsc_env0 $ do+    hsc_env <- getHscEnv+    ty <- hscParseType str+    ioMsgMaybe $ hoistTcRnMessage $ tcRnType hsc_env DefaultFlexi normalise ty++hscParseExpr :: String -> Hsc (LHsExpr GhcPs)+hscParseExpr expr = do+  maybe_stmt <- hscParseStmt expr+  case maybe_stmt of+    Just (L _ (BodyStmt _ expr _ _)) -> return expr+    _ -> throwOneError $+           mkPlainErrorMsgEnvelope noSrcSpan $+           GhcPsMessage $ PsUnknownMessage+             $ mkSimpleUnknownDiagnostic+             $ mkPlainError noHints $+             text "not an expression:" <+> quotes (text expr)++hscParseStmt :: String -> Hsc (Maybe (GhciLStmt GhcPs))+hscParseStmt = hscParseThing parseStmt++hscParseStmtWithLocation :: String -> Int -> String+                         -> Hsc (Maybe (GhciLStmt GhcPs))+hscParseStmtWithLocation source linenumber stmt =+    hscParseThingWithLocation source linenumber parseStmt stmt++hscParseType :: String -> Hsc (LHsType GhcPs)+hscParseType = hscParseThing parseType++hscParseIdentifier :: HscEnv -> String -> IO (LocatedN RdrName)+hscParseIdentifier hsc_env str =+    runInteractiveHsc hsc_env $ hscParseThing parseIdentifier str++hscParseThing :: (Outputable thing, Data thing)+              => Lexer.P thing -> String -> Hsc thing+hscParseThing = hscParseThingWithLocation "<interactive>" 1++hscParseThingWithLocation :: (Outputable thing, Data thing) => String -> Int+                          -> Lexer.P thing -> String -> Hsc thing+hscParseThingWithLocation source linenumber parser str = do+    dflags <- getDynFlags+    logger <- getLogger+    withTiming logger+               (text "Parser [source]")+               (const ()) $ {-# SCC "Parser" #-} do++        let buf = stringToStringBuffer str+            loc = mkRealSrcLoc (fsLit source) linenumber 1++        case unP parser (initParserState (initParserOpts dflags) buf loc) of+            PFailed pst ->+                handleWarningsThrowErrors (getPsMessages pst)+            POk pst thing -> do+                logWarningsReportErrors (getPsMessages pst)+                liftIO $ putDumpFileMaybe logger Opt_D_dump_parsed "Parser"+                            FormatHaskell (ppr thing)+                liftIO $ putDumpFileMaybe logger Opt_D_dump_parsed_ast "Parser AST"+                            FormatHaskell (showAstData NoBlankSrcSpan NoBlankEpAnnotations thing)+                return thing++hscTidy :: HscEnv -> ModGuts -> IO (CgGuts, ModDetails)+hscTidy hsc_env guts = do+  let logger   = hsc_logger hsc_env+  let this_mod = mg_module guts++  opts <- initTidyOpts hsc_env+  (cgguts, details) <- withTiming logger+    (text "CoreTidy"<+>brackets (ppr this_mod))+    (const ())+    $! {-# SCC "CoreTidy" #-} tidyProgram opts guts++  -- post tidy pretty-printing and linting...+  let tidy_rules     = md_rules details+  let all_tidy_binds = cg_binds cgguts+  let name_ppr_ctx   = mkNamePprCtx ptc (hsc_unit_env hsc_env) (mg_rdr_env guts)+      ptc            = initPromotionTickContext (hsc_dflags hsc_env)++  endPassHscEnvIO hsc_env name_ppr_ctx CoreTidy all_tidy_binds tidy_rules++  -- If the endPass didn't print the rules, but ddump-rules is+  -- on, print now+  unless (logHasDumpFlag logger Opt_D_dump_simpl) $+    putDumpFileMaybe logger Opt_D_dump_rules+      "Tidy Core rules"+      FormatText+      (pprRulesForUser tidy_rules)++  -- Print one-line size info+  let cs = coreBindsStats all_tidy_binds+  putDumpFileMaybe logger Opt_D_dump_core_stats "Core Stats"+    FormatText+    (text "Tidy size (terms,types,coercions)"+     <+> ppr (moduleName this_mod) <> colon+     <+> int (cs_tm cs)+     <+> int (cs_ty cs)+     <+> int (cs_co cs))++  pure (cgguts, details)+++{- **********************************************************************+%*                                                                      *+        Desugar, simplify, convert to bytecode, and link an expression+%*                                                                      *+%********************************************************************* -}++hscCompileCoreExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO (ForeignHValue, [Linkable], PkgsLoaded)+hscCompileCoreExpr hsc_env loc expr =+  case hscCompileCoreExprHook (hsc_hooks hsc_env) of+      Nothing -> hscCompileCoreExpr' hsc_env loc expr+      Just h  -> h                   hsc_env loc expr++hscCompileCoreExpr' :: HscEnv -> SrcSpan -> CoreExpr -> IO (ForeignHValue, [Linkable], PkgsLoaded)+hscCompileCoreExpr' hsc_env srcspan ds_expr = do+  {- Simplify it -}+  -- Question: should we call SimpleOpt.simpleOptExpr here instead?+  -- It is, well, simpler, and does less inlining etc.+  let dflags = hsc_dflags hsc_env+  let logger = hsc_logger hsc_env+  let ic = hsc_IC hsc_env+  let unit_env = hsc_unit_env hsc_env+  let simplify_expr_opts = initSimplifyExprOpts dflags ic++  simpl_expr <- simplifyExpr logger (ue_eps unit_env) simplify_expr_opts ds_expr++  -- Create a unique temporary binding+  --+  -- The id has to be exported for the JS backend. This isn't required for the+  -- byte-code interpreter but it does no harm to always do it.+  u <- uniqFromTag 'I'+  let binding_name = mkSystemVarName u (fsLit ("BCO_toplevel"))+  let binding_id   = mkExportedVanillaId binding_name (exprType simpl_expr)++  {- Tidy it (temporary, until coreSat does cloning) -}+  let tidy_occ_env = initTidyOccEnv [occName binding_id]+  let tidy_env     = mkEmptyTidyEnv tidy_occ_env+  let tidy_expr    = tidyExpr tidy_env simpl_expr++  {- Prepare for codegen -}+  cp_cfg <- initCorePrepConfig hsc_env+  prepd_expr <- corePrepExpr+   logger cp_cfg+   tidy_expr++  {- Lint if necessary -}+  lintInteractiveExpr (text "hscCompileCoreExpr") hsc_env prepd_expr+  let this_loc = OsPathModLocation+          { ml_hs_file_ospath   = Nothing,+            ml_hi_file_ospath   = panic "hscCompileCoreExpr':ml_hi_file_ospath",+            ml_obj_file_ospath  = panic "hscCompileCoreExpr':ml_obj_file_ospath",+            ml_dyn_obj_file_ospath = panic "hscCompileCoreExpr': ml_obj_file_ospath",+            ml_dyn_hi_file_ospath  = panic "hscCompileCoreExpr': ml_dyn_hi_file_ospath",+            ml_hie_file_ospath  = panic "hscCompileCoreExpr':ml_hie_file_ospath" }++  -- Ensure module uniqueness by giving it a name like "GhciNNNN".+  -- This uniqueness is needed by the JS linker. Without it we break the 1-1+  -- relationship between modules and object files, i.e. we get different object+  -- files for the same module and the JS linker doesn't support this.+  --+  -- Note that we can't use icInteractiveModule because the ic_mod_index value+  -- isn't bumped between invocations of hscCompileCoreExpr, so uniqueness isn't+  -- guaranteed.+  --+  -- We reuse the unique we obtained for the binding, but any unique would do.+  let this_mod = mkInteractiveModule (show u)+  let for_bytecode = True++  (stg_binds_with_deps, _prov_map, _collected_ccs, _stg_cg_infos) <-+       myCoreToStg logger+                   dflags+                   (interactiveInScope (hsc_IC hsc_env))+                   for_bytecode+                   this_mod+                   this_loc+                   [NonRec binding_id prepd_expr]++  let (stg_binds, _stg_deps) = unzip stg_binds_with_deps++  let interp = hscInterp hsc_env++  case interp of+    -- always generate JS code for the JS interpreter (no bytecode!)+    Interp (ExternalInterp (ExtJS i)) _ _ ->+      jsCodeGen hsc_env srcspan i this_mod stg_binds_with_deps binding_id++    _ -> do+      {- Convert to BCOs -}+      bcos <- byteCodeGen hsc_env+                this_mod+                stg_binds+                []+                Nothing -- modbreaks+                [] -- spt entries++      {- load it -}+      bco_time <- getCurrentTime+      (fv_hvs, mods_needed, units_needed) <- loadDecls interp hsc_env srcspan $+        Linkable bco_time this_mod $ NE.singleton $ BCOs bcos+      {- Get the HValue for the root -}+      return (expectJust $ lookup (idName binding_id) fv_hvs, mods_needed, units_needed)++++-- | Generate JS code for the given bindings and return the HValue for the given id+jsCodeGen+  :: HscEnv+  -> SrcSpan+  -> JSInterp+  -> Module+  -> [(CgStgTopBinding,IdSet)]+  -> Id+  -> IO (ForeignHValue, [Linkable], PkgsLoaded)+jsCodeGen hsc_env srcspan i this_mod stg_binds_with_deps binding_id = do+  let logger           = hsc_logger hsc_env+      tmpfs            = hsc_tmpfs hsc_env+      dflags           = hsc_dflags hsc_env+      interp           = hscInterp hsc_env+      tmp_dir          = tmpDir dflags+      unit_env         = hsc_unit_env hsc_env+      js_config        = initStgToJSConfig dflags++  -- We need to load all the dependencies first.+  --+  -- We get all the imported names from the Stg bindings and load their modules.+  --+  -- (logic adapted from GHC.Linker.Loader.loadDecls for the JS linker)+  let+    (stg_binds, stg_deps) = unzip stg_binds_with_deps+    imported_ids   = nonDetEltsUniqSet (unionVarSets stg_deps)+    imported_names = map idName imported_ids++    needed_mods :: [Module]+    needed_mods = [ nameModule n | n <- imported_names,+                    isExternalName n,       -- Names from other modules+                    not (isWiredInName n)   -- Exclude wired-in names+                  ]                         -- (see note below)+    -- Exclude wired-in names because we may not have read+    -- their interface files, so getLinkDeps will fail+    -- All wired-in names are in the base package, which we link+    -- by default, so we can safely ignore them here.++  -- Initialise the linker (if it's not been done already)+  initLoaderState interp hsc_env++  -- Take lock for the actual work.+  (dep_linkables, dep_units) <- modifyLoaderState interp $ \pls -> do+    let link_opts = initLinkDepsOpts hsc_env++    -- Find what packages and linkables are required+    deps <- getLinkDeps link_opts interp pls srcspan needed_mods+    -- We update the LinkerState even if the JS interpreter maintains its linker+    -- state independently to load new objects here.++    let objs = mapMaybe linkableFilterNative (ldNeededLinkables deps)+        (objs_loaded', _new_objs) = rmDupLinkables (objs_loaded pls) objs++    -- FIXME: we should make the JS linker load new_objs here, instead of+    -- on-demand.++    -- FIXME: we don't report needed units because we would have to find a way+    -- to build a meaningful LoadedPkgInfo (see the mess in+    -- GHC.Linker.Loader.{loadPackage,loadPackages'}). Detecting what to load+    -- and actually loading (using the native interpreter) are intermingled, so+    -- we can't directly reuse this code.+    let pls' = pls { objs_loaded = objs_loaded' }+    pure (pls', (ldAllLinkables deps, emptyUDFM {- ldNeededUnits deps -}) )+++  let foreign_stubs    = NoStubs+      spt_entries      = mempty+      cost_centre_info = mempty++  -- codegen into object file whose path is in out_obj+  out_obj <- newTempName logger tmpfs tmp_dir TFL_CurrentModule "o"+  stgToJS logger js_config stg_binds this_mod spt_entries foreign_stubs cost_centre_info out_obj++  let TxtI id_sym = makeIdentForId binding_id Nothing IdPlain this_mod+  -- link code containing binding "id_sym = expr", using id_sym as root+  withJSInterp i $ \inst -> do+    let roots = mkExportedModFuns this_mod [id_sym]+    jsLinkObject logger tmpfs tmp_dir js_config unit_env inst out_obj roots++  -- look up "id_sym" closure and create a StablePtr (HValue) from it+  href <- lookupClosure interp (IFaststringSymbol id_sym) >>= \case+    Nothing -> pprPanic "Couldn't find just linked TH closure" (ppr id_sym)+    Just r  -> pure r++  binding_fref <- withJSInterp i $ \inst ->+                    mkForeignRef href (freeReallyRemoteRef inst href)++  return (castForeignRef binding_fref, dep_linkables, dep_units)+++{- **********************************************************************+%*                                                                      *+        Statistics on reading interfaces+%*                                                                      *+%********************************************************************* -}++dumpIfaceStats :: HscEnv -> IO ()+dumpIfaceStats hsc_env = do+  eps <- hscEPS hsc_env+  let+    logger = hsc_logger hsc_env+    dump_rn_stats = logHasDumpFlag logger Opt_D_dump_rn_stats+    dump_if_trace = logHasDumpFlag logger Opt_D_dump_if_trace+  when (dump_if_trace || dump_rn_stats) $+    logDumpMsg logger "Interface statistics" (ifaceStats eps)++++writeInterfaceOnlyMode :: DynFlags -> Bool+writeInterfaceOnlyMode dflags =+ gopt Opt_WriteInterface dflags &&+ not (backendGeneratesCode (backend dflags))
+ GHC/Driver/Main.hs-boot view
@@ -0,0 +1,15 @@+module GHC.Driver.Main where++import GHC.Driver.Env.Types (HscEnv)+import GHC.Linker.Types (Linkable)+import GHC.Prelude.Basic+import GHC.Types.TypeEnv (TypeEnv)+import GHC.Unit.Module.Location (ModLocation)+import GHC.Unit.Module.ModIface (ModIface)++loadIfaceByteCode ::+  HscEnv ->+  ModIface ->+  ModLocation ->+  TypeEnv ->+  Maybe (IO Linkable)
GHC/Driver/Make.hs view
@@ -1,2736 +1,1935 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE NondecreasingIndentation #-}-{-# LANGUAGE ScopedTypeVariables #-}--{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE GeneralisedNewtypeDeriving #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE ApplicativeDo #-}-{-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE RecordWildCards #-}---- ----------------------------------------------------------------------------------- (c) The University of Glasgow, 2011------ This module implements multi-module compilation, and is used--- by --make and GHCi.------ ------------------------------------------------------------------------------module GHC.Driver.Make (-        depanal, depanalE, depanalPartial, checkHomeUnitsClosed,-        load, loadWithCache, load', LoadHowMuch(..), ModIfaceCache(..), noIfaceCache, newIfaceCache,-        instantiationNodes,--        downsweep,--        topSortModuleGraph,--        ms_home_srcimps, ms_home_imps,--        summariseModule,-        SummariseResult(..),-        summariseFile,-        hscSourceToIsBoot,-        findExtraSigImports,-        implicitRequirementsShallow,--        noModError, cyclicModuleErr,-        SummaryNode,-        IsBootInterface(..), mkNodeKey,--        ModNodeKey, ModNodeKeyWithUid(..),-        ModNodeMap(..), emptyModNodeMap, modNodeMapElems, modNodeMapLookup, modNodeMapInsert, modNodeMapSingleton, modNodeMapUnionWith-        ) where--import GHC.Prelude-import GHC.Platform--import GHC.Tc.Utils.Backpack-import GHC.Tc.Utils.Monad  ( initIfaceCheck )--import GHC.Runtime.Interpreter-import qualified GHC.Linker.Loader as Linker-import GHC.Linker.Types--import GHC.Platform.Ways--import GHC.Driver.Config.Finder (initFinderOpts)-import GHC.Driver.Config.Parser (initParserOpts)-import GHC.Driver.Config.Diagnostic-import GHC.Driver.Phases-import GHC.Driver.Pipeline-import GHC.Driver.Session-import GHC.Driver.Backend-import GHC.Driver.Monad-import GHC.Driver.Env-import GHC.Driver.Errors-import GHC.Driver.Errors.Types-import GHC.Driver.Main--import GHC.Parser.Header--import GHC.Iface.Load      ( cannotFindModule )-import GHC.IfaceToCore     ( typecheckIface )-import GHC.Iface.Recomp    ( RecompileRequired(..), CompileReason(..) )--import GHC.Data.Bag        ( listToBag )-import GHC.Data.Graph.Directed-import GHC.Data.FastString-import GHC.Data.Maybe      ( expectJust )-import GHC.Data.StringBuffer-import qualified GHC.LanguageExtensions as LangExt--import GHC.Utils.Exception ( throwIO, SomeAsyncException )-import GHC.Utils.Outputable-import GHC.Utils.Panic-import GHC.Utils.Panic.Plain-import GHC.Utils.Misc-import GHC.Utils.Error-import GHC.Utils.Logger-import GHC.Utils.Fingerprint-import GHC.Utils.TmpFs--import GHC.Types.Basic-import GHC.Types.Error-import GHC.Types.Target-import GHC.Types.SourceFile-import GHC.Types.SourceError-import GHC.Types.SrcLoc-import GHC.Types.Unique.FM-import GHC.Types.PkgQual--import GHC.Unit-import GHC.Unit.Env-import GHC.Unit.Finder-import GHC.Unit.Module.ModSummary-import GHC.Unit.Module.ModIface-import GHC.Unit.Module.Graph-import GHC.Unit.Home.ModInfo-import GHC.Unit.Module.ModDetails--import Data.Either ( rights, partitionEithers, lefts )-import qualified Data.Map as Map-import qualified Data.Set as Set--import Control.Concurrent ( newQSem, waitQSem, signalQSem, ThreadId, killThread, forkIOWithUnmask )-import qualified GHC.Conc as CC-import Control.Concurrent.MVar-import Control.Monad-import Control.Monad.Trans.Except ( ExceptT(..), runExceptT, throwE )-import qualified Control.Monad.Catch as MC-import Data.IORef-import Data.Maybe-import Data.Time-import Data.Bifunctor (first)-import System.Directory-import System.FilePath-import System.IO        ( fixIO )--import GHC.Conc ( getNumProcessors, getNumCapabilities, setNumCapabilities )-import Control.Monad.IO.Class-import Control.Monad.Trans.Reader-import GHC.Driver.Pipeline.LogQueue-import qualified Data.Map.Strict as M-import GHC.Types.TypeEnv-import Control.Monad.Trans.State.Lazy-import Control.Monad.Trans.Class-import GHC.Driver.Env.KnotVars-import Control.Concurrent.STM-import Control.Monad.Trans.Maybe-import GHC.Runtime.Loader-import GHC.Rename.Names-import GHC.Utils.Constants---- -------------------------------------------------------------------------------- Loading the program---- | Perform a dependency analysis starting from the current targets--- and update the session with the new module graph.------ Dependency analysis entails parsing the @import@ directives and may--- therefore require running certain preprocessors.------ Note that each 'ModSummary' in the module graph caches its 'DynFlags'.--- These 'DynFlags' are determined by the /current/ session 'DynFlags' and the--- @OPTIONS@ and @LANGUAGE@ pragmas of the parsed module.  Thus if you want--- changes to the 'DynFlags' to take effect you need to call this function--- again.--- In case of errors, just throw them.----depanal :: GhcMonad m =>-           [ModuleName]  -- ^ excluded modules-        -> Bool          -- ^ allow duplicate roots-        -> m ModuleGraph-depanal excluded_mods allow_dup_roots = do-    (errs, mod_graph) <- depanalE excluded_mods allow_dup_roots-    if isEmptyMessages errs-      then pure mod_graph-      else throwErrors (fmap GhcDriverMessage errs)---- | Perform dependency analysis like in 'depanal'.--- In case of errors, the errors and an empty module graph are returned.-depanalE :: GhcMonad m =>     -- New for #17459-            [ModuleName]      -- ^ excluded modules-            -> Bool           -- ^ allow duplicate roots-            -> m (DriverMessages, ModuleGraph)-depanalE excluded_mods allow_dup_roots = do-    hsc_env <- getSession-    (errs, mod_graph) <- depanalPartial excluded_mods allow_dup_roots-    if isEmptyMessages errs-      then do-        hsc_env <- getSession-        let one_unit_messages get_mod_errs k hue = do-              errs <- get_mod_errs-              unknown_module_err <- warnUnknownModules (hscSetActiveUnitId k hsc_env) (homeUnitEnv_dflags hue) mod_graph--              let unused_home_mod_err = warnMissingHomeModules (homeUnitEnv_dflags hue) (hsc_targets hsc_env) mod_graph-                  unused_pkg_err = warnUnusedPackages (homeUnitEnv_units hue) (homeUnitEnv_dflags hue) mod_graph---              return $ errs `unionMessages` unused_home_mod_err-                          `unionMessages` unused_pkg_err-                          `unionMessages` unknown_module_err--        all_errs <- liftIO $ unitEnv_foldWithKey one_unit_messages (return emptyMessages) (hsc_HUG hsc_env)-        logDiagnostics (GhcDriverMessage <$> all_errs)-        setSession hsc_env { hsc_mod_graph = mod_graph }-        pure (emptyMessages, mod_graph)-      else do-        -- We don't have a complete module dependency graph,-        -- The graph may be disconnected and is unusable.-        setSession hsc_env { hsc_mod_graph = emptyMG }-        pure (errs, emptyMG)----- | Perform dependency analysis like 'depanal' but return a partial module--- graph even in the face of problems with some modules.------ Modules which have parse errors in the module header, failing--- preprocessors or other issues preventing them from being summarised will--- simply be absent from the returned module graph.------ Unlike 'depanal' this function will not update 'hsc_mod_graph' with the--- new module graph.-depanalPartial-    :: GhcMonad m-    => [ModuleName]  -- ^ excluded modules-    -> Bool          -- ^ allow duplicate roots-    -> m (DriverMessages, ModuleGraph)-    -- ^ possibly empty 'Bag' of errors and a module graph.-depanalPartial excluded_mods allow_dup_roots = do-  hsc_env <- getSession-  let-         targets = hsc_targets hsc_env-         old_graph = hsc_mod_graph hsc_env-         logger  = hsc_logger hsc_env--  withTiming logger (text "Chasing dependencies") (const ()) $ do-    liftIO $ debugTraceMsg logger 2 (hcat [-              text "Chasing modules from: ",-              hcat (punctuate comma (map pprTarget targets))])--    -- Home package modules may have been moved or deleted, and new-    -- source files may have appeared in the home package that shadow-    -- external package modules, so we have to discard the existing-    -- cached finder data.-    liftIO $ flushFinderCaches (hsc_FC hsc_env) (hsc_unit_env hsc_env)--    (errs, graph_nodes) <- liftIO $ downsweep-      hsc_env (mgModSummaries old_graph)-      excluded_mods allow_dup_roots-    let-      mod_graph = mkModuleGraph graph_nodes-    return (unionManyMessages errs, mod_graph)---- | Collect the instantiations of dependencies to create 'InstantiationNode' work graph nodes.--- These are used to represent the type checking that is done after--- all the free holes (sigs in current package) relevant to that instantiation--- are compiled. This is necessary to catch some instantiation errors.------ In the future, perhaps more of the work of instantiation could be moved here,--- instead of shoved in with the module compilation nodes. That could simplify--- backpack, and maybe hs-boot too.-instantiationNodes :: UnitId -> UnitState -> [ModuleGraphNode]-instantiationNodes uid unit_state = InstantiationNode uid <$> iuids_to_check-  where-    iuids_to_check :: [InstantiatedUnit]-    iuids_to_check =-      nubSort $ concatMap (goUnitId . fst) (explicitUnits unit_state)-     where-      goUnitId uid =-        [ recur-        | VirtUnit indef <- [uid]-        , inst <- instUnitInsts indef-        , recur <- (indef :) $ goUnitId $ moduleUnit $ snd inst-        ]---- The linking plan for each module. If we need to do linking for a home unit--- then this function returns a graph node which depends on all the modules in the home unit.---- At the moment nothing can depend on these LinkNodes.-linkNodes :: [ModuleGraphNode] -> UnitId -> HomeUnitEnv -> Maybe (Either (Messages DriverMessage) ModuleGraphNode)-linkNodes summaries uid hue =-  let dflags = homeUnitEnv_dflags hue-      ofile = outputFile_ dflags--      unit_nodes :: [NodeKey]-      unit_nodes = map mkNodeKey (filter ((== uid) . moduleGraphNodeUnitId) summaries)-  -- Issue a warning for the confusing case where the user-  -- said '-o foo' but we're not going to do any linking.-  -- We attempt linking if either (a) one of the modules is-  -- called Main, or (b) the user said -no-hs-main, indicating-  -- that main() is going to come from somewhere else.-  ---      no_hs_main = gopt Opt_NoHsMain dflags--      main_sum = any (== NodeKey_Module (ModNodeKeyWithUid (GWIB (mainModuleNameIs dflags) NotBoot) uid)) unit_nodes--      do_linking =  main_sum || no_hs_main || ghcLink dflags == LinkDynLib || ghcLink dflags == LinkStaticLib--  in if | ghcLink dflags == LinkBinary && isJust ofile && not do_linking ->-            Just (Left $ singleMessage $ mkPlainErrorMsgEnvelope noSrcSpan (DriverRedirectedNoMain $ mainModuleNameIs dflags))-        -- This should be an error, not a warning (#10895).-        | ghcLink dflags /= NoLink, do_linking -> Just (Right (LinkNode unit_nodes uid))-        | otherwise  -> Nothing---- Note [Missing home modules]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- Sometimes user doesn't want GHC to pick up modules, not explicitly listed--- in a command line. For example, cabal may want to enable this warning--- when building a library, so that GHC warns user about modules, not listed--- neither in `exposed-modules`, nor in `other-modules`.------ Here "home module" means a module, that doesn't come from an other package.------ For example, if GHC is invoked with modules "A" and "B" as targets,--- but "A" imports some other module "C", then GHC will issue a warning--- about module "C" not being listed in a command line.------ The warning in enabled by `-Wmissing-home-modules`. See #13129-warnMissingHomeModules ::  DynFlags -> [Target] -> ModuleGraph -> DriverMessages-warnMissingHomeModules dflags targets mod_graph =-    if null missing-      then emptyMessages-      else warn-  where-    diag_opts = initDiagOpts dflags--    is_known_module mod = any (is_my_target mod) targets--    -- We need to be careful to handle the case where (possibly-    -- path-qualified) filenames (aka 'TargetFile') rather than module-    -- names are being passed on the GHC command-line.-    ---    -- For instance, `ghc --make src-exe/Main.hs` and-    -- `ghc --make -isrc-exe Main` are supposed to be equivalent.-    -- Note also that we can't always infer the associated module name-    -- directly from the filename argument.  See #13727.-    is_my_target mod target =-      let tuid = targetUnitId target-      in case targetId target of-          TargetModule name-            -> moduleName (ms_mod mod) == name-                && tuid == ms_unitid mod-          TargetFile target_file _-            | Just mod_file <- ml_hs_file (ms_location mod)-            ->-             target_file == mod_file ||--             --  Don't warn on B.hs-boot if B.hs is specified (#16551)-             addBootSuffix target_file == mod_file ||--             --  We can get a file target even if a module name was-             --  originally specified in a command line because it can-             --  be converted in guessTarget (by appending .hs/.lhs).-             --  So let's convert it back and compare with module name-             mkModuleName (fst $ splitExtension target_file)-              == moduleName (ms_mod mod)-          _ -> False--    missing = map (moduleName . ms_mod) $-      filter (not . is_known_module) $-        (filter (\ms -> ms_unitid ms == homeUnitId_ dflags)-                (mgModSummaries mod_graph))--    warn = singleMessage $ mkPlainMsgEnvelope diag_opts noSrcSpan-                         $ DriverMissingHomeModules missing (checkBuildingCabalPackage dflags)---- Check that any modules we want to reexport or hide are actually in the package.-warnUnknownModules :: HscEnv -> DynFlags -> ModuleGraph -> IO DriverMessages-warnUnknownModules hsc_env dflags mod_graph = do-  reexported_warns <- filterM check_reexport (Set.toList reexported_mods)-  return $ final_msgs hidden_warns reexported_warns-  where-    diag_opts = initDiagOpts dflags--    unit_mods = Set.fromList (map ms_mod_name-                  (filter (\ms -> ms_unitid ms == homeUnitId_ dflags)-                       (mgModSummaries mod_graph)))--    reexported_mods = reexportedModules dflags-    hidden_mods     = hiddenModules dflags--    hidden_warns = hidden_mods `Set.difference` unit_mods--    lookupModule mn = findImportedModule hsc_env mn NoPkgQual--    check_reexport mn = do-      fr <- lookupModule mn-      case fr of-        Found _ m -> return (moduleUnitId m == homeUnitId_ dflags)-        _ -> return True---    warn flag mod = singleMessage $ mkPlainMsgEnvelope diag_opts noSrcSpan-                         $ flag mod--    final_msgs hidden_warns reexported_warns-          =-        unionManyMessages $-          [warn DriverUnknownHiddenModules (Set.toList hidden_warns) | not (Set.null hidden_warns)]-          ++ [warn DriverUnknownReexportedModules reexported_warns | not (null reexported_warns)]---- | Describes which modules of the module graph need to be loaded.-data LoadHowMuch-   = LoadAllTargets-     -- ^ Load all targets and its dependencies.-   | LoadUpTo HomeUnitModule-     -- ^ Load only the given module and its dependencies.-   | LoadDependenciesOf HomeUnitModule-     -- ^ Load only the dependencies of the given module, but not the module-     -- itself.--{--Note [Caching HomeModInfo]-~~~~~~~~~~~~~~~~~~~~~~~~~~--API clients who call `load` like to cache the HomeModInfo in memory between-calls to this function. In the old days, this cache was a simple MVar which stored-a HomePackageTable. This was insufficient, as the interface files for boot modules-were not recorded in the cache. In the less old days, the cache was returned at the-end of load, and supplied at the start of load, however, this was not sufficient-because it didn't account for the possibility of exceptions such as SIGINT (#20780).--So now, in the current day, we have this ModIfaceCache abstraction which-can incrementally be updated during the process of upsweep. This allows us-to store interface files for boot modules in an exception-safe way.--When the final version of an interface file is completed then it is placed into-the cache. The contents of the cache is retrieved, and the cache cleared, by iface_clearCache.--Note that because we only store the ModIface and Linkable in the ModIfaceCache,-hydration and rehydration is totally irrelevant, and we just store the CachedIface as-soon as it is completed.---}----- Abstract interface to a cache of HomeModInfo--- See Note [Caching HomeModInfo]-data ModIfaceCache = ModIfaceCache { iface_clearCache :: IO [CachedIface]-                                   , iface_addToCache :: CachedIface -> IO () }--addHmiToCache :: ModIfaceCache -> HomeModInfo -> IO ()-addHmiToCache c (HomeModInfo i _ l) = iface_addToCache c (CachedIface i l)--data CachedIface = CachedIface { cached_modiface :: !ModIface-                               , cached_linkable :: !(Maybe Linkable) }--noIfaceCache :: Maybe ModIfaceCache-noIfaceCache = Nothing--newIfaceCache :: IO ModIfaceCache-newIfaceCache = do-  ioref <- newIORef []-  return $-    ModIfaceCache-      { iface_clearCache = atomicModifyIORef' ioref (\c -> ([], c))-      , iface_addToCache = \hmi -> atomicModifyIORef' ioref (\c -> (hmi:c, ()))-      }------- | Try to load the program.  See 'LoadHowMuch' for the different modes.------ This function implements the core of GHC's @--make@ mode.  It preprocesses,--- compiles and loads the specified modules, avoiding re-compilation wherever--- possible.  Depending on the backend (see 'DynFlags.backend' field) compiling--- and loading may result in files being created on disk.------ Calls the 'defaultWarnErrLogger' after each compiling each module, whether--- successful or not.------ If errors are encountered during dependency analysis, the module `depanalE`--- returns together with the errors an empty ModuleGraph.--- After processing this empty ModuleGraph, the errors of depanalE are thrown.--- All other errors are reported using the 'defaultWarnErrLogger'.--load :: GhcMonad f => LoadHowMuch -> f SuccessFlag-load how_much = loadWithCache noIfaceCache how_much--mkBatchMsg :: HscEnv -> Messager-mkBatchMsg hsc_env =-  if length (hsc_all_home_unit_ids hsc_env) > 1-    -- This also displays what unit each module is from.-    then batchMultiMsg-    else batchMsg---loadWithCache :: GhcMonad m => Maybe ModIfaceCache -> LoadHowMuch -> m SuccessFlag-loadWithCache cache how_much = do-    (errs, mod_graph) <- depanalE [] False                        -- #17459-    msg <- mkBatchMsg <$> getSession-    success <- load' cache how_much (Just msg) mod_graph-    if isEmptyMessages errs-      then pure success-      else throwErrors (fmap GhcDriverMessage errs)---- Note [Unused packages]--- ~~~~~~~~~~~~~~~~~~~~~~--- Cabal passes `--package-id` flag for each direct dependency. But GHC--- loads them lazily, so when compilation is done, we have a list of all--- actually loaded packages. All the packages, specified on command line,--- but never loaded, are probably unused dependencies.--warnUnusedPackages :: UnitState -> DynFlags -> ModuleGraph -> DriverMessages-warnUnusedPackages us dflags mod_graph =-    let diag_opts = initDiagOpts dflags--    -- Only need non-source imports here because SOURCE imports are always HPT-        loadedPackages = concat $-          mapMaybe (\(fs, mn) -> lookupModulePackage us (unLoc mn) fs)-            $ concatMap ms_imps (-              filter (\ms -> homeUnitId_ dflags == ms_unitid ms) (mgModSummaries mod_graph))--        used_args = Set.fromList $ map unitId loadedPackages--        resolve (u,mflag) = do-                  -- The units which we depend on via the command line explicitly-                  flag <- mflag-                  -- Which we can find the UnitInfo for (should be all of them)-                  ui <- lookupUnit us u-                  -- Which are not explicitly used-                  guard (Set.notMember (unitId ui) used_args)-                  return (unitId ui, unitPackageName ui, unitPackageVersion ui, flag)--        unusedArgs = mapMaybe resolve (explicitUnits us)--        warn = singleMessage $ mkPlainMsgEnvelope diag_opts noSrcSpan (DriverUnusedPackages unusedArgs)--    in if null unusedArgs-        then emptyMessages-        else warn----- | A ModuleGraphNode which also has a hs-boot file, and the list of nodes on any--- path from module to its boot file.-data ModuleGraphNodeWithBootFile-  = ModuleGraphNodeWithBootFile ModuleGraphNode [ModuleGraphNode]--instance Outputable ModuleGraphNodeWithBootFile where-  ppr (ModuleGraphNodeWithBootFile mgn deps) = text "ModeGraphNodeWithBootFile: " <+> ppr mgn $$ ppr deps--getNode :: ModuleGraphNodeWithBootFile -> ModuleGraphNode-getNode (ModuleGraphNodeWithBootFile mgn _) = mgn-data BuildPlan = SingleModule ModuleGraphNode  -- A simple, single module all alone but *might* have an hs-boot file which isn't part of a cycle-               | ResolvedCycle [Either ModuleGraphNode ModuleGraphNodeWithBootFile]   -- A resolved cycle, linearised by hs-boot files-               | UnresolvedCycle [ModuleGraphNode] -- An actual cycle, which wasn't resolved by hs-boot files--instance Outputable BuildPlan where-  ppr (SingleModule mgn) = text "SingleModule" <> parens (ppr mgn)-  ppr (ResolvedCycle mgn)   = text "ResolvedCycle:" <+> ppr mgn-  ppr (UnresolvedCycle mgn) = text "UnresolvedCycle:" <+> ppr mgn----- Just used for an assertion-countMods :: BuildPlan -> Int-countMods (SingleModule _) = 1-countMods (ResolvedCycle ns) = length ns-countMods (UnresolvedCycle ns) = length ns---- See Note [Upsweep] for a high-level description.-createBuildPlan :: ModuleGraph -> Maybe HomeUnitModule -> [BuildPlan]-createBuildPlan mod_graph maybe_top_mod =-    let -- Step 1: Compute SCCs without .hi-boot files, to find the cycles-        cycle_mod_graph = topSortModuleGraph True mod_graph maybe_top_mod--        -- Step 2: Reanalyse loops, with relevant boot modules, to solve the cycles.-        build_plan :: [BuildPlan]-        build_plan-          -- Fast path, if there are no boot modules just do a normal toposort-          | isEmptyModuleEnv boot_modules = collapseAcyclic $ topSortModuleGraph False mod_graph maybe_top_mod-          | otherwise = toBuildPlan cycle_mod_graph []--        toBuildPlan :: [SCC ModuleGraphNode] -> [ModuleGraphNode] -> [BuildPlan]-        toBuildPlan [] mgn = collapseAcyclic (topSortWithBoot mgn)-        toBuildPlan ((AcyclicSCC node):sccs) mgn = toBuildPlan sccs (node:mgn)-        -- Interesting case-        toBuildPlan ((CyclicSCC nodes):sccs) mgn =-          let acyclic = collapseAcyclic (topSortWithBoot mgn)-              -- Now perform another toposort but just with these nodes and relevant hs-boot files.-              -- The result should be acyclic, if it's not, then there's an unresolved cycle in the graph.-              mresolved_cycle = collapseSCC (topSortWithBoot nodes)-          in acyclic ++ [maybe (UnresolvedCycle nodes) ResolvedCycle mresolved_cycle] ++ toBuildPlan sccs []--        (mg, lookup_node) = moduleGraphNodes False (mgModSummaries' mod_graph)-        trans_deps_map = allReachable mg (mkNodeKey . node_payload)-        -- Compute the intermediate modules between a file and its hs-boot file.-        -- See Step 2a in Note [Upsweep]-        boot_path mn uid =-          map (summaryNodeSummary . expectJust "toNode" . lookup_node) $ Set.toList $-          -- Don't include the boot module itself-          Set.delete (NodeKey_Module (key IsBoot))  $-          -- Keep intermediate dependencies: as per Step 2a in Note [Upsweep], these are-          -- the transitive dependencies of the non-boot file which transitively depend-          -- on the boot file.-          Set.filter (\nk -> nodeKeyUnitId nk == uid  -- Cheap test-                              && (NodeKey_Module (key IsBoot)) `Set.member` expectJust "dep_on_boot" (M.lookup nk trans_deps_map)) $-          expectJust "not_boot_dep" (M.lookup (NodeKey_Module (key NotBoot)) trans_deps_map)-          where-            key ib = ModNodeKeyWithUid (GWIB mn ib) uid---        -- An environment mapping a module to its hs-boot file and all nodes on the path between the two, if one exists-        boot_modules = mkModuleEnv-          [ (ms_mod ms, (m, boot_path (ms_mod_name ms) (ms_unitid ms))) | m@(ModuleNode _ ms) <- (mgModSummaries' mod_graph), isBootSummary ms == IsBoot]--        select_boot_modules :: [ModuleGraphNode] -> [ModuleGraphNode]-        select_boot_modules = mapMaybe (fmap fst . get_boot_module)--        get_boot_module :: (ModuleGraphNode -> Maybe (ModuleGraphNode, [ModuleGraphNode]))-        get_boot_module m = case m of ModuleNode _ ms | HsSrcFile <- ms_hsc_src ms -> lookupModuleEnv boot_modules (ms_mod ms); _ -> Nothing--        -- Any cycles should be resolved now-        collapseSCC :: [SCC ModuleGraphNode] -> Maybe [(Either ModuleGraphNode ModuleGraphNodeWithBootFile)]-        -- Must be at least two nodes, as we were in a cycle-        collapseSCC [AcyclicSCC node1, AcyclicSCC node2] = Just [toNodeWithBoot node1, toNodeWithBoot node2]-        collapseSCC (AcyclicSCC node : nodes) = (toNodeWithBoot node :) <$> collapseSCC nodes-        -- Cyclic-        collapseSCC _ = Nothing--        toNodeWithBoot :: (ModuleGraphNode -> Either ModuleGraphNode ModuleGraphNodeWithBootFile)-        toNodeWithBoot mn =-          case get_boot_module mn of-            -- The node doesn't have a boot file-            Nothing -> Left mn-            -- The node does have a boot file-            Just path -> Right (ModuleGraphNodeWithBootFile mn (snd path))--        -- The toposort and accumulation of acyclic modules is solely to pick-up-        -- hs-boot files which are **not** part of cycles.-        collapseAcyclic :: [SCC ModuleGraphNode] -> [BuildPlan]-        collapseAcyclic (AcyclicSCC node : nodes) = SingleModule node : collapseAcyclic nodes-        collapseAcyclic (CyclicSCC cy_nodes : nodes) = (UnresolvedCycle cy_nodes) : collapseAcyclic nodes-        collapseAcyclic [] = []--        topSortWithBoot nodes = topSortModules False (select_boot_modules nodes ++ nodes) Nothing---  in--    assertPpr (sum (map countMods build_plan) == length (mgModSummaries' mod_graph))-              (vcat [text "Build plan missing nodes:", (text "PLAN:" <+> ppr (sum (map countMods build_plan))), (text "GRAPH:" <+> ppr (length (mgModSummaries' mod_graph )))])-              build_plan---- | Generalized version of 'load' which also supports a custom--- 'Messager' (for reporting progress) and 'ModuleGraph' (generally--- produced by calling 'depanal'.-load' :: GhcMonad m => Maybe ModIfaceCache -> LoadHowMuch -> Maybe Messager -> ModuleGraph -> m SuccessFlag-load' mhmi_cache how_much mHscMessage mod_graph = do-    modifySession $ \hsc_env -> hsc_env { hsc_mod_graph = mod_graph }-    guessOutputFile-    hsc_env <- getSession--    let dflags = hsc_dflags hsc_env-    let logger = hsc_logger hsc_env-    let interp = hscInterp hsc_env--    -- The "bad" boot modules are the ones for which we have-    -- B.hs-boot in the module graph, but no B.hs-    -- The downsweep should have ensured this does not happen-    -- (see msDeps)-    let all_home_mods =-          Set.fromList [ Module (ms_unitid s) (ms_mod_name s)-                    | s <- mgModSummaries mod_graph, isBootSummary s == NotBoot]-    -- TODO: Figure out what the correct form of this assert is. It's violated-    -- when you have HsBootMerge nodes in the graph: then you'll have hs-boot-    -- files without corresponding hs files.-    --  bad_boot_mods = [s        | s <- mod_graph, isBootSummary s,-    --                              not (ms_mod_name s `elem` all_home_mods)]-    -- assert (null bad_boot_mods ) return ()--    -- check that the module given in HowMuch actually exists, otherwise-    -- topSortModuleGraph will bomb later.-    let checkHowMuch (LoadUpTo m)           = checkMod m-        checkHowMuch (LoadDependenciesOf m) = checkMod m-        checkHowMuch _ = id--        checkMod m and_then-            | m `Set.member` all_home_mods = and_then-            | otherwise = do-                    liftIO $ errorMsg logger-                        (text "no such module:" <+> quotes (ppr (moduleUnit m) <> colon <> ppr (moduleName m)))-                    return Failed--    checkHowMuch how_much $ do--    -- mg2_with_srcimps drops the hi-boot nodes, returning a-    -- graph with cycles. It is just used for warning about unecessary source imports.-    let mg2_with_srcimps :: [SCC ModuleGraphNode]-        mg2_with_srcimps = topSortModuleGraph True mod_graph Nothing--    -- If we can determine that any of the {-# SOURCE #-} imports-    -- are definitely unnecessary, then emit a warning.-    warnUnnecessarySourceImports (filterToposortToModules mg2_with_srcimps)--    let maybe_top_mod = case how_much of-                          LoadUpTo m           -> Just m-                          LoadDependenciesOf m -> Just m-                          _                    -> Nothing--        build_plan = createBuildPlan mod_graph maybe_top_mod---    cache <- liftIO $ maybe (return []) iface_clearCache mhmi_cache-    let-        -- prune the HPT so everything is not retained when doing an-        -- upsweep.-        !pruned_cache = pruneCache cache-                            (flattenSCCs (filterToposortToModules  mg2_with_srcimps))---    -- before we unload anything, make sure we don't leave an old-    -- interactive context around pointing to dead bindings.  Also,-    -- write an empty HPT to allow the old HPT to be GC'd.--    let pruneHomeUnitEnv hme = hme { homeUnitEnv_hpt = emptyHomePackageTable }-    setSession $ discardIC $ hscUpdateHUG (unitEnv_map pruneHomeUnitEnv) hsc_env--    -- Unload everything-    liftIO $ unload interp hsc_env--    liftIO $ debugTraceMsg logger 2 (hang (text "Ready for upsweep")-                                    2 (ppr build_plan))--    n_jobs <- case parMakeCount (hsc_dflags hsc_env) of-                    Nothing -> liftIO getNumProcessors-                    Just n  -> return n--    setSession $ hscUpdateHUG (unitEnv_map pruneHomeUnitEnv) hsc_env-    hsc_env <- getSession-    (upsweep_ok, hsc_env1) <- withDeferredDiagnostics $-      liftIO $ upsweep n_jobs hsc_env mhmi_cache mHscMessage (toCache pruned_cache) build_plan-    setSession hsc_env1-    case upsweep_ok of-      Failed -> loadFinish upsweep_ok-      Succeeded -> do-          liftIO $ debugTraceMsg logger 2 (text "Upsweep completely successful.")-          -- Clean up after ourselves-          liftIO $ cleanCurrentModuleTempFilesMaybe logger (hsc_tmpfs hsc_env1) dflags-          loadFinish upsweep_ok------ | Finish up after a load.-loadFinish :: GhcMonad m => SuccessFlag -> m SuccessFlag--- Empty the interactive context and set the module context to the topmost--- newly loaded module, or the Prelude if none were loaded.-loadFinish all_ok-  = do modifySession discardIC-       return all_ok----- | If there is no -o option, guess the name of target executable--- by using top-level source file name as a base.-guessOutputFile :: GhcMonad m => m ()-guessOutputFile = modifySession $ \env ->-    -- Force mod_graph to avoid leaking env-    let !mod_graph = hsc_mod_graph env-        new_home_graph =-          flip unitEnv_map (hsc_HUG env) $ \hue ->-            let dflags = homeUnitEnv_dflags hue-                platform = targetPlatform dflags-                mainModuleSrcPath :: Maybe String-                mainModuleSrcPath = do-                  ms <- mgLookupModule mod_graph (mainModIs hue)-                  ml_hs_file (ms_location ms)-                name = fmap dropExtension mainModuleSrcPath--                -- MP: This exception is quite sensitive to being forced, if you-                -- force it here then the error message is different because it gets-                -- caught by a different error handler than the test (T9930fail) expects.-                -- Putting an exception into DynFlags is probably not a great design but-                -- I'll write this comment rather than more eagerly force the exception.-                name_exe = do-                  -- we must add the .exe extension unconditionally here, otherwise-                  -- when name has an extension of its own, the .exe extension will-                 -- not be added by GHC.Driver.Pipeline.exeFileName.  See #2248-                 !name' <- if platformOS platform == OSMinGW32-                           then fmap (<.> "exe") name-                           else name-                 mainModuleSrcPath' <- mainModuleSrcPath-                 -- #9930: don't clobber input files (unless they ask for it)-                 if name' == mainModuleSrcPath'-                   then throwGhcException . UsageError $-                        "default output name would overwrite the input file; " ++-                        "must specify -o explicitly"-                   else Just name'-            in-              case outputFile_ dflags of-                Just _ -> hue-                Nothing -> hue {homeUnitEnv_dflags = dflags { outputFile_ = name_exe } }-    in env { hsc_unit_env = (hsc_unit_env env) { ue_home_unit_graph = new_home_graph } }---- ----------------------------------------------------------------------------------- | Prune the HomePackageTable------ Before doing an upsweep, we can throw away:------   - all ModDetails, all linked code---   - all unlinked code that is out of date with respect to---     the source file------ This is VERY IMPORTANT otherwise we'll end up requiring 2x the--- space at the end of the upsweep, because the topmost ModDetails of the--- old HPT holds on to the entire type environment from the previous--- compilation.--- Note [GHC Heap Invariants]-pruneCache :: [CachedIface]-                      -> [ModSummary]-                      -> [HomeModInfo]-pruneCache hpt summ-  = strictMap prune hpt-  where prune (CachedIface { cached_modiface = iface-                           , cached_linkable = linkable-                           }) = HomeModInfo iface emptyModDetails linkable'-          where-           modl = moduleName (mi_module iface)-           linkable'-                | Just ms <- lookupUFM ms_map modl-                , mi_src_hash iface /= ms_hs_hash ms-                = Nothing-                | otherwise-                = linkable--        ms_map = listToUFM [(ms_mod_name ms, ms) | ms <- summ]---- --------------------------------------------------------------------------------- | Unloading-unload :: Interp -> HscEnv -> IO ()-unload interp hsc_env-  = case ghcLink (hsc_dflags hsc_env) of-        LinkInMemory -> Linker.unload interp hsc_env []-        _other -> return ()---{- Parallel Upsweep--The parallel upsweep attempts to concurrently compile the modules in the-compilation graph using multiple Haskell threads.--The Algorithm--* The list of `MakeAction`s are created by `interpretBuildPlan`. A `MakeAction` is-a pair of an `IO a` action and a `MVar a`, where to place the result.-  The list is sorted topologically, so can be executed in order without fear of-  blocking.-* runPipelines takes this list and eventually passes it to runLoop which executes-  each action and places the result into the right MVar.-* The amount of parrelism is controlled by a semaphore. This is just used around the-  module compilation step, so that only the right number of modules are compiled at-  the same time which reduces overal memory usage and allocations.-* Each proper node has a LogQueue, which dictates where to send it's output.-* The LogQueue is placed into the LogQueueQueue when the action starts and a worker-  thread processes the LogQueueQueue printing logs for each module in a stable order.-* The result variable for an action producing `a` is of type `Maybe a`, therefore-  it is still filled on a failure. If a module fails to compile, the-  failure is propagated through the whole module graph and any modules which didn't-  depend on the failure can still be compiled. This behaviour also makes the code-  quite a bit cleaner.--}---{---Note [--make mode]-~~~~~~~~~~~~~~~~~-There are two main parts to `--make` mode.--1. `downsweep`: Starts from the top of the module graph and computes dependencies.-2. `upsweep`: Starts from the bottom of the module graph and compiles modules.--The result of the downsweep is a 'ModuleGraph', which is then passed to 'upsweep' which-computers how to build this ModuleGraph.--Note [Upsweep]-~~~~~~~~~~~~~~-Upsweep takes a 'ModuleGraph' as input, computes a build plan and then executes-the plan in order to compile the project.--The first step is computing the build plan from a 'ModuleGraph'.--The output of this step is a `[BuildPlan]`, which is a topologically sorted plan for-how to build all the modules.--```-data BuildPlan = SingleModule ModuleGraphNode  -- A simple, single module all alone but *might* have an hs-boot file which isn't part of a cycle-               | ResolvedCycle [Either ModuleGraphNode ModuleGraphNodeWithBoot]   -- A resolved cycle, linearised by hs-boot files-               | UnresolvedCycle [ModuleGraphNode] -- An actual cycle, which wasn't resolved by hs-boot files-```--The plan is computed in two steps:--Step 1:  Topologically sort the module graph without hs-boot files. This returns a [SCC ModuleGraphNode] which contains-         cycles.-Step 2:  For each cycle, topologically sort the modules in the cycle *with* the relevant hs-boot files. This should-         result in an acyclic build plan if the hs-boot files are sufficient to resolve the cycle.-Step 2a: For each module in the cycle, if the module has a boot file then compute the-         modules on the path between it and the hs-boot file.-         These are the intermediate modules which:-            (1) are (transitive) dependencies of the non-boot module, and-            (2) have the boot module as a (transitive) dependency.-         In particular, all such intermediate modules must appear in the same unit as-         the module under consideration, as module cycles cannot cross unit boundaries.-         This information is stored in ModuleGraphNodeWithBoot.--The `[BuildPlan]` is then interpreted by the `interpretBuildPlan` function.--* SingleModule nodes are compiled normally by either the upsweep_inst or upsweep_mod functions.-* ResolvedCycles need to compiled "together" so that modules outside the cycle are presented-  with a consistent knot-tied version of modules at the end.-    - When the ModuleGraphNodeWithBoot nodes are compiled then suitable rehydration-      is performed both before and after the module in question is compiled.-      See Note [Hydrating Modules] for more information.-* UnresolvedCycles are indicative of a proper cycle, unresolved by hs-boot files-  and are reported as an error to the user.--The main trickiness of `interpretBuildPlan` is deciding which version of a dependency-is visible from each module. For modules which are not in a cycle, there is just-one version of a module, so that is always used. For modules in a cycle, there are two versions of-'HomeModInfo'.--1. Internal to loop: The version created whilst compiling the loop by upsweep_mod.-2. External to loop: The knot-tied version created by typecheckLoop.--Whilst compiling a module inside the loop, we need to use the (1). For a module which-is outside of the loop which depends on something from in the loop, the (2) version-is used.--As the plan is interpreted, which version of a HomeModInfo is visible is updated-by updating a map held in a state monad. So after a loop has finished being compiled,-the visible module is the one created by typecheckLoop and the internal version is not-used again.--This plan also ensures the most important invariant to do with module loops:--> If you depend on anything within a module loop, before you can use the dependency,-  the whole loop has to finish compiling.--The end result of `interpretBuildPlan` is a `[MakeAction]`, which are pairs-of `IO a` actions and a `MVar (Maybe a)`, somewhere to put the result of running-the action. This list is topologically sorted, so can be run in order to compute-the whole graph.--As well as this `interpretBuildPlan` also outputs an `IO [Maybe (Maybe HomeModInfo)]` which-can be queried at the end to get the result of all modules at the end, with their proper-visibility. For example, if any module in a loop fails then all modules in that loop will-report as failed because the visible node at the end will be the result of checking-these modules together.---}---- | Simple wrapper around MVar which allows a functor instance.-data ResultVar b = forall a . ResultVar (a -> b) (MVar (Maybe a))--instance Functor ResultVar where-  fmap f (ResultVar g var) = ResultVar (f . g) var--mkResultVar :: MVar (Maybe a) -> ResultVar a-mkResultVar = ResultVar id---- | Block until the result is ready.-waitResult :: ResultVar a -> MaybeT IO a-waitResult (ResultVar f var) = MaybeT (fmap f <$> readMVar var)---data BuildLoopState = BuildLoopState { buildDep :: M.Map NodeKey (SDoc, ResultVar (Maybe HomeModInfo))-                                          -- The current way to build a specific TNodeKey, without cycles this just points to-                                          -- the appropiate result of compiling a module  but with-                                          -- cycles there can be additional indirection and can point to the result of typechecking a loop-                                     , nNODE :: Int-                                     , hug_var :: MVar HomeUnitGraph-                                     -- A global variable which is incrementally updated with the result-                                     -- of compiling modules.-                                     }--nodeId :: BuildM Int-nodeId = do-  n <- gets nNODE-  modify (\m -> m { nNODE = n + 1 })-  return n--setModulePipeline :: NodeKey -> SDoc -> ResultVar (Maybe HomeModInfo) -> BuildM ()-setModulePipeline mgn doc wrapped_pipeline = do-  modify (\m -> m { buildDep = M.insert mgn (doc, wrapped_pipeline) (buildDep m) })--getBuildMap :: BuildM (M.Map-                    NodeKey (SDoc, ResultVar (Maybe HomeModInfo)))-getBuildMap = gets buildDep--type BuildM a = StateT BuildLoopState IO a----- | Abstraction over the operations of a semaphore which allows usage with the---  -j1 case-data AbstractSem = AbstractSem { acquireSem :: IO ()-                               , releaseSem :: IO () }--withAbstractSem :: AbstractSem -> IO b -> IO b-withAbstractSem sem = MC.bracket_ (acquireSem sem) (releaseSem sem)---- | Environment used when compiling a module-data MakeEnv = MakeEnv { hsc_env :: !HscEnv -- The basic HscEnv which will be augmented for each module-                       , compile_sem :: !AbstractSem-                       -- Modify the environment for module k, with the supplied logger modification function.-                       -- For -j1, this wrapper doesn't do anything-                       -- For -jn, the wrapper initialised a log queue and then modifies the logger to pipe its output-                       --          into the log queue.-                       , withLogger :: forall a . Int -> ((Logger -> Logger) -> IO a) -> IO a-                       , env_messager :: !(Maybe Messager)-                       }--type RunMakeM a = ReaderT MakeEnv (MaybeT IO) a---- | Given the build plan, creates a graph which indicates where each NodeKey should--- get its direct dependencies from. This might not be the corresponding build action--- if the module participates in a loop. This step also labels each node with a number for the output.--- See Note [Upsweep] for a high-level description.-interpretBuildPlan :: HomeUnitGraph-                   -> Maybe ModIfaceCache-                   -> M.Map ModNodeKeyWithUid HomeModInfo-                   -> [BuildPlan]-                   -> IO ( Maybe [ModuleGraphNode] -- Is there an unresolved cycle-                         , [MakeAction] -- Actions we need to run in order to build everything-                         , IO [Maybe (Maybe HomeModInfo)]) -- An action to query to get all the built modules at the end.-interpretBuildPlan hug mhmi_cache old_hpt plan = do-  hug_var <- newMVar hug-  ((mcycle, plans), build_map) <- runStateT (buildLoop plan) (BuildLoopState M.empty 1 hug_var)-  let wait = collect_results (buildDep build_map)-  return (mcycle, plans, wait)--  where-    collect_results build_map =-      sequence (map (\(_doc, res_var) -> collect_result res_var) (M.elems build_map))-      where-        collect_result res_var = runMaybeT (waitResult res_var)--    n_mods = sum (map countMods plan)--    buildLoop :: [BuildPlan]-              -> BuildM (Maybe [ModuleGraphNode], [MakeAction])-    -- Build the abstract pipeline which we can execute-    -- Building finished-    buildLoop []           = return (Nothing, [])-    buildLoop (plan:plans) =-      case plan of-        -- If there was no cycle, then typecheckLoop is not necessary-        SingleModule m -> do-          (one_plan, _) <- buildSingleModule Nothing m-          (cycle, all_plans) <- buildLoop plans-          return (cycle, one_plan : all_plans)--        -- For a resolved cycle, depend on everything in the loop, then update-        -- the cache to point to this node rather than directly to the module build-        -- nodes-        ResolvedCycle ms -> do-          pipes <- buildModuleLoop ms-          (cycle, graph) <- buildLoop plans-          return (cycle, pipes ++ graph)--        -- Can't continue past this point as the cycle is unresolved.-        UnresolvedCycle ns -> return (Just ns, [])--    buildSingleModule :: Maybe [ModuleGraphNode]  -- Modules we need to rehydrate before compiling this module-                      -> ModuleGraphNode          -- The node we are compiling-                      -> BuildM (MakeAction, ResultVar (Maybe HomeModInfo))-    buildSingleModule rehydrate_nodes mod = do-      mod_idx <- nodeId-      home_mod_map <- getBuildMap-      hug_var <- gets hug_var-      -- 1. Get the transitive dependencies of this module, by looking up in the dependency map-      let direct_deps = nodeDependencies False mod-          doc_build_deps = map (expectJust "dep_map" . flip M.lookup home_mod_map) direct_deps-          build_deps = map snd doc_build_deps-      -- 2. Set the default way to build this node, not in a loop here-      let build_action = withCurrentUnit (moduleGraphNodeUnitId mod) $-            case mod of-              InstantiationNode uid iu ->-                const Nothing <$> executeInstantiationNode mod_idx n_mods (wait_deps_hug hug_var build_deps) uid iu-              ModuleNode _build_deps ms -> do-                  let !old_hmi = M.lookup (msKey ms) old_hpt-                      rehydrate_mods = mapMaybe moduleGraphNodeModule <$> rehydrate_nodes-                  hmi <- executeCompileNode mod_idx n_mods old_hmi (wait_deps_hug hug_var build_deps) rehydrate_mods ms--                  -- Write the HMI to an external cache (if one exists)-                  -- See Note [Caching HomeModInfo]-                  liftIO $ forM mhmi_cache $ \hmi_cache -> addHmiToCache hmi_cache hmi-                  -- This global MVar is incrementally modified in order to avoid having to-                  -- recreate the HPT before compiling each module which leads to a quadratic amount of work.-                  hsc_env <- asks hsc_env-                  hmi' <- liftIO $ modifyMVar hug_var (\hug -> do-                    let new_hpt = addHomeModInfoToHug hmi hug-                        new_hsc = setHUG new_hpt hsc_env-                    maybeRehydrateAfter hmi new_hsc rehydrate_mods-                      )-                  return (Just hmi')-              LinkNode _nks uid -> do-                  executeLinkNode (wait_deps_hug hug_var build_deps) (mod_idx, n_mods) uid direct_deps-                  return Nothing---      res_var <- liftIO newEmptyMVar-      let result_var = mkResultVar res_var-      setModulePipeline (mkNodeKey mod) (text "N") result_var-      return $ (MakeAction build_action res_var, result_var)---    buildOneLoopyModule ::  ModuleGraphNodeWithBootFile -> BuildM (MakeAction, (ResultVar (Maybe HomeModInfo)))-    buildOneLoopyModule (ModuleGraphNodeWithBootFile mn deps) =-      buildSingleModule (Just deps) mn--    buildModuleLoop :: [Either ModuleGraphNode ModuleGraphNodeWithBootFile] ->  BuildM [MakeAction]-    buildModuleLoop ms = do-      (build_modules, wait_modules) <- mapAndUnzipM (either (buildSingleModule Nothing) buildOneLoopyModule) ms-      res_var <- liftIO newEmptyMVar-      let loop_action = wait_deps wait_modules-      let fanout i = Just . (!! i) <$> mkResultVar res_var-      -- From outside the module loop, anyone must wait for the loop to finish and then-      -- use the result of the rehydrated iface. This makes sure that things not in the-      -- module loop will see the updated interfaces for all the identifiers in the loop.-      let update_module_pipeline (m, i) = setModulePipeline (NodeKey_Module m) (text "T") (fanout i)--      let ms_i = zip (mapMaybe (fmap msKey . moduleGraphNodeModSum . either id getNode) ms) [0..]-      mapM update_module_pipeline ms_i-      return $ build_modules ++ [MakeAction loop_action res_var]---withCurrentUnit :: UnitId -> RunMakeM a -> RunMakeM a-withCurrentUnit uid = do-  local (\env -> env { hsc_env = hscSetActiveUnitId uid (hsc_env env)})---upsweep-    :: Int -- ^ The number of workers we wish to run in parallel-    -> HscEnv -- ^ The base HscEnv, which is augmented for each module-    -> Maybe ModIfaceCache -- ^ A cache to incrementally write final interface files to-    -> Maybe Messager-    -> M.Map ModNodeKeyWithUid HomeModInfo-    -> [BuildPlan]-    -> IO (SuccessFlag, HscEnv)-upsweep n_jobs hsc_env hmi_cache mHscMessage old_hpt build_plan = do-    (cycle, pipelines, collect_result) <- interpretBuildPlan (hsc_HUG hsc_env) hmi_cache old_hpt build_plan-    runPipelines n_jobs hsc_env mHscMessage pipelines-    res <- collect_result--    let completed = [m | Just (Just m) <- res]-    let hsc_env' = addDepsToHscEnv completed hsc_env--    -- Handle any cycle in the original compilation graph and return the result-    -- of the upsweep.-    case cycle of-        Just mss -> do-          let logger = hsc_logger hsc_env-          liftIO $ fatalErrorMsg logger (cyclicModuleErr mss)-          return (Failed, hsc_env)-        Nothing  -> do-          let success_flag = successIf (all isJust res)-          return (success_flag, hsc_env')--toCache :: [HomeModInfo] -> M.Map (ModNodeKeyWithUid) HomeModInfo-toCache hmis = M.fromList ([(miKey $ hm_iface hmi, hmi) | hmi <- hmis])--miKey :: ModIface -> ModNodeKeyWithUid-miKey hmi = ModNodeKeyWithUid (mi_mnwib hmi) ((toUnitId $ moduleUnit (mi_module hmi)))--upsweep_inst :: HscEnv-             -> Maybe Messager-             -> Int  -- index of module-             -> Int  -- total number of modules-             -> UnitId-             -> InstantiatedUnit-             -> IO ()-upsweep_inst hsc_env mHscMessage mod_index nmods uid iuid = do-        case mHscMessage of-            Just hscMessage -> hscMessage hsc_env (mod_index, nmods) (NeedsRecompile MustCompile) (InstantiationNode uid iuid)-            Nothing -> return ()-        runHsc hsc_env $ ioMsgMaybe $ hoistTcRnMessage $ tcRnCheckUnit hsc_env $ VirtUnit iuid-        pure ()---- | Compile a single module.  Always produce a Linkable for it if--- successful.  If no compilation happened, return the old Linkable.-upsweep_mod :: HscEnv-            -> Maybe Messager-            -> Maybe HomeModInfo-            -> ModSummary-            -> Int  -- index of module-            -> Int  -- total number of modules-            -> IO HomeModInfo-upsweep_mod hsc_env mHscMessage old_hmi summary mod_index nmods =  do-  hmi <- compileOne' mHscMessage hsc_env summary-          mod_index nmods (hm_iface <$> old_hmi) (old_hmi >>= hm_linkable)--  -- MP: This is a bit janky, because before you add the entries you have to extend the HPT with the module-  -- you just compiled. Another option, would be delay adding anything until after upsweep has finished, but I-  -- am unsure if this is sound (wrt running TH splices for example).-  -- This function only does anything if the linkable produced is a BCO, which only happens with the-  -- bytecode backend, no need to guard against the backend type additionally.-  addSptEntries (hscUpdateHPT (\hpt -> addToHpt hpt (ms_mod_name summary) hmi) hsc_env)-                (hm_linkable hmi)--  return hmi---- | Add the entries from a BCO linkable to the SPT table, see--- See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable.-addSptEntries :: HscEnv -> Maybe Linkable -> IO ()-addSptEntries hsc_env mlinkable =-  hscAddSptEntries hsc_env-     [ spt-     | Just linkable <- [mlinkable]-     , unlinked <- linkableUnlinked linkable-     , BCOs _ spts <- pure unlinked-     , spt <- spts-     ]--{- Note [-fno-code mode]-~~~~~~~~~~~~~~~~~~~~~~~~-GHC offers the flag -fno-code for the purpose of parsing and typechecking a-program without generating object files. This is intended to be used by tooling-and IDEs to provide quick feedback on any parser or type errors as cheaply as-possible.--When GHC is invoked with -fno-code no object files or linked output will be-generated. As many errors and warnings as possible will be generated, as if--fno-code had not been passed. The session DynFlags will have-backend == NoBackend.---fwrite-interface-~~~~~~~~~~~~~~~~-Whether interface files are generated in -fno-code mode is controlled by the--fwrite-interface flag. The -fwrite-interface flag is a no-op if -fno-code is-not also passed. Recompilation avoidance requires interface files, so passing--fno-code without -fwrite-interface should be avoided. If -fno-code were-re-implemented today, -fwrite-interface would be discarded and it would be-considered always on; this behaviour is as it is for backwards compatibility.--================================================================-IN SUMMARY: ALWAYS PASS -fno-code AND -fwrite-interface TOGETHER-================================================================--Template Haskell-~~~~~~~~~~~~~~~~-A module using template haskell may invoke an imported function from inside a-splice. This will cause the type-checker to attempt to execute that code, which-would fail if no object files had been generated. See #8025. To rectify this,-during the downsweep we patch the DynFlags in the ModSummary of any home module-that is imported by a module that uses template haskell, to generate object-code.--The flavour of generated object code is chosen by defaultObjectTarget for the-target platform. It would likely be faster to generate bytecode, but this is not-supported on all platforms(?Please Confirm?), and does not support the entirety-of GHC haskell. See #1257.--The object files (and interface files if -fwrite-interface is disabled) produced-for template haskell are written to temporary files.--Note that since template haskell can run arbitrary IO actions, -fno-code mode-is no more secure than running without it.--Potential TODOS:-~~~~~-* Remove -fwrite-interface and have interface files always written in -fno-code-  mode-* Both .o and .dyn_o files are generated for template haskell, but we only need-  .dyn_o. Fix it.-* In make mode, a message like-  Compiling A (A.hs, /tmp/ghc_123.o)-  is shown if downsweep enabled object code generation for A. Perhaps we should-  show "nothing" or "temporary object file" instead. Note that one-  can currently use -keep-tmp-files and inspect the generated file with the-  current behaviour.-* Offer a -no-codedir command line option, and write what were temporary-  object files there. This would speed up recompilation.-* Use existing object files (if they are up to date) instead of always-  generating temporary ones.--}---- Note [When source is considered modified]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--- A number of functions in GHC.Driver accept a SourceModified argument, which--- is part of how GHC determines whether recompilation may be avoided (see the--- definition of the SourceModified data type for details).------ Determining whether or not a source file is considered modified depends not--- only on the source file itself, but also on the output files which compiling--- that module would produce. This is done because GHC supports a number of--- flags which control which output files should be produced, e.g. -fno-code--- -fwrite-interface and -fwrite-ide-file; we must check not only whether the--- source file has been modified since the last compile, but also whether the--- source file has been modified since the last compile which produced all of--- the output files which have been requested.------ Specifically, a source file is considered unmodified if it is up-to-date--- relative to all of the output files which have been requested. Whether or--- not an output file is up-to-date depends on what kind of file it is:------ * iface (.hi) files are considered up-to-date if (and only if) their---   mi_src_hash field matches the hash of the source file,------ * all other output files (.o, .dyn_o, .hie, etc) are considered up-to-date---   if (and only if) their modification times on the filesystem are greater---   than or equal to the modification time of the corresponding .hi file.------ Why do we use '>=' rather than '>' for output files other than the .hi file?--- If the filesystem has poor resolution for timestamps (e.g. FAT32 has a--- resolution of 2 seconds), we may often find that the .hi and .o files have--- the same modification time. Using >= is slightly unsafe, but it matches--- make's behaviour.------ This strategy allows us to do the minimum work necessary in order to ensure--- that all the files the user cares about are up-to-date; e.g. we should not--- worry about .o files if the user has indicated that they are not interested--- in them via -fno-code. See also #9243.------ Note that recompilation avoidance is dependent on .hi files being produced,--- which does not happen if -fno-write-interface -fno-code is passed. That is,--- passing -fno-write-interface -fno-code means that you cannot benefit from--- recompilation avoidance. See also Note [-fno-code mode].------ The correctness of this strategy depends on an assumption that whenever we--- are producing multiple output files, the .hi file is always written first.--- If this assumption is violated, we risk recompiling unnecessarily by--- incorrectly regarding non-.hi files as outdated.------- --------------------------------------------------------------------------------- | Topological sort of the module graph-topSortModuleGraph-          :: Bool-          -- ^ Drop hi-boot nodes? (see below)-          -> ModuleGraph-          -> Maybe HomeUnitModule-             -- ^ Root module name.  If @Nothing@, use the full graph.-          -> [SCC ModuleGraphNode]--- ^ Calculate SCCs of the module graph, possibly dropping the hi-boot nodes--- The resulting list of strongly-connected-components is in topologically--- sorted order, starting with the module(s) at the bottom of the--- dependency graph (ie compile them first) and ending with the ones at--- the top.------ Drop hi-boot nodes (first boolean arg)?------ - @False@:   treat the hi-boot summaries as nodes of the graph,---              so the graph must be acyclic------ - @True@:    eliminate the hi-boot nodes, and instead pretend---              the a source-import of Foo is an import of Foo---              The resulting graph has no hi-boot nodes, but can be cyclic-topSortModuleGraph drop_hs_boot_nodes module_graph mb_root_mod =-    -- stronglyConnCompG flips the original order, so if we reverse-    -- the summaries we get a stable topological sort.-  topSortModules drop_hs_boot_nodes (reverse $ mgModSummaries' module_graph) mb_root_mod--topSortModules :: Bool -> [ModuleGraphNode] -> Maybe HomeUnitModule -> [SCC ModuleGraphNode]-topSortModules drop_hs_boot_nodes summaries mb_root_mod-  = map (fmap summaryNodeSummary) $ stronglyConnCompG initial_graph-  where-    (graph, lookup_node) =-      moduleGraphNodes drop_hs_boot_nodes summaries--    initial_graph = case mb_root_mod of-        Nothing -> graph-        Just (Module uid root_mod) ->-            -- restrict the graph to just those modules reachable from-            -- the specified module.  We do this by building a graph with-            -- the full set of nodes, and determining the reachable set from-            -- the specified node.-            let root | Just node <- lookup_node $ NodeKey_Module $ ModNodeKeyWithUid (GWIB root_mod NotBoot) uid-                     , graph `hasVertexG` node-                     = node-                     | otherwise-                     = throwGhcException (ProgramError "module does not exist")-            in graphFromEdgedVerticesUniq (seq root (reachableG graph root))--newtype ModNodeMap a = ModNodeMap { unModNodeMap :: Map.Map ModNodeKey a }-  deriving (Functor, Traversable, Foldable)--emptyModNodeMap :: ModNodeMap a-emptyModNodeMap = ModNodeMap Map.empty--modNodeMapInsert :: ModNodeKey -> a -> ModNodeMap a -> ModNodeMap a-modNodeMapInsert k v (ModNodeMap m) = ModNodeMap (Map.insert k v m)--modNodeMapElems :: ModNodeMap a -> [a]-modNodeMapElems (ModNodeMap m) = Map.elems m--modNodeMapLookup :: ModNodeKey -> ModNodeMap a -> Maybe a-modNodeMapLookup k (ModNodeMap m) = Map.lookup k m--modNodeMapSingleton :: ModNodeKey -> a -> ModNodeMap a-modNodeMapSingleton k v = ModNodeMap (M.singleton k v)--modNodeMapUnionWith :: (a -> a -> a) -> ModNodeMap a -> ModNodeMap a -> ModNodeMap a-modNodeMapUnionWith f (ModNodeMap m) (ModNodeMap n) = ModNodeMap (M.unionWith f m n)---- | If there are {-# SOURCE #-} imports between strongly connected--- components in the topological sort, then those imports can--- definitely be replaced by ordinary non-SOURCE imports: if SOURCE--- were necessary, then the edge would be part of a cycle.-warnUnnecessarySourceImports :: GhcMonad m => [SCC ModSummary] -> m ()-warnUnnecessarySourceImports sccs = do-  diag_opts <- initDiagOpts <$> getDynFlags-  when (diag_wopt Opt_WarnUnusedImports diag_opts) $ do-    let check ms =-           let mods_in_this_cycle = map ms_mod_name ms in-           [ warn i | m <- ms, i <- ms_home_srcimps m,-                      unLoc i `notElem`  mods_in_this_cycle ]--        warn :: Located ModuleName -> MsgEnvelope GhcMessage-        warn (L loc mod) = GhcDriverMessage <$> mkPlainMsgEnvelope diag_opts-                                                  loc (DriverUnnecessarySourceImports mod)-    logDiagnostics (mkMessages $ listToBag (concatMap (check . flattenSCC) sccs))----- This caches the answer to the question, if we are in this unit, what does--- an import of this module mean.-type DownsweepCache = M.Map (UnitId, PkgQual, ModuleNameWithIsBoot) [Either DriverMessages ModSummary]------------------------------------------------------------------------------------- | Downsweep (dependency analysis)------ Chase downwards from the specified root set, returning summaries--- for all home modules encountered.  Only follow source-import--- links.------ We pass in the previous collection of summaries, which is used as a--- cache to avoid recalculating a module summary if the source is--- unchanged.------ The returned list of [ModSummary] nodes has one node for each home-package--- module, plus one for any hs-boot files.  The imports of these nodes--- are all there, including the imports of non-home-package modules.-downsweep :: HscEnv-          -> [ModSummary]-          -- ^ Old summaries-          -> [ModuleName]       -- Ignore dependencies on these; treat-                                -- them as if they were package modules-          -> Bool               -- True <=> allow multiple targets to have-                                --          the same module name; this is-                                --          very useful for ghc -M-          -> IO ([DriverMessages], [ModuleGraphNode])-                -- The non-error elements of the returned list all have distinct-                -- (Modules, IsBoot) identifiers, unless the Bool is true in-                -- which case there can be repeats-downsweep hsc_env old_summaries excl_mods allow_dup_roots-   = do-       rootSummaries <- mapM getRootSummary roots-       let (root_errs, rootSummariesOk) = partitionEithers rootSummaries -- #17549-           root_map = mkRootMap rootSummariesOk-       checkDuplicates root_map-       (deps, pkg_deps, map0) <- loopSummaries rootSummariesOk (M.empty, Set.empty, root_map)-       let closure_errs = checkHomeUnitsClosed (hsc_unit_env hsc_env) (hsc_all_home_unit_ids hsc_env) (Set.toList pkg_deps)-       let unit_env = hsc_unit_env hsc_env-       let tmpfs    = hsc_tmpfs    hsc_env--       let downsweep_errs = lefts $ concat $ M.elems map0-           downsweep_nodes = M.elems deps--           (other_errs, unit_nodes) = partitionEithers $ unitEnv_foldWithKey (\nodes uid hue -> nodes ++ unitModuleNodes downsweep_nodes uid hue) [] (hsc_HUG hsc_env)-           all_nodes = downsweep_nodes ++ unit_nodes-           all_errs  = all_root_errs ++  downsweep_errs ++ other_errs-           all_root_errs =  closure_errs ++ map snd root_errs--       -- if we have been passed -fno-code, we enable code generation-       -- for dependencies of modules that have -XTemplateHaskell,-       -- otherwise those modules will fail to compile.-       -- See Note [-fno-code mode] #8025-       th_enabled_nodes <- enableCodeGenForTH logger tmpfs unit_env all_nodes-       if null all_root_errs-         then return (all_errs, th_enabled_nodes)-         else pure $ (all_root_errs, [])-     where-        -- Dependencies arising on a unit (backpack and module linking deps)-        unitModuleNodes :: [ModuleGraphNode] -> UnitId -> HomeUnitEnv -> [Either (Messages DriverMessage) ModuleGraphNode]-        unitModuleNodes summaries uid hue =-          let instantiation_nodes = instantiationNodes uid (homeUnitEnv_units hue)-          in map Right instantiation_nodes-              ++ maybeToList (linkNodes (instantiation_nodes ++ summaries) uid hue)--        calcDeps ms =-          -- Add a dependency on the HsBoot file if it exists-          -- This gets passed to the loopImports function which just ignores it if it-          -- can't be found.-          [(ms_unitid ms, NoPkgQual, GWIB (noLoc $ ms_mod_name ms) IsBoot) | NotBoot <- [isBootSummary ms] ] ++-          [(ms_unitid ms, b, c) | (b, c) <- msDeps ms ]--        logger = hsc_logger hsc_env-        roots  = hsc_targets hsc_env--        -- A cache from file paths to the already summarised modules.-        -- Reuse these if we can because the most expensive part of downsweep is-        -- reading the headers.-        old_summary_map :: M.Map FilePath ModSummary-        old_summary_map = M.fromList [(msHsFilePath ms, ms) | ms <- old_summaries]--        getRootSummary :: Target -> IO (Either (UnitId, DriverMessages) ModSummary)-        getRootSummary Target { targetId = TargetFile file mb_phase-                              , targetContents = maybe_buf-                              , targetUnitId = uid-                              }-           = do let offset_file = augmentByWorkingDirectory dflags file-                exists <- liftIO $ doesFileExist offset_file-                if exists || isJust maybe_buf-                    then first (uid,) <$>-                        summariseFile hsc_env home_unit old_summary_map offset_file mb_phase-                                       maybe_buf-                    else return $ Left $ (uid,) $ singleMessage-                                $ mkPlainErrorMsgEnvelope noSrcSpan (DriverFileNotFound offset_file)-            where-              dflags = homeUnitEnv_dflags (ue_findHomeUnitEnv uid (hsc_unit_env hsc_env))-              home_unit = ue_unitHomeUnit uid (hsc_unit_env hsc_env)-        getRootSummary Target { targetId = TargetModule modl-                              , targetContents = maybe_buf-                              , targetUnitId = uid-                              }-           = do maybe_summary <- summariseModule hsc_env home_unit old_summary_map NotBoot-                                           (L rootLoc modl) (ThisPkg (homeUnitId home_unit))-                                           maybe_buf excl_mods-                case maybe_summary of-                   FoundHome s  -> return (Right s)-                   FoundHomeWithError err -> return (Left err)-                   _ -> return $ Left $ (uid, moduleNotFoundErr modl)-            where-              home_unit = ue_unitHomeUnit uid (hsc_unit_env hsc_env)-        rootLoc = mkGeneralSrcSpan (fsLit "<command line>")--        -- In a root module, the filename is allowed to diverge from the module-        -- name, so we have to check that there aren't multiple root files-        -- defining the same module (otherwise the duplicates will be silently-        -- ignored, leading to confusing behaviour).-        checkDuplicates-          :: DownsweepCache-          -> IO ()-        checkDuplicates root_map-           | allow_dup_roots = return ()-           | null dup_roots  = return ()-           | otherwise       = liftIO $ multiRootsErr (head dup_roots)-           where-             dup_roots :: [[ModSummary]]        -- Each at least of length 2-             dup_roots = filterOut isSingleton $ map rights (M.elems root_map)--        -- This loops over all the mod summaries in the dependency graph, accumulates the actual dependencies for each module/unit-        loopSummaries :: [ModSummary]-              -> (M.Map NodeKey ModuleGraphNode, Set.Set (UnitId, UnitId),-                    DownsweepCache)-              -> IO ((M.Map NodeKey ModuleGraphNode), Set.Set (UnitId, UnitId), DownsweepCache)-        loopSummaries [] done = return done-        loopSummaries (ms:next) (done, pkgs, summarised)-          | Just {} <- M.lookup k done-          = loopSummaries next (done, pkgs, summarised)-          -- Didn't work out what the imports mean yet, now do that.-          | otherwise = do-             (final_deps, pkgs1, done', summarised') <- loopImports (calcDeps ms) done summarised-             -- This has the effect of finding a .hs file if we are looking at the .hs-boot file.-             (_, _, done'', summarised'') <- loopImports (maybeToList hs_file_for_boot) done' summarised'-             loopSummaries next (M.insert k (ModuleNode final_deps ms) done'', pkgs1 `Set.union` pkgs, summarised'')-          where-            k = NodeKey_Module (msKey ms)--            hs_file_for_boot-              | HsBootFile <- ms_hsc_src ms = Just $ ((ms_unitid ms), NoPkgQual, (GWIB (noLoc $ ms_mod_name ms) NotBoot))-              | otherwise = Nothing---        -- This loops over each import in each summary. It is mutually recursive with loopSummaries if we discover-        -- a new module by doing this.-        loopImports :: [(UnitId, PkgQual, GenWithIsBoot (Located ModuleName))]-                        -- Work list: process these modules-             -> M.Map NodeKey ModuleGraphNode-             -> DownsweepCache-                        -- Visited set; the range is a list because-                        -- the roots can have the same module names-                        -- if allow_dup_roots is True-             -> IO ([NodeKey], Set.Set (UnitId, UnitId),--                  M.Map NodeKey ModuleGraphNode, DownsweepCache)-                        -- The result is the completed NodeMap-        loopImports [] done summarised = return ([], Set.empty, done, summarised)-        loopImports ((home_uid,mb_pkg, gwib) : ss) done summarised-          | Just summs <- M.lookup cache_key summarised-          = case summs of-              [Right ms] -> do-                let nk = NodeKey_Module (msKey ms)-                (rest, pkgs, summarised', done') <- loopImports ss done summarised-                return (nk: rest, pkgs, summarised', done')-              [Left _err] ->-                loopImports ss done summarised-              _errs ->  do-                loopImports ss done summarised-          | otherwise-          = do-               mb_s <- summariseModule hsc_env home_unit old_summary_map-                                       is_boot wanted_mod mb_pkg-                                       Nothing excl_mods-               case mb_s of-                   NotThere -> loopImports ss done summarised-                   External uid -> do-                    (other_deps, pkgs, done', summarised') <- loopImports ss done summarised-                    return (other_deps, Set.insert (homeUnitId home_unit, uid) pkgs, done', summarised')-                   FoundInstantiation iud -> do-                    (other_deps, pkgs, done', summarised') <- loopImports ss done summarised-                    return (NodeKey_Unit iud : other_deps, pkgs, done', summarised')-                   FoundHomeWithError (_uid, e) ->  loopImports ss done (Map.insert cache_key [(Left e)] summarised)-                   FoundHome s -> do-                     (done', pkgs1, summarised') <--                       loopSummaries [s] (done, Set.empty, Map.insert cache_key [Right s] summarised)-                     (other_deps, pkgs2, final_done, final_summarised) <- loopImports ss done' summarised'--                     -- MP: This assumes that we can only instantiate non home units, which is probably fair enough for now.-                     return (NodeKey_Module (msKey s) : other_deps, pkgs1 `Set.union` pkgs2, final_done, final_summarised)-          where-            cache_key = (home_uid, mb_pkg, unLoc <$> gwib)-            home_unit = ue_unitHomeUnit home_uid (hsc_unit_env hsc_env)-            GWIB { gwib_mod = L loc mod, gwib_isBoot = is_boot } = gwib-            wanted_mod = L loc mod---- This function checks then important property that if both p and q are home units--- then any dependency of p, which transitively depends on q is also a home unit.-checkHomeUnitsClosed ::  UnitEnv -> Set.Set UnitId -> [(UnitId, UnitId)] -> [DriverMessages]--- Fast path, trivially closed.-checkHomeUnitsClosed ue home_id_set home_imp_ids-  | Set.size home_id_set == 1 = []-  | otherwise =-  let res = foldMap loop home_imp_ids-  -- Now check whether everything which transitively depends on a home_unit is actually a home_unit-  -- These units are the ones which we need to load as home packages but failed to do for some reason,-  -- it's a bug in the tool invoking GHC.-      bad_unit_ids = Set.difference res home_id_set-  in if Set.null bad_unit_ids-        then []-        else [singleMessage $ mkPlainErrorMsgEnvelope rootLoc $ DriverHomePackagesNotClosed (Set.toList bad_unit_ids)]--  where-    rootLoc = mkGeneralSrcSpan (fsLit "<command line>")-    -- TODO: This could repeat quite a bit of work but I struggled to write this function.-    -- Which units transitively depend on a home unit-    loop :: (UnitId, UnitId) -> Set.Set UnitId -- The units which transitively depend on a home unit-    loop (from_uid, uid) =-      let us = ue_findHomeUnitEnv from_uid ue in-      let um = unitInfoMap (homeUnitEnv_units us) in-      case Map.lookup uid um of-        Nothing -> pprPanic "uid not found" (ppr uid)-        Just ui ->-          let depends = unitDepends ui-              home_depends = Set.fromList depends `Set.intersection` home_id_set-              other_depends = Set.fromList depends `Set.difference` home_id_set-          in-            -- Case 1: The unit directly depends on a home_id-            if not (null home_depends)-              then-                let res = foldMap (loop . (from_uid,)) other_depends-                in Set.insert uid res-             -- Case 2: Check the rest of the dependencies, and then see if any of them depended on-              else-                let res = foldMap (loop . (from_uid,)) other_depends-                in-                  if not (Set.null res)-                    then Set.insert uid res-                    else res---- | Update the every ModSummary that is depended on--- by a module that needs template haskell. We enable codegen to--- the specified target, disable optimization and change the .hi--- and .o file locations to be temporary files.--- See Note [-fno-code mode]-enableCodeGenForTH-  :: Logger-  -> TmpFs-  -> UnitEnv-  -> [ModuleGraphNode]-  -> IO [ModuleGraphNode]-enableCodeGenForTH logger tmpfs unit_env =-  enableCodeGenWhen logger tmpfs TFL_CurrentModule TFL_GhcSession unit_env---- | Helper used to implement 'enableCodeGenForTH'.--- In particular, this enables--- unoptimized code generation for all modules that meet some--- condition (first parameter), or are dependencies of those--- modules. The second parameter is a condition to check before--- marking modules for code generation.-enableCodeGenWhen-  :: Logger-  -> TmpFs-  -> TempFileLifetime-  -> TempFileLifetime-  -> UnitEnv-  -> [ModuleGraphNode]-  -> IO [ModuleGraphNode]-enableCodeGenWhen logger tmpfs staticLife dynLife unit_env mod_graph =-  mapM enable_code_gen mod_graph-  where-    defaultBackendOf ms = platformDefaultBackend (targetPlatform $ ue_unitFlags (ms_unitid ms) unit_env)-    enable_code_gen :: ModuleGraphNode -> IO ModuleGraphNode-    enable_code_gen n@(ModuleNode deps ms)-      | ModSummary-        { ms_location = ms_location-        , ms_hsc_src = HsSrcFile-        , ms_hspp_opts = dflags-        } <- ms-      , mkNodeKey n `Set.member` needs_codegen_set =-      if | nocode_enable ms -> do-               let new_temp_file suf dynsuf = do-                     tn <- newTempName logger tmpfs (tmpDir dflags) staticLife suf-                     let dyn_tn = tn -<.> dynsuf-                     addFilesToClean tmpfs dynLife [dyn_tn]-                     return (tn, dyn_tn)-                 -- We don't want to create .o or .hi files unless we have been asked-                 -- to by the user. But we need them, so we patch their locations in-                 -- the ModSummary with temporary files.-                 ---               ((hi_file, dyn_hi_file), (o_file, dyn_o_file)) <--                 -- If ``-fwrite-interface` is specified, then the .o and .hi files-                 -- are written into `-odir` and `-hidir` respectively.  #16670-                 if gopt Opt_WriteInterface dflags-                   then return ((ml_hi_file ms_location, ml_dyn_hi_file ms_location)-                               , (ml_obj_file ms_location, ml_dyn_obj_file ms_location))-                   else (,) <$> (new_temp_file (hiSuf_ dflags) (dynHiSuf_ dflags))-                            <*> (new_temp_file (objectSuf_ dflags) (dynObjectSuf_ dflags))-               let ms' = ms-                     { ms_location =-                         ms_location { ml_hi_file = hi_file-                                     , ml_obj_file = o_file-                                     , ml_dyn_hi_file = dyn_hi_file-                                     , ml_dyn_obj_file = dyn_o_file }-                     , ms_hspp_opts = updOptLevel 0 $ dflags {backend = defaultBackendOf ms}-                     }-               -- Recursive call to catch the other cases-               enable_code_gen (ModuleNode deps ms')-         | dynamic_too_enable ms -> do-               let ms' = ms-                     { ms_hspp_opts = gopt_set (ms_hspp_opts ms) Opt_BuildDynamicToo-                     }-               -- Recursive call to catch the other cases-               enable_code_gen (ModuleNode deps ms')-         | ext_interp_enable ms -> do-               let ms' = ms-                     { ms_hspp_opts = gopt_set (ms_hspp_opts ms) Opt_ExternalInterpreter-                     }-               -- Recursive call to catch the other cases-               enable_code_gen (ModuleNode deps ms')--         | otherwise -> return n--    enable_code_gen ms = return ms--    nocode_enable ms@(ModSummary { ms_hspp_opts = dflags }) =-      backend dflags == NoBackend &&-      -- Don't enable codegen for TH on indefinite packages; we-      -- can't compile anything anyway! See #16219.-      isHomeUnitDefinite (ue_unitHomeUnit (ms_unitid ms) unit_env)--    -- #8180 - when using TemplateHaskell, switch on -dynamic-too so-    -- the linker can correctly load the object files.  This isn't necessary-    -- when using -fexternal-interpreter.-    dynamic_too_enable ms-      = hostIsDynamic && internalInterpreter &&-            not isDynWay && not isProfWay &&  not dyn_too_enabled-      where-       lcl_dflags   = ms_hspp_opts ms-       internalInterpreter = not (gopt Opt_ExternalInterpreter lcl_dflags)-       dyn_too_enabled =  (gopt Opt_BuildDynamicToo lcl_dflags)-       isDynWay    = hasWay (ways lcl_dflags) WayDyn-       isProfWay   = hasWay (ways lcl_dflags) WayProf--    -- #16331 - when no "internal interpreter" is available but we-    -- need to process some TemplateHaskell or QuasiQuotes, we automatically-    -- turn on -fexternal-interpreter.-    ext_interp_enable ms = not ghciSupported && internalInterpreter-      where-       lcl_dflags   = ms_hspp_opts ms-       internalInterpreter = not (gopt Opt_ExternalInterpreter lcl_dflags)-----    (mg, lookup_node) = moduleGraphNodes False mod_graph-    needs_codegen_set = Set.fromList $ map (mkNodeKey . node_payload) $ reachablesG mg (map (expectJust "needs_th" . lookup_node) has_th_set)---    has_th_set =-      [ mkNodeKey mn-      | mn@(ModuleNode _ ms) <- mod_graph-      , isTemplateHaskellOrQQNonBoot ms-      ]---- | Populate the Downsweep cache with the root modules.-mkRootMap-  :: [ModSummary]-  -> DownsweepCache-mkRootMap summaries = Map.fromListWith (flip (++))-  [ ((ms_unitid s, NoPkgQual, ms_mnwib s), [Right s]) | s <- summaries ]---------------------------------------------------------------------------------- Summarising modules---- We have two types of summarisation:------    * Summarise a file.  This is used for the root module(s) passed to---      cmLoadModules.  The file is read, and used to determine the root---      module name.  The module name may differ from the filename.------    * Summarise a module.  We are given a module name, and must provide---      a summary.  The finder is used to locate the file in which the module---      resides.--summariseFile-        :: HscEnv-        -> HomeUnit-        -> M.Map FilePath ModSummary    -- old summaries-        -> FilePath                     -- source file name-        -> Maybe Phase                  -- start phase-        -> Maybe (StringBuffer,UTCTime)-        -> IO (Either DriverMessages ModSummary)--summariseFile hsc_env' home_unit old_summaries src_fn mb_phase maybe_buf-        -- we can use a cached summary if one is available and the-        -- source file hasn't changed,  But we have to look up the summary-        -- by source file, rather than module name as we do in summarise.-   | Just old_summary <- M.lookup src_fn old_summaries-   = do-        let location = ms_location $ old_summary--        src_hash <- get_src_hash-                -- The file exists; we checked in getRootSummary above.-                -- If it gets removed subsequently, then this-                -- getFileHash may fail, but that's the right-                -- behaviour.--                -- return the cached summary if the source didn't change-        checkSummaryHash-            hsc_env (new_summary src_fn)-            old_summary location src_hash--   | otherwise-   = do src_hash <- get_src_hash-        new_summary src_fn src_hash-  where-    -- change the main active unit so all operations happen relative to the given unit-    hsc_env = hscSetActiveHomeUnit home_unit hsc_env'-    -- src_fn does not necessarily exist on the filesystem, so we need to-    -- check what kind of target we are dealing with-    get_src_hash = case maybe_buf of-                      Just (buf,_) -> return $ fingerprintStringBuffer buf-                      Nothing -> liftIO $ getFileHash src_fn--    new_summary src_fn src_hash = runExceptT $ do-        preimps@PreprocessedImports {..}-            <- getPreprocessedImports hsc_env src_fn mb_phase maybe_buf--        let fopts = initFinderOpts (hsc_dflags hsc_env)--        -- Make a ModLocation for this file-        let location = mkHomeModLocation fopts pi_mod_name src_fn--        -- Tell the Finder cache where it is, so that subsequent calls-        -- to findModule will find it, even if it's not on any search path-        mod <- liftIO $ do-          let home_unit = hsc_home_unit hsc_env-          let fc        = hsc_FC hsc_env-          addHomeModuleToFinder fc home_unit pi_mod_name location--        liftIO $ makeNewModSummary hsc_env $ MakeNewModSummary-            { nms_src_fn = src_fn-            , nms_src_hash = src_hash-            , nms_is_boot = NotBoot-            , nms_hsc_src =-                if isHaskellSigFilename src_fn-                   then HsigFile-                   else HsSrcFile-            , nms_location = location-            , nms_mod = mod-            , nms_preimps = preimps-            }--checkSummaryHash-    :: HscEnv-    -> (Fingerprint -> IO (Either e ModSummary))-    -> ModSummary -> ModLocation -> Fingerprint-    -> IO (Either e ModSummary)-checkSummaryHash-  hsc_env new_summary-  old_summary-  location src_hash-  | ms_hs_hash old_summary == src_hash &&-      not (gopt Opt_ForceRecomp (hsc_dflags hsc_env)) = do-           -- update the object-file timestamp-           obj_timestamp <- modificationTimeIfExists (ml_obj_file location)--           -- We have to repopulate the Finder's cache for file targets-           -- because the file might not even be on the regular search path-           -- and it was likely flushed in depanal. This is not technically-           -- needed when we're called from sumariseModule but it shouldn't-           -- hurt.-           -- Also, only add to finder cache for non-boot modules as the finder cache-           -- makes sure to add a boot suffix for boot files.-           _ <- do-              let fc        = hsc_FC hsc_env-              case ms_hsc_src old_summary of-                HsSrcFile -> addModuleToFinder fc (ms_mod old_summary) location-                _ -> return ()--           hi_timestamp <- modificationTimeIfExists (ml_hi_file location)-           hie_timestamp <- modificationTimeIfExists (ml_hie_file location)--           return $ Right-             ( old_summary-                     { ms_obj_date = obj_timestamp-                     , ms_iface_date = hi_timestamp-                     , ms_hie_date = hie_timestamp-                     }-             )--   | otherwise =-           -- source changed: re-summarise.-           new_summary src_hash--data SummariseResult =-        FoundInstantiation InstantiatedUnit-      | FoundHomeWithError (UnitId, DriverMessages)-      | FoundHome ModSummary-      | External UnitId-      | NotThere---- Summarise a module, and pick up source and timestamp.-summariseModule-          :: HscEnv-          -> HomeUnit-          -> M.Map FilePath ModSummary-          -- ^ Map of old summaries-          -> IsBootInterface    -- True <=> a {-# SOURCE #-} import-          -> Located ModuleName -- Imported module to be summarised-          -> PkgQual-          -> Maybe (StringBuffer, UTCTime)-          -> [ModuleName]               -- Modules to exclude-          -> IO SummariseResult---summariseModule hsc_env' home_unit old_summary_map is_boot (L _ wanted_mod) mb_pkg-                maybe_buf excl_mods-  | wanted_mod `elem` excl_mods-  = return NotThere-  | otherwise  = find_it-  where-    -- Temporarily change the currently active home unit so all operations-    -- happen relative to it-    hsc_env   = hscSetActiveHomeUnit home_unit hsc_env'-    dflags    = hsc_dflags hsc_env--    find_it :: IO SummariseResult--    find_it = do-        found <- findImportedModule hsc_env wanted_mod mb_pkg-        case found of-             Found location mod-                | isJust (ml_hs_file location) ->-                        -- Home package-                         just_found location mod-                | VirtUnit iud <- moduleUnit mod-                , not (isHomeModule home_unit mod)-                  -> return $ FoundInstantiation iud-                | otherwise -> return $ External (moduleUnitId mod)-             _ -> return NotThere-                        -- Not found-                        -- (If it is TRULY not found at all, we'll-                        -- error when we actually try to compile)--    just_found location mod = do-                -- Adjust location to point to the hs-boot source file,-                -- hi file, object file, when is_boot says so-        let location' = case is_boot of-              IsBoot -> addBootSuffixLocn location-              NotBoot -> location-            src_fn = expectJust "summarise2" (ml_hs_file location')--                -- Check that it exists-                -- It might have been deleted since the Finder last found it-        maybe_h <- fileHashIfExists src_fn-        case maybe_h of-          -- This situation can also happen if we have found the .hs file but the-          -- .hs-boot file doesn't exist.-          Nothing -> return NotThere-          Just h  -> do-            fresult <- new_summary_cache_check location' mod src_fn h-            return $ case fresult of-              Left err -> FoundHomeWithError (moduleUnitId mod, err)-              Right ms -> FoundHome ms--    new_summary_cache_check loc mod src_fn h-      | Just old_summary <- Map.lookup src_fn old_summary_map =--         -- check the hash on the source file, and-         -- return the cached summary if it hasn't changed.  If the-         -- file has changed then need to resummarise.-        case maybe_buf of-           Just (buf,_) ->-               checkSummaryHash hsc_env (new_summary loc mod src_fn) old_summary loc (fingerprintStringBuffer buf)-           Nothing    ->-               checkSummaryHash hsc_env (new_summary loc mod src_fn) old_summary loc h-      | otherwise = new_summary loc mod src_fn h--    new_summary :: ModLocation-                  -> Module-                  -> FilePath-                  -> Fingerprint-                  -> IO (Either DriverMessages ModSummary)-    new_summary location mod src_fn src_hash-      = runExceptT $ do-        preimps@PreprocessedImports {..}-            -- Remember to set the active unit here, otherwise the wrong include paths are passed to CPP-            -- See multiHomeUnits_cpp2 test-            <- getPreprocessedImports (hscSetActiveUnitId (moduleUnitId mod) hsc_env) src_fn Nothing maybe_buf--        -- NB: Despite the fact that is_boot is a top-level parameter, we-        -- don't actually know coming into this function what the HscSource-        -- of the module in question is.  This is because we may be processing-        -- this module because another module in the graph imported it: in this-        -- case, we know if it's a boot or not because of the {-# SOURCE #-}-        -- annotation, but we don't know if it's a signature or a regular-        -- module until we actually look it up on the filesystem.-        let hsc_src-              | is_boot == IsBoot = HsBootFile-              | isHaskellSigFilename src_fn = HsigFile-              | otherwise = HsSrcFile--        when (pi_mod_name /= wanted_mod) $-                throwE $ singleMessage $ mkPlainErrorMsgEnvelope pi_mod_name_loc-                       $ DriverFileModuleNameMismatch pi_mod_name wanted_mod--        let instantiations = homeUnitInstantiations home_unit-        when (hsc_src == HsigFile && isNothing (lookup pi_mod_name instantiations)) $-            throwE $ singleMessage $ mkPlainErrorMsgEnvelope pi_mod_name_loc-                   $ DriverUnexpectedSignature pi_mod_name (checkBuildingCabalPackage dflags) instantiations--        liftIO $ makeNewModSummary hsc_env $ MakeNewModSummary-            { nms_src_fn = src_fn-            , nms_src_hash = src_hash-            , nms_is_boot = is_boot-            , nms_hsc_src = hsc_src-            , nms_location = location-            , nms_mod = mod-            , nms_preimps = preimps-            }---- | Convenience named arguments for 'makeNewModSummary' only used to make--- code more readable, not exported.-data MakeNewModSummary-  = MakeNewModSummary-      { nms_src_fn :: FilePath-      , nms_src_hash :: Fingerprint-      , nms_is_boot :: IsBootInterface-      , nms_hsc_src :: HscSource-      , nms_location :: ModLocation-      , nms_mod :: Module-      , nms_preimps :: PreprocessedImports-      }--makeNewModSummary :: HscEnv -> MakeNewModSummary -> IO ModSummary-makeNewModSummary hsc_env MakeNewModSummary{..} = do-  let PreprocessedImports{..} = nms_preimps-  obj_timestamp <- modificationTimeIfExists (ml_obj_file nms_location)-  dyn_obj_timestamp <- modificationTimeIfExists (ml_dyn_obj_file nms_location)-  hi_timestamp <- modificationTimeIfExists (ml_hi_file nms_location)-  hie_timestamp <- modificationTimeIfExists (ml_hie_file nms_location)--  extra_sig_imports <- findExtraSigImports hsc_env nms_hsc_src pi_mod_name-  (implicit_sigs, _inst_deps) <- implicitRequirementsShallow (hscSetActiveUnitId (moduleUnitId nms_mod) hsc_env) pi_theimps--  return $-        ModSummary-        { ms_mod = nms_mod-        , ms_hsc_src = nms_hsc_src-        , ms_location = nms_location-        , ms_hspp_file = pi_hspp_fn-        , ms_hspp_opts = pi_local_dflags-        , ms_hspp_buf  = Just pi_hspp_buf-        , ms_parsed_mod = Nothing-        , ms_srcimps = pi_srcimps-        , ms_ghc_prim_import = pi_ghc_prim_import-        , ms_textual_imps =-            ((,) NoPkgQual . noLoc <$> extra_sig_imports) ++-            ((,) NoPkgQual . noLoc <$> implicit_sigs) ++-            pi_theimps-        , ms_hs_hash = nms_src_hash-        , ms_iface_date = hi_timestamp-        , ms_hie_date = hie_timestamp-        , ms_obj_date = obj_timestamp-        , ms_dyn_obj_date = dyn_obj_timestamp-        }--data PreprocessedImports-  = PreprocessedImports-      { pi_local_dflags :: DynFlags-      , pi_srcimps  :: [(PkgQual, Located ModuleName)]-      , pi_theimps  :: [(PkgQual, Located ModuleName)]-      , pi_ghc_prim_import :: Bool-      , pi_hspp_fn  :: FilePath-      , pi_hspp_buf :: StringBuffer-      , pi_mod_name_loc :: SrcSpan-      , pi_mod_name :: ModuleName-      }---- Preprocess the source file and get its imports--- The pi_local_dflags contains the OPTIONS pragmas-getPreprocessedImports-    :: HscEnv-    -> FilePath-    -> Maybe Phase-    -> Maybe (StringBuffer, UTCTime)-    -- ^ optional source code buffer and modification time-    -> ExceptT DriverMessages IO PreprocessedImports-getPreprocessedImports hsc_env src_fn mb_phase maybe_buf = do-  (pi_local_dflags, pi_hspp_fn)-      <- ExceptT $ preprocess hsc_env src_fn (fst <$> maybe_buf) mb_phase-  pi_hspp_buf <- liftIO $ hGetStringBuffer pi_hspp_fn-  (pi_srcimps', pi_theimps', pi_ghc_prim_import, L pi_mod_name_loc pi_mod_name)-      <- ExceptT $ do-          let imp_prelude = xopt LangExt.ImplicitPrelude pi_local_dflags-              popts = initParserOpts pi_local_dflags-          mimps <- getImports popts imp_prelude pi_hspp_buf pi_hspp_fn src_fn-          return (first (mkMessages . fmap mkDriverPsHeaderMessage . getMessages) mimps)-  let rn_pkg_qual = renameRawPkgQual (hsc_unit_env hsc_env)-  let rn_imps = fmap (\(pk, lmn@(L _ mn)) -> (rn_pkg_qual mn pk, lmn))-  let pi_srcimps = rn_imps pi_srcimps'-  let pi_theimps = rn_imps pi_theimps'-  return PreprocessedImports {..}-----------------------------------------------------------------------------------                      Error messages---------------------------------------------------------------------------------- Defer and group warning, error and fatal messages so they will not get lost--- in the regular output.-withDeferredDiagnostics :: GhcMonad m => m a -> m a-withDeferredDiagnostics f = do-  dflags <- getDynFlags-  if not $ gopt Opt_DeferDiagnostics dflags-  then f-  else do-    warnings <- liftIO $ newIORef []-    errors <- liftIO $ newIORef []-    fatals <- liftIO $ newIORef []-    logger <- getLogger--    let deferDiagnostics _dflags !msgClass !srcSpan !msg = do-          let action = logMsg logger msgClass srcSpan msg-          case msgClass of-            MCDiagnostic SevWarning _reason-              -> atomicModifyIORef' warnings $ \i -> (action: i, ())-            MCDiagnostic SevError _reason-              -> atomicModifyIORef' errors   $ \i -> (action: i, ())-            MCFatal-              -> atomicModifyIORef' fatals   $ \i -> (action: i, ())-            _ -> action--        printDeferredDiagnostics = liftIO $-          forM_ [warnings, errors, fatals] $ \ref -> do-            -- This IORef can leak when the dflags leaks, so let us always-            -- reset the content.-            actions <- atomicModifyIORef' ref $ \i -> ([], i)-            sequence_ $ reverse actions--    MC.bracket-      (pushLogHookM (const deferDiagnostics))-      (\_ -> popLogHookM >> printDeferredDiagnostics)-      (\_ -> f)--noModError :: HscEnv -> SrcSpan -> ModuleName -> FindResult -> MsgEnvelope GhcMessage--- ToDo: we don't have a proper line number for this error-noModError hsc_env loc wanted_mod err-  = mkPlainErrorMsgEnvelope loc $ GhcDriverMessage $ DriverUnknownMessage $ mkPlainError noHints $-    cannotFindModule hsc_env wanted_mod err--{--noHsFileErr :: SrcSpan -> String -> DriverMessages-noHsFileErr loc path-  = singleMessage $ mkPlainErrorMsgEnvelope loc (DriverFileNotFound path)-  -}--moduleNotFoundErr :: ModuleName -> DriverMessages-moduleNotFoundErr mod = singleMessage $ mkPlainErrorMsgEnvelope noSrcSpan (DriverModuleNotFound mod)--multiRootsErr :: [ModSummary] -> IO ()-multiRootsErr [] = panic "multiRootsErr"-multiRootsErr summs@(summ1:_)-  = throwOneError $ fmap GhcDriverMessage $-    mkPlainErrorMsgEnvelope noSrcSpan $ DriverDuplicatedModuleDeclaration mod files-  where-    mod = ms_mod summ1-    files = map (expectJust "checkDup" . ml_hs_file . ms_location) summs--cyclicModuleErr :: [ModuleGraphNode] -> SDoc--- From a strongly connected component we find--- a single cycle to report-cyclicModuleErr mss-  = assert (not (null mss)) $-    case findCycle graph of-       Nothing   -> text "Unexpected non-cycle" <+> ppr mss-       Just path0 -> vcat-        [ text "Module graph contains a cycle:"-        , nest 2 (show_path path0)]-  where-    graph :: [Node NodeKey ModuleGraphNode]-    graph =-      [ DigraphNode-        { node_payload = ms-        , node_key = mkNodeKey ms-        , node_dependencies = nodeDependencies False ms-        }-      | ms <- mss-      ]--    show_path :: [ModuleGraphNode] -> SDoc-    show_path []  = panic "show_path"-    show_path [m] = ppr_node m <+> text "imports itself"-    show_path (m1:m2:ms) = vcat ( nest 6 (ppr_node m1)-                                : nest 6 (text "imports" <+> ppr_node m2)-                                : go ms )-       where-         go []     = [text "which imports" <+> ppr_node m1]-         go (m:ms) = (text "which imports" <+> ppr_node m) : go ms--    ppr_node :: ModuleGraphNode -> SDoc-    ppr_node (ModuleNode _deps m) = text "module" <+> ppr_ms m-    ppr_node (InstantiationNode _uid u) = text "instantiated unit" <+> ppr u-    ppr_node (LinkNode uid _) = pprPanic "LinkNode should not be in a cycle" (ppr uid)--    ppr_ms :: ModSummary -> SDoc-    ppr_ms ms = quotes (ppr (moduleName (ms_mod ms))) <+>-                (parens (text (msHsFilePath ms)))---cleanCurrentModuleTempFilesMaybe :: MonadIO m => Logger -> TmpFs -> DynFlags -> m ()-cleanCurrentModuleTempFilesMaybe logger tmpfs dflags =-  unless (gopt Opt_KeepTmpFiles dflags) $-    liftIO $ cleanCurrentModuleTempFiles logger tmpfs---addDepsToHscEnv ::  [HomeModInfo] -> HscEnv -> HscEnv-addDepsToHscEnv deps hsc_env =-  hscUpdateHUG (\hug -> foldr addHomeModInfoToHug hug deps) hsc_env--setHPT ::  HomePackageTable -> HscEnv -> HscEnv-setHPT deps hsc_env =-  hscUpdateHPT (const $ deps) hsc_env--setHUG ::  HomeUnitGraph -> HscEnv -> HscEnv-setHUG deps hsc_env =-  hscUpdateHUG (const $ deps) hsc_env---- | Wrap an action to catch and handle exceptions.-wrapAction :: HscEnv -> IO a -> IO (Maybe a)-wrapAction hsc_env k = do-  let lcl_logger = hsc_logger hsc_env-      lcl_dynflags = hsc_dflags hsc_env-  let logg err = printMessages lcl_logger (initDiagOpts lcl_dynflags) (srcErrorMessages err)-  -- MP: It is a bit strange how prettyPrintGhcErrors handles some errors but then we handle-  -- SourceError and ThreadKilled differently directly below. TODO: Refactor to use `catches`-  -- directly. MP should probably use safeTry here to not catch async exceptions but that will regress performance due to-  -- internally using forkIO.-  mres <- MC.try $ liftIO $ prettyPrintGhcErrors lcl_logger $ k-  case mres of-    Right res -> return $ Just res-    Left exc -> do-        case fromException exc of-          Just (err :: SourceError)-            -> logg err-          Nothing -> case fromException exc of-                        -- ThreadKilled in particular needs to actually kill the thread.-                        -- So rethrow that and the other async exceptions-                        Just (err :: SomeAsyncException) -> throwIO err-                        _ -> errorMsg lcl_logger (text (show exc))-        return Nothing--withParLog :: TVar LogQueueQueue -> Int -> ((Logger -> Logger) -> IO b) -> IO b-withParLog lqq_var k cont = do-  let init_log = do-        -- Make a new log queue-        lq <- newLogQueue k-        -- Add it into the LogQueueQueue-        atomically $ initLogQueue lqq_var lq-        return lq-      finish_log lq = liftIO (finishLogQueue lq)-  MC.bracket init_log finish_log $ \lq -> cont (pushLogHook (const (parLogAction lq)))--withLoggerHsc :: Int -> MakeEnv -> (HscEnv -> IO a) -> IO a-withLoggerHsc k MakeEnv{withLogger, hsc_env} cont = do-  withLogger k $ \modifyLogger -> do-    let lcl_logger = modifyLogger (hsc_logger hsc_env)-        hsc_env' = hsc_env { hsc_logger = lcl_logger }-    -- Run continuation with modified logger-    cont hsc_env'---executeInstantiationNode :: Int-  -> Int-  -> RunMakeM HomeUnitGraph-  -> UnitId-  -> InstantiatedUnit-  -> RunMakeM ()-executeInstantiationNode k n wait_deps uid iu = do-        -- Wait for the dependencies of this node-        deps <- wait_deps-        env <- ask-        -- Output of the logger is mediated by a central worker to-        -- avoid output interleaving-        msg <- asks env_messager-        lift $ MaybeT $ withLoggerHsc k env $ \hsc_env ->-          let lcl_hsc_env = setHUG deps hsc_env-          in wrapAction lcl_hsc_env $ do-            res <- upsweep_inst lcl_hsc_env msg k n uid iu-            cleanCurrentModuleTempFilesMaybe (hsc_logger hsc_env) (hsc_tmpfs hsc_env) (hsc_dflags hsc_env)-            return res---executeCompileNode :: Int-  -> Int-  -> Maybe HomeModInfo-  -> RunMakeM HomeUnitGraph-  -> Maybe [ModuleName] -- List of modules we need to rehydrate before compiling-  -> ModSummary-  -> RunMakeM HomeModInfo-executeCompileNode k n !old_hmi wait_deps mrehydrate_mods mod = do-  me@MakeEnv{..} <- ask-  deps <- wait_deps-  -- Rehydrate any dependencies if this module had a boot file or is a signature file.-  lift $ MaybeT (withAbstractSem compile_sem $ withLoggerHsc k me $ \hsc_env -> do-     hydrated_hsc_env <- liftIO $ maybeRehydrateBefore (setHUG deps hsc_env) mod fixed_mrehydrate_mods-     let -- Use the cached DynFlags which includes OPTIONS_GHC pragmas-         lcl_dynflags = ms_hspp_opts mod-     let lcl_hsc_env =-             -- Localise the hsc_env to use the cached flags-             hscSetFlags lcl_dynflags $-             hydrated_hsc_env-     -- Compile the module, locking with a semphore to avoid too many modules-     -- being compiled at the same time leading to high memory usage.-     wrapAction lcl_hsc_env $ do-      res <- upsweep_mod lcl_hsc_env env_messager old_hmi mod k n-      cleanCurrentModuleTempFilesMaybe (hsc_logger hsc_env) (hsc_tmpfs hsc_env) lcl_dynflags-      return res)--  where-    fixed_mrehydrate_mods =-      case ms_hsc_src mod of-        -- MP: It is probably a bit of a misimplementation in backpack that-        -- compiling a signature requires an knot_var for that unit.-        -- If you remove this then a lot of backpack tests fail.-        HsigFile -> Just []-        _ -> mrehydrate_mods--{- Rehydration, see Note [Rehydrating Modules] -}--rehydrate :: HscEnv        -- ^ The HPT in this HscEnv needs rehydrating.-          -> [HomeModInfo] -- ^ These are the modules we want to rehydrate.-          -> IO HscEnv-rehydrate hsc_env hmis = do-  debugTraceMsg logger 2 $-     text "Re-hydrating loop: "-  new_mods <- fixIO $ \new_mods -> do-      let new_hpt = addListToHpt old_hpt new_mods-      let new_hsc_env = hscUpdateHPT (const new_hpt) hsc_env-      mds <- initIfaceCheck (text "rehydrate") new_hsc_env $-                mapM (typecheckIface . hm_iface) hmis-      let new_mods = [ (mn,hmi{ hm_details = details })-                     | (hmi,details) <- zip hmis mds-                     , let mn = moduleName (mi_module (hm_iface hmi)) ]-      return new_mods-  return $ setHPT (foldl' (\old (mn, hmi) -> addToHpt old mn hmi) old_hpt new_mods) hsc_env--  where-    logger  = hsc_logger hsc_env-    to_delete =  (map (moduleName . mi_module . hm_iface) hmis)-    -- Filter out old modules before tying the knot, otherwise we can end-    -- up with a thunk which keeps reference to the old HomeModInfo.-    !old_hpt = foldl' delFromHpt (hsc_HPT hsc_env) to_delete---- If needed, then rehydrate the necessary modules with a suitable KnotVars for the--- module currently being compiled.-maybeRehydrateBefore :: HscEnv -> ModSummary -> Maybe [ModuleName] -> IO HscEnv-maybeRehydrateBefore hsc_env _ Nothing = return hsc_env-maybeRehydrateBefore hsc_env mod (Just mns) = do-  knot_var <- initialise_knot_var hsc_env-  let hmis = map (expectJust "mr" . lookupHpt (hsc_HPT hsc_env)) mns-  rehydrate (hsc_env { hsc_type_env_vars = knotVarsFromModuleEnv knot_var }) hmis--  where-   initialise_knot_var hsc_env = liftIO $-    let mod_name = homeModuleInstantiation (hsc_home_unit_maybe hsc_env) (ms_mod mod)-    in mkModuleEnv . (:[]) . (mod_name,) <$> newIORef emptyTypeEnv--maybeRehydrateAfter :: HomeModInfo-  -> HscEnv-  -> Maybe [ModuleName]-  -> IO (HomeUnitGraph, HomeModInfo)-maybeRehydrateAfter hmi new_hsc Nothing = return (hsc_HUG new_hsc, hmi)-maybeRehydrateAfter hmi new_hsc (Just mns) = do-  let new_hpt = hsc_HPT new_hsc-      hmis = map (expectJust "mrAfter" . lookupHpt new_hpt) mns-      new_mod_name = moduleName (mi_module (hm_iface hmi))-  hsc_env <- rehydrate (new_hsc { hsc_type_env_vars = emptyKnotVars }) (hmi : hmis)-  return (hsc_HUG hsc_env, expectJust "rehydrate" $ lookupHpt (hsc_HPT hsc_env) new_mod_name)--{--Note [Hydrating Modules]-~~~~~~~~~~~~~~~~~~~~~~~~-There are at least 4 different representations of an interface file as described-by this diagram.---------------------------------|       On-disk M.hi         |--------------------------------    |             ^-    | Read file   | Write file-    V             |---------------------------------|      ByteString             |---------------------------------    |             ^-    | Binary.get  | Binary.put-    V             |----------------------------------|    ModIface (an acyclic AST) |----------------------------------    |           ^-    | hydrate   | mkIfaceTc-    V           |-----------------------------------|  ModDetails (lots of cycles)  |------------------------------------The last step, converting a ModIface into a ModDetails is known as "hydration".--Hydration happens in three different places--* When an interface file is initially loaded from disk, it has to be hydrated.-* When a module is finished compiling, we hydrate the ModIface in order to generate-  the version of ModDetails which exists in memory (see Note [ModDetails and --make mode])-* When dealing with boot files and module loops (see Note [Rehydrating Modules])--Note [Rehydrating Modules]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-If a module has a boot file then it is critical to rehydrate the modules on-the path between the two (see #20561).--Suppose we have ("R" for "recursive"):-```-R.hs-boot:   module R where-               data T-               g :: T -> T--A.hs:        module A( f, T, g ) where-                import {-# SOURCE #-} R-                data S = MkS T-                f :: T -> S = ...g...--R.hs:        module R where-                import A-                data T = T1 | T2 S-                g = ...f...-```--== Why we need to rehydrate A's ModIface before compiling R.hs--After compiling A.hs we'll have a TypeEnv in which the Id for `f` has a type-type uses the AbstractTyCon T; and a TyCon for `S` that also mentions that same-AbstractTyCon. (Abstract because it came from R.hs-boot; we know nothing about-it.)--When compiling R.hs, we build a TyCon for `T`.  But that TyCon mentions `S`, and-it currently has an AbstractTyCon for `T` inside it.  But we want to build a-fully cyclic structure, in which `S` refers to `T` and `T` refers to `S`.--Solution: **rehydration**.  *Before compiling `R.hs`*, rehydrate all the-ModIfaces below it that depend on R.hs-boot.  To rehydrate a ModIface, call-`typecheckIface` to convert it to a ModDetails.  It's just a de-serialisation-step, no type inference, just lookups.--Now `S` will be bound to a thunk that, when forced, will "see" the final binding-for `T`; see [Tying the knot](https://gitlab.haskell.org/ghc/ghc/-/wikis/commentary/compiler/tying-the-knot).-But note that this must be done *before* compiling R.hs.--== Why we need to rehydrate A's ModIface after compiling R.hs--When compiling R.hs, the knot-tying stuff above will ensure that `f`'s unfolding-mentions the `LocalId` for `g`.  But when we finish R, we carefully ensure that-all those `LocalIds` are turned into completed `GlobalIds`, replete with-unfoldings etc.   Alas, that will not apply to the occurrences of `g` in `f`'s-unfolding. And if we leave matters like that, they will stay that way, and *all*-subsequent modules that import A will see a crippled unfolding for `f`.--Solution: rehydrate both R and A's ModIface together, right after completing R.hs.--~~ Which modules to rehydrate--We only need rehydrate modules that are-* Below R.hs-* Above R.hs-boot--There might be many unrelated modules (in the home package) that don't need to be-rehydrated.--== Modules "above" the loop--This dark corner is the subject of #14092.--Suppose we add to our example-```-X.hs     module X where-           import A-           data XT = MkX T-           fx = ...g...-```-If in `--make` we compile R.hs-boot, then A.hs, then X.hs, we'll get a `ModDetails` for `X` that has an AbstractTyCon for `T` in the the argument type of `MkX`.  So:--* Either we should delay compiling X until after R has beeen compiled. (This is what we do)-* Or we should rehydrate X after compiling R -- because it transitively depends on R.hs-boot.--Ticket #20200 has exposed some issues to do with the knot-tying logic in GHC.Make, in `--make` mode.-#20200 has lots of issues, many of them now fixed;-this particular issue starts [here](https://gitlab.haskell.org/ghc/ghc/-/issues/20200#note_385758).--The wiki page [Tying the knot](https://gitlab.haskell.org/ghc/ghc/-/wikis/commentary/compiler/tying-the-knot) is helpful.-Also closely related are-    * #14092-    * #14103---}--executeLinkNode :: RunMakeM HomeUnitGraph -> (Int, Int) -> UnitId -> [NodeKey] -> RunMakeM ()-executeLinkNode wait_deps kn uid deps = do-  withCurrentUnit uid $ do-    MakeEnv{..} <- ask-    hug <- wait_deps-    let dflags = hsc_dflags hsc_env-    let hsc_env' = setHUG hug hsc_env-        msg' = (\messager -> \recomp -> messager hsc_env kn recomp (LinkNode deps uid)) <$> env_messager--    linkresult <- liftIO $ withAbstractSem compile_sem $ do-                            link (ghcLink dflags)-                                (hsc_logger hsc_env')-                                (hsc_tmpfs hsc_env')-                                (hsc_hooks hsc_env')-                                dflags-                                (hsc_unit_env hsc_env')-                                True -- We already decided to link-                                msg'-                                (hsc_HPT hsc_env')-    case linkresult of-      Failed -> fail "Link Failed"-      Succeeded -> return ()----- | Wait for some dependencies to finish and then read from the given MVar.-wait_deps_hug :: MVar b -> [ResultVar (Maybe HomeModInfo)] -> ReaderT MakeEnv (MaybeT IO) b-wait_deps_hug hug_var deps = do-  _ <- wait_deps deps-  liftIO $ readMVar hug_var----- | Wait for dependencies to finish, and then return their results.-wait_deps :: [ResultVar (Maybe HomeModInfo)] -> RunMakeM [HomeModInfo]-wait_deps [] = return []-wait_deps (x:xs) = do-  res <- lift $ waitResult x-  case res of-    Nothing -> wait_deps xs-    Just hmi -> (hmi:) <$> wait_deps xs----- Executing the pipelines---- | Start a thread which reads from the LogQueueQueue---label_self :: String -> IO ()-label_self thread_name = do-    self_tid <- CC.myThreadId-    CC.labelThread self_tid thread_name---runPipelines :: Int -> HscEnv -> Maybe Messager -> [MakeAction] -> IO ()--- Don't even initialise plugins if there are no pipelines-runPipelines _ _ _ [] = return ()-runPipelines n_job orig_hsc_env mHscMessager all_pipelines = do-  liftIO $ label_self "main --make thread"--  plugins_hsc_env <- initializePlugins orig_hsc_env-  case n_job of-    1 -> runSeqPipelines plugins_hsc_env mHscMessager all_pipelines-    _n -> runParPipelines n_job plugins_hsc_env mHscMessager all_pipelines--runSeqPipelines :: HscEnv -> Maybe Messager -> [MakeAction] -> IO ()-runSeqPipelines plugin_hsc_env mHscMessager all_pipelines =-  let env = MakeEnv { hsc_env = plugin_hsc_env-                    , withLogger = \_ k -> k id-                    , compile_sem = AbstractSem (return ()) (return ())-                    , env_messager = mHscMessager-                    }-  in runAllPipelines 1 env all_pipelines----- | Build and run a pipeline-runParPipelines :: Int              -- ^ How many capabilities to use-             -> HscEnv           -- ^ The basic HscEnv which is augmented with specific info for each module-             -> Maybe Messager   -- ^ Optional custom messager to use to report progress-             -> [MakeAction]  -- ^ The build plan for all the module nodes-             -> IO ()-runParPipelines n_jobs plugin_hsc_env mHscMessager all_pipelines = do---  -- A variable which we write to when an error has happened and we have to tell the-  -- logging thread to gracefully shut down.-  stopped_var <- newTVarIO False-  -- The queue of LogQueues which actions are able to write to. When an action starts it-  -- will add it's LogQueue into this queue.-  log_queue_queue_var <- newTVarIO newLogQueueQueue-  -- Thread which coordinates the printing of logs-  wait_log_thread <- logThread n_jobs (length all_pipelines) (hsc_logger plugin_hsc_env) stopped_var log_queue_queue_var---  -- Make the logger thread-safe, in case there is some output which isn't sent via the LogQueue.-  thread_safe_logger <- liftIO $ makeThreadSafe (hsc_logger plugin_hsc_env)-  let thread_safe_hsc_env = plugin_hsc_env { hsc_logger = thread_safe_logger }--  let updNumCapabilities = liftIO $ do-          n_capabilities <- getNumCapabilities-          n_cpus <- getNumProcessors-          -- Setting number of capabilities more than-          -- CPU count usually leads to high userspace-          -- lock contention. #9221-          let n_caps = min n_jobs n_cpus-          unless (n_capabilities /= 1) $ setNumCapabilities n_caps-          return n_capabilities--  let resetNumCapabilities orig_n = do-          liftIO $ setNumCapabilities orig_n-          atomically $ writeTVar stopped_var True-          wait_log_thread--  compile_sem <- newQSem n_jobs-  let abstract_sem = AbstractSem (waitQSem compile_sem) (signalQSem compile_sem)-    -- Reset the number of capabilities once the upsweep ends.-  let env = MakeEnv { hsc_env = thread_safe_hsc_env-                    , withLogger = withParLog log_queue_queue_var-                    , compile_sem = abstract_sem-                    , env_messager = mHscMessager-                    }--  MC.bracket updNumCapabilities resetNumCapabilities $ \_ ->-    runAllPipelines n_jobs env all_pipelines--withLocalTmpFS :: RunMakeM a -> RunMakeM a-withLocalTmpFS act = do-  let initialiser = do-        MakeEnv{..} <- ask-        lcl_tmpfs <- liftIO $ forkTmpFsFrom (hsc_tmpfs hsc_env)-        return $ hsc_env { hsc_tmpfs  = lcl_tmpfs }-      finaliser lcl_env = do-        gbl_env <- ask-        liftIO $ mergeTmpFsInto (hsc_tmpfs lcl_env) (hsc_tmpfs (hsc_env gbl_env))-       -- Add remaining files which weren't cleaned up into local tmp fs for-       -- clean-up later.-       -- Clear the logQueue if this node had it's own log queue-  MC.bracket initialiser finaliser $ \lcl_hsc_env -> local (\env -> env { hsc_env = lcl_hsc_env}) act---- | Run the given actions and then wait for them all to finish.-runAllPipelines :: Int -> MakeEnv -> [MakeAction] -> IO ()-runAllPipelines n_jobs env acts = do-  let spawn_actions :: IO [ThreadId]-      spawn_actions = if n_jobs == 1-        then (:[]) <$> (forkIOWithUnmask $ \unmask -> void $ runLoop (\io -> io unmask) env acts)-        else runLoop forkIOWithUnmask env acts--      kill_actions :: [ThreadId] -> IO ()-      kill_actions tids = mapM_ killThread tids--  MC.bracket spawn_actions kill_actions $ \_ -> do-    mapM_ waitMakeAction acts---- | Execute each action in order, limiting the amount of parrelism by the given--- semaphore.-runLoop :: (((forall a. IO a -> IO a) -> IO ()) -> IO a) -> MakeEnv -> [MakeAction] -> IO [a]-runLoop _ _env [] = return []-runLoop fork_thread env (MakeAction act res_var :acts) = do-  new_thread <--    fork_thread $ \unmask -> (do-            mres <- (unmask $ run_pipeline (withLocalTmpFS act))-                      `MC.onException` (putMVar res_var Nothing) -- Defensive: If there's an unhandled exception then still signal the failure.-            putMVar res_var mres)-  threads <- runLoop fork_thread env acts-  return (new_thread : threads)-  where-      run_pipeline :: RunMakeM a -> IO (Maybe a)-      run_pipeline p = runMaybeT (runReaderT p env)--data MakeAction = forall a . MakeAction (RunMakeM a) (MVar (Maybe a))--waitMakeAction :: MakeAction -> IO ()-waitMakeAction (MakeAction _ mvar) = () <$ readMVar mvar--{- Note [GHC Heap Invariants]-   ~~~~~~~~~~~~~~~~~~~~~~~~~~-This note is a general place to explain some of the heap invariants which should-hold for a program compiled with --make mode. These invariants are all things-which can be checked easily using ghc-debug.--1. No HomeModInfo are reachable via the EPS.-   Why? Interfaces are lazily loaded into the EPS and the lazy thunk retains-        a reference to the entire HscEnv, if we are not careful the HscEnv will-        contain the HomePackageTable at the time the interface was loaded and-        it will never be released.-   Where? dontLeakTheHPT in GHC.Iface.Load--2. No KnotVars are live at the end of upsweep (#20491)-   Why? KnotVars contains an old stale reference to the TypeEnv for modules-        which participate in a loop. At the end of a loop all the KnotVars references-        should be removed by the call to typecheckLoop.-   Where? typecheckLoop in GHC.Driver.Make.--3. Immediately after a reload, no ModDetails are live.-   Why? During the upsweep all old ModDetails are replaced with a new ModDetails-        generated from a ModIface. If we don't clear the ModDetails before the-        reload takes place then memory usage during the reload is twice as much-        as it should be as we retain a copy of the ModDetails for too long.-   Where? pruneCache in GHC.Driver.Make--4. No TcGblEnv or TcLclEnv are live after typechecking is completed.-   Why? By the time we get to simplification all the data structures from typechecking-        should be eliminated.-   Where? No one place in the compiler. These leaks can be introduced by not suitable-          forcing functions which take a TcLclEnv as an argument.-+{-# LANGUAGE NondecreasingIndentation #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE ViewPatterns #-}++-- -----------------------------------------------------------------------------+--+-- (c) The University of Glasgow, 2011+--+-- This module implements multi-module compilation, and is used+-- by --make and GHCi.+--+-- -----------------------------------------------------------------------------+module GHC.Driver.Make (+        depanal, depanalE, depanalPartial,+        load, loadWithCache, load', AnyGhcDiagnostic, LoadHowMuch(..), ModIfaceCache(..), noIfaceCache, newIfaceCache,++        downsweep,++        topSortModuleGraph,++        ms_home_srcimps, ms_home_imps,++        hscSourceToIsBoot,+        findExtraSigImports,+        implicitRequirementsShallow,++        noModError, cyclicModuleErr,+        SummaryNode,+        IsBootInterface(..), mkNodeKey,++        ModNodeKey, ModNodeKeyWithUid(..),+        ModNodeMap(..), emptyModNodeMap, modNodeMapElems, modNodeMapLookup, modNodeMapInsert, modNodeMapSingleton, modNodeMapUnionWith,++        -- * Re-exports from Downsweep+        checkHomeUnitsClosed,+        summariseModule,+        summariseModuleInterface,+        SummariseResult(..),+        summariseFile,++        instantiationNodes,+        ) where++import GHC.Prelude+import GHC.Platform++import GHC.Tc.Utils.Backpack+import GHC.Tc.Utils.Monad  ( initIfaceCheck, concatMapM )++import GHC.Runtime.Interpreter+import qualified GHC.Linker.Loader as Linker+import GHC.Linker.Types+++import GHC.Driver.Config.Diagnostic+import GHC.Driver.Pipeline+import GHC.Driver.Session+import GHC.Driver.DynFlags (ReexportedModule(..))+import GHC.Driver.Monad+import GHC.Driver.Env+import GHC.Driver.Errors+import GHC.Driver.Errors.Types+import GHC.Driver.Main+import GHC.Driver.MakeSem+import GHC.Driver.Downsweep+import GHC.Driver.MakeAction++import GHC.ByteCode.Types++import GHC.Iface.Load      ( cannotFindModule, readIface )+import GHC.IfaceToCore     ( typecheckIface )+import GHC.Iface.Recomp    ( RecompileRequired(..), CompileReason(..) )++import GHC.Data.Bag        ( listToBag )+import GHC.Data.Graph.Directed+import GHC.Data.Maybe      ( expectJust )++import GHC.Utils.Exception ( throwIO, SomeAsyncException )+import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Utils.Misc+import GHC.Utils.Error+import GHC.Utils.Logger+import GHC.Utils.TmpFs++import GHC.Types.Basic+import GHC.Types.Error+import GHC.Types.Target+import GHC.Types.SourceFile+import GHC.Types.SourceError+import GHC.Types.SrcLoc+import GHC.Types.PkgQual++import GHC.Unit+import GHC.Unit.Env+import GHC.Unit.Finder+import GHC.Unit.Module.ModSummary+import GHC.Unit.Module.ModIface+import GHC.Unit.Module.Graph+import GHC.Unit.Home.ModInfo+import GHC.Unit.Module.ModDetails++import qualified Data.Map as Map+import qualified Data.Set as Set++import Control.Concurrent.MVar+import Control.Monad+import qualified Control.Monad.Catch as MC+import Data.IORef+import Data.Maybe+import Data.List (sortOn, groupBy, sortBy)+import qualified Data.List as List+import System.FilePath++import Control.Monad.IO.Class+import Control.Monad.Trans.Reader+import qualified Data.Map.Strict as M+import GHC.Types.TypeEnv+import Control.Monad.Trans.State.Lazy+import Control.Monad.Trans.Class+import GHC.Driver.Env.KnotVars+import Control.Monad.Trans.Maybe+import GHC.Runtime.Loader+import GHC.Utils.Constants+import GHC.Iface.Errors.Types+import Data.Function+import qualified GHC.Data.Maybe as M++import GHC.Data.Graph.Directed.Reachability+import qualified GHC.Unit.Home.Graph as HUG+import GHC.Unit.Home.PackageTable++-- -----------------------------------------------------------------------------+-- Loading the program++-- | Perform a dependency analysis starting from the current targets+-- and update the session with the new module graph.+--+-- Dependency analysis entails parsing the @import@ directives and may+-- therefore require running certain preprocessors.+--+-- Note that each 'ModSummary' in the module graph caches its 'DynFlags'.+-- These 'DynFlags' are determined by the /current/ session 'DynFlags' and the+-- @OPTIONS@ and @LANGUAGE@ pragmas of the parsed module.  Thus if you want+-- changes to the 'DynFlags' to take effect you need to call this function+-- again.+-- In case of errors, just throw them.+--+depanal :: GhcMonad m =>+           [ModuleName]  -- ^ excluded modules+        -> Bool          -- ^ allow duplicate roots+        -> m ModuleGraph+depanal excluded_mods allow_dup_roots = do+    (errs, mod_graph) <- depanalE mkUnknownDiagnostic Nothing excluded_mods allow_dup_roots+    if isEmptyMessages errs+      then pure mod_graph+      else throwErrors (fmap GhcDriverMessage errs)++-- | Perform dependency analysis like in 'depanal'.+-- In case of errors, the errors and an empty module graph are returned.+depanalE :: GhcMonad m =>     -- New for #17459+               (GhcMessage -> AnyGhcDiagnostic)+            -> Maybe Messager+            -> [ModuleName]      -- ^ excluded modules+            -> Bool           -- ^ allow duplicate roots+            -> m (DriverMessages, ModuleGraph)+depanalE diag_wrapper msg excluded_mods allow_dup_roots = do+    hsc_env <- getSession+    (errs, mod_graph) <- depanalPartial diag_wrapper msg excluded_mods allow_dup_roots+    if isEmptyMessages errs+      then do+        hsc_env <- getSession+        let one_unit_messages get_mod_errs k hue = do+              errs <- get_mod_errs+              unknown_module_err <- warnUnknownModules (hscSetActiveUnitId k hsc_env) (homeUnitEnv_dflags hue) mod_graph++              let unused_home_mod_err = warnMissingHomeModules (homeUnitEnv_dflags hue) (hsc_targets hsc_env) mod_graph+                  unused_pkg_err = warnUnusedPackages (homeUnitEnv_units hue) (homeUnitEnv_dflags hue) mod_graph+++              return $ errs `unionMessages` unused_home_mod_err+                          `unionMessages` unused_pkg_err+                          `unionMessages` unknown_module_err++        all_errs <- liftIO $ HUG.unitEnv_foldWithKey one_unit_messages (return emptyMessages) (hsc_HUG hsc_env)+        logDiagnostics (GhcDriverMessage <$> all_errs)+        setSession (setModuleGraph mod_graph hsc_env)+        pure (emptyMessages, mod_graph)+      else do+        -- We don't have a complete module dependency graph,+        -- The graph may be disconnected and is unusable.+        setSession (setModuleGraph emptyMG hsc_env)+        pure (errs, emptyMG)+++-- | Perform dependency analysis like 'depanal' but return a partial module+-- graph even in the face of problems with some modules.+--+-- Modules which have parse errors in the module header, failing+-- preprocessors or other issues preventing them from being summarised will+-- simply be absent from the returned module graph.+--+-- Unlike 'depanal' this function will not update 'hsc_mod_graph' with the+-- new module graph.+depanalPartial+    :: GhcMonad m+    => (GhcMessage -> AnyGhcDiagnostic)+    -> Maybe Messager+    -> [ModuleName]  -- ^ excluded modules+    -> Bool          -- ^ allow duplicate roots+    -> m (DriverMessages, ModuleGraph)+    -- ^ possibly empty 'Bag' of errors and a module graph.+depanalPartial diag_wrapper msg excluded_mods allow_dup_roots = do+  hsc_env <- getSession+  let+         targets = hsc_targets hsc_env+         old_graph = hsc_mod_graph hsc_env+         logger  = hsc_logger hsc_env++  withTiming logger (text "Chasing dependencies") (const ()) $ do+    liftIO $ debugTraceMsg logger 2 (hcat [+              text "Chasing modules from: ",+              hcat (punctuate comma (map pprTarget targets))])++    -- Home package modules may have been moved or deleted, and new+    -- source files may have appeared in the home package that shadow+    -- external package modules, so we have to discard the existing+    -- cached finder data.+    liftIO $ flushFinderCaches (hsc_FC hsc_env) (hsc_unit_env hsc_env)++    (errs, mod_graph) <- liftIO $ downsweep+      hsc_env diag_wrapper msg (mgModSummaries old_graph)+      excluded_mods allow_dup_roots+    return (unionManyMessages errs, mod_graph)+++-- Note [Missing home modules]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- Sometimes we don't want GHC to process modules that weren't specified as+-- explicit targets. For example, cabal may want to enable this warning+-- when building a library, so that GHC warns the user about modules listed+-- neither in `exposed-modules` nor in `other-modules`.+--+-- Here "home module" means a module that doesn't come from another package.+--+-- For example, if GHC is invoked with modules "A" and "B" as targets,+-- but "A" imports some other module "C", then GHC will issue a warning+-- about module "C" not being listed in the command line.+--+-- The warning in enabled by `-Wmissing-home-modules`. See #13129+warnMissingHomeModules ::  DynFlags -> [Target] -> ModuleGraph -> DriverMessages+warnMissingHomeModules dflags targets mod_graph =+    if null missing+      then emptyMessages+      else warn+  where+    diag_opts = initDiagOpts dflags++    -- We need to be careful to handle the case where (possibly+    -- path-qualified) filenames (aka 'TargetFile') rather than module+    -- names are being passed on the GHC command-line.+    --+    -- For instance, `ghc --make src-exe/Main.hs` and+    -- `ghc --make -isrc-exe Main` are supposed to be equivalent.+    -- Note also that we can't always infer the associated module name+    -- directly from the filename argument.  See #13727.+    is_known_module mod =+      is_module_target mod+      ||+      maybe False is_file_target (ml_hs_file (ms_location mod))++    is_module_target mod = (moduleName (ms_mod mod), ms_unitid mod) `Set.member` mod_targets++    is_file_target file = Set.member (withoutExt file) file_targets++    file_targets = Set.fromList (mapMaybe file_target targets)++    file_target Target {targetId} =+      case targetId of+        TargetModule _ -> Nothing+        TargetFile file _ ->+          Just (withoutExt (augmentByWorkingDirectory dflags file))++    mod_targets = Set.fromList (mod_target <$> targets)++    mod_target Target {targetUnitId, targetId} =+      case targetId of+        TargetModule name -> (name, targetUnitId)+        TargetFile file _ -> (mkModuleName (withoutExt file), targetUnitId)++    withoutExt = fst . splitExtension++    missing = map (moduleName . ms_mod) $+      filter (not . is_known_module) $+        (filter (\ms -> ms_unitid ms == homeUnitId_ dflags)+                (mgModSummaries mod_graph))++    warn = singleMessage $ mkPlainMsgEnvelope diag_opts noSrcSpan+                         $ DriverMissingHomeModules (homeUnitId_ dflags) missing (checkBuildingCabalPackage dflags)++-- Check that any modules we want to reexport or hide are actually in the package.+warnUnknownModules :: HscEnv -> DynFlags -> ModuleGraph -> IO DriverMessages+warnUnknownModules hsc_env dflags mod_graph = do+  reexported_warns <- filterM check_reexport reexported_mods+  return $ final_msgs hidden_warns reexported_warns+  where+    diag_opts = initDiagOpts dflags++    unit_mods = Set.fromList (map ms_mod_name+                  (filter (\ms -> ms_unitid ms == homeUnitId_ dflags)+                       (mgModSummaries mod_graph)))++    reexported_mods = reexportedModules dflags+    hidden_mods     = hiddenModules dflags++    hidden_warns = hidden_mods `Set.difference` unit_mods++    lookupModule mn = findImportedModule hsc_env mn NoPkgQual++    check_reexport mn = do+      fr <- lookupModule (reexportFrom mn)+      case fr of+        Found _ m -> return (moduleUnitId m == homeUnitId_ dflags)+        _ -> return True+++    warn diagnostic = singleMessage $ mkPlainMsgEnvelope diag_opts noSrcSpan+                         $ diagnostic++    final_msgs hidden_warns reexported_warns+          =+        unionManyMessages $+          [warn (DriverUnknownHiddenModules (homeUnitId_ dflags) (Set.toList hidden_warns)) | not (Set.null hidden_warns)]+          ++ [warn (DriverUnknownReexportedModules (homeUnitId_ dflags) reexported_warns) | not (null reexported_warns)]++-- | Describes which modules of the module graph need to be loaded.+data LoadHowMuch+   = LoadAllTargets+     -- ^ Load all targets and its dependencies.+   | LoadUpTo [HomeUnitModule]+     -- ^ Load only the given modules and its dependencies.+     -- If empty, we load none of the targets+   | LoadDependenciesOf HomeUnitModule+     -- ^ Load only the dependencies of the given module, but not the module+     -- itself.++{-+Note [Caching HomeModInfo]+~~~~~~~~~~~~~~~~~~~~~~~~~~++API clients who call `load` like to cache the HomeModInfo in memory between+calls to this function. In the old days, this cache was a simple MVar which stored+a HomePackageTable. This was insufficient, as the interface files for boot modules+were not recorded in the cache. In the less old days, the cache was returned at the+end of load, and supplied at the start of load, however, this was not sufficient+because it didn't account for the possibility of exceptions such as SIGINT (#20780).++So now, in the current day, we have this ModIfaceCache abstraction which+can incrementally be updated during the process of upsweep. This allows us+to store interface files for boot modules in an exception-safe way.++When the final version of an interface file is completed then it is placed into+the cache. The contents of the cache is retrieved, and the cache cleared, by iface_clearCache.++Note that because we only store the ModIface and Linkable in the ModIfaceCache,+hydration and rehydration is totally irrelevant, and we just store the CachedIface as+soon as it is completed.++-}+++-- Abstract interface to a cache of HomeModInfo+-- See Note [Caching HomeModInfo]+data ModIfaceCache = ModIfaceCache { iface_clearCache :: IO [CachedIface]+                                   , iface_addToCache :: CachedIface -> IO () }++addHmiToCache :: ModIfaceCache -> HomeModInfo -> IO ()+addHmiToCache c (HomeModInfo i _ l) = iface_addToCache c (CachedIface i l)++data CachedIface = CachedIface { cached_modiface :: !ModIface+                               , cached_linkable :: !HomeModLinkable }++instance Outputable CachedIface where+  ppr (CachedIface mi ln) = hsep [text "CachedIface", ppr (miKey mi), ppr ln]++noIfaceCache :: Maybe ModIfaceCache+noIfaceCache = Nothing++newIfaceCache :: IO ModIfaceCache+newIfaceCache = do+  ioref <- newIORef []+  return $+    ModIfaceCache+      { iface_clearCache = atomicModifyIORef' ioref (\c -> ([], c))+      , iface_addToCache = \hmi -> atomicModifyIORef' ioref (\c -> (hmi:c, ()))+      }+++++-- | Try to load the program.  See 'LoadHowMuch' for the different modes.+--+-- This function implements the core of GHC's @--make@ mode.  It preprocesses,+-- compiles and loads the specified modules, avoiding re-compilation wherever+-- possible.  Depending on the backend (see 'DynFlags.backend' field) compiling+-- and loading may result in files being created on disk.+--+-- Calls the 'defaultWarnErrLogger' after each compiling each module, whether+-- successful or not.+--+-- If errors are encountered during dependency analysis, the module `depanalE`+-- returns together with the errors an empty ModuleGraph.+-- After processing this empty ModuleGraph, the errors of depanalE are thrown.+-- All other errors are reported using the 'defaultWarnErrLogger'.++load :: GhcMonad f => LoadHowMuch -> f SuccessFlag+load how_much = loadWithCache noIfaceCache mkUnknownDiagnostic how_much++mkBatchMsg :: HscEnv -> Messager+mkBatchMsg hsc_env =+  if length (hsc_all_home_unit_ids hsc_env) > 1+    -- This also displays what unit each module is from.+    then batchMultiMsg+    else batchMsg+++loadWithCache :: GhcMonad m => Maybe ModIfaceCache -- ^ Instructions about how to cache interfaces as we create them.+                            -> (GhcMessage -> AnyGhcDiagnostic) -- ^ How to wrap error messages before they are displayed to a user.+                                                                -- If you are using the GHC API you can use this to override how messages+                                                                -- created during 'loadWithCache' are displayed to the user.+                            -> LoadHowMuch -- ^ How much `loadWithCache` should load+                            -> m SuccessFlag+loadWithCache cache diag_wrapper how_much = do+    msg <- mkBatchMsg <$> getSession+    (errs, mod_graph) <- depanalE diag_wrapper (Just msg) [] False                        -- #17459+    success <- load' cache how_much diag_wrapper (Just msg) mod_graph+    if isEmptyMessages errs+      then pure success+      else throwErrors (fmap GhcDriverMessage errs)++-- Note [Unused packages]+-- ~~~~~~~~~~~~~~~~~~~~~~+-- Cabal passes `-package-id` flag for each direct dependency. But GHC+-- loads them lazily, so when compilation is done, we have a list of all+-- actually loaded packages. All the packages, specified on command line,+-- but never loaded, are probably unused dependencies.++warnUnusedPackages :: UnitState -> DynFlags -> ModuleGraph -> DriverMessages+warnUnusedPackages us dflags mod_graph =+    let diag_opts = initDiagOpts dflags++        home_mod_sum = filter (\ms -> homeUnitId_ dflags == ms_unitid ms) (mgModSummaries mod_graph)++    -- Only need non-source imports here because SOURCE imports are always HPT+        loadedPackages = concat $+          mapMaybe (\(_st, fs, mn) -> lookupModulePackage us (unLoc mn) fs)+            $ concatMap ms_imps home_mod_sum++        used_args = Set.fromList (map unitId loadedPackages)++        resolve (u,mflag) = do+                  -- The units which we depend on via the command line explicitly+                  flag <- mflag+                  -- Which we can find the UnitInfo for (should be all of them)+                  ui <- lookupUnit us u+                  -- Which are not explicitly used+                  guard (Set.notMember (unitId ui) used_args)+                  return (unitId ui, unitPackageName ui, unitPackageVersion ui, flag)++        unusedArgs = sortOn (\(u,_,_,_) -> u) $ mapMaybe resolve (explicitUnits us)++        warn = singleMessage $ mkPlainMsgEnvelope diag_opts noSrcSpan (DriverUnusedPackages unusedArgs)++    in if null unusedArgs+        then emptyMessages+        else warn++-- | A ModuleGraphNode which also has a hs-boot file, and the list of nodes on any+-- path from module to its boot file.+data ModuleGraphNodeWithBootFile+  = ModuleGraphNodeWithBootFile+     ModuleGraphNode+       -- ^ The module itself (not the hs-boot module)+     [NodeKey]+       -- ^ The modules in between the module and its hs-boot file,+       -- not including the hs-boot file itself.+++instance Outputable ModuleGraphNodeWithBootFile where+  ppr (ModuleGraphNodeWithBootFile mgn deps) = text "ModeGraphNodeWithBootFile: " <+> ppr mgn $$ ppr deps++-- | A 'BuildPlan' is the result of attempting to linearise a single strongly-connected+-- component of the module graph.+data BuildPlan+  -- | A simple, single module all alone (which *might* have an hs-boot file, if it isn't part of a cycle)+  = SingleModule ModuleGraphNode+  -- | A resolved cycle, linearised by hs-boot files+  | ResolvedCycle [Either ModuleGraphNode ModuleGraphNodeWithBootFile]+  -- | An actual cycle, which wasn't resolved by hs-boot files+  | UnresolvedCycle [ModuleGraphNode]++instance Outputable BuildPlan where+  ppr (SingleModule mgn) = text "SingleModule" <> parens (ppr mgn)+  ppr (ResolvedCycle mgn)   = text "ResolvedCycle:" <+> ppr mgn+  ppr (UnresolvedCycle mgn) = text "UnresolvedCycle:" <+> ppr mgn+++-- Just used for an assertion+countMods :: BuildPlan -> Int+countMods (SingleModule _) = 1+countMods (ResolvedCycle ns) = length ns+countMods (UnresolvedCycle ns) = length ns++-- See Note [Upsweep] for a high-level description.+createBuildPlan :: ModuleGraph -> Maybe [HomeUnitModule] -> [BuildPlan]+createBuildPlan mod_graph maybe_top_mod =+    let -- Step 1: Compute SCCs without .hi-boot files, to find the cycles+        cycle_mod_graph   = topSortModuleGraph True  mod_graph maybe_top_mod+        acyclic_mod_graph = topSortModuleGraph False mod_graph maybe_top_mod++        -- Step 2: Reanalyse loops, with relevant boot modules, to solve the cycles.+        build_plan :: [BuildPlan]+        build_plan+          -- Fast path, if there are no boot modules just do a normal toposort+          | isEmptyModuleEnv boot_modules = collapseAcyclic acyclic_mod_graph+          | otherwise = toBuildPlan cycle_mod_graph []++        toBuildPlan :: [SCC ModuleGraphNode] -> [ModuleGraphNode] -> [BuildPlan]+        toBuildPlan [] mgn = collapseAcyclic (topSortWithBoot mgn)+        toBuildPlan ((AcyclicSCC node):sccs) mgn = toBuildPlan sccs (node:mgn)+        -- Interesting case+        toBuildPlan ((CyclicSCC nodes):sccs) mgn =+          let acyclic = collapseAcyclic (topSortWithBoot mgn)+              -- Now perform another toposort but just with these nodes and relevant hs-boot files.+              -- The result should be acyclic, if it's not, then there's an unresolved cycle in the graph.+              mresolved_cycle = collapseSCC (topSortWithBoot nodes)+          in acyclic ++ [either UnresolvedCycle ResolvedCycle mresolved_cycle] ++ toBuildPlan sccs []++        -- Compute the intermediate modules between a file and its hs-boot file.+        -- See Step 2a in Note [Upsweep]+        boot_path mn uid =+          Set.toList $+          -- Don't include the boot module itself+          Set.filter ((/= NodeKey_Module (key IsBoot)) . mkNodeKey)  $+          -- Keep intermediate dependencies: as per Step 2a in Note [Upsweep], these are+          -- the transitive dependencies of the non-boot file which transitively depend+          -- on the boot file.+          Set.filter (\(mkNodeKey -> nk) ->+            nodeKeyUnitId nk == uid  -- Cheap test+              && mgQuery mod_graph nk (NodeKey_Module (key IsBoot))) $+          Set.fromList $+          expectJust (mgReachable mod_graph (NodeKey_Module (key NotBoot)))+          where+            key ib = ModNodeKeyWithUid (GWIB mn ib) uid+++        -- An environment mapping a module to its hs-boot file and all nodes on the path between the two, if one exists+        boot_modules = mkModuleEnv+          [ (mn, (m, boot_path (moduleName mn) (moduleUnitId mn)))+            | m@(ModuleNode _ ms) <- mgModSummaries' mod_graph+            , let mn = moduleNodeInfoModule ms+            , isBootModuleNodeInfo ms == IsBoot]++        select_boot_modules :: [ModuleGraphNode] -> [ModuleGraphNode]+        select_boot_modules = mapMaybe (fmap fst . get_boot_module)++        get_boot_module :: ModuleGraphNode -> Maybe (ModuleGraphNode, [ModuleGraphNode])+        get_boot_module (ModuleNode _ ms)+          | NotBoot <- isBootModuleNodeInfo ms+          = lookupModuleEnv boot_modules (moduleNodeInfoModule ms)+        get_boot_module _ = Nothing++        -- Any cycles should be resolved now+        collapseSCC :: [SCC ModuleGraphNode] -> Either [ModuleGraphNode] [(Either ModuleGraphNode ModuleGraphNodeWithBootFile)]+        -- Must be at least two nodes, as we were in a cycle+        collapseSCC [AcyclicSCC node1, AcyclicSCC node2] = Right [toNodeWithBoot node1, toNodeWithBoot node2]+        collapseSCC (AcyclicSCC node : nodes) = either (Left . (node :)) (Right . (toNodeWithBoot node :)) (collapseSCC nodes)+        -- Cyclic+        collapseSCC nodes = Left (flattenSCCs nodes)++        toNodeWithBoot :: ModuleGraphNode -> Either ModuleGraphNode ModuleGraphNodeWithBootFile+        toNodeWithBoot mn =+          case get_boot_module mn of+            -- The node doesn't have a boot file+            Nothing -> Left mn+            -- The node does have a boot file+            Just path -> Right (ModuleGraphNodeWithBootFile mn (map mkNodeKey (snd path)))++        -- The toposort and accumulation of acyclic modules is solely to pick-up+        -- hs-boot files which are **not** part of cycles.+        collapseAcyclic :: [SCC ModuleGraphNode] -> [BuildPlan]+        collapseAcyclic (AcyclicSCC node : nodes) = SingleModule node : collapseAcyclic nodes+        collapseAcyclic (CyclicSCC cy_nodes : nodes) = (UnresolvedCycle cy_nodes) : collapseAcyclic nodes+        collapseAcyclic [] = []++        topSortWithBoot nodes = topSortModules False (select_boot_modules nodes ++ nodes) Nothing+  in+    -- We need to use 'acyclic_mod_graph', since if 'maybe_top_mod' is 'Just', then the resulting module+    -- graph is pruned, reducing the number of 'build_plan' elements.+    -- We don't use the size of 'cycle_mod_graph', as it removes @.hi-boot@ modules. These are added+    -- later in the processing.+    assertPpr (sum (map countMods build_plan) == lengthMGWithSCC acyclic_mod_graph)+              (vcat [text "Build plan missing nodes:", (text "PLAN:" <+> ppr (sum (map countMods build_plan))), (text "GRAPH:" <+> ppr (lengthMGWithSCC acyclic_mod_graph))])+              build_plan+  where+    lengthMGWithSCC :: [SCC a] -> Int+    lengthMGWithSCC = List.foldl' (\acc scc -> length scc + acc) 0++-- | Generalized version of 'load' which also supports a custom+-- 'Messager' (for reporting progress) and 'ModuleGraph' (generally+-- produced by calling 'depanal'.+load' :: GhcMonad m => Maybe ModIfaceCache -> LoadHowMuch -> (GhcMessage -> AnyGhcDiagnostic) -> Maybe Messager -> ModuleGraph -> m SuccessFlag+load' mhmi_cache how_much diag_wrapper mHscMessage mod_graph = do+    -- In normal usage plugins are initialised already by ghc/Main.hs this is protective+    -- for any client who might interact with GHC via load'.+    -- See Note [Timing of plugin initialization]+    initializeSessionPlugins+    modifySession (setModuleGraph mod_graph)+    guessOutputFile+    hsc_env <- getSession++    let dflags = hsc_dflags hsc_env+    let logger = hsc_logger hsc_env+    let interp = hscInterp hsc_env++    -- The "bad" boot modules are the ones for which we have+    -- B.hs-boot in the module graph, but no B.hs+    -- The downsweep should have ensured this does not happen+    -- (see msDeps)+    let all_home_mods =+          Set.fromList [ Module (ms_unitid s) (ms_mod_name s)+                    | s <- mgModSummaries mod_graph, isBootSummary s == NotBoot]+    -- TODO: Figure out what the correct form of this assert is. It's violated+    -- when you have HsBootMerge nodes in the graph: then you'll have hs-boot+    -- files without corresponding hs files.+    --  bad_boot_mods = [s        | s <- mod_graph, isBootSummary s,+    --                              not (ms_mod_name s `elem` all_home_mods)]+    -- assert (null bad_boot_mods ) return ()++    -- check that the module given in HowMuch actually exists, otherwise+    -- topSortModuleGraph will bomb later.+    let checkHowMuch (LoadUpTo ms)          = checkMods ms+        checkHowMuch (LoadDependenciesOf m) = checkMods [m]+        checkHowMuch _ = id++        checkMods ms and_then =+          case List.partition (`Set.member` all_home_mods) ms of+            (_, []) -> and_then+            (_, not_found_mods) -> do+              let+                mkModuleNotFoundError m =+                  mkPlainErrorMsgEnvelope noSrcSpan+                  $ GhcDriverMessage+                  $ DriverModuleNotFound (moduleUnit m) (moduleName m)+              throwErrors $ mkMessages $ listToBag [mkModuleNotFoundError not_found | not_found <- not_found_mods]++    checkHowMuch how_much $ do++    -- mg2_with_srcimps drops the hi-boot nodes, returning a+    -- graph with cycles. It is just used for warning about unnecessary source imports.+    let mg2_with_srcimps :: [SCC ModuleGraphNode]+        mg2_with_srcimps = topSortModuleGraph True mod_graph Nothing++    -- If we can determine that any of the {-# SOURCE #-} imports+    -- are definitely unnecessary, then emit a warning.+    warnUnnecessarySourceImports (filterToposortToModules mg2_with_srcimps)++    let maybe_top_mods = case how_much of+                          LoadUpTo m           -> Just m+                          LoadDependenciesOf m -> Just [m]+                          _                    -> Nothing++        build_plan = createBuildPlan mod_graph maybe_top_mods+++    cache <- liftIO $ maybe (return []) iface_clearCache mhmi_cache+    let+        -- prune the HPT so everything is not retained when doing an+        -- upsweep.+        !pruned_cache = pruneCache cache+                            [ms | (ModuleNodeCompile ms) <- (flattenSCCs (filterToposortToModules  mg2_with_srcimps))]++++    -- before we unload anything, make sure we don't leave an old+    -- interactive context around pointing to dead bindings.  Also,+    -- write an empty HPT to allow the old HPT to be GC'd.++    let pruneHomeUnitEnv hme = do+          emptyHPT <- liftIO emptyHomePackageTable+          pure $! hme{ homeUnitEnv_hpt = emptyHPT }+    hug' <- traverse pruneHomeUnitEnv (ue_home_unit_graph $ hsc_unit_env hsc_env)+    let ue' = (hsc_unit_env hsc_env){ ue_home_unit_graph = hug' }+    setSession $ discardIC hsc_env{hsc_unit_env = ue' }+    hsc_env <- getSession++    -- Unload everything+    liftIO $ unload interp hsc_env++    liftIO $ debugTraceMsg logger 2 (hang (text "Ready for upsweep")+                                    2 (ppr build_plan))++    worker_limit <- liftIO $ mkWorkerLimit dflags++    (upsweep_ok, new_deps) <- withDeferredDiagnostics $ do+      hsc_env <- getSession+      liftIO $ upsweep worker_limit hsc_env mhmi_cache diag_wrapper mHscMessage (toCache pruned_cache) build_plan++    -- At this point, all the HPT variables will be populated, but we don't want+    -- to leak the contents of a failed session.+    liftIO $ restrictDepsHscEnv new_deps hsc_env+    case upsweep_ok of+      Failed -> loadFinish upsweep_ok+      Succeeded -> do+          liftIO $ debugTraceMsg logger 2 (text "Upsweep completely successful.")+          loadFinish upsweep_ok++++-- | Finish up after a load.+loadFinish :: GhcMonad m => SuccessFlag -> m SuccessFlag+-- Empty the interactive context and set the module context to the topmost+-- newly loaded module, or the Prelude if none were loaded.+loadFinish all_ok+  = do modifySession discardIC+       return all_ok+++-- | If there is no -o option, guess the name of target executable+-- by using top-level source file name as a base.+guessOutputFile :: GhcMonad m => m ()+guessOutputFile = modifySession $ \env ->+    -- Force mod_graph to avoid leaking env+    let !mod_graph = hsc_mod_graph env+        new_home_graph =+          flip fmap (hsc_HUG env) $ \hue ->+            let dflags = homeUnitEnv_dflags hue+                platform = targetPlatform dflags+                mainModuleSrcPath :: Maybe String+                mainModuleSrcPath = do+                  ms <- mgLookupModule mod_graph (mainModIs hue)+                  ml_hs_file (moduleNodeInfoLocation ms)+                name = fmap dropExtension mainModuleSrcPath++                -- MP: This exception is quite sensitive to being forced, if you+                -- force it here then the error message is different because it gets+                -- caught by a different error handler than the test (T9930fail) expects.+                -- Putting an exception into DynFlags is probably not a great design but+                -- I'll write this comment rather than more eagerly force the exception.+                name_exe = do+                  -- we must add the .exe extension unconditionally here, otherwise+                  -- when name has an extension of its own, the .exe extension will+                 -- not be added by GHC.Driver.Pipeline.exeFileName.  See #2248+                 !name' <- case platformArchOS platform of+                             ArchOS _ OSMinGW32  -> fmap (<.> "exe") name+                             ArchOS ArchWasm32 _ -> fmap (<.> "wasm") name+                             _ -> name+                 mainModuleSrcPath' <- mainModuleSrcPath+                 -- #9930: don't clobber input files (unless they ask for it)+                 if name' == mainModuleSrcPath'+                   then throwGhcException . UsageError $+                        "default output name would overwrite the input file; " +++                        "must specify -o explicitly"+                   else Just name'+            in+              case outputFile_ dflags of+                Just _ -> hue+                Nothing -> hue {homeUnitEnv_dflags = dflags { outputFile_ = name_exe } }+    in env { hsc_unit_env = (hsc_unit_env env) { ue_home_unit_graph = new_home_graph } }++-- -----------------------------------------------------------------------------+--+-- | Prune the HomePackageTable+--+-- Before doing an upsweep, we can throw away:+--+--   - all ModDetails, all linked code+--   - all unlinked code that is out of date with respect to+--     the source file+--+-- This is VERY IMPORTANT otherwise we'll end up requiring 2x the+-- space at the end of the upsweep, because the topmost ModDetails of the+-- old HPT holds on to the entire type environment from the previous+-- compilation.+-- Note [GHC Heap Invariants]+pruneCache :: [CachedIface]+                      -> [ModSummary]+                      -> [HomeModInfo]+pruneCache hpt summ+  = strictMap prune hpt+  where prune (CachedIface { cached_modiface = iface+                           , cached_linkable = linkable+                           }) = HomeModInfo iface emptyModDetails linkable'+          where+           modl = miKey iface+           linkable'+                | Just ms <- M.lookup modl ms_map+                , mi_src_hash iface == Just (ms_hs_hash ms)+                = linkable+                | otherwise+                = emptyHomeModInfoLinkable++        -- Using UFM Module is safe for determinism because the map is just used for a transient lookup. The cache should be unique and a key clash is an error.+        ms_map = M.fromListWith+                  (\ms1 ms2 -> assertPpr False (text "prune_cache" $$ (ppr ms1 <+> ppr ms2))+                               ms2)+                  [(msKey ms, ms) | ms <- summ]++-- ---------------------------------------------------------------------------+--+-- | Unloading+unload :: Interp -> HscEnv -> IO ()+unload interp hsc_env+  = case ghcLink (hsc_dflags hsc_env) of+        LinkInMemory -> Linker.unload interp hsc_env []+        _other -> return ()+++{- Parallel Upsweep++The parallel upsweep attempts to concurrently compile the modules in the+compilation graph using multiple Haskell threads.++The Algorithm++* The list of `MakeAction`s are created by `interpretBuildPlan`. A `MakeAction` is+a pair of an `IO a` action and a `MVar a`, where to place the result.+  The list is sorted topologically, so can be executed in order without fear of+  blocking.+* runPipelines takes this list and eventually passes it to runLoop which executes+  each action and places the result into the right MVar.+* The amount of parallelism is controlled by a semaphore. This is just used around the+  module compilation step, so that only the right number of modules are compiled at+  the same time which reduces overall memory usage and allocations.+* Each proper node has a LogQueue, which dictates where to send it's output.+* The LogQueue is placed into the LogQueueQueue when the action starts and a worker+  thread processes the LogQueueQueue printing logs for each module in a stable order.+* The result variable for an action producing `a` is of type `Maybe a`, therefore+  it is still filled on a failure. If a module fails to compile, the+  failure is propagated through the whole module graph and any modules which didn't+  depend on the failure can still be compiled. This behaviour also makes the code+  quite a bit cleaner.+-}+++{-++Note [--make mode]+~~~~~~~~~~~~~~~~~+There are two main parts to `--make` mode.++1. `downsweep`: Starts from the top of the module graph and computes dependencies.+2. `upsweep`: Starts from the bottom of the module graph and compiles modules.++The result of the downsweep is a 'ModuleGraph', which is then passed to 'upsweep' which+computers how to build this ModuleGraph.++Note [Upsweep]+~~~~~~~~~~~~~~+Upsweep takes a 'ModuleGraph' as input, computes a build plan and then executes+the plan in order to compile the project.++The first step is computing the build plan from a 'ModuleGraph'.++The output of this step is a `[BuildPlan]`, which is a topologically sorted plan for+how to build all the modules.++```+data BuildPlan = SingleModule ModuleGraphNode  -- A simple, single module all alone but *might* have an hs-boot file which isn't part of a cycle+               | ResolvedCycle [Either ModuleGraphNode ModuleGraphNodeWithBoot]   -- A resolved cycle, linearised by hs-boot files+               | UnresolvedCycle [ModuleGraphNode] -- An actual cycle, which wasn't resolved by hs-boot files+```++The plan is computed in two steps:++Step 1:  Topologically sort the module graph without hs-boot files. This returns a [SCC ModuleGraphNode] which contains+         cycles.+Step 2:  For each cycle, topologically sort the modules in the cycle *with* the relevant hs-boot files. This should+         result in an acyclic build plan if the hs-boot files are sufficient to resolve the cycle.+Step 2a: For each module in the cycle, if the module has a boot file then compute the+         modules on the path between it and the hs-boot file.+         These are the intermediate modules which:+            (1) are (transitive) dependencies of the non-boot module, and+            (2) have the boot module as a (transitive) dependency.+         In particular, all such intermediate modules must appear in the same unit as+         the module under consideration, as module cycles cannot cross unit boundaries.+         This information is stored in ModuleGraphNodeWithBoot.++The `[BuildPlan]` is then interpreted by the `interpretBuildPlan` function.++* SingleModule nodes are compiled normally by either the upsweep_inst or upsweep_mod functions.+* ResolvedCycles need to compiled "together" so that modules outside the cycle are presented+  with a consistent knot-tied version of modules at the end.+    - When the ModuleGraphNodeWithBoot nodes are compiled then suitable rehydration+      is performed both before and after the module in question is compiled.+      See Note [Hydrating Modules] for more information.+* UnresolvedCycles are indicative of a proper cycle, unresolved by hs-boot files+  and are reported as an error to the user.++The main trickiness of `interpretBuildPlan` is deciding which version of a dependency+is visible from each module. For modules which are not in a cycle, there is just+one version of a module, so that is always used. For modules in a cycle, there are two versions of+'HomeModInfo'.++1. Internal to loop: The version created whilst compiling the loop by upsweep_mod.+2. External to loop: The knot-tied version created by typecheckLoop.++Whilst compiling a module inside the loop, we need to use the (1). For a module which+is outside of the loop which depends on something from in the loop, the (2) version+is used.++As the plan is interpreted, which version of a HomeModInfo is visible is updated+by updating a map held in a state monad. So after a loop has finished being compiled,+the visible module is the one created by typecheckLoop and the internal version is not+used again.++This plan also ensures the most important invariant to do with module loops:++> If you depend on anything within a module loop, before you can use the dependency,+  the whole loop has to finish compiling.++The end result of `interpretBuildPlan` is a `[MakeAction]`, which are pairs+of `IO a` actions and a `MVar (Maybe a)`, somewhere to put the result of running+the action. This list is topologically sorted, so can be run in order to compute+the whole graph.++As well as this `interpretBuildPlan` also outputs an `IO [Maybe (Maybe HomeModInfo)]` which+can be queried at the end to get the result of all modules at the end, with their proper+visibility. For example, if any module in a loop fails then all modules in that loop will+report as failed because the visible node at the end will be the result of checking+these modules together.++-}++-- | Simple wrapper around MVar which allows a functor instance.+data ResultVar b = forall a . ResultVar (a -> b) (MVar (Maybe a))++deriving instance Functor ResultVar++mkResultVar :: MVar (Maybe a) -> ResultVar a+mkResultVar = ResultVar id++-- | Block until the result is ready.+waitResult :: ResultVar a -> MaybeT IO a+waitResult (ResultVar f var) = MaybeT (fmap f <$> readMVar var)++data BuildResult = BuildResult { _resultOrigin :: ResultOrigin+                               , resultVar    :: ResultVar (Maybe HomeModInfo)+                               }++-- The origin of this result var, useful for debugging+data ResultOrigin = NoLoop | Loop ResultLoopOrigin deriving (Show)++data ResultLoopOrigin = Initialise | Rehydrated | Finalised deriving (Show)++mkBuildResult :: ResultOrigin -> ResultVar (Maybe HomeModInfo) -> BuildResult+mkBuildResult = BuildResult+++data BuildLoopState = BuildLoopState { buildDep :: M.Map NodeKey BuildResult+                                          -- The current way to build a specific TNodeKey, without cycles this just points to+                                          -- the appropriate result of compiling a module  but with+                                          -- cycles there can be additional indirection and can point to the result of typechecking a loop+                                     , nNODE :: Int+                                     }++nodeId :: BuildM Int+nodeId = do+  n <- gets nNODE+  modify (\m -> m { nNODE = n + 1 })+  return n+++setModulePipeline :: NodeKey -> BuildResult -> BuildM ()+setModulePipeline mgn build_result = do+  modify (\m -> m { buildDep = M.insert mgn build_result (buildDep m) })++type BuildMap = M.Map NodeKey BuildResult++getBuildMap :: BuildM BuildMap+getBuildMap = gets buildDep++getDependencies :: [NodeKey] -> BuildMap -> [BuildResult]+getDependencies direct_deps build_map =+  strictMap (expectJust . flip M.lookup build_map) direct_deps++type BuildM a = StateT BuildLoopState IO a+++++-- | Given the build plan, creates a graph which indicates where each NodeKey should+-- get its direct dependencies from. This might not be the corresponding build action+-- if the module participates in a loop. This step also labels each node with a number for the output.+-- See Note [Upsweep] for a high-level description.+interpretBuildPlan :: HomeUnitGraph+                   -> Maybe ModIfaceCache+                   -> M.Map ModNodeKeyWithUid HomeModInfo+                   -> [BuildPlan]+                   -> IO ( Maybe [ModuleGraphNode] -- Is there an unresolved cycle+                         , [MakeAction] -- Actions we need to run in order to build everything+                         , IO [Maybe (Maybe HomeModInfo)]) -- An action to query to get all the built modules at the end.+interpretBuildPlan hug mhmi_cache old_hpt plan = do+  ((mcycle, plans), build_map) <- runStateT (buildLoop plan) (BuildLoopState M.empty 1)+  let wait = collect_results (buildDep build_map)+  return (mcycle, plans, wait)++  where+    collect_results build_map =+      sequence (map (\br -> collect_result (resultVar br)) (M.elems build_map))+      where+        collect_result res_var = runMaybeT (waitResult res_var)++    -- Just used for an assertion+    count_mods :: BuildPlan -> Int+    count_mods (SingleModule m) = count_m m+    count_mods (ResolvedCycle ns) = length ns+    count_mods (UnresolvedCycle ns) = length ns++    count_m (UnitNode {}) = 0+    count_m _ = 1++    n_mods = sum (map count_mods plan)++    buildLoop :: [BuildPlan]+              -> BuildM (Maybe [ModuleGraphNode], [MakeAction])+    -- Build the abstract pipeline which we can execute+    -- Building finished+    buildLoop []           = return (Nothing, [])+    buildLoop (plan:plans) =+      case plan of+        -- If there was no cycle, then typecheckLoop is not necessary+        SingleModule m -> do+          one_plan <- buildSingleModule Nothing NoLoop m+          (cycle, all_plans) <- buildLoop plans+          return (cycle, one_plan : all_plans)++        -- For a resolved cycle, depend on everything in the loop, then update+        -- the cache to point to this node rather than directly to the module build+        -- nodes+        ResolvedCycle ms -> do+          pipes <- buildModuleLoop ms+          (cycle, graph) <- buildLoop plans+          return (cycle, pipes ++ graph)++        -- Can't continue past this point as the cycle is unresolved.+        UnresolvedCycle ns -> return (Just ns, [])++    buildSingleModule :: Maybe [NodeKey]  -- Modules we need to rehydrate before compiling this module+                      -> ResultOrigin+                      -> ModuleGraphNode          -- The node we are compiling+                      -> BuildM MakeAction+    buildSingleModule rehydrate_nodes origin mod = do+      !build_map <- getBuildMap+      -- 1. Get the direct dependencies of this module+      let direct_deps = mgNodeDependencies False mod+          -- It's really important to force build_deps, or the whole buildMap is retained,+          -- which would retain all the result variables, preventing us from collecting them+          -- after they are no longer used.+          !build_deps = getDependencies direct_deps build_map+      !build_action <-+            case mod of+              InstantiationNode uid iu -> do+                mod_idx <- nodeId+                return $ withCurrentUnit (mgNodeUnitId mod) $ do+                  !_ <- wait_deps build_deps+                  executeInstantiationNode mod_idx n_mods hug uid iu+                  return Nothing+              ModuleNode _build_deps ms -> do+                let !old_hmi = M.lookup (mnKey ms) old_hpt+                    rehydrate_mods = mapMaybe nodeKeyModName <$> rehydrate_nodes+                mod_idx <- nodeId+                return $ withCurrentUnit (mgNodeUnitId mod) $ do+                     !_ <- wait_deps build_deps+                     hmi <- executeCompileNode mod_idx n_mods old_hmi hug rehydrate_mods ms+                     -- Write the HMI to an external cache (if one exists)+                     -- See Note [Caching HomeModInfo]+                     liftIO $ forM mhmi_cache $ \hmi_cache -> addHmiToCache hmi_cache hmi+                     -- Make sure the result is written to the HPT var+                     liftIO $ HUG.addHomeModInfoToHug hmi hug+                     return (Just hmi)+              LinkNode _nks uid -> do+                  mod_idx <- nodeId+                  return $ withCurrentUnit (mgNodeUnitId mod) $ do+                    !_ <- wait_deps build_deps+                    executeLinkNode hug (mod_idx, n_mods) uid direct_deps+                    return Nothing+              UnitNode {} -> return $ return Nothing+++      res_var <- liftIO newEmptyMVar+      let result_var = mkResultVar res_var+      setModulePipeline (mkNodeKey mod) (mkBuildResult origin result_var)+      return $! (MakeAction build_action res_var)+++    buildOneLoopyModule :: ModuleGraphNodeWithBootFile -> BuildM [MakeAction]+    buildOneLoopyModule (ModuleGraphNodeWithBootFile mn deps) = do+      ma <- buildSingleModule (Just deps) (Loop Initialise) mn+      -- Rehydration (1) from Note [Hydrating Modules], "Loops with multiple boot files"+      rehydrate_action <- rehydrateAction Rehydrated ((GWIB (mkNodeKey mn) IsBoot) : (map (\d -> GWIB d NotBoot) deps))+      return $ [ma, rehydrate_action]+++    buildModuleLoop :: [Either ModuleGraphNode ModuleGraphNodeWithBootFile] -> BuildM [MakeAction]+    buildModuleLoop ms = do+      build_modules <- concatMapM (either (fmap (:[]) <$> buildSingleModule Nothing (Loop Initialise)) buildOneLoopyModule) ms+      let extract (Left mn) = GWIB (mkNodeKey mn) NotBoot+          extract (Right (ModuleGraphNodeWithBootFile mn _)) = GWIB (mkNodeKey mn) IsBoot+      let loop_mods = map extract ms+      -- Rehydration (2) from Note [Hydrating Modules], "Loops with multiple boot files"+      -- Fixes the space leak described in that note.+      rehydrate_action <- rehydrateAction Finalised loop_mods++      return $ build_modules ++ [rehydrate_action]++    -- An action which rehydrates the given keys+    rehydrateAction :: ResultLoopOrigin -> [GenWithIsBoot NodeKey] -> BuildM MakeAction+    rehydrateAction origin deps = do+      !build_map <- getBuildMap+      res_var <- liftIO newEmptyMVar+      let loop_unit :: UnitId+          !loop_unit = nodeKeyUnitId (gwib_mod (head deps))+          !build_deps = getDependencies (map gwib_mod deps) build_map+      let loop_action = withCurrentUnit loop_unit $ do+            !_ <- wait_deps build_deps+            hsc_env <- asks hsc_env+            let mns :: [ModuleName]+                mns = mapMaybe (nodeKeyModName . gwib_mod) deps++            hmis' <- liftIO $ rehydrateAfter hsc_env mns++            checkRehydrationInvariant hmis' deps++            -- Add hydrated interfaces to global variable+            liftIO $ mapM_ (\hmi -> HUG.addHomeModInfoToHug hmi hug) hmis'+            return hmis'++      let fanout i = Just . (!! i) <$> mkResultVar res_var+      -- From outside the module loop, anyone must wait for the loop to finish and then+      -- use the result of the rehydrated iface. This makes sure that things not in the+      -- module loop will see the updated interfaces for all the identifiers in the loop.+          boot_key :: NodeKey -> NodeKey+          boot_key (NodeKey_Module m) = NodeKey_Module (m { mnkModuleName = (mnkModuleName m) { gwib_isBoot = IsBoot } } )+          boot_key k = pprPanic "boot_key" (ppr k)++          update_module_pipeline (m, i) =+            case gwib_isBoot m of+              NotBoot -> setModulePipeline (gwib_mod m) (mkBuildResult (Loop origin) (fanout i))+              IsBoot -> do+                setModulePipeline (gwib_mod m) (mkBuildResult (Loop origin) (fanout i))+                -- SPECIAL: Anything outside the loop needs to see A rather than A.hs-boot+                setModulePipeline (boot_key (gwib_mod m)) (mkBuildResult (Loop origin) (fanout i))++      let deps_i = zip deps [0..]+      mapM update_module_pipeline deps_i++      return $ MakeAction loop_action res_var++      -- Checks that the interfaces returned from hydration match-up with the names of the+      -- modules which were fed into the function.+    checkRehydrationInvariant hmis deps =+        let hmi_names = map (moduleName . mi_module . hm_iface) hmis+            start = mapMaybe (nodeKeyModName . gwib_mod) deps+        in massertPpr (hmi_names == start) $ (ppr hmi_names $$ ppr start)+++withCurrentUnit :: UnitId -> RunMakeM a -> RunMakeM a+withCurrentUnit uid = do+  local (\env -> env { hsc_env = hscSetActiveUnitId uid (hsc_env env)})++upsweep+    :: WorkerLimit -- ^ The number of workers we wish to run in parallel+    -> HscEnv -- ^ The base HscEnv, which is augmented for each module+    -> Maybe ModIfaceCache -- ^ A cache to incrementally write final interface files to+    -> (GhcMessage -> AnyGhcDiagnostic)+    -> Maybe Messager+    -> M.Map ModNodeKeyWithUid HomeModInfo+    -> [BuildPlan]+    -> IO (SuccessFlag, [HomeModInfo])+upsweep n_jobs hsc_env hmi_cache diag_wrapper mHscMessage old_hpt build_plan = do+    (cycle, pipelines, collect_result) <- interpretBuildPlan (hsc_HUG hsc_env) hmi_cache old_hpt build_plan+    runPipelines n_jobs hsc_env diag_wrapper mHscMessage pipelines+    res <- collect_result++    let completed = [m | Just (Just m) <- res]++    -- Handle any cycle in the original compilation graph and return the result+    -- of the upsweep.+    case cycle of+        Just mss -> do+          throwOneError $ cyclicModuleErr mss+        Nothing  -> do+          let success_flag = successIf (all isJust res)+          return (success_flag, completed)++toCache :: [HomeModInfo] -> M.Map (ModNodeKeyWithUid) HomeModInfo+toCache hmis = M.fromList ([(miKey $ hm_iface hmi, hmi) | hmi <- hmis])++upsweep_inst :: HscEnv+             -> Maybe Messager+             -> Int  -- index of module+             -> Int  -- total number of modules+             -> UnitId+             -> InstantiatedUnit+             -> IO ()+upsweep_inst hsc_env mHscMessage mod_index nmods uid iuid = do+        case mHscMessage of+            Just hscMessage -> hscMessage hsc_env (mod_index, nmods) (NeedsRecompile MustCompile) (InstantiationNode uid iuid)+            Nothing -> return ()+        runHsc hsc_env $ ioMsgMaybe $ hoistTcRnMessage $ tcRnCheckUnit hsc_env $ VirtUnit iuid+        pure ()++-- | Compile a single module.  Always produce a Linkable for it if+-- successful.  If no compilation happened, return the old Linkable.+upsweep_mod :: HscEnv+            -> Maybe Messager+            -> Maybe HomeModInfo+            -> ModSummary+            -> Int  -- index of module+            -> Int  -- total number of modules+            -> IO HomeModInfo+upsweep_mod hsc_env mHscMessage old_hmi summary mod_index nmods =  do+  hmi <- compileOne' mHscMessage hsc_env summary+          mod_index nmods (hm_iface <$> old_hmi) (maybe emptyHomeModInfoLinkable hm_linkable old_hmi)++  -- MP: This is a bit janky, because before you add the entries you have to extend the HPT with the module+  -- you just compiled. Another option, would be delay adding anything until after upsweep has finished, but I+  -- am unsure if this is sound (wrt running TH splices for example).+  -- This function only does anything if the linkable produced is a BCO, which+  -- used to only happen with the bytecode backend, but with+  -- @-fprefer-byte-code@, @HomeModInfo@ has bytecode even when generating+  -- object code, see #25230.+  hscInsertHPT hmi hsc_env+  addSptEntries (hsc_env)+                (homeModInfoByteCode hmi)++  return hmi++-- | Add the entries from a BCO linkable to the SPT table, see+-- See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable.+addSptEntries :: HscEnv -> Maybe Linkable -> IO ()+addSptEntries hsc_env mlinkable =+  hscAddSptEntries hsc_env+     [ spt+     | linkable <- maybeToList mlinkable+     , bco <- linkableBCOs linkable+     , spt <- bc_spt_entries bco+     ]+++-- Note [When source is considered modified]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- A number of functions in GHC.Driver accept a SourceModified argument, which+-- is part of how GHC determines whether recompilation may be avoided (see the+-- definition of the SourceModified data type for details).+--+-- Determining whether or not a source file is considered modified depends not+-- only on the source file itself, but also on the output files which compiling+-- that module would produce. This is done because GHC supports a number of+-- flags which control which output files should be produced, e.g. -fno-code+-- -fwrite-interface and -fwrite-ide-file; we must check not only whether the+-- source file has been modified since the last compile, but also whether the+-- source file has been modified since the last compile which produced all of+-- the output files which have been requested.+--+-- Specifically, a source file is considered unmodified if it is up-to-date+-- relative to all of the output files which have been requested. Whether or+-- not an output file is up-to-date depends on what kind of file it is:+--+-- * iface (.hi) files are considered up-to-date if (and only if) their+--   mi_src_hash field matches the hash of the source file,+--+-- * all other output files (.o, .dyn_o, .hie, etc) are considered up-to-date+--   if (and only if) their modification times on the filesystem are greater+--   than or equal to the modification time of the corresponding .hi file.+--+-- Why do we use '>=' rather than '>' for output files other than the .hi file?+-- If the filesystem has poor resolution for timestamps (e.g. FAT32 has a+-- resolution of 2 seconds), we may often find that the .hi and .o files have+-- the same modification time. Using >= is slightly unsafe, but it matches+-- make's behaviour.+--+-- This strategy allows us to do the minimum work necessary in order to ensure+-- that all the files the user cares about are up-to-date; e.g. we should not+-- worry about .o files if the user has indicated that they are not interested+-- in them via -fno-code. See also #9243.+--+-- Note that recompilation avoidance is dependent on .hi files being produced,+-- which does not happen if -fno-write-interface -fno-code is passed. That is,+-- passing -fno-write-interface -fno-code means that you cannot benefit from+-- recompilation avoidance. See also Note [-fno-code mode].+--+-- The correctness of this strategy depends on an assumption that whenever we+-- are producing multiple output files, the .hi file is always written first.+-- If this assumption is violated, we risk recompiling unnecessarily by+-- incorrectly regarding non-.hi files as outdated.+--++-- ---------------------------------------------------------------------------+--+-- | Topological sort of the module graph+topSortModuleGraph+          :: Bool+          -- ^ Drop hi-boot nodes? (see below)+          -> ModuleGraph+          -> Maybe [HomeUnitModule]+             -- ^ Root module name.  If @Nothing@, use the full graph.+          -> [SCC ModuleGraphNode]+-- ^ Calculate SCCs of the module graph, possibly dropping the hi-boot nodes+-- The resulting list of strongly-connected-components is in topologically+-- sorted order, starting with the module(s) at the bottom of the+-- dependency graph (ie compile them first) and ending with the ones at+-- the top.+--+-- Drop hi-boot nodes (first boolean arg)?+--+-- - @False@:   treat the hi-boot summaries as nodes of the graph,+--              so the graph must be acyclic+--+-- - @True@:    eliminate the hi-boot nodes, and instead pretend+--              the a source-import of Foo is an import of Foo+--              The resulting graph has no hi-boot nodes, but can be cyclic+topSortModuleGraph drop_hs_boot_nodes module_graph mb_root_mod =+  topSortModules drop_hs_boot_nodes+    (sortBy (cmpModuleGraphNodes `on` mkNodeKey) $ mgModSummaries' module_graph)+    mb_root_mod+++  where+    -- In order to get the "right" ordering+    --    Module nodes must be in reverse lexigraphic order.+    --    All modules nodes must appear before package nodes.+    --+    -- MP: This is just the ordering which the tests needed in Jan 2025, it does+    --     not arise from nature.+    --+    -- Given the current implementation of scc, the result is in+    -- The order is sensitive to the internal implementation in Data.Graph,+    -- if it changes in future then this ordering will need to be modified.+    --+    -- The SCC algorithm firstly transposes the input graph and then+    -- performs dfs on the vertices in the order which they are originally given.+    -- Therefore, if `ExternalUnit` nodes are first, the order returned will+    -- be determined by the order the dependencies are stored in the transposed graph.+    moduleGraphNodeRank :: NodeKey -> Int+    moduleGraphNodeRank k =+      case k of+        NodeKey_Unit {}         -> 0+        NodeKey_Module {}       -> 1+        NodeKey_Link {}         -> 2+        NodeKey_ExternalUnit {} -> 3++    cmpModuleGraphNodes k1 k2 = compare (moduleGraphNodeRank k1) (moduleGraphNodeRank k2)+                                  `mappend` compare k2 k1++topSortModules :: Bool -> [ModuleGraphNode] -> Maybe [HomeUnitModule] -> [SCC ModuleGraphNode]+topSortModules drop_hs_boot_nodes summaries mb_root_mod+  = map (fmap summaryNodeSummary) $ stronglyConnCompG initial_graph+  where+    (graph, lookup_node) =+      moduleGraphNodes drop_hs_boot_nodes summaries++    initial_graph = case mb_root_mod of+        Nothing -> graph+        Just mods ->+            -- restrict the graph to just those modules reachable from+            -- the specified module.  We do this by building a graph with+            -- the full set of nodes, and determining the reachable set from+            -- the specified node.+            let+              findNodeForModule (Module uid root_mod)+                | Just node <- lookup_node $ NodeKey_Module $ ModNodeKeyWithUid (GWIB root_mod NotBoot) uid+                , graph `hasVertexG` node+                = seq node node+                | otherwise+                = throwGhcException (ProgramError "module does not exist")+              roots = fmap findNodeForModule mods+            in graphFromEdgedVerticesUniq (seq roots (roots ++ allReachableMany (graphReachability graph) roots))++newtype ModNodeMap a = ModNodeMap { unModNodeMap :: Map.Map ModNodeKey a }+  deriving (Functor, Traversable, Foldable)++emptyModNodeMap :: ModNodeMap a+emptyModNodeMap = ModNodeMap Map.empty++modNodeMapInsert :: ModNodeKey -> a -> ModNodeMap a -> ModNodeMap a+modNodeMapInsert k v (ModNodeMap m) = ModNodeMap (Map.insert k v m)++modNodeMapElems :: ModNodeMap a -> [a]+modNodeMapElems (ModNodeMap m) = Map.elems m++modNodeMapLookup :: ModNodeKey -> ModNodeMap a -> Maybe a+modNodeMapLookup k (ModNodeMap m) = Map.lookup k m++modNodeMapSingleton :: ModNodeKey -> a -> ModNodeMap a+modNodeMapSingleton k v = ModNodeMap (M.singleton k v)++modNodeMapUnionWith :: (a -> a -> a) -> ModNodeMap a -> ModNodeMap a -> ModNodeMap a+modNodeMapUnionWith f (ModNodeMap m) (ModNodeMap n) = ModNodeMap (M.unionWith f m n)++-- | If there are {-# SOURCE #-} imports between strongly connected+-- components in the topological sort, then those imports can+-- definitely be replaced by ordinary non-SOURCE imports: if SOURCE+-- were necessary, then the edge would be part of a cycle.+warnUnnecessarySourceImports :: GhcMonad m => [SCC ModuleNodeInfo] -> m ()+warnUnnecessarySourceImports sccs = do+  diag_opts <- initDiagOpts <$> getDynFlags+  when (diag_wopt Opt_WarnUnusedImports diag_opts) $ do+    let check ms =+           let mods_in_this_cycle = map moduleNodeInfoModuleName ms in+           [ warn i | (ModuleNodeCompile m) <- ms, i <- ms_home_srcimps m,+                      unLoc i `notElem`  mods_in_this_cycle ]++        warn :: Located ModuleName -> MsgEnvelope GhcMessage+        warn (L loc mod) = GhcDriverMessage <$> mkPlainMsgEnvelope diag_opts+                                                  loc (DriverUnnecessarySourceImports mod)+    logDiagnostics (mkMessages $ listToBag (concatMap (check . flattenSCC) sccs))+++-----------------------------------------------------------------------------+--                      Error messages+-----------------------------------------------------------------------------++-- Defer and group warning, error and fatal messages so they will not get lost+-- in the regular output.+withDeferredDiagnostics :: GhcMonad m => m a -> m a+withDeferredDiagnostics f = do+  dflags <- getDynFlags+  if not $ gopt Opt_DeferDiagnostics dflags+  then f+  else do+    warnings <- liftIO $ newIORef []+    errors <- liftIO $ newIORef []+    fatals <- liftIO $ newIORef []+    logger <- getLogger++    let deferDiagnostics _dflags !msgClass !srcSpan !msg = do+          let action = logMsg logger msgClass srcSpan msg+          case msgClass of+            MCDiagnostic SevWarning _reason _code+              -> atomicModifyIORef' warnings $ \(!i) -> (action: i, ())+            MCDiagnostic SevError _reason _code+              -> atomicModifyIORef' errors   $ \(!i) -> (action: i, ())+            MCFatal+              -> atomicModifyIORef' fatals   $ \(!i) -> (action: i, ())+            _ -> action++        printDeferredDiagnostics = liftIO $+          forM_ [warnings, errors, fatals] $ \ref -> do+            -- This IORef can leak when the dflags leaks, so let us always+            -- reset the content. The lazy variant is used here as we want to force+            -- this error if the IORef is ever accessed again, rather than now.+            -- See #20981 for an issue which discusses this general issue.+            let landmine = if debugIsOn then panic "withDeferredDiagnostics: use after free" else []+            actions <- atomicModifyIORef ref $ \i -> (landmine, i)+            sequence_ $ reverse actions++    MC.bracket+      (pushLogHookM (const deferDiagnostics))+      (\_ -> popLogHookM >> printDeferredDiagnostics)+      (\_ -> f)++noModError :: HscEnv -> SrcSpan -> ModuleName -> FindResult -> MsgEnvelope GhcMessage+-- ToDo: we don't have a proper line number for this error+noModError hsc_env loc wanted_mod err+  = mkPlainErrorMsgEnvelope loc $ GhcDriverMessage $+    DriverInterfaceError $+    (Can'tFindInterface (cannotFindModule hsc_env wanted_mod err) (LookingForModule wanted_mod NotBoot))++{-+noHsFileErr :: SrcSpan -> String -> DriverMessages+noHsFileErr loc path+  = singleMessage $ mkPlainErrorMsgEnvelope loc (DriverFileNotFound path)+  -}++++cyclicModuleErr :: [ModuleGraphNode] -> MsgEnvelope GhcMessage+-- From a strongly connected component we find+-- a single cycle to report+cyclicModuleErr mss+  = assert (not (null mss)) $+    case findCycle graph of+       Nothing   -> pprPanic "Unexpected non-cycle" (ppr mss)+       Just path -> mkPlainErrorMsgEnvelope src_span $+                    GhcDriverMessage $ DriverModuleGraphCycle path+        where+          src_span = maybe noSrcSpan (mkFileSrcSpan . moduleNodeInfoLocation) (mgNodeIsModule (head path))+  where+    graph :: [Node NodeKey ModuleGraphNode]+    graph =+      [ DigraphNode+        { node_payload = ms+        , node_key = mkNodeKey ms+        , node_dependencies = mgNodeDependencies False ms+        }+      | ms <- mss+      ]++cleanCurrentModuleTempFilesMaybe :: MonadIO m => Logger -> TmpFs -> DynFlags -> m ()+cleanCurrentModuleTempFilesMaybe logger tmpfs dflags =+  if gopt Opt_KeepTmpFiles dflags+    then liftIO $ keepCurrentModuleTempFiles logger tmpfs+    else liftIO $ cleanCurrentModuleTempFiles logger tmpfs+++-- | Thin each HPT variable to only contain keys from the given dependencies.+-- This is used at the end of upsweep to make sure that only completely successfully loaded+-- modules are visible for subsequent operations.+restrictDepsHscEnv :: [HomeModInfo] -> HscEnv -> IO ()+restrictDepsHscEnv deps hsc_env =+  let deps_with_unit = map (\xs -> (fst (head xs), map snd xs)) $ groupBy ((==) `on` fst) (sortOn fst (map go deps))+      hug = ue_home_unit_graph $ hsc_unit_env hsc_env+      go hmi = (hmi_unit, hmi)+        where+          hmi_mod  = mi_module (hm_iface hmi)+          hmi_unit = toUnitId (moduleUnit hmi_mod)+  in HUG.restrictHug deps_with_unit hug+++setHUG ::  HomeUnitGraph -> HscEnv -> HscEnv+setHUG deps hsc_env =+  hscUpdateHUG (const $ deps) hsc_env++-- | Wrap an action to catch and handle exceptions.+wrapAction :: (GhcMessage -> AnyGhcDiagnostic) -> HscEnv -> IO a -> IO (Maybe a)+wrapAction msg_wrapper hsc_env k = do+  let lcl_logger = hsc_logger hsc_env+      lcl_dynflags = hsc_dflags hsc_env+      print_config = initPrintConfig lcl_dynflags+      logg err = printMessages lcl_logger print_config (initDiagOpts lcl_dynflags) (msg_wrapper <$> srcErrorMessages err)+  -- MP: It is a bit strange how prettyPrintGhcErrors handles some errors but then we handle+  -- SourceError and ThreadKilled differently directly below. TODO: Refactor to use `catches`+  -- directly. MP should probably use safeTry here to not catch async exceptions but that will regress performance due to+  -- internally using forkIO.+  mres <- MC.try $ prettyPrintGhcErrors lcl_logger $ k+  case mres of+    Right res -> return $ Just res+    Left exc -> do+        case fromException exc of+          Just (err :: SourceError)+            -> logg err+          Nothing -> case fromException exc of+                        -- ThreadKilled in particular needs to actually kill the thread.+                        -- So rethrow that and the other async exceptions+                        Just (err :: SomeAsyncException) -> throwIO err+                        _ -> errorMsg lcl_logger (text (show exc))+        return Nothing+++++executeInstantiationNode :: Int+  -> Int+  -> HomeUnitGraph+  -> UnitId+  -> InstantiatedUnit+  -> RunMakeM ()+executeInstantiationNode k n deps uid iu = do+        env <- ask+        -- Output of the logger is mediated by a central worker to+        -- avoid output interleaving+        msg <- asks env_messager+        wrapper <- asks diag_wrapper+        lift $ MaybeT $ withLoggerHsc k env $ \hsc_env ->+          let lcl_hsc_env = setHUG deps hsc_env+          in wrapAction wrapper lcl_hsc_env $ do+            res <- upsweep_inst lcl_hsc_env msg k n uid iu+            cleanCurrentModuleTempFilesMaybe (hsc_logger hsc_env) (hsc_tmpfs hsc_env) (hsc_dflags hsc_env)+            return res+++-- | executeCompileNode interprets how --make module should compile a ModuleNode+--+-- 1. If the ModuleNode is a ModuleNodeCompile, then we first check+--    if the interface file exists and is up to date. If it is, we return those.+--    Otherwise, we compile the module and return the new HomeModInfo.+-- 2. If the ModuleNode is a ModuleNodeFixed, then we just need to load the interface+--    and artifacts from disk.++executeCompileNode :: Int+  -> Int+  -> Maybe HomeModInfo+  -> HomeUnitGraph+  -> Maybe [ModuleName] -- List of modules we need to rehydrate before compiling+  -> ModuleNodeInfo+  -> RunMakeM HomeModInfo+executeCompileNode k n !old_hmi hug mrehydrate_mods mni = do+  me@MakeEnv{..} <- ask+  -- Rehydrate any dependencies if this module had a boot file or is a signature file.+  lift $ MaybeT (withAbstractSem compile_sem $ withLoggerHsc k me $ \hsc_env -> do+     hsc_env' <- liftIO $ maybeRehydrateBefore (setHUG hug hsc_env) mni fixed_mrehydrate_mods+     case mni of+       ModuleNodeCompile mod -> executeCompileNodeWithSource hsc_env' me  mod+       ModuleNodeFixed key loc -> executeCompileNodeFixed hsc_env' me key loc+    )++  where+    fixed_mrehydrate_mods =+      case moduleNodeInfoHscSource mni of+        -- MP: It is probably a bit of a misimplementation in backpack that+        -- compiling a signature requires an knot_var for that unit.+        -- If you remove this then a lot of backpack tests fail.+        Just HsigFile -> Just []+        _        -> mrehydrate_mods++    executeCompileNodeFixed :: HscEnv -> MakeEnv -> ModNodeKeyWithUid -> ModLocation -> IO (Maybe HomeModInfo)+    executeCompileNodeFixed hsc_env MakeEnv{diag_wrapper, env_messager} mod loc =+      wrapAction diag_wrapper hsc_env $ do+        forM_ env_messager $ \hscMessage -> hscMessage hsc_env (k, n) UpToDate (ModuleNode [] (ModuleNodeFixed mod loc))+        read_result <- readIface (hsc_hooks hsc_env) (hsc_logger hsc_env) (hsc_dflags hsc_env) (hsc_NC hsc_env) (mnkToModule mod) (ml_hi_file loc)+        case read_result of+          M.Failed interface_err ->+            let mn = mnkModuleName mod+                err = Can'tFindInterface (BadIfaceFile interface_err) (LookingForModule (gwib_mod mn) (gwib_isBoot mn))+            in throwErrors $ singleMessage $ mkPlainErrorMsgEnvelope noSrcSpan (GhcDriverMessage (DriverInterfaceError err))+          M.Succeeded iface -> do+            details <- genModDetails hsc_env iface+            mb_object <- findObjectLinkableMaybe (mi_module iface) loc+            mb_bytecode <- loadIfaceByteCodeLazy hsc_env iface loc (md_types details)+            let hm_linkable = HomeModLinkable mb_bytecode mb_object+            return (HomeModInfo iface details hm_linkable)++    executeCompileNodeWithSource :: HscEnv -> MakeEnv -> ModSummary -> IO (Maybe HomeModInfo)+    executeCompileNodeWithSource hsc_env MakeEnv{diag_wrapper, env_messager} mod = do+     let -- Use the cached DynFlags which includes OPTIONS_GHC pragmas+         lcl_dynflags = ms_hspp_opts mod+     let lcl_hsc_env =+             -- Localise the hsc_env to use the cached flags+             hscSetFlags lcl_dynflags $+             hsc_env+     -- Compile the module, locking with a semaphore to avoid too many modules+     -- being compiled at the same time leading to high memory usage.+     wrapAction diag_wrapper lcl_hsc_env $ do+      res <- upsweep_mod lcl_hsc_env env_messager old_hmi mod k n+      cleanCurrentModuleTempFilesMaybe (hsc_logger hsc_env) (hsc_tmpfs hsc_env) lcl_dynflags+      return res+++{- Rehydration, see Note [Rehydrating Modules] -}++rehydrate :: HscEnv        -- ^ The HPT in this HscEnv needs rehydrating.+          -> [HomeModInfo] -- ^ These are the modules we want to rehydrate.+          -> IO [HomeModInfo]+rehydrate hsc_env hmis = do+  debugTraceMsg logger 2 $ (+     text "Re-hydrating loop: " <+> (ppr (map (mi_module . hm_iface) hmis)))+  -- When the HPT was pure we had to tie a knot to update the ModDetails in the+  -- HPT required to update those ModDetails, but since it was made an IORef we+  -- just have to make sure the new ModDetails are "reset" so that the new+  -- modules are looked up in HPT when it is forced. If we didn't "reset" the+  -- ModDetails, modules in a loop would refer the wrong (hs-boot) definitions+  -- (as explained in Note [Rehydrating Modules]).+  mds <- initIfaceCheck (text "rehydrate") hsc_env $+            mapM (typecheckIface . hm_iface) hmis+  let new_mods = [ hmi{ hm_details = details }+                 | (hmi,details) <- zip hmis mds+                 ]+  return new_mods++  where+    logger = hsc_logger hsc_env++-- If needed, then rehydrate the necessary modules with a suitable KnotVars for the+-- module currently being compiled.+maybeRehydrateBefore :: HscEnv -> ModuleNodeInfo -> Maybe [ModuleName] -> IO HscEnv+maybeRehydrateBefore hsc_env _ Nothing = return hsc_env+maybeRehydrateBefore hsc_env mni (Just mns) = do+  knot_var <- initialise_knot_var hsc_env+  let hsc_env' = hsc_env { hsc_type_env_vars = knotVarsFromModuleEnv knot_var }+  hmis <- mapM (fmap expectJust . lookupHpt (hsc_HPT hsc_env')) mns+  hmis' <- rehydrate hsc_env' hmis+  mapM_ (\hmi -> HUG.addHomeModInfoToHug hmi (hsc_HUG hsc_env')) hmis'+  return hsc_env'++  where+   initialise_knot_var hsc_env = liftIO $+    let mod_name = homeModuleInstantiation (hsc_home_unit_maybe hsc_env) (moduleNodeInfoModule mni)+    in mkModuleEnv . (:[]) . (mod_name,) <$> newIORef emptyTypeEnv++rehydrateAfter :: HscEnv+  -> [ModuleName]+  -> IO [HomeModInfo]+rehydrateAfter hsc mns = do+  let hpt = hsc_HPT hsc+  hmis <- mapM (fmap expectJust . lookupHpt hpt) mns+  rehydrate (hsc { hsc_type_env_vars = emptyKnotVars }) hmis++{-+Note [Hydrating Modules]+~~~~~~~~~~~~~~~~~~~~~~~~+There are at least 4 different representations of an interface file as described+by this diagram.++------------------------------+|       On-disk M.hi         |+------------------------------+    |             ^+    | Read file   | Write file+    V             |+-------------------------------+|      ByteString             |+-------------------------------+    |             ^+    | Binary.get  | Binary.put+    V             |+--------------------------------+|    ModIface (an acyclic AST) |+--------------------------------+    |           ^+    | hydrate   | mkIfaceTc+    V           |+---------------------------------+|  ModDetails (lots of cycles)  |+---------------------------------++The last step, converting a ModIface into a ModDetails is known as "hydration".++Hydration happens in three different places++* When an interface file is initially loaded from disk, it has to be hydrated.+* When a module is finished compiling, we hydrate the ModIface in order to generate+  the version of ModDetails which exists in memory (see Note [ModDetails and --make mode])+* When dealing with boot files and module loops (see Note [Rehydrating Modules])++Note [Rehydrating Modules]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+If a module has a boot file then it is critical to rehydrate the modules on+the path between the two (see #20561).++Suppose we have ("R" for "recursive"):+```+R.hs-boot:   module R where+               data T+               g :: T -> T++A.hs:        module A( f, T, g ) where+                import {-# SOURCE #-} R+                data S = MkS T+                f :: T -> S = ...g...++R.hs:        module R where+                import A+                data T = T1 | T2 S+                g = ...f...+```++== Why we need to rehydrate A's ModIface before compiling R.hs++After compiling A.hs we'll have a TypeEnv in which the Id for `f` has a type+that uses the AbstractTyCon T; and a TyCon for `S` that also mentions that same+AbstractTyCon. (Abstract because it came from R.hs-boot; we know nothing about+it.)++When compiling R.hs, we build a TyCon for `T`.  But that TyCon mentions `S`, and+it currently has an AbstractTyCon for `T` inside it.  But we want to build a+fully cyclic structure, in which `S` refers to `T` and `T` refers to `S`.++Solution: **rehydration**.  *Before compiling `R.hs`*, rehydrate all the+ModIfaces below it that depend on R.hs-boot.  To rehydrate a ModIface, call+`typecheckIface` to convert it to a ModDetails.  It's just a de-serialisation+step, no type inference, just lookups.++Now `S` will be bound to a thunk that, when forced, will "see" the final binding+for `T`; see [Tying the knot](https://gitlab.haskell.org/ghc/ghc/-/wikis/commentary/compiler/tying-the-knot).+But note that this must be done *before* compiling R.hs.++== Why we need to rehydrate A's ModIface after compiling R.hs++When compiling R.hs, the knot-tying stuff above will ensure that `f`'s unfolding+mentions the `LocalId` for `g`.  But when we finish R, we carefully ensure that+all those `LocalIds` are turned into completed `GlobalIds`, replete with+unfoldings etc.   Alas, that will not apply to the occurrences of `g` in `f`'s+unfolding. And if we leave matters like that, they will stay that way, and *all*+subsequent modules that import A will see a crippled unfolding for `f`.++Solution: rehydrate both R and A's ModIface together, right after completing R.hs.++~~ Which modules to rehydrate++We only need rehydrate modules that are+* Below R.hs+* Above R.hs-boot++There might be many unrelated modules (in the home package) that don't need to be+rehydrated.++== Loops with multiple boot files++It is possible for a module graph to have a loop (SCC, when ignoring boot files)+which requires multiple boot files to break. In this case, we must perform+several hydration steps:+  1. The hydration steps described above, which are necessary for correctness.+  2. An extra hydration step at the end of compiling the entire SCC, in order to+     remove space leaks, as we explain below.++Consider the following example:++   ┌─────┐     ┌─────┐+   │  A  │     │  B  │+   └──┬──┘     └──┬──┘+      │           │+  ┌───▼───────────▼───┐+  │         C         │+  └───┬───────────┬───┘+      │           │+ ┌────▼───┐   ┌───▼────┐+ │ A-boot │   │ B-boot │+ └────────┘   └────────┘++A, B and C live together in a SCC. Suppose that we compile the modules in the+order:++  A-boot, B-boot, C, A, B.++When we come to compile A, we will perform the necessary hydration steps,+because A has a boot file. This means that C will be hydrated relative to A,+and the ModDetails for A will reference C/A. Then, when B is compiled,+C will be rehydrated again, and so B will reference C/A,B. At this point,+its interface will be hydrated relative to both A and B.+This causes a space leak: there are now two different copies of C's ModDetails,+kept alive by modules A and B. This is especially problematic if C is large.++The way to avoid this space leak is to rehydrate an entire SCC together at the+end of compilation, so that all the ModDetails point to interfaces for .hs files.+In this example, when we hydrate A, B and C together, then both A and B will refer to+C/A,B.++See #21900 for some more discussion.++== Modules "above" the loop++This dark corner is the subject of #14092.++Suppose we add to our example+```+X.hs     module X where+           import A+           data XT = MkX T+           fx = ...g...+```+If in `--make` we compile R.hs-boot, then A.hs, then X.hs, we'll get a `ModDetails` for `X` that has an AbstractTyCon for `T` in the argument type of `MkX`.  So:++* Either we should delay compiling X until after R has been compiled. (This is what we do)+* Or we should rehydrate X after compiling R -- because it transitively depends on R.hs-boot.++Ticket #20200 has exposed some issues to do with the knot-tying logic in GHC.Make, in `--make` mode.+#20200 has lots of issues, many of them now fixed;+this particular issue starts [here](https://gitlab.haskell.org/ghc/ghc/-/issues/20200#note_385758).++The wiki page [Tying the knot](https://gitlab.haskell.org/ghc/ghc/-/wikis/commentary/compiler/tying-the-knot) is helpful.+Also closely related are+    * #14092+    * #14103++-}++executeLinkNode :: HomeUnitGraph -> (Int, Int) -> UnitId -> [NodeKey] -> RunMakeM ()+executeLinkNode hug kn uid deps = do+  withCurrentUnit uid $ do+    MakeEnv{..} <- ask+    let dflags = hsc_dflags hsc_env+    let hsc_env' = setHUG hug hsc_env+        msg' = (\messager -> \recomp -> messager hsc_env kn recomp (LinkNode deps uid)) <$> env_messager++    linkresult <- liftIO $ withAbstractSem compile_sem $ do+                            link (ghcLink dflags)+                                (hsc_logger hsc_env')+                                (hsc_tmpfs hsc_env')+                                (hsc_FC hsc_env')+                                (hsc_hooks hsc_env')+                                dflags+                                (hsc_unit_env hsc_env')+                                True -- We already decided to link+                                msg'+                                (hsc_HPT hsc_env')+    case linkresult of+      Failed -> fail "Link Failed"+      Succeeded -> return ()++-- | Wait for dependencies to finish, and then return their results.+wait_deps :: [BuildResult] -> RunMakeM [HomeModInfo]+wait_deps [] = return []+wait_deps (x:xs) = do+  res <- lift $ waitResult (resultVar x)+  hmis <- wait_deps xs+  case res of+    Nothing -> return hmis+    Just hmi -> return (hmi:hmis)+++{- Note [GHC Heap Invariants]+   ~~~~~~~~~~~~~~~~~~~~~~~~~~+This note is a general place to explain some of the heap invariants which should+hold for a program compiled with --make mode. These invariants are all things+which can be checked easily using ghc-debug.++1. No HomeModInfo are reachable via the EPS.+   Why? Interfaces are lazily loaded into the EPS and the lazy thunk retains+        a reference to the entire HscEnv, if we are not careful the HscEnv will+        contain the HomePackageTable at the time the interface was loaded and+        it will never be released.+   Where? dontLeakTheHUG in GHC.Iface.Load++2. No KnotVars are live at the end of upsweep (#20491)+   Why? KnotVars contains an old stale reference to the TypeEnv for modules+        which participate in a loop. At the end of a loop all the KnotVars references+        should be removed by the call to typecheckLoop.+   Where? typecheckLoop in GHC.Driver.Make.++3. Immediately after a reload, no ModDetails are live.+   Why? During the upsweep all old ModDetails are replaced with a new ModDetails+        generated from a ModIface. If we don't clear the ModDetails before the+        reload takes place then memory usage during the reload is twice as much+        as it should be as we retain a copy of the ModDetails for too long.+   Where? pruneCache in GHC.Driver.Make++4. No TcGblEnv or TcLclEnv are live after typechecking is completed.+   Why? By the time we get to simplification all the data structures from typechecking+        should be eliminated.+   Where? No one place in the compiler. These leaks can be introduced by not suitable+          forcing functions which take a TcLclEnv as an argument.++5. At the end of a successful upsweep, the number of live ModDetails equals the+   number of non-boot Modules.+   Why? Each module has a HomeModInfo which contains a ModDetails from that module. -}
+ GHC/Driver/MakeAction.hs view
@@ -0,0 +1,248 @@+{-# LANGUAGE CPP #-}+module GHC.Driver.MakeAction+  ( MakeAction(..)+  , MakeEnv(..)+  , RunMakeM+  -- * Running the pipelines+  , runAllPipelines+  , runParPipelines+  , runSeqPipelines+  , runPipelines+  -- * Worker limit+  , WorkerLimit(..)+  , mkWorkerLimit+  , runWorkerLimit+  -- * Utility+  , withLoggerHsc+  , withParLog+  , withLocalTmpFS+  , withLocalTmpFSMake+  ) where++import GHC.Prelude+import GHC.Driver.DynFlags++import GHC.Driver.Monad+import GHC.Driver.Env+import GHC.Driver.Errors.Types+import GHC.Driver.Messager+import GHC.Driver.MakeSem++import GHC.Utils.Logger+import GHC.Utils.TmpFs++import Control.Concurrent ( newQSem, waitQSem, signalQSem, ThreadId, killThread, forkIOWithUnmask )+import qualified GHC.Conc as CC+import Control.Concurrent.MVar+import Control.Monad+import qualified Control.Monad.Catch as MC++import GHC.Conc ( getNumProcessors, getNumCapabilities, setNumCapabilities )+import Control.Monad.Trans.Reader+import GHC.Driver.Pipeline.LogQueue+import Control.Concurrent.STM+import Control.Monad.Trans.Maybe++-- Executing the pipelines++mkWorkerLimit :: DynFlags -> IO WorkerLimit+mkWorkerLimit dflags =+  case parMakeCount dflags of+    Nothing -> pure $ num_procs 1+    Just (ParMakeSemaphore h) -> pure (JSemLimit (SemaphoreName h))+    Just ParMakeNumProcessors -> num_procs <$> getNumProcessors+    Just (ParMakeThisMany n) -> pure $ num_procs n+  where+    num_procs x = NumProcessorsLimit (max 1 x)++isWorkerLimitSequential :: WorkerLimit -> Bool+isWorkerLimitSequential (NumProcessorsLimit x) = x <= 1+isWorkerLimitSequential (JSemLimit {})         = False++-- | This describes what we use to limit the number of jobs, either we limit it+-- ourselves to a specific number or we have an external parallelism semaphore+-- limit it for us.+data WorkerLimit+  = NumProcessorsLimit Int+  | JSemLimit+    SemaphoreName+      -- ^ Semaphore name to use+  deriving Eq++-- | Environment used when compiling a module+data MakeEnv = MakeEnv { hsc_env :: !HscEnv -- The basic HscEnv which will be augmented for each module+                       , compile_sem :: !AbstractSem+                       -- Modify the environment for module k, with the supplied logger modification function.+                       -- For -j1, this wrapper doesn't do anything+                       -- For -jn, the wrapper initialised a log queue and then modifies the logger to pipe its output+                       --          into the log queue.+                       , withLogger :: forall a . Int -> ((Logger -> Logger) -> IO a) -> IO a+                       , env_messager :: !(Maybe Messager)+                       , diag_wrapper :: GhcMessage -> AnyGhcDiagnostic+                       }+++label_self :: String -> IO ()+label_self thread_name = do+    self_tid <- CC.myThreadId+    CC.labelThread self_tid thread_name+++runPipelines :: WorkerLimit -> HscEnv -> (GhcMessage -> AnyGhcDiagnostic) -> Maybe Messager -> [MakeAction] -> IO ()+-- Don't even initialise plugins if there are no pipelines+runPipelines n_job hsc_env diag_wrapper mHscMessager all_pipelines = do+  liftIO $ label_self "main --make thread"+  case n_job of+    NumProcessorsLimit n | n <= 1 -> runSeqPipelines hsc_env diag_wrapper mHscMessager all_pipelines+    _n -> runParPipelines n_job hsc_env diag_wrapper mHscMessager all_pipelines++runSeqPipelines :: HscEnv -> (GhcMessage -> AnyGhcDiagnostic) -> Maybe Messager -> [MakeAction] -> IO ()+runSeqPipelines plugin_hsc_env diag_wrapper mHscMessager all_pipelines =+  let env = MakeEnv { hsc_env = plugin_hsc_env+                    , withLogger = \_ k -> k id+                    , compile_sem = AbstractSem (return ()) (return ())+                    , env_messager = mHscMessager+                    , diag_wrapper = diag_wrapper+                    }+  in runAllPipelines (NumProcessorsLimit 1) env all_pipelines++runNjobsAbstractSem :: Int -> (AbstractSem -> IO a) -> IO a+runNjobsAbstractSem n_jobs action = do+  compile_sem <- newQSem n_jobs+  n_capabilities <- getNumCapabilities+  n_cpus <- getNumProcessors+  let+    asem = AbstractSem (waitQSem compile_sem) (signalQSem compile_sem)+    set_num_caps n = unless (n_capabilities /= 1) $ setNumCapabilities n+    updNumCapabilities =  do+      -- Setting number of capabilities more than+      -- CPU count usually leads to high userspace+      -- lock contention. #9221+      set_num_caps $ min n_jobs n_cpus+    resetNumCapabilities = set_num_caps n_capabilities+  MC.bracket_ updNumCapabilities resetNumCapabilities $ action asem++runWorkerLimit :: WorkerLimit -> (AbstractSem -> IO a) -> IO a+#if defined(wasm32_HOST_ARCH)+runWorkerLimit _ action = do+  lock <- newMVar ()+  action $ AbstractSem (takeMVar lock) (putMVar lock ())+#else+runWorkerLimit worker_limit action = case worker_limit of+    NumProcessorsLimit n_jobs ->+      runNjobsAbstractSem n_jobs action+    JSemLimit sem ->+      runJSemAbstractSem sem action+#endif++-- | Build and run a pipeline+runParPipelines :: WorkerLimit -- ^ How to limit work parallelism+             -> HscEnv         -- ^ The basic HscEnv which is augmented with specific info for each module+             -> (GhcMessage -> AnyGhcDiagnostic)+             -> Maybe Messager   -- ^ Optional custom messager to use to report progress+             -> [MakeAction]  -- ^ The build plan for all the module nodes+             -> IO ()+runParPipelines worker_limit plugin_hsc_env diag_wrapper mHscMessager all_pipelines = do+++  -- A variable which we write to when an error has happened and we have to tell the+  -- logging thread to gracefully shut down.+  stopped_var <- newTVarIO False+  -- The queue of LogQueues which actions are able to write to. When an action starts it+  -- will add it's LogQueue into this queue.+  log_queue_queue_var <- newTVarIO newLogQueueQueue+  -- Thread which coordinates the printing of logs+  wait_log_thread <- logThread (hsc_logger plugin_hsc_env) stopped_var log_queue_queue_var+++  -- Make the logger thread-safe, in case there is some output which isn't sent via the LogQueue.+  thread_safe_logger <- liftIO $ makeThreadSafe (hsc_logger plugin_hsc_env)+  let thread_safe_hsc_env = plugin_hsc_env { hsc_logger = thread_safe_logger }++  runWorkerLimit worker_limit $ \abstract_sem -> do+    let env = MakeEnv { hsc_env = thread_safe_hsc_env+                      , withLogger = withParLog log_queue_queue_var+                      , compile_sem = abstract_sem+                      , env_messager = mHscMessager+                      , diag_wrapper = diag_wrapper+                      }+    -- Reset the number of capabilities once the upsweep ends.+    runAllPipelines worker_limit env all_pipelines+    atomically $ writeTVar stopped_var True+    wait_log_thread++withLoggerHsc :: Int -> MakeEnv -> (HscEnv -> IO a) -> IO a+withLoggerHsc k MakeEnv{withLogger, hsc_env} cont = do+  withLogger k $ \modifyLogger -> do+    let lcl_logger = modifyLogger (hsc_logger hsc_env)+        hsc_env' = hsc_env { hsc_logger = lcl_logger }+    -- Run continuation with modified logger+    cont hsc_env'++withParLog :: TVar LogQueueQueue -> Int -> ((Logger -> Logger) -> IO b) -> IO b+withParLog lqq_var k cont = do+  let init_log = do+        -- Make a new log queue+        lq <- newLogQueue k+        -- Add it into the LogQueueQueue+        atomically $ initLogQueue lqq_var lq+        return lq+      finish_log lq = liftIO (finishLogQueue lq)+  MC.bracket init_log finish_log $ \lq -> cont (pushLogHook (const (parLogAction lq)))++withLocalTmpFS :: TmpFs -> (TmpFs -> IO a) -> IO a+withLocalTmpFS tmpfs act = do+  let initialiser = do+        liftIO $ forkTmpFsFrom tmpfs+      finaliser tmpfs_local = do+        liftIO $ mergeTmpFsInto tmpfs_local tmpfs+       -- Add remaining files which weren't cleaned up into local tmp fs for+       -- clean-up later.+       -- Clear the logQueue if this node had it's own log queue+  MC.bracket initialiser finaliser act++withLocalTmpFSMake :: MakeEnv -> (MakeEnv -> IO a) -> IO a+withLocalTmpFSMake env k =+  withLocalTmpFS (hsc_tmpfs (hsc_env env)) $ \lcl_tmpfs+    -> k (env { hsc_env = (hsc_env env) { hsc_tmpfs = lcl_tmpfs }})+++-- | Run the given actions and then wait for them all to finish.+runAllPipelines :: WorkerLimit -> MakeEnv -> [MakeAction] -> IO ()+runAllPipelines worker_limit env acts = do+  let single_worker = isWorkerLimitSequential worker_limit+      spawn_actions :: IO [ThreadId]+      spawn_actions = if single_worker+        then (:[]) <$> (forkIOWithUnmask $ \unmask -> void $ runLoop (\io -> io unmask) env acts)+        else runLoop forkIOWithUnmask env acts++      kill_actions :: [ThreadId] -> IO ()+      kill_actions tids = mapM_ killThread tids++  MC.bracket spawn_actions kill_actions $ \_ -> do+    mapM_ waitMakeAction acts++-- | Execute each action in order, limiting the amount of parallelism by the given+-- semaphore.+runLoop :: (((forall a. IO a -> IO a) -> IO ()) -> IO a) -> MakeEnv -> [MakeAction] -> IO [a]+runLoop _ _env [] = return []+runLoop fork_thread env (MakeAction act res_var :acts) = do++  -- withLocalTmpFs has to occur outside of fork to remain deterministic+  new_thread <- withLocalTmpFSMake env $ \lcl_env ->+    fork_thread $ \unmask -> (do+            mres <- (unmask $ run_pipeline lcl_env act)+                      `MC.onException` (putMVar res_var Nothing) -- Defensive: If there's an unhandled exception then still signal the failure.+            putMVar res_var mres)+  threads <- runLoop fork_thread env acts+  return (new_thread : threads)+  where+      run_pipeline :: MakeEnv -> RunMakeM a -> IO (Maybe a)+      run_pipeline env p = runMaybeT (runReaderT p env)++type RunMakeM a = ReaderT MakeEnv (MaybeT IO) a++data MakeAction = forall a . MakeAction !(RunMakeM a) !(MVar (Maybe a))++waitMakeAction :: MakeAction -> IO ()+waitMakeAction (MakeAction _ mvar) = () <$ readMVar mvar
GHC/Driver/MakeFile.hs view
@@ -10,23 +10,24 @@  module GHC.Driver.MakeFile    ( doMkDependHS+   , doMkDependModuleGraph    ) where  import GHC.Prelude  import qualified GHC+import GHC.Driver.Make import GHC.Driver.Monad-import GHC.Driver.Session-import GHC.Driver.Ppr+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.Utils.Panic.Plain import GHC.Types.SourceError import GHC.Types.SrcLoc import GHC.Types.PkgQual@@ -52,6 +53,8 @@ import Data.Maybe       ( isJust ) import Data.IORef import qualified Data.Set as Set+import GHC.Iface.Errors.Types+import Data.Either  ----------------------------------------------------------------- --@@ -61,8 +64,6 @@  doMkDependHS :: GhcMonad m => [FilePath] -> m () doMkDependHS srcs = do-    logger <- getLogger-     -- Initialisation     dflags0 <- GHC.getSessionDynFlags @@ -84,17 +85,22 @@                  then dflags1 { depSuffixes = [""] }                  else dflags1 -    tmpfs <- hsc_tmpfs <$> getSession-    files <- liftIO $ beginMkDependHS logger tmpfs dflags-     -- Do the downsweep to find all the modules     targets <- mapM (\s -> GHC.guessTarget s Nothing Nothing) srcs     GHC.setTargets targets     let excl_mods = depExcludeMods dflags     module_graph <- GHC.depanal excl_mods True {- Allow dup roots -}+    doMkDependModuleGraph dflags module_graph -    -- Sort into dependency order-    -- There should be no cycles+++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@@ -209,20 +215,22 @@ -- -- For {-# SOURCE #-} imports the "hi" will be "hi-boot". -processDeps dflags _ _ _ _ (CyclicSCC nodes)+processDeps _ _ _ _ _ (CyclicSCC nodes)   =     -- There shouldn't be any cycles; report them-    throwGhcExceptionIO $ ProgramError $-      showSDoc dflags $ GHC.cyclicModuleErr nodes+    throwOneError $ cyclicModuleErr nodes -processDeps dflags _ _ _ _ (AcyclicSCC (InstantiationNode _uid node))+processDeps _ _ _ _ _ (AcyclicSCC (InstantiationNode _uid node))   =     -- There shouldn't be any backpack instantiations; report them as well-    throwGhcExceptionIO $ ProgramError $-      showSDoc dflags $-        vcat [ text "Unexpected backpack instantiation in dependency graph while constructing Makefile:"-             , nest 2 $ ppr node ]-processDeps _dflags _ _ _ _ (AcyclicSCC (LinkNode {})) = return ()+    throwOneError $+      mkPlainErrorMsgEnvelope noSrcSpan $+      GhcDriverMessage $ DriverInstantiationNodeInDependencyGeneration node -processDeps dflags hsc_env excl_mods root hdl (AcyclicSCC (ModuleNode _ 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@@ -252,7 +260,7 @@           -- files if the module has a corresponding .hs-boot file (#14482)         ; when (isBootSummary node == IsBoot) $ do             let hi_boot = msHiFilePath node-            let obj     = removeBootSuffix (msObjFilePath node)+            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]@@ -260,7 +268,7 @@                  -- Emit a dependency for each CPP import         ; when (depIncludeCppDeps dflags) $ do-            -- CPP deps are descovered in the module parsing phase by parsing+            -- 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).@@ -274,10 +282,10 @@          ; let do_imps is_boot idecls = sequence_                     [ do_imp loc is_boot mb_pkg mod-                    | (mb_pkg, L loc mod) <- idecls,+                    | (_lvl, mb_pkg, L loc mod) <- idecls,                       mod `notElem` excl_mods ] -        ; do_imps IsBoot (ms_srcimps node)+        ; do_imps IsBoot (map ((,,) NormalLevel NoPkgQual) (ms_srcimps node))         ; do_imps NotBoot (ms_imps node)         } @@ -292,12 +300,12 @@ 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+  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 (addBootSuffix_maybe is_boot (ml_hi_file loc)))+        -> return (Just (ml_hi_file loc))          -- Not in this package: we don't need a dependency         | otherwise@@ -306,8 +314,8 @@     fail ->         throwOneError $           mkPlainErrorMsgEnvelope srcloc $-          GhcDriverMessage $ DriverUnknownMessage $ mkPlainError noHints $-             cannotFindModule hsc_env imp fail+          GhcDriverMessage $ DriverInterfaceError $+             (Can'tFindInterface (cannotFindModule hsc_env imp fail) (LookingForModule imp is_boot))  ----------------------------- writeDependency :: FilePath -> Handle -> [FilePath] -> FilePath -> IO ()@@ -403,43 +411,63 @@ -- Print a cycle, but show only the imports within the cycle pprCycle summaries = pp_group (CyclicSCC summaries)   where-    cycle_mods :: [ModuleName]  -- The modules in this cycle-    cycle_mods = map (moduleName . ms_mod) [ms | ModuleNode _ ms <- summaries]+    cycle_keys :: [NodeKey]  -- The modules in this cycle+    cycle_keys = map mkNodeKey summaries      pp_group :: SCC ModuleGraphNode -> SDoc-    pp_group (AcyclicSCC (ModuleNode _ ms)) = pp_ms ms+    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_ms loop_breaker $$ vcat (map pp_group groups)+          pp_mod loop_deps loop_breaker $$ vcat (map pp_group groups)         where-          (boot_only, others) = partition is_boot_only mss-          is_boot_only (ModuleNode _ ms) = not (any in_group (map snd (ms_imps ms)))-          is_boot_only  _ = False-          in_group (L _ m) = m `elem` group_mods-          group_mods = map (moduleName . ms_mod) [ms | ModuleNode _ ms <- mss]+          (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_breaker = head ([ms | ModuleNode _ ms  <- boot_only])-          all_others   = tail boot_only ++ others+          (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_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_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) -    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+    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+         ]  ----------------------------------------------------------------- --
+ GHC/Driver/MakeSem.hs view
@@ -0,0 +1,545 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE NumericUnderscores #-}++-- | Implementation of a jobserver using system semaphores.+--+--+module GHC.Driver.MakeSem+  ( -- * JSem: parallelism semaphore backed+    -- by a system semaphore (Posix/Windows)+    runJSemAbstractSem++  -- * System semaphores+  , Semaphore, SemaphoreName(..)++  -- * Abstract semaphores+  , AbstractSem(..)+  , withAbstractSem+  )+  where++import GHC.Prelude+import GHC.Conc+import GHC.Data.OrdList+import GHC.IO.Exception+import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Utils.Json++import System.Semaphore++import Control.Monad+import qualified Control.Monad.Catch as MC+import Control.Concurrent.MVar+import Control.Concurrent.STM+import Data.Foldable+import Data.Functor+import GHC.Stack+import Debug.Trace++---------------------------------------+-- Semaphore jobserver++-- | A jobserver based off a system 'Semaphore'.+--+-- Keeps track of the pending jobs and resources+-- available from the semaphore.+data Jobserver+  = Jobserver+  { jSemaphore :: !Semaphore+    -- ^ The semaphore which controls available resources+  , jobs :: !(TVar JobResources)+    -- ^ The currently pending jobs, and the resources+    -- obtained from the semaphore+  }++data JobserverOptions+  = JobserverOptions+  { releaseDebounce    :: !Int+     -- ^ Minimum delay, in milliseconds, between acquiring a token+     -- and releasing a token.+  , setNumCapsDebounce :: !Int+    -- ^ Minimum delay, in milliseconds, between two consecutive+    -- calls of 'setNumCapabilities'.+  }++defaultJobserverOptions :: JobserverOptions+defaultJobserverOptions =+  JobserverOptions+    { releaseDebounce    = 1000 -- 1 second+    , setNumCapsDebounce = 1000 -- 1 second+    }++-- | Resources available for running jobs, i.e.+-- tokens obtained from the parallelism semaphore.+data JobResources+  = Jobs+  { tokensOwned :: !Int+    -- ^ How many tokens have been claimed from the semaphore+  , tokensFree  :: !Int+    -- ^ How many tokens are not currently being used+  , jobsWaiting :: !(OrdList (TMVar ()))+    -- ^ Pending jobs waiting on a token, the job will be blocked on the TMVar so putting into+    -- the TMVar will allow the job to continue.+  }++instance Outputable JobResources where+  ppr Jobs{..}+    = text "JobResources" <+>+        ( braces $ hsep+          [ text "owned=" <> ppr tokensOwned+          , text "free=" <> ppr tokensFree+          , text "num_waiting=" <> ppr (length jobsWaiting)+          ] )++-- | Add one new token.+addToken :: JobResources -> JobResources+addToken jobs@( Jobs { tokensOwned = owned, tokensFree = free })+  = jobs { tokensOwned = owned + 1, tokensFree = free + 1 }++-- | Free one token.+addFreeToken :: JobResources -> JobResources+addFreeToken jobs@( Jobs { tokensFree = free })+  = assertPpr (tokensOwned jobs > free)+      (text "addFreeToken:" <+> ppr (tokensOwned jobs) <+> ppr free)+  $ jobs { tokensFree = free + 1 }++-- | Use up one token.+removeFreeToken :: JobResources -> JobResources+removeFreeToken jobs@( Jobs { tokensFree = free })+  = assertPpr (free > 0)+      (text "removeFreeToken:" <+> ppr free)+  $ jobs { tokensFree = free - 1 }++-- | Return one owned token.+removeOwnedToken :: JobResources -> JobResources+removeOwnedToken jobs@( Jobs { tokensOwned = owned })+  = assertPpr (owned > 1)+      (text "removeOwnedToken:" <+> ppr owned)+  $ jobs { tokensOwned = owned - 1 }++-- | Add one new job to the end of the list of pending jobs.+addJob :: TMVar () -> JobResources -> JobResources+addJob job jobs@( Jobs { jobsWaiting = wait })+  = jobs { jobsWaiting = wait `SnocOL` job }++-- | The state of the semaphore job server.+data JobserverState+  = JobserverState+    { jobserverAction  :: !JobserverAction+      -- ^ The current action being performed by the+      -- job server.+    , canChangeNumCaps :: !(TVar Bool)+      -- ^ A TVar that signals whether it has been long+      -- enough since we last changed 'numCapabilities'.+    , canReleaseToken  :: !(TVar Bool)+      -- ^ A TVar that signals whether we last acquired+      -- a token long enough ago that we can now release+      -- a token.+    }+data JobserverAction+  -- | The jobserver is idle: no thread is currently+  -- interacting with the semaphore.+  = Idle+  -- | A thread is waiting for a token on the semaphore.+  | Acquiring+    { activeWaitId   :: WaitId+    , threadFinished :: TMVar (Maybe MC.SomeException) }++-- | Retrieve the 'TMVar' that signals if the current thread has finished,+-- if any thread is currently active in the jobserver.+activeThread_maybe :: JobserverAction -> Maybe (TMVar (Maybe MC.SomeException))+activeThread_maybe Idle                                   = Nothing+activeThread_maybe (Acquiring { threadFinished = tmvar }) = Just tmvar++-- | Whether we should try to acquire a new token from the semaphore:+-- there is a pending job and no free tokens.+guardAcquire :: JobResources -> Bool+guardAcquire ( Jobs { tokensFree, jobsWaiting } )+  = tokensFree == 0 && not (null jobsWaiting)++-- | Whether we should release a token from the semaphore:+-- there are no pending jobs and we can release a token.+guardRelease :: JobResources -> Bool+guardRelease ( Jobs { tokensFree, tokensOwned, jobsWaiting } )+  = null jobsWaiting && tokensFree > 0 && tokensOwned > 1++---------------------------------------+-- Semaphore jobserver implementation++-- | Add one pending job to the jobserver.+--+-- Blocks, waiting on the jobserver to supply a free token.+acquireJob :: TVar JobResources -> IO ()+acquireJob jobs_tvar = do+  (job_tmvar, _jobs0) <- tracedAtomically "acquire" $+    modifyJobResources jobs_tvar \ jobs -> do+      job_tmvar <- newEmptyTMVar+      return ((job_tmvar, jobs), addJob job_tmvar jobs)+  atomically $ takeTMVar job_tmvar++-- | Signal to the job server that one job has completed,+-- releasing its corresponding token.+releaseJob :: TVar JobResources -> IO ()+releaseJob jobs_tvar = do+  tracedAtomically "release" do+    modifyJobResources jobs_tvar \ jobs -> do+      massertPpr (tokensFree jobs < tokensOwned jobs)+        (text "releaseJob: more free jobs than owned jobs!")+      return ((), addFreeToken jobs)+++-- | Release all tokens owned from the semaphore (to clean up+-- the jobserver at the end).+cleanupJobserver :: Jobserver -> IO ()+cleanupJobserver (Jobserver { jSemaphore = sem+                            , jobs       = jobs_tvar })+  = do+    Jobs { tokensOwned = owned } <- readTVarIO jobs_tvar+    let toks_to_release = owned - 1+      -- Subtract off the implicit token: whoever spawned the ghc process+      -- in the first place is responsible for that token.+    releaseSemaphore sem toks_to_release++-- | Dispatch the available tokens acquired from the semaphore+-- to the pending jobs in the job server.+dispatchTokens :: JobResources -> STM JobResources+dispatchTokens jobs@( Jobs { tokensFree = toks_free, jobsWaiting = wait } )+  | toks_free > 0+  , next `ConsOL` rest <- wait+  -- There's a pending job and a free token:+  -- pass on the token to that job, and recur.+  = do+      putTMVar next ()+      let jobs' = jobs { tokensFree = toks_free - 1, jobsWaiting = rest }+      dispatchTokens jobs'+  | otherwise+  = return jobs++-- | Update the available resources used from a semaphore, dispatching+-- any newly acquired resources.+--+-- Invariant: if the number of available resources decreases, there+-- must be no pending jobs.+--+-- All modifications should go through this function to ensure the contents+-- of the 'TVar' remains in normal form.+modifyJobResources :: HasCallStack => TVar JobResources+                   -> (JobResources -> STM (a, JobResources))+                   -> STM (a, Maybe JobResources)+modifyJobResources jobs_tvar action = do+  old_jobs  <- readTVar jobs_tvar+  (a, jobs) <- action old_jobs++  -- Check the invariant: if the number of free tokens has decreased,+  -- there must be no pending jobs.+  massertPpr (null (jobsWaiting jobs) || tokensFree jobs >= tokensFree old_jobs) $+    vcat [ text "modiyJobResources: pending jobs but fewer free tokens" ]+  dispatched_jobs <- dispatchTokens jobs+  writeTVar jobs_tvar dispatched_jobs+  return (a, Just dispatched_jobs)+++tracedAtomically_ :: String -> STM (Maybe JobResources) -> IO ()+tracedAtomically_ s act = tracedAtomically s (((),) <$> act)++tracedAtomically :: String -> STM (a, Maybe JobResources) -> IO a+tracedAtomically origin act = do+  (a, mjr) <- atomically act+  forM_ mjr $ \ jr -> do+    -- Use the "jsem:" prefix to identify where the write traces are+    traceEventIO ("jsem:" ++ renderJobResources origin jr)+  return a++renderJobResources :: String -> JobResources -> String+renderJobResources origin (Jobs own free pending) = showSDocUnsafe $ renderJSON $+  JSObject [ ("name", JSString origin)+           , ("owned", JSInt own)+           , ("free", JSInt free)+           , ("pending", JSInt (length pending) )+           ]+++-- | Spawn a new thread that waits on the semaphore in order to acquire+-- an additional token.+acquireThread :: Jobserver -> IO JobserverAction+acquireThread (Jobserver { jSemaphore = sem, jobs = jobs_tvar }) = do+    threadFinished_tmvar <- newEmptyTMVarIO+    let+      wait_result_action :: Either MC.SomeException Bool -> IO ()+      wait_result_action wait_res =+        tracedAtomically_ "acquire_thread" do+          (r, jb) <- case wait_res of+            Left (e :: MC.SomeException) -> do+              return $ (Just e, Nothing)+            Right success -> do+              if success+                then do+                  modifyJobResources jobs_tvar \ jobs ->+                    return (Nothing, addToken jobs)+                else+                  return (Nothing, Nothing)+          putTMVar threadFinished_tmvar r+          return jb+    wait_id <- forkWaitOnSemaphoreInterruptible sem wait_result_action+    labelThread (waitingThreadId wait_id) "acquire_thread"+    return $ Acquiring { activeWaitId   = wait_id+                       , threadFinished = threadFinished_tmvar }++-- | Spawn a thread to release ownership of one resource from the semaphore,+-- provided we have spare resources and no pending jobs.+releaseThread :: Jobserver -> IO JobserverAction+releaseThread (Jobserver { jSemaphore = sem, jobs = jobs_tvar }) = do+  threadFinished_tmvar <- newEmptyTMVarIO+  MC.mask_ do+    -- Pre-release the resource so that another thread doesn't take control of it+    -- just as we release the lock on the semaphore.+    still_ok_to_release+      <- tracedAtomically "pre_release" $+         modifyJobResources jobs_tvar \ jobs ->+           if guardRelease jobs+               -- TODO: should this also debounce?+           then return (True , removeOwnedToken $ removeFreeToken jobs)+           else return (False, jobs)+    if not still_ok_to_release+    then return Idle+    else do+      tid <- forkIO $ do+        x <- MC.try $ releaseSemaphore sem 1+        tracedAtomically_ "post-release" $ do+          (r, jobs) <- case x of+            Left (e :: MC.SomeException) -> do+              modifyJobResources jobs_tvar \ jobs ->+                return (Just e, addToken jobs)+            Right _ -> do+              return (Nothing, Nothing)+          putTMVar threadFinished_tmvar r+          return jobs+      labelThread tid "release_thread"+      return Idle++-- | When there are pending jobs but no free tokens,+-- spawn a thread to acquire a new token from the semaphore.+--+-- See 'acquireThread'.+tryAcquire :: JobserverOptions+           -> Jobserver+           -> JobserverState+           -> STM (IO JobserverState)+tryAcquire opts js@( Jobserver { jobs = jobs_tvar })+  st@( JobserverState { jobserverAction = Idle } )+  = do+    jobs <- readTVar jobs_tvar+    guard $ guardAcquire jobs+    return do+      action           <- acquireThread js+      -- Set a debounce after acquiring a token.+      can_release_tvar <- registerDelay $ (releaseDebounce opts * 1000)+      return $ st { jobserverAction = action+                  , canReleaseToken = can_release_tvar }+tryAcquire _ _ _ = retry++-- | When there are free tokens and no pending jobs,+-- spawn a thread to release a token from the semaphore.+--+-- See 'releaseThread'.+tryRelease :: Jobserver+           -> JobserverState+           -> STM (IO JobserverState)+tryRelease sjs@( Jobserver { jobs = jobs_tvar } )+  st@( JobserverState+      { jobserverAction = Idle+      , canReleaseToken = can_release_tvar } )+  = do+    jobs <- readTVar jobs_tvar+    guard  $ guardRelease jobs+    can_release <- readTVar can_release_tvar+    guard can_release+    return do+      action <- releaseThread sjs+      return $ st { jobserverAction = action }+tryRelease _ _ = retry++-- | Wait for an active thread to finish. Once it finishes:+--+--  - set the 'JobserverAction' to 'Idle',+--  - update the number of capabilities to reflect the number+--    of owned tokens from the semaphore.+tryNoticeIdle :: JobserverOptions+              -> TVar JobResources+              -> JobserverState+              -> STM (IO JobserverState)+tryNoticeIdle opts jobs_tvar jobserver_state+  | Just threadFinished_tmvar <- activeThread_maybe $ jobserverAction jobserver_state+  = sync_num_caps (canChangeNumCaps jobserver_state) threadFinished_tmvar+  | otherwise+  = retry -- no active thread: wait until jobserver isn't idle+  where+    sync_num_caps :: TVar Bool+                  -> TMVar (Maybe MC.SomeException)+                  -> STM (IO JobserverState)+    sync_num_caps can_change_numcaps_tvar threadFinished_tmvar = do+      mb_ex <- takeTMVar threadFinished_tmvar+      for_ mb_ex MC.throwM+      Jobs { tokensOwned } <- readTVar jobs_tvar+      can_change_numcaps <- readTVar can_change_numcaps_tvar+      guard can_change_numcaps+      return do+        x <- getNumCapabilities+        can_change_numcaps_tvar_2 <-+          if x == tokensOwned+          then return can_change_numcaps_tvar+          else do+            setNumCapabilities tokensOwned+            registerDelay $ (setNumCapsDebounce opts * 1000)+        return $+          jobserver_state+            { jobserverAction  = Idle+            , canChangeNumCaps = can_change_numcaps_tvar_2 }++-- | Try to stop the current thread which is acquiring/releasing resources+-- if that operation is no longer relevant.+tryStopThread :: TVar JobResources+              -> JobserverState+              -> STM (IO JobserverState)+tryStopThread jobs_tvar jsj = do+  case jobserverAction jsj of+    Acquiring { activeWaitId = wait_id } -> do+     jobs <- readTVar jobs_tvar+     guard $ null (jobsWaiting jobs)+     return do+       interruptWaitOnSemaphore wait_id+       return $ jsj { jobserverAction = Idle }+    _ -> retry++-- | Main jobserver loop: acquire/release resources as+-- needed for the pending jobs and available semaphore tokens.+jobserverLoop :: JobserverOptions -> Jobserver -> IO ()+jobserverLoop opts sjs@(Jobserver { jobs = jobs_tvar })+  = do+      true_tvar <- newTVarIO True+      let init_state :: JobserverState+          init_state =+            JobserverState+              { jobserverAction  = Idle+              , canChangeNumCaps = true_tvar+              , canReleaseToken  = true_tvar }+      loop init_state+  where+    loop s = do+      action <- atomically $ asum $ (\x -> x s) <$>+        [ tryRelease    sjs+        , tryAcquire    opts sjs+        , tryNoticeIdle opts jobs_tvar+        , tryStopThread jobs_tvar+        ]+      s <- action+      loop s++-- | Create a new jobserver using the given semaphore handle.+makeJobserver :: SemaphoreName -> IO (AbstractSem, IO ())+makeJobserver sem_name = do+  semaphore <- openSemaphore sem_name+  let+    init_jobs =+      Jobs { tokensOwned = 1+           , tokensFree  = 1+           , jobsWaiting = NilOL+           }+  jobs_tvar <- newTVarIO init_jobs+  let+    opts = defaultJobserverOptions -- TODO: allow this to be configured+    sjs = Jobserver { jSemaphore = semaphore+                    , jobs       = jobs_tvar }+  loop_finished_mvar <- newEmptyMVar+  loop_tid <- forkIOWithUnmask \ unmask -> do+    r <- try $ unmask $ jobserverLoop opts sjs+    putMVar loop_finished_mvar $+      case r of+        Left e+          | Just ThreadKilled <- fromException e+          -> Nothing+          | otherwise+          -> Just e+        Right () -> Nothing+  labelThread loop_tid "job_server"+  let+    acquireSem = acquireJob jobs_tvar+    releaseSem = releaseJob jobs_tvar+    cleanupSem = do+      -- this is interruptible+      cleanupJobserver sjs+      killThread loop_tid+      mb_ex <- takeMVar loop_finished_mvar+      for_ mb_ex MC.throwM++  return (AbstractSem{..}, cleanupSem)++-- | Implement an abstract semaphore using a semaphore 'Jobserver'+-- which queries the system semaphore of the given name for resources.+runJSemAbstractSem :: SemaphoreName         -- ^ the system semaphore to use+                   -> (AbstractSem -> IO a) -- ^ the operation to run+                                            -- which requires a semaphore+                   -> IO a+runJSemAbstractSem sem action = MC.mask \ unmask -> do+  (abs, cleanup) <- makeJobserver sem+  r <- try $ unmask $ action abs+  case r of+    Left (e1 :: MC.SomeException) -> do+      (_ :: Either MC.SomeException ()) <- MC.try cleanup+      MC.throwM e1+    Right x -> cleanup $> x++{- Note [Architecture of the Job Server]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In `-jsem` mode, the amount of parallelism that GHC can use is controlled by a+system semaphore. We take resources from the semaphore when we need them, and+give them back if we don't have enough to do.++A naive implementation would just take and release the semaphore around performing+the action, but this leads to two issues:++* When taking a token in the semaphore, we must call `setNumCapabilities` in order+  to adjust how many capabilities are available for parallel garbage collection.+  This causes unnecessary synchronisations.+* We want to implement a debounce, so that whilst there is pending work in the+  current process we prefer to keep hold of resources from the semaphore.+  This reduces overall memory usage, as there are fewer live GHC processes at once.++Therefore, the obtention of semaphore resources is separated away from the+request for the resource in the driver.++A token from the semaphore is requested using `acquireJob`. This creates a pending+job, which is a MVar that can be filled in to signal that the requested token is ready.++When the job is finished, the token is released by calling `releaseJob`, which just+increases the number of `free` jobs. If there are more pending jobs when the free count+is increased, the token is immediately reused (see `modifyJobResources`).++The `jobServerLoop` interacts with the system semaphore: when there are pending+jobs, `acquireThread` blocks, waiting for a token from the semaphore. Once a+token is obtained, it increases the owned count.++When GHC has free tokens (tokens from the semaphore that it is not using),+no pending jobs, and the debounce has expired, then `releaseThread` will+release tokens back to the global semaphore.++`tryStopThread` attempts to kill threads which are waiting to acquire a resource+when we no longer need it. For example, consider that we attempt to acquire two+tokens, but the first job finishes before we acquire the second token.+This second token is no longer needed, so we should cancel the wait+(as it would not be used to do any work, and not be returned until the debounce).+We only need to kill `acquireJob`, because `releaseJob` never blocks.++Note [Eventlog Messages for jsem]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It can be tricky to verify that the work is shared adequately across different+processes. To help debug this, we output the values of `JobResource` to the+eventlog whenever the global state changes. There are some scripts which can be used+to analyse this output and report statistics about core saturation in the+GitHub repo (https://github.com/mpickering/ghc-jsem-analyse).++-}
+ GHC/Driver/Messager.hs view
@@ -0,0 +1,66 @@+module GHC.Driver.Messager (Messager, oneShotMsg, batchMsg, batchMultiMsg, showModuleIndex) where++import GHC.Prelude+import GHC.Driver.Env+import GHC.Unit.Module.Graph+import GHC.Iface.Recomp+import GHC.Utils.Logger+import GHC.Utils.Outputable+import GHC.Utils.Error+import GHC.Unit.State++type Messager = HscEnv -> (Int,Int) -> RecompileRequired -> ModuleGraphNode -> IO ()++--------------------------------------------------------------+-- Progress displayers.+--------------------------------------------------------------++oneShotMsg :: Logger -> RecompileRequired -> IO ()+oneShotMsg logger recomp =+    case recomp of+        UpToDate -> compilationProgressMsg logger $ text "compilation IS NOT required"+        NeedsRecompile _ -> return ()++batchMsg :: Messager+batchMsg = batchMsgWith (\_ _ _ _ -> empty)+batchMultiMsg :: Messager+batchMultiMsg = batchMsgWith (\_ _ _ node -> brackets (ppr (mgNodeUnitId node)))++batchMsgWith :: (HscEnv -> (Int, Int) -> RecompileRequired -> ModuleGraphNode -> SDoc) -> Messager+batchMsgWith extra hsc_env_start mod_index recomp node =+      case recomp of+        UpToDate+          | logVerbAtLeast logger 2 -> showMsg (text "Skipping") empty+          | otherwise -> return ()+        NeedsRecompile reason0 -> showMsg (text herald) $ case reason0 of+          MustCompile            -> empty+          (RecompBecause reason) -> text " [" <> pprWithUnitState state (ppr reason) <> text "]"+    where+        herald = case node of+                    LinkNode {} -> "Linking"+                    InstantiationNode {} -> "Instantiating"+                    ModuleNode {} -> "Compiling"+                    UnitNode {} -> "Loading"+        hsc_env = hscSetActiveUnitId (mgNodeUnitId node) hsc_env_start+        dflags = hsc_dflags hsc_env+        logger = hsc_logger hsc_env+        state  = hsc_units hsc_env+        showMsg msg reason =+            compilationProgressMsg logger $+            (showModuleIndex mod_index <>+            msg <+> showModMsg dflags (recompileRequired recomp) node)+                <> extra hsc_env mod_index recomp node+                <> reason++{- **********************************************************************+%*                                                                      *+        Progress Messages: Module i of n+%*                                                                      *+%********************************************************************* -}++showModuleIndex :: (Int, Int) -> SDoc+showModuleIndex (i,n) = text "[" <> pad <> int i <> text " of " <> int n <> text "] "+  where+    -- compute the length of x > 0 in base 10+    len x = ceiling (logBase 10 (fromIntegral x+1) :: Float)+    pad = text (replicate (len n - len i) ' ') -- TODO: use GHC.Utils.Ppr.RStr
GHC/Driver/Monad.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveFunctor, DerivingVia, RankNTypes #-}+{-# LANGUAGE DerivingVia, NoPolyKinds #-} {-# OPTIONS_GHC -funbox-strict-fields #-} -- ----------------------------------------------------------------------------- --@@ -23,6 +23,8 @@         modifyLogger,         pushLogHookM,         popLogHookM,+        pushJsonLogHookM,+        popJsonLogHookM,         putLogMsgM,         putMsgM,         withTimingM,@@ -34,7 +36,7 @@  import GHC.Prelude -import GHC.Driver.Session+import GHC.Driver.DynFlags import GHC.Driver.Env import GHC.Driver.Errors ( printOrThrowDiagnostics, printMessages ) import GHC.Driver.Errors.Types@@ -121,6 +123,12 @@ 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@@ -147,15 +155,16 @@   dflags <- getSessionDynFlags   logger <- getLogger   let !diag_opts = initDiagOpts dflags-  liftIO $ printOrThrowDiagnostics logger diag_opts warns+      !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 (Functor)-  deriving (MonadThrow, MonadCatch, MonadMask) via (ReaderT Session IO)+  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@@ -163,19 +172,6 @@ -- interactive evaluation, and various caches. data Session = Session !(IORef HscEnv) -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 HasDynFlags Ghc where   getDynFlags = getSessionDynFlags @@ -213,22 +209,12 @@ -- -- Note that the wrapped monad must support IO and handling of exceptions. newtype GhcT m a = GhcT { unGhcT :: Session -> m a }-  deriving (Functor)-  deriving (MonadThrow, MonadCatch, MonadMask) via (ReaderT Session m)+  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 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 MonadIO m => HasDynFlags (GhcT m) where   getDynFlags = GhcT $ \(Session r) -> liftM hsc_dflags (liftIO $ readIORef r) @@ -247,7 +233,8 @@   dflags <- getDynFlags   logger <- getLogger   let !diag_opts = initDiagOpts dflags-  liftIO $ printMessages logger diag_opts (srcErrorMessages err)+      !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 ()
GHC/Driver/Phases.hs view
@@ -23,6 +23,7 @@    isDynLibSuffix,    isHaskellUserSrcSuffix,    isHaskellSigSuffix,+   isHaskellBootSuffix,    isSourceSuffix,     isHaskellishTarget,@@ -99,6 +100,7 @@         | 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@@ -134,6 +136,7 @@ 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@@ -157,14 +160,15 @@       LlvmLlc    -> LlvmMangle       LlvmMangle -> As False       As _       -> MergeForeign-      Ccxx       -> As False-      Cc         -> As False-      Cobjc      -> As False-      Cobjcxx    -> As False+      Ccxx       -> MergeForeign+      Cc         -> MergeForeign+      Cobjc      -> MergeForeign+      Cobjcxx    -> MergeForeign       CmmCpp     -> Cmm       Cmm        -> maybeHCc-      HCc        -> As False+      HCc        -> MergeForeign       MergeForeign -> StopLn+      Js         -> StopLn       StopLn     -> panic "nextPhase: nothing after StopLn"     where maybeHCc = if platformUnregisterised platform                      then HCc@@ -198,6 +202,7 @@ 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@@ -226,10 +231,11 @@ phaseInputExt CmmCpp              = "cmmcpp" phaseInputExt Cmm                 = "cmm" phaseInputExt MergeForeign        = "o"+phaseInputExt Js                  = "js" phaseInputExt StopLn              = "o"  haskellish_src_suffixes, backpackish_suffixes, haskellish_suffixes, cish_suffixes,-    haskellish_user_src_suffixes, haskellish_sig_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.@@ -238,10 +244,12 @@ 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 ++ [ "hs", "lhs", "hs-boot", "lhs-boot" ]+  haskellish_sig_suffixes ++ haskellish_boot_suffixes ++ [ "hs", "lhs" ]+haskellish_boot_suffixes     = [ "hs-boot", "lhs-boot" ] haskellish_sig_suffixes      = [ "hsig", "lhsig" ] backpackish_suffixes         = [ "bkp" ] @@ -259,13 +267,15 @@   _         -> ["so"]  isHaskellishSuffix, isBackpackishSuffix, isHaskellSrcSuffix, isCishSuffix,-    isHaskellUserSrcSuffix, isHaskellSigSuffix+    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@@ -275,6 +285,7 @@ isSourceSuffix :: String -> Bool isSourceSuffix suff  = isHaskellishSuffix suff                     || isCishSuffix suff+                    || isJsSuffix suff                     || isBackpackishSuffix suff  -- | When we are given files (modified by -x arguments) we need@@ -291,7 +302,7 @@ isHaskellishTarget (f,Nothing) =   looksLikeModuleName f || isHaskellSrcFilename f || not (hasExtension f) isHaskellishTarget (_,Just phase) =-  phase `notElem` [ As True, As False, Cc, Cobjc, Cobjcxx, CmmCpp, Cmm+  phase `notElem` [ As True, As False, Cc, Cobjc, Cobjcxx, CmmCpp, Cmm, Js                   , StopLn]  isHaskellishFilename, isHaskellSrcFilename, isCishFilename,@@ -319,5 +330,5 @@   HCc          -> Just LangC   As _         -> Just LangAsm   MergeForeign -> Just RawObject+  Js           -> Just LangJs   _            -> Nothing-
GHC/Driver/Pipeline.hs view
@@ -1,12 +1,7 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE BangPatterns #-}--{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE NondecreasingIndentation #-}-{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE LambdaCase #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NondecreasingIndentation #-}+{-# LANGUAGE ViewPatterns #-}  ----------------------------------------------------------------------------- --@@ -40,7 +35,7 @@    TPipelineClass, MonadUse(..),     preprocessPipeline, fullPipeline, hscPipeline, hscBackendPipeline, hscPostBackendPipeline,-   hscGenBackendPipeline, asPipeline, viaCPipeline, cmmCppPipeline, cmmPipeline,+   hscGenBackendPipeline, asPipeline, viaCPipeline, cmmCppPipeline, cmmPipeline, jsPipeline,    llvmPipeline, llvmLlcPipeline, llvmManglePipeline, pipelineStart,     -- * Default method of running a pipeline@@ -49,6 +44,7 @@   import GHC.Prelude+import GHC.Builtin.Names  import GHC.Platform @@ -60,6 +56,7 @@ 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@@ -71,6 +68,7 @@ import GHC.Platform.Ways  import GHC.SysTools+import GHC.SysTools.Cpp import GHC.Utils.TmpFs  import GHC.Linker.ExtraObj@@ -78,6 +76,8 @@ 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@@ -92,11 +92,13 @@ 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 )+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@@ -104,12 +106,11 @@  import GHC.Unit import GHC.Unit.Env---import GHC.Unit.Finder---import GHC.Unit.State+import GHC.Unit.Finder import GHC.Unit.Module.ModSummary import GHC.Unit.Module.ModIface-import GHC.Unit.Module.Deps import GHC.Unit.Home.ModInfo+import GHC.Unit.Home.PackageTable  import System.Directory import System.FilePath@@ -117,11 +118,13 @@ import Control.Monad import qualified Control.Monad.Catch as MC (handle) import Data.Maybe-import Data.Either      ( partitionEithers ) import qualified Data.Set as Set+import 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@@ -155,13 +158,14 @@     handler (ProgramError msg) =       return $ Left $ singleMessage $         mkPlainErrorMsgEnvelope srcspan $-        DriverUnknownMessage $ mkPlainError noHints $ text msg+        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"-                             (vcat $ pprMsgEnvelopeBagWithLoc (getMessages msgs))+                             -- 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@@ -209,7 +213,7 @@            -> Int             -- ^ module N ...            -> Int             -- ^ ... of M            -> Maybe ModIface  -- ^ old interface, if we have one-           -> Maybe Linkable  -- ^ old linkable, if we have one+           -> HomeModLinkable  -- ^ old linkable, if we have one            -> IO HomeModInfo   -- ^ the complete HomeModInfo, if successful  compileOne = compileOne' (Just batchMsg)@@ -220,7 +224,7 @@             -> Int             -- ^ module N ...             -> Int             -- ^ ... of M             -> Maybe ModIface  -- ^ old interface, if we have one-            -> Maybe Linkable  -- ^ old linkable, if we have one+            -> HomeModLinkable             -> IO HomeModInfo   -- ^ the complete HomeModInfo, if successful  compileOne' mHscMessage@@ -229,33 +233,31 @@     debugTraceMsg logger 2 (text "compile: input file" <+> text input_fnpp) -   let flags = hsc_dflags hsc_env0-     in do unless (gopt Opt_KeepHiFiles flags) $-               addFilesToClean tmpfs TFL_CurrentModule $-                   [ml_hi_file $ ms_location summary]-           unless (gopt Opt_KeepOFiles flags) $-               addFilesToClean tmpfs TFL_GhcSession $-                   [ml_obj_file $ ms_location summary]+   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 hsc_env) pipeline+   (iface, linkable) <- runPipeline (hsc_hooks plugin_hsc_env) pipeline    -- See Note [ModDetails and --make mode]-   details <- initModDetails plugin_hsc_env upd_summary iface-   return $! HomeModInfo iface details linkable+   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 "compile:hs" (ml_hs_file location)+       input_fn    = expectJust (ml_hs_file location)        input_fnpp  = ms_hspp_file summary -       pipelineOutput = case bcknd of-         Interpreter -> NoOutputFile-         NoBackend -> NoOutputFile-         _ -> Persistent+       pipelineOutput = backendPipelineOutput bcknd         logger = hsc_logger hsc_env0        tmpfs  = hsc_tmpfs hsc_env0@@ -279,7 +281,10 @@          -- was set), force it to generate byte-code. This is NOT transitive and          -- only applies to direct targets.          | loadAsByteCode-         = (Interpreter, gopt_set (lcl_dflags { backend = Interpreter }) Opt_ForceRecomp)+         = ( interpreterBackend+           , gopt_set (lcl_dflags { backend = interpreterBackend }) Opt_ForceRecomp+           )+          | otherwise          = (backend dflags, lcl_dflags)        -- See Note [Filepaths and Multiple Home Units]@@ -342,6 +347,7 @@ link :: GhcLink                 -- ^ interactive or batch      -> Logger                  -- ^ Logger      -> TmpFs+     -> FinderCache      -> Hooks      -> DynFlags                -- ^ dynamic flags      -> UnitEnv                 -- ^ unit environment@@ -357,23 +363,23 @@ -- exports main, i.e., we have good reason to believe that linking -- will succeed. -link ghcLink logger tmpfs hooks dflags unit_env batch_attempt_linking mHscMessage hpt =+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+        NoLink        -> return Succeeded+        LinkBinary    -> normal_link+        LinkStaticLib -> normal_link+        LinkDynLib    -> normal_link+        LinkMergedObj -> normal_link+        LinkInMemory+          | platformMisc_ghcWithInterpreter $ platformMisc dflags+           -- Not Linking...(demand linker will do the job)+            -> return Succeeded+          | otherwise+            -> panicBadLink LinkInMemory       Just h  -> h ghcLink dflags batch_attempt_linking hpt   where-    normal_link = link' logger tmpfs dflags unit_env batch_attempt_linking mHscMessage hpt+    normal_link = link' logger tmpfs fc dflags unit_env batch_attempt_linking mHscMessage hpt   panicBadLink :: GhcLink -> a@@ -382,6 +388,7 @@  link' :: Logger       -> TmpFs+      -> FinderCache       -> DynFlags                -- ^ dynamic flags       -> UnitEnv                 -- ^ unit environment       -> Bool                    -- ^ attempt linking in batch mode?@@ -389,7 +396,7 @@       -> HomePackageTable        -- ^ what to link       -> IO SuccessFlag -link' logger tmpfs dflags unit_env batch_attempt_linking mHscMessager hpt+link' logger tmpfs fc dflags unit_env batch_attempt_linking mHscMessager hpt    | batch_attempt_linking    = do         let@@ -397,18 +404,20 @@                           LinkStaticLib -> True                           _ -> False -            home_mod_infos = eltsHpt hpt+        -- 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 packages we depend on-            pkg_deps  = Set.toList-                          $ Set.unions-                          $ fmap (dep_direct_pkgs . mi_deps . hm_iface)-                          $ home_mod_infos+        -- the linkables to link+        linkables <- hptCollectObjects hpt -            -- the linkables to link-            linkables = map (expectJust "link".hm_linkable) home_mod_infos+        -- 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)@@ -416,10 +425,10 @@                   return Succeeded           else do -        let getOfiles LM{ linkableUnlinked } = map nameOfObject (filter isObject linkableUnlinked)-            obj_files = concatMap getOfiles linkables+        let obj_files = concatMap linkableObjs linkables             platform  = targetPlatform dflags-            exe_file  = exeFileName platform staticLink (outputFile_ dflags)+            arch_os   = platformArchOS platform+            exe_file  = exeFileName arch_os staticLink (outputFile_ dflags)          linking_needed <- linkingNeeded logger dflags unit_env staticLink linkables pkg_deps @@ -431,12 +440,13 @@           -- Don't showPass in Batch mode; doLink will do that for us.-        let link = case ghcLink dflags of-                LinkBinary    -> linkBinary logger tmpfs-                LinkStaticLib -> linkStaticLib logger-                LinkDynLib    -> linkDynLibCheck logger tmpfs-                other         -> panicBadLink other-        link dflags unit_env obj_files pkg_deps+        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") @@ -449,22 +459,30 @@         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_units unit_env-      exe_file   = exeFileName platform staticLink (outputFile_ dflags)+      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 ]-        e_extra_times <- mapM (tryIO . getModificationUTCTime) extra_ld_inputs-        let (errs,extra_times) = partitionEithers e_extra_times+        (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@@ -472,15 +490,23 @@          -- 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) pkg_deps,+                          | 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-        e_lib_times <- mapM (tryIO . getModificationUTCTime)-                          (catMaybes pkg_libfiles)-        let (lib_errs,lib_times) = partitionEithers e_lib_times+        (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@@ -504,7 +530,12 @@ -- Compile files in one-shot mode.  oneShot :: HscEnv -> StopPhase -> [(String, Maybe Phase)] -> IO ()-oneShot hsc_env stop_phase srcs = do+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 ()@@ -514,50 +545,55 @@  compileFile :: HscEnv -> StopPhase -> (FilePath, Maybe Phase) -> IO (Maybe FilePath) compileFile hsc_env stop_phase (src, mb_phase) = do-   exists <- doesFileExist src-   when (not exists) $-        throwGhcExceptionIO (CmdLineError ("does not exist: " ++ src))+   let 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 -   let-        dflags    = hsc_dflags hsc_env-        mb_o_file = outputFile dflags-        ghc_link  = ghcLink dflags      -- Set by -c or -no-link-        notStopPreprocess | StopPreprocess <- stop_phase = False-                          | _              <- stop_phase = True-        -- When linking, the -o argument refers to the linker's output.-        -- otherwise, we use it as the name for the pipeline's output.-        output-         | NoBackend <- backend dflags, notStopPreprocess = NoOutputFile-                -- avoid -E -fno-code undesirable interactions. see #20439-         | NoStop <- stop_phase, not (isNoLink ghc_link) = Persistent-                -- -o foo applies to linker-         | isJust mb_o_file = SpecificFile-                -- -o foo applies to the file we are compiling now-         | otherwise = Persistent-        pipe_env = mkPipeEnv stop_phase src mb_phase output-        pipeline = pipelineStart pipe_env (setDumpPrefix pipe_env hsc_env) src 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 =-    let-        dflags   = hsc_dflags   hsc_env-        logger   = hsc_logger   hsc_env-        unit_env = hsc_unit_env hsc_env-        tmpfs    = hsc_tmpfs    hsc_env-    in case ghcLink dflags of-        NoLink        -> return ()-        LinkBinary    -> linkBinary         logger tmpfs dflags unit_env o_files []-        LinkStaticLib -> linkStaticLib      logger       dflags unit_env o_files []-        LinkDynLib    -> linkDynLibCheck    logger tmpfs dflags unit_env o_files []-        LinkMergedObj-          | Just out <- outputFile dflags-          , let objs = [ f | FileOption _ f <- ldInputs dflags ]-                      -> joinObjectFiles hsc_env (o_files ++ objs) out-          | otherwise -> panic "Output path must be specified for LinkMergedObj"-        other         -> panicBadLink other+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. @@ -581,16 +617,14 @@               LangObjc   -> viaCPipeline Cobjc               LangObjcxx -> viaCPipeline Cobjcxx               LangAsm    -> \pe hsc_env ml fp -> asPipeline True pe hsc_env ml fp-#if __GLASGOW_HASKELL__ < 811-              RawObject  -> panic "compileForeign: should be unreachable"-#endif+              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" (ppr stub_c)+          Nothing -> pprPanic "compileForeign" (text stub_c)           Just fp -> return fp  compileEmptyStub :: DynFlags -> HscEnv -> FilePath -> ModLocation -> ModuleName -> IO ()@@ -604,16 +638,29 @@   -- and https://github.com/haskell/cabal/issues/2257   let logger = hsc_logger hsc_env   let tmpfs  = hsc_tmpfs hsc_env-  empty_stub <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "c"   let home_unit = hsc_home_unit hsc_env-      src = text "int" <+> ppr (mkHomeModule home_unit mod_name) <+> text "= 0;"-  writeFile empty_stub (showSDoc dflags (pprCode CStyle src))-  let pipe_env = (mkPipeEnv NoStop empty_stub Nothing Persistent) { src_basename = basename}-      pipeline = viaCPipeline HCc pipe_env hsc_env (Just location) empty_stub-  _ <- runPipeline (hsc_hooks hsc_env) pipeline-  return () +  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@@ -689,8 +736,9 @@             -- Reparse with original hsc_env so that we don't get duplicated options             use (T_FileArgs hsc_env pp_fn) -  liftIO (printOrThrowDiagnostics (hsc_logger hsc_env) (initDiagOpts dflags3) (GhcPsMessage <$> p_warns3))-  liftIO (handleFlagWarnings (hsc_logger hsc_env) (initDiagOpts dflags3) warns3)+  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)  @@ -711,7 +759,7 @@            $ phaseIfFlag hsc_env flag def action  -- | The complete compilation pipeline, from start to finish-fullPipeline :: P m => PipeEnv -> HscEnv -> FilePath -> HscSource -> m (ModIface, Maybe Linkable)+fullPipeline :: 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@@ -720,7 +768,7 @@   hscPipeline pipe_env (hsc_env_with_plugins, mod_sum, hsc_recomp_status)  -- | Everything after preprocess-hscPipeline :: P m => PipeEnv ->  ((HscEnv, ModSummary, HscRecompStatus)) -> m (ModIface, Maybe Linkable)+hscPipeline :: 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)@@ -729,28 +777,34 @@       hscBackendAction <- use (T_HscPostTc hsc_env_with_plugins mod_sum tc_result warnings mb_old_hash )       hscBackendPipeline pipe_env hsc_env_with_plugins mod_sum hscBackendAction -hscBackendPipeline :: P m => PipeEnv -> HscEnv -> ModSummary -> HscBackendAction -> m (ModIface, Maybe Linkable)+hscBackendPipeline :: P m => PipeEnv -> HscEnv -> ModSummary -> HscBackendAction -> m (ModIface, HomeModLinkable) hscBackendPipeline pipe_env hsc_env mod_sum result =-  case backend (hsc_dflags hsc_env) of-    NoBackend ->-      case result of-        HscUpdate iface ->  return (iface, Nothing)-        HscRecomp {} -> (,) <$> liftIO (mkFullIface hsc_env (hscs_partial_iface result) Nothing Nothing) <*> pure Nothing-    -- TODO: Why is there not a linkable?-    -- Interpreter -> (,) <$> use (T_IO (mkFullIface hsc_env (hscs_partial_iface result) Nothing)) <*> pure Nothing-    _ -> do+  if backendGeneratesCode (backend (hsc_dflags hsc_env)) then+    do       res <- hscGenBackendPipeline pipe_env hsc_env mod_sum result-      when (gopt Opt_BuildDynamicToo (hsc_dflags hsc_env)) $ do+      -- 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, Maybe Linkable)+  -> 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)@@ -762,24 +816,37 @@       -- No object file produced, bytecode or NoBackend       Nothing -> return mlinkable       Just o_fp -> do-        unlinked_time <- liftIO (liftIO getCurrentTime)-        final_unlinked <- DotO <$> use (T_MergeForeign pipe_env hsc_env o_fp fos)-        let !linkable = LM unlinked_time (ms_mod mod_sum) [final_unlinked]-        return (Just linkable)-  return (miface, final_linkable)+        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 input_fn)+  out_fn <- use (T_Cc c_phase pipe_env hsc_env location input_fn)   case stop_phase pipe_env of     StopC -> return Nothing-    _ -> asPipeline False pipe_env hsc_env location out_fn+    _ -> return $ Just out_fn  llvmPipeline :: P m => PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m (Maybe FilePath) llvmPipeline pipe_env hsc_env location fp = do@@ -797,32 +864,47 @@     if gopt Opt_NoLlvmMangler (hsc_dflags hsc_env)       then return llc_fn       else use (T_LlvmMangle pipe_env hsc_env llc_fn)-  asPipeline False pipe_env hsc_env location mangled_fn+  lasPipeline False pipe_env hsc_env location mangled_fn -cmmCppPipeline :: P m => PipeEnv -> HscEnv -> FilePath -> m FilePath+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 FilePath+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 -> panic "CMM pipeline - produced no .o file"-    Just mo_fn -> use (T_MergeForeign pipe_env hsc_env mo_fn fos)+    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 _ _ HsBootFile _ _ _   = return Nothing-hscPostBackendPipeline _ _ HsigFile _ _ _     = return Nothing-hscPostBackendPipeline pipe_env hsc_env _ bcknd ml input_fn =-  case bcknd of-        ViaC        -> viaCPipeline HCc pipe_env hsc_env ml input_fn-        NCG         -> asPipeline False pipe_env hsc_env ml input_fn-        LLVM        -> llvmPipeline pipe_env hsc_env ml input_fn-        NoBackend   -> return Nothing-        Interpreter -> return Nothing+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 =@@ -854,10 +936,9 @@    as :: P m => Bool -> m (Maybe FilePath)    as use_cpp = asPipeline use_cpp pipe_env hsc_env Nothing input_fn -   objFromLinkable (_, Just (LM _ _ [DotO lnk])) = Just lnk+   objFromLinkable (_, 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@@ -873,8 +954,9 @@    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     = Just <$> cmmCppPipeline pipe_env hsc_env input_fn-   fromPhase Cmm        = Just <$> cmmPipeline pipe_env hsc_env 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"  {-@@ -891,7 +973,7 @@ `TPipelineClass` to give different behaviours that the default `HookedPhase` implementation:  * Additional logging of different phases-* Automatic parrelism (in the style of shake)+* 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.
GHC/Driver/Pipeline.hs-boot view
@@ -3,11 +3,22 @@  import GHC.Driver.Env.Types ( HscEnv ) import GHC.ForeignSrcLang ( ForeignSrcLang )-import GHC.Prelude (FilePath, IO)+import GHC.Prelude (FilePath, IO, Maybe, Either) import GHC.Unit.Module.Location (ModLocation)-import GHC.Unit.Module.Name (ModuleName) import GHC.Driver.Session (DynFlags)+import GHC.Driver.Phases (Phase)+import GHC.Driver.Errors.Types (DriverMessages)+import GHC.Types.Target (InputFileBuffer) +import Language.Haskell.Syntax.Module.Name+ -- These are used in GHC.Driver.Pipeline.Execute, but defined in terms of runPipeline compileForeign :: HscEnv -> ForeignSrcLang -> FilePath -> IO FilePath compileEmptyStub :: DynFlags -> HscEnv -> FilePath -> ModLocation -> ModuleName -> IO ()++preprocess :: HscEnv+           -> FilePath+           -> Maybe InputFileBuffer+           -> Maybe Phase+           -> IO (Either DriverMessages (DynFlags, FilePath))+
GHC/Driver/Pipeline/Execute.hs view
@@ -4,7 +4,6 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE GADTs #-}-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} #include <ghcplatform.h>  {- Functions for providing the default interpretation of the 'TPhase' actions@@ -21,20 +20,20 @@ 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.Module.Name ( ModuleName ) 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.Linker.Types import GHC.Driver.Backend import GHC.Driver.Session-import GHC.Driver.CmdLine import GHC.Unit.Module.ModSummary import qualified GHC.LanguageExtensions as LangExt import GHC.Types.SrcLoc import GHC.Driver.Main+import GHC.Driver.Downsweep import GHC.Tc.Types import GHC.Types.Error import GHC.Driver.Errors.Types@@ -44,12 +43,11 @@ import GHC.Platform import Data.List (intercalate, isInfixOf) import GHC.Unit.Env-import GHC.SysTools.Info import GHC.Utils.Error import Data.Maybe import GHC.CmmToLlvm.Mangler import GHC.SysTools-import GHC.Utils.Panic.Plain+import GHC.SysTools.Cpp import System.Directory import System.FilePath import GHC.Utils.Misc@@ -59,30 +57,34 @@ import GHC.Unit.Home import GHC.Data.Maybe import GHC.Iface.Make-import Data.Time import GHC.Driver.Config.Parser import GHC.Parser.Header import GHC.Data.StringBuffer+import GHC.Data.OsPath (unsafeEncodeUtf) import GHC.Types.SourceError import GHC.Unit.Finder-import GHC.Runtime.Loader import Data.IORef import GHC.Types.Name.Env import GHC.Platform.Ways-import GHC.Platform.ArchOS-import GHC.CmmToLlvm.Base ( llvmVersionList )+import 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 Data.Version 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) @@ -121,9 +123,16 @@         (hsc_tmpfs hsc_env)         (hsc_dflags hsc_env)         (hsc_unit_env hsc_env)-        False{-not raw-}+        (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)@@ -133,13 +142,15 @@   let foreign_os = maybeToList stub_o   return (foreign_os, output_fn) -runPhase (T_Cc phase pipe_env hsc_env input_fn) = runCcPhase phase pipe_env hsc_env input_fn+runPhase (T_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) =@@ -209,6 +220,7 @@     --     -- 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@@ -217,7 +229,7 @@           _ -> "-O2"          defaultOptions = map GHC.SysTools.Option . concatMap words . snd-                         $ unzip (llvmOptions dflags)+                         $ unzip (llvmOptions llvm_config dflags)         optFlag = if null (getOpts dflags opt_lc)                   then map GHC.SysTools.Option $ words llvmOpts                   else []@@ -243,16 +255,17 @@ 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 $ llvmConfig dflags of+        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 dflags)+                         $ 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@@ -275,23 +288,13 @@     return output_fn  -runAsPhase :: Bool -> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> IO FilePath-runAsPhase with_cpp pipe_env hsc_env location input_fn = do+-- 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 platform   = ue_platform unit_env -        -- LLVM from version 3.0 onwards doesn't support the OS X system-        -- assembler, so we use clang as the assembler instead. (#5636)-        let (as_prog, get_asm_info) | backend dflags == LLVM-                    , platformOS platform == OSDarwin-                    = (GHC.SysTools.runClang, pure Clang)-                    | otherwise-                    = (GHC.SysTools.runAs, getAssemblerInfo logger dflags)--        asmInfo <- get_asm_info-         let cmdline_include_paths = includePaths dflags         let pic_c_flags = picCCOpts dflags @@ -301,16 +304,21 @@         -- might be a hierarchical module.         createDirectoryIfMissing True (takeDirectory output_fn) -        let global_includes = [ GHC.SysTools.Option ("-I" ++ p)-                              | p <- includePathsGlobal cmdline_include_paths ]-        let local_includes = [ GHC.SysTools.Option ("-iquote" ++ p)-                             | p <- includePathsQuote cmdline_include_paths ++-                                includePathsQuoteImplicit cmdline_include_paths]+        -- 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 ->-                    as_prog+                    run_as                        logger dflags-                       (local_includes ++ global_includes+                       (all_includes                        -- See Note [-fPIC for assembler]                        ++ map GHC.SysTools.Option pic_c_flags                        -- See Note [Produce big objects on Windows]@@ -319,9 +327,10 @@                           , not $ target32Bit (targetPlatform dflags)                           ] -                       ++ (if any (asmInfo ==) [Clang, AppleClang, AppleClang51]-                            then [GHC.SysTools.Option "-Qunused-arguments"]-                            else [])+                       -- 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"@@ -330,20 +339,77 @@                           , 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" ] -runCcPhase :: Phase -> PipeEnv -> HscEnv -> FilePath -> IO FilePath-runCcPhase cc_phase pipe_env hsc_env input_fn = do+-- 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 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@@ -365,19 +431,6 @@          includePathsQuoteImplicit cmdline_include_paths)   let include_paths = include_paths_quote ++ include_paths_global -  -- pass -D or -optP to preprocessor when compiling foreign C files-  -- (#16737). Doing it in this way is simpler and also enable the C-  -- compiler to perform preprocessing and parsing in a single pass,-  -- but it may introduce inconsistency if a different pgm_P is specified.-  let opts = getOpts dflags opt_P-      aug_imports = augmentImports dflags opts--      more_preprocessor_opts = concat-        [ ["-Xpreprocessor", i]-        | not hcc-        , i <- aug_imports-        ]-   let gcc_extra_viac_flags = extraGccViaCFlags dflags   let pic_c_flags = picCCOpts dflags @@ -402,10 +455,12 @@              | llvmOptLevel dflags >= 1 = [ "-O" ]              | otherwise            = [] -  -- Decide next phase-  let next_phase = As False-  output_fn <- phaseOutputFilenameNew next_phase pipe_env hsc_env Nothing+  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@@ -423,25 +478,42 @@           -- very weakly typed, being derived from C--.           ["-fno-strict-aliasing"] -  ghcVersionH <- getGhcVersionPathName dflags unit_env+  ghcVersionH <- getGhcVersionIncludeFlags dflags unit_env -  GHC.SysTools.runCc (phaseForeignLanguage cc_phase) logger tmpfs dflags (-                  [ GHC.SysTools.FileOption "" input_fn+  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 "" output_fn+                  , 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.-                 ++ (if platformOS platform == OSMinGW32 &&-                        isHomeUnitId home_unit baseUnitId-                          then [ "-DCOMPILING_BASE_PACKAGE" ]-                          else [])+                 ++ (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)@@ -452,12 +524,10 @@                        then gcc_extra_viac_flags ++ more_hcc_opts                        else [])                  ++ verbFlags-                 ++ [ "-S" ]                  ++ cc_opt-                 ++ [ "-include", ghcVersionH ]+                 ++ ghcVersionH                  ++ framework_paths                  ++ include_paths-                 ++ more_preprocessor_opts                  ++ pkg_extra_cc_opts                  )) @@ -470,7 +540,7 @@                    -> HscSource                    -> ModLocation                    -> HscBackendAction-                   -> IO ([FilePath], ModIface, Maybe Linkable, FilePath)+                   -> 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@@ -478,78 +548,92 @@       next_phase = hscPostBackendPhase src_flavour (backend dflags)   case result of       HscUpdate iface ->-          do-             case src_flavour of-               HsigFile -> do-                 -- We need to create a REAL but empty .o file-                 -- because we are going to attempt to put it in a library-                 let input_fn = expectJust "runPhase" (ml_hs_file location)-                     basename = dropExtension input_fn-                 compileEmptyStub dflags hsc_env basename location mod_name+          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 logger dflags o_file-               HsSrcFile -> panic "HscUpdate not relevant for HscSrcFile"+                   -- 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" -             return ([], iface, Nothing, o_file)+                 -- 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                 }-        -> case backend dflags of-          NoBackend -> panic "HscRecomp not relevant for NoBackend"-          Interpreter -> do-              -- In interpreted mode the regular codeGen backend is not run so we-              -- generate a interface without codeGen info.-              final_iface <- mkFullIface hsc_env partial_iface Nothing Nothing-              hscMaybeWriteIface logger dflags True final_iface mb_old_iface_hash location--              (hasStub, comp_bc, spt_entries) <- hscInteractive hsc_env cgguts mod_location--              stub_o <- case hasStub of-                        Nothing -> return []-                        Just stub_c -> do-                            stub_o <- compileStub hsc_env stub_c-                            return [DotO stub_o]--              let hs_unlinked = [BCOs comp_bc spt_entries]-              unlinked_time <- getCurrentTime-              let !linkable = LM unlinked_time (mkHomeModule (hsc_home_unit hsc_env) mod_name)-                             (hs_unlinked ++ stub_o)-              return ([], final_iface, Just linkable, panic "interpreter")-          _ -> do+        -> 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, mb_stg_infos, mb_cg_infos) <-+              (outputFilename, mStub, foreign_files, stg_infos, cg_infos) <-                 hscGenHardCode hsc_env cgguts mod_location output_fn-              final_iface <- mkFullIface hsc_env partial_iface mb_stg_infos mb_cg_infos -              -- See Note [Writing interface files]-              hscMaybeWriteIface logger dflags False final_iface mb_old_iface_hash mod_location-               stub_o <- mapM (compileStub hsc_env) mStub               foreign_os <-                 mapM (uncurry (compileForeign hsc_env)) foreign_files-              let fos = (maybe [] return stub_o ++ foreign_os)+              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, Nothing, outputFilename)+              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.Coverage.isGoodTickSrcSpan where we check that the filename in-       -- a SrcLoc is the same as the source filenaame, the two will+       -- 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:-       -- libraries/hpc/tests/function/subdir/tough2.hs+       -- testsuite/tests/hpc/function/subdir/tough2.hs        escape ('\\':cs) = '\\':'\\': escape cs        escape ('\"':cs) = '\\':'\"': escape cs        escape ('\'':cs) = '\\':'\'': escape cs@@ -571,13 +655,14 @@      return output_fn -getFileArgs :: HscEnv -> FilePath -> IO ((DynFlags, Messages PsMessage, [Warn]))+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 input_fn+  (warns0, src_opts) <- getOptionsFromFile parser_opts (supportedLanguagePragmas dflags0) input_fn   (dflags1, unhandled_flags, warns)-    <- parseDynamicFilePragma dflags0 src_opts+    <- parseDynamicFilePragma logger dflags0 src_opts   checkProcessArgsResult unhandled_flags   return (dflags1, warns0, warns) @@ -587,7 +672,10 @@            (hsc_tmpfs hsc_env)            (hsc_dflags hsc_env)            (hsc_unit_env hsc_env)-           True{-raw-}+           (CppOpts+              { sourceCodePreprocessor  = SCPHsCpp+              , cppLinePragmas          = True+              })            input_fn output_fn   return output_fn @@ -609,22 +697,24 @@       new_includes = addImplicitQuoteInclude paths [current_dir]       paths = includePaths dflags0       dflags = dflags0 { includePaths = new_includes }-      hsc_env = hscSetFlags dflags hsc_env0-+      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, ghc_prim_imp) <- do+  (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 (\(rpk, lmn@(L _ mn)) -> (rn_pkg_qual mn rpk, lmn))+        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, ghc_prim_imp, L _ mod_name) -> return-              (Just buf, mod_name, rn_imps imps, rn_imps src_imps, ghc_prim_imp)+        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@@ -647,7 +737,7 @@   mod <- do     let home_unit = hsc_home_unit hsc_env     let fc        = hsc_FC hsc_env-    addHomeModuleToFinder fc home_unit mod_name location+    addHomeModuleToFinder fc home_unit mod_name location src_flavour    -- Make the ModSummary to hand to hscMain   let@@ -663,7 +753,6 @@                                 ms_parsed_mod   = Nothing,                                 ms_iface_date   = hi_date,                                 ms_hie_date     = hie_date,-                                ms_ghc_prim_import = ghc_prim_imp,                                 ms_textual_imps = imps,                                 ms_srcimps      = src_imps } @@ -671,19 +760,25 @@   -- run the compiler!   let msg :: Messager       msg hsc_env _ what _ = oneShotMsg (hsc_logger hsc_env) what-  plugin_hsc_env' <- initializePlugins hsc_env +  -- 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 plugin_hsc_env = plugin_hsc_env' { hsc_type_env_vars = knotVarsFromModuleEnv (mkModuleEnv [(mod, type_env_var)]) }+  let hsc_env' =+        setModuleGraph mg+          hsc_env { hsc_type_env_vars = knotVarsFromModuleEnv (mkModuleEnv [(mod, type_env_var)]) } -  status <- hscRecompStatus (Just msg) plugin_hsc_env mod_summary-                        Nothing Nothing (1, 1) -  return (plugin_hsc_env, mod_summary, status) +  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)@@ -691,24 +786,18 @@ mkOneShotModLocation pipe_env dflags src_flavour mod_name = do     let PipeEnv{ src_basename=basename,              src_suffix=suff } = pipe_env-    let location1 = mkHomeModLocation2 fopts mod_name basename suff--    -- Boot-ify it if necessary-    let location2-          | HsBootFile <- src_flavour = addBootSuffixLocnOut location1-          | otherwise                 = location1-+    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-        location3 | Just fn <- ohi = location2{ ml_hi_file = fn }-                  | otherwise      = location2+        location2 | Just fn <- ohi = location1{ ml_hi_file_ospath = unsafeEncodeUtf fn }+                  | otherwise      = location1      let dynohi = dynOutputHi dflags-        location4 | Just fn <- dynohi = location3{ ml_dyn_hi_file = fn }-                  | otherwise         = location3+        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@@ -721,11 +810,11 @@         location5 | Just ofile <- expl_o_file                   , let dyn_ofile = fromMaybe (ofile -<.> dynObjectSuf_ dflags) expl_dyn_o_file                   , isNoLink (ghcLink dflags)-                  = location4 { ml_obj_file = ofile-                              , ml_dyn_obj_file = dyn_ofile }+                  = location3 { ml_obj_file_ospath = unsafeEncodeUtf ofile+                              , ml_dyn_obj_file_ospath = unsafeEncodeUtf dyn_ofile }                   | Just dyn_ofile <- expl_dyn_o_file-                  = location4 { ml_dyn_obj_file = dyn_ofile }-                  | otherwise = location4+                  = location3 { ml_dyn_obj_file_ospath = unsafeEncodeUtf dyn_ofile }+                  | otherwise = location3     return location5     where       fopts = initFinderOpts dflags@@ -801,7 +890,7 @@  | StopLn <- next_phase, Just loc <- maybe_location  =       return $ if dynamicNow dflags then ml_dyn_obj_file loc                                     else ml_obj_file loc- -- 2. If output style is persistant then+ -- 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@@ -823,9 +912,11 @@  | otherwise                             = newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule    suffix     where-          getOutputFile_ dflags = case outputFile_ dflags of-                                    Nothing -> pprPanic "SpecificFile: No filename" (ppr $ (dynamicNow dflags, outputFile_ dflags, dynOutputFile_ dflags))-                                    Just fn -> fn+          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@@ -867,14 +958,12 @@  -- | LLVM Options. These are flags to be passed to opt and llc, to ensure -- consistency we list them in pairs, so that they form groups.-llvmOptions :: DynFlags+llvmOptions :: LlvmConfig+            -> DynFlags             -> [(String, String)]  -- ^ pairs of (opt, llc) arguments-llvmOptions dflags =-       [("-enable-tbaa -tbaa",  "-enable-tbaa") | gopt Opt_LlvmTBAA dflags ]-    ++ [("-relocation-model=" ++ rmodel+llvmOptions llvm_config dflags =+       [("-relocation-model=" ++ rmodel         ,"-relocation-model=" ++ rmodel) | not (null rmodel)]-    ++ [("-stack-alignment=" ++ (show align)-        ,"-stack-alignment=" ++ (show align)) | align > 0 ]      -- Additional llc flags     ++ [("", "-mcpu=" ++ mcpu)   | not (null mcpu)@@ -883,24 +972,32 @@     ++ [("", "-target-abi=" ++ abi) | not (null abi) ]    where target = platformMisc_llvmTarget $ platformMisc dflags-        Just (LlvmTarget _ mcpu mattr) = lookup target (llvmTargets $ llvmConfig dflags)+        target_os = platformOS (targetPlatform dflags)+        LlvmTarget _ mcpu mattr = expectJust $ lookup target (llvmTargets llvm_config)          -- Relocation models-        rmodel | gopt Opt_PIC dflags         = "pic"-               | positionIndependent dflags  = "pic"-               | ways dflags `hasWay` WayDyn = "dynamic-no-pic"-               | otherwise                   = "static"+        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--        align :: Int-        align = case platformArch platform of-                  ArchX86_64 | isAvxEnabled dflags -> 32-                  _                                -> 0+        arch = platformArch platform          attrs :: String         attrs = intercalate "," $ mattr-              ++ ["+sse42"   | isSse4_2Enabled dflags   ]+              ++ ["+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  ]@@ -909,162 +1006,21 @@               ++ ["+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"                 _           -> "" ---- Note [Filepaths and Multiple Home Units]-offsetIncludePaths :: DynFlags -> IncludeSpecs -> IncludeSpecs-offsetIncludePaths dflags (IncludeSpecs incs quotes impl) =-     let go = map (augmentByWorkingDirectory dflags)-     in IncludeSpecs (go incs) (go quotes) (go impl)--- -------------------------------------------------------------------------------- Running CPP---- | Run CPP------ UnitEnv is needed to compute MIN_VERSION macros-doCpp :: Logger -> TmpFs -> DynFlags -> UnitEnv -> Bool -> FilePath -> FilePath -> IO ()-doCpp logger tmpfs dflags unit_env raw input_fn output_fn = do-    let hscpp_opts = picPOpts dflags-    let cmdline_include_paths = offsetIncludePaths dflags (includePaths dflags)-    let unit_state = ue_units unit_env-    pkg_include_dirs <- mayThrowUnitErr-                        (collectIncludeDirs <$> preloadUnitsInfo unit_env)-    -- MP: This is not quite right, the headers which are supposed to be installed in-    -- the package might not be the same as the provided include paths, but it's a close-    -- enough approximation for things to work. A proper solution would be to have to declare which paths should-    -- be propagated to dependent packages.-    let home_pkg_deps =-         [homeUnitEnv_dflags . ue_findHomeUnitEnv uid $ unit_env | uid <- ue_transitiveHomeDeps (ue_currentUnit unit_env) unit_env]-        dep_pkg_extra_inputs = [offsetIncludePaths fs (includePaths fs) | fs <- home_pkg_deps]--    let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) []-          (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs-                                                    ++ concatMap includePathsGlobal dep_pkg_extra_inputs)-    let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) []-          (includePathsQuote cmdline_include_paths ++-           includePathsQuoteImplicit cmdline_include_paths)-    let include_paths = include_paths_quote ++ include_paths_global--    let verbFlags = getVerbFlags dflags--    let cpp_prog args | raw       = GHC.SysTools.runCpp logger dflags args-                      | otherwise = GHC.SysTools.runCc Nothing logger tmpfs dflags-                                        (GHC.SysTools.Option "-E" : args)--    let platform   = targetPlatform dflags-        targetArch = stringEncodeArch $ platformArch platform-        targetOS = stringEncodeOS $ platformOS platform-        isWindows = platformOS platform == OSMinGW32-    let target_defs =-          [ "-D" ++ HOST_OS     ++ "_BUILD_OS",-            "-D" ++ HOST_ARCH   ++ "_BUILD_ARCH",-            "-D" ++ targetOS    ++ "_HOST_OS",-            "-D" ++ targetArch  ++ "_HOST_ARCH" ]-        -- remember, in code we *compile*, the HOST is the same our TARGET,-        -- and BUILD is the same as our HOST.--    let io_manager_defs =-          [ "-D__IO_MANAGER_WINIO__=1" | isWindows ] ++-          [ "-D__IO_MANAGER_MIO__=1"               ]--    let sse_defs =-          [ "-D__SSE__"      | isSseEnabled      platform ] ++-          [ "-D__SSE2__"     | isSse2Enabled     platform ] ++-          [ "-D__SSE4_2__"   | isSse4_2Enabled   dflags ]--    let avx_defs =-          [ "-D__AVX__"      | isAvxEnabled      dflags ] ++-          [ "-D__AVX2__"     | isAvx2Enabled     dflags ] ++-          [ "-D__AVX512CD__" | isAvx512cdEnabled dflags ] ++-          [ "-D__AVX512ER__" | isAvx512erEnabled dflags ] ++-          [ "-D__AVX512F__"  | isAvx512fEnabled  dflags ] ++-          [ "-D__AVX512PF__" | isAvx512pfEnabled dflags ]--    backend_defs <- getBackendDefs logger dflags--    let th_defs = [ "-D__GLASGOW_HASKELL_TH__" ]-    -- Default CPP defines in Haskell source-    ghcVersionH <- getGhcVersionPathName dflags unit_env-    let hsSourceCppOpts = [ "-include", ghcVersionH ]--    -- MIN_VERSION macros-    let uids = explicitUnits unit_state-        pkgs = mapMaybe (lookupUnit unit_state . fst) uids-    mb_macro_include <--        if not (null pkgs) && gopt Opt_VersionMacros dflags-            then do macro_stub <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "h"-                    writeFile macro_stub (generatePackageVersionMacros pkgs)-                    -- Include version macros for every *exposed* package.-                    -- Without -hide-all-packages and with a package database-                    -- size of 1000 packages, it takes cpp an estimated 2-                    -- milliseconds to process this file. See #10970-                    -- comment 8.-                    return [GHC.SysTools.FileOption "-include" macro_stub]-            else return []--    cpp_prog       (   map GHC.SysTools.Option verbFlags-                    ++ map GHC.SysTools.Option include_paths-                    ++ map GHC.SysTools.Option hsSourceCppOpts-                    ++ map GHC.SysTools.Option target_defs-                    ++ map GHC.SysTools.Option backend_defs-                    ++ map GHC.SysTools.Option th_defs-                    ++ map GHC.SysTools.Option hscpp_opts-                    ++ map GHC.SysTools.Option sse_defs-                    ++ map GHC.SysTools.Option avx_defs-                    ++ map GHC.SysTools.Option io_manager_defs-                    ++ mb_macro_include-        -- Set the language mode to assembler-with-cpp when preprocessing. This-        -- alleviates some of the C99 macro rules relating to whitespace and the hash-        -- operator, which we tend to abuse. Clang in particular is not very happy-        -- about this.-                    ++ [ GHC.SysTools.Option     "-x"-                       , GHC.SysTools.Option     "assembler-with-cpp"-                       , GHC.SysTools.Option     input_fn-        -- We hackily use Option instead of FileOption here, so that the file-        -- name is not back-slashed on Windows.  cpp is capable of-        -- dealing with / in filenames, so it works fine.  Furthermore-        -- if we put in backslashes, cpp outputs #line directives-        -- with *double* backslashes.   And that in turn means that-        -- our error messages get double backslashes in them.-        -- In due course we should arrange that the lexer deals-        -- with these \\ escapes properly.-                       , GHC.SysTools.Option     "-o"-                       , GHC.SysTools.FileOption "" output_fn-                       ])--getBackendDefs :: Logger -> DynFlags -> IO [String]-getBackendDefs logger dflags | backend dflags == LLVM = do-    llvmVer <- figureLlvmVersion logger dflags-    return $ case fmap llvmVersionList llvmVer of-               Just [m] -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,0) ]-               Just (m:n:_) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,n) ]-               _ -> []-  where-    format (major, minor)-      | minor >= 100 = error "getBackendDefs: Unsupported minor version"-      | otherwise = show $ (100 * major + minor :: Int) -- Contract is Int--getBackendDefs _ _ =-    return []- -- | What phase to run after one of the backend code generators has run hscPostBackendPhase :: HscSource -> Backend -> Phase-hscPostBackendPhase HsBootFile _    =  StopLn-hscPostBackendPhase HsigFile _      =  StopLn-hscPostBackendPhase _ bcknd =-  case bcknd of-        ViaC        -> HCc-        NCG         -> As False-        LLVM        -> LlvmOpt-        NoBackend   -> StopLn-        Interpreter -> StopLn+hscPostBackendPhase (HsBootOrSig _) _ =  StopLn+hscPostBackendPhase HsSrcFile bcknd = backendNormalSuccessorPhase bcknd   compileStub :: HscEnv -> FilePath -> IO FilePath@@ -1105,7 +1061,7 @@ Note [Object merging] ~~~~~~~~~~~~~~~~~~~~~ On most platforms one can "merge" a set of relocatable object files into a new,-partiall-linked-but-still-relocatable object. In a typical UNIX-style linker,+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@@ -1117,14 +1073,18 @@ The command used for object linking is set using the -pgmlm and -optlm command-line options. -Sadly, the LLD linker that we use on Windows does not support the `-r` flag-needed to support object merging (see #21068). For this reason on Windows we do-not support GHCi objects.  To deal with foreign stubs we build a static archive-of all of a module's object files instead merging them. Consequently, we can-end up producing `.o` files which are in fact static archives. However,-toolchains generally don't have a problem with this as they use file headers,-not the filename, to determine the nature of inputs.+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.@@ -1153,17 +1113,10 @@   let toolSettings' = toolSettings dflags       ldIsGnuLd = toolSettings_ldIsGnuLd toolSettings'       ld_r args = GHC.SysTools.runMergeObjects (hsc_logger hsc_env) (hsc_tmpfs hsc_env) (hsc_dflags hsc_env) (-                        map GHC.SysTools.Option ld_build_id-                     ++ [ GHC.SysTools.Option "-o",+                        [ GHC.SysTools.Option "-o",                           GHC.SysTools.FileOption "" output_fn ]                      ++ args) -      -- suppress the generation of the .note.gnu.build-id section,-      -- which we don't need and sometimes causes ld to emit a-      -- warning:-      ld_build_id | toolSettings_ldSupportsBuildId toolSettings' = ["--build-id=none"]-                  | otherwise                                    = []-   if ldIsGnuLd      then do           script <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "ldscript"@@ -1217,61 +1170,15 @@   --- ------------------------------------------------------------------------------ Macros (cribbed from Cabal)--generatePackageVersionMacros :: [UnitInfo] -> String-generatePackageVersionMacros pkgs = concat-  -- Do not add any C-style comments. See #3389.-  [ generateMacros "" pkgname version-  | pkg <- pkgs-  , let version = unitPackageVersion pkg-        pkgname = map fixchar (unitPackageNameString pkg)-  ]--fixchar :: Char -> Char-fixchar '-' = '_'-fixchar c   = c--generateMacros :: String -> String -> Version -> String-generateMacros prefix name version =-  concat-  ["#define ", prefix, "VERSION_",name," ",show (showVersion version),"\n"-  ,"#define MIN_", prefix, "VERSION_",name,"(major1,major2,minor) (\\\n"-  ,"  (major1) <  ",major1," || \\\n"-  ,"  (major1) == ",major1," && (major2) <  ",major2," || \\\n"-  ,"  (major1) == ",major1," && (major2) == ",major2," && (minor) <= ",minor,")"-  ,"\n\n"-  ]-  where-    (major1:major2:minor:_) = map show (versionBranch version ++ repeat 0)-- -- ----------------------------------------------------------------------------- -- Misc.   -touchObjectFile :: Logger -> DynFlags -> FilePath -> IO ()-touchObjectFile logger dflags path = do+touchObjectFile :: FilePath -> IO ()+touchObjectFile path = do   createDirectoryIfMissing True $ takeDirectory path-  GHC.SysTools.touch logger dflags "Touching object file" path---- | Find out path to @ghcversion.h@ file-getGhcVersionPathName :: DynFlags -> UnitEnv -> IO FilePath-getGhcVersionPathName dflags unit_env = do-  candidates <- case ghcVersionFile dflags of-    Just path -> return [path]-    Nothing -> do-        ps <- mayThrowUnitErr (preloadUnitsInfo' unit_env [rtsUnitId])-        return ((</> "ghcversion.h") <$> collectIncludeDirs ps)--  found <- filterM doesFileExist candidates-  case found of-      []    -> throwGhcExceptionIO (InstallationError-                                    ("ghcversion.h missing; tried: "-                                      ++ intercalate ", " candidates))-      (x:_) -> return x+  GHC.Utils.Touch.touch path  -- Note [-fPIC for assembler] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1341,9 +1248,9 @@    4) -fhpc   At some point during compilation with -fhpc, in the function-  `GHC.HsToCore.Coverage.isGoodTickSrcSpan`, we compare the filename that a+  `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 legitimally be+  For some reason I don't yet understand, they can sometimes legitimately be   different, and then hpc ignores that SrcSpan.  Problem@@ -1370,4 +1277,31 @@   that commit was addressing has since been solved in a different manner, in a   commit called "Fix the filename passed to unlit" (1eedbc6b). So the   `normalise` is no longer necessary.+-}++{-+Note [-Wa,--no-type-check on wasm32]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Wasm32 has a type system and corresponding validation rules, so it's+possible to produce syntactically valid object code that doesn't pass+validation.++We have no problem with that, but we do have a problem with clang.+When clang takes an assembly input for wasm32, it uses its internal+type-checker, which is a huge source of trouble (see llvm ticket+#56935 #58438): it may reject valid assembly, and even worse, it may+silently alter the output object code!!! The worsest of all, is the+person that added the wasm32 asm typechecker logic has moved on from+Google/LLVM, and while other LLVM devs may be knowledgable enough to+fix this mess, they likely got tons of other stuff on their table and+don't care enough.++We do have an escape hatch, just pass -Wa,--no-type-check to clang to+bypass the entire wasm32 asm typechecking logic. There's little point+in type-checking object code at compile-time anyway, the wasm engines+will do type-checking at run-time. And even if we want to add some+linting flag to do compile-time checks, we should just rely on+battle-tested external tools instead of a completely broken horror+story. -}
GHC/Driver/Pipeline/LogQueue.hs view
@@ -100,10 +100,10 @@                                                 Just ((k, v), lqq') | k == n -> Just (v, LogQueueQueue (n + 1) lqq')                                                 _ -> Nothing -logThread :: Int -> Int -> Logger -> TVar Bool -- Signal that no more new logs will be added, clear the queue and exit+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+logThread logger stopped lqq_var = do   finished_var <- newEmptyMVar   _ <- forkIO $ print_logs *> putMVar finished_var ()   return (takeMVar finished_var)
GHC/Driver/Pipeline/Phases.hs view
@@ -6,8 +6,7 @@ import GHC.Prelude import GHC.Driver.Pipeline.Monad import GHC.Driver.Env.Types-import GHC.Driver.Session-import GHC.Driver.CmdLine+import GHC.Driver.DynFlags import GHC.Types.SourceFile import GHC.Unit.Module.ModSummary import GHC.Unit.Module.Status@@ -16,11 +15,12 @@ import GHC.Driver.Errors.Types import GHC.Fingerprint.Type import GHC.Unit.Module.Location ( ModLocation )-import GHC.Unit.Module.Name ( ModuleName ) import GHC.Unit.Module.ModIface-import GHC.Linker.Types import GHC.Driver.Phases +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@@ -28,7 +28,7 @@ -- phase if the inputs have been modified. data TPhase res where   T_Unlit :: PipeEnv -> HscEnv -> FilePath -> TPhase FilePath-  T_FileArgs :: HscEnv -> FilePath -> TPhase (DynFlags, Messages PsMessage, [Warn])+  T_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)@@ -38,13 +38,16 @@               -> Messages GhcMessage               -> Maybe Fingerprint               -> TPhase HscBackendAction-  T_HscBackend :: PipeEnv -> HscEnv -> ModuleName -> HscSource -> ModLocation -> HscBackendAction -> TPhase ([FilePath], ModIface, Maybe Linkable, FilePath)+  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 -> FilePath -> TPhase 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
GHC/Driver/Plugins.hs view
@@ -1,6 +1,13 @@ {-# 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.@@ -14,6 +21,10 @@     , CommandLineOption     , PsMessages(..)     , ParsedResult(..)++      -- * External plugins+    , loadExternalPlugins+       -- ** Recompilation checking     , purePlugin, impurePlugin, flagRecompile     , PluginRecompile(..)@@ -47,11 +58,16 @@       -- | 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 @@ -60,6 +76,7 @@ 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@@ -69,13 +86,20 @@  import qualified GHC.Tc.Types import GHC.Tc.Types ( TcGblEnv, IfM, TcM, tcg_rn_decls, tcg_rn_exports  )-import GHC.Tc.Errors.Hole.FitTypes ( HoleFitPluginR )+import GHC.Tc.Errors.Hole.Plugin ( HoleFitPluginR ) -import GHC.Core.Opt.Monad ( CoreToDo, CoreM )+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 (Outputable(..), text, (<+>))+import GHC.Utils.Outputable+import GHC.Utils.Panic  import Data.List (sort) @@ -84,9 +108,14 @@ import qualified Data.Semigroup  import Control.Monad-import GHC.Linker.Types-import GHC.Types.Unique.DFM +#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@@ -134,6 +163,13 @@     --     --   @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@@ -195,11 +231,21 @@   -- ^ 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@@ -229,6 +275,7 @@ 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@@ -249,6 +296,7 @@       , defaultingPlugin      = const Nothing       , holeFitPlugin         = const Nothing       , driverPlugin          = const return+      , latePlugin            = \_ -> const return       , pluginRecompile       = impurePlugin       , renamedResultAction   = \_ env grp -> return (env, grp)       , parsedResultAction    = \_ _ -> return@@ -284,6 +332,10 @@       -- 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.@@ -298,12 +350,17 @@   }  emptyPlugins :: Plugins-emptyPlugins = Plugins [] [] ([], emptyUDFM)-+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.@@ -327,3 +384,53 @@     } defaultFrontendPlugin :: FrontendPlugin defaultFrontendPlugin = FrontendPlugin { frontend = \_ _ -> return () }+++-- | Load external plugins+loadExternalPlugins :: [ExternalPluginSpec] -> IO [ExternalPlugin]+loadExternalPlugins [] = return []+#if !defined(HAVE_INTERNAL_INTERPRETER)+loadExternalPlugins _ = do+  panic "loadExternalPlugins: can't load external plugins with GHC built without internal interpreter"+#elif !defined(CAN_LOAD_DLL)+loadExternalPlugins _ = do+  panic "loadExternalPlugins: loading shared libraries isn't supported by this compiler"+#else+loadExternalPlugins ps = do+  -- initialize the linker+  initObjLinker RetainCAFs+  -- load plugins+  forM ps $ \(ExternalPluginSpec path unit mod_name opts) -> do+    loadExternalPluginLib path+    -- lookup symbol+    let ztmp = zEncodeString mod_name ++ "_plugin_closure"+        symbol+          | null unit = ztmp+          | otherwise = zEncodeString unit ++ "_" ++ ztmp+    plugin <- lookupSymbol symbol >>= \case+      Nothing -> pprPanic "loadExternalPlugins"+                  (vcat [ text "Symbol not found"+                        , text "  Library path: " <> text path+                        , text "  Symbol      : " <> text symbol+                        ])+      Just (Ptr addr) -> case addrToAny# addr of+        (# a #) -> pure a++    pure $ ExternalPlugin (PluginWithArgs plugin opts) unit mod_name++loadExternalPluginLib :: FilePath -> IO ()+loadExternalPluginLib path = do+  -- load library+  loadDLL path >>= \case+    Left errmsg -> pprPanic "loadExternalPluginLib"+                     (vcat [ text "Can't load plugin library"+                           , text "  Library path: " <> text path+                           , text "  Error       : " <> text errmsg+                           ])+    Right _ -> do+      -- resolve objects+      resolveObjs >>= \case+        True -> return ()+        False -> pprPanic "loadExternalPluginLib" (text "Unable to resolve objects for library: " <> text path)++#endif
+ GHC/Driver/Plugins/External.hs view
@@ -0,0 +1,79 @@+-- | External plugins+--+-- GHC supports two kinds of "static" plugins:+--  1. internal: setup with GHC-API+--  2. external: setup as explained below and loaded from shared libraries+--+-- The intended use case for external static plugins is with cross compilers: at+-- the time of writing, GHC is mono-target and a GHC cross-compiler (i.e. when+-- host /= target) can't build nor load plugins for the host using the+-- "non-static" plugin approach. Fixing this is tracked in #14335. If you're not+-- using a cross-compiler, you'd better use non-static plugins which are easier+-- to build and and safer to use (see below).+--+-- External static plugins can be configured via the command-line with+-- the -fplugin-library flag. Syntax is:+--+--   -fplugin-library=⟨file-path⟩;⟨unit-id⟩;⟨module⟩;⟨args⟩+--+-- Example:+--    -fplugin-library=path/to/plugin;package-123;Plugin.Module;["Argument","List"]+--+-- Building the plugin library:+--  1. link with the libraries used to build the compiler you target.  If you+--  target a cross-compiler (stage2), you can't directly use it to build the+--  plugin library. Use the stage1 compiler instead.+--+--  2. if you use cabal to build the library, its unit-id will be set by cabal+--  and will contain a hash (e.g. "my-plugin-unit-1345656546ABCDEF"). To force+--  the unit id, use GHC's `-this-unit-id` command line flag:+--    e.g. -this-unit-id my-plugin-unit+--  You can set this in the .cabal file of your library with the following+--  stanza: `ghc-options: -this-unit-id my-plugin-unit`+--+--  3. To make your plugin easier to distribute, you may want to link it+--  statically with all its dependencies. You would need to use `-shared`+--  without `-dynamic` when building your library.+--+--  However, all the static dependencies have to be built with `-fPIC` and it's+--  not done by default. See+--  https://www.hobson.space/posts/haskell-foreign-library/ for a way to modify+--  the compiler to do it.+--+--  In any case, don't link your plugin library statically with the RTS (e.g.+--  use `-fno-link-rts`) as there are some global variables in the RTS that must+--  be shared between the plugin and the compiler.+--+-- With external static plugins we don't check the type of the `plugin` closure+-- we look up. If it's not a valid `Plugin` value, it will probably crash badly.+--++module GHC.Driver.Plugins.External+  ( ExternalPluginSpec (..)+  , parseExternalPluginSpec+  )+where++import GHC.Prelude+import Text.Read++-- | External plugin spec+data ExternalPluginSpec = ExternalPluginSpec+  { esp_lib     :: !FilePath+  , esp_unit_id :: !String+  , esp_module  :: !String+  , esp_args    :: ![String]+  }++-- | Parser external static plugin specification from command-line flag+parseExternalPluginSpec :: String -> Maybe ExternalPluginSpec+parseExternalPluginSpec optflag =+  case break (== ';') optflag of+    (libPath, _:rest) -> case break (== ';') rest of+      (libName, _:pack) -> case break (== ';') pack of+        (modName, _:args) -> case readMaybe args of+          Just as -> Just (ExternalPluginSpec libPath libName modName as)+          Nothing -> Nothing+        _ -> Nothing+      _ -> Nothing+    _ -> Nothing
GHC/Driver/Ppr.hs view
@@ -6,12 +6,13 @@    , showPpr    , showPprUnsafe    , printForUser+   , printForUserColoured    ) where  import GHC.Prelude -import GHC.Driver.Session+import GHC.Driver.DynFlags import GHC.Unit.State  import GHC.Utils.Outputable@@ -26,14 +27,21 @@ showPpr :: Outputable a => DynFlags -> a -> String showPpr dflags thing = showSDoc dflags (ppr thing) --- | Allows caller to specify the PrintUnqualified to use-showSDocForUser :: DynFlags -> UnitState -> PrintUnqualified -> SDoc -> String-showSDocForUser dflags unit_state unqual doc = renderWithContext (initSDocContext dflags sty) doc'+-- | 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 unqual AllTheWay+      sty  = mkUserStyle name_ppr_ctx AllTheWay       doc' = pprWithUnitState unit_state doc -printForUser :: DynFlags -> Handle -> PrintUnqualified -> Depth -> SDoc -> IO ()-printForUser dflags handle unqual depth 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 (mkUserStyle unqual depth)+    where ctx = initSDocContext dflags (setStyleColoured colour $ mkUserStyle name_ppr_ctx depth)+
GHC/Driver/Session.hs view
@@ -1,5059 +1,3821 @@ {-# LANGUAGE CPP #-}-{-# 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-------------------------------------------------------------------------------------{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}--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,-        xopt, xopt_set, xopt_unset,-        xopt_set_unlessExplSpec,-        xopt_DuplicateRecordFields,-        xopt_FieldSelectors,-        lang_set,-        DynamicTooState(..), dynamicTooState, setDynamicNow,-        sccProfilingEnabled,-        needSourceNotes,-        DynFlags(..),-        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,-        setFlagsFromEnvFile,-        pprDynFlagsDiff,-        flagSpecOf,--        targetProfile,--        -- ** Safe Haskell-        safeHaskellOn, safeHaskellModeEnabled,-        safeImportsOn, safeLanguageOn, safeInferOn,-        packageTrustOn,-        safeDirectImpsReq, safeImplicitImpsReq,-        unsafeFlags, unsafeFlagsForInfer,--        -- ** LLVM Targets-        LlvmTarget(..), LlvmConfig(..),--        -- ** System tool settings and locations-        Settings(..),-        sProgramName,-        sProjectVersion,-        sGhcUsagePath,-        sGhciUsagePath,-        sToolDir,-        sTopDir,-        sGlobalPackageDatabasePath,-        sLdSupportsCompactUnwind,-        sLdSupportsBuildId,-        sLdSupportsFilelist,-        sLdIsGnuLd,-        sGccSupportsNoPie,-        sPgm_L,-        sPgm_P,-        sPgm_F,-        sPgm_c,-        sPgm_cxx,-        sPgm_a,-        sPgm_l,-        sPgm_lm,-        sPgm_dll,-        sPgm_T,-        sPgm_windres,-        sPgm_libtool,-        sPgm_ar,-        sPgm_ranlib,-        sPgm_lo,-        sPgm_lc,-        sPgm_lcc,-        sPgm_i,-        sOpt_L,-        sOpt_P,-        sOpt_P_fingerprint,-        sOpt_F,-        sOpt_c,-        sOpt_cxx,-        sOpt_a,-        sOpt_l,-        sOpt_lm,-        sOpt_windres,-        sOpt_lo,-        sOpt_lc,-        sOpt_lcc,-        sOpt_i,-        sExtraGccViaCFlags,-        sTargetPlatformString,-        sGhcWithInterpreter,-        sLibFFI,-        GhcNameVersion(..),-        FileSettings(..),-        PlatformMisc(..),-        settings,-        programName, projectVersion,-        ghcUsagePath, ghciUsagePath, topDir,-        versionedAppDir, versionedFilePath,-        extraGccViaCFlags, globalPackageDatabasePath,-        pgm_L, pgm_P, pgm_F, pgm_c, pgm_cxx, pgm_a, pgm_l, pgm_lm, pgm_dll, pgm_T,-        pgm_windres, pgm_libtool, pgm_ar, pgm_otool, pgm_install_name_tool,-        pgm_ranlib, pgm_lo, pgm_lc, pgm_lcc, pgm_i,-        opt_L, opt_P, opt_F, opt_c, opt_cxx, opt_a, opt_l, opt_lm, opt_i,-        opt_P_signature,-        opt_windres, opt_lo, opt_lc, opt_lcc,-        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,--        TurnOnFlag,-        turnOn,-        turnOff,-        impliedGFlags,-        impliedOffGFlags,-        impliedXFlags,--        -- ** State-        CmdLineP(..), runCmdLineP,-        getCmdLineState, putCmdLineState,-        processCmdLineP,--        -- ** Parsing DynFlags-        parseDynamicFlagsCmdLine,-        parseDynamicFilePragma,-        parseDynamicFlagsFull,--        -- ** 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-        isSse4_2Enabled,-        isBmiEnabled,-        isBmi2Enabled,-        isAvxEnabled,-        isAvx2Enabled,-        isAvx512cdEnabled,-        isAvx512erEnabled,-        isAvx512fEnabled,-        isAvx512pfEnabled,--        -- * Linker/compiler information-        LinkerInfo(..),-        CompilerInfo(..),-        useXLinkerRPath,--        -- * Include specifications-        IncludeSpecs(..), addGlobalInclude, addQuoteInclude, flattenIncludes,-        addImplicitQuoteInclude,--        -- * SDoc-        initSDocContext, initDefaultSDocContext,-  ) where--import GHC.Prelude--import GHC.Platform-import GHC.Platform.Ways-import GHC.Platform.Profile--import GHC.UniqueSubdir (uniqueSubdir)-import GHC.Unit.Types-import GHC.Unit.Parser-import GHC.Unit.Module-import GHC.Builtin.Names ( mAIN_NAME )-import GHC.Driver.Phases ( Phase(..), phaseInputExt )-import GHC.Driver.Flags-import GHC.Driver.Backend-import GHC.Settings.Config-import GHC.Utils.CliOption-import GHC.Core.Unfold-import GHC.Driver.CmdLine-import GHC.Settings.Constants-import GHC.Utils.Panic-import qualified GHC.Utils.Ppr.Colour as Col-import GHC.Utils.Misc-import GHC.Utils.Constants (debugIsOn)-import GHC.Utils.GlobalVars-import GHC.Data.Maybe-import GHC.Data.Bool-import GHC.Utils.Monad-import GHC.Types.Error (DiagnosticReason(..))-import GHC.Types.SrcLoc-import GHC.Types.SafeHaskell-import GHC.Types.Basic ( IntWithInf, treatZeroAsInf )-import qualified GHC.Types.FieldLabel as FieldLabel-import GHC.Data.FastString-import GHC.Utils.TmpFs-import GHC.Utils.Fingerprint-import GHC.Utils.Outputable-import GHC.Settings-import GHC.CmmToAsm.CFG.Weight-import {-# SOURCE #-} GHC.Core.Opt.CallerCC--import GHC.SysTools.Terminal ( stderrSupportsAnsiColors )-import GHC.SysTools.BaseDir ( expandToolDir, expandTopDir )--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.Monad.Trans.State as State-import Data.Functor.Identity--import Data.Ord-import Data.Char-import Data.List (intercalate, sortBy)-import qualified Data.List.NonEmpty as NE-import qualified Data.Map as Map-import qualified Data.Set as Set-import System.FilePath-import System.Directory-import System.Environment (lookupEnv)-import System.IO-import System.IO.Error-import Text.ParserCombinators.ReadP hiding (char)-import Text.ParserCombinators.ReadP as R--import GHC.Data.EnumSet (EnumSet)-import qualified GHC.Data.EnumSet as EnumSet--import GHC.Foreign (withCString, peekCString)-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---- | 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--{- 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 attemps and-  lead to unnecessary recompilations when the source paths in BA differ from the-  source paths in subsequent builds.- -}----- | 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,-  targetPlatform    :: Platform,       -- Filled in by SysTools-  toolSettings      :: {-# UNPACK #-} !ToolSettings,-  platformMisc      :: {-# UNPACK #-} !PlatformMisc,-  rawSettings       :: [(String, String)],-  tmpDir            :: TempDir,--  llvmConfig            :: LlvmConfig,-    -- ^ N.B. It's important that this field is lazy since we load the LLVM-    -- configuration lazily. See Note [LLVM configuration] in "GHC.SysTools".-  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 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-  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-  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--  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     :: Set.Set ModuleName,--  -- 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.--  --  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,-  -- 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,--  ghciHistSize          :: Int,--  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,-  colScheme             :: Col.Scheme,--  -- | what kind of {-# SCC #-} to add automatically-  profAuto              :: ProfAuto,-  callerCcFilters       :: [CallerCcFilter],--  interactivePrint      :: Maybe String,--  -- | Machine dependent flags (-m\<blah> stuff)-  sseVersion            :: Maybe SseVersion,-  bmiVersion            :: Maybe BmiVersion,-  avx                   :: Bool,-  avx2                  :: Bool,-  avx512cd              :: Bool, -- Enable AVX-512 Conflict Detection Instructions.-  avx512er              :: Bool, -- Enable AVX-512 Exponential and Reciprocal Instructions.-  avx512f               :: Bool, -- Enable AVX-512 instructions.-  avx512pf              :: Bool, -- Enable AVX-512 PreFetch Instructions.--  -- | Run-time linker information (what options we need, etc.)-  rtldInfo              :: IORef (Maybe LinkerInfo),--  -- | Run-time C compiler information-  rtccInfo              :: IORef (Maybe CompilerInfo),--  -- | Run-time assembler information-  rtasmInfo              :: IORef (Maybe CompilerInfo),--  -- Constants used to control the amount of optimization done.--  -- | Max size, in bytes, of inline array allocations.-  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         :: Word,-  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--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 LlvmTarget = LlvmTarget-  { lDataLayout :: String-  , lCPU        :: String-  , lAttributes :: [String]-  }---- | See Note [LLVM configuration] in "GHC.SysTools".-data LlvmConfig = LlvmConfig { llvmTargets :: [(String, LlvmTarget)]-                             , llvmPasses  :: [(Int, String)]-                             }---------------------------------------------------------------------------------- Accessessors 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-  , sTargetPlatform = targetPlatform dflags-  , sToolSettings = toolSettings dflags-  , sPlatformMisc = platformMisc dflags-  , sRawSettings = rawSettings dflags-  }--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-toolDir               :: DynFlags -> Maybe FilePath-toolDir dflags = fileSettings_toolDir $ fileSettings dflags-topDir                :: DynFlags -> FilePath-topDir dflags = fileSettings_topDir $ fileSettings dflags-extraGccViaCFlags     :: DynFlags -> [String]-extraGccViaCFlags dflags = toolSettings_extraGccViaCFlags $ toolSettings dflags-globalPackageDatabasePath   :: DynFlags -> FilePath-globalPackageDatabasePath dflags = fileSettings_globalPackageDatabase $ fileSettings 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_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_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_dll               :: DynFlags -> (String,[Option])-pgm_dll dflags = toolSettings_pgm_dll $ toolSettings dflags-pgm_T                 :: DynFlags -> String-pgm_T dflags = toolSettings_pgm_T $ toolSettings dflags-pgm_windres           :: DynFlags -> String-pgm_windres dflags = toolSettings_pgm_windres $ toolSettings dflags-pgm_libtool           :: DynFlags -> String-pgm_libtool dflags = toolSettings_pgm_libtool $ toolSettings dflags-pgm_lcc               :: DynFlags -> (String,[Option])-pgm_lcc dflags = toolSettings_pgm_lcc $ toolSettings dflags-pgm_ar                :: DynFlags -> String-pgm_ar dflags = toolSettings_pgm_ar $ toolSettings dflags-pgm_otool             :: DynFlags -> String-pgm_otool dflags = toolSettings_pgm_otool $ toolSettings dflags-pgm_install_name_tool :: DynFlags -> String-pgm_install_name_tool dflags = toolSettings_pgm_install_name_tool $ 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_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)---- 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-  )--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= 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_lcc                :: DynFlags -> [String]-opt_lcc dflags= toolSettings_opt_lcc $ 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_i                 :: DynFlags -> [String]-opt_i dflags= toolSettings_opt_i $ toolSettings 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---- | 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-      }----------------------------------------------------------------------------------- | Used by 'GHC.runGhc' to partially initialize a new 'DynFlags' value-initDynFlags :: DynFlags -> IO DynFlags-initDynFlags dflags = do- let- refRtldInfo <- newIORef Nothing- refRtccInfo <- newIORef Nothing- refRtasmInfo <- newIORef Nothing- 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,-        colScheme     = colScheme',-        rtldInfo      = refRtldInfo,-        rtccInfo      = refRtccInfo,-        rtasmInfo     = refRtasmInfo,-        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 -> LlvmConfig -> DynFlags-defaultDynFlags mySettings llvmConfig =--- 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-        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            = Just 1,--        enableTimeStats         = False,-        ghcHeapSize             = Nothing,--        importPaths             = ["."],-        mainModuleNameIs        = mAIN_NAME,-        mainFunIs               = Nothing,-        reductionDepth          = treatZeroAsInf mAX_REDUCTION_DEPTH,-        solverIterations        = treatZeroAsInf mAX_SOLVER_ITERATIONS,--        homeUnitId_             = mainUnitId,-        homeUnitInstanceOf_     = Nothing,-        homeUnitInstantiations_ = [],--        workingDirectory        = Nothing,-        thisPackageName         = Nothing,-        hiddenModules           = Set.empty,-        reexportedModules       = Set.empty,--        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      = [],--        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,-        fileSettings = sFileSettings mySettings,-        toolSettings = sToolSettings mySettings,-        targetPlatform = sTargetPlatform mySettings,-        platformMisc = sPlatformMisc mySettings,-        rawSettings = sRawSettings mySettings,--        tmpDir                  = panic "defaultDynFlags: uninitialized tmpDir",--        -- See Note [LLVM configuration].-        llvmConfig              = llvmConfig,-        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,-        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,--        ghciHistSize = 50, -- keep a log of length 50 by default--        flushOut = defaultFlushOut,-        pprUserLength = 5,-        pprCols = 100,-        useUnicode = False,-        useColor = Auto,-        canUseColor = 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,-        rtldInfo = panic "defaultDynFlags: no rtldInfo",-        rtccInfo = panic "defaultDynFlags: no rtccInfo",-        rtasmInfo = panic "defaultDynFlags: no rtasmInfo",--        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--{--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] -> EnumSet LangExt.Extension-flattenExtensionFlags ml = foldr f defaultExtensionFlags-    where f (On f)  flags = EnumSet.insert f flags-          f (Off f) flags = EnumSet.delete f flags-          defaultExtensionFlags = EnumSet.fromList (languageExtensions ml)---- | 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 GHC2021)--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)-      ]--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 ]--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,-       -- 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]--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 = (f `EnumSet.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_tc                     = False-          enableIfVerbose Opt_D_dump_rn                     = 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_verbose_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 = 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) }---- | 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)-          }---- | 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-  :: [(String, DynFlags -> SrcSpan, DynFlags -> Bool, DynFlags -> DynFlags)]-unsafeFlags = [ ("-XGeneralizedNewtypeDeriving", newDerivOnLoc,-                    xopt LangExt.GeneralizedNewtypeDeriving,-                    flip xopt_unset LangExt.GeneralizedNewtypeDeriving)-              , ("-XDerivingVia", deriveViaOnLoc,-                    xopt LangExt.DerivingVia,-                    flip xopt_unset LangExt.DerivingVia)-              , ("-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, setHieDir, setStubDir, setDumpDir, setOutputDir,-         setDynObjectSuf, setDynHiSuf,-         setDylibInstallName,-         setObjectSuf, setHiSuf, setHieSuf, setHcSuf, parseDynLibLoaderMode,-         setPgmP, addOptl, addOptc, addOptcxx, addOptP,-         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--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) = 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]-  where-  fingerprintStrings ss = fingerprintFingerprints $ map fingerprintString ss---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 => DynFlags -> [Located String]-                         -> m (DynFlags, [Located String], [Warn])-                            -- ^ 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], [Warn])-                          -- ^ 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)--instance Monad (CmdLineP s) where-    CmdLineP k >>= f = CmdLineP (k >>= \x -> case f x of CmdLineP g -> g)-    return = pure--instance Applicative (CmdLineP s) where-    pure x = CmdLineP (pure x)-    (<*>) = ap--instance Functor (CmdLineP s) where-    fmap f (CmdLineP k) = CmdLineP (fmap f k)--getCmdLineState :: CmdLineP s s-getCmdLineState = CmdLineP State.get--putCmdLineState :: s -> CmdLineP s ()-putCmdLineState x = CmdLineP (State.put x)--runCmdLineP :: CmdLineP s a -> s -> (a, s)-runCmdLineP (CmdLineP k) s0 = runIdentity $ runStateT k s0---- | A helper to parse a set of flags from a list of command-line arguments, handling--- response files.-processCmdLineP-    :: forall s m. MonadIO m-    => [Flag (CmdLineP s)]  -- ^ valid flags to match against-    -> s                    -- ^ current state-    -> [Located String]     -- ^ arguments to parse-    -> m (([Located String], [Err], [Warn]), s)-                            -- ^ (leftovers, errors, warnings)-processCmdLineP activeFlags s0 args =-    runStateT (processArgs (map (hoistFlag getCmdLineP) activeFlags) args parseResponseFile) s0-  where-    getCmdLineP :: CmdLineP s a -> StateT s m a-    getCmdLineP (CmdLineP k) = k---- | Parses the dynamically set flags for GHC. This is the most general form of--- the dynamic flag parser that the other methods simply wrap. It allows--- saying which flags are valid flags and indicating if we are parsing--- arguments from the command line or from a file pragma.-parseDynamicFlagsFull-    :: forall m. MonadIO m-    => [Flag (CmdLineP DynFlags)]    -- ^ valid flags to match against-    -> Bool                          -- ^ are the arguments from the command line?-    -> DynFlags                      -- ^ current dynamic flags-    -> [Located String]              -- ^ arguments to parse-    -> m (DynFlags, [Located String], [Warn])-parseDynamicFlagsFull activeFlags cmdline dflags0 args = do-  ((leftover, errs, 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) = 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--  let warns' = map (Warn WarningWithoutFlag) (consistency_warnings ++ sh_warns)--  return (dflags3, leftover, warns' ++ 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, [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   -> (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, [])--    pkgWarnMsg = [L (pkgTrustOnLoc dflags') $-                    "-fpackage-trust ignored;" ++-                    " must be specified with a Safe Haskell flag"]--    -- Have we inferred Unsafe? See Note [GHC.Driver.Main . 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-                              , 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)-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 (WordSuffix f) message =-                                  WordSuffix $ \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 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 specifying that the number of-                 -- parallel builds is equal to the-                 -- result of getNumProcessors-  , 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 "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 removeWayDyn)-  , 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 "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 "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 "pgmdll"-      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_dll = (f,[]) }-  , make_ord_flag defFlag "pgmwindres"-      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_windres = f }-  , make_ord_flag defFlag "pgmlibtool"-      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_libtool = 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 "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 "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 }--  , make_ord_flag defGhcFlag "split-objs"-      (NoArg $ addWarn "ignoring -split-objs")--  , make_ord_flag defGhcFlag "split-sections"-      (noArgM (\dflags -> do-        if platformHasSubsectionsViaSymbols (targetPlatform dflags)-          then do addWarn $-                    "-split-sections is not useful on this platform " ++-                    "since it always uses subsections via symbols. Ignoring."-                  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-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 LLVM >> setGeneralFlag Opt_KeepLlvmFiles)-  , make_ord_flag defGhcFlag "keep-llvm-files"-        (NoArg $ setObjBackend LLVM >> 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 })))--  -- 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_SuppressStgExts-                  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-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-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-prep"-        (setDumpFlag Opt_D_dump_prep)-  , make_ord_flag defGhcFlag "ddump-late-cc"-        (setDumpFlag Opt_D_dump_late_cc)-  , make_ord_flag defGhcFlag "ddump-stg-from-core"-        (setDumpFlag Opt_D_dump_stg_from_core)-  , make_ord_flag defGhcFlag "ddump-stg-unarised"-        (setDumpFlag Opt_D_dump_stg_unarised)-  , make_ord_flag defGhcFlag "ddump-stg-final"-        (setDumpFlag Opt_D_dump_stg_final)-  , make_ord_flag defGhcFlag "ddump-stg-cg"-        (setDumpFlag Opt_D_dump_stg_cg)-  , make_dep_flag defGhcFlag "ddump-stg"-        (setDumpFlag Opt_D_dump_stg_from_core)-        "Use `-ddump-stg-from-core` or `-ddump-stg-final` instead"-  , make_ord_flag defGhcFlag "ddump-stg-tags"-        (setDumpFlag Opt_D_dump_stg_tags)-  , make_ord_flag defGhcFlag "ddump-call-arity"-        (setDumpFlag Opt_D_dump_call_arity)-  , make_ord_flag defGhcFlag "ddump-exitify"-        (setDumpFlag Opt_D_dump_exitify)-  , 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-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-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 "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_ord_flag defGhcFlag "ddump-json"-        (setDumpFlag Opt_D_dump_json )-  , make_ord_flag defGhcFlag "dppr-debug"-        (setDumpFlag Opt_D_ppr_debug)-  , make_ord_flag defGhcFlag "ddebug-output"-        (noArg (flip dopt_unset Opt_D_no_debug_output))-  , make_ord_flag defGhcFlag "dno-debug-output"-        (setDumpFlag Opt_D_no_debug_output)--  , make_ord_flag defGhcFlag "ddump-faststrings"-        (setDumpFlag Opt_D_dump_faststrings)--        ------ Machine dependent (-m<blah>) stuff -----------------------------  , make_ord_flag defGhcFlag "msse"         (noArg (\d ->-                                                  d { sseVersion = Just SSE1 }))-  , make_ord_flag defGhcFlag "msse2"        (noArg (\d ->-                                                  d { sseVersion = Just SSE2 }))-  , make_ord_flag defGhcFlag "msse3"        (noArg (\d ->-                                                  d { sseVersion = Just SSE3 }))-  , make_ord_flag defGhcFlag "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 }))--     ------ 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 = EnumSet.empty})))-                                             "Use -w or -Wno-everything instead"-  , make_ord_flag defFlag "w"       (NoArg (upd (\d ->-                                              d {warningFlags = EnumSet.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 = EnumSet.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-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)--        ------ 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_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 }))-  , (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 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"-      (wordSuffix (\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)-  , make_ord_flag defGhcFlag "fdistinct-constructor-tables"-      (NoArg (setGeneralFlag Opt_DistinctConstructorTables))-  , make_ord_flag defGhcFlag "finfo-table-map"-      (NoArg (setGeneralFlag Opt_InfoTableMap))-        ------ Compiler flags -------------------------------------------------  , make_ord_flag defGhcFlag "fasm"             (NoArg (setObjBackend NCG))-  , 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 LLVM))--  , make_ord_flag defFlag "fno-code"         (NoArg ((upd $ \d ->-                  d { ghcLink=NoLink }) >> setBackend NoBackend))-  , make_ord_flag defFlag "fbyte-code"-      (noArgM $ \dflags -> do-        setBackend Interpreter-        pure $ gopt_set dflags Opt_ByteCode)-  , make_ord_flag defFlag "fobject-code"     $ NoArg $ do-      dflags <- liftEwM getCmdLineState-      setBackend $ platformDefaultBackend (targetPlatform dflags)--  , 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 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- ++ map (mkFlag turnOn  "W"         setWarningFlag    ) wWarningFlagsDeps- ++ map (mkFlag turnOff "Wno-"      unSetWarningFlag  ) wWarningFlagsDeps- ++ map (mkFlag turnOn  "Werror="   setWErrorFlag )     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-") ]- ++ [ make_ord_flag defFlag "Werror=compat"-        (NoArg (mapM_ setWErrorFlag minusWcompatOpts))-    , make_ord_flag defFlag "Wno-error=compat"-        (NoArg (mapM_ unSetFatalWarningFlag minusWcompatOpts))-    , make_ord_flag defFlag "Wwarn=compat"-        (NoArg (mapM_ unSetFatalWarningFlag minusWcompatOpts)) ]- ++ 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---- | This is where we handle unrecognised warning flags. We only issue a warning--- if -Wunrecognised-warning-flags is set. See #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 $ addFlagWarn (WarningWithFlag Opt_WarnUnrecognisedWarningFlags) $-        "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 (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)-  ]-  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 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 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)---- here to avoid module cycle with GHC.Driver.CmdLine-deprecate :: Monad m => String -> EwM m ()-deprecate s = do-    arg <- getArg-    addFlagWarn (WarningWithFlag Opt_WarnDeprecatedFlags) (arg ++ " is deprecated: " ++ s)--deprecatedForExtension :: String -> TurnOnFlag -> String-deprecatedForExtension lang turn_on-    = "use -X" ++ flag ++-      " or pragma {-# LANGUAGE " ++ flag ++ " #-} instead"-    where-      flag | turn_on   = lang-           | otherwise = "No" ++ lang--useInstead :: String -> String -> TurnOnFlag -> String-useInstead prefix flag turn_on-  = "Use " ++ prefix ++ no ++ flag ++ " instead"-  where-    no = if turn_on then "" else "no-"--nop :: TurnOnFlag -> DynP ()-nop _ = return ()---- | Find the 'FlagSpec' for a 'WarningFlag'.-flagSpecOf :: WarningFlag -> Maybe (FlagSpec WarningFlag)-flagSpecOf = flip Map.lookup wWarningFlagMap--wWarningFlagMap :: Map.Map WarningFlag (FlagSpec WarningFlag)-wWarningFlagMap = Map.fromListWith (\_ x -> x) $ map (flagSpecFlag &&& id) wWarningFlags---- | These @-W\<blah\>@ flags can all be reversed with @-Wno-\<blah\>@-wWarningFlags :: [FlagSpec WarningFlag]-wWarningFlags = map snd (sortBy (comparing fst) wWarningFlagsDeps)--wWarningFlagsDeps :: [(Deprecation, FlagSpec WarningFlag)]-wWarningFlagsDeps = mconcat [--- See Note [Updating flag description in the User's Guide]--- See Note [Supporting CLI completion]--- Please keep the list of flags below sorted alphabetically-  warnSpec    Opt_WarnAlternativeLayoutRuleTransitional,-  warnSpec    Opt_WarnAmbiguousFields,-  depWarnSpec Opt_WarnAutoOrphans-              "it has no effect",-  warnSpec    Opt_WarnCPPUndef,-  warnSpec    Opt_WarnUnbangedStrictPatterns,-  warnSpec    Opt_WarnDeferredTypeErrors,-  warnSpec    Opt_WarnDeferredOutOfScopeVariables,-  warnSpec    Opt_WarnWarningsDeprecations,-  warnSpec    Opt_WarnDeprecatedFlags,-  warnSpec    Opt_WarnDerivingDefaults,-  warnSpec    Opt_WarnDerivingTypeable,-  warnSpec    Opt_WarnDodgyExports,-  warnSpec    Opt_WarnDodgyForeignImports,-  warnSpec    Opt_WarnDodgyImports,-  warnSpec    Opt_WarnEmptyEnumerations,-  subWarnSpec "duplicate-constraints"-              Opt_WarnDuplicateConstraints-              "it is subsumed by -Wredundant-constraints",-  warnSpec    Opt_WarnRedundantConstraints,-  warnSpec    Opt_WarnDuplicateExports,-  depWarnSpec Opt_WarnHiShadows-              "it is not used, and was never implemented",-  warnSpec    Opt_WarnInaccessibleCode,-  warnSpec    Opt_WarnImplicitPrelude,-  depWarnSpec Opt_WarnImplicitKindVars-              "it is now an error",-  warnSpec    Opt_WarnIncompletePatterns,-  warnSpec    Opt_WarnIncompletePatternsRecUpd,-  warnSpec    Opt_WarnIncompleteUniPatterns,-  warnSpec    Opt_WarnInlineRuleShadowing,-  warnSpec    Opt_WarnIdentities,-  warnSpec    Opt_WarnMissingFields,-  warnSpec    Opt_WarnMissingImportList,-  warnSpec    Opt_WarnMissingExportList,-  subWarnSpec "missing-local-sigs"-              Opt_WarnMissingLocalSignatures-              "it is replaced by -Wmissing-local-signatures",-  warnSpec    Opt_WarnMissingLocalSignatures,-  warnSpec    Opt_WarnMissingMethods,-  depWarnSpec Opt_WarnMissingMonadFailInstances-              "fail is no longer a method of Monad",-  warnSpec    Opt_WarnSemigroup,-  warnSpec    Opt_WarnMissingSignatures,-  warnSpec    Opt_WarnMissingKindSignatures,-  subWarnSpec "missing-exported-sigs"-              Opt_WarnMissingExportedSignatures-              "it is replaced by -Wmissing-exported-signatures",-  warnSpec    Opt_WarnMissingExportedSignatures,-  warnSpec    Opt_WarnMonomorphism,-  warnSpec    Opt_WarnNameShadowing,-  warnSpec    Opt_WarnNonCanonicalMonadInstances,-  depWarnSpec Opt_WarnNonCanonicalMonadFailInstances-              "fail is no longer a method of Monad",-  warnSpec    Opt_WarnNonCanonicalMonoidInstances,-  warnSpec    Opt_WarnOrphans,-  warnSpec    Opt_WarnOverflowedLiterals,-  warnSpec    Opt_WarnOverlappingPatterns,-  warnSpec    Opt_WarnMissedSpecs,-  warnSpec    Opt_WarnAllMissedSpecs,-  warnSpec'   Opt_WarnSafe setWarnSafe,-  warnSpec    Opt_WarnTrustworthySafe,-  warnSpec    Opt_WarnInferredSafeImports,-  warnSpec    Opt_WarnMissingSafeHaskellMode,-  warnSpec    Opt_WarnTabs,-  warnSpec    Opt_WarnTypeDefaults,-  warnSpec    Opt_WarnTypedHoles,-  warnSpec    Opt_WarnPartialTypeSignatures,-  warnSpec    Opt_WarnUnrecognisedPragmas,-  warnSpec    Opt_WarnMisplacedPragmas,-  warnSpec'   Opt_WarnUnsafe setWarnUnsafe,-  warnSpec    Opt_WarnUnsupportedCallingConventions,-  warnSpec    Opt_WarnUnsupportedLlvmVersion,-  warnSpec    Opt_WarnMissedExtraSharedLib,-  warnSpec    Opt_WarnUntickedPromotedConstructors,-  warnSpec    Opt_WarnUnusedDoBind,-  warnSpec    Opt_WarnUnusedForalls,-  warnSpec    Opt_WarnUnusedImports,-  warnSpec    Opt_WarnUnusedLocalBinds,-  warnSpec    Opt_WarnUnusedMatches,-  warnSpec    Opt_WarnUnusedPatternBinds,-  warnSpec    Opt_WarnUnusedTopBinds,-  warnSpec    Opt_WarnUnusedTypePatterns,-  warnSpec    Opt_WarnUnusedRecordWildcards,-  warnSpec    Opt_WarnRedundantBangPatterns,-  warnSpec    Opt_WarnRedundantRecordWildcards,-  warnSpec    Opt_WarnRedundantStrictnessFlags,-  warnSpec    Opt_WarnWrongDoBind,-  warnSpec    Opt_WarnMissingPatternSynonymSignatures,-  warnSpec    Opt_WarnMissingDerivingStrategies,-  warnSpec    Opt_WarnSimplifiableClassConstraints,-  warnSpec    Opt_WarnMissingHomeModules,-  warnSpec    Opt_WarnUnrecognisedWarningFlags,-  warnSpec    Opt_WarnStarBinder,-  warnSpec    Opt_WarnStarIsType,-  depWarnSpec Opt_WarnSpaceAfterBang-              "bang patterns can no longer be written with a space",-  warnSpec    Opt_WarnPartialFields,-  warnSpec    Opt_WarnPrepositiveQualifiedModule,-  warnSpec    Opt_WarnUnusedPackages,-  warnSpec    Opt_WarnCompatUnqualifiedImports,-  warnSpec    Opt_WarnInvalidHaddock,-  warnSpec    Opt_WarnOperatorWhitespaceExtConflict,-  warnSpec    Opt_WarnOperatorWhitespace,-  warnSpec    Opt_WarnImplicitLift,-  warnSpec    Opt_WarnMissingExportedPatternSynonymSignatures,-  warnSpec    Opt_WarnForallIdentifier,-  warnSpec    Opt_WarnUnicodeBidirectionalFormatCharacters,-  warnSpec    Opt_WarnGADTMonoLocalBinds,-  warnSpec    Opt_WarnTypeEqualityOutOfScope,-  warnSpec    Opt_WarnTypeEqualityRequiresOperators- ]---- | These @-\<blah\>@ flags can all be reversed with @-no-\<blah\>@-negatableFlagsDeps :: [(Deprecation, FlagSpec GeneralFlag)]-negatableFlagsDeps = [-  flagGhciSpec "ignore-dot-ghci"         Opt_IgnoreDotGhci ]---- | These @-d\<blah\>@ flags can all be reversed with @-dno-\<blah\>@-dFlagsDeps :: [(Deprecation, FlagSpec GeneralFlag)]-dFlagsDeps = [--- See Note [Updating flag description in the User's Guide]--- See Note [Supporting CLI completion]--- Please keep the list of flags below sorted alphabetically-  flagSpec "ppr-case-as-let"            Opt_PprCaseAsLet,-  depFlagSpec' "ppr-ticks"              Opt_PprShowTicks-     (\turn_on -> useInstead "-d" "suppress-ticks" (not turn_on)),-  flagSpec "suppress-ticks"             Opt_SuppressTicks,-  depFlagSpec' "suppress-stg-free-vars" Opt_SuppressStgExts-     (useInstead "-d" "suppress-stg-exts"),-  flagSpec "suppress-stg-exts"          Opt_SuppressStgExts,-  flagSpec "suppress-coercions"         Opt_SuppressCoercions,-  flagSpec "suppress-idinfo"            Opt_SuppressIdInfo,-  flagSpec "suppress-unfoldings"        Opt_SuppressUnfoldings,-  flagSpec "suppress-module-prefixes"   Opt_SuppressModulePrefixes,-  flagSpec "suppress-timestamps"        Opt_SuppressTimestamps,-  flagSpec "suppress-type-applications" Opt_SuppressTypeApplications,-  flagSpec "suppress-type-signatures"   Opt_SuppressTypeSignatures,-  flagSpec "suppress-uniques"           Opt_SuppressUniques,-  flagSpec "suppress-var-kinds"         Opt_SuppressVarKinds,-  flagSpec "suppress-core-sizes"        Opt_SuppressCoreSizes-  ]---- | These @-f\<blah\>@ flags can all be reversed with @-fno-\<blah\>@-fFlags :: [FlagSpec GeneralFlag]-fFlags = map snd fFlagsDeps--fFlagsDeps :: [(Deprecation, FlagSpec GeneralFlag)]-fFlagsDeps = [--- See Note [Updating flag description in the User's Guide]--- See Note [Supporting CLI completion]--- Please keep the list of flags below sorted alphabetically-  flagSpec "asm-shortcutting"                 Opt_AsmShortcutting,-  flagGhciSpec "break-on-error"               Opt_BreakOnError,-  flagGhciSpec "break-on-exception"           Opt_BreakOnException,-  flagSpec "building-cabal-package"           Opt_BuildingCabalPackage,-  flagSpec "call-arity"                       Opt_CallArity,-  flagSpec "exitification"                    Opt_Exitification,-  flagSpec "case-merge"                       Opt_CaseMerge,-  flagSpec "case-folding"                     Opt_CaseFolding,-  flagSpec "cmm-elim-common-blocks"           Opt_CmmElimCommonBlocks,-  flagSpec "cmm-sink"                         Opt_CmmSink,-  flagSpec "cmm-static-pred"                  Opt_CmmStaticPred,-  flagSpec "cse"                              Opt_CSE,-  flagSpec "stg-cse"                          Opt_StgCSE,-  flagSpec "stg-lift-lams"                    Opt_StgLiftLams,-  flagSpec "cpr-anal"                         Opt_CprAnal,-  flagSpec "defer-diagnostics"                Opt_DeferDiagnostics,-  flagSpec "defer-type-errors"                Opt_DeferTypeErrors,-  flagSpec "defer-typed-holes"                Opt_DeferTypedHoles,-  flagSpec "defer-out-of-scope-variables"     Opt_DeferOutOfScopeVariables,-  flagSpec "diagnostics-show-caret"           Opt_DiagnosticsShowCaret,-  flagSpec "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 "eager-blackholing"                Opt_EagerBlackHoling,-  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-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 "gen-manifest"                     Opt_GenManifest,-  flagSpec "ghci-history"                     Opt_GhciHistory,-  flagSpec "ghci-leak-check"                  Opt_GhciLeakCheck,-  flagSpec "validate-ide-info"                Opt_ValidateHie,-  flagGhciSpec "local-ghci-history"           Opt_LocalGhciHistory,-  flagGhciSpec "no-it"                        Opt_NoIt,-  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 "keep-going"                       Opt_KeepGoing,-  flagSpec "late-dmd-anal"                    Opt_LateDmdAnal,-  flagSpec "late-specialise"                  Opt_LateSpecialise,-  flagSpec "liberate-case"                    Opt_LiberateCase,-  flagHiddenSpec "llvm-tbaa"                  Opt_LlvmTBAA,-  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-typechecker-elaboration"    Opt_PrintTypecheckerElaboration,-  flagSpec "prof-cafs"                        Opt_AutoSccsOnIndividualCafs,-  flagSpec "prof-count-entries"               Opt_ProfCountEntries,-  flagSpec "prof-late"                        Opt_ProfLateCcs,-  flagSpec "prof-manual"                      Opt_ProfManualCcs,-  flagSpec "prof-late-inline"                 Opt_ProfLateInlineCcs,-  flagSpec "regs-graph"                       Opt_RegsGraph,-  flagSpec "regs-iterative"                   Opt_RegsIterative,-  depFlagSpec' "rewrite-rules"                Opt_EnableRewriteRules-   (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 "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-ide-info"                   Opt_WriteHie,-  flagSpec "unbox-small-strict-fields"        Opt_UnboxSmallStrictFields,-  flagSpec "unbox-strict-fields"              Opt_UnboxStrictFields,-  flagSpec "version-macros"                   Opt_VersionMacros,-  flagSpec "worker-wrapper"                   Opt_WorkerWrapper,-  flagSpec "worker-wrapper-cbv"               Opt_WorkerWrapperUnlift,-  flagSpec "solve-constant-dicts"             Opt_SolveConstantDicts,-  flagSpec "catch-nonexhaustive-cases"        Opt_CatchNonexhaustiveCases,-  flagSpec "alignment-sanitisation"           Opt_AlignmentSanitisation,-  flagSpec "check-prim-bounds"                Opt_DoBoundsChecking,-  flagSpec "num-constant-folding"             Opt_NumConstantFolding,-  flagSpec "core-constant-folding"            Opt_CoreConstantFolding,-  flagSpec "fast-pap-calls"                   Opt_FastPAPCalls,-  flagSpec "cmm-control-flow"                 Opt_CmmControlFlow,-  flagSpec "show-warning-groups"              Opt_ShowWarnGroups,-  flagSpec "hide-source-paths"                Opt_HideSourcePaths,-  flagSpec "show-loaded-modules"              Opt_ShowLoadedModules,-  flagSpec "whole-archive-hs-libs"            Opt_WholeArchiveHsLibs,-  flagSpec "keep-cafs"                        Opt_KeepCAFs,-  flagSpec "link-rts"                         Opt_LinkRts,-  flagSpec' "compact-unwind"                  Opt_CompactUnwind-      (\turn_on -> updM (\dflags -> do-        unless (platformOS (targetPlatform dflags) == OSDarwin && turn_on)-               (addWarn "-compact-unwind is only implemented by the darwin platform. Ignoring.")-        return dflags))--  ]-  ++ fHoleFlags---- | These @-f\<blah\>@ flags have to do with the typed-hole error message or--- the valid hole fits in that message. See Note [Valid hole fits include ...]--- in the "GHC.Tc.Errors.Hole" module. These flags can all be reversed with--- @-fno-\<blah\>@-fHoleFlags :: [(Deprecation, FlagSpec GeneralFlag)]-fHoleFlags = [-  flagSpec "show-hole-constraints"            Opt_ShowHoleConstraints,-  depFlagSpec' "show-valid-substitutions"     Opt_ShowValidHoleFits-   (useInstead "-f" "show-valid-hole-fits"),-  flagSpec "show-valid-hole-fits"             Opt_ShowValidHoleFits,-  -- Sorting settings-  flagSpec "sort-valid-hole-fits"             Opt_SortValidHoleFits,-  flagSpec "sort-by-size-hole-fits"           Opt_SortBySizeHoleFits,-  flagSpec "sort-by-subsumption-hole-fits"    Opt_SortBySubsumHoleFits,-  flagSpec "abstract-refinement-hole-fits"    Opt_AbstractRefHoleFits,-  -- Output format settings-  flagSpec "show-hole-matches-of-hole-fits"   Opt_ShowMatchesOfHoleFits,-  flagSpec "show-provenance-of-hole-fits"     Opt_ShowProvOfHoleFits,-  flagSpec "show-type-of-hole-fits"           Opt_ShowTypeOfHoleFits,-  flagSpec "show-type-app-of-hole-fits"       Opt_ShowTypeAppOfHoleFits,-  flagSpec "show-type-app-vars-of-hole-fits"  Opt_ShowTypeAppVarsOfHoleFits,-  flagSpec "show-docs-of-hole-fits"           Opt_ShowDocsOfHoleFits,-  flagSpec "unclutter-valid-hole-fits"        Opt_UnclutterValidHoleFits-  ]---- | These @-f\<blah\>@ flags can all be reversed with @-fno-\<blah\>@-fLangFlags :: [FlagSpec LangExt.Extension]-fLangFlags = map snd fLangFlagsDeps--fLangFlagsDeps :: [(Deprecation, FlagSpec LangExt.Extension)]-fLangFlagsDeps = [--- See Note [Updating flag description in the User's Guide]--- See Note [Supporting CLI completion]-  depFlagSpecOp' "th"                           LangExt.TemplateHaskell-    checkTemplateHaskellOk-    (deprecatedForExtension "TemplateHaskell"),-  depFlagSpec' "fi"                             LangExt.ForeignFunctionInterface-    (deprecatedForExtension "ForeignFunctionInterface"),-  depFlagSpec' "ffi"                            LangExt.ForeignFunctionInterface-    (deprecatedForExtension "ForeignFunctionInterface"),-  depFlagSpec' "arrows"                         LangExt.Arrows-    (deprecatedForExtension "Arrows"),-  depFlagSpec' "implicit-prelude"               LangExt.ImplicitPrelude-    (deprecatedForExtension "ImplicitPrelude"),-  depFlagSpec' "bang-patterns"                  LangExt.BangPatterns-    (deprecatedForExtension "BangPatterns"),-  depFlagSpec' "monomorphism-restriction"       LangExt.MonomorphismRestriction-    (deprecatedForExtension "MonomorphismRestriction"),-  depFlagSpec' "extended-default-rules"         LangExt.ExtendedDefaultRules-    (deprecatedForExtension "ExtendedDefaultRules"),-  depFlagSpec' "implicit-params"                LangExt.ImplicitParams-    (deprecatedForExtension "ImplicitParams"),-  depFlagSpec' "scoped-type-variables"          LangExt.ScopedTypeVariables-    (deprecatedForExtension "ScopedTypeVariables"),-  depFlagSpec' "allow-overlapping-instances"    LangExt.OverlappingInstances-    (deprecatedForExtension "OverlappingInstances"),-  depFlagSpec' "allow-undecidable-instances"    LangExt.UndecidableInstances-    (deprecatedForExtension "UndecidableInstances"),-  depFlagSpec' "allow-incoherent-instances"     LangExt.IncoherentInstances-    (deprecatedForExtension "IncoherentInstances")-  ]--supportedLanguages :: [String]-supportedLanguages = map (flagSpecName . snd) languageFlagsDeps--supportedLanguageOverlays :: [String]-supportedLanguageOverlays = map (flagSpecName . snd) safeHaskellFlagsDeps--supportedExtensions :: ArchOS -> [String]-supportedExtensions (ArchOS _ 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]-      | otherwise = [name, noName]-      where-        isAIX = os == OSAIX-        noName = "No" ++ name-        name = flagSpecName flg--supportedLanguagesAndExtensions :: ArchOS -> [String]-supportedLanguagesAndExtensions arch_os =-    supportedLanguages ++ supportedLanguageOverlays ++ supportedExtensions arch_os---- | These -X<blah> flags cannot be reversed with -XNo<blah>-languageFlagsDeps :: [(Deprecation, FlagSpec Language)]-languageFlagsDeps = [-  flagSpec "Haskell98"   Haskell98,-  flagSpec "Haskell2010" Haskell2010,-  flagSpec "GHC2021"     GHC2021-  ]---- | These -X<blah> flags cannot be reversed with -XNo<blah>--- They are used to place hard requirements on what GHC Haskell language--- features can be used.-safeHaskellFlagsDeps :: [(Deprecation, FlagSpec SafeHaskellMode)]-safeHaskellFlagsDeps = [mkF Sf_Unsafe, mkF Sf_Trustworthy, mkF Sf_Safe]-    where mkF flag = flagSpec (show flag) flag---- | These -X<blah> flags can all be reversed with -XNo<blah>-xFlags :: [FlagSpec LangExt.Extension]-xFlags = map snd xFlagsDeps--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,-  depFlagSpecCond "AutoDeriveTypeable"        LangExt.AutoDeriveTypeable-    id-         ("Typeable instances are created automatically " ++-                     "for all types since GHC 8.2."),-  flagSpec "BangPatterns"                     LangExt.BangPatterns,-  flagSpec "BinaryLiterals"                   LangExt.BinaryLiterals,-  flagSpec "CApiFFI"                          LangExt.CApiFFI,-  flagSpec "CPP"                              LangExt.Cpp,-  flagSpec "CUSKs"                            LangExt.CUSKs,-  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' "DerivingVia"                     LangExt.DerivingVia-                                              setDeriveVia,-  flagSpec "DisambiguateRecordFields"         LangExt.DisambiguateRecordFields,-  flagSpec "DoAndIfThenElse"                  LangExt.DoAndIfThenElse,-  flagSpec "BlockArguments"                   LangExt.BlockArguments,-  depFlagSpec' "DoRec"                        LangExt.RecursiveDo-    (deprecatedForExtension "RecursiveDo"),-  flagSpec "DuplicateRecordFields"            LangExt.DuplicateRecordFields,-  flagSpec "FieldSelectors"                   LangExt.FieldSelectors,-  flagSpec "EmptyCase"                        LangExt.EmptyCase,-  flagSpec "EmptyDataDecls"                   LangExt.EmptyDataDecls,-  flagSpec "EmptyDataDeriving"                LangExt.EmptyDataDeriving,-  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' "GeneralisedNewtypeDeriving"      LangExt.GeneralizedNewtypeDeriving-                                              setGenDeriving,-  flagSpec "ImplicitParams"                   LangExt.ImplicitParams,-  flagSpec "ImplicitPrelude"                  LangExt.ImplicitPrelude,-  flagSpec "ImportQualifiedPost"              LangExt.ImportQualifiedPost,-  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 "LexicalNegation"                  LangExt.LexicalNegation,-  flagSpec "LiberalTypeSynonyms"              LangExt.LiberalTypeSynonyms,-  flagSpec "LinearTypes"                      LangExt.LinearTypes,-  flagSpec "MagicHash"                        LangExt.MagicHash,-  flagSpec "MonadComprehensions"              LangExt.MonadComprehensions,-  flagSpec "MonoLocalBinds"                   LangExt.MonoLocalBinds,-  flagSpec "DeepSubsumption"                  LangExt.DeepSubsumption,-  flagSpec "MonomorphismRestriction"          LangExt.MonomorphismRestriction,-  flagSpec "MultiParamTypeClasses"            LangExt.MultiParamTypeClasses,-  flagSpec "MultiWayIf"                       LangExt.MultiWayIf,-  flagSpec "NumericUnderscores"               LangExt.NumericUnderscores,-  flagSpec "NPlusKPatterns"                   LangExt.NPlusKPatterns,-  flagSpec "NamedFieldPuns"                   LangExt.NamedFieldPuns,-  flagSpec "NamedWildCards"                   LangExt.NamedWildCards,-  flagSpec "NegativeLiterals"                 LangExt.NegativeLiterals,-  flagSpec "HexFloatLiterals"                 LangExt.HexFloatLiterals,-  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 "QuantifiedConstraints"            LangExt.QuantifiedConstraints,-  flagSpec "PostfixOperators"                 LangExt.PostfixOperators,-  flagSpec "QuasiQuotes"                      LangExt.QuasiQuotes,-  flagSpec "QualifiedDo"                      LangExt.QualifiedDo,-  flagSpec "Rank2Types"                       LangExt.RankNTypes,-  flagSpec "RankNTypes"                       LangExt.RankNTypes,-  flagSpec "RebindableSyntax"                 LangExt.RebindableSyntax,-  flagSpec "OverloadedRecordDot"              LangExt.OverloadedRecordDot,-  flagSpec "OverloadedRecordUpdate"           LangExt.OverloadedRecordUpdate,-  depFlagSpec' "RecordPuns"                   LangExt.NamedFieldPuns-    (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 "StarIsType"                       LangExt.StarIsType,-  flagSpec "StaticPointers"                   LangExt.StaticPointers,-  flagSpec "Strict"                           LangExt.Strict,-  flagSpec "StrictData"                       LangExt.StrictData,-  flagSpec' "TemplateHaskell"                 LangExt.TemplateHaskell-                                              checkTemplateHaskellOk,-  flagSpec "TemplateHaskellQuotes"            LangExt.TemplateHaskellQuotes,-  flagSpec "StandaloneKindSignatures"         LangExt.StandaloneKindSignatures,-  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 "UnliftedDatatypes"                LangExt.UnliftedDatatypes,-  flagSpec "UnliftedFFITypes"                 LangExt.UnliftedFFITypes,-  flagSpec "UnliftedNewtypes"                 LangExt.UnliftedNewtypes,-  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_FamAppCache,-      Opt_GenManifest,-      Opt_GhciHistory,-      Opt_GhciSandbox,-      Opt_HelpfulErrors,-      Opt_KeepHiFiles,-      Opt_KeepOFiles,-      Opt_OmitYields,-      Opt_PrintBindContents,-      Opt_ProfCountEntries,-      Opt_SharedImplib,-      Opt_SimplPreInlining,-      Opt_VersionMacros,-      Opt_RPath,-      Opt_CompactUnwind-    ]--    ++ [f | (ns,f) <- optLevelFlags, 0 `elem` ns]-             -- The default -O0 options--    ++ 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 ]---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) ]--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]-    (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_DoLinearCoreLinting, turnOn, Opt_DoCoreLinting)-                ,(Opt_Strictness, turnOn, Opt_WorkerWrapper)-                ] ++ 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)]--impliedXFlags :: [(LangExt.Extension, TurnOnFlag, LangExt.Extension)]-impliedXFlags--- See Note [Updating flag description in the User's Guide]-  = [ (LangExt.RankNTypes,                turnOn, LangExt.ExplicitForAll)-    , (LangExt.QuantifiedConstraints,     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. #7854-    , (LangExt.TypeFamilyDependencies,    turnOn, LangExt.TypeFamilies)--    , (LangExt.RebindableSyntax, turnOff, LangExt.ImplicitPrelude)      -- NB: turn off!--    , (LangExt.DerivingVia, turnOn, LangExt.DerivingStrategies)--    , (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--    -- TypeInType is now just a synonym for a couple of other extensions.-    , (LangExt.TypeInType,       turnOn, LangExt.DataKinds)-    , (LangExt.TypeInType,       turnOn, LangExt.PolyKinds)-    , (LangExt.TypeInType,       turnOn, LangExt.KindSignatures)--    -- Standalone kind signatures are a replacement for CUSKs.-    , (LangExt.StandaloneKindSignatures, turnOff, LangExt.CUSKs)--    -- 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)--    -- Historically only UnboxedTuples was required for unboxed sums to work.-    -- To avoid breaking code, we make UnboxedTuples imply UnboxedSums.-    , (LangExt.UnboxedTuples, turnOn, LangExt.UnboxedSums)--    -- The extensions needed to declare an H98 unlifted data type-    , (LangExt.UnliftedDatatypes, turnOn, LangExt.DataKinds)-    , (LangExt.UnliftedDatatypes, turnOn, LangExt.StandaloneKindSignatures)-  ]---- 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)-    , ([0,1,2], Opt_DoEtaReduction)       -- See Note [Eta-reduction in -O0]-    , ([0,1,2], Opt_LlvmTBAA)-    , ([0,1,2], Opt_ProfManualCcs )-    , ([2], Opt_DictsStrict)--    , ([0],     Opt_IgnoreInterfacePragmas)-    , ([0],     Opt_OmitInterfacePragmas)--    , ([1,2],   Opt_CoreConstantFolding)--    , ([1,2],   Opt_CallArity)-    , ([1,2],   Opt_Exitification)-    , ([1,2],   Opt_CaseMerge)-    , ([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-    ]---enableUnusedBinds :: DynP ()-enableUnusedBinds = mapM_ setWarningFlag unusedBindsFlags--disableUnusedBinds :: DynP ()-disableUnusedBinds = mapM_ unSetWarningFlag unusedBindsFlags---- | 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---- Please keep 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 ]--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))--wordSuffix :: (Word -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags)-wordSuffix fn = WordSuffix (\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--removeWayDyn :: DynP ()-removeWayDyn = upd (\dfs -> dfs { targetWays_ = removeWay WayDyn (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.-----------------------------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 }-----------------------------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)------------------------------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--data PkgDbRef-  = GlobalPkgDb-  | UserPkgDb-  | PkgDbPath FilePath-  deriving Eq--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 }--setWorkingDirectory :: String -> DynFlags -> DynFlags-setWorkingDirectory p d = d { workingDirectory =  Just p }--{--Note [Filepaths and Multiple Home Units]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--It is common to assume that a package is compiled in the directory where its-cabal file resides. Thus, all paths used in the compiler are assumed to be relative-to this directory. When there are multiple home units the compiler is often-not operating in the standard directory and instead where the cabal.project-file is located. In this case the `-working-dir` option can be passed which specifies-the path from the current directory to the directory the unit assumes to be it's root,-normally the directory which contains the cabal file.--When the flag is passed, any relative paths used by the compiler are offset-by the working directory. Notably this includes `-i`, `-I⟨dir⟩`, `-hidir`, `-odir` etc and-the location of input files.---}--augmentByWorkingDirectory :: DynFlags -> FilePath -> FilePath-augmentByWorkingDirectory dflags fp | isRelative fp, Just offset <- workingDirectory dflags = offset </> fp-augmentByWorkingDirectory _ fp = fp--setPackageName :: String -> DynFlags -> DynFlags-setPackageName p d = d { thisPackageName =  Just p }--addHiddenModule :: String -> DynP ()-addHiddenModule p =-  upd (\s -> s{ hiddenModules  = Set.insert (mkModuleName p) (hiddenModules s) })--addReexportedModule :: String -> DynP ()-addReexportedModule p =-  upd (\s -> s{ reexportedModules  = Set.insert (mkModuleName p) (reexportedModules s) })----- If we're linking a binary, then only backends that produce object--- code are allowed (requests for other target types are ignored).-setBackend :: Backend -> DynP ()-setBackend l = upd $ \ dfs ->-  if ghcLink dfs /= LinkBinary || backendProducesObject 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-     | backendProducesObject (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-  | not (null main_fn) && isLower (head main_fn)-     -- The arg looked like "Foo.Bar.baz"-  = upd $ \d -> d { mainFunIs = Just main_fn,-                    mainModuleNameIs = mkModuleName main_mod }--  | isUpper (head arg)  -- The arg looked like "Foo" or "Foo.Bar"-  = upd $ \d -> d { mainModuleNameIs = 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]}---- -------------------------------------------------------------------------------- Load dynflags from environment files.--setFlagsFromEnvFile :: FilePath -> String -> DynP ()-setFlagsFromEnvFile envfile content = do-  setGeneralFlag Opt_HideAllPackages-  parseEnvFile envfile content--parseEnvFile :: FilePath -> String -> DynP ()-parseEnvFile envfile = mapM_ parseEntry . lines-  where-    parseEntry str = case words str of-      ("package-db": _)     -> addPkgDbRef (PkgDbPath (envdir </> db))-        -- relative package dbs are interpreted relative to the env file-        where envdir = takeDirectory envfile-              db     = drop 11 str-      ["clear-package-db"]  -> clearPkgDb-      ["hide-package", pkg]  -> hidePackage pkg-      ["global-package-db"] -> addPkgDbRef GlobalPkgDb-      ["user-package-db"]   -> addPkgDbRef UserPkgDb-      ["package-id", pkgid] -> exposePackageId pkgid-      (('-':'-':_):_)       -> return () -- comments-      -- and the original syntax introduced in 7.10:-      [pkgid]               -> exposePackageId pkgid-      []                    -> return ()-      _                     -> throwGhcException $ CmdLineError $-                                    "Can't parse environment file entry: "-                                 ++ envfile ++ ": " ++ str----------------------------------------------------------------------------------- Paths & Libraries--addImportPath, addLibraryPath, addIncludePath, addFrameworkPath :: FilePath -> DynP ()---- -i on its own deletes the import paths-addImportPath "" = upd (\s -> s{importPaths = []})-addImportPath p  = upd (\s -> s{importPaths = importPaths s ++ splitPathList p})--addLibraryPath p =-  upd (\s -> s{libraryPaths = libraryPaths s ++ splitPathList p})--addIncludePath p =-  upd (\s -> s{includePaths =-                  addGlobalInclude (includePaths s) (splitPathList p)})--addFrameworkPath p =-  upd (\s -> s{frameworkPaths = frameworkPaths s ++ splitPathList p})--#if !defined(mingw32_HOST_OS)-split_marker :: Char-split_marker = ':'   -- not configurable (ToDo)-#endif--splitPathList :: String -> [String]-splitPathList s = filter notNull (splitUp s)-                -- empty paths are ignored: there might be a trailing-                -- ':' in the initial list, for example.  Empty paths can-                -- cause confusion when they are translated into -I options-                -- for passing to gcc.-  where-#if !defined(mingw32_HOST_OS)-    splitUp xs = split split_marker xs-#else-     -- Windows: 'hybrid' support for DOS-style paths in directory lists.-     ---     -- That is, if "foo:bar:baz" is used, this interpreted as-     -- consisting of three entries, 'foo', 'bar', 'baz'.-     -- However, with "c:/foo:c:\\foo;x:/bar", this is interpreted-     -- as 3 elts, "c:/foo", "c:\\foo", "x:/bar"-     ---     -- Notice that no attempt is made to fully replace the 'standard'-     -- split marker ':' with the Windows / DOS one, ';'. The reason being-     -- that this will cause too much breakage for users & ':' will-     -- work fine even with DOS paths, if you're not insisting on being silly.-     -- So, use either.-    splitUp []             = []-    splitUp (x:':':div:xs) | div `elem` dir_markers-                           = ((x:':':div:p): splitUp rs)-                           where-                              (p,rs) = findNextPath xs-          -- we used to check for existence of the path here, but that-          -- required the IO monad to be threaded through the command-line-          -- parser which is quite inconvenient.  The-    splitUp xs = cons p (splitUp rs)-               where-                 (p,rs) = findNextPath xs--                 cons "" xs = xs-                 cons x  xs = x:xs--    -- will be called either when we've consumed nought or the-    -- "<Drive>:/" part of a DOS path, so splitting is just a Q of-    -- finding the next split marker.-    findNextPath xs =-        case break (`elem` split_markers) xs of-           (p, _:ds) -> (p, ds)-           (p, xs)   -> (p, xs)--    split_markers :: [Char]-    split_markers = [':', ';']--    dir_markers :: [Char]-    dir_markers = ['/', '\\']-#endif---- -------------------------------------------------------------------------------- tmpDir, where we store temporary files.--setTmpDir :: FilePath -> DynFlags -> DynFlags-setTmpDir dir d = d { tmpDir = TempDir (normalise dir) }-  -- we used to fix /cygdrive/c/.. on Windows, but this doesn't-  -- seem necessary now --SDM 7/2/2008---------------------------------------------------------------------------------- RTS opts--setRtsOpts :: String -> DynP ()-setRtsOpts arg  = upd $ \ d -> d {rtsOpts = Just arg}--setRtsOptsEnabled :: RtsOptsEnabled -> DynP ()-setRtsOptsEnabled arg  = upd $ \ d -> d {rtsOptsEnabled = arg}---------------------------------------------------------------------------------- Hpc stuff--setOptHpcDir :: String -> DynP ()-setOptHpcDir arg  = upd $ \ d -> d {hpcDir = arg}---------------------------------------------------------------------------------- Via-C compilation stuff---- There are some options that we need to pass to gcc when compiling--- Haskell code via C, but are only supported by recent versions of--- gcc.  The configure script decides which of these options we need,--- and puts them in the "settings" file in $topdir. The advantage of--- having these in a separate file is that the file can be created at--- install-time depending on the available gcc version, and even--- re-generated later if gcc is upgraded.------ The options below are not dependent on the version of gcc, only the--- platform.--picCCOpts :: DynFlags -> [String]-picCCOpts dflags =-      case platformOS (targetPlatform dflags) of-      OSDarwin-          -- Apple prefers to do things the other way round.-          -- PIC is on by default.-          -- -mdynamic-no-pic:-          --     Turn off PIC code generation.-          -- -fno-common:-          --     Don't generate "common" symbols - these are unwanted-          --     in dynamic libraries.--       | gopt Opt_PIC dflags -> ["-fno-common", "-U__PIC__", "-D__PIC__"]-       | otherwise           -> ["-mdynamic-no-pic"]-      OSMinGW32 -- no -fPIC for Windows-       | gopt Opt_PIC dflags -> ["-U__PIC__", "-D__PIC__"]-       | otherwise           -> []-      _-      -- we need -fPIC for C files when we are compiling with -dynamic,-      -- otherwise things like stub.c files don't get compiled-      -- correctly.  They need to reference data in the Haskell-      -- objects, but can't without -fPIC.  See-      -- https://gitlab.haskell.org/ghc/ghc/wikis/commentary/position-independent-code-       | gopt Opt_PIC dflags || ways dflags `hasWay` WayDyn ->-          ["-fPIC", "-U__PIC__", "-D__PIC__"]-      -- 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),-       ("Booter version",              cBooterVersion),-       ("Stage",                       cStage),-       ("Build platform",              cBuildPlatformString),-       ("Host platform",               cHostPlatformString),-       ("Target platform",             platformMisc_targetPlatformString $ platformMisc dflags),-       ("Have interpreter",            showBool $ platformMisc_ghcWithInterpreter $ platformMisc dflags),-       ("Object splitting supported",  showBool False),-       ("Have native code generator",  showBool $ platformNcgSupported (targetPlatform dflags)),-       ("Target default backend",      show $ platformDefaultBackend (targetPlatform dflags)),-       -- 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),-       -- The path of the global package database used by GHC-       ("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----- | Get target profile-targetProfile :: DynFlags -> Profile-targetProfile dflags = Profile (targetPlatform dflags) (ways dflags)--{- ------------------------------------------------------------------------------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- -- Disable -dynamic-too if we are are compiling with -dynamic already, otherwise- -- you get two dynamic object files (.o and .dyn_o). (#20436)- | ways dflags `hasWay` WayDyn && gopt Opt_BuildDynamicToo dflags-    = let dflags' = gopt_unset dflags Opt_BuildDynamicToo-          warn = "-dynamic-too is ignored when using -dynamic"-      in loop dflags' warn--   -- Via-C backend only supports unregisterised ABI. Switch to a backend-   -- supporting it if possible.- | backend dflags == ViaC &&-   not (platformUnregisterised (targetPlatform dflags))-    = case platformDefaultBackend (targetPlatform dflags) of-         NCG ->  let dflags' = dflags { backend = NCG }-                     warn = "Target platform doesn't use unregisterised ABI, so using native code generator rather than compiling via C"-                 in loop dflags' warn-         LLVM -> let dflags' = dflags { backend = LLVM }-                     warn = "Target platform doesn't use unregisterised ABI, so using LLVM rather than compiling via C"-                 in loop dflags' warn-         _    -> pgmError "Compiling via C only supports unregisterised ABI but target platform doesn't use it."-- | gopt Opt_Hpc dflags && backend dflags == Interpreter-    = let dflags' = gopt_unset dflags Opt_Hpc-          warn = "Hpc can't be used with byte-code interpreter. Ignoring -fhpc."-      in loop dflags' warn-- | backend dflags `elem` [NCG, LLVM] &&-   platformUnregisterised (targetPlatform dflags)-    = loop (dflags { backend = ViaC })-           "Target platform uses unregisterised ABI, so compiling via C"-- | backend dflags == NCG &&-   not (platformNcgSupported $ targetPlatform dflags)-      = let dflags' = dflags { backend = LLVM }-            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"-- | backend dflags == Interpreter- , let (dflags', changed) = updOptLevelChanged 0 dflags- , changed-    = loop dflags' "Optimization flags conflict with --interactive; optimization flags ignored."-- | LinkInMemory <- ghcLink dflags- , not (gopt Opt_ExternalInterpreter dflags)- , hostIsProfiled- , backendProducesObject (backend dflags)- , ways dflags `hasNotWay` WayProf-    = loop dflags{targetWays_ = addWay WayProf (targetWays_ dflags)}-         "Enabling -prof, because -fobject-code is enabled and GHCi is profiled"-- | LinkMergedObj <- ghcLink dflags- , Nothing <- outputFile dflags- = pgmError "--output must be specified when using --merge-objs"-- | otherwise = (dflags, [])-    where loc = mkGeneralSrcSpan (fsLit "when making flags consistent")-          loop updated_dflags warning-              = case makeDynFlagsConsistent updated_dflags of-                (dflags', ws) -> (dflags', L loc warning : ws)-          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)----- -------------------------------------------------------------------------------- SSE and AVX--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---- -------------------------------------------------------------------------------- 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---- | 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---- -------------------------------------------------------------------------------- Linker/compiler information---- LinkerInfo contains any extra options needed by the system linker.-data LinkerInfo-  = GnuLD    [Option]-  | GnuGold  [Option]-  | LlvmLLD  [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----- | Should we use `-XLinker -rpath` when linking or not?--- See Note [-fno-use-rpaths]-useXLinkerRPath :: DynFlags -> OS -> Bool-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 ()----- | 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-  , 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-  , 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-  , sdocErrorSpans                  = gopt Opt_ErrorSpans dflags-  , sdocStarIsType                  = xopt LangExt.StarIsType dflags-  , sdocImpredicativeTypes          = xopt LangExt.ImpredicativeTypes dflags-  , sdocLinearTypes                 = xopt LangExt.LinearTypes dflags-  , sdocPrintTypeAbbreviations      = True-  , sdocUnitIdForUser               = ftext-  }---- | Initialize the pretty-printing options using the default user style-initDefaultSDocContext :: DynFlags -> SDocContext-initDefaultSDocContext dflags = initSDocContext dflags defaultUserStyle--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--ways :: DynFlags -> Ways-ways dflags-   | dynamicNow dflags = addWay WayDyn (targetWays_ dflags)-   | otherwise         = targetWays_ dflags+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE LambdaCase #-}++-------------------------------------------------------------------------------+--+-- | Dynamic flags+--+-- Most flags are dynamic flags, which means they can change from compilation+-- to compilation using @OPTIONS_GHC@ pragmas, and in a multi-session GHC each+-- session can be using different dynamic flags. Dynamic flags can also be set+-- at the prompt in GHCi.+--+-- (c) The University of Glasgow 2005+--+-------------------------------------------------------------------------------++module GHC.Driver.Session (+        -- * Dynamic flags and associated configuration types+        DumpFlag(..),+        GeneralFlag(..),+        WarningFlag(..), DiagnosticReason(..),+        Language(..),+        FatalMessager, FlushOut(..),+        ProfAuto(..),+        glasgowExtsFlags,+        hasPprDebug, hasNoDebugOutput, hasNoStateHack, hasNoOptCoercion,+        dopt, dopt_set, dopt_unset,+        gopt, gopt_set, gopt_unset, setGeneralFlag', unSetGeneralFlag',+        wopt, wopt_set, wopt_unset,+        wopt_fatal, wopt_set_fatal, wopt_unset_fatal,+        wopt_set_all_custom, wopt_unset_all_custom,+        wopt_set_all_fatal_custom, wopt_unset_all_fatal_custom,+        wopt_set_custom, wopt_unset_custom,+        wopt_set_fatal_custom, wopt_unset_fatal_custom,+        wopt_any_custom,+        xopt, xopt_set, xopt_unset,+        xopt_set_unlessExplSpec,+        xopt_DuplicateRecordFields,+        xopt_FieldSelectors,+        lang_set,+        DynamicTooState(..), dynamicTooState, setDynamicNow,+        sccProfilingEnabled,+        needSourceNotes,+        OnOff(..),+        DynFlags(..),+        ParMakeCount(..),+        outputFile, objectSuf, ways,+        FlagSpec(..),+        HasDynFlags(..), ContainsDynFlags(..),+        RtsOptsEnabled(..),+        GhcMode(..), isOneShot,+        GhcLink(..), isNoLink,+        PackageFlag(..), PackageArg(..), ModRenaming(..),+        packageFlagsChanged,+        IgnorePackageFlag(..), TrustFlag(..),+        PackageDBFlag(..), PkgDbRef(..),+        Option(..), showOpt,+        DynLibLoader(..),+        fFlags, fLangFlags, xFlags,+        wWarningFlags,+        makeDynFlagsConsistent,+        positionIndependent,+        optimisationFlags,+        codeGenFlags,+        setFlagsFromEnvFile,+        pprDynFlagsDiff,+        flagSpecOf,++        targetProfile,++        -- ** Safe Haskell+        safeHaskellOn, safeHaskellModeEnabled,+        safeImportsOn, safeLanguageOn, safeInferOn,+        packageTrustOn,+        safeDirectImpsReq, safeImplicitImpsReq,+        unsafeFlags, unsafeFlagsForInfer,++        -- ** base+        baseUnitId,++        -- ** System tool settings and locations+        Settings(..),+        sProgramName,+        sProjectVersion,+        sGhcUsagePath,+        sGhciUsagePath,+        sToolDir,+        sTopDir,+        sGlobalPackageDatabasePath,+        sLdSupportsCompactUnwind,+        sLdSupportsFilelist,+        sLdIsGnuLd,+        sGccSupportsNoPie,+        sPgm_L,+        sPgm_P,+        sPgm_F,+        sPgm_c,+        sPgm_cxx,+        sPgm_cpp,+        sPgm_a,+        sPgm_l,+        sPgm_lm,+        sPgm_windres,+        sPgm_ar,+        sPgm_ranlib,+        sPgm_lo,+        sPgm_lc,+        sPgm_las,+        sPgm_i,+        sOpt_L,+        sOpt_P,+        sOpt_P_fingerprint,+        sOpt_JSP,+        sOpt_JSP_fingerprint,+        sOpt_CmmP,+        sOpt_CmmP_fingerprint,+        sOpt_F,+        sOpt_c,+        sOpt_cxx,+        sOpt_a,+        sOpt_l,+        sOpt_lm,+        sOpt_windres,+        sOpt_lo,+        sOpt_lc,+        sOpt_i,+        sExtraGccViaCFlags,+        sTargetPlatformString,+        sGhcWithInterpreter,+        sLibFFI,+        sTargetRTSLinkerOnlySupportsSharedLibs,+        GhcNameVersion(..),+        FileSettings(..),+        PlatformMisc(..),+        settings,+        programName, projectVersion,+        ghcUsagePath, ghciUsagePath, topDir,+        versionedAppDir, versionedFilePath,+        extraGccViaCFlags, globalPackageDatabasePath,+        pgm_L, pgm_P, pgm_JSP, pgm_CmmP, pgm_F, pgm_c, pgm_cxx, pgm_cpp, pgm_a, pgm_l,+        pgm_lm, pgm_windres, pgm_ar,+        pgm_ranlib, pgm_lo, pgm_lc, pgm_las, pgm_i,+        opt_L, opt_P, opt_JSP, opt_CmmP, opt_F, opt_c, opt_cxx, opt_a, opt_l, opt_lm, opt_i,+        opt_P_signature, opt_JSP_signature, opt_CmmP_signature,+        opt_windres, opt_lo, opt_lc, opt_las,+        updatePlatformConstants,++        -- ** Manipulating DynFlags+        addPluginModuleName,+        defaultDynFlags,                -- Settings -> DynFlags+        initDynFlags,                   -- DynFlags -> IO DynFlags+        defaultFatalMessager,+        defaultFlushOut,+        setOutputFile, setDynOutputFile, setOutputHi, setDynOutputHi,+        augmentByWorkingDirectory,++        getOpts,                        -- DynFlags -> (DynFlags -> [a]) -> [a]+        getVerbFlags,+        updOptLevel,+        setTmpDir,+        setUnitId,+        setHomeUnitId,++        TurnOnFlag,+        turnOn,+        turnOff,+        impliedGFlags,+        impliedOffGFlags,+        impliedXFlags,++        -- ** State+        CmdLineP(..), runCmdLineP,+        getCmdLineState, putCmdLineState,+        processCmdLineP,++        -- ** Parsing DynFlags+        parseDynamicFlagsCmdLine,+        parseDynamicFilePragma,+        parseDynamicFlagsFull,+        flagSuggestions,++        -- ** Available DynFlags+        allNonDeprecatedFlags,+        flagsAll,+        flagsDynamic,+        flagsPackage,+        flagsForCompletion,++        supportedLanguagesAndExtensions,+        languageExtensions,++        -- ** DynFlags C compiler options+        picCCOpts, picPOpts,++        -- ** DynFlags C linker options+        pieCCLDOpts,++        -- * Compiler configuration suitable for display to the user+        compilerInfo,++        wordAlignment,++        setUnsafeGlobalDynFlags,++        -- * SSE and AVX+        isSse3Enabled,+        isSsse3Enabled,+        isSse4_1Enabled,+        isSse4_2Enabled,+        isBmiEnabled,+        isBmi2Enabled,+        isAvxEnabled,+        isAvx2Enabled,+        isAvx512cdEnabled,+        isAvx512erEnabled,+        isAvx512fEnabled,+        isAvx512pfEnabled,+        isFmaEnabled,++        -- * Linker/compiler information+        useXLinkerRPath,++        -- * Include specifications+        IncludeSpecs(..), addGlobalInclude, addQuoteInclude, flattenIncludes,+        addImplicitQuoteInclude,++        -- * SDoc+        initSDocContext, initDefaultSDocContext,+        initPromotionTickContext,+  ) where++import GHC.Prelude++import GHC.Platform+import GHC.Platform.Ways+import GHC.Platform.Profile+import GHC.Platform.ArchOS++import GHC.Unit.Types+import GHC.Unit.Parser+import GHC.Unit.Module+import GHC.Unit.Module.Warnings+import GHC.Driver.DynFlags+import GHC.Driver.Config.Diagnostic+import GHC.Driver.Flags+import GHC.Driver.Backend+import GHC.Driver.Errors.Types+import GHC.Driver.Plugins.External+import GHC.Settings.Config+import GHC.Core.Unfold+import GHC.Driver.CmdLine+import GHC.Utils.Logger+import GHC.Utils.Panic+import GHC.Utils.Misc+import GHC.Utils.Constants (debugIsOn)+import GHC.Utils.GlobalVars+import GHC.Data.Maybe+import GHC.Data.Bool+import GHC.Data.StringBuffer (stringToStringBuffer)+import GHC.Types.Error+import GHC.Types.Name.Reader (RdrName(..))+import GHC.Types.Name.Occurrence (isVarOcc, occNameString)+import GHC.Utils.Monad+import GHC.Types.SrcLoc+import GHC.Types.SafeHaskell+import GHC.Types.Basic ( treatZeroAsInf )+import GHC.Data.FastString+import GHC.Utils.TmpFs+import GHC.Utils.Fingerprint+import GHC.Utils.Outputable+import GHC.Utils.Error (emptyDiagOpts, logInfo)+import GHC.Settings+import GHC.CmmToAsm.CFG.Weight+import GHC.Core.Opt.CallerCC+import GHC.Parser (parseIdentifier)+import GHC.Parser.Lexer (mkParserOpts, initParserState, P(..), ParseResult(..))++import GHC.SysTools.BaseDir ( expandToolDir, expandTopDir )++import Data.IORef+import Control.Arrow ((&&&))+import Control.Monad+import Control.Monad.Trans.State as State+import Data.Functor.Identity++import Data.Ord+import Data.Char+import Data.List (intercalate, sortBy, partition)+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NE+import qualified Data.Map as Map+import qualified Data.Set as Set+import Data.Word+import System.FilePath+import Text.ParserCombinators.ReadP hiding (char)+import Text.ParserCombinators.ReadP as R++import qualified GHC.Data.EnumSet as EnumSet++import qualified GHC.LanguageExtensions as LangExt+++-- Note [Updating flag description in the User's Guide]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- If you modify anything in this file please make sure that your changes are+-- described in the User's Guide. Please update the flag description in the+-- users guide (docs/users_guide) whenever you add or change a flag.+-- Please make sure you add ":since:" information to new flags.++-- Note [Supporting CLI completion]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- The command line interface completion (in for example bash) is an easy way+-- for the developer to learn what flags are available from GHC.+-- GHC helps by separating which flags are available when compiling with GHC,+-- and which flags are available when using GHCi.+-- A flag is assumed to either work in both these modes, or only in one of them.+-- When adding or changing a flag, please consider for which mode the flag will+-- have effect, and annotate it accordingly. For Flags use defFlag, defGhcFlag,+-- defGhciFlag, and for FlagSpec use flagSpec or flagGhciSpec.++-- Note [Adding a language extension]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+--+-- There are a few steps to adding (or removing) a language extension,+--+--  * Adding the extension to GHC.LanguageExtensions+--+--    The Extension type in libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs+--    is the canonical list of language extensions known by GHC.+--+--  * Adding a flag to DynFlags.xFlags+--+--    This is fairly self-explanatory. The name should be concise, memorable,+--    and consistent with any previous implementations of the similar idea in+--    other Haskell compilers.+--+--  * Adding the flag to the documentation+--+--    This is the same as any other flag. See+--    Note [Updating flag description in the User's Guide]+--+--  * Adding the flag to Cabal+--+--    The Cabal library has its own list of all language extensions supported+--    by all major compilers. This is the list that user code being uploaded+--    to Hackage is checked against to ensure language extension validity.+--    Consequently, it is very important that this list remains up-to-date.+--+--    To this end, there is a testsuite test (testsuite/tests/driver/T4437.hs)+--    whose job it is to ensure these GHC's extensions are consistent with+--    Cabal.+--+--    The recommended workflow is,+--+--     1. Temporarily add your new language extension to the+--        expectedGhcOnlyExtensions list in T4437 to ensure the test doesn't+--        break while Cabal is updated.+--+--     2. After your GHC change is accepted, submit a Cabal pull request adding+--        your new extension to Cabal's list (found in+--        Cabal/Language/Haskell/Extension.hs).+--+--     3. After your Cabal change is accepted, let the GHC developers know so+--        they can update the Cabal submodule and remove the extensions from+--        expectedGhcOnlyExtensions.+--+--  * Adding the flag to the GHC Wiki+--+--    There is a change log tracking language extension additions and removals+--    on the GHC wiki:  https://gitlab.haskell.org/ghc/ghc/wikis/language-pragma-history+--+--  See #4437 and #8176.++-- -----------------------------------------------------------------------------+-- DynFlags++{- Note [RHS Floating]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+  We provide both 'Opt_LocalFloatOut' and 'Opt_LocalFloatOutTopLevel' to correspond to+  'doFloatFromRhs'; with this we can control floating out with GHC flags.++  This addresses https://gitlab.haskell.org/ghc/ghc/-/issues/13663 and+  allows for experimentation.+-}++-----------------------------------------------------------------------------+-- Accessors from 'DynFlags'++-- | "unbuild" a 'Settings' from a 'DynFlags'. This shouldn't be needed in the+-- vast majority of code. But GHCi questionably uses this to produce a default+-- 'DynFlags' from which to compute a flags diff for printing.+settings :: DynFlags -> Settings+settings dflags = Settings+  { sGhcNameVersion = ghcNameVersion dflags+  , sFileSettings = fileSettings dflags+  , sUnitSettings = unitSettings dflags+  , sTargetPlatform = targetPlatform dflags+  , sToolSettings = toolSettings dflags+  , sPlatformMisc = platformMisc dflags+  , sRawSettings = rawSettings dflags+  }++pgm_L                 :: DynFlags -> String+pgm_L dflags = toolSettings_pgm_L $ toolSettings dflags+pgm_P                 :: DynFlags -> (String,[Option])+pgm_P dflags = toolSettings_pgm_P $ toolSettings dflags+pgm_JSP               :: DynFlags -> (String,[Option])+pgm_JSP dflags = toolSettings_pgm_JSP $ toolSettings dflags+pgm_CmmP              :: DynFlags -> (String,[Option])+pgm_CmmP dflags = toolSettings_pgm_CmmP $ toolSettings dflags+pgm_F                 :: DynFlags -> String+pgm_F dflags = toolSettings_pgm_F $ toolSettings dflags+pgm_c                 :: DynFlags -> String+pgm_c dflags = toolSettings_pgm_c $ toolSettings dflags+pgm_cxx               :: DynFlags -> String+pgm_cxx dflags = toolSettings_pgm_cxx $ toolSettings dflags+pgm_cpp               :: DynFlags -> (String,[Option])+pgm_cpp dflags = toolSettings_pgm_cpp $ toolSettings dflags+pgm_a                 :: DynFlags -> (String,[Option])+pgm_a dflags = toolSettings_pgm_a $ toolSettings dflags+pgm_l                 :: DynFlags -> (String,[Option])+pgm_l dflags = toolSettings_pgm_l $ toolSettings dflags+pgm_lm                 :: DynFlags -> Maybe (String,[Option])+pgm_lm dflags = toolSettings_pgm_lm $ toolSettings dflags+pgm_windres           :: DynFlags -> String+pgm_windres dflags = toolSettings_pgm_windres $ toolSettings dflags+pgm_ar                :: DynFlags -> String+pgm_ar dflags = toolSettings_pgm_ar $ toolSettings dflags+pgm_ranlib            :: DynFlags -> String+pgm_ranlib dflags = toolSettings_pgm_ranlib $ toolSettings dflags+pgm_lo                :: DynFlags -> (String,[Option])+pgm_lo dflags = toolSettings_pgm_lo $ toolSettings dflags+pgm_lc                :: DynFlags -> (String,[Option])+pgm_lc dflags = toolSettings_pgm_lc $ toolSettings dflags+pgm_las               :: DynFlags -> (String,[Option])+pgm_las dflags = toolSettings_pgm_las $ toolSettings dflags+pgm_i                 :: DynFlags -> String+pgm_i dflags = toolSettings_pgm_i $ toolSettings dflags+opt_L                 :: DynFlags -> [String]+opt_L dflags = toolSettings_opt_L $ toolSettings dflags+opt_P                 :: DynFlags -> [String]+opt_P dflags = concatMap (wayOptP (targetPlatform dflags)) (ways dflags)+            ++ toolSettings_opt_P (toolSettings dflags)+opt_JSP               :: DynFlags -> [String]+opt_JSP dflags = concatMap (wayOptP (targetPlatform dflags)) (ways dflags)+            ++ toolSettings_opt_JSP (toolSettings dflags)+opt_CmmP              :: DynFlags -> [String]+opt_CmmP dflags = toolSettings_opt_CmmP $ toolSettings dflags++-- This function packages everything that's needed to fingerprint opt_P+-- flags. See Note [Repeated -optP hashing].+opt_P_signature       :: DynFlags -> ([String], Fingerprint)+opt_P_signature dflags =+  ( concatMap (wayOptP (targetPlatform dflags)) (ways dflags)+  , toolSettings_opt_P_fingerprint $ toolSettings dflags+  )+-- This function packages everything that's needed to fingerprint opt_P+-- flags. See Note [Repeated -optP hashing].+opt_JSP_signature     :: DynFlags -> ([String], Fingerprint)+opt_JSP_signature dflags =+  ( concatMap (wayOptP (targetPlatform dflags)) (ways dflags)+  , toolSettings_opt_JSP_fingerprint $ toolSettings dflags+  )+-- This function packages everything that's needed to fingerprint opt_CmmP+-- flags. See Note [Repeated -optP hashing].+opt_CmmP_signature     :: DynFlags -> Fingerprint+opt_CmmP_signature = toolSettings_opt_CmmP_fingerprint . toolSettings++opt_F                 :: DynFlags -> [String]+opt_F dflags= toolSettings_opt_F $ toolSettings dflags+opt_c                 :: DynFlags -> [String]+opt_c dflags = concatMap (wayOptc (targetPlatform dflags)) (ways dflags)+            ++ toolSettings_opt_c (toolSettings dflags)+opt_cxx               :: DynFlags -> [String]+opt_cxx dflags = concatMap (wayOptcxx (targetPlatform dflags)) (ways dflags)+           ++ toolSettings_opt_cxx (toolSettings dflags)+opt_a                 :: DynFlags -> [String]+opt_a dflags= toolSettings_opt_a $ toolSettings dflags+opt_l                 :: DynFlags -> [String]+opt_l dflags = concatMap (wayOptl (targetPlatform dflags)) (ways dflags)+            ++ toolSettings_opt_l (toolSettings dflags)+opt_lm                :: DynFlags -> [String]+opt_lm dflags= toolSettings_opt_lm $ toolSettings dflags+opt_windres           :: DynFlags -> [String]+opt_windres dflags= toolSettings_opt_windres $ toolSettings dflags+opt_lo                :: DynFlags -> [String]+opt_lo dflags= toolSettings_opt_lo $ toolSettings dflags+opt_lc                :: DynFlags -> [String]+opt_lc dflags= toolSettings_opt_lc $ toolSettings dflags+opt_las               :: DynFlags -> [String]+opt_las dflags = toolSettings_opt_las $ toolSettings dflags+opt_i                 :: DynFlags -> [String]+opt_i dflags= toolSettings_opt_i $ toolSettings dflags+++setBaseUnitId :: String -> DynP ()+setBaseUnitId s = upd $ \d -> d { unitSettings = UnitSettings (stringToUnitId s) }++-----------------------------------------------------------------------------++{-+Note [Verbosity levels]+~~~~~~~~~~~~~~~~~~~~~~~+    0   |   print errors & warnings only+    1   |   minimal verbosity: print "compiling M ... done." for each module.+    2   |   equivalent to -dshow-passes+    3   |   equivalent to existing "ghc -v"+    4   |   "ghc -v -ddump-most"+    5   |   "ghc -v -ddump-all"+-}++-- | Set the Haskell language standard to use+setLanguage :: Language -> DynP ()+setLanguage l = upd (`lang_set` Just l)++-- | Is the -fpackage-trust mode on+packageTrustOn :: DynFlags -> Bool+packageTrustOn = gopt Opt_PackageTrust++-- | Is Safe Haskell on in some way (including inference mode)+safeHaskellOn :: DynFlags -> Bool+safeHaskellOn dflags = safeHaskellModeEnabled dflags || safeInferOn dflags++safeHaskellModeEnabled :: DynFlags -> Bool+safeHaskellModeEnabled dflags = safeHaskell dflags `elem` [Sf_Unsafe, Sf_Trustworthy+                                                   , Sf_Safe ]+++-- | Is the Safe Haskell safe language in use+safeLanguageOn :: DynFlags -> Bool+safeLanguageOn dflags = safeHaskell dflags == Sf_Safe++-- | Is the Safe Haskell safe inference mode active+safeInferOn :: DynFlags -> Bool+safeInferOn = safeInfer++-- | Test if Safe Imports are on in some form+safeImportsOn :: DynFlags -> Bool+safeImportsOn dflags = safeHaskell dflags == Sf_Unsafe ||+                       safeHaskell dflags == Sf_Trustworthy ||+                       safeHaskell dflags == Sf_Safe++-- | Set a 'Safe Haskell' flag+setSafeHaskell :: SafeHaskellMode -> DynP ()+setSafeHaskell s = updM f+    where f dfs = do+              let sf = safeHaskell dfs+              safeM <- combineSafeFlags sf s+              case s of+                Sf_Safe -> return $ dfs { safeHaskell = safeM, safeInfer = False }+                -- leave safe inference on in Trustworthy mode so we can warn+                -- if it could have been inferred safe.+                Sf_Trustworthy -> do+                  l <- getCurLoc+                  return $ dfs { safeHaskell = safeM, trustworthyOnLoc = l }+                -- leave safe inference on in Unsafe mode as well.+                _ -> return $ dfs { safeHaskell = safeM }++-- | Are all direct imports required to be safe for this Safe Haskell mode?+-- Direct imports are when the code explicitly imports a module+safeDirectImpsReq :: DynFlags -> Bool+safeDirectImpsReq d = safeLanguageOn d++-- | Are all implicit imports required to be safe for this Safe Haskell mode?+-- Implicit imports are things in the prelude. e.g System.IO when print is used.+safeImplicitImpsReq :: DynFlags -> Bool+safeImplicitImpsReq d = safeLanguageOn d++-- | Combine two Safe Haskell modes correctly. Used for dealing with multiple flags.+-- This makes Safe Haskell very much a monoid but for now I prefer this as I don't+-- want to export this functionality from the module but do want to export the+-- type constructors.+combineSafeFlags :: SafeHaskellMode -> SafeHaskellMode -> DynP SafeHaskellMode+combineSafeFlags a b | a == Sf_None         = return b+                     | b == Sf_None         = return a+                     | a == Sf_Ignore || b == Sf_Ignore = return Sf_Ignore+                     | a == b               = return a+                     | otherwise            = addErr errm >> pure a+    where errm = "Incompatible Safe Haskell flags! ("+                    ++ show a ++ ", " ++ show b ++ ")"++-- | A list of unsafe flags under Safe Haskell. Tuple elements are:+--     * name of the flag+--     * function to get srcspan that enabled the flag+--     * function to test if the flag is on+--     * function to turn the flag off+unsafeFlags, unsafeFlagsForInfer+  :: [(LangExt.Extension, DynFlags -> SrcSpan, DynFlags -> Bool, DynFlags -> DynFlags)]+unsafeFlags = [ (LangExt.GeneralizedNewtypeDeriving, newDerivOnLoc,+                    xopt LangExt.GeneralizedNewtypeDeriving,+                    flip xopt_unset LangExt.GeneralizedNewtypeDeriving)+              , (LangExt.DerivingVia, deriveViaOnLoc,+                    xopt LangExt.DerivingVia,+                    flip xopt_unset LangExt.DerivingVia)+              , (LangExt.TemplateHaskell, thOnLoc,+                    xopt LangExt.TemplateHaskell,+                    flip xopt_unset LangExt.TemplateHaskell)+              ]+unsafeFlagsForInfer = unsafeFlags+++-- | Retrieve the options corresponding to a particular @opt_*@ field in the correct order+getOpts :: DynFlags             -- ^ 'DynFlags' to retrieve the options from+        -> (DynFlags -> [a])    -- ^ Relevant record accessor: one of the @opt_*@ accessors+        -> [a]                  -- ^ Correctly ordered extracted options+getOpts dflags opts = reverse (opts dflags)+        -- We add to the options from the front, so we need to reverse the list++-- | Gets the verbosity flag for the current verbosity level. This is fed to+-- other tools, so GHC-specific verbosity flags like @-ddump-most@ are not included+getVerbFlags :: DynFlags -> [String]+getVerbFlags dflags+  | verbosity dflags >= 4 = ["-v"]+  | otherwise             = []++setObjectDir, setHiDir, setHieDir, setStubDir, setDumpDir, setOutputDir,+         setDynObjectSuf, setDynHiSuf,+         setDylibInstallName,+         setObjectSuf, setHiSuf, setHieSuf, setHcSuf, parseDynLibLoaderMode,+         setPgmP, setPgmJSP, setPgmCmmP, addOptl, addOptc, addOptcxx, addOptP,+         addOptJSP, addOptCmmP,+         addCmdlineFramework, addHaddockOpts, addGhciScript,+         setInteractivePrint+   :: String -> DynFlags -> DynFlags+setOutputFile, setDynOutputFile, setOutputHi, setDynOutputHi, setDumpPrefixForce+   :: Maybe String -> DynFlags -> DynFlags++setObjectDir  f d = d { objectDir  = Just f}+setHiDir      f d = d { hiDir      = Just f}+setHieDir     f d = d { hieDir     = Just f}+setStubDir    f d = d { stubDir    = Just f+                      , includePaths = addGlobalInclude (includePaths d) [f] }+  -- -stubdir D adds an implicit -I D, so that gcc can find the _stub.h file+  -- \#included from the .hc file when compiling via C (i.e. unregisterised+  -- builds).+setDumpDir    f d = d { dumpDir    = Just f}+setOutputDir  f = setObjectDir f+                . setHieDir f+                . setHiDir f+                . setStubDir f+                . setDumpDir f+setDylibInstallName  f d = d { dylibInstallName = Just f}++setObjectSuf    f d = d { objectSuf_    = f}+setDynObjectSuf f d = d { dynObjectSuf_ = f}+setHiSuf        f d = d { hiSuf_        = f}+setHieSuf       f d = d { hieSuf        = f}+setDynHiSuf     f d = d { dynHiSuf_     = f}+setHcSuf        f d = d { hcSuf         = f}++setOutputFile    f d = d { outputFile_    = f}+setDynOutputFile f d = d { dynOutputFile_ = f}+setOutputHi      f d = d { outputHi       = f}+setDynOutputHi   f d = d { dynOutputHi    = f}++parseUnitInsts :: String -> Instantiations+parseUnitInsts str = case filter ((=="").snd) (readP_to_S parse str) of+    [(r, "")] -> r+    _ -> throwGhcException $ CmdLineError ("Can't parse -instantiated-with: " ++ str)+  where parse = sepBy parseEntry (R.char ',')+        parseEntry = do+            n <- parseModuleName+            _ <- R.char '='+            m <- parseHoleyModule+            return (n, m)++setUnitInstantiations :: String -> DynFlags -> DynFlags+setUnitInstantiations s d =+    d { homeUnitInstantiations_ = parseUnitInsts s }++setUnitInstanceOf :: String -> DynFlags -> DynFlags+setUnitInstanceOf s d =+    d { homeUnitInstanceOf_ = Just (UnitId (fsLit s)) }++addPluginModuleName :: String -> DynFlags -> DynFlags+addPluginModuleName name d = d { pluginModNames = (mkModuleName name) : (pluginModNames d) }++clearPluginModuleNames :: DynFlags -> DynFlags+clearPluginModuleNames d =+    d { pluginModNames = []+      , pluginModNameOpts = []+      }++addPluginModuleNameOption :: String -> DynFlags -> DynFlags+addPluginModuleNameOption optflag d = d { pluginModNameOpts = (mkModuleName m, option) : (pluginModNameOpts d) }+  where (m, rest) = break (== ':') optflag+        option = case rest of+          [] -> "" -- should probably signal an error+          (_:plug_opt) -> plug_opt -- ignore the ':' from break++addExternalPlugin :: String -> DynFlags -> DynFlags+addExternalPlugin optflag d = case parseExternalPluginSpec optflag of+  Just r  -> d { externalPluginSpecs = r : externalPluginSpecs d }+  Nothing -> cmdLineError $ "Couldn't parse external plugin specification: " ++ optflag++addFrontendPluginOption :: String -> DynFlags -> DynFlags+addFrontendPluginOption s d = d { frontendPluginOpts = s : frontendPluginOpts d }++parseDynLibLoaderMode f d =+ case splitAt 8 f of+   ("deploy", "")       -> d { dynLibLoader = Deployable }+   ("sysdep", "")       -> d { dynLibLoader = SystemDependent }+   _                    -> throwGhcException (CmdLineError ("Unknown dynlib loader: " ++ f))++setDumpPrefixForce f d = d { dumpPrefixForce = f}++-- XXX HACK: Prelude> words "'does not' work" ===> ["'does","not'","work"]+-- Config.hs should really use Option.+setPgmP   f = alterToolSettings (\s -> s { toolSettings_pgm_P   = (pgm, map Option args)})+  where pgm:|args = expectNonEmpty $ words f+-- XXX HACK: Prelude> words "'does not' work" ===> ["'does","not'","work"]+-- Config.hs should really use Option.+setPgmJSP   f = alterToolSettings (\s -> s { toolSettings_pgm_JSP   = (pgm, map Option args)})+  where pgm:|args = expectNonEmpty $ words f+-- XXX HACK: Prelude> words "'does not' work" ===> ["'does","not'","work"]+-- Config.hs should really use Option.+setPgmCmmP f = alterToolSettings (\s -> s { toolSettings_pgm_CmmP = (pgm, map Option args)})+  where pgm:|args = expectNonEmpty $ words f+addOptl   f = alterToolSettings (\s -> s { toolSettings_opt_l   = f : toolSettings_opt_l s})+addOptc   f = alterToolSettings (\s -> s { toolSettings_opt_c   = f : toolSettings_opt_c s})+addOptcxx f = alterToolSettings (\s -> s { toolSettings_opt_cxx = f : toolSettings_opt_cxx s})+addOptP   f = alterToolSettings $ \s -> s+          { toolSettings_opt_P   = f : toolSettings_opt_P s+          , toolSettings_opt_P_fingerprint = fingerprintStrings (f : toolSettings_opt_P s)+          }+          -- See Note [Repeated -optP hashing]+addOptJSP f = alterToolSettings $ \s -> s+          { toolSettings_opt_JSP   = f : toolSettings_opt_JSP s+          , toolSettings_opt_JSP_fingerprint = fingerprintStrings (f : toolSettings_opt_JSP s)+          }+          -- See Note [Repeated -optP hashing]+addOptCmmP f = alterToolSettings $ \s -> s+          { toolSettings_opt_CmmP = f : toolSettings_opt_CmmP s+          , toolSettings_opt_CmmP_fingerprint = fingerprintStrings (f : toolSettings_opt_CmmP s)+          }++setDepMakefile :: FilePath -> DynFlags -> DynFlags+setDepMakefile f d = d { depMakefile = f }++setDepIncludeCppDeps :: Bool -> DynFlags -> DynFlags+setDepIncludeCppDeps b d = d { depIncludeCppDeps = b }++setDepIncludePkgDeps :: Bool -> DynFlags -> DynFlags+setDepIncludePkgDeps b d = d { depIncludePkgDeps = b }++addDepExcludeMod :: String -> DynFlags -> DynFlags+addDepExcludeMod m d+    = d { depExcludeMods = mkModuleName m : depExcludeMods d }++addDepSuffix :: FilePath -> DynFlags -> DynFlags+addDepSuffix s d = d { depSuffixes = s : depSuffixes d }++addCmdlineFramework f d = d { cmdlineFrameworks = f : cmdlineFrameworks d}++addGhcVersionFile :: FilePath -> DynFlags -> DynFlags+addGhcVersionFile f d = d { ghcVersionFile = Just f }++addHaddockOpts f d = d { haddockOptions = Just f}++addGhciScript f d = d { ghciScripts = f : ghciScripts d}++setInteractivePrint f d = d { interactivePrint = Just f}++-----------------------------------------------------------------------------+-- Setting the optimisation level++updOptLevelChanged :: Int -> DynFlags -> (DynFlags, Bool)+-- ^ Sets the 'DynFlags' to be appropriate to the optimisation level and signals if any changes took place+updOptLevelChanged n dfs+  = (dfs3, changed1 || changed2 || changed3)+  where+   final_n = max 0 (min 2 n)    -- Clamp to 0 <= n <= 2+   (dfs1, changed1) = foldr unset (dfs , False) remove_gopts+   (dfs2, changed2) = foldr set   (dfs1, False) extra_gopts+   (dfs3, changed3) = setLlvmOptLevel dfs2++   extra_gopts  = [ f | (ns,f) <- optLevelFlags, final_n `elem` ns ]+   remove_gopts = [ f | (ns,f) <- optLevelFlags, final_n `notElem` ns ]++   set f (dfs, changed)+     | gopt f dfs = (dfs, changed)+     | otherwise = (gopt_set dfs f, True)++   unset f (dfs, changed)+     | not (gopt f dfs) = (dfs, changed)+     | otherwise = (gopt_unset dfs f, True)++   setLlvmOptLevel dfs+     | llvmOptLevel dfs /= final_n = (dfs{ llvmOptLevel = final_n }, True)+     | otherwise = (dfs, False)++updOptLevel :: Int -> DynFlags -> DynFlags+-- ^ Sets the 'DynFlags' to be appropriate to the optimisation level+updOptLevel n = fst . updOptLevelChanged n++{- **********************************************************************+%*                                                                      *+                DynFlags parser+%*                                                                      *+%********************************************************************* -}++-- -----------------------------------------------------------------------------+-- Parsing the dynamic flags.+++-- | Parse dynamic flags from a list of command line arguments.  Returns+-- the parsed 'DynFlags', the left-over arguments, and a list of warnings.+-- Throws a 'UsageError' if errors occurred during parsing (such as unknown+-- flags or missing arguments).+parseDynamicFlagsCmdLine :: MonadIO m => Logger -> DynFlags -> [Located String]+                         -> m (DynFlags, [Located String], Messages DriverMessage)+                            -- ^ Updated 'DynFlags', left-over arguments, and+                            -- list of warnings.+parseDynamicFlagsCmdLine = parseDynamicFlagsFull flagsAll True+++-- | Like 'parseDynamicFlagsCmdLine' but does not allow the package flags+-- (-package, -hide-package, -ignore-package, -hide-all-packages, -package-db).+-- Used to parse flags set in a modules pragma.+parseDynamicFilePragma :: MonadIO m => Logger -> DynFlags -> [Located String]+                       -> m (DynFlags, [Located String], Messages DriverMessage)+                          -- ^ Updated 'DynFlags', left-over arguments, and+                          -- list of warnings.+parseDynamicFilePragma = parseDynamicFlagsFull flagsDynamic False++newtype CmdLineP s a = CmdLineP (forall m. (Monad m) => StateT s m a)+  deriving (Functor)++instance Monad (CmdLineP s) where+    CmdLineP k >>= f = CmdLineP (k >>= \x -> case f x of CmdLineP g -> g)+    return = pure++instance Applicative (CmdLineP s) where+    pure x = CmdLineP (pure x)+    (<*>) = ap++getCmdLineState :: CmdLineP s s+getCmdLineState = CmdLineP State.get++putCmdLineState :: s -> CmdLineP s ()+putCmdLineState x = CmdLineP (State.put x)++runCmdLineP :: CmdLineP s a -> s -> (a, s)+runCmdLineP (CmdLineP k) s0 = runIdentity $ runStateT k s0++-- | A helper to parse a set of flags from a list of command-line arguments, handling+-- response files.+processCmdLineP+    :: forall s m. MonadIO m+    => [Flag (CmdLineP s)]  -- ^ valid flags to match against+    -> s                    -- ^ current state+    -> [Located String]     -- ^ arguments to parse+    -> m (([Located String], [Err], [Warn]), s)+                            -- ^ (leftovers, errors, warnings)+processCmdLineP activeFlags s0 args =+    runStateT (processArgs (map (hoistFlag getCmdLineP) activeFlags) args parseResponseFile) s0+  where+    getCmdLineP :: CmdLineP s a -> StateT s m a+    getCmdLineP (CmdLineP k) = k++-- | Parses the dynamically set flags for GHC. This is the most general form of+-- the dynamic flag parser that the other methods simply wrap. It allows+-- saying which flags are valid flags and indicating if we are parsing+-- arguments from the command line or from a file pragma.+parseDynamicFlagsFull+    :: forall m. MonadIO m+    => [Flag (CmdLineP DynFlags)]    -- ^ valid flags to match against+    -> Bool                          -- ^ are the arguments from the command line?+    -> Logger                        -- ^ logger+    -> DynFlags                      -- ^ current dynamic flags+    -> [Located String]              -- ^ arguments to parse+    -> m (DynFlags, [Located String], Messages DriverMessage)+parseDynamicFlagsFull activeFlags cmdline logger dflags0 args = do+  ((leftover, errs, cli_warns), dflags1) <- processCmdLineP activeFlags dflags0 args++  -- See Note [Handling errors when parsing command-line flags]+  let rdr = renderWithContext (initSDocContext dflags0 defaultUserStyle)+  unless (null errs) $ liftIO $ throwGhcExceptionIO $ errorsToGhcException $+    map ((rdr . ppr . getLoc &&& unLoc) . errMsg) $ errs++  -- check for disabled flags in safe haskell+  let (dflags2, sh_warns) = safeFlagCheck cmdline dflags1+      theWays = ways dflags2++  unless (allowed_combination theWays) $ liftIO $+      throwGhcExceptionIO (CmdLineError ("combination not supported: " +++                               intercalate "/" (map wayDesc (Set.toAscList theWays))))++  let (dflags3, consistency_warnings, infoverb) = makeDynFlagsConsistent dflags2++  -- Set timer stats & heap size+  when (enableTimeStats dflags3) $ liftIO enableTimingStats+  case (ghcHeapSize dflags3) of+    Just x -> liftIO (setHeapSize x)+    _      -> return ()++  liftIO $ setUnsafeGlobalDynFlags dflags3++  -- create message envelopes using final DynFlags: #23402+  let diag_opts = initDiagOpts dflags3+      warns = warnsToMessages diag_opts $ mconcat [consistency_warnings, sh_warns, cli_warns]++  when (logVerbAtLeast logger 3) $+    mapM_ (\(L _loc m) -> liftIO $ logInfo logger m) infoverb++  return (dflags3, leftover, warns)++-- | Check (and potentially disable) any extensions that aren't allowed+-- in safe mode.+--+-- The bool is to indicate if we are parsing command line flags (false means+-- file pragma). This allows us to generate better warnings.+safeFlagCheck :: Bool -> DynFlags -> (DynFlags, [Warn])+safeFlagCheck _ dflags | safeLanguageOn dflags = (dflagsUnset, warns)+  where+    -- Handle illegal flags under safe language.+    (dflagsUnset, warns) = foldl' check_method (dflags, mempty) unsafeFlags++    check_method (df, warns) (ext,loc,test,fix)+        | test df   = (fix df, safeFailure (loc df) ext :  warns)+        | otherwise = (df, warns)++    safeFailure loc ext+       = L loc $ DriverSafeHaskellIgnoredExtension ext++safeFlagCheck cmdl dflags =+  case safeInferOn dflags of+    True   -> (dflags' { safeInferred = safeFlags }, warn)+    False  -> (dflags', warn)++  where+    -- dynflags and warn for when -fpackage-trust by itself with no safe+    -- haskell flag+    (dflags', warn)+      | not (safeHaskellModeEnabled dflags) && not cmdl && packageTrustOn dflags+      = (gopt_unset dflags Opt_PackageTrust, pkgWarnMsg)+      | otherwise = (dflags, mempty)++    pkgWarnMsg :: [Warn]+    pkgWarnMsg = [ L (pkgTrustOnLoc dflags') DriverPackageTrustIgnored ]++    -- Have we inferred Unsafe? See Note [Safe Haskell Inference] in GHC.Driver.Main+    -- Force this to avoid retaining reference to old DynFlags value+    !safeFlags = all (\(_,_,t,_) -> not $ t dflags) unsafeFlagsForInfer++-- | Produce a list of suggestions for a user provided flag that is invalid.+flagSuggestions+  :: [String] -- valid flags to match against+  -> String+  -> [String]+flagSuggestions flags userInput+  -- fixes #11789+  -- If the flag contains '=',+  -- this uses both the whole and the left side of '=' for comparing.+  | elem '=' userInput =+        let (flagsWithEq, flagsWithoutEq) = partition (elem '=') flags+            fName = takeWhile (/= '=') userInput+        in (fuzzyMatch userInput flagsWithEq) ++ (fuzzyMatch fName flagsWithoutEq)+  | otherwise = fuzzyMatch userInput flags++{- **********************************************************************+%*                                                                      *+                DynFlags specifications+%*                                                                      *+%********************************************************************* -}++-- | All dynamic flags option strings without the deprecated ones.+-- These are the user facing strings for enabling and disabling options.+allNonDeprecatedFlags :: [String]+allNonDeprecatedFlags = allFlagsDeps False++-- | All flags with possibility to filter deprecated ones+allFlagsDeps :: Bool -> [String]+allFlagsDeps keepDeprecated = [ '-':flagName flag+                              | (deprecated, flag) <- flagsAllDeps+                              , keepDeprecated || not (isDeprecated deprecated)]+  where isDeprecated Deprecated = True+        isDeprecated _ = False++{-+ - Below we export user facing symbols for GHC dynamic flags for use with the+ - GHC API.+ -}++-- All dynamic flags present in GHC.+flagsAll :: [Flag (CmdLineP DynFlags)]+flagsAll = map snd flagsAllDeps++-- All dynamic flags present in GHC with deprecation information.+flagsAllDeps :: [(Deprecation, Flag (CmdLineP DynFlags))]+flagsAllDeps =  package_flags_deps ++ dynamic_flags_deps+++-- All dynamic flags, minus package flags, present in GHC.+flagsDynamic :: [Flag (CmdLineP DynFlags)]+flagsDynamic = map snd dynamic_flags_deps++-- ALl package flags present in GHC.+flagsPackage :: [Flag (CmdLineP DynFlags)]+flagsPackage = map snd package_flags_deps++----------------Helpers to make flags and keep deprecation information----------++type FlagMaker m = String -> OptKind m -> Flag m+type DynFlagMaker = FlagMaker (CmdLineP DynFlags)++-- Make a non-deprecated flag+make_ord_flag :: DynFlagMaker -> String -> OptKind (CmdLineP DynFlags)+              -> (Deprecation, Flag (CmdLineP DynFlags))+make_ord_flag fm name kind = (NotDeprecated, fm name kind)++-- Make a deprecated flag+make_dep_flag :: DynFlagMaker -> String -> OptKind (CmdLineP DynFlags) -> String+                 -> (Deprecation, Flag (CmdLineP DynFlags))+make_dep_flag fm name kind message = (Deprecated,+                                      fm name $ add_dep_message kind message)++add_dep_message :: OptKind (CmdLineP DynFlags) -> String+                -> OptKind (CmdLineP DynFlags)+add_dep_message (NoArg f) message = NoArg $ f >> deprecate message+add_dep_message (HasArg f) message = HasArg $ \s -> f s >> deprecate message+add_dep_message (SepArg f) message = SepArg $ \s -> f s >> deprecate message+add_dep_message (Prefix f) message = Prefix $ \s -> f s >> deprecate message+add_dep_message (OptPrefix f) message =+                                  OptPrefix $ \s -> f s >> deprecate message+add_dep_message (OptIntSuffix f) message =+                               OptIntSuffix $ \oi -> f oi >> deprecate message+add_dep_message (IntSuffix f) message =+                                  IntSuffix $ \i -> f i >> deprecate message+add_dep_message (Word64Suffix f) message =+                                  Word64Suffix $ \i -> f i >> deprecate message+add_dep_message (FloatSuffix f) message =+                                FloatSuffix $ \fl -> f fl >> deprecate message+add_dep_message (PassFlag f) message =+                                   PassFlag $ \s -> f s >> deprecate message+add_dep_message (AnySuffix f) message =+                                  AnySuffix $ \s -> f s >> deprecate message++----------------------- The main flags themselves ------------------------------+-- See Note [Updating flag description in the User's Guide]+-- See Note [Supporting CLI completion]+dynamic_flags_deps :: [(Deprecation, Flag (CmdLineP DynFlags))]+dynamic_flags_deps = [+    make_dep_flag defFlag "n" (NoArg $ return ())+        "The -n flag is deprecated and no longer has any effect"+  , make_ord_flag defFlag "cpp"      (NoArg (setExtensionFlag LangExt.Cpp))+  , make_ord_flag defFlag "F"        (NoArg (setGeneralFlag Opt_Pp))+  , (Deprecated, defFlag "#include"+      (HasArg (\_s ->+         deprecate ("-#include and INCLUDE pragmas are " +++                    "deprecated: They no longer have any effect"))))+  , make_ord_flag defFlag "v"        (OptIntSuffix setVerbosity)++  , make_ord_flag defGhcFlag "j"     (OptIntSuffix+        (\n -> case n of+                 Just n+                     | n > 0     -> upd (\d -> d { parMakeCount = Just (ParMakeThisMany n) })+                     | otherwise -> addErr "Syntax: -j[n] where n > 0"+                 Nothing -> upd (\d -> d { parMakeCount = Just ParMakeNumProcessors })))+                 -- When the number of parallel builds+                 -- is omitted, it is the same+                 -- as specifying that the number of+                 -- parallel builds is equal to the+                 -- result of getNumProcessors+  , make_ord_flag defGhcFlag "jsem" $ hasArg $ \f d -> d { parMakeCount = Just (ParMakeSemaphore f) }++  , make_ord_flag defFlag "instantiated-with"   (sepArg setUnitInstantiations)+  , make_ord_flag defFlag "this-component-id"   (sepArg setUnitInstanceOf)++    -- RTS options -------------------------------------------------------------+  , make_ord_flag defFlag "H"           (HasArg (\s -> upd (\d ->+          d { ghcHeapSize = Just $ fromIntegral (decodeSize s)})))++  , make_ord_flag defFlag "Rghc-timing" (NoArg (upd (\d ->+                                               d { enableTimeStats = True })))++    ------- ways ---------------------------------------------------------------+  , make_ord_flag defGhcFlag "prof"           (NoArg (addWayDynP WayProf))+  , (Deprecated, defFlag     "eventlog"+     $ noArgM $ \d -> do+         deprecate "the eventlog is now enabled in all runtime system ways"+         return d)+  , make_ord_flag defGhcFlag "debug"          (NoArg (addWayDynP WayDebug))+  , make_ord_flag defGhcFlag "threaded"       (NoArg (addWayDynP WayThreaded))+  , make_ord_flag defGhcFlag "single-threaded" (NoArg (removeWayDynP WayThreaded))++  , make_ord_flag defGhcFlag "ticky"+      (NoArg (setGeneralFlag Opt_Ticky >> addWayDynP WayDebug))++    -- -ticky enables ticky-ticky code generation, and also implies -debug which+    -- is required to get the RTS ticky support.++        ----- Linker --------------------------------------------------------+  , make_ord_flag defGhcFlag "static"         (NoArg (removeWayDynP WayDyn))+  , make_ord_flag defGhcFlag "dynamic"        (NoArg (addWayDynP WayDyn))+  , make_ord_flag defGhcFlag "rdynamic" $ noArg $+#if defined(linux_HOST_OS)+                              addOptl "-rdynamic"+#elif defined(mingw32_HOST_OS)+                              addOptl "-Wl,--export-all-symbols"+#else+    -- ignored for compat w/ gcc:+                              id+#endif+  , make_ord_flag defGhcFlag "relative-dynlib-paths"+      (NoArg (setGeneralFlag Opt_RelativeDynlibPaths))+  , make_ord_flag defGhcFlag "copy-libs-when-linking"+      (NoArg (setGeneralFlag Opt_SingleLibFolder))+  , make_ord_flag defGhcFlag "pie"            (NoArg (setGeneralFlag Opt_PICExecutable))+  , make_ord_flag defGhcFlag "no-pie"         (NoArg (unSetGeneralFlag Opt_PICExecutable))++        ------- Specific phases  --------------------------------------------+    -- need to appear before -pgmL to be parsed as LLVM flags.+  , make_ord_flag defFlag "pgmlo"+      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_lo  = (f,[]) }+  , make_ord_flag defFlag "pgmlc"+      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_lc  = (f,[]) }+  , make_ord_flag defFlag "pgmlas"+      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_las  = (f,[]) }+  , make_ord_flag defFlag "pgmlm"+      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_lm  =+          if null f then Nothing else Just (f,[]) }+  , make_ord_flag defFlag "pgmi"+      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_i   =  f }+  , make_ord_flag defFlag "pgmL"+      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_L   = f }+  , make_ord_flag defFlag "pgmP"+      (hasArg setPgmP)+  , make_ord_flag defFlag "pgmJSP"+      (hasArg setPgmJSP)+  , make_ord_flag defFlag "pgmCmmP"+      (hasArg setPgmCmmP)+  , make_ord_flag defFlag "pgmF"+      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_F   = f }+  , make_ord_flag defFlag "pgmc"+      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_c   = f }+  , make_ord_flag defFlag "pgmcxx"+      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_cxx = f }+  , (Deprecated, defFlag  "pgmc-supports-no-pie"+      $ noArgM  $ \d -> do+        deprecate $ "use -pgml-supports-no-pie instead"+        pure $ alterToolSettings (\s -> s { toolSettings_ccSupportsNoPie = True }) d)+  , make_ord_flag defFlag "pgms"+      (HasArg (\_ -> addWarn "Object splitting was removed in GHC 8.8"))+  , make_ord_flag defFlag "pgma"+      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_a   = (f,[]) }+  , make_ord_flag defFlag "pgml"+      $ hasArg $ \f -> alterToolSettings $ \s -> s+         { toolSettings_pgm_l   = (f,[])+         , -- Don't pass -no-pie with custom -pgml (see #15319). Note+           -- that this could break when -no-pie is actually needed.+           -- But the CC_SUPPORTS_NO_PIE check only happens at+           -- buildtime, and -pgml is a runtime option. A better+           -- solution would be running this check for each custom+           -- -pgml.+           toolSettings_ccSupportsNoPie = False+         }+  , make_ord_flag defFlag "pgml-supports-no-pie"+      $ noArg $ alterToolSettings $ \s -> s { toolSettings_ccSupportsNoPie = True }+  , make_ord_flag defFlag "pgmwindres"+      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_windres = f }+  , make_ord_flag defFlag "pgmar"+      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_ar = f }+  , make_ord_flag defFlag "pgmotool"+      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_otool = f}+  , make_ord_flag defFlag "pgminstall_name_tool"+      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_install_name_tool = f}+  , make_ord_flag defFlag "pgmranlib"+      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_ranlib = f }+++    -- need to appear before -optl/-opta to be parsed as LLVM flags.+  , make_ord_flag defFlag "optlm"+      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_lm  = f : toolSettings_opt_lm s }+  , make_ord_flag defFlag "optlo"+      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_lo  = f : toolSettings_opt_lo s }+  , make_ord_flag defFlag "optlc"+      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_lc  = f : toolSettings_opt_lc s }+  , make_ord_flag defFlag "optlas"+      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_las  = f : toolSettings_opt_las s }+  , make_ord_flag defFlag "opti"+      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_i   = f : toolSettings_opt_i s }+  , make_ord_flag defFlag "optL"+      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_L   = f : toolSettings_opt_L s }+  , make_ord_flag defFlag "optP"+      (hasArg addOptP)+  , make_ord_flag defFlag "optJSP"+      (hasArg addOptJSP)+  , make_ord_flag defFlag "optCmmP"+      (hasArg addOptCmmP)+  , make_ord_flag defFlag "optF"+      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_F   = f : toolSettings_opt_F s }+  , make_ord_flag defFlag "optc"+      (hasArg addOptc)+  , make_ord_flag defFlag "optcxx"+      (hasArg addOptcxx)+  , make_ord_flag defFlag "opta"+      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_a   = f : toolSettings_opt_a s }+  , make_ord_flag defFlag "optl"+      (hasArg addOptl)+  , make_ord_flag defFlag "optwindres"+      $ hasArg $ \f ->+        alterToolSettings $ \s -> s { toolSettings_opt_windres = f : toolSettings_opt_windres s }++    -- N.B. We may someday deprecate this in favor of -fsplit-sections,+    -- which has the benefit of also having a negating -fno-split-sections.+  , make_ord_flag defGhcFlag "split-sections"+      (NoArg $ setGeneralFlag Opt_SplitSections)++        -------- ghc -M -----------------------------------------------------+  , make_ord_flag defGhcFlag "dep-suffix"              (hasArg addDepSuffix)+  , make_ord_flag defGhcFlag "dep-makefile"            (hasArg setDepMakefile)+  , make_ord_flag defGhcFlag "include-cpp-deps"+        (noArg (setDepIncludeCppDeps True))+  , make_ord_flag defGhcFlag "include-pkg-deps"+        (noArg (setDepIncludePkgDeps True))+  , make_ord_flag defGhcFlag "exclude-module"          (hasArg addDepExcludeMod)++        -------- Linking ----------------------------------------------------+  , make_ord_flag defGhcFlag "no-link"+        (noArg (\d -> d { ghcLink=NoLink }))+  , make_ord_flag defGhcFlag "shared"+        (noArg (\d -> d { ghcLink=LinkDynLib }))+  , make_ord_flag defGhcFlag "staticlib"+        (noArg (\d -> setGeneralFlag' Opt_LinkRts (d { ghcLink=LinkStaticLib })))+  , make_ord_flag defGhcFlag "-merge-objs"+        (noArg (\d -> d { ghcLink=LinkMergedObj }))+  , make_ord_flag defGhcFlag "dynload"            (hasArg parseDynLibLoaderMode)+  , make_ord_flag defGhcFlag "dylib-install-name" (hasArg setDylibInstallName)++        ------- Libraries ---------------------------------------------------+  , make_ord_flag defFlag "L"   (Prefix addLibraryPath)+  , make_ord_flag defFlag "l"   (hasArg (addLdInputs . Option . ("-l" ++)))++        ------- Frameworks --------------------------------------------------+        -- -framework-path should really be -F ...+  , make_ord_flag defFlag "framework-path" (HasArg addFrameworkPath)+  , make_ord_flag defFlag "framework"      (hasArg addCmdlineFramework)++        ------- Output Redirection ------------------------------------------+  , make_ord_flag defGhcFlag "odir"              (hasArg setObjectDir)+  , make_ord_flag defGhcFlag "o"                 (sepArg (setOutputFile . Just))+  , make_ord_flag defGhcFlag "dyno"+        (sepArg (setDynOutputFile . Just))+  , make_ord_flag defGhcFlag "ohi"+        (hasArg (setOutputHi . Just ))+  , make_ord_flag defGhcFlag "dynohi"+        (hasArg (setDynOutputHi . Just ))+  , make_ord_flag defGhcFlag "osuf"              (hasArg setObjectSuf)+  , make_ord_flag defGhcFlag "dynosuf"           (hasArg setDynObjectSuf)+  , make_ord_flag defGhcFlag "hcsuf"             (hasArg setHcSuf)+  , make_ord_flag defGhcFlag "hisuf"             (hasArg setHiSuf)+  , make_ord_flag defGhcFlag "hiesuf"            (hasArg setHieSuf)+  , make_ord_flag defGhcFlag "dynhisuf"          (hasArg setDynHiSuf)+  , make_ord_flag defGhcFlag "hidir"             (hasArg setHiDir)+  , make_ord_flag defGhcFlag "hiedir"            (hasArg setHieDir)+  , make_ord_flag defGhcFlag "tmpdir"            (hasArg setTmpDir)+  , make_ord_flag defGhcFlag "stubdir"           (hasArg setStubDir)+  , make_ord_flag defGhcFlag "dumpdir"           (hasArg setDumpDir)+  , make_ord_flag defGhcFlag "outputdir"         (hasArg setOutputDir)+  , make_ord_flag defGhcFlag "ddump-file-prefix"+        (hasArg (setDumpPrefixForce . Just . flip (++) "."))++  , make_ord_flag defGhcFlag "dynamic-too"+        (NoArg (setGeneralFlag Opt_BuildDynamicToo))++        ------- Keeping temporary files -------------------------------------+     -- These can be singular (think ghc -c) or plural (think ghc --make)+  , make_ord_flag defGhcFlag "keep-hc-file"+        (NoArg (setGeneralFlag Opt_KeepHcFiles))+  , make_ord_flag defGhcFlag "keep-hc-files"+        (NoArg (setGeneralFlag Opt_KeepHcFiles))+  , make_ord_flag defGhcFlag "keep-hscpp-file"+        (NoArg (setGeneralFlag Opt_KeepHscppFiles))+  , make_ord_flag defGhcFlag "keep-hscpp-files"+        (NoArg (setGeneralFlag Opt_KeepHscppFiles))+  , make_ord_flag defGhcFlag "keep-s-file"+        (NoArg (setGeneralFlag Opt_KeepSFiles))+  , make_ord_flag defGhcFlag "keep-s-files"+        (NoArg (setGeneralFlag Opt_KeepSFiles))+  , make_ord_flag defGhcFlag "keep-llvm-file"+        (NoArg $ setObjBackend llvmBackend >> setGeneralFlag Opt_KeepLlvmFiles)+  , make_ord_flag defGhcFlag "keep-llvm-files"+        (NoArg $ setObjBackend llvmBackend >> setGeneralFlag Opt_KeepLlvmFiles)+     -- This only makes sense as plural+  , make_ord_flag defGhcFlag "keep-tmp-files"+        (NoArg (setGeneralFlag Opt_KeepTmpFiles))+  , make_ord_flag defGhcFlag "keep-hi-file"+        (NoArg (setGeneralFlag Opt_KeepHiFiles))+  , make_ord_flag defGhcFlag "no-keep-hi-file"+        (NoArg (unSetGeneralFlag Opt_KeepHiFiles))+  , make_ord_flag defGhcFlag "keep-hi-files"+        (NoArg (setGeneralFlag Opt_KeepHiFiles))+  , make_ord_flag defGhcFlag "no-keep-hi-files"+        (NoArg (unSetGeneralFlag Opt_KeepHiFiles))+  , make_ord_flag defGhcFlag "keep-o-file"+        (NoArg (setGeneralFlag Opt_KeepOFiles))+  , make_ord_flag defGhcFlag "no-keep-o-file"+        (NoArg (unSetGeneralFlag Opt_KeepOFiles))+  , make_ord_flag defGhcFlag "keep-o-files"+        (NoArg (setGeneralFlag Opt_KeepOFiles))+  , make_ord_flag defGhcFlag "no-keep-o-files"+        (NoArg (unSetGeneralFlag Opt_KeepOFiles))++        ------- Miscellaneous ----------------------------------------------+  , make_ord_flag defGhcFlag "no-auto-link-packages"+        (NoArg (unSetGeneralFlag Opt_AutoLinkPackages))+  , make_ord_flag defGhcFlag "no-hs-main"+        (NoArg (setGeneralFlag Opt_NoHsMain))+  , make_ord_flag defGhcFlag "fno-state-hack"+        (NoArg (setGeneralFlag Opt_G_NoStateHack))+  , make_ord_flag defGhcFlag "fno-opt-coercion"+        (NoArg (setGeneralFlag Opt_G_NoOptCoercion))+  , make_ord_flag defGhcFlag "with-rtsopts"+        (HasArg setRtsOpts)+  , make_ord_flag defGhcFlag "rtsopts"+        (NoArg (setRtsOptsEnabled RtsOptsAll))+  , make_ord_flag defGhcFlag "rtsopts=all"+        (NoArg (setRtsOptsEnabled RtsOptsAll))+  , make_ord_flag defGhcFlag "rtsopts=some"+        (NoArg (setRtsOptsEnabled RtsOptsSafeOnly))+  , make_ord_flag defGhcFlag "rtsopts=none"+        (NoArg (setRtsOptsEnabled RtsOptsNone))+  , make_ord_flag defGhcFlag "rtsopts=ignore"+        (NoArg (setRtsOptsEnabled RtsOptsIgnore))+  , make_ord_flag defGhcFlag "rtsopts=ignoreAll"+        (NoArg (setRtsOptsEnabled RtsOptsIgnoreAll))+  , make_ord_flag defGhcFlag "no-rtsopts"+        (NoArg (setRtsOptsEnabled RtsOptsNone))+  , make_ord_flag defGhcFlag "no-rtsopts-suggestions"+      (noArg (\d -> d {rtsOptsSuggestions = False}))+  , make_ord_flag defGhcFlag "dhex-word-literals"+        (NoArg (setGeneralFlag Opt_HexWordLiterals))++  , make_ord_flag defGhcFlag "ghcversion-file"      (hasArg addGhcVersionFile)+  , make_ord_flag defGhcFlag "main-is"              (SepArg setMainIs)+  , make_ord_flag defGhcFlag "haddock"              (NoArg (setGeneralFlag Opt_Haddock))+  , make_ord_flag defGhcFlag "no-haddock"           (NoArg (unSetGeneralFlag Opt_Haddock))+  , make_ord_flag defGhcFlag "haddock-opts"         (hasArg addHaddockOpts)+  , make_ord_flag defGhcFlag "hpcdir"               (SepArg setOptHpcDir)+  , make_ord_flag defGhciFlag "ghci-script"         (hasArg addGhciScript)+  , make_ord_flag defGhciFlag "interactive-print"   (hasArg setInteractivePrint)+  , make_ord_flag defGhcFlag "ticky-allocd"+        (NoArg (setGeneralFlag Opt_Ticky_Allocd))+  , make_ord_flag defGhcFlag "ticky-LNE"+        (NoArg (setGeneralFlag Opt_Ticky_LNE))+  , make_ord_flag defGhcFlag "ticky-ap-thunk"+        (NoArg (setGeneralFlag Opt_Ticky_AP))+  , make_ord_flag defGhcFlag "ticky-dyn-thunk"+        (NoArg (setGeneralFlag Opt_Ticky_Dyn_Thunk))+  , make_ord_flag defGhcFlag "ticky-tag-checks"+        (NoArg (setGeneralFlag Opt_Ticky_Tag))+        ------- recompilation checker --------------------------------------+  , make_dep_flag defGhcFlag "recomp"+        (NoArg $ unSetGeneralFlag Opt_ForceRecomp)+             "Use -fno-force-recomp instead"+  , make_dep_flag defGhcFlag "no-recomp"+        (NoArg $ setGeneralFlag Opt_ForceRecomp) "Use -fforce-recomp instead"+  , make_ord_flag defFlag "fmax-errors"+      (intSuffix (\n d -> d { maxErrors = Just (max 1 n) }))+  , make_ord_flag defFlag "fno-max-errors"+      (noArg (\d -> d { maxErrors = Nothing }))+  , make_ord_flag defFlag "freverse-errors"+        (noArg (\d -> d {reverseErrors = True} ))+  , make_ord_flag defFlag "fno-reverse-errors"+        (noArg (\d -> d {reverseErrors = False} ))++        ------ HsCpp opts ---------------------------------------------------+  , make_ord_flag defFlag "D"              (AnySuffix (upd . addOptP))+  , make_ord_flag defFlag "U"              (AnySuffix (upd . addOptP))++        ------- Include/Import Paths ----------------------------------------+  , make_ord_flag defFlag "I"              (Prefix    addIncludePath)+  , make_ord_flag defFlag "i"              (OptPrefix addImportPath)++        ------ Output style options -----------------------------------------+  , make_ord_flag defFlag "dppr-user-length" (intSuffix (\n d ->+                                                       d { pprUserLength = n }))+  , make_ord_flag defFlag "dppr-cols"        (intSuffix (\n d ->+                                                             d { pprCols = n }))+  , make_ord_flag defFlag "fdiagnostics-color=auto"+      (NoArg (upd (\d -> d { useColor = Auto })))+  , make_ord_flag defFlag "fdiagnostics-color=always"+      (NoArg (upd (\d -> d { useColor = Always })))+  , make_ord_flag defFlag "fdiagnostics-color=never"+      (NoArg (upd (\d -> d { useColor = Never })))++  , make_ord_flag defFlag "fprint-error-index-links=auto"+      (NoArg (upd (\d -> d { useErrorLinks = Auto })))+  , make_ord_flag defFlag "fprint-error-index-links=always"+      (NoArg (upd (\d -> d { useErrorLinks = Always })))+  , make_ord_flag defFlag "fprint-error-index-links=never"+      (NoArg (upd (\d -> d { useErrorLinks = Never })))++  -- Suppress all that is suppressible in core dumps.+  -- Except for uniques, as some simplifier phases introduce new variables that+  -- have otherwise identical names.+  , make_ord_flag defGhcFlag "dsuppress-all"+      (NoArg $ do setGeneralFlag Opt_SuppressCoercions+                  setGeneralFlag Opt_SuppressCoercionTypes+                  setGeneralFlag Opt_SuppressVarKinds+                  setGeneralFlag Opt_SuppressModulePrefixes+                  setGeneralFlag Opt_SuppressTypeApplications+                  setGeneralFlag Opt_SuppressIdInfo+                  setGeneralFlag Opt_SuppressTicks+                  setGeneralFlag Opt_SuppressStgExts+                  setGeneralFlag Opt_SuppressStgReps+                  setGeneralFlag Opt_SuppressTypeSignatures+                  setGeneralFlag Opt_SuppressCoreSizes+                  setGeneralFlag Opt_SuppressTimestamps)++        ------ Debugging ----------------------------------------------------+  , make_ord_flag defGhcFlag "dstg-stats"+        (NoArg (setGeneralFlag Opt_StgStats))++  , make_ord_flag defGhcFlag "ddump-cmm"+        (setDumpFlag Opt_D_dump_cmm)+  , make_ord_flag defGhcFlag "ddump-cmm-from-stg"+        (setDumpFlag Opt_D_dump_cmm_from_stg)+  , make_ord_flag defGhcFlag "ddump-cmm-raw"+        (setDumpFlag Opt_D_dump_cmm_raw)+  , make_ord_flag defGhcFlag "ddump-cmm-verbose"+        (setDumpFlag Opt_D_dump_cmm_verbose)+  , make_ord_flag defGhcFlag "ddump-cmm-verbose-by-proc"+        (setDumpFlag Opt_D_dump_cmm_verbose_by_proc)+  , make_ord_flag defGhcFlag "ddump-cmm-cfg"+        (setDumpFlag Opt_D_dump_cmm_cfg)+  , make_ord_flag defGhcFlag "ddump-cmm-cbe"+        (setDumpFlag Opt_D_dump_cmm_cbe)+  , make_ord_flag defGhcFlag "ddump-cmm-switch"+        (setDumpFlag Opt_D_dump_cmm_switch)+  , make_ord_flag defGhcFlag "ddump-cmm-proc"+        (setDumpFlag Opt_D_dump_cmm_proc)+  , make_ord_flag defGhcFlag "ddump-cmm-sp"+        (setDumpFlag Opt_D_dump_cmm_sp)+  , make_ord_flag defGhcFlag "ddump-cmm-sink"+        (setDumpFlag Opt_D_dump_cmm_sink)+  , make_ord_flag defGhcFlag "ddump-cmm-caf"+        (setDumpFlag Opt_D_dump_cmm_caf)+  , make_ord_flag defGhcFlag "ddump-cmm-procmap"+        (setDumpFlag Opt_D_dump_cmm_procmap)+  , make_ord_flag defGhcFlag "ddump-cmm-split"+        (setDumpFlag Opt_D_dump_cmm_split)+  , make_ord_flag defGhcFlag "ddump-cmm-info"+        (setDumpFlag Opt_D_dump_cmm_info)+  , make_ord_flag defGhcFlag "ddump-cmm-cps"+        (setDumpFlag Opt_D_dump_cmm_cps)+  , make_ord_flag defGhcFlag "ddump-cmm-opt"+        (setDumpFlag Opt_D_dump_opt_cmm)+  , make_ord_flag defGhcFlag "ddump-cmm-thread-sanitizer"+        (setDumpFlag Opt_D_dump_cmm_thread_sanitizer)+  , make_ord_flag defGhcFlag "ddump-cfg-weights"+        (setDumpFlag Opt_D_dump_cfg_weights)+  , make_ord_flag defGhcFlag "ddump-core-stats"+        (setDumpFlag Opt_D_dump_core_stats)+  , make_ord_flag defGhcFlag "ddump-asm"+        (setDumpFlag Opt_D_dump_asm)+  , make_ord_flag defGhcFlag "ddump-js"+        (setDumpFlag Opt_D_dump_js)+  , make_ord_flag defGhcFlag "ddump-asm-native"+        (setDumpFlag Opt_D_dump_asm_native)+  , make_ord_flag defGhcFlag "ddump-asm-liveness"+        (setDumpFlag Opt_D_dump_asm_liveness)+  , make_ord_flag defGhcFlag "ddump-asm-regalloc"+        (setDumpFlag Opt_D_dump_asm_regalloc)+  , make_ord_flag defGhcFlag "ddump-asm-conflicts"+        (setDumpFlag Opt_D_dump_asm_conflicts)+  , make_ord_flag defGhcFlag "ddump-asm-regalloc-stages"+        (setDumpFlag Opt_D_dump_asm_regalloc_stages)+  , make_ord_flag defGhcFlag "ddump-asm-stats"+        (setDumpFlag Opt_D_dump_asm_stats)+  , make_ord_flag defGhcFlag "ddump-llvm"+        (NoArg $ setDumpFlag' Opt_D_dump_llvm)+  , make_ord_flag defGhcFlag "ddump-c-backend"+        (NoArg $ setDumpFlag' Opt_D_dump_c_backend)+  , make_ord_flag defGhcFlag "ddump-deriv"+        (setDumpFlag Opt_D_dump_deriv)+  , make_ord_flag defGhcFlag "ddump-ds"+        (setDumpFlag Opt_D_dump_ds)+  , make_ord_flag defGhcFlag "ddump-ds-preopt"+        (setDumpFlag Opt_D_dump_ds_preopt)+  , make_ord_flag defGhcFlag "ddump-foreign"+        (setDumpFlag Opt_D_dump_foreign)+  , make_ord_flag defGhcFlag "ddump-inlinings"+        (setDumpFlag Opt_D_dump_inlinings)+  , make_ord_flag defGhcFlag "ddump-verbose-inlinings"+        (setDumpFlag Opt_D_dump_verbose_inlinings)+  , make_ord_flag defGhcFlag "ddump-rule-firings"+        (setDumpFlag Opt_D_dump_rule_firings)+  , make_ord_flag defGhcFlag "ddump-rule-rewrites"+        (setDumpFlag Opt_D_dump_rule_rewrites)+  , make_ord_flag defGhcFlag "ddump-simpl-trace"+        (setDumpFlag Opt_D_dump_simpl_trace)+  , make_ord_flag defGhcFlag "ddump-occur-anal"+        (setDumpFlag Opt_D_dump_occur_anal)+  , make_ord_flag defGhcFlag "ddump-parsed"+        (setDumpFlag Opt_D_dump_parsed)+  , make_ord_flag defGhcFlag "ddump-parsed-ast"+        (setDumpFlag Opt_D_dump_parsed_ast)+  , make_ord_flag defGhcFlag "dkeep-comments"+        (NoArg (setGeneralFlag Opt_KeepRawTokenStream))+  , make_ord_flag defGhcFlag "ddump-rn"+        (setDumpFlag Opt_D_dump_rn)+  , make_ord_flag defGhcFlag "ddump-rn-ast"+        (setDumpFlag Opt_D_dump_rn_ast)+  , make_ord_flag defGhcFlag "ddump-simpl"+        (setDumpFlag Opt_D_dump_simpl)+  , make_ord_flag defGhcFlag "ddump-simpl-iterations"+      (setDumpFlag Opt_D_dump_simpl_iterations)+  , make_ord_flag defGhcFlag "ddump-spec"+        (setDumpFlag Opt_D_dump_spec)+  , make_ord_flag defGhcFlag "ddump-spec-constr"+        (setDumpFlag Opt_D_dump_spec_constr)+  , make_ord_flag defGhcFlag "ddump-prep"+        (setDumpFlag Opt_D_dump_prep)+  , make_ord_flag defGhcFlag "ddump-late-cc"+        (setDumpFlag Opt_D_dump_late_cc)+  , make_ord_flag defGhcFlag "ddump-stg-from-core"+        (setDumpFlag Opt_D_dump_stg_from_core)+  , make_ord_flag defGhcFlag "ddump-stg-unarised"+        (setDumpFlag Opt_D_dump_stg_unarised)+  , make_ord_flag defGhcFlag "ddump-stg-final"+        (setDumpFlag Opt_D_dump_stg_final)+  , make_ord_flag defGhcFlag "ddump-stg-cg"+        (setDumpFlag Opt_D_dump_stg_cg)+  , make_dep_flag defGhcFlag "ddump-stg"+        (setDumpFlag Opt_D_dump_stg_from_core)+        "Use `-ddump-stg-from-core` or `-ddump-stg-final` instead"+  , make_ord_flag defGhcFlag "ddump-stg-tags"+        (setDumpFlag Opt_D_dump_stg_tags)+  , make_ord_flag defGhcFlag "ddump-stg-from-js-sinker"+        (setDumpFlag Opt_D_dump_stg_from_js_sinker)+  , make_ord_flag defGhcFlag "ddump-call-arity"+        (setDumpFlag Opt_D_dump_call_arity)+  , make_ord_flag defGhcFlag "ddump-exitify"+        (setDumpFlag Opt_D_dump_exitify)+  , make_dep_flag defGhcFlag "ddump-stranal"+        (setDumpFlag Opt_D_dump_dmdanal)+        "Use `-ddump-dmdanal` instead"+  , make_dep_flag defGhcFlag "ddump-str-signatures"+        (setDumpFlag Opt_D_dump_dmd_signatures)+        "Use `-ddump-dmd-signatures` instead"+  , make_ord_flag defGhcFlag "ddump-dmdanal"+        (setDumpFlag Opt_D_dump_dmdanal)+  , make_ord_flag defGhcFlag "ddump-dmd-signatures"+        (setDumpFlag Opt_D_dump_dmd_signatures)+  , make_ord_flag defGhcFlag "ddump-cpranal"+        (setDumpFlag Opt_D_dump_cpranal)+  , make_ord_flag defGhcFlag "ddump-cpr-signatures"+        (setDumpFlag Opt_D_dump_cpr_signatures)+  , make_ord_flag defGhcFlag "ddump-tc"+        (setDumpFlag Opt_D_dump_tc)+  , make_ord_flag defGhcFlag "ddump-tc-ast"+        (setDumpFlag Opt_D_dump_tc_ast)+  , make_ord_flag defGhcFlag "ddump-hie"+        (setDumpFlag Opt_D_dump_hie)+  , make_ord_flag defGhcFlag "ddump-types"+        (setDumpFlag Opt_D_dump_types)+  , make_ord_flag defGhcFlag "ddump-rules"+        (setDumpFlag Opt_D_dump_rules)+  , make_ord_flag defGhcFlag "ddump-cse"+        (setDumpFlag Opt_D_dump_cse)+  , make_ord_flag defGhcFlag "ddump-float-out"+        (setDumpFlag Opt_D_dump_float_out)+  , make_ord_flag defGhcFlag "ddump-full-laziness"+        (setDumpFlag Opt_D_dump_float_out)+  , make_ord_flag defGhcFlag "ddump-float-in"+        (setDumpFlag Opt_D_dump_float_in)+  , make_ord_flag defGhcFlag "ddump-liberate-case"+        (setDumpFlag Opt_D_dump_liberate_case)+  , make_ord_flag defGhcFlag "ddump-static-argument-transformation"+        (setDumpFlag Opt_D_dump_static_argument_transformation)+  , make_ord_flag defGhcFlag "ddump-worker-wrapper"+        (setDumpFlag Opt_D_dump_worker_wrapper)+  , make_ord_flag defGhcFlag "ddump-rn-trace"+        (setDumpFlag Opt_D_dump_rn_trace)+  , make_ord_flag defGhcFlag "ddump-if-trace"+        (setDumpFlag Opt_D_dump_if_trace)+  , make_ord_flag defGhcFlag "ddump-cs-trace"+        (setDumpFlag Opt_D_dump_cs_trace)+  , make_ord_flag defGhcFlag "ddump-tc-trace"+        (NoArg (do setDumpFlag' Opt_D_dump_tc_trace+                   setDumpFlag' Opt_D_dump_cs_trace))+  , make_ord_flag defGhcFlag "ddump-ec-trace"+        (setDumpFlag Opt_D_dump_ec_trace)+  , make_ord_flag defGhcFlag "ddump-splices"+        (setDumpFlag Opt_D_dump_splices)+  , make_ord_flag defGhcFlag "dth-dec-file"+        (setDumpFlag Opt_D_th_dec_file)++  , make_ord_flag defGhcFlag "ddump-rn-stats"+        (setDumpFlag Opt_D_dump_rn_stats)+  , make_ord_flag defGhcFlag "ddump-opt-cmm" --old alias for cmm-opt+        (setDumpFlag Opt_D_dump_opt_cmm)+  , make_ord_flag defGhcFlag "ddump-simpl-stats"+        (setDumpFlag Opt_D_dump_simpl_stats)+  , make_ord_flag defGhcFlag "ddump-bcos"+        (setDumpFlag Opt_D_dump_BCOs)+  , make_ord_flag defGhcFlag "dsource-stats"+        (setDumpFlag Opt_D_source_stats)+  , make_ord_flag defGhcFlag "dverbose-core2core"+        (NoArg $ setVerbosity (Just 2) >> setDumpFlag' Opt_D_verbose_core2core)+  , make_ord_flag defGhcFlag "dverbose-stg2stg"+        (setDumpFlag Opt_D_verbose_stg2stg)+  , make_ord_flag defGhcFlag "ddump-hi"+        (setDumpFlag Opt_D_dump_hi)+  , make_ord_flag defGhcFlag "ddump-minimal-imports"+        (NoArg (setGeneralFlag Opt_D_dump_minimal_imports))+  , make_ord_flag defGhcFlag "ddump-hpc"+        (setDumpFlag Opt_D_dump_ticked) -- back compat+  , make_ord_flag defGhcFlag "ddump-ticked"+        (setDumpFlag Opt_D_dump_ticked)+  , make_ord_flag defGhcFlag "ddump-mod-cycles"+        (setDumpFlag Opt_D_dump_mod_cycles)+  , make_ord_flag defGhcFlag "ddump-mod-map"+        (setDumpFlag Opt_D_dump_mod_map)+  , make_ord_flag defGhcFlag "ddump-timings"+        (setDumpFlag Opt_D_dump_timings)+  , make_ord_flag defGhcFlag "ddump-view-pattern-commoning"+        (setDumpFlag Opt_D_dump_view_pattern_commoning)+  , make_ord_flag defGhcFlag "ddump-to-file"+        (NoArg (setGeneralFlag Opt_DumpToFile))+  , make_ord_flag defGhcFlag "ddump-hi-diffs"+        (setDumpFlag Opt_D_dump_hi_diffs)+  , make_ord_flag defGhcFlag "ddump-rtti"+        (setDumpFlag Opt_D_dump_rtti)+  , make_ord_flag defGhcFlag "dlint"+        (NoArg enableDLint)+  , make_ord_flag defGhcFlag "dcore-lint"+        (NoArg (setGeneralFlag Opt_DoCoreLinting))+  , make_ord_flag defGhcFlag "dlinear-core-lint"+        (NoArg (setGeneralFlag Opt_DoLinearCoreLinting))+  , make_ord_flag defGhcFlag "dstg-lint"+        (NoArg (setGeneralFlag Opt_DoStgLinting))+  , make_ord_flag defGhcFlag "dcmm-lint"+        (NoArg (setGeneralFlag Opt_DoCmmLinting))+  , make_ord_flag defGhcFlag "dasm-lint"+        (NoArg (setGeneralFlag Opt_DoAsmLinting))+  , make_ord_flag defGhcFlag "dannot-lint"+        (NoArg (setGeneralFlag Opt_DoAnnotationLinting))+  , make_ord_flag defGhcFlag "dtag-inference-checks"+        (NoArg (setGeneralFlag Opt_DoTagInferenceChecks))+  , make_ord_flag defGhcFlag "dshow-passes"+        (NoArg $ forceRecompile >> (setVerbosity $ Just 2))+  , make_ord_flag defGhcFlag "dipe-stats"+        (setDumpFlag Opt_D_ipe_stats)+  , make_ord_flag defGhcFlag "dfaststring-stats"+        (setDumpFlag Opt_D_faststring_stats)+  , make_ord_flag defGhcFlag "dno-llvm-mangler"+        (NoArg (setGeneralFlag Opt_NoLlvmMangler)) -- hidden flag+  , make_ord_flag defGhcFlag "dno-typeable-binds"+        (NoArg (setGeneralFlag Opt_NoTypeableBinds))+  , make_ord_flag defGhcFlag "ddump-debug"+        (setDumpFlag Opt_D_dump_debug)+  , make_dep_flag defGhcFlag "ddump-json"+        (setDumpFlag Opt_D_dump_json)+        "Use `-fdiagnostics-as-json` instead"+  , make_ord_flag defGhcFlag "dppr-debug"+        (setDumpFlag Opt_D_ppr_debug)+  , make_ord_flag defGhcFlag "ddebug-output"+        (noArg (flip dopt_unset Opt_D_no_debug_output))+  , make_ord_flag defGhcFlag "dno-debug-output"+        (setDumpFlag Opt_D_no_debug_output)+  , make_ord_flag defGhcFlag "ddump-faststrings"+        (setDumpFlag Opt_D_dump_faststrings)++        ------ Machine dependent (-m<blah>) stuff ---------------------------++  , make_ord_flag defGhcFlag "msse"         (noArg (\d ->+                                                  d { sseVersion = Just SSE1 }))+  , make_ord_flag defGhcFlag "msse2"        (noArg (\d ->+                                                  d { sseVersion = Just SSE2 }))+  , make_ord_flag defGhcFlag "msse3"        (noArg (\d ->+                                                  d { sseVersion = Just SSE3 }))+  , make_ord_flag defGhcFlag "mssse3"       (noArg (\d ->+                                                  d { sseVersion = Just SSSE3 }))+  , make_ord_flag defGhcFlag "msse4"        (noArg (\d ->+                                                  d { sseVersion = Just SSE4 }))+  , make_ord_flag defGhcFlag "msse4.2"      (noArg (\d ->+                                                 d { sseVersion = Just SSE42 }))+  , make_ord_flag defGhcFlag "mbmi"         (noArg (\d ->+                                                 d { bmiVersion = Just BMI1 }))+  , make_ord_flag defGhcFlag "mbmi2"        (noArg (\d ->+                                                 d { bmiVersion = Just BMI2 }))+  , make_ord_flag defGhcFlag "mavx"         (noArg (\d -> d { avx = True }))+  , make_ord_flag defGhcFlag "mavx2"        (noArg (\d -> d { avx2 = True }))+  , make_ord_flag defGhcFlag "mavx512cd"    (noArg (\d ->+                                                         d { avx512cd = True }))+  , make_ord_flag defGhcFlag "mavx512er"    (noArg (\d ->+                                                         d { avx512er = True }))+  , make_ord_flag defGhcFlag "mavx512f"     (noArg (\d -> d { avx512f = True }))+  , make_ord_flag defGhcFlag "mavx512pf"    (noArg (\d ->+                                                         d { avx512pf = True }))+  , make_ord_flag defGhcFlag "mfma"         (noArg (\d -> d { fma = True }))++        ------ Plugin flags ------------------------------------------------+  , make_ord_flag defGhcFlag "fplugin-opt" (hasArg addPluginModuleNameOption)+  , make_ord_flag defGhcFlag "fplugin-trustworthy"+      (NoArg (setGeneralFlag Opt_PluginTrustworthy))+  , make_ord_flag defGhcFlag "fplugin"     (hasArg addPluginModuleName)+  , make_ord_flag defGhcFlag "fclear-plugins" (noArg clearPluginModuleNames)+  , make_ord_flag defGhcFlag "ffrontend-opt" (hasArg addFrontendPluginOption)++  , make_ord_flag defGhcFlag "fplugin-library" (hasArg addExternalPlugin)++        ------ Optimisation flags ------------------------------------------+  , make_dep_flag defGhcFlag "Onot"   (noArgM $ setOptLevel 0 )+                                                            "Use -O0 instead"+  , make_ord_flag defGhcFlag "O"      (optIntSuffixM (\mb_n ->+                                                setOptLevel (mb_n `orElse` 1)))+                -- If the number is missing, use 1++  , make_ord_flag defFlag "fbinary-blob-threshold"+      (intSuffix (\n d -> d { binBlobThreshold = case fromIntegral n of+                                                    0 -> Nothing+                                                    x -> Just x}))+  , make_ord_flag defFlag "fmax-relevant-binds"+      (intSuffix (\n d -> d { maxRelevantBinds = Just n }))+  , make_ord_flag defFlag "fno-max-relevant-binds"+      (noArg (\d -> d { maxRelevantBinds = Nothing }))++  , make_ord_flag defFlag "fmax-valid-hole-fits"+      (intSuffix (\n d -> d { maxValidHoleFits = Just n }))+  , make_ord_flag defFlag "fno-max-valid-hole-fits"+      (noArg (\d -> d { maxValidHoleFits = Nothing }))+  , make_ord_flag defFlag "fmax-refinement-hole-fits"+      (intSuffix (\n d -> d { maxRefHoleFits = Just n }))+  , make_ord_flag defFlag "fno-max-refinement-hole-fits"+      (noArg (\d -> d { maxRefHoleFits = Nothing }))+  , make_ord_flag defFlag "frefinement-level-hole-fits"+      (intSuffix (\n d -> d { refLevelHoleFits = Just n }))+  , make_ord_flag defFlag "fno-refinement-level-hole-fits"+      (noArg (\d -> d { refLevelHoleFits = Nothing }))++  , make_ord_flag defFlag "fwrite-if-compression"+      (intSuffix (\n d -> d { ifCompression = n }))++  , make_dep_flag defGhcFlag "fllvm-pass-vectors-in-regs"+            (noArg id)+            "vectors registers are now passed in registers by default."+  , make_ord_flag defFlag "fmax-uncovered-patterns"+      (intSuffix (\n d -> d { maxUncoveredPatterns = n }))+  , make_ord_flag defFlag "fmax-pmcheck-models"+      (intSuffix (\n d -> d { maxPmCheckModels = n }))+  , make_ord_flag defFlag "fsimplifier-phases"+      (intSuffix (\n d -> d { simplPhases = n }))+  , make_ord_flag defFlag "fmax-simplifier-iterations"+      (intSuffix (\n d -> d { maxSimplIterations = n }))+  , (Deprecated, defFlag "fmax-pmcheck-iterations"+      (intSuffixM (\_ d ->+       do { deprecate $ "use -fmax-pmcheck-models instead"+          ; return d })))+  , make_ord_flag defFlag "fsimpl-tick-factor"+      (intSuffix (\n d -> d { simplTickFactor = n }))+  , make_ord_flag defFlag "fdmd-unbox-width"+      (intSuffix (\n d -> d { dmdUnboxWidth = n }))+  , make_ord_flag defFlag "fspec-constr-threshold"+      (intSuffix (\n d -> d { specConstrThreshold = Just n }))+  , make_ord_flag defFlag "fno-spec-constr-threshold"+      (noArg (\d -> d { specConstrThreshold = Nothing }))+  , make_ord_flag defFlag "fspec-constr-count"+      (intSuffix (\n d -> d { specConstrCount = Just n }))+  , make_ord_flag defFlag "fno-spec-constr-count"+      (noArg (\d -> d { specConstrCount = Nothing }))+  , make_ord_flag defFlag "fspec-constr-recursive"+      (intSuffix (\n d -> d { specConstrRecursive = n }))+  , make_ord_flag defFlag "fliberate-case-threshold"+      (intSuffix (\n d -> d { liberateCaseThreshold = Just n }))+  , make_ord_flag defFlag "fno-liberate-case-threshold"+      (noArg (\d -> d { liberateCaseThreshold = Nothing }))+  , make_ord_flag defFlag "drule-check"+      (sepArg (\s d -> d { ruleCheck = Just s }))+  , make_ord_flag defFlag "dinline-check"+      (sepArg (\s d -> d { unfoldingOpts = updateReportPrefix (Just s) (unfoldingOpts d)}))+  , make_ord_flag defFlag "freduction-depth"+      (intSuffix (\n d -> d { reductionDepth = treatZeroAsInf n }))+  , make_ord_flag defFlag "fconstraint-solver-iterations"+      (intSuffix (\n d -> d { solverIterations = treatZeroAsInf n }))+  , make_ord_flag defFlag "fgivens-expansion-fuel"+      (intSuffix (\n d -> d { givensFuel = n }))+  , make_ord_flag defFlag "fwanteds-expansion-fuel"+      (intSuffix (\n d -> d { wantedsFuel = n }))+  , make_ord_flag defFlag "fqcs-expansion-fuel"+      (intSuffix (\n d -> d { qcsFuel = n }))+  , (Deprecated, defFlag "fcontext-stack"+      (intSuffixM (\n d ->+       do { deprecate $ "use -freduction-depth=" ++ show n ++ " instead"+          ; return $ d { reductionDepth = treatZeroAsInf n } })))+  , (Deprecated, defFlag "ftype-function-depth"+      (intSuffixM (\n d ->+       do { deprecate $ "use -freduction-depth=" ++ show n ++ " instead"+          ; return $ d { reductionDepth = treatZeroAsInf n } })))+  , make_ord_flag defFlag "fstrictness-before"+      (intSuffix (\n d -> d { strictnessBefore = n : strictnessBefore d }))+  , make_ord_flag defFlag "ffloat-lam-args"+      (intSuffix (\n d -> d { floatLamArgs = Just n }))+  , make_ord_flag defFlag "ffloat-all-lams"+      (noArg (\d -> d { floatLamArgs = Nothing }))+  , make_ord_flag defFlag "fstg-lift-lams-rec-args"+      (intSuffix (\n d -> d { liftLamsRecArgs = Just n }))+  , make_ord_flag defFlag "fstg-lift-lams-rec-args-any"+      (noArg (\d -> d { liftLamsRecArgs = Nothing }))+  , make_ord_flag defFlag "fstg-lift-lams-non-rec-args"+      (intSuffix (\n d -> d { liftLamsNonRecArgs = Just n }))+  , make_ord_flag defFlag "fstg-lift-lams-non-rec-args-any"+      (noArg (\d -> d { liftLamsNonRecArgs = Nothing }))+  , make_ord_flag defFlag "fstg-lift-lams-known"+      (noArg (\d -> d { liftLamsKnown = True }))+  , make_ord_flag defFlag "fno-stg-lift-lams-known"+      (noArg (\d -> d { liftLamsKnown = False }))+  , make_ord_flag defFlag "fproc-alignment"+      (intSuffix (\n d -> d { cmmProcAlignment = Just n }))+  , make_ord_flag defFlag "fblock-layout-weights"+        (HasArg (\s ->+            upd (\d -> d { cfgWeights =+                parseWeights s (cfgWeights d)})))+  , make_ord_flag defFlag "fhistory-size"+      (intSuffix (\n d -> d { historySize = n }))++  , make_ord_flag defFlag "funfolding-creation-threshold"+      (intSuffix   (\n d -> d { unfoldingOpts = updateCreationThreshold n (unfoldingOpts d)}))+  , make_ord_flag defFlag "funfolding-use-threshold"+      (intSuffix   (\n d -> d { unfoldingOpts = updateUseThreshold n (unfoldingOpts d)}))+  , make_ord_flag defFlag "funfolding-fun-discount"+      (intSuffix   (\n d -> d { unfoldingOpts = updateFunAppDiscount n (unfoldingOpts d)}))+  , make_ord_flag defFlag "funfolding-dict-discount"+      (intSuffix   (\n d -> d { unfoldingOpts = updateDictDiscount n (unfoldingOpts d)}))++  , make_ord_flag defFlag "funfolding-case-threshold"+      (intSuffix   (\n d -> d { unfoldingOpts = updateCaseThreshold n (unfoldingOpts d)}))+  , make_ord_flag defFlag "funfolding-case-scaling"+      (intSuffix   (\n d -> d { unfoldingOpts = updateCaseScaling n (unfoldingOpts d)}))++  , make_dep_flag defFlag "funfolding-keeness-factor"+      (floatSuffix (\_ d -> d))+      "-funfolding-keeness-factor is no longer respected as of GHC 9.0"++  , make_ord_flag defFlag "fmax-worker-args"+      (intSuffix (\n d -> d {maxWorkerArgs = n}))+  , make_ord_flag defFlag "fmax-forced-spec-args"+      (intSuffix (\n d -> d {maxForcedSpecArgs = n}))+  , make_ord_flag defGhciFlag "fghci-hist-size"+      (intSuffix (\n d -> d {ghciHistSize = n}))++  -- wasm ghci browser mode+  , make_ord_flag defGhciFlag "fghci-browser-host"+      $ hasArg $ \f d -> d { ghciBrowserHost = f }+  , make_ord_flag defGhciFlag "fghci-browser-port"+      $ intSuffix $ \n d -> d { ghciBrowserPort = n }+  , make_ord_flag defGhciFlag "fghci-browser-puppeteer-launch-opts"+      $ hasArg $ \f d -> d { ghciBrowserPuppeteerLaunchOpts = Just f }+  , make_ord_flag defGhciFlag "fghci-browser-playwright-browser-type"+      $ hasArg $ \f d -> d { ghciBrowserPlaywrightBrowserType = Just f }+  , make_ord_flag defGhciFlag "fghci-browser-playwright-launch-opts"+      $ hasArg $ \f d -> d { ghciBrowserPlaywrightLaunchOpts = Just f }++  , make_ord_flag defGhcFlag "fmax-inline-alloc-size"+      (intSuffix (\n d -> d { maxInlineAllocSize = n }))+  , make_ord_flag defGhcFlag "fmax-inline-memcpy-insns"+      (intSuffix (\n d -> d { maxInlineMemcpyInsns = n }))+  , make_ord_flag defGhcFlag "fmax-inline-memset-insns"+      (intSuffix (\n d -> d { maxInlineMemsetInsns = n }))+  , make_ord_flag defGhcFlag "dinitial-unique"+      (word64Suffix (\n d -> d { initialUnique = n }))+  , make_ord_flag defGhcFlag "dunique-increment"+      (intSuffix (\n d -> d { uniqueIncrement = n }))++        ------ Profiling ----------------------------------------------------++        -- OLD profiling flags+  , make_dep_flag defGhcFlag "auto-all"+                    (noArg (\d -> d { profAuto = ProfAutoAll } ))+                    "Use -fprof-auto instead"+  , make_dep_flag defGhcFlag "no-auto-all"+                    (noArg (\d -> d { profAuto = NoProfAuto } ))+                    "Use -fno-prof-auto instead"+  , make_dep_flag defGhcFlag "auto"+                    (noArg (\d -> d { profAuto = ProfAutoExports } ))+                    "Use -fprof-auto-exported instead"+  , make_dep_flag defGhcFlag "no-auto"+            (noArg (\d -> d { profAuto = NoProfAuto } ))+                    "Use -fno-prof-auto instead"+  , make_dep_flag defGhcFlag "caf-all"+            (NoArg (setGeneralFlag Opt_AutoSccsOnIndividualCafs))+                    "Use -fprof-cafs instead"+  , make_dep_flag defGhcFlag "no-caf-all"+            (NoArg (unSetGeneralFlag Opt_AutoSccsOnIndividualCafs))+                    "Use -fno-prof-cafs instead"++        -- NEW profiling flags+  , make_ord_flag defGhcFlag "fprof-auto"+      (noArg (\d -> d { profAuto = ProfAutoAll } ))+  , make_ord_flag defGhcFlag "fprof-auto-top"+      (noArg (\d -> d { profAuto = ProfAutoTop } ))+  , make_ord_flag defGhcFlag "fprof-auto-exported"+      (noArg (\d -> d { profAuto = ProfAutoExports } ))+  , make_ord_flag defGhcFlag "fprof-auto-calls"+      (noArg (\d -> d { profAuto = ProfAutoCalls } ))+  , make_ord_flag defGhcFlag "fno-prof-auto"+      (noArg (\d -> d { profAuto = NoProfAuto } ))++        -- Caller-CC+  , make_ord_flag defGhcFlag "fprof-callers"+         (HasArg setCallerCcFilters)+        ------ Compiler flags -----------------------------------------------++  , make_ord_flag defGhcFlag "fasm"             (NoArg (setObjBackend ncgBackend))+  , make_ord_flag defGhcFlag "fvia-c"           (NoArg+         (deprecate $ "The -fvia-c flag does nothing; " +++                      "it will be removed in a future GHC release"))+  , make_ord_flag defGhcFlag "fvia-C"           (NoArg+         (deprecate $ "The -fvia-C flag does nothing; " +++                      "it will be removed in a future GHC release"))+  , make_ord_flag defGhcFlag "fllvm"            (NoArg (setObjBackend llvmBackend))++  , make_ord_flag defFlag "fno-code"         (NoArg ((upd $ \d ->+                  d { ghcLink=NoLink }) >> setBackend noBackend))+  , make_ord_flag defFlag "fbyte-code"+      (noArgM $ \dflags -> do+        setBackend interpreterBackend+        pure $ flip gopt_unset Opt_ByteCodeAndObjectCode (gopt_set dflags Opt_ByteCode))+  , make_ord_flag defFlag "fobject-code"     $ noArgM $ \dflags -> do+      setBackend $ platformDefaultBackend (targetPlatform dflags)+      dflags' <- liftEwM getCmdLineState+      pure $ gopt_unset dflags' Opt_ByteCodeAndObjectCode++  , make_dep_flag defFlag "fglasgow-exts"+      (NoArg enableGlasgowExts) "Use individual extensions instead"+  , make_dep_flag defFlag "fno-glasgow-exts"+      (NoArg disableGlasgowExts) "Use individual extensions instead"++        ------ Safe Haskell flags -------------------------------------------+  , make_ord_flag defFlag "fpackage-trust"   (NoArg setPackageTrust)+  , make_ord_flag defFlag "fno-safe-infer"   (noArg (\d ->+                                                    d { safeInfer = False }))+  , make_ord_flag defFlag "fno-safe-haskell" (NoArg (setSafeHaskell Sf_Ignore))++        ------ position independent flags  ----------------------------------+  , make_ord_flag defGhcFlag "fPIC"          (NoArg (setGeneralFlag Opt_PIC))+  , make_ord_flag defGhcFlag "fno-PIC"       (NoArg (unSetGeneralFlag Opt_PIC))+  , make_ord_flag defGhcFlag "fPIE"          (NoArg (setGeneralFlag Opt_PIE))+  , make_ord_flag defGhcFlag "fno-PIE"       (NoArg (unSetGeneralFlag Opt_PIE))++         ------ Debugging flags ----------------------------------------------+  , make_ord_flag defGhcFlag "g"             (OptIntSuffix setDebugLevel)+ ]+ ++ map (mkFlag turnOn  ""          setGeneralFlag    ) negatableFlagsDeps+ ++ map (mkFlag turnOff "no-"       unSetGeneralFlag  ) negatableFlagsDeps+ ++ map (mkFlag turnOn  "d"         setGeneralFlag    ) dFlagsDeps+ ++ map (mkFlag turnOff "dno-"      unSetGeneralFlag  ) dFlagsDeps+ ++ map (mkFlag turnOn  "f"         setGeneralFlag    ) fFlagsDeps+ ++ map (mkFlag turnOff "fno-"      unSetGeneralFlag  ) fFlagsDeps+ ++++        ------ Warning flags -------------------------------------------------+  [ make_ord_flag defFlag "W"       (NoArg (setWarningGroup W_extra))+  , make_ord_flag defFlag "Werror"+               (NoArg (do { setGeneralFlag Opt_WarnIsError+                          ; setFatalWarningGroup W_everything }))+  , make_ord_flag defFlag "Wwarn"+               (NoArg (do { unSetGeneralFlag Opt_WarnIsError+                          ; unSetFatalWarningGroup W_everything }))+                          -- Opt_WarnIsError is still needed to pass -Werror+                          -- to CPP; see runCpp in SysTools+  , make_dep_flag defFlag "Wnot"    (NoArg (unSetWarningGroup W_everything))+                                             "Use -w or -Wno-everything instead"+  , make_ord_flag defFlag "w"       (NoArg (unSetWarningGroup W_everything))+  ]++     -- New-style uniform warning sets+     --+     -- Note that -Weverything > -Wall > -Wextra > -Wdefault > -Wno-everything+ ++ warningControls setWarningGroup unSetWarningGroup setWErrorWarningGroup unSetFatalWarningGroup warningGroupsDeps+ ++ warningControls setWarningFlag unSetWarningFlag setWErrorFlag unSetFatalWarningFlag wWarningFlagsDeps+ ++ warningControls setCustomWarningFlag unSetCustomWarningFlag setCustomWErrorFlag unSetCustomFatalWarningFlag+      [(NotDeprecated, FlagSpec "warnings-deprecations" defaultWarningCategory nop AllModes)]+      -- See Note [Warning categories] in GHC.Unit.Module.Warnings.++ ++ [ (NotDeprecated, customOrUnrecognisedWarning "Wno-"       unSetCustomWarningFlag)+    , (NotDeprecated, customOrUnrecognisedWarning "Werror="    setCustomWErrorFlag)+    , (NotDeprecated, customOrUnrecognisedWarning "Wwarn="     unSetCustomFatalWarningFlag)+    , (NotDeprecated, customOrUnrecognisedWarning "Wno-error=" unSetCustomFatalWarningFlag)+    , (NotDeprecated, customOrUnrecognisedWarning "W"          setCustomWarningFlag)+    , (Deprecated,    customOrUnrecognisedWarning "fwarn-"     setCustomWarningFlag)+    , (Deprecated,    customOrUnrecognisedWarning "fno-warn-"  unSetCustomWarningFlag)+    ]++     ------ JavaScript flags -----------------------------------------------+ ++ [ make_ord_flag defFlag "ddisable-js-minifier" (NoArg (setGeneralFlag Opt_DisableJsMinifier))+    , make_ord_flag defFlag "ddisable-js-c-sources" (NoArg (setGeneralFlag Opt_DisableJsCsources))+    ]++     ------ Language flags -------------------------------------------------+ ++ map (mkFlag turnOn  "f"         setExtensionFlag  ) fLangFlagsDeps+ ++ map (mkFlag turnOff "fno-"      unSetExtensionFlag) fLangFlagsDeps+ ++ map (mkFlag turnOn  "X"         setExtensionFlag  ) xFlagsDeps+ ++ map (mkFlag turnOff "XNo"       unSetExtensionFlag) xFlagsDeps+ ++ map (mkFlag turnOn  "X"         setLanguage       ) languageFlagsDeps+ ++ map (mkFlag turnOn  "X"         setSafeHaskell    ) safeHaskellFlagsDeps++-- | Warnings have both new-style flags to control their state (@-W@, @-Wno-@,+-- @-Werror=@, @-Wwarn=@) and old-style flags (@-fwarn-@, @-fno-warn-@).  We+-- define these uniformly for individual warning flags and groups of warnings.+warningControls :: (warn_flag -> DynP ()) -- ^ Set the warning+                -> (warn_flag -> DynP ()) -- ^ Unset the warning+                -> (warn_flag -> DynP ()) -- ^ Make the warning an error+                -> (warn_flag -> DynP ()) -- ^ Clear the error status+                -> [(Deprecation, FlagSpec warn_flag)]+                -> [(Deprecation, Flag (CmdLineP DynFlags))]+warningControls set unset set_werror unset_fatal xs =+    map (mkFlag turnOn  "W"          set             ) xs+ ++ map (mkFlag turnOff "Wno-"       unset           ) xs+ ++ map (mkFlag turnOn  "Werror="    set_werror      ) xs+ ++ map (mkFlag turnOn  "Wwarn="     unset_fatal     ) xs+ ++ map (mkFlag turnOn  "Wno-error=" unset_fatal     ) xs+ ++ map (mkFlag turnOn  "fwarn-"     set   . hideFlag) xs+ ++ map (mkFlag turnOff "fno-warn-"  unset . hideFlag) xs++-- | This is where we handle unrecognised warning flags. If the flag is valid as+-- an extended warning category, we call the supplied action. Otherwise, issue a+-- warning if -Wunrecognised-warning-flags is set. See #11429 for context.+-- See Note [Warning categories] in GHC.Unit.Module.Warnings.+customOrUnrecognisedWarning :: String -> (WarningCategory -> DynP ()) -> Flag (CmdLineP DynFlags)+customOrUnrecognisedWarning prefix custom = defHiddenFlag prefix (Prefix action)+  where+    action :: String -> DynP ()+    action flag+      | validWarningCategory cat = custom cat+      | otherwise = unrecognised flag+      where+        cat = mkWarningCategory (mkFastString flag)++    unrecognised flag = do+      -- #23402 and #12056+      -- for unrecognised flags we consider current dynflags, not the final one.+      -- But if final state says to not report unrecognised flags, they won't anyway.+      f <- wopt Opt_WarnUnrecognisedWarningFlags <$> liftEwM getCmdLineState+      when f $ addFlagWarn (DriverUnrecognisedFlag (prefix ++ flag))++-- See Note [Supporting CLI completion]+package_flags_deps :: [(Deprecation, Flag (CmdLineP DynFlags))]+package_flags_deps = [+        ------- Packages ----------------------------------------------------+    make_ord_flag defFlag "package-db"+      (HasArg (addPkgDbRef . PkgDbPath))+  , make_ord_flag defFlag "clear-package-db"      (NoArg clearPkgDb)+  , make_ord_flag defFlag "no-global-package-db"  (NoArg removeGlobalPkgDb)+  , make_ord_flag defFlag "no-user-package-db"    (NoArg removeUserPkgDb)+  , make_ord_flag defFlag "global-package-db"+      (NoArg (addPkgDbRef GlobalPkgDb))+  , make_ord_flag defFlag "user-package-db"+      (NoArg (addPkgDbRef UserPkgDb))+    -- backwards compat with GHC<=7.4 :+  , make_dep_flag defFlag "package-conf"+      (HasArg $ addPkgDbRef . PkgDbPath) "Use -package-db instead"+  , make_dep_flag defFlag "no-user-package-conf"+      (NoArg removeUserPkgDb)              "Use -no-user-package-db instead"+  , make_ord_flag defGhcFlag "package-name"       (HasArg $ \name ->+                                      upd (setUnitId name))+  , make_ord_flag defGhcFlag "this-unit-id"       (hasArg setUnitId)++  , make_ord_flag defGhcFlag "working-dir"       (hasArg setWorkingDirectory)+  , make_ord_flag defGhcFlag "this-package-name"  (hasArg setPackageName)+  , make_ord_flag defGhcFlag "hidden-module"      (HasArg addHiddenModule)+  , make_ord_flag defGhcFlag "reexported-module"  (HasArg addReexportedModule)++  , make_ord_flag defFlag "package"               (HasArg exposePackage)+  , make_ord_flag defFlag "plugin-package-id"     (HasArg exposePluginPackageId)+  , make_ord_flag defFlag "plugin-package"        (HasArg exposePluginPackage)+  , make_ord_flag defFlag "package-id"            (HasArg exposePackageId)+  , make_ord_flag defFlag "hide-package"          (HasArg hidePackage)+  , make_ord_flag defFlag "hide-all-packages"+      (NoArg (setGeneralFlag Opt_HideAllPackages))+  , make_ord_flag defFlag "hide-all-plugin-packages"+      (NoArg (setGeneralFlag Opt_HideAllPluginPackages))+  , make_ord_flag defFlag "package-env"           (HasArg setPackageEnv)+  , make_ord_flag defFlag "ignore-package"        (HasArg ignorePackage)+  , make_dep_flag defFlag "syslib" (HasArg exposePackage) "Use -package instead"+  , make_ord_flag defFlag "distrust-all-packages"+      (NoArg (setGeneralFlag Opt_DistrustAllPackages))+  , make_ord_flag defFlag "trust"                 (HasArg trustPackage)+  , make_ord_flag defFlag "distrust"              (HasArg distrustPackage)+  , make_ord_flag defFlag "base-unit-id"          (HasArg setBaseUnitId)+  ]+  where+    setPackageEnv env = upd $ \s -> s { packageEnv = Just env }++-- | Make a list of flags for shell completion.+-- Filter all available flags into two groups, for interactive GHC vs all other.+flagsForCompletion :: Bool -> [String]+flagsForCompletion isInteractive+    = [ '-':flagName flag+      | flag <- flagsAll+      , modeFilter (flagGhcMode flag)+      ]+    where+      modeFilter AllModes = True+      modeFilter OnlyGhci = isInteractive+      modeFilter OnlyGhc = not isInteractive+      modeFilter HiddenFlag = False++data FlagSpec flag+   = FlagSpec+       { flagSpecName :: String   -- ^ Flag in string form+       , flagSpecFlag :: flag     -- ^ Flag in internal form+       , flagSpecAction :: (TurnOnFlag -> DynP ())+           -- ^ Extra action to run when the flag is found+           -- Typically, emit a warning or error+       , flagSpecGhcMode :: GhcFlagMode+           -- ^ In which ghc mode the flag has effect+       }++-- | Define a new flag.+flagSpec :: String -> flag -> (Deprecation, FlagSpec flag)+flagSpec name flag = flagSpec' name flag nop++-- | Define a new flag with an effect.+flagSpec' :: String -> flag -> (TurnOnFlag -> DynP ())+          -> (Deprecation, FlagSpec flag)+flagSpec' name flag act = (NotDeprecated, FlagSpec name flag act AllModes)++-- | Define a warning flag.+warnSpec :: WarningFlag -> [(Deprecation, FlagSpec WarningFlag)]+warnSpec flag = warnSpec' flag nop++-- | Define a warning flag with an effect.+warnSpec' :: WarningFlag -> (TurnOnFlag -> DynP ())+          -> [(Deprecation, FlagSpec WarningFlag)]+warnSpec' flag act = [ (NotDeprecated, FlagSpec name flag act AllModes)+                     | name <- NE.toList (warnFlagNames flag)+                     ]++-- | Define a new deprecated flag with an effect.+depFlagSpecOp :: String -> flag -> (TurnOnFlag -> DynP ()) -> String+            -> (Deprecation, FlagSpec flag)+depFlagSpecOp name flag act dep =+    (Deprecated, snd (flagSpec' name flag (\f -> act f >> deprecate dep)))++-- | Define a new deprecated flag.+depFlagSpec :: String -> flag -> String+            -> (Deprecation, FlagSpec flag)+depFlagSpec name flag dep = depFlagSpecOp name flag nop dep++-- | Define a deprecated warning flag.+depWarnSpec :: WarningFlag -> String+            -> [(Deprecation, FlagSpec WarningFlag)]+depWarnSpec flag dep = [ depFlagSpecOp name flag nop dep+                       | name <- NE.toList (warnFlagNames flag)+                       ]++-- | Define a deprecated warning name substituted by another.+subWarnSpec :: String -> WarningFlag -> String+            -> [(Deprecation, FlagSpec WarningFlag)]+subWarnSpec oldname flag dep = [ depFlagSpecOp oldname flag nop dep ]+++-- | Define a new deprecated flag with an effect where the deprecation message+-- depends on the flag value+depFlagSpecOp' :: String+             -> flag+             -> (TurnOnFlag -> DynP ())+             -> (TurnOnFlag -> String)+             -> (Deprecation, FlagSpec flag)+depFlagSpecOp' name flag act dep =+    (Deprecated, FlagSpec name flag (\f -> act f >> (deprecate $ dep f))+                                                                       AllModes)++-- | Define a new deprecated flag where the deprecation message+-- depends on the flag value+depFlagSpec' :: String+             -> flag+             -> (TurnOnFlag -> String)+             -> (Deprecation, FlagSpec flag)+depFlagSpec' name flag dep = depFlagSpecOp' name flag nop dep++-- | Define a new flag for GHCi.+flagGhciSpec :: String -> flag -> (Deprecation, FlagSpec flag)+flagGhciSpec name flag = flagGhciSpec' name flag nop++-- | Define a new flag for GHCi with an effect.+flagGhciSpec' :: String -> flag -> (TurnOnFlag -> DynP ())+              -> (Deprecation, FlagSpec flag)+flagGhciSpec' name flag act = (NotDeprecated, FlagSpec name flag act OnlyGhci)++-- | Define a new flag invisible to CLI completion.+flagHiddenSpec :: String -> flag -> (Deprecation, FlagSpec flag)+flagHiddenSpec name flag = flagHiddenSpec' name flag nop++-- | Define a new flag invisible to CLI completion with an effect.+flagHiddenSpec' :: String -> flag -> (TurnOnFlag -> DynP ())+                -> (Deprecation, FlagSpec flag)+flagHiddenSpec' name flag act = (NotDeprecated, FlagSpec name flag act+                                                                     HiddenFlag)++-- | Hide a 'FlagSpec' from being displayed in @--show-options@.+--+-- This is for example useful for flags that are obsolete, but should not+-- (yet) be deprecated for compatibility reasons.+hideFlag :: (Deprecation, FlagSpec a) -> (Deprecation, FlagSpec a)+hideFlag (dep, fs) = (dep, fs { flagSpecGhcMode = HiddenFlag })++mkFlag :: TurnOnFlag            -- ^ True <=> it should be turned on+       -> String                -- ^ The flag prefix+       -> (flag -> DynP ())     -- ^ What to do when the flag is found+       -> (Deprecation, FlagSpec flag)  -- ^ Specification of+                                        -- this particular flag+       -> (Deprecation, Flag (CmdLineP DynFlags))+mkFlag turn_on flagPrefix f (dep, (FlagSpec name flag extra_action mode))+    = (dep,+       Flag (flagPrefix ++ name) (NoArg (f flag >> extra_action turn_on)) mode)++deprecate :: String -> DynP ()+deprecate s = do+    arg <- getArg+    addFlagWarn (DriverDeprecatedFlag arg s)++deprecatedForExtension :: String -> TurnOnFlag -> String+deprecatedForExtension lang turn_on+    = "use -X" ++ flag +++      " or pragma {-# LANGUAGE " ++ flag ++ " #-} instead"+    where+      flag | turn_on   = lang+           | otherwise = "No" ++ lang++deprecatedForExtensions :: [String] -> TurnOnFlag -> String+deprecatedForExtensions [] _ = panic "new extension has not been specified"+deprecatedForExtensions [lang] turn_on = deprecatedForExtension lang turn_on+deprecatedForExtensions langExts turn_on+    = "use " ++ xExt flags ++ " instead"+    where+      flags | turn_on = langExts+            | otherwise = ("No" ++) <$> langExts++      xExt fls = intercalate " and "  $ (\flag -> "-X" ++ flag) <$> fls++useInstead :: String -> String -> TurnOnFlag -> String+useInstead prefix flag turn_on+  = "Use " ++ prefix ++ no ++ flag ++ " instead"+  where+    no = if turn_on then "" else "no-"++nop :: TurnOnFlag -> DynP ()+nop _ = return ()++-- | Find the 'FlagSpec' for a 'WarningFlag'.+flagSpecOf :: WarningFlag -> Maybe (FlagSpec WarningFlag)+flagSpecOf = flip Map.lookup wWarningFlagMap++wWarningFlagMap :: Map.Map WarningFlag (FlagSpec WarningFlag)+wWarningFlagMap = Map.fromListWith (\_ x -> x) $ map (flagSpecFlag &&& id) wWarningFlags++-- | These @-W\<blah\>@ flags can all be reversed with @-Wno-\<blah\>@+wWarningFlags :: [FlagSpec WarningFlag]+wWarningFlags = map snd (sortBy (comparing fst) wWarningFlagsDeps)++wWarningFlagsDeps :: [(Deprecation, FlagSpec WarningFlag)]+wWarningFlagsDeps = [minBound..maxBound] >>= \x -> case x of+-- See Note [Updating flag description in the User's Guide]+-- See Note [Supporting CLI completion]+  Opt_WarnAlternativeLayoutRuleTransitional -> warnSpec x+  Opt_WarnAmbiguousFields -> warnSpec x+  Opt_WarnAutoOrphans -> depWarnSpec x "it has no effect"+  Opt_WarnCPPUndef -> warnSpec x+  Opt_WarnBadlyLevelledTypes ->+    warnSpec x +++    subWarnSpec "badly-staged-types" x "it is renamed to -Wbadly-levelled-types"+  Opt_WarnUnbangedStrictPatterns -> warnSpec x+  Opt_WarnDeferredTypeErrors -> warnSpec x+  Opt_WarnDeferredOutOfScopeVariables -> warnSpec x+  Opt_WarnDeprecatedFlags -> warnSpec x+  Opt_WarnDerivingDefaults -> warnSpec x+  Opt_WarnDerivingTypeable -> warnSpec x+  Opt_WarnDodgyExports -> warnSpec x+  Opt_WarnDodgyForeignImports -> warnSpec x+  Opt_WarnDodgyImports -> warnSpec x+  Opt_WarnEmptyEnumerations -> warnSpec x+  Opt_WarnDuplicateConstraints+    -> subWarnSpec "duplicate-constraints" x "it is subsumed by -Wredundant-constraints"+  Opt_WarnRedundantConstraints -> warnSpec x+  Opt_WarnDuplicateExports -> warnSpec x+  Opt_WarnHiShadows+    -> depWarnSpec x "it is not used, and was never implemented"+  Opt_WarnInaccessibleCode -> warnSpec x+  Opt_WarnImplicitPrelude -> warnSpec x+  Opt_WarnImplicitKindVars -> depWarnSpec x "it is now an error"+  Opt_WarnIncompletePatterns -> warnSpec x+  Opt_WarnIncompletePatternsRecUpd -> warnSpec x+  Opt_WarnIncompleteUniPatterns -> warnSpec x+  Opt_WarnInconsistentFlags -> warnSpec x+  Opt_WarnInlineRuleShadowing -> warnSpec x+  Opt_WarnIdentities -> warnSpec x+  Opt_WarnLoopySuperclassSolve -> depWarnSpec x "it is now an error"+  Opt_WarnMissingFields -> warnSpec x+  Opt_WarnMissingImportList -> warnSpec x+  Opt_WarnMissingExportList -> warnSpec x+  Opt_WarnMissingLocalSignatures+    -> subWarnSpec "missing-local-sigs" x+                   "it is replaced by -Wmissing-local-signatures"+       ++ warnSpec x+  Opt_WarnMissingMethods -> warnSpec x+  Opt_WarnMissingMonadFailInstances+    -> depWarnSpec x "fail is no longer a method of Monad"+  Opt_WarnSemigroup -> depWarnSpec x "Semigroup is now a superclass of Monoid"+  Opt_WarnMissingSignatures -> warnSpec x+  Opt_WarnMissingKindSignatures -> warnSpec x+  Opt_WarnMissingPolyKindSignatures -> warnSpec x+  Opt_WarnMissingExportedSignatures+    -> subWarnSpec "missing-exported-sigs" x+                   "it is replaced by -Wmissing-exported-signatures"+       ++ warnSpec x+  Opt_WarnMonomorphism -> warnSpec x+  Opt_WarnNameShadowing -> warnSpec x+  Opt_WarnNonCanonicalMonadInstances -> warnSpec x+  Opt_WarnNonCanonicalMonadFailInstances+    -> depWarnSpec x "fail is no longer a method of Monad"+  Opt_WarnNonCanonicalMonoidInstances -> warnSpec x+  Opt_WarnOrphans -> warnSpec x+  Opt_WarnOverflowedLiterals -> warnSpec x+  Opt_WarnOverlappingPatterns -> warnSpec x+  Opt_WarnMissedSpecs -> warnSpec x+  Opt_WarnAllMissedSpecs -> warnSpec x+  Opt_WarnSafe -> warnSpec' x setWarnSafe+  Opt_WarnTrustworthySafe -> warnSpec x+  Opt_WarnInferredSafeImports -> warnSpec x+  Opt_WarnMissingSafeHaskellMode -> warnSpec x+  Opt_WarnTabs -> warnSpec x+  Opt_WarnTypeDefaults -> warnSpec x+  Opt_WarnTypedHoles -> warnSpec x+  Opt_WarnPartialTypeSignatures -> warnSpec x+  Opt_WarnUnrecognisedPragmas -> warnSpec x+  Opt_WarnMisplacedPragmas -> warnSpec x+  Opt_WarnUnsafe -> warnSpec' x setWarnUnsafe+  Opt_WarnUnsupportedCallingConventions -> warnSpec x+  Opt_WarnUnsupportedLlvmVersion -> warnSpec x+  Opt_WarnMissedExtraSharedLib -> warnSpec x+  Opt_WarnUntickedPromotedConstructors -> warnSpec x+  Opt_WarnUnusedDoBind -> warnSpec x+  Opt_WarnUnusedForalls -> warnSpec x+  Opt_WarnUnusedImports -> warnSpec x+  Opt_WarnUnusedLocalBinds -> warnSpec x+  Opt_WarnUnusedMatches -> warnSpec x+  Opt_WarnUnusedPatternBinds -> warnSpec x+  Opt_WarnUnusedTopBinds -> warnSpec x+  Opt_WarnUnusedTypePatterns -> warnSpec x+  Opt_WarnUnusedRecordWildcards -> warnSpec x+  Opt_WarnRedundantBangPatterns -> warnSpec x+  Opt_WarnRedundantRecordWildcards -> warnSpec x+  Opt_WarnRedundantStrictnessFlags -> warnSpec x+  Opt_WarnWrongDoBind -> warnSpec x+  Opt_WarnMissingPatternSynonymSignatures -> warnSpec x+  Opt_WarnMissingDerivingStrategies -> warnSpec x+  Opt_WarnSimplifiableClassConstraints -> warnSpec x+  Opt_WarnMissingHomeModules -> warnSpec x+  Opt_WarnUnrecognisedWarningFlags -> warnSpec x+  Opt_WarnStarBinder -> warnSpec x+  Opt_WarnStarIsType -> warnSpec x+  Opt_WarnSpaceAfterBang+    -> depWarnSpec x "bang patterns can no longer be written with a space"+  Opt_WarnPartialFields -> warnSpec x+  Opt_WarnPrepositiveQualifiedModule -> warnSpec x+  Opt_WarnUnusedPackages -> warnSpec x+  Opt_WarnCompatUnqualifiedImports ->+    depWarnSpec x "This warning no longer does anything; see GHC #24904"+  Opt_WarnInvalidHaddock -> warnSpec x+  Opt_WarnOperatorWhitespaceExtConflict -> warnSpec x+  Opt_WarnOperatorWhitespace -> warnSpec x+  Opt_WarnImplicitLift -> warnSpec x+  Opt_WarnMissingExportedPatternSynonymSignatures -> warnSpec x+  Opt_WarnForallIdentifier+    -> depWarnSpec x "forall is no longer a valid identifier"+  Opt_WarnUnicodeBidirectionalFormatCharacters -> warnSpec x+  Opt_WarnGADTMonoLocalBinds -> warnSpec x+  Opt_WarnTypeEqualityOutOfScope -> warnSpec x+  Opt_WarnTypeEqualityRequiresOperators -> warnSpec x+  Opt_WarnTermVariableCapture -> warnSpec x+  Opt_WarnMissingRoleAnnotations -> warnSpec x+  Opt_WarnImplicitRhsQuantification -> warnSpec x+  Opt_WarnIncompleteExportWarnings -> warnSpec x+  Opt_WarnIncompleteRecordSelectors -> warnSpec x+  Opt_WarnDataKindsTC+    -> depWarnSpec x "DataKinds violations are now always an error"+  Opt_WarnDefaultedExceptionContext -> warnSpec x+  Opt_WarnViewPatternSignatures -> warnSpec x+  Opt_WarnUselessSpecialisations -> warnSpec x+  Opt_WarnDeprecatedPragmas -> warnSpec x+  Opt_WarnRuleLhsEqualities -> warnSpec x+  Opt_WarnUnusableUnpackPragmas -> warnSpec x+  Opt_WarnPatternNamespaceSpecifier -> warnSpec x++warningGroupsDeps :: [(Deprecation, FlagSpec WarningGroup)]+warningGroupsDeps = map mk warningGroups+  where+    mk g = (NotDeprecated, FlagSpec (warningGroupName g) g nop AllModes)++-- | These @-\<blah\>@ flags can all be reversed with @-no-\<blah\>@+negatableFlagsDeps :: [(Deprecation, FlagSpec GeneralFlag)]+negatableFlagsDeps = [+  flagGhciSpec "ignore-dot-ghci"         Opt_IgnoreDotGhci ]++-- | These @-d\<blah\>@ flags can all be reversed with @-dno-\<blah\>@+dFlagsDeps :: [(Deprecation, FlagSpec GeneralFlag)]+dFlagsDeps = [+-- See Note [Updating flag description in the User's Guide]+-- See Note [Supporting CLI completion]+-- Please keep the list of flags below sorted alphabetically+  flagSpec "ppr-case-as-let"            Opt_PprCaseAsLet,+  depFlagSpec' "ppr-ticks"              Opt_PprShowTicks+     (\turn_on -> useInstead "-d" "suppress-ticks" (not turn_on)),+  flagSpec "suppress-ticks"             Opt_SuppressTicks,+  depFlagSpec' "suppress-stg-free-vars" Opt_SuppressStgExts+     (useInstead "-d" "suppress-stg-exts"),+  flagSpec "suppress-stg-exts"          Opt_SuppressStgExts,+  flagSpec "suppress-stg-reps"          Opt_SuppressStgReps,+  flagSpec "suppress-coercions"         Opt_SuppressCoercions,+  flagSpec "suppress-coercion-types"    Opt_SuppressCoercionTypes,+  flagSpec "suppress-idinfo"            Opt_SuppressIdInfo,+  flagSpec "suppress-unfoldings"        Opt_SuppressUnfoldings,+  flagSpec "suppress-module-prefixes"   Opt_SuppressModulePrefixes,+  flagSpec "suppress-timestamps"        Opt_SuppressTimestamps,+  flagSpec "suppress-type-applications" Opt_SuppressTypeApplications,+  flagSpec "suppress-type-signatures"   Opt_SuppressTypeSignatures,+  flagSpec "suppress-uniques"           Opt_SuppressUniques,+  flagSpec "suppress-var-kinds"         Opt_SuppressVarKinds,+  flagSpec "suppress-core-sizes"        Opt_SuppressCoreSizes+  ]++-- | These @-f\<blah\>@ flags can all be reversed with @-fno-\<blah\>@+fFlags :: [FlagSpec GeneralFlag]+fFlags = map snd fFlagsDeps++fFlagsDeps :: [(Deprecation, FlagSpec GeneralFlag)]+fFlagsDeps = [+-- See Note [Updating flag description in the User's Guide]+-- See Note [Supporting CLI completion]+-- Please keep the list of flags below sorted alphabetically+  flagSpec "asm-shortcutting"                 Opt_AsmShortcutting,+  flagGhciSpec "break-on-error"               Opt_BreakOnError,+  flagGhciSpec "break-on-exception"           Opt_BreakOnException,+  flagSpec "building-cabal-package"           Opt_BuildingCabalPackage,+  flagSpec "call-arity"                       Opt_CallArity,+  flagSpec "exitification"                    Opt_Exitification,+  flagSpec "case-merge"                       Opt_CaseMerge,+  flagSpec "case-folding"                     Opt_CaseFolding,+  flagSpec "cmm-elim-common-blocks"           Opt_CmmElimCommonBlocks,+  flagSpec "cmm-sink"                         Opt_CmmSink,+  flagSpec "cmm-static-pred"                  Opt_CmmStaticPred,+  flagSpec "cse"                              Opt_CSE,+  flagSpec "stg-cse"                          Opt_StgCSE,+  flagSpec "stg-lift-lams"                    Opt_StgLiftLams,+  flagSpec "cpr-anal"                         Opt_CprAnal,+  flagSpec "defer-diagnostics"                Opt_DeferDiagnostics,+  flagSpec "defer-type-errors"                Opt_DeferTypeErrors,+  flagSpec "defer-typed-holes"                Opt_DeferTypedHoles,+  flagSpec "defer-out-of-scope-variables"     Opt_DeferOutOfScopeVariables,+  flagSpec "diagnostics-show-caret"           Opt_DiagnosticsShowCaret,+  flagSpec "diagnostics-as-json"              Opt_DiagnosticsAsJSON,+  -- With-ways needs to be reversible hence why its made via flagSpec unlike+  -- other debugging flags.+  flagSpec "dump-with-ways"                   Opt_DumpWithWays,+  flagSpec "dicts-cheap"                      Opt_DictsCheap,+  flagSpec "dicts-strict"                     Opt_DictsStrict,+  depFlagSpec "dmd-tx-dict-sel"+      Opt_DmdTxDictSel "effect is now unconditionally enabled",+  flagSpec "do-eta-reduction"                 Opt_DoEtaReduction,+  flagSpec "do-lambda-eta-expansion"          Opt_DoLambdaEtaExpansion,+  flagSpec "do-clever-arg-eta-expansion"      Opt_DoCleverArgEtaExpansion, -- See Note [Eta expansion of arguments in CorePrep]+  flagSpec "eager-blackholing"                Opt_EagerBlackHoling,+  flagSpec "orig-thunk-info"                  Opt_OrigThunkInfo,+  flagSpec "embed-manifest"                   Opt_EmbedManifest,+  flagSpec "enable-rewrite-rules"             Opt_EnableRewriteRules,+  flagSpec "enable-th-splice-warnings"        Opt_EnableThSpliceWarnings,+  flagSpec "error-spans"                      Opt_ErrorSpans,+  flagSpec "excess-precision"                 Opt_ExcessPrecision,+  flagSpec "expose-all-unfoldings"            Opt_ExposeAllUnfoldings,+  flagSpec "expose-overloaded-unfoldings"     Opt_ExposeOverloadedUnfoldings,+  flagSpec "keep-auto-rules"                  Opt_KeepAutoRules,+  flagSpec "expose-internal-symbols"          Opt_ExposeInternalSymbols,+  flagSpec "external-dynamic-refs"            Opt_ExternalDynamicRefs,+  flagSpec "external-interpreter"             Opt_ExternalInterpreter,+  flagSpec "family-application-cache"         Opt_FamAppCache,+  flagSpec "float-in"                         Opt_FloatIn,+  flagSpec "force-recomp"                     Opt_ForceRecomp,+  flagSpec "ignore-optim-changes"             Opt_IgnoreOptimChanges,+  flagSpec "ignore-hpc-changes"               Opt_IgnoreHpcChanges,+  flagSpec "full-laziness"                    Opt_FullLaziness,+  depFlagSpec' "fun-to-thunk"                 Opt_FunToThunk+      (useInstead "-f" "full-laziness"),+  flagSpec "local-float-out"                  Opt_LocalFloatOut,+  flagSpec "local-float-out-top-level"        Opt_LocalFloatOutTopLevel,+  flagSpec "gen-manifest"                     Opt_GenManifest,+  flagSpec "ghci-history"                     Opt_GhciHistory,+  flagSpec "ghci-leak-check"                  Opt_GhciLeakCheck,+  flagSpec "inter-module-far-jumps"               Opt_InterModuleFarJumps,+  flagSpec "validate-ide-info"                Opt_ValidateHie,+  flagGhciSpec "local-ghci-history"           Opt_LocalGhciHistory,+  flagGhciSpec "no-it"                        Opt_NoIt,+  flagSpec "ghci-sandbox"                     Opt_GhciSandbox,++  -- wasm ghci browser mode+  flagGhciSpec "ghci-browser"                 Opt_GhciBrowser,+  flagGhciSpec "ghci-browser-redirect-wasi-console" Opt_GhciBrowserRedirectWasiConsole,++  -- load all targets on GHCi startup+  flagGhciSpec "load-initial-targets"         Opt_GhciDoLoadTargets,++  flagSpec "helpful-errors"                   Opt_HelpfulErrors,+  flagSpec "hpc"                              Opt_Hpc,+  flagSpec "ignore-asserts"                   Opt_IgnoreAsserts,+  flagSpec "ignore-interface-pragmas"         Opt_IgnoreInterfacePragmas,+  flagGhciSpec "implicit-import-qualified"    Opt_ImplicitImportQualified,+  flagSpec "irrefutable-tuples"               Opt_IrrefutableTuples,+  flagSpec "keep-going"                       Opt_KeepGoing,+  flagSpec "late-dmd-anal"                    Opt_LateDmdAnal,+  flagSpec "late-specialise"                  Opt_LateSpecialise,+  flagSpec "liberate-case"                    Opt_LiberateCase,+  flagHiddenSpec "llvm-fill-undef-with-garbage" Opt_LlvmFillUndefWithGarbage,+  flagSpec "loopification"                    Opt_Loopification,+  flagSpec "block-layout-cfg"                 Opt_CfgBlocklayout,+  flagSpec "block-layout-weightless"          Opt_WeightlessBlocklayout,+  flagSpec "omit-interface-pragmas"           Opt_OmitInterfacePragmas,+  flagSpec "omit-yields"                      Opt_OmitYields,+  flagSpec "optimal-applicative-do"           Opt_OptimalApplicativeDo,+  flagSpec "pedantic-bottoms"                 Opt_PedanticBottoms,+  flagSpec "pre-inlining"                     Opt_SimplPreInlining,+  flagGhciSpec "print-bind-contents"          Opt_PrintBindContents,+  flagGhciSpec "print-bind-result"            Opt_PrintBindResult,+  flagGhciSpec "print-evld-with-show"         Opt_PrintEvldWithShow,+  flagSpec "print-explicit-foralls"           Opt_PrintExplicitForalls,+  flagSpec "print-explicit-kinds"             Opt_PrintExplicitKinds,+  flagSpec "print-explicit-coercions"         Opt_PrintExplicitCoercions,+  flagSpec "print-explicit-runtime-reps"      Opt_PrintExplicitRuntimeReps,+  flagSpec "print-equality-relations"         Opt_PrintEqualityRelations,+  flagSpec "print-axiom-incomps"              Opt_PrintAxiomIncomps,+  flagSpec "print-unicode-syntax"             Opt_PrintUnicodeSyntax,+  flagSpec "print-expanded-synonyms"          Opt_PrintExpandedSynonyms,+  flagSpec "print-potential-instances"        Opt_PrintPotentialInstances,+  flagSpec "print-redundant-promotion-ticks"  Opt_PrintRedundantPromotionTicks,+  flagSpec "print-typechecker-elaboration"    Opt_PrintTypecheckerElaboration,+  flagSpec "prof-cafs"                        Opt_AutoSccsOnIndividualCafs,+  flagSpec "prof-count-entries"               Opt_ProfCountEntries,+  flagSpec "prof-late"                        Opt_ProfLateCcs,+  flagSpec "prof-late-overloaded"             Opt_ProfLateOverloadedCcs,+  flagSpec "prof-late-overloaded-calls"       Opt_ProfLateoverloadedCallsCCs,+  flagSpec "prof-manual"                      Opt_ProfManualCcs,+  flagSpec "prof-late-inline"                 Opt_ProfLateInlineCcs,+  flagSpec "regs-graph"                       Opt_RegsGraph,+  flagSpec "regs-iterative"                   Opt_RegsIterative,+  depFlagSpec' "rewrite-rules"                Opt_EnableRewriteRules+   (useInstead "-f" "enable-rewrite-rules"),+  flagSpec "shared-implib"                    Opt_SharedImplib,+  flagSpec "spec-constr"                      Opt_SpecConstr,+  flagSpec "spec-constr-keen"                 Opt_SpecConstrKeen,+  flagSpec "specialise"                       Opt_Specialise,+  flagSpec "specialize"                       Opt_Specialise,+  flagSpec "specialise-aggressively"          Opt_SpecialiseAggressively,+  flagSpec "specialize-aggressively"          Opt_SpecialiseAggressively,+  flagSpec "cross-module-specialise"          Opt_CrossModuleSpecialise,+  flagSpec "cross-module-specialize"          Opt_CrossModuleSpecialise,+  flagSpec "polymorphic-specialisation"       Opt_PolymorphicSpecialisation,+  flagSpec "specialise-incoherents"           Opt_SpecialiseIncoherents,+  flagSpec "inline-generics"                  Opt_InlineGenerics,+  flagSpec "inline-generics-aggressively"     Opt_InlineGenericsAggressively,+  flagSpec "static-argument-transformation"   Opt_StaticArgumentTransformation,+  flagSpec "strictness"                       Opt_Strictness,+  flagSpec "use-rpaths"                       Opt_RPath,+  flagSpec "write-interface"                  Opt_WriteInterface,+  flagSpec "write-if-simplified-core"         Opt_WriteIfSimplifiedCore,+  flagSpec "write-if-self-recomp"             Opt_WriteSelfRecompInfo,+  flagSpec "write-if-self-recomp-flags"       Opt_WriteSelfRecompFlags,+  flagSpec "write-ide-info"                   Opt_WriteHie,+  flagSpec "unbox-small-strict-fields"        Opt_UnboxSmallStrictFields,+  flagSpec "unbox-strict-fields"              Opt_UnboxStrictFields,+  flagSpec "unoptimized-core-for-interpreter" Opt_UnoptimizedCoreForInterpreter,+  flagSpec "version-macros"                   Opt_VersionMacros,+  flagSpec "worker-wrapper"                   Opt_WorkerWrapper,+  flagSpec "worker-wrapper-cbv"               Opt_WorkerWrapperUnlift, -- See Note [Worker/wrapper for strict arguments]+  flagSpec "solve-constant-dicts"             Opt_SolveConstantDicts,+  flagSpec "catch-nonexhaustive-cases"        Opt_CatchNonexhaustiveCases,+  flagSpec "alignment-sanitisation"           Opt_AlignmentSanitisation,+  flagSpec "check-prim-bounds"                Opt_DoBoundsChecking,+  flagSpec "add-bco-name"                     Opt_AddBcoName,+  flagSpec "num-constant-folding"             Opt_NumConstantFolding,+  flagSpec "core-constant-folding"            Opt_CoreConstantFolding,+  flagSpec "fast-pap-calls"                   Opt_FastPAPCalls,+  flagSpec "spec-eval"                        Opt_SpecEval,+  flagSpec "spec-eval-dictfun"                Opt_SpecEvalDictFun,+  flagSpec "cmm-control-flow"                 Opt_CmmControlFlow,+  flagSpec "show-warning-groups"              Opt_ShowWarnGroups,+  flagSpec "hide-source-paths"                Opt_HideSourcePaths,+  flagSpec "show-loaded-modules"              Opt_ShowLoadedModules,+  flagSpec "whole-archive-hs-libs"            Opt_WholeArchiveHsLibs,+  flagSpec "keep-cafs"                        Opt_KeepCAFs,+  flagSpec "link-rts"                         Opt_LinkRts,+  flagSpec "byte-code-and-object-code"        Opt_ByteCodeAndObjectCode,+  flagSpec "prefer-byte-code"                 Opt_UseBytecodeRatherThanObjects,+  flagSpec "object-determinism"               Opt_ObjectDeterminism,+  flagSpec' "compact-unwind"                  Opt_CompactUnwind+      (\turn_on -> updM (\dflags -> do+        unless (platformOS (targetPlatform dflags) == OSDarwin && turn_on)+               (addWarn "-compact-unwind is only implemented by the darwin platform. Ignoring.")+        return dflags)),+  flagSpec "show-error-context"               Opt_ShowErrorContext,+  flagSpec "cmm-thread-sanitizer"             Opt_CmmThreadSanitizer,+  flagSpec "split-sections"                   Opt_SplitSections,+  flagSpec "break-points"                     Opt_InsertBreakpoints,+  flagSpec "distinct-constructor-tables"      Opt_DistinctConstructorTables,+  flagSpec "info-table-map"                   Opt_InfoTableMap,+  flagSpec "info-table-map-with-stack"        Opt_InfoTableMapWithStack,+  flagSpec "info-table-map-with-fallback"     Opt_InfoTableMapWithFallback+  ]+  ++ fHoleFlags++-- | These @-f\<blah\>@ flags have to do with the typed-hole error message or+-- the valid hole fits in that message. See Note [Valid hole fits include ...]+-- in the "GHC.Tc.Errors.Hole" module. These flags can all be reversed with+-- @-fno-\<blah\>@+fHoleFlags :: [(Deprecation, FlagSpec GeneralFlag)]+fHoleFlags = [+  flagSpec "show-hole-constraints"            Opt_ShowHoleConstraints,+  depFlagSpec' "show-valid-substitutions"     Opt_ShowValidHoleFits+   (useInstead "-f" "show-valid-hole-fits"),+  flagSpec "show-valid-hole-fits"             Opt_ShowValidHoleFits,+  -- Sorting settings+  flagSpec "sort-valid-hole-fits"             Opt_SortValidHoleFits,+  flagSpec "sort-by-size-hole-fits"           Opt_SortBySizeHoleFits,+  flagSpec "sort-by-subsumption-hole-fits"    Opt_SortBySubsumHoleFits,+  flagSpec "abstract-refinement-hole-fits"    Opt_AbstractRefHoleFits,+  -- Output format settings+  flagSpec "show-hole-matches-of-hole-fits"   Opt_ShowMatchesOfHoleFits,+  flagSpec "show-provenance-of-hole-fits"     Opt_ShowProvOfHoleFits,+  flagSpec "show-type-of-hole-fits"           Opt_ShowTypeOfHoleFits,+  flagSpec "show-type-app-of-hole-fits"       Opt_ShowTypeAppOfHoleFits,+  flagSpec "show-type-app-vars-of-hole-fits"  Opt_ShowTypeAppVarsOfHoleFits,+  flagSpec "show-docs-of-hole-fits"           Opt_ShowDocsOfHoleFits,+  flagSpec "unclutter-valid-hole-fits"        Opt_UnclutterValidHoleFits+  ]++-- | These @-f\<blah\>@ flags can all be reversed with @-fno-\<blah\>@+fLangFlags :: [FlagSpec LangExt.Extension]+fLangFlags = map snd fLangFlagsDeps++fLangFlagsDeps :: [(Deprecation, FlagSpec LangExt.Extension)]+fLangFlagsDeps = [+-- See Note [Updating flag description in the User's Guide]+-- See Note [Supporting CLI completion]+  depFlagSpecOp' "th"                           LangExt.TemplateHaskell+    checkTemplateHaskellOk+    (deprecatedForExtension "TemplateHaskell"),+  depFlagSpec' "fi"                             LangExt.ForeignFunctionInterface+    (deprecatedForExtension "ForeignFunctionInterface"),+  depFlagSpec' "ffi"                            LangExt.ForeignFunctionInterface+    (deprecatedForExtension "ForeignFunctionInterface"),+  depFlagSpec' "arrows"                         LangExt.Arrows+    (deprecatedForExtension "Arrows"),+  depFlagSpec' "implicit-prelude"               LangExt.ImplicitPrelude+    (deprecatedForExtension "ImplicitPrelude"),+  depFlagSpec' "bang-patterns"                  LangExt.BangPatterns+    (deprecatedForExtension "BangPatterns"),+  depFlagSpec' "monomorphism-restriction"       LangExt.MonomorphismRestriction+    (deprecatedForExtension "MonomorphismRestriction"),+  depFlagSpec' "extended-default-rules"         LangExt.ExtendedDefaultRules+    (deprecatedForExtension "ExtendedDefaultRules"),+  depFlagSpec' "implicit-params"                LangExt.ImplicitParams+    (deprecatedForExtension "ImplicitParams"),+  depFlagSpec' "scoped-type-variables"          LangExt.ScopedTypeVariables+    (deprecatedForExtension "ScopedTypeVariables"),+  depFlagSpec' "allow-overlapping-instances"    LangExt.OverlappingInstances+    (deprecatedForExtension "OverlappingInstances"),+  depFlagSpec' "allow-undecidable-instances"    LangExt.UndecidableInstances+    (deprecatedForExtension "UndecidableInstances"),+  depFlagSpec' "allow-incoherent-instances"     LangExt.IncoherentInstances+    (deprecatedForExtension "IncoherentInstances")+  ]++supportedLanguages :: [String]+supportedLanguages = map (flagSpecName . snd) languageFlagsDeps++supportedLanguageOverlays :: [String]+supportedLanguageOverlays = map (flagSpecName . snd) safeHaskellFlagsDeps++supportedExtensions :: ArchOS -> [String]+supportedExtensions (ArchOS arch os) = concatMap toFlagSpecNamePair xFlags+  where+    toFlagSpecNamePair flg+      -- IMPORTANT! Make sure that `ghc --supported-extensions` omits+      -- "TemplateHaskell"/"QuasiQuotes" when it's known not to work out of the+      -- box. See also GHC #11102 and #16331 for more details about+      -- the rationale+      | isAIX, flagSpecFlag flg == LangExt.TemplateHaskell  = [noName]+      | isAIX, flagSpecFlag flg == LangExt.QuasiQuotes      = [noName]+      -- "JavaScriptFFI" is only supported on the JavaScript/Wasm backend+      | notJSOrWasm, flagSpecFlag flg == LangExt.JavaScriptFFI = [noName]+      | otherwise = [name, noName]+      where+        isAIX = os == OSAIX+        notJSOrWasm = not $ arch `elem` [ ArchJavaScript, ArchWasm32 ]+        noName = "No" ++ name+        name = flagSpecName flg++supportedLanguagesAndExtensions :: ArchOS -> [String]+supportedLanguagesAndExtensions arch_os =+    supportedLanguages ++ supportedLanguageOverlays ++ supportedExtensions arch_os++-- | These -X<blah> flags cannot be reversed with -XNo<blah>+languageFlagsDeps :: [(Deprecation, FlagSpec Language)]+languageFlagsDeps = [+  flagSpec "Haskell98"   Haskell98,+  flagSpec "Haskell2010" Haskell2010,+  flagSpec "GHC2021"     GHC2021,+  flagSpec "GHC2024"     GHC2024+  ]++-- | These -X<blah> flags cannot be reversed with -XNo<blah>+-- They are used to place hard requirements on what GHC Haskell language+-- features can be used.+safeHaskellFlagsDeps :: [(Deprecation, FlagSpec SafeHaskellMode)]+safeHaskellFlagsDeps = [mkF Sf_Unsafe, mkF Sf_Trustworthy, mkF Sf_Safe]+    where mkF flag = flagSpec (show flag) flag++-- | These -X<blah> flags can all be reversed with -XNo<blah>+xFlags :: [FlagSpec LangExt.Extension]+xFlags = map snd xFlagsDeps++makeExtensionFlags :: LangExt.Extension -> [(Deprecation, FlagSpec LangExt.Extension)]+makeExtensionFlags ext = [ makeExtensionFlag name depr ext | (depr, name) <- extensionNames ext ]++xFlagsDeps :: [(Deprecation, FlagSpec LangExt.Extension)]+xFlagsDeps = concatMap makeExtensionFlags [minBound .. maxBound]++makeExtensionFlag :: String -> ExtensionDeprecation -> LangExt.Extension -> (Deprecation, FlagSpec LangExt.Extension)+makeExtensionFlag name depr ext = (deprecation depr, spec)+  where effect = extensionEffect ext+        spec = FlagSpec name ext (\f -> effect f >> act f) AllModes+        act = case depr of+                ExtensionNotDeprecated -> nop+                ExtensionDeprecatedFor xs+                  -> deprecate . deprecatedForExtensions (map extensionName xs)+                ExtensionFlagDeprecatedCond cond str+                  -> \f -> when (f == cond) (deprecate str)+                ExtensionFlagDeprecated str+                  -> const (deprecate str)++extensionEffect :: LangExt.Extension -> (TurnOnFlag -> DynP ())+extensionEffect = \case+  LangExt.TemplateHaskell+    -> checkTemplateHaskellOk+  LangExt.OverlappingInstances+    -> setOverlappingInsts+  LangExt.GeneralizedNewtypeDeriving+    -> setGenDeriving+  LangExt.IncoherentInstances+    -> setIncoherentInsts+  LangExt.DerivingVia+    -> setDeriveVia+  _ -> nop++-- | Things you get with `-dlint`.+enableDLint :: DynP ()+enableDLint = do+    mapM_ setGeneralFlag dLintFlags+    addWayDynP WayDebug+  where+    dLintFlags :: [GeneralFlag]+    dLintFlags =+        [ Opt_DoCoreLinting+        , Opt_DoStgLinting+        , Opt_DoCmmLinting+        , Opt_DoAsmLinting+        , Opt_CatchNonexhaustiveCases+        , Opt_LlvmFillUndefWithGarbage+        ]++enableGlasgowExts :: DynP ()+enableGlasgowExts = do setGeneralFlag Opt_PrintExplicitForalls+                       mapM_ setExtensionFlag glasgowExtsFlags++disableGlasgowExts :: DynP ()+disableGlasgowExts = do unSetGeneralFlag Opt_PrintExplicitForalls+                        mapM_ unSetExtensionFlag glasgowExtsFlags+++setWarnSafe :: Bool -> DynP ()+setWarnSafe True  = getCurLoc >>= \l -> upd (\d -> d { warnSafeOnLoc = l })+setWarnSafe False = return ()++setWarnUnsafe :: Bool -> DynP ()+setWarnUnsafe True  = getCurLoc >>= \l -> upd (\d -> d { warnUnsafeOnLoc = l })+setWarnUnsafe False = return ()++setPackageTrust :: DynP ()+setPackageTrust = do+    setGeneralFlag Opt_PackageTrust+    l <- getCurLoc+    upd $ \d -> d { pkgTrustOnLoc = l }++setGenDeriving :: TurnOnFlag -> DynP ()+setGenDeriving True  = getCurLoc >>= \l -> upd (\d -> d { newDerivOnLoc = l })+setGenDeriving False = return ()++setDeriveVia :: TurnOnFlag -> DynP ()+setDeriveVia True  = getCurLoc >>= \l -> upd (\d -> d { deriveViaOnLoc = l })+setDeriveVia False = return ()++setOverlappingInsts :: TurnOnFlag -> DynP ()+setOverlappingInsts False = return ()+setOverlappingInsts True = do+  l <- getCurLoc+  upd (\d -> d { overlapInstLoc = l })++setIncoherentInsts :: TurnOnFlag -> DynP ()+setIncoherentInsts False = return ()+setIncoherentInsts True = do+  l <- getCurLoc+  upd (\d -> d { incoherentOnLoc = l })++checkTemplateHaskellOk :: TurnOnFlag -> DynP ()+checkTemplateHaskellOk _turn_on+  = getCurLoc >>= \l -> upd (\d -> d { thOnLoc = l })++{- **********************************************************************+%*                                                                      *+                DynFlags constructors+%*                                                                      *+%********************************************************************* -}++type DynP = EwM (CmdLineP DynFlags)++upd :: (DynFlags -> DynFlags) -> DynP ()+upd f = liftEwM (do dflags <- getCmdLineState+                    putCmdLineState $! f dflags)++updM :: (DynFlags -> DynP DynFlags) -> DynP ()+updM f = do dflags <- liftEwM getCmdLineState+            dflags' <- f dflags+            liftEwM $ putCmdLineState $! dflags'++--------------- Constructor functions for OptKind -----------------+noArg :: (DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags)+noArg fn = NoArg (upd fn)++noArgM :: (DynFlags -> DynP DynFlags) -> OptKind (CmdLineP DynFlags)+noArgM fn = NoArg (updM fn)++hasArg :: (String -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags)+hasArg fn = HasArg (upd . fn)++sepArg :: (String -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags)+sepArg fn = SepArg (upd . fn)++intSuffix :: (Int -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags)+intSuffix fn = IntSuffix (\n -> upd (fn n))++intSuffixM :: (Int -> DynFlags -> DynP DynFlags) -> OptKind (CmdLineP DynFlags)+intSuffixM fn = IntSuffix (\n -> updM (fn n))++word64Suffix :: (Word64 -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags)+word64Suffix fn = Word64Suffix (\n -> upd (fn n))++floatSuffix :: (Float -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags)+floatSuffix fn = FloatSuffix (\n -> upd (fn n))++optIntSuffixM :: (Maybe Int -> DynFlags -> DynP DynFlags)+              -> OptKind (CmdLineP DynFlags)+optIntSuffixM fn = OptIntSuffix (\mi -> updM (fn mi))++setDumpFlag :: DumpFlag -> OptKind (CmdLineP DynFlags)+setDumpFlag dump_flag = NoArg (setDumpFlag' dump_flag)++--------------------------+addWayDynP :: Way -> DynP ()+addWayDynP = upd . addWay'++addWay' :: Way -> DynFlags -> DynFlags+addWay' w dflags0 =+   let platform = targetPlatform dflags0+       dflags1 = dflags0 { targetWays_ = addWay w (targetWays_ dflags0) }+       dflags2 = foldr setGeneralFlag' dflags1+                       (wayGeneralFlags platform w)+       dflags3 = foldr unSetGeneralFlag' dflags2+                       (wayUnsetGeneralFlags platform w)+   in dflags3++removeWayDynP :: Way -> DynP ()+removeWayDynP w = upd (\dfs -> dfs { targetWays_ = removeWay w (targetWays_ dfs) })++--------------------------+setGeneralFlag, unSetGeneralFlag :: GeneralFlag -> DynP ()+setGeneralFlag   f = upd (setGeneralFlag' f)+unSetGeneralFlag f = upd (unSetGeneralFlag' f)++setGeneralFlag' :: GeneralFlag -> DynFlags -> DynFlags+setGeneralFlag' f dflags = foldr ($) (gopt_set dflags f) deps+  where+    deps = [ if turn_on then setGeneralFlag'   d+                        else unSetGeneralFlag' d+           | (f', turn_on, d) <- impliedGFlags, f' == f ]+        -- When you set f, set the ones it implies+        -- NB: use setGeneralFlag recursively, in case the implied flags+        --     implies further flags++unSetGeneralFlag' :: GeneralFlag -> DynFlags -> DynFlags+unSetGeneralFlag' f dflags = foldr ($) (gopt_unset dflags f) deps+  where+    deps = [ if turn_on then setGeneralFlag' d+                        else unSetGeneralFlag' d+           | (f', turn_on, d) <- impliedOffGFlags, f' == f ]+   -- In general, when you un-set f, we don't un-set the things it implies.+   -- There are however some exceptions, e.g., -fno-strictness implies+   -- -fno-worker-wrapper.+   --+   -- NB: use unSetGeneralFlag' recursively, in case the implied off flags+   --     imply further flags.++--------------------------+setWarningGroup :: WarningGroup -> DynP ()+setWarningGroup g = do+    mapM_ setWarningFlag (warningGroupFlags g)+    when (warningGroupIncludesExtendedWarnings g) $ upd wopt_set_all_custom++unSetWarningGroup :: WarningGroup -> DynP ()+unSetWarningGroup g = do+    mapM_ unSetWarningFlag (warningGroupFlags g)+    when (warningGroupIncludesExtendedWarnings g) $ upd wopt_unset_all_custom++setWErrorWarningGroup :: WarningGroup -> DynP ()+setWErrorWarningGroup g =+  do { setWarningGroup g+     ; setFatalWarningGroup g }++setFatalWarningGroup :: WarningGroup -> DynP ()+setFatalWarningGroup g = do+    mapM_ setFatalWarningFlag (warningGroupFlags g)+    when (warningGroupIncludesExtendedWarnings g) $ upd wopt_set_all_fatal_custom++unSetFatalWarningGroup :: WarningGroup -> DynP ()+unSetFatalWarningGroup g = do+    mapM_ unSetFatalWarningFlag (warningGroupFlags g)+    when (warningGroupIncludesExtendedWarnings g) $ upd wopt_unset_all_fatal_custom+++setWarningFlag, unSetWarningFlag :: WarningFlag -> DynP ()+setWarningFlag   f = upd (\dfs -> wopt_set dfs f)+unSetWarningFlag f = upd (\dfs -> wopt_unset dfs f)++setFatalWarningFlag, unSetFatalWarningFlag :: WarningFlag -> DynP ()+setFatalWarningFlag   f = upd (\dfs -> wopt_set_fatal dfs f)+unSetFatalWarningFlag f = upd (\dfs -> wopt_unset_fatal dfs f)++setWErrorFlag :: WarningFlag -> DynP ()+setWErrorFlag flag =+  do { setWarningFlag flag+     ; setFatalWarningFlag flag }+++setCustomWarningFlag, unSetCustomWarningFlag :: WarningCategory -> DynP ()+setCustomWarningFlag   f = upd (\dfs -> wopt_set_custom dfs f)+unSetCustomWarningFlag f = upd (\dfs -> wopt_unset_custom dfs f)++setCustomFatalWarningFlag, unSetCustomFatalWarningFlag :: WarningCategory -> DynP ()+setCustomFatalWarningFlag   f = upd (\dfs -> wopt_set_fatal_custom dfs f)+unSetCustomFatalWarningFlag f = upd (\dfs -> wopt_unset_fatal_custom dfs f)++setCustomWErrorFlag :: WarningCategory -> DynP ()+setCustomWErrorFlag flag =+  do { setCustomWarningFlag flag+     ; setCustomFatalWarningFlag flag }+++--------------------------+setExtensionFlag, unSetExtensionFlag :: LangExt.Extension -> DynP ()+setExtensionFlag f = upd (setExtensionFlag' f)+unSetExtensionFlag f = upd (unSetExtensionFlag' f)++setExtensionFlag', unSetExtensionFlag' :: LangExt.Extension -> DynFlags -> DynFlags+setExtensionFlag' f dflags = foldr ($) (xopt_set dflags f) deps+  where+    deps :: [DynFlags -> DynFlags]+    deps = [ setExtension d+           | (f', d) <- impliedXFlags, f' == f ]+        -- When you set f, set the ones it implies+        -- NB: use setExtensionFlag recursively, in case the implied flags+        --     implies further flags++    setExtension :: OnOff LangExt.Extension -> DynFlags -> DynFlags+    setExtension = \ case+      On extension -> setExtensionFlag' extension+      Off extension -> unSetExtensionFlag' extension++unSetExtensionFlag' f dflags = xopt_unset dflags f+   -- When you un-set f, however, we don't un-set the things it implies+   --      (except for -fno-glasgow-exts, which is treated specially)++--------------------------++alterToolSettings :: (ToolSettings -> ToolSettings) -> DynFlags -> DynFlags+alterToolSettings f dynFlags = dynFlags { toolSettings = f (toolSettings dynFlags) }++--------------------------+setDumpFlag' :: DumpFlag -> DynP ()+setDumpFlag' dump_flag+  = do upd (\dfs -> dopt_set dfs dump_flag)+       when want_recomp forceRecompile+    where -- Certain dumpy-things are really interested in what's going+          -- on during recompilation checking, so in those cases we+          -- don't want to turn it off.+          want_recomp = dump_flag `notElem` [Opt_D_dump_if_trace,+                                             Opt_D_dump_hi_diffs,+                                             Opt_D_no_debug_output]++forceRecompile :: DynP ()+-- Whenever we -ddump, force recompilation (by switching off the+-- recompilation checker), else you don't see the dump! However,+-- don't switch it off in --make mode, else *everything* gets+-- recompiled which probably isn't what you want+forceRecompile = do dfs <- liftEwM getCmdLineState+                    when (force_recomp dfs) (setGeneralFlag Opt_ForceRecomp)+        where+          force_recomp dfs = isOneShot (ghcMode dfs)+++setVerbosity :: Maybe Int -> DynP ()+setVerbosity mb_n = upd (\dfs -> dfs{ verbosity = mb_n `orElse` 3 })++setDebugLevel :: Maybe Int -> DynP ()+setDebugLevel mb_n =+  upd (\dfs -> exposeSyms $ dfs{ debugLevel = n })+  where+    n = mb_n `orElse` 2+    exposeSyms+      | n > 2     = setGeneralFlag' Opt_ExposeInternalSymbols+      | otherwise = id++addPkgDbRef :: PkgDbRef -> DynP ()+addPkgDbRef p = upd $ \s ->+  s { packageDBFlags = PackageDB p : packageDBFlags s }++removeUserPkgDb :: DynP ()+removeUserPkgDb = upd $ \s ->+  s { packageDBFlags = NoUserPackageDB : packageDBFlags s }++removeGlobalPkgDb :: DynP ()+removeGlobalPkgDb = upd $ \s ->+ s { packageDBFlags = NoGlobalPackageDB : packageDBFlags s }++clearPkgDb :: DynP ()+clearPkgDb = upd $ \s ->+  s { packageDBFlags = ClearPackageDBs : packageDBFlags s }++parsePackageFlag :: String                 -- the flag+                 -> ReadP PackageArg       -- type of argument+                 -> String                 -- string to parse+                 -> PackageFlag+parsePackageFlag flag arg_parse str+ = case filter ((=="").snd) (readP_to_S parse str) of+    [(r, "")] -> r+    _ -> throwGhcException $ CmdLineError ("Can't parse package flag: " ++ str)+  where doc = flag ++ " " ++ str+        parse = do+            pkg_arg <- tok arg_parse+            let mk_expose = ExposePackage doc pkg_arg+            ( do _ <- tok $ string "with"+                 fmap (mk_expose . ModRenaming True) parseRns+             <++ fmap (mk_expose . ModRenaming False) parseRns+             <++ return (mk_expose (ModRenaming True [])))+        parseRns = do _ <- tok $ R.char '('+                      rns <- tok $ sepBy parseItem (tok $ R.char ',')+                      _ <- tok $ R.char ')'+                      return rns+        parseItem = do+            orig <- tok $ parseModuleName+            (do _ <- tok $ string "as"+                new <- tok $ parseModuleName+                return (orig, new)+              ++++             return (orig, orig))+        tok m = m >>= \x -> skipSpaces >> return x++exposePackage, exposePackageId, hidePackage,+        exposePluginPackage, exposePluginPackageId,+        ignorePackage,+        trustPackage, distrustPackage :: String -> DynP ()+exposePackage p = upd (exposePackage' p)+exposePackageId p =+  upd (\s -> s{ packageFlags =+    parsePackageFlag "-package-id" parseUnitArg p : packageFlags s })+exposePluginPackage p =+  upd (\s -> s{ pluginPackageFlags =+    parsePackageFlag "-plugin-package" parsePackageArg p : pluginPackageFlags s })+exposePluginPackageId p =+  upd (\s -> s{ pluginPackageFlags =+    parsePackageFlag "-plugin-package-id" parseUnitArg p : pluginPackageFlags s })+hidePackage p =+  upd (\s -> s{ packageFlags = HidePackage p : packageFlags s })+ignorePackage p =+  upd (\s -> s{ ignorePackageFlags = IgnorePackage p : ignorePackageFlags s })++trustPackage p = exposePackage p >> -- both trust and distrust also expose a package+  upd (\s -> s{ trustFlags = TrustPackage p : trustFlags s })+distrustPackage p = exposePackage p >>+  upd (\s -> s{ trustFlags = DistrustPackage p : trustFlags s })++exposePackage' :: String -> DynFlags -> DynFlags+exposePackage' p dflags+    = dflags { packageFlags =+            parsePackageFlag "-package" parsePackageArg p : packageFlags dflags }++parsePackageArg :: ReadP PackageArg+parsePackageArg =+    fmap PackageArg (munch1 (\c -> isAlphaNum c || c `elem` ":-_."))++parseUnitArg :: ReadP PackageArg+parseUnitArg =+    fmap UnitIdArg parseUnit++setUnitId :: String -> DynFlags -> DynFlags+setUnitId p d = d { homeUnitId_ = stringToUnitId p }++setHomeUnitId :: UnitId -> DynFlags -> DynFlags+setHomeUnitId p d = d { homeUnitId_ = p }++setWorkingDirectory :: String -> DynFlags -> DynFlags+setWorkingDirectory p d = d { workingDirectory =  Just p }++{-+Note [Filepaths and Multiple Home Units]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++It is common to assume that a package is compiled in the directory where its+cabal file resides. Thus, all paths used in the compiler are assumed to be relative+to this directory. When there are multiple home units the compiler is often+not operating in the standard directory and instead where the cabal.project+file is located. In this case the `-working-dir` option can be passed which specifies+the path from the current directory to the directory the unit assumes to be it's root,+normally the directory which contains the cabal file.++When the flag is passed, any relative paths used by the compiler are offset+by the working directory. Notably this includes `-i`, `-I⟨dir⟩`, `-hidir`, `-odir` etc and+the location of input files.++-}++augmentByWorkingDirectory :: DynFlags -> FilePath -> FilePath+augmentByWorkingDirectory dflags fp | isRelative fp, Just offset <- workingDirectory dflags = offset </> fp+augmentByWorkingDirectory _ fp = fp++setPackageName :: String -> DynFlags -> DynFlags+setPackageName p d = d { thisPackageName =  Just p }++addHiddenModule :: String -> DynP ()+addHiddenModule p =+  upd (\s -> s{ hiddenModules  = Set.insert (mkModuleName p) (hiddenModules s) })++addReexportedModule :: String -> DynP ()+addReexportedModule p =+  upd (\s -> s{ reexportedModules  = (parseReexportedModule p) : (reexportedModules s) })++parseReexportedModule :: String                 -- string to parse+                      -> ReexportedModule+parseReexportedModule str+ = case filter ((=="").snd) (readP_to_S parseItem str) of+    [(r, "")] -> r+    _ -> throwGhcException $ CmdLineError ("Can't parse reexported module flag: " ++ str)+  where+        parseItem = do+            orig <- tok $ parseModuleName+            (do _ <- tok $ string "as"+                new <- tok $ parseModuleName+                return (ReexportedModule orig new))+              ++++             return (ReexportedModule orig orig)++        tok m = m >>= \x -> skipSpaces >> return x+++-- If we're linking a binary, then only backends that produce object+-- code are allowed (requests for other target types are ignored).+setBackend :: Backend -> DynP ()+setBackend l = upd $ \ dfs ->+  if ghcLink dfs /= LinkBinary || backendWritesFiles l+  then dfs{ backend = l }+  else dfs++-- Changes the target only if we're compiling object code.  This is+-- used by -fasm and -fllvm, which switch from one to the other, but+-- not from bytecode to object-code.  The idea is that -fasm/-fllvm+-- can be safely used in an OPTIONS_GHC pragma.+setObjBackend :: Backend -> DynP ()+setObjBackend l = updM set+  where+   set dflags+     | backendWritesFiles (backend dflags)+       = return $ dflags { backend = l }+     | otherwise = return dflags++setOptLevel :: Int -> DynFlags -> DynP DynFlags+setOptLevel n dflags = return (updOptLevel n dflags)++setCallerCcFilters :: String -> DynP ()+setCallerCcFilters arg =+  case parseCallerCcFilter arg of+    Right filt -> upd $ \d -> d { callerCcFilters = filt : callerCcFilters d }+    Left err -> addErr err++setMainIs :: String -> DynP ()+setMainIs arg = parse parse_main_f arg+  where+    parse callback str = case unP parseIdentifier (p_state str) of+      PFailed _      -> addErr $ "Can't parse -main-is \"" ++ arg ++ "\" as an identifier or module."+      POk _ (L _ re) -> callback re++    -- dummy parser state.+    p_state str = initParserState+              (mkParserOpts mempty emptyDiagOpts False False False True)+              (stringToStringBuffer str)+              (mkRealSrcLoc (mkFastString []) 1 1)++    parse_main_f (Unqual occ)+      | isVarOcc occ = upd $ \d -> d { mainFunIs = main_f occ }+    parse_main_f (Qual (ModuleName mod) occ)+      | isVarOcc occ = upd $ \d -> d { mainModuleNameIs = mkModuleNameFS mod+                                     , mainFunIs = main_f occ }+    -- append dummy "function" to parse A.B as the module A.B+    -- and not the Data constructor B from the module A+    parse_main_f _ = parse parse_mod (arg ++ ".main")++    main_f = Just . occNameString++    parse_mod (Qual (ModuleName mod) _) = upd $ \d -> d { mainModuleNameIs = mkModuleNameFS mod }+    -- we appended ".m" and any parse error was caught. We are Qual or something went very wrong+    parse_mod _ = error "unreachable"++addLdInputs :: Option -> DynFlags -> DynFlags+addLdInputs p dflags = dflags{ldInputs = ldInputs dflags ++ [p]}++-- -----------------------------------------------------------------------------+-- Load dynflags from environment files.++setFlagsFromEnvFile :: FilePath -> String -> DynP ()+setFlagsFromEnvFile envfile content = do+  setGeneralFlag Opt_HideAllPackages+  parseEnvFile envfile content++parseEnvFile :: FilePath -> String -> DynP ()+parseEnvFile envfile = mapM_ parseEntry . lines+  where+    parseEntry str = case words str of+      ("package-db": _)     -> addPkgDbRef (PkgDbPath (envdir </> db))+        -- relative package dbs are interpreted relative to the env file+        where envdir = takeDirectory envfile+              db     = drop 11 str+      ["clear-package-db"]  -> clearPkgDb+      ["hide-package", pkg]  -> hidePackage pkg+      ["global-package-db"] -> addPkgDbRef GlobalPkgDb+      ["user-package-db"]   -> addPkgDbRef UserPkgDb+      ["package-id", pkgid] -> exposePackageId pkgid+      (('-':'-':_):_)       -> return () -- comments+      -- and the original syntax introduced in 7.10:+      [pkgid]               -> exposePackageId pkgid+      []                    -> return ()+      _                     -> throwGhcException $ CmdLineError $+                                    "Can't parse environment file entry: "+                                 ++ envfile ++ ": " ++ str+++-----------------------------------------------------------------------------+-- Paths & Libraries++addImportPath, addLibraryPath, addIncludePath, addFrameworkPath :: FilePath -> DynP ()++-- -i on its own deletes the import paths+addImportPath "" = upd (\s -> s{importPaths = []})+addImportPath p  = upd (\s -> s{importPaths = importPaths s ++ splitPathList p})++addLibraryPath p =+  upd (\s -> s{libraryPaths = libraryPaths s ++ splitPathList p})++addIncludePath p =+  upd (\s -> s{includePaths =+                  addGlobalInclude (includePaths s) (splitPathList p)})++addFrameworkPath p =+  upd (\s -> s{frameworkPaths = frameworkPaths s ++ splitPathList p})++#if !defined(mingw32_HOST_OS)+split_marker :: Char+split_marker = ':'   -- not configurable (ToDo)+#endif++splitPathList :: String -> [String]+splitPathList s = filter notNull (splitUp s)+                -- empty paths are ignored: there might be a trailing+                -- ':' in the initial list, for example.  Empty paths can+                -- cause confusion when they are translated into -I options+                -- for passing to gcc.+  where+#if !defined(mingw32_HOST_OS)+    splitUp xs = split split_marker xs+#else+     -- Windows: 'hybrid' support for DOS-style paths in directory lists.+     --+     -- That is, if "foo:bar:baz" is used, this interpreted as+     -- consisting of three entries, 'foo', 'bar', 'baz'.+     -- However, with "c:/foo:c:\\foo;x:/bar", this is interpreted+     -- as 3 elts, "c:/foo", "c:\\foo", "x:/bar"+     --+     -- Notice that no attempt is made to fully replace the 'standard'+     -- split marker ':' with the Windows / DOS one, ';'. The reason being+     -- that this will cause too much breakage for users & ':' will+     -- work fine even with DOS paths, if you're not insisting on being silly.+     -- So, use either.+    splitUp []             = []+    splitUp (x:':':div:xs) | div `elem` dir_markers+                           = ((x:':':div:p): splitUp rs)+                           where+                              (p,rs) = findNextPath xs+          -- we used to check for existence of the path here, but that+          -- required the IO monad to be threaded through the command-line+          -- parser which is quite inconvenient.  The+    splitUp xs = cons p (splitUp rs)+               where+                 (p,rs) = findNextPath xs++                 cons "" xs = xs+                 cons x  xs = x:xs++    -- will be called either when we've consumed nought or the+    -- "<Drive>:/" part of a DOS path, so splitting is just a Q of+    -- finding the next split marker.+    findNextPath xs =+        case break (`elem` split_markers) xs of+           (p, _:ds) -> (p, ds)+           (p, xs)   -> (p, xs)++    split_markers :: [Char]+    split_markers = [':', ';']++    dir_markers :: [Char]+    dir_markers = ['/', '\\']+#endif++-- -----------------------------------------------------------------------------+-- tmpDir, where we store temporary files.++setTmpDir :: FilePath -> DynFlags -> DynFlags+setTmpDir dir d = d { tmpDir = TempDir (normalise dir) }+  -- we used to fix /cygdrive/c/.. on Windows, but this doesn't+  -- seem necessary now --SDM 7/2/2008++-----------------------------------------------------------------------------+-- RTS opts++setRtsOpts :: String -> DynP ()+setRtsOpts arg  = upd $ \ d -> d {rtsOpts = Just arg}++setRtsOptsEnabled :: RtsOptsEnabled -> DynP ()+setRtsOptsEnabled arg  = upd $ \ d -> d {rtsOptsEnabled = arg}++-----------------------------------------------------------------------------+-- Hpc stuff++setOptHpcDir :: String -> DynP ()+setOptHpcDir arg  = upd $ \ d -> d {hpcDir = arg}++-----------------------------------------------------------------------------+-- Via-C compilation stuff++-- There are some options that we need to pass to gcc when compiling+-- Haskell code via C, but are only supported by recent versions of+-- gcc.  The configure script decides which of these options we need,+-- and puts them in the "settings" file in $topdir. The advantage of+-- having these in a separate file is that the file can be created at+-- install-time depending on the available gcc version, and even+-- re-generated later if gcc is upgraded.+--+-- The options below are not dependent on the version of gcc, only the+-- platform.++picCCOpts :: DynFlags -> [String]+picCCOpts dflags =+      case platformOS (targetPlatform dflags) of+      OSDarwin+          -- Apple prefers to do things the other way round.+          -- PIC is on by default.+          -- -mdynamic-no-pic:+          --     Turn off PIC code generation.+          -- -fno-common:+          --     Don't generate "common" symbols - these are unwanted+          --     in dynamic libraries.++       | gopt Opt_PIC dflags -> ["-fno-common", "-U__PIC__", "-D__PIC__"]+       | otherwise           -> ["-mdynamic-no-pic"]+      OSMinGW32 -- no -fPIC for Windows+       | gopt Opt_PIC dflags -> ["-U__PIC__", "-D__PIC__"]+       | otherwise           -> []+      _+      -- we need -fPIC for C files when we are compiling with -dynamic,+      -- otherwise things like stub.c files don't get compiled+      -- correctly.  They need to reference data in the Haskell+      -- objects, but can't without -fPIC.  See+      -- https://gitlab.haskell.org/ghc/ghc/wikis/commentary/position-independent-code+       | gopt Opt_PIC dflags || ways dflags `hasWay` WayDyn ->+          ["-fPIC", "-U__PIC__", "-D__PIC__"] +++          -- Clang defaults to -fvisibility=hidden for wasm targets,+          -- but we need these compile-time flags to generate PIC+          -- objects that can be properly linked by wasm-ld using+          -- --export-dynamic; without these flags we would need+          -- -Wl,--export-all at .so link-time which will export+          -- internal symbols as well, and that severely pollutes the+          -- global symbol namespace.+          (if platformArch (targetPlatform dflags) == ArchWasm32+            then [ "-fvisibility=default", "-fvisibility-inlines-hidden" ]+            else [])+      -- gcc may be configured to have PIC on by default, let's be+      -- explicit here, see #15847+       | otherwise -> ["-fno-PIC"]++pieCCLDOpts :: DynFlags -> [String]+pieCCLDOpts dflags+      | gopt Opt_PICExecutable dflags       = ["-pie"]+        -- See Note [No PIE when linking]+      | toolSettings_ccSupportsNoPie (toolSettings dflags) = ["-no-pie"]+      | otherwise                           = []+++{-+Note [No PIE when linking]+~~~~~~~~~~~~~~~~~~~~~~~~~~+As of 2016 some Linux distributions (e.g. Debian) have started enabling -pie by+default in their gcc builds. This is incompatible with -r as it implies that we+are producing an executable. Consequently, we must manually pass -no-pie to gcc+when joining object files or linking dynamic libraries. Unless, of course, the+user has explicitly requested a PIE executable with -pie. See #12759.+-}++picPOpts :: DynFlags -> [String]+picPOpts dflags+ | gopt Opt_PIC dflags = ["-U__PIC__", "-D__PIC__"]+ | otherwise           = []++-- -----------------------------------------------------------------------------+-- Compiler Info++compilerInfo :: DynFlags -> [(String, String)]+compilerInfo dflags+    = -- We always make "Project name" be first to keep parsing in+      -- other languages simple, i.e. when looking for other fields,+      -- you don't have to worry whether there is a leading '[' or not+      ("Project name",                 cProjectName)+      -- Next come the settings, so anything else can be overridden+      -- in the settings file (as "lookup" uses the first match for the+      -- key)+    : map (fmap $ expandDirectories (topDir dflags) (toolDir dflags))+          (rawSettings dflags)+   ++ [("Project version",             projectVersion dflags),+       ("Project Git commit id",       cProjectGitCommitId),+       ("Project Version Int",         cProjectVersionInt),+       ("Project Patch Level",         cProjectPatchLevel),+       ("Project Patch Level1",        cProjectPatchLevel1),+       ("Project Patch Level2",        cProjectPatchLevel2),+       ("Project Unit Id",             cProjectUnitId),+       ("ghc-internal Unit Id",        cGhcInternalUnitId), -- See Note [Special unit-ids]+       ("Booter version",              cBooterVersion),+       ("Stage",                       cStage),+       ("Build platform",              cBuildPlatformString),+       ("Host platform",               cHostPlatformString),+       ("Target platform",             platformMisc_targetPlatformString $ platformMisc dflags),+       ("target os string",            stringEncodeOS (platformOS (targetPlatform dflags))),+       ("target arch string",          stringEncodeArch (platformArch (targetPlatform dflags))),+       ("target word size in bits",    show (platformWordSizeInBits (targetPlatform dflags))),+       ("Have interpreter",            showBool $ platformMisc_ghcWithInterpreter $ platformMisc dflags),+       ("Object splitting supported",  showBool False),+       ("Have native code generator",  showBool $ platformNcgSupported platform),+       ("target has RTS linker",       showBool $ platformHasRTSLinker platform),+       ("Target default backend",      show     $ platformDefaultBackend platform),+       -- Whether or not we support @-dynamic-too@+       ("Support dynamic-too",         showBool $ not isWindows),+       -- Whether or not we support the @-j@ flag with @--make@.+       ("Support parallel --make",     "YES"),+       -- Whether or not we support "Foo from foo-0.1-XXX:Foo" syntax in+       -- installed package info.+       ("Support reexported-modules",  "YES"),+       -- Whether or not we support extended @-package foo (Foo)@ syntax.+       ("Support thinning and renaming package flags", "YES"),+       -- Whether or not we support Backpack.+       ("Support Backpack", "YES"),+       -- If true, we require that the 'id' field in installed package info+       -- match what is passed to the @-this-unit-id@ flag for modules+       -- built in it+       ("Requires unified installed package IDs", "YES"),+       -- Whether or not we support the @-this-package-key@ flag.  Prefer+       -- "Uses unit IDs" over it. We still say yes even if @-this-package-key@+       -- flag has been removed, otherwise it breaks Cabal...+       ("Uses package keys",           "YES"),+       -- Whether or not we support the @-this-unit-id@ flag+       ("Uses unit IDs",               "YES"),+       -- Whether or not GHC was compiled using -dynamic+       ("GHC Dynamic",                 showBool hostIsDynamic),+       -- Whether or not GHC was compiled using -prof+       ("GHC Profiled",                showBool hostIsProfiled),+       ("Debug on",                    showBool debugIsOn),+       ("LibDir",                      topDir dflags),+       -- This is always an absolute path, unlike "Relative Global Package DB" which is+       -- in the settings file.+       ("Global Package DB",           globalPackageDatabasePath dflags)+      ]+  where+    showBool True  = "YES"+    showBool False = "NO"+    platform  = targetPlatform dflags+    isWindows = platformOS platform == OSMinGW32+    useInplaceMinGW = toolSettings_useInplaceMinGW $ toolSettings dflags+    expandDirectories :: FilePath -> Maybe FilePath -> String -> String+    expandDirectories topd mtoold = expandToolDir useInplaceMinGW mtoold . expandTopDir topd++-- Note [Special unit-ids]+-- ~~~~~~~~~~~~~~~~~~~~~~~+-- Certain units are special to the compiler:+-- - Wired-in identifiers reference a specific unit-id of `ghc-internal`.+-- - GHC plugins must be linked against a specific unit-id of `ghc`,+--   namely the same one as the compiler.+-- - When using Template Haskell, the result of executing splices refer to+--   the Template Haskell ASTs created using constructors from `ghc-internal`,+--   and must be linked against the same `ghc-internal` unit-id as the compiler.+--+-- We therefore expose the unit-id of `ghc-internal` ("ghc-internal Unit Id") and+-- ghc ("Project Unit Id") through `ghc --info`.+--+-- This allows build tools to act accordingly, eg, if a user wishes to build a+-- GHC plugin, `cabal-install` might force them to use the exact `ghc` unit+-- that the compiler was linked against.+-- See:+--  - https://github.com/haskell/cabal/issues/10087+--  - https://github.com/commercialhaskell/stack/issues/6749++{- -----------------------------------------------------------------------------+Note [DynFlags consistency]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~++There are a number of number of DynFlags configurations which either+do not make sense or lead to unimplemented or buggy codepaths in the+compiler. makeDynFlagsConsistent is responsible for verifying the validity+of a set of DynFlags, fixing any issues, and reporting them back to the+caller.++GHCi and -O+---------------++When using optimization, the compiler can introduce several things+(such as unboxed tuples) into the intermediate code, which GHCi later+chokes on since the bytecode interpreter can't handle this (and while+this is arguably a bug these aren't handled, there are no plans to fix+it.)++While the driver pipeline always checks for this particular erroneous+combination when parsing flags, we also need to check when we update+the flags; this is because API clients may parse flags but update the+DynFlags afterwords, before finally running code inside a session (see+T10052 and #10052).++Host ways vs Build ways mismatch+--------------------------------+Many consistency checks aim to fix the situation where the wanted build ways+are not compatible with the ways the compiler is built in. This happens when+using the interpreter, TH, and the runtime linker, where the compiler cannot+load objects compiled for ways not matching its own.++For instance, a profiled-dynamic object can only be loaded by a+profiled-dynamic compiler (and not any other kind of compiler).++This incompatibility is traditionally solved in either of two ways:++(1) Force the "wanted" build ways to match the compiler ways exactly,+    guaranteeing they match.++(2) Force the use of the external interpreter. When interpreting is offloaded+    to the external interpreter it no longer matters what are the host compiler ways.++In the checks and fixes performed by `makeDynFlagsConsistent`, the choice+between the two does not seem uniform. TODO: Make this choice more evident and uniform.+-}++-- | Resolve any internal inconsistencies in a set of 'DynFlags'.+-- Returns the consistent 'DynFlags' as well as a list of warnings+-- to report to the user, and a list of verbose info msgs.+--+-- See Note [DynFlags consistency]+makeDynFlagsConsistent :: DynFlags -> (DynFlags, [Warn], [Located SDoc])+-- Whenever makeDynFlagsConsistent does anything, it starts over, to+-- ensure that a later change doesn't invalidate an earlier check.+-- Be careful not to introduce potential loops!+makeDynFlagsConsistent dflags+ -- Disable -dynamic-too on Windows (#8228, #7134, #5987)+ | os == OSMinGW32 && gopt Opt_BuildDynamicToo dflags+    = let dflags' = gopt_unset dflags Opt_BuildDynamicToo+          warn    = "-dynamic-too is not supported on Windows"+      in loop dflags' warn+ -- Disable -dynamic-too if we are are compiling with -dynamic already, otherwise+ -- you get two dynamic object files (.o and .dyn_o). (#20436)+ | ways dflags `hasWay` WayDyn && gopt Opt_BuildDynamicToo dflags+    = let dflags' = gopt_unset dflags Opt_BuildDynamicToo+          warn = "-dynamic-too is ignored when using -dynamic"+      in loop dflags' warn++ | gopt Opt_SplitSections dflags+ , platformHasSubsectionsViaSymbols (targetPlatform dflags)+    = let dflags' = gopt_unset dflags Opt_SplitSections+          warn = "-fsplit-sections is not useful on this platform " +++                 "since it uses subsections-via-symbols. Ignoring."+      in loop dflags' warn++   -- Via-C backend only supports unregisterised ABI. Switch to a backend+   -- supporting it if possible.+ | backendUnregisterisedAbiOnly (backend dflags) &&+   not (platformUnregisterised (targetPlatform dflags))+    = let b = platformDefaultBackend (targetPlatform dflags)+      in if backendSwappableWithViaC b then+           let dflags' = dflags { backend = b }+               warn = "Target platform doesn't use unregisterised ABI, so using " +++                      backendDescription b ++ " rather than " +++                      backendDescription (backend dflags)+           in loop dflags' warn+         else+           pgmError (backendDescription (backend dflags) +++                     " supports only unregisterised ABI but target platform doesn't use it.")++ | gopt Opt_Hpc dflags && not (backendSupportsHpc (backend dflags))+    = let dflags' = gopt_unset dflags Opt_Hpc+          warn = "Hpc can't be used with " ++ backendDescription (backend dflags) +++                 ". Ignoring -fhpc."+      in loop dflags' warn++ | backendSwappableWithViaC (backend dflags) &&+   platformUnregisterised (targetPlatform dflags)+    = loop (dflags { backend = viaCBackend })+           "Target platform uses unregisterised ABI, so compiling via C"++ | backendNeedsPlatformNcgSupport (backend dflags) &&+   not (platformNcgSupported $ targetPlatform dflags)+      = let dflags' = dflags { backend = llvmBackend }+            warn = "Native code generator doesn't support target platform, so using LLVM"+        in loop dflags' warn++ | not (osElfTarget os) && gopt Opt_PIE dflags+    = loop (gopt_unset dflags Opt_PIE)+           "Position-independent only supported on ELF platforms"+ | os == OSDarwin &&+   arch == ArchX86_64 &&+   not (gopt Opt_PIC dflags)+    = loop (gopt_set dflags Opt_PIC)+           "Enabling -fPIC as it is always on for this platform"++ | backendForcesOptimization0 (backend dflags)+ , gopt Opt_UnoptimizedCoreForInterpreter dflags+ , let (dflags', changed) = updOptLevelChanged 0 dflags+ , changed+    = loop dflags' $+      "Ignoring optimization flags since they are experimental for the " +++      backendDescription (backend dflags) +++      ". Pass -fno-unoptimized-core-for-interpreter to enable this feature."++ | LinkInMemory <- ghcLink dflags+ , not (gopt Opt_ExternalInterpreter dflags)+ , hostIsProfiled+ , backendWritesFiles (backend dflags)+ , ways dflags `hasNotWay` WayProf+    = loop dflags{targetWays_ = addWay WayProf (targetWays_ dflags)}+         "Enabling -prof, because -fobject-code is enabled and GHCi is profiled"++ | gopt Opt_ByteCode dflags || gopt Opt_ByteCodeAndObjectCode dflags+ , not (gopt Opt_ExternalInterpreter dflags)+ , hostIsProfiled+ , ways dflags `hasNotWay` WayProf+    = loop (gopt_set dflags Opt_ExternalInterpreter)+         "Enabling external interpreter, because GHC is profiled and bytecode is being used for TH"++ | LinkMergedObj <- ghcLink dflags+ , Nothing <- outputFile dflags+    = pgmError "--output must be specified when using --merge-objs"++ | platformTablesNextToCode platform+   && os == OSMinGW32+   && arch == ArchAArch64+    = case backendCodeOutput (backend dflags) of+        LlvmCodeOutput -> pgmError "-fllvm is incompatible with enabled TablesNextToCode at Windows Aarch64"+        NcgCodeOutput -> pgmError "-fasm is incompatible with enabled TablesNextToCode at Windows Aarch64"+        _ -> (dflags, mempty, mempty)++  -- When we do ghci, force using dyn ways if the target RTS linker+  -- only supports dynamic code+ | LinkInMemory <- ghcLink dflags+ , sTargetRTSLinkerOnlySupportsSharedLibs $ settings dflags+ , not (ways dflags `hasWay` WayDyn && gopt Opt_ExternalInterpreter dflags)+    = flip loopNoWarn "Forcing dynamic way because target RTS linker only supports dynamic code" $+        -- See checkOptions, -fexternal-interpreter is+        -- required when using --interactive with a non-standard+        -- way (-prof, -static, or -dynamic).+        setGeneralFlag' Opt_ExternalInterpreter $+        addWay' WayDyn dflags++ | LinkInMemory <- ghcLink dflags+ , not (gopt Opt_ExternalInterpreter dflags)+ , targetWays_ dflags /= hostFullWays+    = flip loopNoWarn "Forcing build ways to match the compiler ways because we're using the internal interpreter" $+        let dflags_a = dflags { targetWays_ = hostFullWays }+            dflags_b = foldl gopt_set dflags_a+                     $ concatMap (wayGeneralFlags platform)+                                 hostFullWays+            dflags_c = foldl gopt_unset dflags_b+                     $ concatMap (wayUnsetGeneralFlags platform)+                                 hostFullWays+        in dflags_c++ | otherwise = (dflags, mempty, mempty)+    where loc = mkGeneralSrcSpan (fsLit "when making flags consistent")+          loop updated_dflags warning+              = case makeDynFlagsConsistent updated_dflags of+                (dflags', ws, is) -> (dflags', L loc (DriverInconsistentDynFlags warning) : ws, is)+          loopNoWarn updated_dflags doc+              = case makeDynFlagsConsistent updated_dflags of+                (dflags', ws, is) -> (dflags', ws, L loc (text doc):is)+          platform = targetPlatform dflags+          arch = platformArch platform+          os   = platformOS   platform+++setUnsafeGlobalDynFlags :: DynFlags -> IO ()+setUnsafeGlobalDynFlags dflags = do+   writeIORef v_unsafeHasPprDebug (hasPprDebug dflags)+   writeIORef v_unsafeHasNoDebugOutput (hasNoDebugOutput dflags)+   writeIORef v_unsafeHasNoStateHack (hasNoStateHack dflags)+++-- -----------------------------------------------------------------------------++-- | Indicate if cost-centre profiling is enabled+sccProfilingEnabled :: DynFlags -> Bool+sccProfilingEnabled dflags = profileIsProfiling (targetProfile dflags)++-- | Indicate whether we need to generate source notes+needSourceNotes :: DynFlags -> Bool+needSourceNotes dflags = debugLevel dflags > 0+                       || gopt Opt_InfoTableMap dflags++                       -- Source ticks are used to approximate the location of+                       -- overloaded call cost centers+                       || gopt Opt_ProfLateoverloadedCallsCCs dflags++-- -----------------------------------------------------------------------------+-- Linker/compiler information++-- | Should we use `-XLinker -rpath` when linking or not?+-- See Note [-fno-use-rpaths]+useXLinkerRPath :: DynFlags -> OS -> Bool+-- wasm shared libs don't have RPATH at all and wasm-ld doesn't accept+-- any RPATH-related flags+useXLinkerRPath dflags _ | ArchWasm32 <- platformArch $ targetPlatform dflags = False+useXLinkerRPath _ OSDarwin = False -- See Note [Dynamic linking on macOS]+useXLinkerRPath dflags _ = gopt Opt_RPath dflags++{-+Note [-fno-use-rpaths]+~~~~~~~~~~~~~~~~~~~~~~++First read, Note [Dynamic linking on macOS] to understand why on darwin we never+use `-XLinker -rpath`.++The specification of `Opt_RPath` is as follows:++The default case `-fuse-rpaths`:+* On darwin, never use `-Xlinker -rpath -Xlinker`, always inject the rpath+  afterwards, see `runInjectRPaths`. There is no way to use `-Xlinker` on darwin+  as things stand but it wasn't documented in the user guide before this patch how+  `-fuse-rpaths` should behave and the fact it was always disabled on darwin.+* Otherwise, use `-Xlinker -rpath -Xlinker` to set the rpath of the executable,+  this is the normal way you should set the rpath.++The case of `-fno-use-rpaths`+* Never inject anything into the rpath.++When this was first implemented, `Opt_RPath` was disabled on darwin, but+the rpath was still always augmented by `runInjectRPaths`, and there was no way to+stop this. This was problematic because you couldn't build an executable in CI+with a clean rpath.++-}++-- -----------------------------------------------------------------------------+-- RTS hooks++-- Convert sizes like "3.5M" into integers+decodeSize :: String -> Integer+decodeSize str+  | c == ""      = truncate n+  | c == "K" || c == "k" = truncate (n * 1000)+  | c == "M" || c == "m" = truncate (n * 1000 * 1000)+  | c == "G" || c == "g" = truncate (n * 1000 * 1000 * 1000)+  | otherwise            = throwGhcException (CmdLineError ("can't decode size: " ++ str))+  where (m, c) = span pred str+        n      = readRational m+        pred c = isDigit c || c == '.'++foreign import ccall unsafe "setHeapSize"       setHeapSize       :: Int -> IO ()+foreign import ccall unsafe "enableTimingStats" enableTimingStats :: IO ()++outputFile :: DynFlags -> Maybe String+outputFile dflags+   | dynamicNow dflags = dynOutputFile_ dflags+   | otherwise         = outputFile_    dflags++objectSuf :: DynFlags -> String+objectSuf dflags+   | dynamicNow dflags = dynObjectSuf_ dflags+   | otherwise         = objectSuf_    dflags  -- | Pretty-print the difference between 2 DynFlags. --
+ GHC/Driver/Session/Inspect.hs view
@@ -0,0 +1,201 @@+{-# LANGUAGE LambdaCase #-}++-- | GHC API utilities for inspecting the GHC session+module GHC.Driver.Session.Inspect where++import GHC.Prelude+import GHC.Data.Maybe+import Control.Monad++import GHC.ByteCode.Types+import GHC.Core.FamInstEnv+import GHC.Core.InstEnv+import GHC.Driver.Env+import GHC.Driver.Main+import GHC.Driver.Monad+import GHC.Driver.Session+import GHC.Rename.Names+import GHC.Runtime.Context+import GHC.Runtime.Interpreter+import GHC.Types.Avail+import GHC.Types.Name+import GHC.Types.Name.Ppr+import GHC.Types.Name.Reader+import GHC.Types.Name.Set+import GHC.Types.PkgQual+import GHC.Types.SafeHaskell+import GHC.Types.SrcLoc+import GHC.Types.TyThing+import GHC.Types.TypeEnv+import GHC.Unit.External+import GHC.Unit.Home.ModInfo+import GHC.Unit.Module+import GHC.Unit.Module.Graph+import GHC.Unit.Module.ModDetails+import GHC.Unit.Module.ModIface+import GHC.Utils.Misc+import GHC.Utils.Outputable+import qualified GHC.Unit.Home.Graph as HUG++-- %************************************************************************+-- %*                                                                      *+--             Inspecting the session+-- %*                                                                      *+-- %************************************************************************++-- | Get the module dependency graph.+getModuleGraph :: GhcMonad m => m ModuleGraph -- ToDo: DiGraph ModSummary+getModuleGraph = liftM hsc_mod_graph getSession++{-# DEPRECATED isLoaded "Prefer 'isLoadedModule' and 'isLoadedHomeModule'" #-}+-- | Return @True@ \<==> module is loaded.+isLoaded :: GhcMonad m => ModuleName -> m Bool+isLoaded m = withSession $ \hsc_env -> liftIO $ do+  hmis <- HUG.lookupAllHug (hsc_HUG hsc_env) m+  return $! not (null hmis)++-- | Check whether a 'ModuleName' is found in the 'HomePackageTable'+-- for the given 'UnitId'.+isLoadedModule :: GhcMonad m => UnitId -> ModuleName -> m Bool+isLoadedModule uid m = withSession $ \hsc_env -> liftIO $ do+  hmi <- HUG.lookupHug (hsc_HUG hsc_env) uid m+  return $! isJust hmi++-- | Check whether 'Module' is part of the 'HomeUnitGraph'.+--+-- Similar to 'isLoadedModule', but for 'Module's.+isLoadedHomeModule :: GhcMonad m => Module -> m Bool+isLoadedHomeModule m = withSession $ \hsc_env -> liftIO $ do+  hmi <- HUG.lookupHugByModule m (hsc_HUG hsc_env)+  return $! isJust hmi++-- | Return the bindings for the current interactive session.+getBindings :: GhcMonad m => m [TyThing]+getBindings = withSession $ \hsc_env ->+    return $ icInScopeTTs $ hsc_IC hsc_env++-- | Return the instances for the current interactive session.+getInsts :: GhcMonad m => m ([ClsInst], [FamInst])+getInsts = withSession $ \hsc_env ->+    let (inst_env, fam_env) = ic_instances (hsc_IC hsc_env)+    in return (instEnvElts inst_env, fam_env)++getNamePprCtx :: GhcMonad m => m NamePprCtx+getNamePprCtx = withSession $ \hsc_env -> do+  return $ icNamePprCtx (hsc_unit_env hsc_env) (hsc_IC hsc_env)++-- | Container for information about a 'Module'.+data ModuleInfo = ModuleInfo {+        minf_type_env  :: TypeEnv,+        minf_exports   :: [AvailInfo],+        minf_instances :: [ClsInst],+        minf_iface     :: Maybe ModIface,+        minf_safe      :: SafeHaskellMode,+        minf_modBreaks :: Maybe InternalModBreaks+  }+        -- We don't want HomeModInfo here, because a ModuleInfo applies+        -- to package modules too.++-- | Request information about a loaded 'Module'+getModuleInfo :: GhcMonad m => Module -> m (Maybe ModuleInfo)  -- XXX: Maybe X+getModuleInfo mdl = withSession $ \hsc_env -> do+  if HUG.memberHugUnit (moduleUnit mdl) (hsc_HUG hsc_env)+        then liftIO $ getHomeModuleInfo hsc_env mdl+        else liftIO $ getPackageModuleInfo hsc_env mdl++getPackageModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo)+getPackageModuleInfo hsc_env mdl+  = do  eps <- hscEPS hsc_env+        iface <- hscGetModuleInterface hsc_env mdl+        let+            avails = mi_exports iface+            pte    = eps_PTE eps+            tys    = [ ty | name <- concatMap availNames avails,+                            Just ty <- [lookupTypeEnv pte name] ]++        return (Just (ModuleInfo {+                        minf_type_env  = mkTypeEnv tys,+                        minf_exports   = avails,+                        minf_instances = error "getModuleInfo: instances for package module unimplemented",+                        minf_iface     = Just iface,+                        minf_safe      = getSafeMode $ mi_trust iface,+                        minf_modBreaks = Nothing+                }))++availsToGlobalRdrEnv :: HasDebugCallStack => HscEnv -> Module -> [AvailInfo] -> IfGlobalRdrEnv+availsToGlobalRdrEnv hsc_env mod avails+  = forceGlobalRdrEnv rdr_env+    -- See Note [Forcing GREInfo] in GHC.Types.GREInfo.+  where+    rdr_env = mkGlobalRdrEnv (gresFromAvails hsc_env (Just imp_spec) avails)+      -- We're building a GlobalRdrEnv as if the user imported+      -- all the specified modules into the global interactive module+    imp_spec = ImpSpec { is_decl = decl, is_item = ImpAll}+    decl = ImpDeclSpec { is_mod = mod, is_as = moduleName mod,+                         is_qual = False, is_isboot = NotBoot, is_pkg_qual = NoPkgQual,+                         is_dloc = srcLocSpan interactiveSrcLoc,+                         is_level = NormalLevel }++getHomeModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo)+getHomeModuleInfo hsc_env mdl =+  HUG.lookupHugByModule mdl (hsc_HUG hsc_env) >>= \case+    Nothing  -> return Nothing+    Just hmi -> do+      let details  = hm_details hmi+          iface    = hm_iface hmi+      return (Just (ModuleInfo {+                        minf_type_env  = md_types details,+                        minf_exports   = md_exports details,+                         -- NB: already forced. See Note [Forcing GREInfo] in GHC.Types.GREInfo.+                        minf_instances = instEnvElts $ md_insts details,+                        minf_iface     = Just iface,+                        minf_safe      = getSafeMode $ mi_trust iface,+                        minf_modBreaks = getModBreaks hmi+                        }))++-- | The list of top-level entities defined in a module+modInfoTyThings :: ModuleInfo -> [TyThing]+modInfoTyThings minf = typeEnvElts (minf_type_env minf)++modInfoExports :: ModuleInfo -> [Name]+modInfoExports minf = concatMap availNames $! minf_exports minf++modInfoExportsWithSelectors :: ModuleInfo -> [Name]+modInfoExportsWithSelectors minf = concatMap availNames $! minf_exports minf++-- | Returns the instances defined by the specified module.+-- Warning: currently unimplemented for package modules.+modInfoInstances :: ModuleInfo -> [ClsInst]+modInfoInstances = minf_instances++modInfoIsExportedName :: ModuleInfo -> Name -> Bool+modInfoIsExportedName minf name = elemNameSet name (availsToNameSet (minf_exports minf))++mkNamePprCtxForModule ::+  GhcMonad m =>+  Module     ->+  ModuleInfo ->+  m NamePprCtx+mkNamePprCtxForModule mod minf = withSession $ \hsc_env -> do+  let name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env) (availsToGlobalRdrEnv hsc_env mod (minf_exports minf))+      ptc = initPromotionTickContext (hsc_dflags hsc_env)+  return name_ppr_ctx++modInfoLookupName :: GhcMonad m =>+                     ModuleInfo -> Name+                  -> m (Maybe TyThing) -- XXX: returns a Maybe X+modInfoLookupName minf name = withSession $ \hsc_env -> do+   case lookupTypeEnv (minf_type_env minf) name of+     Just tyThing -> return (Just tyThing)+     Nothing      -> liftIO (lookupType hsc_env name)++modInfoIface :: ModuleInfo -> Maybe ModIface+modInfoIface = minf_iface++-- | Retrieve module safe haskell mode+modInfoSafe :: ModuleInfo -> SafeHaskellMode+modInfoSafe = minf_safe++modInfoModBreaks :: ModuleInfo -> Maybe InternalModBreaks+modInfoModBreaks = minf_modBreaks+
+ GHC/Driver/Session/Units.hs view
@@ -0,0 +1,249 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NondecreasingIndentation #-}+{-# LANGUAGE TupleSections #-}+module GHC.Driver.Session.Units (initMake, initMulti) where++-- The official GHC API+import qualified GHC+import GHC              (parseTargetFiles, Ghc, GhcMonad(..))++import GHC.Driver.Env+import GHC.Driver.Errors+import GHC.Driver.Errors.Types+import GHC.Driver.Phases+import GHC.Driver.Session+import GHC.Driver.Ppr+import GHC.Driver.Pipeline  ( oneShot, compileFile )+import GHC.Driver.Config.Diagnostic++import GHC.Unit.Env+import GHC.Unit (UnitId)+import GHC.Unit.Home.PackageTable+import qualified GHC.Unit.Home.Graph as HUG+import GHC.Unit.State  ( emptyUnitState )+import qualified GHC.Unit.State as State++import GHC.Types.SrcLoc+import GHC.Types.SourceError++import GHC.Utils.Misc+import GHC.Utils.Panic+import GHC.Utils.Outputable as Outputable+import GHC.Utils.Monad       ( liftIO, mapMaybeM )+import GHC.Data.Maybe++import System.IO+import System.Exit+import System.FilePath+import Control.Monad+import Data.List ( partition, (\\) )+import qualified Data.Set as Set+import Prelude+import GHC.ResponseFile (expandResponse)+import Data.Bifunctor+import GHC.Data.Graph.Directed+import qualified Data.List.NonEmpty as NE++-- Strip out any ["+RTS", ..., "-RTS"] sequences in the command string list.+removeRTS :: [String] -> [String]+removeRTS ("+RTS" : xs)  =+  case dropWhile (/= "-RTS") xs of+    [] -> []+    (_ : ys) -> removeRTS ys+removeRTS (y:ys)         = y : removeRTS ys+removeRTS []             = []++initMake :: [(String,Maybe Phase)] -> Ghc [(String, Maybe Phase)]+initMake srcs  = do+    let (hs_srcs, non_hs_srcs) = partition isHaskellishTarget srcs++    hsc_env <- GHC.getSession++    -- if we have no haskell sources from which to do a dependency+    -- analysis, then just do one-shot compilation and/or linking.+    -- This means that "ghc Foo.o Bar.o -o baz" links the program as+    -- we expect.+    if (null hs_srcs)+       then liftIO (oneShot hsc_env NoStop srcs) >> return []+       else do++    o_files <- mapMaybeM (\x -> liftIO $ compileFile hsc_env NoStop x)+                 non_hs_srcs+    dflags <- GHC.getSessionDynFlags+    let dflags' = dflags { ldInputs = map (FileOption "") o_files+                                      ++ ldInputs dflags }+    _ <- GHC.setSessionDynFlags dflags'+    return hs_srcs++initMulti :: NE.NonEmpty String+          -> (DynFlags -> [(String,Maybe Phase)] -> [String] -> [String] -> IO ())+          -- ^ Function to lint initMulti DynFlags and sources.+          -- In GHC, this is instanced to @checkOptions@.+          -> Ghc ([(String, Maybe UnitId, Maybe Phase)])+initMulti unitArgsFiles lintDynFlagsAndSrcs = do+  hsc_env <- GHC.getSession+  let logger = hsc_logger hsc_env+  initial_dflags <- GHC.getSessionDynFlags++  dynFlagsAndSrcs <- forM unitArgsFiles $ \f -> do+    when (verbosity initial_dflags > 2) (liftIO $ print f)+    args <- liftIO $ expandResponse [f]+    (dflags2, fileish_args, warns) <- parseDynamicFlagsCmdLine logger initial_dflags (map (mkGeneralLocated f) (removeRTS args))+    handleSourceError (\e -> do+       GHC.printException e+       liftIO $ exitWith (ExitFailure 1)) $ do+         liftIO $ printOrThrowDiagnostics logger (initPrintConfig dflags2) (initDiagOpts dflags2) (GhcDriverMessage <$> warns)++    let (dflags3, srcs, objs) = parseTargetFiles dflags2 (map unLoc fileish_args)+        dflags4 = offsetDynFlags dflags3++    let (hs_srcs, non_hs_srcs) = partition isHaskellishTarget srcs++    -- This is dubious as the whole unit environment won't be set-up correctly, but+    -- that doesn't matter for what we use it for (linking and oneShot)+    let dubious_hsc_env = hscSetFlags dflags4 hsc_env+    -- if we have no haskell sources from which to do a dependency+    -- analysis, then just do one-shot compilation and/or linking.+    -- This means that "ghc Foo.o Bar.o -o baz" links the program as+    -- we expect.+    if (null hs_srcs)+       then liftIO (oneShot dubious_hsc_env NoStop srcs) >> return (dflags4, [])+       else do++    o_files <- mapMaybeM (\x -> liftIO $ compileFile dubious_hsc_env NoStop x)+                 non_hs_srcs+    let dflags5 = dflags4 { ldInputs = map (FileOption "") o_files+                                      ++ ldInputs dflags4 }++    liftIO $ lintDynFlagsAndSrcs dflags5 srcs objs []++    pure (dflags5, hs_srcs)++  let+    unitDflags = NE.map fst dynFlagsAndSrcs+    srcs = NE.map (\(dflags, lsrcs) -> map (uncurry (,Just $ homeUnitId_ dflags,)) lsrcs) dynFlagsAndSrcs+    (hs_srcs, _non_hs_srcs) = unzip (map (partition (\(file, _uid, phase) -> isHaskellishTarget (file, phase))) (NE.toList srcs))++  checkDuplicateUnits initial_dflags (NE.toList (NE.zip unitArgsFiles unitDflags))++  (initial_home_graph, mainUnitId) <- liftIO $ createUnitEnvFromFlags unitDflags+  let home_units = HUG.allUnits initial_home_graph++  home_unit_graph <- forM initial_home_graph $ \homeUnitEnv -> do+    let cached_unit_dbs = homeUnitEnv_unit_dbs homeUnitEnv+        hue_flags = homeUnitEnv_dflags homeUnitEnv+        dflags = homeUnitEnv_dflags homeUnitEnv+    (dbs,unit_state,home_unit,mconstants) <- liftIO $ State.initUnits logger hue_flags cached_unit_dbs home_units++    updated_dflags <- liftIO $ updatePlatformConstants dflags mconstants+    emptyHpt <- liftIO $ emptyHomePackageTable+    pure $ HomeUnitEnv+      { homeUnitEnv_units = unit_state+      , homeUnitEnv_unit_dbs = Just dbs+      , homeUnitEnv_dflags = updated_dflags+      , homeUnitEnv_hpt = emptyHpt+      , homeUnitEnv_home_unit = Just home_unit+      }++  checkUnitCycles initial_dflags home_unit_graph++  let dflags = homeUnitEnv_dflags $ HUG.unitEnv_lookup mainUnitId home_unit_graph+  unitEnv <- assertUnitEnvInvariant <$> (liftIO $ initUnitEnv mainUnitId home_unit_graph (ghcNameVersion dflags) (targetPlatform dflags))+  let final_hsc_env = hsc_env { hsc_unit_env = unitEnv }++  GHC.setSession final_hsc_env++  -- if we have no haskell sources from which to do a dependency+  -- analysis, then just do one-shot compilation and/or linking.+  -- This means that "ghc Foo.o Bar.o -o baz" links the program as+  -- we expect.+  if (null hs_srcs)+      then do+        liftIO $ hPutStrLn stderr $ "Multi Mode can not be used for one-shot mode."+        liftIO $ exitWith (ExitFailure 1)+      else do++{-+  o_files <- liftIO $ mapMaybeM+                (\(src, uid, mphase) ->+                  compileFile (hscSetActiveHomeUnit (ue_unitHomeUnit (fromJust uid) unitEnv) final_hsc_env) NoStop (src, mphase)+                )+                (concat non_hs_srcs)+                -}++  -- MP: This should probably modify dflags for each unit?+  --let dflags' = dflags { ldInputs = map (FileOption "") o_files+  --                                  ++ ldInputs dflags }+  return $ concat hs_srcs++checkUnitCycles :: DynFlags -> HUG.HomeUnitGraph -> Ghc ()+checkUnitCycles dflags graph = processSCCs (HUG.hugSCCs graph)+  where++    processSCCs [] = return ()+    processSCCs (AcyclicSCC _: other_sccs) = processSCCs other_sccs+    processSCCs (CyclicSCC uids: _) = throwGhcException $ CmdLineError $ showSDoc dflags (cycle_err uids)+++    cycle_err uids =+      hang (text "Units form a dependency cycle:")+           2+           (one_err uids)++    one_err uids = vcat $+                    (map (\uid -> text "-" <+> ppr uid <+> text "depends on") start)+                    ++ [text "-" <+> ppr final]+      where+        start = init uids+        final = last uids++-- | Check that we don't have multiple units with the same UnitId.+checkDuplicateUnits :: DynFlags -> [(FilePath, DynFlags)] -> Ghc ()+checkDuplicateUnits dflags flags =+  unless (null duplicate_ids)+         (throwGhcException $ CmdLineError $ showSDoc dflags multi_err)++  where+    uids = map (second homeUnitId_) flags+    deduplicated_uids = ordNubOn snd uids+    duplicate_ids = Set.fromList (map snd uids \\ map snd deduplicated_uids)++    duplicate_flags = filter (flip Set.member duplicate_ids . snd) uids++    one_err (fp, home_uid) = text "-" <+> ppr home_uid <+> text "defined in" <+> text fp++    multi_err =+      hang (text "Multiple units with the same unit-id:")+           2+           (vcat (map one_err duplicate_flags))+++offsetDynFlags :: DynFlags -> DynFlags+offsetDynFlags dflags =+  dflags { hiDir = c hiDir+         , objectDir  = c objectDir+         , stubDir = c stubDir+         , hieDir  = c hieDir+         , dumpDir = c dumpDir  }++  where+    c f = augment_maybe (f dflags)++    augment_maybe Nothing = Nothing+    augment_maybe (Just f) = Just (augment f)+    augment f | isRelative f, Just offset <- workingDirectory dflags = offset </> f+              | otherwise = f+++createUnitEnvFromFlags :: NE.NonEmpty DynFlags -> IO (HomeUnitGraph, UnitId)+createUnitEnvFromFlags unitDflags = do+  unitEnvList <- forM unitDflags $ \dflags -> do+    emptyHpt <- emptyHomePackageTable+    let newInternalUnitEnv =+          HUG.mkHomeUnitEnv emptyUnitState Nothing dflags emptyHpt Nothing+    return (homeUnitId_ dflags, newInternalUnitEnv)+  let activeUnit = fst $ NE.head unitEnvList+  return (HUG.hugFromList (NE.toList unitEnvList), activeUnit)++
GHC/Hs.hs view
@@ -9,6 +9,7 @@ therefore, is almost nothing but re-exporting. -} +{-# OPTIONS_GHC -Wno-orphans    #-} -- Outputable {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE FlexibleContexts #-}@@ -17,6 +18,7 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleInstances #-} -- For deriving instance Data+{-# LANGUAGE DataKinds #-}  module GHC.Hs (         module Language.Haskell.Syntax,@@ -34,7 +36,7 @@         Fixity,          HsModule(..), AnnsModule(..),-        HsParsedModule(..)+        HsParsedModule(..), XModulePs(..) ) where  -- friends:@@ -58,92 +60,67 @@ import GHC.Utils.Outputable import GHC.Types.Fixity         ( Fixity ) import GHC.Types.SrcLoc-import GHC.Unit.Module          ( ModuleName )-import GHC.Unit.Module.Warnings ( WarningTxt )+import GHC.Unit.Module.Warnings  -- libraries: import Data.Data hiding ( Fixity ) --- | Haskell Module------ All we actually declare here is the top-level structure for a module.-data HsModule-  =  -- | 'GHC.Parser.Annotation.AnnKeywordId's-     ---     --  - 'GHC.Parser.Annotation.AnnModule','GHC.Parser.Annotation.AnnWhere'-     ---     --  - 'GHC.Parser.Annotation.AnnOpen','GHC.Parser.Annotation.AnnSemi',-     --    'GHC.Parser.Annotation.AnnClose' for explicit braces and semi around-     --    hsmodImports,hsmodDecls if this style is used.--     -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation-    HsModule {+-- | Haskell Module extension point: GHC specific+data XModulePs+  = XModulePs {       hsmodAnn :: EpAnn AnnsModule,-      hsmodLayout :: LayoutInfo,+      hsmodLayout :: EpLayout,         -- ^ Layout info for the module.-        -- For incomplete modules (e.g. the output of parseHeader), it is NoLayoutInfo.-      hsmodName :: Maybe (LocatedA ModuleName),-        -- ^ @Nothing@: \"module X where\" is omitted (in which case the next-        --     field is Nothing too)-      hsmodExports :: Maybe (LocatedL [LIE GhcPs]),-        -- ^ Export list-        ---        --  - @Nothing@: export list omitted, so export everything-        ---        --  - @Just []@: export /nothing/-        ---        --  - @Just [...]@: as you would expect...-        ---        ---        --  - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnOpen'-        --                                   ,'GHC.Parser.Annotation.AnnClose'--        -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation-      hsmodImports :: [LImportDecl GhcPs],-        -- ^ We snaffle interesting stuff out of the imported interfaces early-        -- on, adding that info to TyDecls/etc; so this list is often empty,-        -- downstream.-      hsmodDecls :: [LHsDecl GhcPs],-        -- ^ Type, class, value, and interface signature decls-      hsmodDeprecMessage :: Maybe (LocatedP (WarningTxt GhcPs)),+        -- For incomplete modules (e.g. the output of parseHeader), it is EpNoLayout.+      hsmodDeprecMessage :: Maybe (LWarningTxt GhcPs),         -- ^ reason\/explanation for warning/deprecation of this module-        ---        --  - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnOpen'-        --                                   ,'GHC.Parser.Annotation.AnnClose'-        ----        -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation       hsmodHaddockModHeader :: Maybe (LHsDoc GhcPs)         -- ^ Haddock module info and description, unparsed-        ---        --  - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnOpen'-        --                                   ,'GHC.Parser.Annotation.AnnClose'--        -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation    }+   deriving Data -deriving instance Data HsModule+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_main :: [AddEpAnn],-    am_decls :: AnnList+    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 Outputable HsModule where+instance NoAnn AnnsModule where+  noAnn = AnnsModule NoEpTok NoEpTok NoEpTok [] [] Nothing -    ppr (HsModule _ _ Nothing _ imports decls _ mbDoc)+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 _ _ (Just name) exports imports decls deprec mbDoc)+    ppr (HsModule { hsmodExt = XModulePs { hsmodDeprecMessage = deprec+                                         , hsmodHaddockModHeader = mbDoc }+                  , hsmodName = (Just name)+                  , hsmodExports = exports+                  , hsmodImports = imports+                  , hsmodDecls = decls })       = pprMaybeWithDoc mbDoc $         vcat           [ case exports of               Nothing -> pp_header (text "where")               Just es -> vcat [                            pp_header lparen,-                           nest 8 (fsep (punctuate comma (map ppr (unLoc es)))),+                           nest 8 (pprWithCommas ppr (unLoc es)),                            nest 4 (text ") where")                           ],             pp_nonnull imports,@@ -161,7 +138,7 @@ pp_nonnull xs = vcat (map ppr xs)  data HsParsedModule = HsParsedModule {-    hpm_module    :: Located HsModule,+    hpm_module    :: Located (HsModule GhcPs),     hpm_src_files :: [FilePath]        -- ^ extra source files (e.g. from #includes).  The lexer collects        -- these from '# <file> <line>' pragmas, which the C preprocessor
+ GHC/Hs/Basic.hs view
@@ -0,0 +1,56 @@+{-# OPTIONS_GHC -Wno-orphans #-} -- Outputable, Binary+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DeriveDataTypeable #-}++-- | Fixity+module GHC.Hs.Basic+   ( module Language.Haskell.Syntax.Basic+   ) where++import GHC.Prelude++import GHC.Utils.Outputable+import GHC.Utils.Binary++import Data.Data ()++import Language.Haskell.Syntax.Basic++instance Outputable LexicalFixity where+  ppr Prefix = text "Prefix"+  ppr Infix  = text "Infix"++instance Outputable FixityDirection where+    ppr InfixL = text "infixl"+    ppr InfixR = text "infixr"+    ppr InfixN = text "infix"++instance Outputable Fixity where+    ppr (Fixity prec dir) = hcat [ppr dir, space, int prec]+++instance Binary Fixity where+    put_ bh (Fixity aa ab) = do+            put_ bh aa+            put_ bh ab+    get bh = do+          aa <- get bh+          ab <- get bh+          return (Fixity aa ab)++------------------------++instance Binary FixityDirection where+    put_ bh InfixL =+            putByte bh 0+    put_ bh InfixR =+            putByte bh 1+    put_ bh InfixN =+            putByte bh 2+    get bh = do+            h <- getByte bh+            case h of+              0 -> return InfixL+              1 -> return InfixR+              _ -> return InfixN
GHC/Hs/Binds.hs view
@@ -1,5 +1,7 @@+{-# 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 #-}@@ -24,16 +26,20 @@ 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, pprFunBind, pprPatBind )+import {-# SOURCE #-} GHC.Hs.Expr ( pprExpr, pprLExpr, pprFunBind, pprPatBind ) import {-# SOURCE #-} GHC.Hs.Pat  (pprLPat ) -import Language.Haskell.Syntax.Extension+import GHC.Data.BooleanFormula ( LBooleanFormula, pprBooleanFormulaNormal )+import GHC.Types.Tickish import GHC.Hs.Extension import GHC.Parser.Annotation import GHC.Hs.Type@@ -44,13 +50,11 @@ import GHC.Types.SourceText import GHC.Types.SrcLoc as SrcLoc import GHC.Types.Var-import GHC.Data.Bag-import GHC.Data.BooleanFormula (LBooleanFormula)-import GHC.Types.Name.Reader import GHC.Types.Name  import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Misc ((<||>))  import Data.Function import Data.List (sortBy)@@ -66,11 +70,11 @@ Global bindings (where clauses) -} --- the ...LR datatypes are parametrized by two id types,+-- 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-type instance XHsIPBinds       (GhcPass pL) (GhcPass pR) = EpAnn AnnList+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 @@ -83,7 +87,7 @@       [(RecFlag, LHsBinds idL)]       [LSig GhcRn] -type instance XValBinds    (GhcPass pL) (GhcPass pR) = AnnSortKey+type instance XValBinds    (GhcPass pL) (GhcPass pR) = AnnSortKey BindTag type instance XXValBindsLR (GhcPass pL) pR             = NHsValBindsLR (GhcPass pL) @@ -95,9 +99,10 @@ -- extension field contains the locally-bound free variables of this -- defn. See Note [Bind free vars] -type instance XFunBind    (GhcPass pL) GhcTc = HsWrapper--- ^ After the type-checker, the FunBind extension field contains a--- coercion from the type of the MatchGroup to the type of the Id.+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: -- -- @@@ -111,23 +116,52 @@ -- type         Int -> forall a'. a' -> a' -- Notice that the coercion captures the free a'. -type instance XPatBind    GhcPs (GhcPass pR) = EpAnn [AddEpAnn]+type instance XPatBind    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+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) = NoExtField+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 = EpAnn [AddEpAnn]+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.@@ -422,7 +456,7 @@     = getPprDebug $ \case         -- Print with sccs showing         True  -> vcat (map ppr sigs) $$ vcat (map ppr_scc sccs)-        False -> pprDeclList (pprLHsBindsForUser (unionManyBags (map snd sccs)) sigs)+        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"@@ -432,7 +466,7 @@             => LHsBindsLR (GhcPass idL) (GhcPass idR) -> SDoc pprLHsBinds binds   | isEmptyLHsBinds binds = empty-  | otherwise = pprDeclList (map ppr (bagToList binds))+  | otherwise = pprDeclList (map ppr binds)  pprLHsBindsForUser :: (OutputableBndrId idL,                        OutputableBndrId idR,@@ -450,7 +484,7 @@      decls :: [(SrcSpan, SDoc)]     decls = [(locA loc, ppr sig)  | L loc sig <- sigs] ++-            [(locA loc, ppr bind) | L loc bind <- bagToList binds]+            [(locA loc, ppr bind) | L loc bind <- binds]      sort_by_loc decls = sortBy (SrcLoc.leftmost_smallest `on` fst) decls @@ -478,20 +512,20 @@ isEmptyValBinds (XValBindsLR (NValBinds ds sigs)) = null ds && null sigs  emptyValBindsIn, emptyValBindsOut :: HsValBindsLR (GhcPass a) (GhcPass b)-emptyValBindsIn  = ValBinds NoAnnSortKey emptyBag []+emptyValBindsIn  = ValBinds NoAnnSortKey [] [] emptyValBindsOut = XValBindsLR (NValBinds [] [])  emptyLHsBinds :: LHsBindsLR (GhcPass idL) idR-emptyLHsBinds = emptyBag+emptyLHsBinds = []  isEmptyLHsBinds :: LHsBindsLR (GhcPass idL) idR -> Bool-isEmptyLHsBinds = isEmptyBag+isEmptyLHsBinds = null  ------------ plusHsValBinds :: HsValBinds (GhcPass a) -> HsValBinds (GhcPass a)                -> HsValBinds(GhcPass a) plusHsValBinds (ValBinds _ ds1 sigs1) (ValBinds _ ds2 sigs2)-  = ValBinds NoAnnSortKey (ds1 `unionBags` ds2) (sigs1 ++ sigs2)+  = ValBinds NoAnnSortKey (ds1 ++ ds2) (sigs1 ++ sigs2) plusHsValBinds (XValBindsLR (NValBinds ds1 sigs1))                (XValBindsLR (NValBinds ds2 sigs2))   = XValBindsLR (NValBinds (ds1 ++ ds2) (sigs1 ++ sigs2))@@ -506,26 +540,36 @@                 (OutputableBndrId idL, OutputableBndrId idR)              => HsBindLR (GhcPass idL) (GhcPass idR) -> SDoc -ppr_monobind (PatBind { pat_lhs = pat, pat_rhs = grhss })-  = pprPatBind pat grhss+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_tick = ticks,-                        fun_ext = wrap })-  = pprTicks empty (if null ticks then empty-                    else text "-- ticks = " <> ppr ticks)+                        fun_ext = ext })+  = pprTicks empty ticksDoc     $$  whenPprDebug (pprBndr LetBind (unLoc fun))     $$  pprFunBind  matches-    $$  whenPprDebug (pprIfTc @idR $ ppr wrap)+    $$  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-#if __GLASGOW_HASKELL__ <= 900-  GhcPs -> dataConCantHappen b-  GhcRn -> dataConCantHappen b-#endif   GhcTc -> ppr_absbinds b     where       ppr_absbinds (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars@@ -568,7 +612,7 @@                     GhcPs -> ppr v                     GhcRn -> ppr v                     GhcTc -> ppr v-          PrefixCon _ vs -> hsep (pprPrefixOcc psyn : map ppr_v vs)+          PrefixCon vs   -> hsep (pprPrefixOcc psyn : map ppr_v vs)             where                 ppr_v v = case ghcPass @r of                     GhcPs -> ppr v@@ -583,9 +627,9 @@                     GhcTc -> ppr v        ppr_rhs = case dir of-          Unidirectional           -> ppr_simple (text "<-")+          Unidirectional           -> ppr_simple larrow           ImplicitBidirectional    -> ppr_simple equals-          ExplicitBidirectional mg -> ppr_simple (text "<-") <+> text "where" $$+          ExplicitBidirectional mg -> ppr_simple larrow <+> text "where" $$                                       (nest 2 $ pprFunBind mg)  pprTicks :: SDoc -> SDoc -> SDoc@@ -600,6 +644,9 @@          then pp_when_debug          else pp_no_debug +instance Outputable (XRecGhc (IdGhcP p)) => Outputable (RecordPatSynField (GhcPass p)) where+    ppr (RecordPatSynField { recordPatSynField = v }) = ppr v+ {- ************************************************************************ *                                                                      *@@ -623,7 +670,7 @@ isEmptyIPBindsTc (IPBinds ds is) = null is && isEmptyTcEvBinds ds  -- EPA annotations in GhcPs, dictionary Id in GhcTc-type instance XCIPBind GhcPs = EpAnn [AddEpAnn]+type instance XCIPBind GhcPs = EpToken "=" type instance XCIPBind GhcRn = NoExtField type instance XCIPBind GhcTc = Id type instance XXIPBind    (GhcPass p) = DataConCantHappen@@ -648,52 +695,156 @@ ************************************************************************ -} -type instance XTypeSig          (GhcPass p) = EpAnn AnnSig-type instance XPatSynSig        (GhcPass p) = EpAnn AnnSig-type instance XClassOpSig       (GhcPass p) = EpAnn AnnSig-type instance XIdSig            (GhcPass p) = NoExtField -- No anns, generated-type instance XFixSig           (GhcPass p) = EpAnn [AddEpAnn]-type instance XInlineSig        (GhcPass p) = EpAnn [AddEpAnn]-type instance XSpecSig          (GhcPass p) = EpAnn [AddEpAnn]-type instance XSpecInstSig      (GhcPass p) = EpAnn [AddEpAnn]-type instance XMinimalSig       (GhcPass p) = EpAnn [AddEpAnn]-type instance XSCCFunSig        (GhcPass p) = EpAnn [AddEpAnn]-type instance XCompleteMatchSig (GhcPass p) = EpAnn [AddEpAnn]+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 XXSig             (GhcPass p) = DataConCantHappen+type instance XSpecSigE         GhcPs = AnnSpecSig+type instance XSpecSigE         GhcRn = Name+type instance XSpecSigE         GhcTc = NoExtField -type instance XFixitySig  (GhcPass p) = 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 :: AddEpAnn, -- Not an EpaAnchor to capture unicode option-      asRest   :: [AddEpAnn]+      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+-- '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+-- | Located Type checker Specialisation Pragmas type LTcSpecPrag = Located TcSpecPrag --- | Type checker Specification Pragma+-- | 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-        HsWrapper-        InlinePragma-  -- ^ The Id to be specialised, a wrapper that specialises the-  -- polymorphic function, and inlining spec for the specialised function-  deriving Data+      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 [] @@ -714,34 +865,51 @@ 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 (inlinePragmaSource inl) pragmaSrc (pprSpec (unLoc var)-                                             (interpp'SP ty) inl)++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 (inl_src inl)-        _                -> "{-# " ++ extractSpecPragName (inl_src inl)  ++ "_INLINE"+        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)-  = pragSrcBrackets (inlinePragmaSource inl) "{-# INLINE"  (pprInline inl-                                   <+> pprPrefixOcc (unLoc var))-ppr_sig (SpecInstSig _ src ty)+  = 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)+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)+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)+ppr_sig (CompleteMatchSig (_, src) cs mty)   = pragSrcBrackets src "{-# COMPLETE"-      ((hsep (punctuate comma (map ppr_n (unLoc cs))))+      ((hsep (punctuate comma (map ppr_n cs)))         <+> opt_sig)   where     opt_sig = maybe empty ((\t -> dcolon <+> ppr t) . unLoc) mty@@ -749,11 +917,51 @@         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 _ names fixity) = sep [ppr fixity, pprops]+  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@@ -762,7 +970,7 @@ -- | 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 (SourceText src) _   doc = ftext src <+> doc <+> text "#-}" pragSrcBrackets NoSourceText     alt doc = text alt <+> doc <+> text "#-}"  pprVarSig :: (OutputableBndr id) => [id] -> SDoc -> SDoc@@ -782,12 +990,59 @@  instance Outputable TcSpecPrag where   ppr (SpecPrag var _ inl)-    = ppr (extractSpecPragName $ inl_src inl) <+> pprSpec var (text "<type>") inl+    = text (extractSpecPragName $ inl_src inl) <+> pprSpec var (text "<type>") inl+  ppr (SpecPragE { spe_bndrs = bndrs, spe_call = spec_e, spe_inl = inl })+    = text (extractSpecPragName $ inl_src inl)+       <+> hang (ppr bndrs) 2 (pprLExpr spec_e) -pprMinimalSig :: (OutputableBndr name)-              => LBooleanFormula (GenLocated l name) -> SDoc-pprMinimalSig (L _ bf) = ppr (fmap unLoc bf)+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)+ {- ************************************************************************ *                                                                      *@@ -799,15 +1054,8 @@ type instance Anno (HsBindLR (GhcPass idL) (GhcPass idR)) = SrcSpanAnnA type instance Anno (IPBind (GhcPass p)) = SrcSpanAnnA type instance Anno (Sig (GhcPass p)) = SrcSpanAnnA---- For CompleteMatchSig-type instance Anno [LocatedN RdrName] = SrcSpan-type instance Anno [LocatedN Name]    = SrcSpan-type instance Anno [LocatedN Id]      = SrcSpan+type instance Anno (RuleBndr (GhcPass p)) = EpAnnCO  type instance Anno (FixitySig (GhcPass p)) = SrcSpanAnnA -type instance Anno StringLiteral = SrcAnn NoEpAnns-type instance Anno (LocatedN RdrName) = SrcSpan-type instance Anno (LocatedN Name) = SrcSpan-type instance Anno (LocatedN Id) = SrcSpan+type instance Anno StringLiteral = EpAnnCO
GHC/Hs/Decls.hs view
@@ -6,19 +6,18 @@ {-# 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 -} --{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}- -- | Abstract syntax of global declarations. -- -- Definitions for: @SynDecl@ and @ConDecl@, @ClassDecl@,@@ -27,11 +26,16 @@   -- * Toplevel declarations   HsDecl(..), LHsDecl, HsDataDefn(..), HsDeriving, LHsFunDep,   HsDerivingClause(..), LHsDerivingClause, DerivClauseTys(..), LDerivClauseTys,-  NewOrData(..), newOrDataToFlavour,+  NewOrData, newOrDataToFlavour, anyLConIsGadt,   StandaloneKindSig(..), LStandaloneKindSig, standaloneKindSigName,    -- ** Class or type declarations   TyClDecl(..), LTyClDecl, DataDeclRn(..),+  AnnDataDefn(..),+  AnnClassDecl(..),+  AnnSynDecl(..),+  AnnFamilyDecl(..),+  AnnClsInstDecl(..),   TyClGroup(..),   tyClGroupTyClDecls, tyClGroupInstDecls, tyClGroupRoleDecls,   tyClGroupKindSigs,@@ -39,11 +43,12 @@   isFamilyDecl, isTypeFamilyDecl, isDataFamilyDecl,   isOpenTypeFamilyInfo, isClosedTypeFamilyInfo,   tyFamInstDeclName, tyFamInstDeclLName,-  countTyClDecls, pprTyClDeclFlavour,+  countTyClDecls, tyClDeclFlavour,   tyClDeclLName, tyClDeclTyVars,   hsDeclHasCusk, famResultKindSignature,   FamilyDecl(..), LFamilyDecl,-  FunDep(..),+  FunDep(..), ppDataDefnHeader,+  pp_vanilla_decl_head,    -- ** Instance declarations   InstDecl(..), LInstDecl, FamilyInfo(..),@@ -51,11 +56,11 @@   TyFamDefltDecl, LTyFamDefltDecl,   DataFamInstDecl(..), LDataFamInstDecl,   pprDataFamInstFlavour, pprTyFamInstDecl, pprHsFamInstLHS,-  FamEqn(..), TyFamInstEqn, LTyFamInstEqn, HsTyPats,+  FamEqn(..), TyFamInstEqn, LTyFamInstEqn, HsFamEqnPats,   LClsInstDecl, ClsInstDecl(..),    -- ** Standalone deriving declarations-  DerivDecl(..), LDerivDecl,+  DerivDecl(..), LDerivDecl, AnnDerivDecl,   -- ** Deriving strategies   DerivStrategy(..), LDerivStrategy,   derivStrategyName, foldDerivStrategy, mapDerivStrategy,@@ -69,19 +74,21 @@   -- ** @default@ declarations   DefaultDecl(..), LDefaultDecl,   -- ** Template haskell declaration splice-  SpliceExplicitFlag(..),+  SpliceDecoration(..),   SpliceDecl(..), LSpliceDecl,   -- ** Foreign function interface declarations   ForeignDecl(..), LForeignDecl, ForeignImport(..), ForeignExport(..),   CImportSpec(..),   -- ** Data-constructor declarations   ConDecl(..), LConDecl,-  HsConDeclH98Details, HsConDeclGADTDetails(..), hsConDeclTheta,+  HsConDeclH98Details, HsConDeclGADTDetails(..),+  AnnConDeclH98(..), AnnConDeclGADT(..),+  hsConDeclTheta,   getConNames, getRecConArgs_maybe,   -- ** Document comments   DocDecl(..), LDocDecl, docDeclDoc,   -- ** Deprecations-  WarnDecl(..),  LWarnDecl,+  WarnDecl(..), LWarnDecl,   WarnDecls(..), LWarnDecls,   -- ** Annotations   AnnDecl(..), LAnnDecl,@@ -103,8 +110,9 @@ import GHC.Prelude  import Language.Haskell.Syntax.Decls+import Language.Haskell.Syntax.Extension -import {-# SOURCE #-} GHC.Hs.Expr ( pprExpr, pprSpliceDecl )+import {-# SOURCE #-} GHC.Hs.Expr ( pprExpr, pprUntypedSplice )         -- Because Expr imports Decls via HsBracket  import GHC.Hs.Binds@@ -112,7 +120,7 @@ import GHC.Hs.Doc import GHC.Types.Basic import GHC.Core.Coercion-import Language.Haskell.Syntax.Extension+ import GHC.Hs.Extension import GHC.Parser.Annotation import GHC.Types.Name@@ -120,16 +128,19 @@ 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.Bag import GHC.Data.Maybe import Data.Data (Data)+import Data.List (concatMap)+import Data.Foldable (toList)  {- ************************************************************************@@ -169,12 +180,12 @@       [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl GhcPs]) partitionBindsAndSigs = go   where-    go [] = (emptyBag, [], [], [], [], [])+    go [] = ([], [], [], [], [], [])     go ((L l decl) : ds) =       let (bs, ss, ts, tfis, dfis, docs) = go ds in       case decl of         ValD _ b-          -> (L l b `consBag` bs, ss, ts, tfis, dfis, docs)+          -> (L l b : bs, ss, ts, tfis, dfis, docs)         SigD _ s           -> (bs, L l s : ss, ts, tfis, dfis, docs)         TyClD _ (FamDecl _ t)@@ -187,6 +198,10 @@           -> (bs, ss, ts, tfis, dfis, L l d : docs)         _ -> pprPanic "partitionBindsAndSigs" (ppr decl) +-- Okay, I need to reconstruct the document comments, but for now:+instance Outputable (DocDecl name) where+  ppr _ = text "<document comment>"+ type instance XCHsGroup (GhcPass _) = NoExtField type instance XXHsGroup (GhcPass _) = DataConCantHappen @@ -216,6 +231,20 @@                 , 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@@ -313,8 +342,14 @@  instance OutputableBndrId p        => Outputable (SpliceDecl (GhcPass p)) where-   ppr (SpliceDecl _ (L _ e) f) = pprSpliceDecl e f+  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+++ {- ************************************************************************ *                                                                      *@@ -325,24 +360,88 @@  type instance XFamDecl      (GhcPass _) = NoExtField -type instance XSynDecl      GhcPs = EpAnn [AddEpAnn]+type instance XSynDecl      GhcPs = AnnSynDecl type instance XSynDecl      GhcRn = NameSet -- FVs type instance XSynDecl      GhcTc = NameSet -- FVs -type instance XDataDecl     GhcPs = EpAnn [AddEpAnn]+type instance XDataDecl     GhcPs = NoExtField type instance XDataDecl     GhcRn = DataDeclRn type instance XDataDecl     GhcTc = DataDeclRn -type instance XClassDecl    GhcPs = (EpAnn [AddEpAnn], AnnSortKey, LayoutInfo)  -- See Note [Class LayoutInfo]-  -- TODO:AZ:tidy up AnnSortKey above+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 _) = EpAnn [AddEpAnn]+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@@ -361,6 +460,25 @@ 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@@ -404,7 +522,7 @@                     tcdFDs  = fds,                     tcdSigs = sigs, tcdMeths = methods,                     tcdATs = ats, tcdATDefs = at_defs})-      | null sigs && isEmptyBag methods && null ats && null at_defs -- No "where" part+      | null sigs && null methods && null ats && null at_defs -- No "where" part       = top_matter        | otherwise       -- Laid out@@ -432,7 +550,7 @@       ppr instds  pp_vanilla_decl_head :: (OutputableBndrId p)-   => XRec (GhcPass p) (IdP (GhcPass p))+   => XRecGhc (IdGhcP p)    -> LHsQTyVars (GhcPass p)    -> LexicalFixity    -> Maybe (LHsContext (GhcPass p))@@ -441,10 +559,11 @@  = hsep [pprLHsContext context, pp_tyvars tyvars]   where     pp_tyvars (varl:varsr)-      | fixity == Infix && length varsr > 1+      | fixity == Infix, varr:varsr'@(_:_) <- varsr+         -- If varsr has at least 2 elements, parenthesize.          = hsep [char '(',ppr (unLoc varl), pprInfixOcc (unLoc thing)-                , (ppr.unLoc) (head varsr), char ')'-                , hsep (map (ppr.unLoc) (tail varsr))]+                , (ppr.unLoc) varr, char ')'+                , hsep (map (ppr.unLoc) varsr')]       | fixity == Infix          = hsep [ppr (unLoc varl), pprInfixOcc (unLoc thing)          , hsep (map (ppr.unLoc) varsr)]@@ -452,18 +571,23 @@                   , hsep (map (ppr.unLoc) (varl:varsr))]     pp_tyvars [] = pprPrefixOcc (unLoc thing) -pprTyClDeclFlavour :: TyClDecl (GhcPass p) -> 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+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 _) = EpAnn [AddEpAnn]+type instance XCFunDep    (GhcPass _) = TokRarrow type instance XXFunDep    (GhcPass _) = DataConCantHappen  pprFundeps :: OutputableBndrId p => [FunDep (GhcPass p)] -> SDoc@@ -481,7 +605,14 @@ *                                                                      * ********************************************************************* -} -type instance XCTyClGroup (GhcPass _) = NoExtField+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  @@ -497,13 +628,31 @@ type instance XTyVarSig         (GhcPass _) = NoExtField type instance XXFamilyResultSig (GhcPass _) = DataConCantHappen -type instance XCFamilyDecl    (GhcPass _) = EpAnn [AddEpAnn]+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) -> XRec (GhcPass p) (IdP (GhcPass p))+familyDeclLName :: FamilyDecl (GhcPass p) -> XRecGhc (IdGhcP p) familyDeclLName (FamilyDecl { fdLName = n }) = n  familyDeclName :: FamilyDecl (GhcPass p) -> IdP (GhcPass p)@@ -513,18 +662,18 @@ famResultKindSignature (NoSig _) = Nothing famResultKindSignature (KindSig _ ki) = Just ki famResultKindSignature (TyVarSig _ bndr) =-  case unLoc bndr of-    UserTyVar _ _ _ -> Nothing-    KindedTyVar _ _ _ ki -> Just ki+  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) = Just $ hsLTyVarName sig+resultVariableName (TyVarSig _ sig) = hsLTyVarName sig resultVariableName _                = Nothing  ------------- Pretty printing FamilyDecls ----------- -type instance XCInjectivityAnn  (GhcPass _) = EpAnn [AddEpAnn]+type instance XCInjectivityAnn  (GhcPass _) = TokRarrow type instance XXInjectivityAnn  (GhcPass _) = DataConCantHappen  instance OutputableBndrId p@@ -550,7 +699,7 @@                   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) ]+                   hsep [ vbar, ppr lhs, arrow, hsep (map ppr rhs) ]                  Nothing -> empty       (pp_where, pp_eqns) = case info of         ClosedTypeFamily mb_eqns ->@@ -568,10 +717,10 @@ *                                                                      * ********************************************************************* -} -type instance XCHsDataDefn    (GhcPass _) = NoExtField+type instance XCHsDataDefn    (GhcPass _) = AnnDataDefn type instance XXHsDataDefn    (GhcPass _) = DataConCantHappen -type instance XCHsDerivingClause    (GhcPass _) = EpAnn [AddEpAnn]+type instance XCHsDerivingClause    (GhcPass _) = EpToken "deriving" type instance XXHsDerivingClause    (GhcPass _) = DataConCantHappen  instance OutputableBndrId p@@ -590,6 +739,15 @@             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@@ -598,7 +756,7 @@   ppr (DctSingle _ ty) = ppr ty   ppr (DctMulti _ tys) = parens (interpp'SP tys) -type instance XStandaloneKindSig GhcPs = EpAnn [AddEpAnn]+type instance XStandaloneKindSig GhcPs = (EpToken "type", TokDcolon) type instance XStandaloneKindSig GhcRn = NoExtField type instance XStandaloneKindSig GhcTc = NoExtField @@ -607,53 +765,100 @@ standaloneKindSigName :: StandaloneKindSig (GhcPass p) -> IdP (GhcPass p) standaloneKindSigName (StandaloneKindSig _ lname _) = unLoc lname -type instance XConDeclGADT (GhcPass _) = EpAnn [AddEpAnn]-type instance XConDeclH98  (GhcPass _) = EpAnn [AddEpAnn]+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} = names+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 [LConDeclField GhcRn])+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+  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 (HsDataDefn { dd_ND = new_or_data, dd_ctxt = context-                                , dd_cType = mb_ct-                                , dd_kindSig = mb_sig-                                , dd_cons = condecls, dd_derivs = derivings })+pp_data_defn pp_hdr defn@HsDataDefn+  { dd_cons = condecls+  , dd_derivs = derivings }   | null condecls-  = ppr new_or_data <+> pp_ct <+> pp_hdr context <+> pp_sig-    <+> pp_derivings derivings+  = ppDataDefnHeader pp_hdr defn <+> pp_derivings derivings    | otherwise-  = hang (ppr new_or_data <+> pp_ct  <+> pp_hdr context <+> pp_sig)-       2 (pp_condecls condecls $$ pp_derivings derivings)+  = hang (ppDataDefnHeader pp_hdr defn) 2 (pp_condecls (toList 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 ds = vcat (map ppr ds)  instance OutputableBndrId p@@ -663,19 +868,14 @@ instance OutputableBndrId p        => Outputable (StandaloneKindSig (GhcPass p)) where   ppr (StandaloneKindSig _ v ki)-    = text "type" <+> pprPrefixOcc (unLoc v) <+> text "::" <+> ppr ki+    = text "type" <+> pprPrefixOcc (unLoc v) <+> dcolon <+> ppr ki  pp_condecls :: forall p. OutputableBndrId p => [LConDecl (GhcPass p)] -> SDoc pp_condecls cs-  | gadt_syntax                  -- In GADT syntax+  | anyLConIsGadt cs             -- In GADT syntax   = hang (text "where") 2 (vcat (map ppr cs))   | otherwise                    -- In H98 syntax   = equals <+> sep (punctuate (text " |") (map ppr cs))-  where-    gadt_syntax = case cs of-      []                      -> False-      (L _ ConDeclH98{}  : _) -> False-      (L _ ConDeclGADT{} : _) -> True  instance (OutputableBndrId p) => Outputable (ConDecl (GhcPass p)) where     ppr = pprConDecl@@ -692,27 +892,31 @@   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 [ppr (hsScaledThing t1),+    ppr_details (InfixCon t1 t2) = hsep [pprHsConDeclFieldNoMult t1,                                          pprInfixOcc con,-                                         ppr (hsScaledThing t2)]-    ppr_details (PrefixCon _ tys) = hsep (pprPrefixOcc con-                                    : map (pprHsType . unLoc . hsScaledThing) tys)+                                         pprHsConDeclFieldNoMult t2]+    ppr_details (PrefixCon tys)  = hsep (pprPrefixOcc con+                                    : map pprHsConDeclFieldNoMult tys)     ppr_details (RecCon fields)  = pprPrefixOcc con-                                 <+> pprConDeclFields (unLoc fields)+                                    <+> pprHsConDeclRecFields (unLoc fields) -pprConDecl (ConDeclGADT { con_names = cons, con_bndrs = L _ outer_bndrs+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 cons <+> dcolon-    <+> (sep [pprHsOuterSigTyVarBndrs outer_bndrs <+> pprLHsContext mcxt,+  = 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 (\(HsScaled arr t) -> ppr t <+> ppr_arr arr) args-    ppr_args (RecConGADT fields _) = [pprConDeclFields (unLoc fields) <+> arrow]+    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 (HsLinearArrow _) = sdocOption sdocLinearTypes $ \show_linear_types ->+    ppr_arr (HsLinearAnn _) = sdocOption sdocLinearTypes $ \show_linear_types ->                                   if show_linear_types then lollipop else arrow     ppr_arr arr = pprHsArrow arr @@ -727,15 +931,22 @@ ************************************************************************ -} -type instance XCFamEqn    (GhcPass _) r = EpAnn [AddEpAnn]+type instance XCFamEqn    (GhcPass _) r = ([EpToken "("], [EpToken ")"], EpToken "=") type instance XXFamEqn    (GhcPass _) r = DataConCantHappen -type instance Anno (FamEqn (GhcPass p) _) = SrcSpanAnnA- ----------------- Class instances ------------- -type instance XCClsInstDecl    GhcPs = (EpAnn [AddEpAnn], AnnSortKey) -- TODO:AZ:tidy up-type instance XCClsInstDecl    GhcRn = NoExtField+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@@ -752,6 +963,31 @@  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@@ -797,14 +1033,14 @@                   -- pp_data_defn pretty-prints the kind sig. See #14817.  pprDataFamInstFlavour :: DataFamInstDecl (GhcPass p) -> SDoc-pprDataFamInstFlavour (DataFamInstDecl { dfid_eqn =-                       (FamEqn { feqn_rhs = HsDataDefn { dd_ND = nd }})})-  = ppr nd+pprDataFamInstFlavour DataFamInstDecl+  { dfid_eqn = FamEqn { feqn_rhs = HsDataDefn { dd_cons = cons }}}+  = ppr (dataDefnConsNewOrData cons)  pprHsFamInstLHS :: (OutputableBndrId p)    => IdP (GhcPass p)    -> HsOuterFamEqnTyVarBndrs (GhcPass p)-   -> HsTyPats (GhcPass p)+   -> HsFamEqnPats (GhcPass p)    -> LexicalFixity    -> Maybe (LHsContext (GhcPass p))    -> SDoc@@ -815,11 +1051,11 @@  instance OutputableBndrId p        => Outputable (ClsInstDecl (GhcPass p)) where-    ppr (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = binds-                     , cid_sigs = sigs, cid_tyfam_insts = ats-                     , cid_overlap_mode = mbOverlap-                     , cid_datafam_insts = adts })-      | null sigs, null ats, null adts, isEmptyBag binds  -- No "where" part+    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@@ -829,8 +1065,9 @@                map (pprDataFamInstDecl NotTopLevel . unLoc) adts ++                pprLHsBindsForUser binds sigs ]       where-        top_matter = text "instance" <+> ppOverlapPragma mbOverlap-                                             <+> ppr inst_ty+        top_matter = text "instance" <+> maybe empty ppr (cidDeprecation cid)+                                     <+> ppOverlapPragma mbOverlap+                                     <+> ppr inst_ty  ppDerivStrategy :: OutputableBndrId p                 => Maybe (LDerivStrategy (GhcPass p)) -> SDoc@@ -848,9 +1085,10 @@     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) _   = text src <+> text "#-}"+    maybe_stext (SourceText src) _   = ftext src <+> text "#-}"   instance (OutputableBndrId p) => Outputable (InstDecl (GhcPass p)) where@@ -870,6 +1108,19 @@     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 #-}+ {- ************************************************************************ *                                                                      *@@ -878,19 +1129,43 @@ ************************************************************************ -} -type instance XCDerivDecl    (GhcPass _) = EpAnn [AddEpAnn]+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 instance Anno OverlapMode = SrcSpanAnnP+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 (DerivDecl { deriv_type = ty+    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 ] @@ -902,15 +1177,15 @@ ************************************************************************ -} -type instance XStockStrategy    GhcPs = EpAnn [AddEpAnn]+type instance XStockStrategy    GhcPs = EpToken "stock" type instance XStockStrategy    GhcRn = NoExtField type instance XStockStrategy    GhcTc = NoExtField -type instance XAnyClassStrategy GhcPs = EpAnn [AddEpAnn]+type instance XAnyClassStrategy GhcPs = EpToken "anyclass" type instance XAnyClassStrategy GhcRn = NoExtField type instance XAnyClassStrategy GhcTc = NoExtField -type instance XNewtypeStrategy  GhcPs = EpAnn [AddEpAnn]+type instance XNewtypeStrategy  GhcPs = EpToken "newtype" type instance XNewtypeStrategy  GhcRn = NoExtField type instance XNewtypeStrategy  GhcTc = NoExtField @@ -918,7 +1193,7 @@ type instance XViaStrategy GhcRn = LHsSigType GhcRn type instance XViaStrategy GhcTc = Type -data XViaStrategyPs = XViaStrategyPs (EpAnn [AddEpAnn]) (LHsSigType GhcPs)+data XViaStrategyPs = XViaStrategyPs (EpToken "via") (LHsSigType GhcPs)  instance OutputableBndrId p         => Outputable (DerivStrategy (GhcPass p)) where@@ -957,7 +1232,7 @@ ************************************************************************ -} -type instance XCDefaultDecl    GhcPs = EpAnn [AddEpAnn]+type instance XCDefaultDecl    GhcPs = (EpToken "default", EpToken "(", EpToken ")") type instance XCDefaultDecl    GhcRn = NoExtField type instance XCDefaultDecl    GhcTc = NoExtField @@ -965,8 +1240,8 @@  instance OutputableBndrId p        => Outputable (DefaultDecl (GhcPass p)) where-    ppr (DefaultDecl _ tys)-      = text "default" <+> parens (interpp'SP tys)+    ppr (DefaultDecl _ cl tys)+      = text "default" <+> maybe id ((<+>) . ppr) cl (parens (interpp'SP tys))  {- ************************************************************************@@ -976,16 +1251,25 @@ ************************************************************************ -} -type instance XForeignImport   GhcPs = EpAnn [AddEpAnn]+type instance XForeignImport   GhcPs = (EpToken "foreign", EpToken "import", TokDcolon) type instance XForeignImport   GhcRn = NoExtField type instance XForeignImport   GhcTc = Coercion -type instance XForeignExport   GhcPs = EpAnn [AddEpAnn]+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 })@@ -995,6 +1279,40 @@     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 '"'+ {- ************************************************************************ *                                                                      *@@ -1003,65 +1321,65 @@ ************************************************************************ -} -type instance XCRuleDecls    GhcPs = EpAnn [AddEpAnn]-type instance XCRuleDecls    GhcRn = NoExtField-type instance XCRuleDecls    GhcTc = NoExtField+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 = EpAnn HsRuleAnn-type instance XHsRule       GhcRn = HsRuleRn-type instance XHsRule       GhcTc = HsRuleRn--type instance XXRuleDecl    (GhcPass _) = DataConCantHappen+type instance XHsRule       GhcPs = ((ActivationAnn, EpToken "="), SourceText)+type instance XHsRule       GhcRn = (HsRuleRn, SourceText)+type instance XHsRule       GhcTc = (HsRuleRn, SourceText) -type instance Anno (SourceText, RuleName) = SrcAnn NoEpAnns+data HsRuleRn = HsRuleRn NameSet NameSet -- Free-vars from the LHS and RHS+  deriving Data  data HsRuleAnn   = HsRuleAnn-       { ra_tyanns :: Maybe (AddEpAnn, AddEpAnn)-                 -- ^ The locations of 'forall' and '.' for forall'd type vars-                 -- Using AddEpAnn to capture possible unicode variants-       , ra_tmanns :: Maybe (AddEpAnn, AddEpAnn)-                 -- ^ The locations of 'forall' and '.' for forall'd term vars-                 -- Using AddEpAnn to capture possible unicode variants-       , ra_rest :: [AddEpAnn]+       { 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 -type instance XCRuleBndr    (GhcPass _) = EpAnn [AddEpAnn]-type instance XRuleBndrSig  (GhcPass _) = EpAnn [AddEpAnn]-type instance XXRuleBndr    (GhcPass _) = DataConCantHappen- instance (OutputableBndrId p) => Outputable (RuleDecls (GhcPass p)) where-  ppr (HsRules { rds_src = st+  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_name = name+  ppr (HsRule { rd_ext  = ext+              , rd_name = name               , rd_act  = act-              , rd_tyvs = tys-              , rd_tmvs = tms+              , rd_bndrs = bndrs               , rd_lhs  = lhs               , rd_rhs  = rhs })-        = sep [pprFullRuleName name <+> ppr act,-               nest 4 (pp_forall_ty tys <+> pp_forall_tm tys-                                        <+> pprExpr (unLoc lhs)),+        = sep [pprFullRuleName st name <+> ppr act,+               nest 4 (ppr bndrs <+> pprExpr (unLoc lhs)),                nest 6 (equals <+> pprExpr (unLoc rhs)) ]         where-          pp_forall_ty Nothing     = empty-          pp_forall_ty (Just qtvs) = forAllLit <+> fsep (map ppr qtvs) <> dot-          pp_forall_tm Nothing | null tms = empty-          pp_forall_tm _ = forAllLit <+> fsep (map ppr tms) <> dot+          st = case ghcPass @p of+                 GhcPs | (_, st) <- ext -> st+                 GhcRn | (_, st) <- ext -> st+                 GhcTc | (_, st) <- ext -> st -instance (OutputableBndrId p) => Outputable (RuleBndr (GhcPass p)) where-   ppr (RuleBndr _ name) = ppr name-   ppr (RuleBndrSig _ name ty) = parens (ppr name <> dcolon <> ppr ty)+pprFullRuleName :: SourceText -> GenLocated a (RuleName) -> SDoc+pprFullRuleName st (L _ n) = pprWithSourceText st (doubleQuotes $ ftext n) + {- ************************************************************************ *                                                                      *@@ -1070,27 +1388,37 @@ ************************************************************************ -} -type instance XWarnings      GhcPs = EpAnn [AddEpAnn]-type instance XWarnings      GhcRn = NoExtField-type instance XWarnings      GhcTc = NoExtField+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 _) = EpAnn [AddEpAnn]+type instance XWarning      (GhcPass _) = (NamespaceSpecifier, (EpToken "[", EpToken "]")) type instance XXWarnDecl    (GhcPass _) = DataConCantHappen   instance OutputableBndrId p         => Outputable (WarnDecls (GhcPass p)) where-    ppr (Warnings _ (SourceText src) decls)-      = text src <+> vcat (punctuate comma (map ppr decls)) <+> text "#-}"-    ppr (Warnings _ NoSourceText _decls) = panic "WarnDecls"+    ppr (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 _ thing txt)-      = hsep ( punctuate comma (map ppr thing))+    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  {- ************************************************************************@@ -1100,11 +1428,11 @@ ************************************************************************ -} -type instance XHsAnnotation (GhcPass _) = EpAnn AnnPragma+type instance XHsAnnotation (GhcPass _) = (AnnPragma, SourceText) type instance XXAnnDecl     (GhcPass _) = DataConCantHappen  instance (OutputableBndrId p) => Outputable (AnnDecl (GhcPass p)) where-    ppr (HsAnnotation _ _ provenance expr)+    ppr (HsAnnotation _ provenance expr)       = hsep [text "{-#", pprAnnProvenance provenance, pprExpr (unLoc expr), text "#-}"]  pprAnnProvenance :: OutputableBndrId p => AnnProvenance (GhcPass p) -> SDoc@@ -1122,14 +1450,12 @@ ************************************************************************ -} -type instance XCRoleAnnotDecl GhcPs = EpAnn [AddEpAnn]+type instance XCRoleAnnotDecl GhcPs = (EpToken "type", EpToken "role") type instance XCRoleAnnotDecl GhcRn = NoExtField type instance XCRoleAnnotDecl GhcTc = NoExtField  type instance XXRoleAnnotDecl (GhcPass _) = DataConCantHappen -type instance Anno (Maybe Role) = SrcAnn NoEpAnns- instance OutputableBndr (IdP (GhcPass p))        => Outputable (RoleAnnotDecl (GhcPass p)) where   ppr (RoleAnnotDecl _ ltycon roles)@@ -1154,16 +1480,16 @@ 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)) = SrcAnn NoEpAnns+type instance Anno (FamilyResultSig (GhcPass p)) = EpAnnCO type instance Anno (FamilyDecl (GhcPass p)) = SrcSpanAnnA-type instance Anno (InjectivityAnn (GhcPass p)) = SrcAnn NoEpAnns+type instance Anno (InjectivityAnn (GhcPass p)) = EpAnnCO type instance Anno CType = SrcSpanAnnP-type instance Anno (HsDerivingClause (GhcPass p)) = SrcAnn NoEpAnns+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 = SrcAnn NoEpAnns-type instance Anno [LocatedA (ConDeclField (GhcPass _))] = SrcSpanAnnL+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@@ -1173,15 +1499,17 @@ 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)) = SrcAnn NoEpAnns+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) = SrcAnn NoEpAnns-type instance Anno (RuleBndr (GhcPass p)) = SrcAnn NoEpAnns+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) = SrcAnn NoEpAnns+type instance Anno (Maybe Role) = EpAnnCO+type instance Anno CCallConv   = EpaLocation+type instance Anno Safety      = EpaLocation+type instance Anno CExportSpec = EpaLocation
GHC/Hs/Doc.hs view
@@ -36,10 +36,9 @@ import GHC.Data.EnumSet (EnumSet) import GHC.Types.Avail import GHC.Types.Name.Set-import GHC.Unit.Module.Name import GHC.Driver.Flags -import Control.Applicative (liftA2)+import Control.DeepSeq import Data.Data import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap@@ -48,13 +47,15 @@ import Data.List.NonEmpty (NonEmpty(..)) import GHC.LanguageExtensions.Type import qualified GHC.Utils.Outputable as O-import Language.Haskell.Syntax.Extension import GHC.Hs.Extension import GHC.Types.Unique.Map import Data.List (sortBy)  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 @@ -74,6 +75,8 @@  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.@@ -85,9 +88,9 @@ instance Binary a => Binary (WithHsDocIdentifiers a GhcRn) where   put_ bh (WithHsDocIdentifiers s ids) = do     put_ bh s-    put_ bh ids+    put_ bh $ BinLocated <$> ids   get bh =-    liftA2 WithHsDocIdentifiers (get bh) (get bh)+    liftA2 WithHsDocIdentifiers (get bh) (fmap unBinLocated <$> get bh)  -- | Extract a mapping from the lexed identifiers to the names they may -- correspond to.@@ -118,19 +121,24 @@  -- | A simplified version of 'HsImpExp.IE'. data DocStructureItem-  = DsiSectionHeading Int (HsDoc GhcRn)-  | DsiDocChunk (HsDoc GhcRn)-  | DsiNamedChunkRef String-  | DsiExports Avails+  = DsiSectionHeading !Int !(HsDoc GhcRn)+  | DsiDocChunk !(HsDoc GhcRn)+  | DsiNamedChunkRef !String+  | DsiExports !DetOrdAvails   | DsiModExport-      (NonEmpty ModuleName) -- ^ We might re-export avails from multiple+      !(NonEmpty ModuleName) -- ^ We might re-export avails from multiple                             -- modules with a single export declaration. E.g.                             -- when we have                             --                             -- > module M (module X) where                             -- > import R0 as X                             -- > import R1 as X-      Avails+                            --+                            -- 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@@ -179,11 +187,22 @@     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@@ -203,11 +222,18 @@     -- ^ 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) $ nonDetEltsUniqMap $ docs_decls docs)-    put_ bh (sortBy (\a b -> (fst a) `stableNameCmp` fst b) $ nonDetEltsUniqMap $ docs_args 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)@@ -215,6 +241,7 @@     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@@ -223,7 +250,8 @@     language <- get bh     exts <- get bh     pure Docs { docs_mod_hdr = mod_hdr-              , docs_decls =  decls+              , docs_exports = exports+              , docs_decls = decls               , docs_args = args               , docs_structure = structure               , docs_named_chunks = named_chunks@@ -236,6 +264,7 @@   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@@ -265,6 +294,7 @@ emptyDocs :: Docs emptyDocs = Docs   { docs_mod_hdr = Nothing+  , docs_exports = emptyUniqMap   , docs_decls = emptyUniqMap   , docs_args = emptyUniqMap   , docs_structure = []
+ GHC/Hs/Doc.hs-boot view
@@ -0,0 +1,19 @@+{-# LANGUAGE RoleAnnotations #-}+module GHC.Hs.Doc where++-- See #21592 for progress on removing this boot file.++import GHC.Types.SrcLoc+import GHC.Hs.DocString+import Data.Kind++type role WithHsDocIdentifiers representational nominal+type WithHsDocIdentifiers :: Type -> Type -> Type+data WithHsDocIdentifiers a pass++type HsDoc :: Type -> Type+type HsDoc = WithHsDocIdentifiers HsDocString++type LHsDoc :: Type -> Type+type LHsDoc pass = Located (HsDoc pass)+
GHC/Hs/DocString.hs view
@@ -1,5 +1,7 @@ -- | An exactprintable structure for docstrings {-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}  module GHC.Hs.DocString   ( LHsDocString@@ -19,6 +21,7 @@   , renderHsDocStrings   , exactPrintHsDocString   , pprWithDocString+  , printDecorator   ) where  import GHC.Prelude@@ -27,6 +30,7 @@ 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@@ -59,6 +63,11 @@ 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.@@ -75,19 +84,19 @@     MultiLineDocString dec xs -> do       putByte bh 0       put_ bh dec-      put_ bh xs+      put_ bh $ BinLocated <$> xs     NestedDocString dec x -> do       putByte bh 1       put_ bh dec-      put_ bh x+      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 <*> get bh-      1 -> NestedDocString <$> get bh <*> get bh+      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 @@ -101,6 +110,12 @@ 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 = "^"@@ -124,9 +139,10 @@  type LHsDocStringChunk = Located HsDocStringChunk --- | A continguous chunk of documentation+-- | A contiguous chunk of documentation newtype HsDocStringChunk = HsDocStringChunk ByteString-  deriving (Eq,Ord,Data, Show)+  deriving stock (Eq,Ord,Data, Show)+  deriving newtype (NFData)  instance Binary HsDocStringChunk where   put_ bh (HsDocStringChunk bs) = put_ bh bs@@ -135,9 +151,8 @@ instance Outputable HsDocStringChunk where   ppr = text . unpackHDSC - mkHsDocStringChunk :: String -> HsDocStringChunk-mkHsDocStringChunk s = HsDocStringChunk (utf8EncodeString s)+mkHsDocStringChunk s = HsDocStringChunk (utf8EncodeByteString s)  -- | Create a 'HsDocString' from a UTF8-encoded 'ByteString'. mkHsDocStringChunkUtf8ByteString :: ByteString -> HsDocStringChunk@@ -192,6 +207,6 @@ unlines' = intercalate "\n"  -- | Just get the docstring, without any decorators--- Seperates docstrings using "\n\n", which is how haddock likes to render them+-- Separates docstrings using "\n\n", which is how haddock likes to render them renderHsDocStrings :: [HsDocString] -> String renderHsDocStrings = intercalate "\n\n" . map renderHsDocString
GHC/Hs/Dump.hs view
@@ -4,7 +4,12 @@ -} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DataKinds #-} +{-# OPTIONS_GHC -fno-specialise #-}+   -- Don't do type-class specialisation; it goes mad in this module+   -- See #25463+ -- | Contains a debug function to dump parts of the GHC.Hs AST. It uses a syb -- traversal which falls back to displaying based on the constructor name, so -- can be used to dump anything having a @Data.Data@ instance.@@ -30,11 +35,11 @@ import GHC.Types.SrcLoc import GHC.Types.Var import GHC.Types.SourceText-import GHC.Unit.Module 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@@ -58,28 +63,39 @@     showAstData' =       generic               `ext1Q` list+              `extQ` list_epaLocation+              `extQ` list_epTokenOpenP+              `extQ` list_epTokenCloseP               `extQ` string `extQ` fastString `extQ` srcSpan `extQ` realSrcSpan-              `extQ` annotation               `extQ` annotationModule-              `extQ` annotationAddEpAnn               `extQ` annotationGrhsAnn-              `extQ` annotationEpAnnHsCase               `extQ` annotationAnnList+              `extQ` annotationAnnListWhere+              `extQ` annotationAnnListCommas+              `extQ` annotationAnnListIE               `extQ` annotationEpAnnImportDecl-              `extQ` annotationAnnParen-              `extQ` annotationTrailingAnn-              `extQ` annotationEpaLocation               `extQ` annotationNoEpAnns-              `extQ` addEpAnn+              `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` epaAnchor+              `extQ` epaLocation+              `extQ` maybe_epaLocation               `extQ` bytestring               `extQ` name `extQ` occName `extQ` moduleName `extQ` var               `extQ` dataCon               `extQ` bagName `extQ` bagRdrName `extQ` bagVar `extQ` nameSet-              `extQ` fixity               `ext2Q` located               `extQ` srcSpanAnnA               `extQ` srcSpanAnnL@@ -102,6 +118,24 @@             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)@@ -138,18 +172,26 @@                                                , generic s ]              sourceText :: SourceText -> SDoc-            sourceText NoSourceText = parens $ text "NoSourceText"+            sourceText NoSourceText = case bs of+              BlankSrcSpan -> parens $ text "SourceText" <+> text "blanked"+              _            -> parens $ text "NoSourceText"             sourceText (SourceText src) = case bs of-              NoBlankSrcSpan   -> parens $ text "SourceText" <+> text src-              BlankSrcSpanFile -> parens $ text "SourceText" <+> text src-              _                -> parens $ text "SourceText" <+> text "blanked"+              BlankSrcSpan     -> parens $ text "SourceText" <+> text "blanked"+              _                -> parens $ text "SourceText" <+> ftext src -            epaAnchor :: EpaLocation -> SDoc-            epaAnchor (EpaSpan r)  = parens $ text "EpaSpan" <+> realSrcSpan r-            epaAnchor (EpaDelta d cs) = case ba of-              NoBlankEpAnnotations -> parens $ text "EpaDelta" <+> deltaPos d <+> showAstData' cs-              BlankEpAnnotations -> parens $ text "EpaDelta" <+> deltaPos d <+> text "blanked"+            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@@ -159,7 +201,7 @@              occName n  =  braces $                           text "OccName:"-                      <+> text (occNameString n)+                      <+> ftext (occNameFS n)              moduleName :: ModuleName -> SDoc             moduleName m = braces $ text "ModuleName:" <+> ppr m@@ -167,35 +209,123 @@             srcSpan :: SrcSpan -> SDoc             srcSpan ss = case bs of              BlankSrcSpan -> text "{ ss }"-             NoBlankSrcSpan -> braces $ char ' ' <>-                             (hang (ppr ss) 1-                                   -- TODO: show annotations here-                                   (text ""))-             BlankSrcSpanFile -> braces $ char ' ' <>-                             (hang (pprUserSpan False ss) 1-                                   -- TODO: show annotations here-                                   (text ""))+             NoBlankSrcSpan -> braces $ char ' ' <> (ppr ss) <> char ' '+             BlankSrcSpanFile -> braces $ char ' ' <> (pprUserSpan False ss) <> char ' '              realSrcSpan :: RealSrcSpan -> SDoc             realSrcSpan ss = case bs of              BlankSrcSpan -> text "{ ss }"-             NoBlankSrcSpan -> braces $ char ' ' <>-                             (hang (ppr ss) 1-                                   -- TODO: show annotations here-                                   (text ""))-             BlankSrcSpanFile -> braces $ char ' ' <>-                             (hang (pprUserRealSpan False ss) 1-                                   -- TODO: show annotations here-                                   (text ""))+             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]+                                      ) -            addEpAnn :: AddEpAnn -> SDoc-            addEpAnn (AddEpAnn a s) = case ba of+            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 "AddEpAnn"+                                      $ text "blanked:" <+> text "BracketAnn"              NoBlankEpAnnotations ->-              parens $ text "AddEpAnn" <+> ppr a <+> epaAnchor s+              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 @@ -221,11 +351,6 @@                           text "NameSet:"                        $$ (list . nameSetElemsStable $ ns) -            fixity :: Fixity -> SDoc-            fixity fx =  braces $-                         text "Fixity:"-                     <+> ppr fx-             located :: (Data a, Data b) => GenLocated a b -> SDoc             located (L ss a)               = parens (text "L"@@ -234,35 +359,26 @@              -- ------------------------- -            annotation :: EpAnn [AddEpAnn] -> SDoc-            annotation = annotation' (text "EpAnn [AddEpAnn]")-             annotationModule :: EpAnn AnnsModule -> SDoc             annotationModule = annotation' (text "EpAnn AnnsModule") -            annotationAddEpAnn :: EpAnn AddEpAnn -> SDoc-            annotationAddEpAnn = annotation' (text "EpAnn AddEpAnn")-             annotationGrhsAnn :: EpAnn GrhsAnn -> SDoc             annotationGrhsAnn = annotation' (text "EpAnn GrhsAnn") -            annotationEpAnnHsCase :: EpAnn EpAnnHsCase -> SDoc-            annotationEpAnnHsCase = annotation' (text "EpAnn EpAnnHsCase")--            annotationAnnList :: EpAnn AnnList -> SDoc-            annotationAnnList = annotation' (text "EpAnn AnnList")+            annotationAnnList :: EpAnn (AnnList ()) -> SDoc+            annotationAnnList = annotation' (text "EpAnn (AnnList ())") -            annotationEpAnnImportDecl :: EpAnn EpAnnImportDecl -> SDoc-            annotationEpAnnImportDecl = annotation' (text "EpAnn EpAnnImportDecl")+            annotationAnnListWhere :: EpAnn (AnnList (EpToken "where")) -> SDoc+            annotationAnnListWhere = annotation' (text "EpAnn (AnnList (EpToken \"where\"))") -            annotationAnnParen :: EpAnn AnnParen -> SDoc-            annotationAnnParen = annotation' (text "EpAnn AnnParen")+            annotationAnnListCommas :: EpAnn (AnnList [EpToken ","]) -> SDoc+            annotationAnnListCommas = annotation' (text "EpAnn (AnnList [EpToken \",\"])") -            annotationTrailingAnn :: EpAnn TrailingAnn -> SDoc-            annotationTrailingAnn = annotation' (text "EpAnn TrailingAnn")+            annotationAnnListIE :: EpAnn (AnnList (EpToken "hiding", [EpToken ","])) -> SDoc+            annotationAnnListIE = annotation' (text "EpAnn (AnnList (EpToken \"hiding\", [EpToken \",\"]))") -            annotationEpaLocation :: EpAnn EpaLocation -> SDoc-            annotationEpaLocation = annotation' (text "EpAnn EpaLocation")+            annotationEpAnnImportDecl :: EpAnn EpAnnImportDecl -> SDoc+            annotationEpAnnImportDecl = annotation' (text "EpAnn EpAnnImportDecl")              annotationNoEpAnns :: EpAnn NoEpAnns -> SDoc             annotationNoEpAnns = annotation' (text "EpAnn NoEpAnns")@@ -276,32 +392,32 @@              -- ------------------------- -            srcSpanAnnA :: SrcSpanAnn' (EpAnn AnnListItem) -> SDoc+            srcSpanAnnA :: EpAnn AnnListItem -> SDoc             srcSpanAnnA = locatedAnn'' (text "SrcSpanAnnA") -            srcSpanAnnL :: SrcSpanAnn' (EpAnn AnnList) -> SDoc+            srcSpanAnnL :: EpAnn (AnnList ()) -> SDoc             srcSpanAnnL = locatedAnn'' (text "SrcSpanAnnL") -            srcSpanAnnP :: SrcSpanAnn' (EpAnn AnnPragma) -> SDoc+            srcSpanAnnP :: EpAnn AnnPragma -> SDoc             srcSpanAnnP = locatedAnn'' (text "SrcSpanAnnP") -            srcSpanAnnC :: SrcSpanAnn' (EpAnn AnnContext) -> SDoc+            srcSpanAnnC :: EpAnn AnnContext -> SDoc             srcSpanAnnC = locatedAnn'' (text "SrcSpanAnnC") -            srcSpanAnnN :: SrcSpanAnn' (EpAnn NameAnn) -> SDoc+            srcSpanAnnN :: EpAnn NameAnn -> SDoc             srcSpanAnnN = locatedAnn'' (text "SrcSpanAnnN")              locatedAnn'' :: forall a. (Typeable a, Data a)-              => SDoc -> SrcSpanAnn' a -> SDoc+              => SDoc -> EpAnn a -> SDoc             locatedAnn'' tag ss = parens $               case cast ss of-                Just ((SrcSpanAnn ann s) :: SrcSpanAnn' a) ->+                Just (ann :: EpAnn a) ->                   case ba of                     BlankEpAnnotations                       -> parens (text "blanked:" <+> tag)                     NoBlankEpAnnotations-                      -> text "SrcSpanAnn" <+> showAstData' ann-                              <+> srcSpan s+                      -> text (showConstr (toConstr ann))+                                          $$ vcat (gmapQ showAstData' ann)                 Nothing -> text "locatedAnn:unmatched" <+> tag                            <+> (parens $ text (showConstr (toConstr ss)))
GHC/Hs/Expr.hs view
@@ -14,2058 +14,2709 @@ {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]                                       -- in module Language.Haskell.Syntax.Extension -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}-{-# 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.Decls-import GHC.Hs.Pat-import GHC.Hs.Lit-import Language.Haskell.Syntax.Extension-import GHC.Hs.Extension-import GHC.Hs.Type-import GHC.Hs.Binds-import GHC.Parser.Annotation---- others:-import GHC.Tc.Types.Evidence-import GHC.Core.DataCon (FieldLabelString)-import GHC.Types.Name-import GHC.Types.Name.Set-import GHC.Types.Basic-import GHC.Types.Fixity-import GHC.Types.SourceText-import GHC.Types.SrcLoc-import GHC.Types.Tickish (CoreTickish)-import GHC.Core.ConLike-import GHC.Unit.Module (ModuleName)-import GHC.Utils.Misc-import GHC.Utils.Outputable-import GHC.Utils.Panic-import GHC.Utils.Panic.Plain-import GHC.Data.FastString-import GHC.Core.Type-import GHC.Builtin.Types (mkTupleStr)-import GHC.Tc.Utils.TcType (TcType, TcTyVar)-import {-# SOURCE #-} GHC.Tc.Types (TcLclEnv)---- 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 (uncons)-import Data.Bifunctor (first)--{- *********************************************************************-*                                                                      *-                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 noComments (HsString (SourceText  "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---- | Make a 'SyntaxExpr' from a 'Name' (the "rn" is because this is used in the--- renamer).-mkRnSyntaxExpr :: Name -> SyntaxExprRn-mkRnSyntaxExpr name = SyntaxExprRn $ HsVar noExtField $ noLocA name--instance Outputable SyntaxExprRn where-  ppr (SyntaxExprRn expr) = ppr expr-  ppr NoSyntaxExprRn      = text "<no syntax expr>"--instance Outputable SyntaxExprTc where-  ppr (SyntaxExprTc { syn_expr      = expr-                    , syn_arg_wraps = arg_wraps-                    , syn_res_wrap  = res_wrap })-    = sdocOption sdocPrintExplicitCoercions $ \print_co ->-      getPprDebug $ \debug ->-      if debug || print_co-      then ppr expr <> braces (pprWithCommas ppr arg_wraps)-                    <> braces (ppr res_wrap)-      else ppr expr--  ppr NoSyntaxExprTc = text "<no syntax expr>"---- | Extra data fields for a 'RecordUpd', added by the type checker-data RecordUpdTc = RecordUpdTc-      { rupd_cons :: [ConLike]-                -- Filled in by the type checker to the-                -- _non-empty_ list of DataCons that have-                -- all the upd'd fields--      , rupd_in_tys  :: [Type]  -- Argument types of *input* record type-      , rupd_out_tys :: [Type]  --             and  *output* record type-                -- For a data family, these are the type args of the-                -- /representation/ type constructor--      , rupd_wrap :: HsWrapper  -- See Note [Record Update HsWrapper]-      }---- | 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)---- -----------------------------------------------------------------------{--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 brackets, contains:-  - The renamed quote :: HsQuote GhcRn -- for the desugarer-  - [PendingTcSplice]-  - The type of the quote-  - Maybe QuoteWrapper--Note that (HsBracketTc) stores the untyped (HsQuote GhcRn) for both typed and-untyped brackets. They are treated uniformly by the desugarer, and we can-easily construct untyped brackets from typed ones (with ExpBr).--Typed quotes-~~~~~~~~~~~~-Here is the life cycle of a /typed/ quote [|| e ||], whose datacon is-  HsTypedBracket   (XTypedBracket p)   (LHsExpr p)--  In pass p   (XTypedBracket p)       (LHsExpr p)-  --------------------------------------------  GhcPs   Annotations only            LHsExpr GhcPs-  GhcRn   Annotations only            LHsExpr GhcRn-  GhcTc   HsBracketTc                 LHsExpr GhcTc: unused!--Note that in the GhcTc tree, the second field (HsExpr GhcTc)-is entirely unused; the desugarer uses the (HsExpr GhcRn) from the-first field.--Untyped quotes-~~~~~~~~~~~~~~-Here is the life cycle of an /untyped/ quote, whose datacon is-   HsUntypedBracket (XUntypedBracket p) (HsQuote p)--Here HsQuote is a sum-type of expressions [| e |], patterns [| p |],-types [| t |] etc.--  In pass p   (XUntypedBracket p)          (HsQuote p)-  --------------------------------------------------------  GhcPs   Annotations only                 HsQuote GhcPs-  GhcRn   Annotations, [PendingRnSplice]   HsQuote GhcRn-  GhcTc   HsBracketTc                      HsQuote GhcTc: unused!--The difficulty is: the typechecker does not typecheck the body of an-untyped quote, so how do we make a (HsQuote GhcTc) to put in the-second field?--Answer: we use the extension constructor of HsQuote, XQuote, and make-all the other constructors into DataConCantHappen.  That is, the only-non-bottom value of type (HsQuote GhcTc) is (XQuote noExtField). Hence-the instances-  type instance XExpBr GhcTc = DataConCantHappen-  ...etc...--See the related Note [How brackets and nested splices are handled] in GHC.Tc.Gen.Splice--}--data HsBracketTc = HsBracketTc-  { brack_renamed_quote   :: (HsQuote GhcRn)      -- See Note [The life cycle of a TH quotation]-  , brack_ty              :: Type-  , brack_quote_wrapper   :: (Maybe QuoteWrapper) -- The wrapper to apply type and dictionary argument to the quote.-  , brack_pending_splices :: [PendingTcSplice]    -- Output of the type checker is the *original*-                                                  -- renamed expression, plus-                                                  -- _typechecked_ splices to be-                                                  -- pasted back in by the desugarer-  }--type instance XTypedBracket GhcPs = EpAnn [AddEpAnn]-type instance XTypedBracket GhcRn = NoExtField-type instance XTypedBracket GhcTc = HsBracketTc-type instance XUntypedBracket GhcPs = EpAnn [AddEpAnn]-type instance XUntypedBracket GhcRn = [PendingRnSplice] -- See Note [Pending Splices]-                                                        -- Output of the renamer is the *original* renamed expression,-                                                        -- plus _renamed_ splices to be type checked-type instance XUntypedBracket GhcTc = HsBracketTc---- ------------------------------------------------------------------------- API Annotations types--data EpAnnHsCase = EpAnnHsCase-      { hsCaseAnnCase :: EpaLocation-      , hsCaseAnnOf   :: EpaLocation-      , hsCaseAnnsRest :: [AddEpAnn]-      } deriving Data--data EpAnnUnboundVar = EpAnnUnboundVar-     { hsUnboundBackquotes :: (EpaLocation, EpaLocation)-     , hsUnboundHole       :: EpaLocation-     } deriving Data--type instance XVar           (GhcPass _) = NoExtField---- Record selectors at parse time are HsVar; they convert to HsRecSel--- on renaming.-type instance XRecSel              GhcPs = DataConCantHappen-type instance XRecSel              GhcRn = NoExtField-type instance XRecSel              GhcTc = NoExtField--type instance XLam           (GhcPass _) = NoExtField---- OverLabel not present in GhcTc pass; see GHC.Rename.Expr--- Note [Handling overloaded and rebindable constructs]-type instance XOverLabel     GhcPs = EpAnnCO-type instance XOverLabel     GhcRn = EpAnnCO-type instance XOverLabel     GhcTc = DataConCantHappen---- -----------------------------------------------------------------------type instance XVar           (GhcPass _) = NoExtField--type instance XUnboundVar    GhcPs = EpAnn EpAnnUnboundVar-type instance XUnboundVar    GhcRn = NoExtField-type instance XUnboundVar    GhcTc = HoleExprRef-  -- 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.--type instance XIPVar         GhcPs = EpAnnCO-type instance XIPVar         GhcRn = EpAnnCO-type instance XIPVar         GhcTc = DataConCantHappen-type instance XOverLitE      (GhcPass _) = EpAnnCO-type instance XLitE          (GhcPass _) = EpAnnCO--type instance XLam           (GhcPass _) = NoExtField--type instance XLamCase       (GhcPass _) = EpAnn [AddEpAnn]--type instance XApp           (GhcPass _) = EpAnnCO--type instance XAppTypeE      GhcPs = SrcSpan -- Where the `@` lives-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 = EpAnn [AddEpAnn]-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 = EpAnnCO-type instance XSectionR      GhcPs = EpAnnCO-type instance XSectionL      GhcRn = EpAnnCO-type instance XSectionR      GhcRn = EpAnnCO-type instance XSectionL      GhcTc = DataConCantHappen-type instance XSectionR      GhcTc = DataConCantHappen---type instance XNegApp        GhcPs = EpAnn [AddEpAnn]-type instance XNegApp        GhcRn = NoExtField-type instance XNegApp        GhcTc = NoExtField--type instance XPar           (GhcPass _) = EpAnnCO--type instance XExplicitTuple GhcPs = EpAnn [AddEpAnn]-type instance XExplicitTuple GhcRn = NoExtField-type instance XExplicitTuple GhcTc = NoExtField--type instance XExplicitSum   GhcPs = EpAnn AnnExplicitSum-type instance XExplicitSum   GhcRn = NoExtField-type instance XExplicitSum   GhcTc = [Type]--type instance XCase          GhcPs = EpAnn EpAnnHsCase-type instance XCase          GhcRn = NoExtField-type instance XCase          GhcTc = NoExtField--type instance XIf            GhcPs = EpAnn AnnsIf-type instance XIf            GhcRn = NoExtField-type instance XIf            GhcTc = NoExtField--type instance XMultiIf       GhcPs = EpAnn [AddEpAnn]-type instance XMultiIf       GhcRn = NoExtField-type instance XMultiIf       GhcTc = Type--type instance XLet           GhcPs = EpAnnCO-type instance XLet           GhcRn = NoExtField-type instance XLet           GhcTc = NoExtField--type instance XDo            GhcPs = EpAnn AnnList-type instance XDo            GhcRn = NoExtField-type instance XDo            GhcTc = Type--type instance XExplicitList  GhcPs = EpAnn 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 = EpAnn [AddEpAnn]-type instance XRecordCon     GhcRn = NoExtField-type instance XRecordCon     GhcTc = PostTcExpr   -- Instantiated constructor function--type instance XRecordUpd     GhcPs = EpAnn [AddEpAnn]-type instance XRecordUpd     GhcRn = NoExtField-type instance XRecordUpd     GhcTc = RecordUpdTc--type instance XGetField     GhcPs = EpAnnCO-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 = EpAnn 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 = EpAnn [AddEpAnn]-type instance XExprWithTySig GhcRn = NoExtField-type instance XExprWithTySig GhcTc = NoExtField--type instance XArithSeq      GhcPs = EpAnn [AddEpAnn]-type instance XArithSeq      GhcRn = NoExtField-type instance XArithSeq      GhcTc = PostTcExpr--type instance XSpliceE       (GhcPass _) = EpAnnCO-type instance XProc          (GhcPass _) = EpAnn [AddEpAnn]--type instance XStatic        GhcPs = EpAnn [AddEpAnn]-type instance XStatic        GhcRn = NameSet-type instance XStatic        GhcTc = (NameSet, Type)-  -- Free variables and type of expression, this is stored for convenience as wiring in-  -- StaticPtr is a bit tricky (see #20150)--type instance XPragE         (GhcPass _) = NoExtField--type instance Anno [LocatedA ((StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (body (GhcPass pr)))))] = SrcSpanAnnL-type instance Anno (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))) = SrcSpanAnnA--data AnnExplicitSum-  = AnnExplicitSum {-      aesOpen       :: EpaLocation,-      aesBarsBefore :: [EpaLocation],-      aesBarsAfter  :: [EpaLocation],-      aesClose      :: EpaLocation-      } deriving Data--data AnnFieldLabel-  = AnnFieldLabel {-      afDot :: Maybe EpaLocation-      } deriving Data--data AnnProjection-  = AnnProjection {-      apOpen  :: EpaLocation, -- ^ '('-      apClose :: EpaLocation  -- ^ ')'-      } deriving Data--data AnnsIf-  = AnnsIf {-      aiIf       :: EpaLocation,-      aiThen     :: EpaLocation,-      aiElse     :: EpaLocation,-      aiThenSemi :: Maybe EpaLocation,-      aiElseSemi :: Maybe EpaLocation-      } deriving Data---- -----------------------------------------------------------------------type instance XSCC           (GhcPass _) = EpAnn AnnPragma-type instance XXPragE        (GhcPass _) = DataConCantHappen--type instance XCDotFieldOcc (GhcPass _) = EpAnn AnnFieldLabel-type instance XXDotFieldOcc (GhcPass _) = DataConCantHappen--type instance XPresent         (GhcPass _) = EpAnn [AddEpAnn]--type instance XMissing         GhcPs = EpAnn EpaLocation-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---{- *********************************************************************-*                                                                      *-            XXExpr: the extension constructor of HsExpr-*                                                                      *-********************************************************************* -}--type instance XXExpr GhcPs = DataConCantHappen-type instance XXExpr GhcRn = HsExpansion (HsExpr GhcRn) (HsExpr GhcRn)-type instance XXExpr GhcTc = XXExprGhcTc--- HsExpansion: see Note [Rebindable syntax and HsExpansion] below---data XXExprGhcTc-  = WrapExpr        -- Type and evidence application and abstractions-      {-# UNPACK #-} !(HsWrap HsExpr)--  | ExpansionExpr   -- See Note [Rebindable syntax and HsExpansion] below-      {-# UNPACK #-} !(HsExpansion (HsExpr GhcRn) (HsExpr GhcTc))--  | ConLikeTc      -- Result of typechecking a data-con-                   -- See Note [Typechecking data constructors] in-                   --     GHC.Tc.Gen.Head-                   -- The two arguments describe how to eta-expand-                   -- the data constructor when desugaring-        ConLike [TcTyVar] [Scaled TcType]--  ----------------------------------------  -- Haskell program coverage (Hpc) Support--  | HsTick-     CoreTickish-     (LHsExpr GhcTc)                    -- sub-expression--  | HsBinTick-     Int                                -- module-local tick number for True-     Int                                -- module-local tick number for False-     (LHsExpr GhcTc)                    -- sub-expression---{- *********************************************************************-*                                                                      *-            Pretty-printing expressions-*                                                                      *-********************************************************************* -}--instance (OutputableBndrId p) => Outputable (HsExpr (GhcPass p)) where-    ppr expr = pprExpr expr---------------------------- pprExpr, pprLExpr, pprBinds call pprDeeper;--- the underscore versions do not-pprLExpr :: (OutputableBndrId p) => LHsExpr (GhcPass p) -> SDoc-pprLExpr (L _ e) = pprExpr e--pprExpr :: (OutputableBndrId p) => HsExpr (GhcPass p) -> SDoc-pprExpr e | isAtomicHsExpr e || isQuietHsExpr e =            ppr_expr e-          | otherwise                           = pprDeeper (ppr_expr e)--isQuietHsExpr :: HsExpr id -> Bool--- Parentheses do display something, but it gives little info and--- if we go deeper when we go inside them then we get ugly things--- like (...)-isQuietHsExpr (HsPar {})        = True--- applications don't display anything themselves-isQuietHsExpr (HsApp {})        = True-isQuietHsExpr (HsAppType {})    = True-isQuietHsExpr (OpApp {})        = True-isQuietHsExpr _ = False--pprBinds :: (OutputableBndrId idL, OutputableBndrId idR)-         => HsLocalBindsLR (GhcPass idL) (GhcPass idR) -> SDoc-pprBinds b = pprDeeper (ppr b)--------------------------ppr_lexpr :: (OutputableBndrId p) => LHsExpr (GhcPass p) -> SDoc-ppr_lexpr e = ppr_expr (unLoc e)--ppr_expr :: forall p. (OutputableBndrId p)-         => HsExpr (GhcPass p) -> SDoc-ppr_expr (HsVar _ (L _ v))   = pprPrefixOcc v-ppr_expr (HsUnboundVar _ uv) = pprPrefixOcc uv-ppr_expr (HsRecSel _ f)      = pprPrefixOcc f-ppr_expr (HsIPVar _ v)       = ppr v-ppr_expr (HsOverLabel _ l)   = char '#' <> ppr l-ppr_expr (HsLit _ lit)       = ppr lit-ppr_expr (HsOverLit _ lit)   = ppr lit-ppr_expr (HsPar _ _ e _)     = parens (ppr_lexpr e)--ppr_expr (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-    -- `Solo x`, not `(x)`-  | [Present _ expr] <- exprs-  , Boxed <- boxity-  = hsep [text (mkTupleStr Boxed 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 _ matches)-  = pprMatches matches--ppr_expr (HsLamCase _ lc_variant matches)-  = sep [ sep [lamCaseKeyword lc_variant],-          nest 2 (pprMatches matches) ]--ppr_expr (HsCase _ expr matches@(MG { mg_alts = L _ alts }))-  = sep [ sep [text "case", nest 4 (ppr expr), 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 (map ppr_alt alts))-  where ppr_alt (L _ (GRHS _ guards expr)) =-          hang vbar 2 (ppr_one one_alt)-          where-            ppr_one [] = panic "ppr_exp HsMultiIf"-            ppr_one (h:t) = hang h 2 (sep t)-            one_alt = [ interpp'SP guards-                      , text "->" <+> pprDeeper (ppr expr) ]-        ppr_alt (L _ (XGRHS x)) = ppr x---- special case: let ... in let ...-ppr_expr (HsLet _ _ 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-      Left rbinds -> hang (ppr aexp) 2 (braces (fsep (punctuate comma (map ppr rbinds))))-      Right 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 (HsSpliceE _ s)         = pprSplice s--ppr_expr (HsTypedBracket b e)-  = case ghcPass @p of-    GhcPs -> thTyBrackets (ppr e)-    GhcRn -> thTyBrackets (ppr e)-    GhcTc | HsBracketTc _  _ty _wrap ps <- b ->-      thTyBrackets (ppr e) `ppr_with_pending_tc_splices` ps-ppr_expr (HsUntypedBracket b q)-  = case ghcPass @p of-    GhcPs -> ppr q-    GhcRn -> case b of-      [] -> ppr q-      ps -> ppr q $$ text "pending(rn)" <+> ppr ps-    GhcTc | HsBracketTc rnq  _ty _wrap ps <- b ->-      ppr rnq `ppr_with_pending_tc_splices` ps--ppr_expr (HsProc _ pat (L _ (HsCmdTop _ cmd)))-  = hsep [text "proc", ppr pat, text "->", ppr cmd]--ppr_expr (HsStatic _ e)-  = hsep [text "static", ppr e]--ppr_expr (XExpr x) = case ghcPass @p of-#if __GLASGOW_HASKELL__ < 811-  GhcPs -> ppr x-#endif-  GhcRn -> ppr x-  GhcTc -> ppr x--instance Outputable XXExprGhcTc where-  ppr (WrapExpr (HsWrap co_fn e))-    = pprHsWrapper co_fn (\_parens -> pprExpr e)--  ppr (ExpansionExpr e)-    = ppr e -- e is an HsExpansion, we print the original-            -- expression (LHsExpr GhcPs), not the-            -- desugared one (LHsExpr GhcTc).--  ppr (ConLikeTc con _ _) = pprPrefixOcc con-   -- Used in error messages generated by-   -- the pattern match overlap checker--  ppr (HsTick tickish exp) =-    pprTicks (ppr exp) $-      ppr tickish <+> ppr_lexpr exp--  ppr (HsBinTick tickIdTrue tickIdFalse exp) =-    pprTicks (ppr exp) $-      hcat [text "bintick<",-            ppr tickIdTrue,-            text ",",-            ppr tickIdFalse,-            text ">(",-            ppr exp, text ")"]--ppr_infix_expr :: forall p. (OutputableBndrId p) => HsExpr (GhcPass p) -> Maybe SDoc-ppr_infix_expr (HsVar _ (L _ v))    = Just (pprInfixOcc v)-ppr_infix_expr (HsRecSel _ f)       = Just (pprInfixOcc f)-ppr_infix_expr (HsUnboundVar _ occ) = Just (pprInfixOcc occ)-ppr_infix_expr (XExpr x)            = case ghcPass @p of-#if __GLASGOW_HASKELL__ < 901-                                        GhcPs -> Nothing-#endif-                                        GhcRn -> ppr_infix_expr_rn x-                                        GhcTc -> ppr_infix_expr_tc x-ppr_infix_expr _ = Nothing--ppr_infix_expr_rn :: HsExpansion (HsExpr GhcRn) (HsExpr GhcRn) -> Maybe SDoc-ppr_infix_expr_rn (HsExpanded a _) = ppr_infix_expr a--ppr_infix_expr_tc :: XXExprGhcTc -> Maybe SDoc-ppr_infix_expr_tc (WrapExpr (HsWrap _ e))          = ppr_infix_expr e-ppr_infix_expr_tc (ExpansionExpr (HsExpanded a _)) = ppr_infix_expr a-ppr_infix_expr_tc (ConLikeTc {})                   = Nothing-ppr_infix_expr_tc (HsTick {})                      = Nothing-ppr_infix_expr_tc (HsBinTick {})                   = Nothing--ppr_apps :: (OutputableBndrId p)-         => HsExpr (GhcPass p)-         -> [Either (LHsExpr (GhcPass p)) (LHsWcType (NoGhcTc (GhcPass p)))]-         -> 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 (HsUnboundVar{})               = 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 (HsLamCase{})                  = 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 (HsSpliceE{})                  = False-    go (HsTypedBracket{})             = False-    go (HsUntypedBracket{})           = False-    go (HsProc{})                     = prec > topPrec-    go (HsStatic{})                   = prec >= appPrec-    go (RecordCon{})                  = False-    go (HsRecSel{})                   = False-    go (HsProjection{})               = True-    go (HsGetField{})                 = False-    go (XExpr x) = case ghcPass @p of-                     GhcTc -> go_x_tc x-                     GhcRn -> go_x_rn x-#if __GLASGOW_HASKELL__ <= 900-                     GhcPs -> True-#endif--    go_x_tc :: XXExprGhcTc -> Bool-    go_x_tc (WrapExpr (HsWrap _ e))          = hsExprNeedsParens prec e-    go_x_tc (ExpansionExpr (HsExpanded a _)) = hsExprNeedsParens prec a-    go_x_tc (ConLikeTc {})                   = False-    go_x_tc (HsTick _ (L _ e))               = hsExprNeedsParens prec e-    go_x_tc (HsBinTick _ _ (L _ e))          = hsExprNeedsParens prec e--    go_x_rn :: HsExpansion (HsExpr GhcRn) (HsExpr GhcRn) -> Bool-    go_x_rn (HsExpanded a _) = hsExprNeedsParens prec a----- | Parenthesize an expression without token information-gHsPar :: LHsExpr (GhcPass id) -> HsExpr (GhcPass id)-gHsPar e = HsPar noAnn noHsTok e noHsTok---- | @'parenthesizeHsExpr' p e@ checks if @'hsExprNeedsParens' p e@ is true,--- and if so, surrounds @e@ with an 'HsPar'. Otherwise, it simply returns @e@.-parenthesizeHsExpr :: IsPass p => PprPrec -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)-parenthesizeHsExpr p le@(L loc e)-  | hsExprNeedsParens p e = L loc (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 (HsUnboundVar {}) = True-isAtomicHsExpr (HsRecSel{})      = True-isAtomicHsExpr (XExpr x)-  | GhcTc <- ghcPass @p          = go_x_tc x-  | GhcRn <- ghcPass @p          = go_x_rn x-  where-    go_x_tc (WrapExpr      (HsWrap _ e))     = isAtomicHsExpr e-    go_x_tc (ExpansionExpr (HsExpanded a _)) = isAtomicHsExpr a-    go_x_tc (ConLikeTc {})                   = True-    go_x_tc (HsTick {}) = False-    go_x_tc (HsBinTick {}) = False--    go_x_rn (HsExpanded a _) = isAtomicHsExpr a--isAtomicHsExpr _ = False--instance Outputable (HsPragE (GhcPass p)) where-  ppr (HsPragSCC _ st (StringLiteral stl lbl _)) =-    pprWithSourceText st (text "{-# SCC")-     -- no doublequotes if stl empty, for the case where the SCC was written-     -- without quotes.-    <+> pprWithSourceText stl (ftext lbl) <+> text "#-}"---{- *********************************************************************-*                                                                      *-             HsExpansion and rebindable syntax-*                                                                      *-********************************************************************* -}--{- Note [Rebindable syntax and HsExpansion]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-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-'HsExpansion' 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-      (HsExpanded-        (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 (HsExpansion 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 (HsExpanded <original node> <desugared>)-        for patterns, XPat (HsPatExpanded <original node> <desugared>)- - At typechecking-time:-    - remove any logic that was previously dealing with your rebindable-      construct, typically involving [tc]SyntaxOp, SyntaxExpr and friends.-    - the XExpr (HsExpanded ... ...) 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-HsExpansion].--When OverloadedRecordDot is enabled:-- Field selection expressions-  - e.g. foo.bar.baz-  - Have abstract syntax HsGetField-  - After renaming are XExpr (HsExpanded (HsGetField ...) (getField @"..."...)) expressions-- Field selector expressions e.g. (.x.y)-  - Have abstract syntax HsProjection-  - After renaming are XExpr (HsExpanded (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 (HsExpanded (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.--}---- See Note [Rebindable syntax and HsExpansion] just above.-data HsExpansion orig expanded-  = HsExpanded orig expanded-  deriving Data---- | Just print the original expression (the @a@).-instance (Outputable a, Outputable b) => Outputable (HsExpansion a b) where-  ppr (HsExpanded orig expanded)-    = ifPprDebug (vcat [ppr orig, braces (text "Expansion:" <+> ppr expanded)])-                 (ppr orig)---{--************************************************************************-*                                                                      *-\subsection{Commands (in arrow abstractions)}-*                                                                      *-************************************************************************--}--type instance XCmdArrApp  GhcPs = EpAnn AddEpAnn-type instance XCmdArrApp  GhcRn = NoExtField-type instance XCmdArrApp  GhcTc = Type--type instance XCmdArrForm GhcPs = EpAnn AnnList-type instance XCmdArrForm GhcRn = NoExtField-type instance XCmdArrForm GhcTc = NoExtField--type instance XCmdApp     (GhcPass _) = EpAnnCO-type instance XCmdLam     (GhcPass _) = NoExtField-type instance XCmdPar     (GhcPass _) = EpAnnCO--type instance XCmdCase    GhcPs = EpAnn EpAnnHsCase-type instance XCmdCase    GhcRn = NoExtField-type instance XCmdCase    GhcTc = NoExtField--type instance XCmdLamCase (GhcPass _) = EpAnn [AddEpAnn]--type instance XCmdIf      GhcPs = EpAnn AnnsIf-type instance XCmdIf      GhcRn = NoExtField-type instance XCmdIf      GhcTc = NoExtField--type instance XCmdLet     GhcPs = EpAnnCO-type instance XCmdLet     GhcRn = NoExtField-type instance XCmdLet     GhcTc = NoExtField--type instance XCmdDo      GhcPs = EpAnn AnnList-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--type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsCmd (GhcPass pr))))]-  = SrcSpanAnnL--    -- If   cmd :: arg1 --> res-    --      wrap :: arg1 "->" arg2-    -- Then (XCmd (HsWrap wrap cmd)) :: arg2 --> res--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 _ matches)-  = pprMatches matches--ppr_cmd (HsCmdCase _ expr matches)-  = sep [ sep [text "case", nest 4 (ppr expr), text "of"],-          nest 2 (pprMatches matches) ]--ppr_cmd (HsCmdLamCase _ lc_variant matches)-  = sep [ lamCaseKeyword lc_variant, nest 2 (pprMatches matches) ]--ppr_cmd (HsCmdIf _ _ e ct ce)-  = sep [hsep [text "if", nest 2 (ppr e), 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 _ (L _ op) ps_fix rn_fix args)-  | HsVar _ (L _ v) <- op-  = ppr_cmd_infix v-  | GhcTc <- ghcPass @p-  , XExpr (ConLikeTc c _ _) <- op-  = ppr_cmd_infix (conLikeName c)-  | otherwise-  = fall_through-  where-    fall_through = hang (text "(|" <+> ppr_expr op)-                      4 (sep (map (pprCmdArg.unLoc) args) <+> text "|)")--    ppr_cmd_infix :: OutputableBndr v => v -> SDoc-    ppr_cmd_infix v-      | [arg1, arg2] <- args-      , isJust rn_fix || ps_fix == Infix-      = hang (pprCmdArg (unLoc arg1))-           4 (sep [ pprInfixOcc v, pprCmdArg (unLoc arg2)])-      | otherwise-      = fall_through--ppr_cmd (XCmd x) = case ghcPass @p of-#if __GLASGOW_HASKELL__ < 811-  GhcPs -> ppr x-  GhcRn -> ppr x-#endif-  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 = NoExtField-type instance XMG         GhcRn b = NoExtField-type instance XMG         GhcTc b = MatchGroupTc--type instance XXMatchGroup (GhcPass _) b = DataConCantHappen--type instance XCMatch (GhcPass _) b = EpAnn [AddEpAnn]-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--- 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 (GhcPass id) body -> [LPat (GhcPass id)]-hsLMatchPats (L _ (Match { m_pats = pats })) = pats---- 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 EpaLocation, -- TODO:AZ do we need this?-      ga_sep  :: AddEpAnn -- ^ Match separator location-      } deriving (Data)--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 (GhcPass p)) grhss)]--pprMatch :: (OutputableBndrId idR, Outputable body)-         => Match (GhcPass idR) body -> SDoc-pprMatch (Match { m_pats = pats, m_ctxt = ctxt, m_grhss = grhss })-  = sep [ sep (herald : map (nest 2 . pprParendLPat appPrec) other_pats)-        , nest 2 (pprGRHSs ctxt grhss) ]-  where-    (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)--            LambdaExpr -> (char '\\', pats)--            -- We don't simply return (empty, pats) to avoid introducing an-            -- additional `nest 2` via the empty herald-            LamCaseAlt LamCases ->-              maybe (empty, []) (first $ pprParendLPat appPrec) (uncons pats)--            ArrowMatchCtxt (ArrowLamCaseAlt LamCases) ->-              maybe (empty, []) (first $ pprParendLPat appPrec) (uncons pats)--            ArrowMatchCtxt KappaExpr -> (char '\\', pats)--            ArrowMatchCtxt ProcExpr -> (text "proc", pats)--            _ -> case pats of-                   []    -> (empty, [])-                   [pat] -> (ppr pat, [])  -- No parens around the single pat in a case-                   _     -> pprPanic "pprMatch" (ppr ctxt $$ ppr pats)--pprGRHSs :: (OutputableBndrId idR, Outputable body)-         => HsMatchContext passL -> GRHSs (GhcPass idR) body -> SDoc-pprGRHSs ctxt (GRHSs _ grhss 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 passL -> 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 passL -> body -> SDoc-pp_rhs ctxt rhs = matchSeparator ctxt <+> pprDeeper (ppr rhs)--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 = EpAnn [AddEpAnn]-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 b = NoExtField-type instance XApplicativeStmt (GhcPass _) GhcRn b = NoExtField-type instance XApplicativeStmt (GhcPass _) GhcTc b = Type--type instance XBodyStmt        (GhcPass _) GhcPs b = NoExtField-type instance XBodyStmt        (GhcPass _) GhcRn b = NoExtField-type instance XBodyStmt        (GhcPass _) GhcTc b = Type--type instance XLetStmt         (GhcPass _) (GhcPass _) b = EpAnn [AddEpAnn]--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 = EpAnn [AddEpAnn]-type instance XTransStmt       (GhcPass _) GhcRn b = NoExtField-type instance XTransStmt       (GhcPass _) GhcTc b = Type--type instance XRecStmt         (GhcPass _) GhcPs b = EpAnn AnnList-type instance XRecStmt         (GhcPass _) GhcRn b = NoExtField-type instance XRecStmt         (GhcPass _) GhcTc b = RecStmtTc--type instance XXStmtLR         (GhcPass _) (GhcPass _) b = DataConCantHappen--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 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 (ApplicativeStmt _ args mb_join)-  = getPprStyle $ \style ->-      if userStyle style-         then pp_for_user-         else pp_debug-  where-  -- make all the Applicative stuff invisible in error messages by-  -- flattening the whole ApplicativeStmt nest back to a sequence-  -- of statements.-   pp_for_user = vcat $ concatMap flattenArg args--   -- ppr directly rather than transforming here, because we need to-   -- inject a "return" which is hard when we're polymorphic in the id-   -- type.-   flattenStmt :: ExprLStmt (GhcPass idL) -> [SDoc]-   flattenStmt (L _ (ApplicativeStmt _ args _)) = concatMap flattenArg args-   flattenStmt stmt = [ppr stmt]--   flattenArg :: forall a . (a, ApplicativeArg (GhcPass idL)) -> [SDoc]-   flattenArg (_, ApplicativeArgOne _ pat expr isBody)-     | isBody =  [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-*                                                                      *-************************************************************************--}--newtype HsSplicedT = HsSplicedT DelayedSplice deriving (Data)--type instance XTypedSplice   (GhcPass _) = EpAnn [AddEpAnn]-type instance XUntypedSplice (GhcPass _) = EpAnn [AddEpAnn]-type instance XQuasiQuote    (GhcPass _) = NoExtField-type instance XSpliced       (GhcPass _) = NoExtField-type instance XXSplice       GhcPs       = DataConCantHappen-type instance XXSplice       GhcRn       = DataConCantHappen-type instance XXSplice       GhcTc       = HsSplicedT---- 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---- | Pending Renamer Splice-data PendingRnSplice-  = PendingRnSplice UntypedSpliceFlavour SplicePointName (LHsExpr GhcRn)---- | Pending Type-checker Splice-data PendingTcSplice-  = PendingTcSplice SplicePointName (LHsExpr GhcTc)--{--Note [Pending Splices]-~~~~~~~~~~~~~~~~~~~~~~-When we rename an untyped bracket, we name and lift out all the nested-splices, so that when the typechecker hits the bracket, it can-typecheck those nested splices without having to walk over the untyped-bracket code.  So for example-    [| f $(g x) |]-looks like--    HsUntypedBracket _ (HsApp (HsVar "f") (HsSpliceE _ (HsUntypedSplice sn (g x)))--which the renamer rewrites to--    HsUntypedBracket-        [PendingRnSplice UntypedExpSplice sn (g x)]-        (HsApp (HsVar f) (HsSpliceE _ (HsUntypedSplice sn (g x)))--* The 'sn' is the Name of the splice point, the SplicePointName--* The PendingRnExpSplice gives the splice that splice-point name maps to;-  and the typechecker can now conveniently find these sub-expressions--* Note that a nested splice, such as the `$(g x)` now appears twice:-  - In the PendingRnSplice: this is the version that will later be typechecked-  - In the HsSpliceE in the body of the bracket. This copy is used only for pretty printing.--There are four varieties of pending splices generated by the renamer,-distinguished by their UntypedSpliceFlavour-- * 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 GHC.Rename.Splice.makePending, HsQuasiQuote case)--     * cross-stage lifting, where the pending expression expands to-          $(lift x)-       (see GHC.Rename.Splice.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)||]--}--instance OutputableBndrId p-       => Outputable (HsSplicedThing (GhcPass p)) where-  ppr (HsSplicedExpr e) = ppr_expr e-  ppr (HsSplicedTy   t) = ppr t-  ppr (HsSplicedPat  p) = ppr p--instance (OutputableBndrId p) => Outputable (HsSplice (GhcPass p)) where-  ppr s = pprSplice s--pprPendingSplice :: (OutputableBndrId p)-                 => SplicePointName -> LHsExpr (GhcPass p) -> SDoc-pprPendingSplice n e = angleBrackets (ppr n <> comma <+> ppr (stripParensLHsExpr e))--pprSpliceDecl ::  (OutputableBndrId p)-          => HsSplice (GhcPass p) -> SpliceExplicitFlag -> SDoc-pprSpliceDecl e@HsQuasiQuote{} _ = pprSplice e-pprSpliceDecl e ExplicitSplice   = text "$" <> ppr_splice_decl e-pprSpliceDecl e ImplicitSplice   = ppr_splice_decl e--ppr_splice_decl :: (OutputableBndrId p)-                => HsSplice (GhcPass p) -> SDoc-ppr_splice_decl (HsUntypedSplice _ _ n e) = ppr_splice empty n e empty-ppr_splice_decl e = pprSplice e--pprSplice :: forall p. (OutputableBndrId p) => HsSplice (GhcPass p) -> SDoc-pprSplice (HsTypedSplice _ DollarSplice n e)-  = ppr_splice (text "$$") n e empty-pprSplice (HsTypedSplice _ BareSplice _ _ )-  = panic "Bare typed splice"  -- impossible-pprSplice (HsUntypedSplice _ DollarSplice n e)-  = ppr_splice (text "$")  n e empty-pprSplice (HsUntypedSplice _ BareSplice n e)-  = ppr_splice empty  n e empty-pprSplice (HsQuasiQuote _ n q _ s)      = ppr_quasi n q s-pprSplice (HsSpliced _ _ thing)         = ppr thing-pprSplice (XSplice x)                   = case ghcPass @p of-#if __GLASGOW_HASKELL__ < 811-                                            GhcPs -> dataConCantHappen x-                                            GhcRn -> dataConCantHappen x-#endif-                                            GhcTc -> case x of-                                                       HsSplicedT _ -> text "Unevaluated typed splice"--ppr_quasi :: OutputableBndr p => p -> p -> FastString -> SDoc-ppr_quasi n quoter quote = whenPprDebug (brackets (ppr n)) <>-                           char '[' <> ppr quoter <> vbar <>-                           ppr quote <> text "|]"--ppr_splice :: (OutputableBndrId p)-           => SDoc -> (IdP (GhcPass p)) -> LHsExpr (GhcPass p) -> SDoc -> SDoc-ppr_splice herald n e trail-    = herald <> whenPprDebug (brackets (ppr n)) <> ppr e <> trail---type instance XExpBr  GhcPs       = NoExtField-type instance XPatBr  GhcPs       = NoExtField-type instance XDecBrL GhcPs       = NoExtField-type instance XDecBrG GhcPs       = NoExtField-type instance XTypBr  GhcPs       = NoExtField-type instance XVarBr  GhcPs       = NoExtField-type instance XXQuote GhcPs       = DataConCantHappen--type instance XExpBr  GhcRn       = NoExtField-type instance XPatBr  GhcRn       = NoExtField-type instance XDecBrL GhcRn       = NoExtField-type instance XDecBrG GhcRn       = NoExtField-type instance XTypBr  GhcRn       = NoExtField-type instance XVarBr  GhcRn       = NoExtField-type instance XXQuote GhcRn       = DataConCantHappen---- See Note [The life cycle of a TH quotation]-type instance XExpBr  GhcTc       = DataConCantHappen-type instance XPatBr  GhcTc       = DataConCantHappen-type instance XDecBrL GhcTc       = DataConCantHappen-type instance XDecBrG GhcTc       = DataConCantHappen-type instance XTypBr  GhcTc       = DataConCantHappen-type instance XVarBr  GhcTc       = DataConCantHappen-type instance XXQuote GhcTc       = NoExtField--instance OutputableBndrId p-          => Outputable (HsQuote (GhcPass p)) where-  ppr = pprHsQuote-    where-      pprHsQuote :: forall p. (OutputableBndrId p)-                   => HsQuote (GhcPass p) -> SDoc-      pprHsQuote (ExpBr _ e)   = thBrackets empty (ppr e)-      pprHsQuote (PatBr _ p)   = thBrackets (char 'p') (ppr p)-      pprHsQuote (DecBrG _ gp) = thBrackets (char 'd') (ppr gp)-      pprHsQuote (DecBrL _ ds) = thBrackets (char 'd') (vcat (map ppr ds))-      pprHsQuote (TypBr _ t)   = thBrackets (char 't') (ppr t)-      pprHsQuote (VarBr _ True n)-        = char '\'' <> pprPrefixOcc (unLoc n)-      pprHsQuote (VarBr _ False n)-        = text "''" <> pprPrefixOcc (unLoc n)-      pprHsQuote (XQuote b)  = case ghcPass @p of-#if __GLASGOW_HASKELL__ <= 900-          GhcPs -> dataConCantHappen b-          GhcRn -> dataConCantHappen b-#endif-          GhcTc -> pprPanic "pprHsQuote: `HsQuote GhcTc` shouldn't exist" (ppr b)-                   -- See Note [The life cycle of a TH quotation]--thBrackets :: SDoc -> SDoc -> SDoc-thBrackets pp_kind pp_body = char '[' <> pp_kind <> vbar <+>-                             pp_body <+> text "|]"--thTyBrackets :: SDoc -> SDoc-thTyBrackets pp_body = text "[||" <+> pp_body <+> text "||]"--instance Outputable PendingRnSplice where-  ppr (PendingRnSplice _ n e) = pprPendingSplice n e--instance Outputable PendingTcSplice where-  ppr (PendingTcSplice n e) = pprPendingSplice n e--ppr_with_pending_tc_splices :: SDoc -> [PendingTcSplice] -> SDoc-ppr_with_pending_tc_splices x [] = x-ppr_with_pending_tc_splices x ps = x $$ text "pending(tc)" <+> ppr ps--{--************************************************************************-*                                                                      *-\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}-*                                                                      *-************************************************************************--}--instance OutputableBndrId p => Outputable (HsMatchContext (GhcPass p)) where-  ppr m@(FunRhs{})            = text "FunRhs" <+> ppr (mc_fun m) <+> ppr (mc_fixity m)-  ppr LambdaExpr              = text "LambdaExpr"-  ppr CaseAlt                 = text "CaseAlt"-  ppr (LamCaseAlt lc_variant) = text "LamCaseAlt" <+> ppr lc_variant-  ppr IfAlt                   = text "IfAlt"-  ppr (ArrowMatchCtxt c)      = text "ArrowMatchCtxt" <+> ppr c-  ppr PatBindRhs              = text "PatBindRhs"-  ppr PatBindGuards           = text "PatBindGuards"-  ppr RecUpd                  = text "RecUpd"-  ppr (StmtCtxt _)            = text "StmtCtxt _"-  ppr ThPatSplice             = text "ThPatSplice"-  ppr ThPatQuote              = text "ThPatQuote"-  ppr PatSyn                  = text "PatSyn"--instance Outputable LamCaseVariant where-  ppr = text . \case-    LamCase  -> "LamCase"-    LamCases -> "LamCases"--instance Outputable HsArrowMatchContext where-  ppr ProcExpr                     = text "ProcExpr"-  ppr ArrowCaseAlt                 = text "ArrowCaseAlt"-  ppr (ArrowLamCaseAlt lc_variant) = parens $ text "ArrowLamCaseAlt" <+> ppr lc_variant-  ppr KappaExpr                    = text "KappaExpr"---------------------instance OutputableBndrId p-      => Outputable (HsStmtContext (GhcPass p)) where-    ppr = pprStmtContext---- Used to generate the string for a *runtime* error message-matchContextErrString :: OutputableBndrId p-                      => HsMatchContext (GhcPass p) -> SDoc-matchContextErrString (FunRhs{mc_fun=L _ fun})      = text "function" <+> ppr fun-matchContextErrString CaseAlt                       = text "case"-matchContextErrString (LamCaseAlt lc_variant)       = lamCaseKeyword lc_variant-matchContextErrString IfAlt                         = text "multi-way if"-matchContextErrString PatBindRhs                    = text "pattern binding"-matchContextErrString PatBindGuards                 = text "pattern binding guards"-matchContextErrString RecUpd                        = text "record update"-matchContextErrString LambdaExpr                    = text "lambda"-matchContextErrString (ArrowMatchCtxt c)            = matchArrowContextErrString c-matchContextErrString ThPatSplice                   = panic "matchContextErrString"  -- Not used at runtime-matchContextErrString ThPatQuote                    = panic "matchContextErrString"  -- Not used at runtime-matchContextErrString PatSyn                        = panic "matchContextErrString"  -- Not used at runtime-matchContextErrString (StmtCtxt (ParStmtCtxt c))    = matchContextErrString (StmtCtxt c)-matchContextErrString (StmtCtxt (TransStmtCtxt c))  = matchContextErrString (StmtCtxt c)-matchContextErrString (StmtCtxt (PatGuard _))       = text "pattern guard"-matchContextErrString (StmtCtxt (ArrowExpr))        = text "'do' block"-matchContextErrString (StmtCtxt (HsDoStmt flavour)) = matchDoContextErrString flavour--matchArrowContextErrString :: HsArrowMatchContext -> SDoc-matchArrowContextErrString ProcExpr                     = text "proc"-matchArrowContextErrString ArrowCaseAlt                 = text "case"-matchArrowContextErrString (ArrowLamCaseAlt lc_variant) = lamCaseKeyword lc_variant-matchArrowContextErrString KappaExpr                    = text "kappa"--matchDoContextErrString :: HsDoFlavour -> SDoc-matchDoContextErrString GhciStmtCtxt = text "interactive GHCi command"-matchDoContextErrString (DoExpr m)   = prependQualified m (text "'do' block")-matchDoContextErrString (MDoExpr m)  = prependQualified m (text "'mdo' block")-matchDoContextErrString ListComp     = text "list comprehension"-matchDoContextErrString MonadComp    = text "monad comprehension"--pprMatchInCtxt :: (OutputableBndrId idR, Outputable body)-               => Match (GhcPass idR) body -> SDoc-pprMatchInCtxt match  = hang (text "In" <+> pprMatchContext (m_ctxt match)-                                        <> colon)-                             4 (pprMatch match)--pprStmtInCtxt :: (OutputableBndrId idL,-                  OutputableBndrId idR,-                  OutputableBndrId ctx,-                  Outputable body,-                 Anno (StmtLR (GhcPass idL) (GhcPass idR) body) ~ SrcSpanAnnA)-              => HsStmtContext (GhcPass ctx)-              -> 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--{--************************************************************************-*                                                                      *-\subsection{Anno instances}-*                                                                      *-************************************************************************--}--type instance Anno (HsExpr (GhcPass p)) = SrcSpanAnnA-type instance Anno [LocatedA ((StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsExpr (GhcPass pr)))))] = SrcSpanAnnL-type instance Anno [LocatedA ((StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsCmd (GhcPass pr)))))] = SrcSpanAnnL--type instance Anno (HsCmd (GhcPass p)) = SrcSpanAnnA--type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsCmd (GhcPass pr))))]-  = SrcSpanAnnL-type instance Anno (HsCmdTop (GhcPass p)) = SrcAnn NoEpAnns-type instance Anno [LocatedA (Match (GhcPass p) (LocatedA (HsExpr (GhcPass p))))] = SrcSpanAnnL-type instance Anno [LocatedA (Match (GhcPass p) (LocatedA (HsCmd  (GhcPass p))))] = SrcSpanAnnL-type instance Anno (Match (GhcPass p) (LocatedA (HsExpr (GhcPass p)))) = SrcSpanAnnA-type instance Anno (Match (GhcPass p) (LocatedA (HsCmd  (GhcPass p)))) = SrcSpanAnnA-type instance Anno (GRHS (GhcPass p) (LocatedA (HsExpr (GhcPass p)))) = SrcAnn NoEpAnns-type instance Anno (GRHS (GhcPass p) (LocatedA (HsCmd  (GhcPass p)))) = SrcAnn NoEpAnns-type instance Anno (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsExpr (GhcPass pr)))) = SrcSpanAnnA-type instance Anno (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsCmd  (GhcPass pr)))) = SrcSpanAnnA--type instance Anno (HsSplice (GhcPass p)) = SrcSpanAnnA--type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsExpr (GhcPass pr))))] = SrcSpanAnnL-type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsCmd  (GhcPass pr))))] = SrcSpanAnnL--type instance Anno (FieldLabelStrings (GhcPass p)) = SrcAnn NoEpAnns-type instance Anno (FieldLabelString) = SrcAnn NoEpAnns-type instance Anno (DotFieldOcc (GhcPass p)) = SrcAnn NoEpAnns--instance (Anno a ~ SrcSpanAnn' (EpAnn an))+{-# OPTIONS_GHC -Wno-orphans #-} -- Outputable++{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+-}++-- | Abstract Haskell syntax for expressions.+module GHC.Hs.Expr+  ( module Language.Haskell.Syntax.Expr+  , module GHC.Hs.Expr+  ) where++import Language.Haskell.Syntax.Expr++-- friends:+import GHC.Prelude++import GHC.Hs.Basic() -- import instances+import GHC.Hs.Decls() -- import instances+import GHC.Hs.Pat+import GHC.Hs.Lit+import Language.Haskell.Syntax.Extension+import Language.Haskell.Syntax.Basic (FieldLabelString(..))+import GHC.Hs.Extension+import GHC.Hs.Type+import GHC.Hs.Binds+import GHC.Parser.Annotation++-- others:+import GHC.Tc.Types.Evidence+import GHC.Types.Id.Info ( RecSelParent )+import GHC.Types.Name+import GHC.Types.Name.Reader+import GHC.Types.Name.Set+import GHC.Types.Basic+import GHC.Types.Fixity+import GHC.Types.SourceText+import GHC.Types.SrcLoc+import GHC.Types.Tickish (CoreTickish)+import GHC.Types.Unique.Set (UniqSet)+import GHC.Types.ThLevelIndex+import GHC.Core.ConLike ( conLikeName, ConLike )+import GHC.Unit.Module (ModuleName)+import GHC.Utils.Misc+import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Data.FastString+import GHC.Core.Type+import GHC.Builtin.Types (mkTupleStr)+import GHC.Tc.Utils.TcType (TcType, TcTyVar)+import {-# SOURCE #-} GHC.Tc.Types.LclEnv (TcLclEnv)++import GHCi.RemoteTypes ( ForeignRef )+import qualified GHC.Boot.TH.Syntax as TH (Q)++-- libraries:+import Data.Data hiding (Fixity(..))+import qualified Data.Data as Data (Fixity(..))+import qualified Data.Kind+import Data.Maybe (isJust)+import Data.Foldable ( toList )+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NE+import Data.Void (Void)+import qualified Data.Set as S+{- *********************************************************************+*                                                                      *+                Expressions proper+*                                                                      *+********************************************************************* -}++-- | Post-Type checking Expression+--+-- PostTcExpr is an evidence expression attached to the syntax tree by the+-- type checker (c.f. postTcType).+type PostTcExpr  = HsExpr GhcTc++-- | Post-Type checking Table+--+-- We use a PostTcTable where there are a bunch of pieces of evidence, more+-- than is convenient to keep individually.+type PostTcTable = [(Name, PostTcExpr)]++-------------------------++-- Defining SyntaxExpr in two stages allows for better type inference, because+-- we can declare SyntaxExprGhc to be injective (and closed). Without injectivity,+-- noSyntaxExpr would be ambiguous.+type instance SyntaxExpr (GhcPass p) = SyntaxExprGhc p++type family SyntaxExprGhc (p :: Pass) = (r :: Data.Kind.Type) | r -> p where+  SyntaxExprGhc 'Parsed      = NoExtField+  SyntaxExprGhc 'Renamed     = SyntaxExprRn+  SyntaxExprGhc 'Typechecked = SyntaxExprTc++-- | The function to use in rebindable syntax. See Note [NoSyntaxExpr].+data SyntaxExprRn = SyntaxExprRn (HsExpr GhcRn)+    -- Why is the payload not just a Name?+    -- See Note [Monad fail : Rebindable syntax, overloaded strings] in "GHC.Rename.Expr"+                  | NoSyntaxExprRn++-- | An expression with wrappers, used for rebindable syntax+--+-- This should desugar to+--+-- > syn_res_wrap $ syn_expr (syn_arg_wraps[0] arg0)+-- >                         (syn_arg_wraps[1] arg1) ...+--+-- where the actual arguments come from elsewhere in the AST.+data SyntaxExprTc = SyntaxExprTc { syn_expr      :: HsExpr GhcTc+                                 , syn_arg_wraps :: [HsWrapper]+                                 , syn_res_wrap  :: HsWrapper }+                  | NoSyntaxExprTc  -- See Note [NoSyntaxExpr]++-- | This is used for rebindable-syntax pieces that are too polymorphic+-- for tcSyntaxOp (trS_fmap and the mzip in ParStmt)+noExpr :: HsExpr (GhcPass p)+noExpr = HsLit noExtField (HsString (SourceText $ fsLit "noExpr") (fsLit "noExpr"))++noSyntaxExpr :: forall p. IsPass p => SyntaxExpr (GhcPass p)+                              -- Before renaming, and sometimes after+                              -- See Note [NoSyntaxExpr]+noSyntaxExpr = case ghcPass @p of+  GhcPs -> noExtField+  GhcRn -> NoSyntaxExprRn+  GhcTc -> NoSyntaxExprTc++-- | Make a 'SyntaxExpr GhcRn' from an expression+-- Used only in getMonadFailOp.+-- See Note [Monad fail : Rebindable syntax, overloaded strings] in "GHC.Rename.Expr"+mkSyntaxExpr :: HsExpr GhcRn -> SyntaxExprRn+mkSyntaxExpr = SyntaxExprRn++instance Outputable SyntaxExprRn where+  ppr (SyntaxExprRn expr) = ppr expr+  ppr NoSyntaxExprRn      = text "<no syntax expr>"++instance Outputable SyntaxExprTc where+  ppr (SyntaxExprTc { syn_expr      = expr+                    , syn_arg_wraps = arg_wraps+                    , syn_res_wrap  = res_wrap })+    = sdocOption sdocPrintExplicitCoercions $ \print_co ->+      getPprDebug $ \debug ->+      if debug || print_co+      then ppr expr <> braces (pprWithCommas ppr arg_wraps)+                    <> braces (ppr res_wrap)+      else ppr expr++  ppr NoSyntaxExprTc = text "<no syntax expr>"++-- | HsWrap appears only in typechecker output+data HsWrap hs_syn = HsWrap HsWrapper      -- the wrapper+                            (hs_syn GhcTc) -- the thing that is wrapped++deriving instance (Data (hs_syn GhcTc), Typeable hs_syn) => Data (HsWrap hs_syn)++-- ---------------------------------------------------------------------++data HsBracketTc = HsBracketTc+  { hsb_quote   :: HsQuote GhcRn        -- See Note [The life cycle of a TH quotation]+  , hsb_ty      :: Type+  , hsb_wrap    :: Maybe QuoteWrapper   -- The wrapper to apply type and dictionary argument to the quote.+  , hsb_splices :: [PendingTcSplice]    -- Output of the type checker is the *original*+                                        -- renamed expression, plus+                                        -- _typechecked_ splices to be+                                        -- pasted back in by the desugarer+  }++type instance XTypedBracket GhcPs = (BracketAnn (EpToken "[||") (EpToken "[e||"), EpToken "||]")+type instance XTypedBracket GhcRn = NoExtField+type instance XTypedBracket GhcTc = HsBracketTc+type instance XUntypedBracket GhcPs = NoExtField+type instance XUntypedBracket GhcRn = [PendingRnSplice] -- See Note [Pending Splices]+                                                        -- Output of the renamer is the *original* renamed expression,+                                                        -- plus _renamed_ splices to be type checked+type instance XUntypedBracket GhcTc = HsBracketTc++data BracketAnn noE hasE+  = BracketNoE noE+  | BracketHasE hasE+  deriving Data++instance (NoAnn n, NoAnn h) => NoAnn (BracketAnn n h) where+  noAnn = BracketNoE noAnn++-- ---------------------------------------------------------------------++-- API Annotations types++data EpAnnHsCase = EpAnnHsCase+      { hsCaseAnnCase :: EpToken "case"+      , hsCaseAnnOf   :: EpToken "of"+      } deriving Data++instance NoAnn EpAnnHsCase where+  noAnn = EpAnnHsCase noAnn noAnn++data EpAnnLam = EpAnnLam+      { epl_lambda :: EpToken "\\"      -- ^ Location of '\' keyword+      , epl_case   :: Maybe EpaLocation -- ^ Location of 'case' or+                                        -- 'cases' keyword, depending+                                        -- on related 'HsLamVariant'.+      } deriving Data++instance NoAnn EpAnnLam where+  noAnn = EpAnnLam noAnn noAnn++-- Record selectors at parse time are HsVar; they convert to HsRecSel+-- on renaming.+type instance XRecSel              GhcPs = DataConCantHappen+type instance XRecSel              GhcRn = NoExtField+type instance XRecSel              GhcTc = NoExtField++-- OverLabel not present in GhcTc pass; see GHC.Rename.Expr+-- Note [Handling overloaded and rebindable constructs]+type instance XOverLabel     GhcPs = SourceText+type instance XOverLabel     GhcRn = SourceText+type instance XOverLabel     GhcTc = DataConCantHappen++-- ---------------------------------------------------------------------++type instance XVar           (GhcPass _) = NoExtField++type instance XIPVar         GhcPs = NoExtField+type instance XIPVar         GhcRn = NoExtField+type instance XIPVar         GhcTc = DataConCantHappen+type instance XOverLitE      (GhcPass _) = NoExtField+type instance XLitE          (GhcPass _) = NoExtField+type instance XLam           (GhcPass _) = EpAnnLam+type instance XApp           (GhcPass _) = NoExtField++type instance XAppTypeE      GhcPs = EpToken "@"+type instance XAppTypeE      GhcRn = NoExtField+type instance XAppTypeE      GhcTc = Type++-- OpApp not present in GhcTc pass; see GHC.Rename.Expr+-- Note [Handling overloaded and rebindable constructs]+type instance XOpApp         GhcPs = NoExtField+type instance XOpApp         GhcRn = Fixity+type instance XOpApp         GhcTc = DataConCantHappen++-- SectionL, SectionR not present in GhcTc pass; see GHC.Rename.Expr+-- Note [Handling overloaded and rebindable constructs]+type instance XSectionL      GhcPs = NoExtField+type instance XSectionR      GhcPs = NoExtField+type instance XSectionL      GhcRn = NoExtField+type instance XSectionR      GhcRn = NoExtField+type instance XSectionL      GhcTc = DataConCantHappen+type instance XSectionR      GhcTc = DataConCantHappen+++type instance XNegApp        GhcPs = EpToken "-"+type instance XNegApp        GhcRn = NoExtField+type instance XNegApp        GhcTc = NoExtField++type instance XPar           GhcPs = (EpToken "(", EpToken ")")+type instance XPar           GhcRn = NoExtField+type instance XPar           GhcTc = NoExtField++type instance XExplicitTuple GhcPs = (EpaLocation, EpaLocation)+type instance XExplicitTuple GhcRn = NoExtField+type instance XExplicitTuple GhcTc = NoExtField++type instance XExplicitSum   GhcPs = AnnExplicitSum+type instance XExplicitSum   GhcRn = NoExtField+type instance XExplicitSum   GhcTc = [Type]++type instance XCase          GhcPs = EpAnnHsCase+type instance XCase          GhcRn = HsMatchContextRn+type instance XCase          GhcTc = HsMatchContextRn++type instance XIf            GhcPs = AnnsIf+type instance XIf            GhcRn = NoExtField+type instance XIf            GhcTc = NoExtField++type instance XMultiIf       GhcPs = (EpToken "if", EpToken "{", EpToken "}")+type instance XMultiIf       GhcRn = NoExtField+type instance XMultiIf       GhcTc = Type++type instance XLet           GhcPs = (EpToken "let", EpToken "in")+type instance XLet           GhcRn = NoExtField+type instance XLet           GhcTc = NoExtField++type instance XDo            GhcPs = AnnList EpaLocation+type instance XDo            GhcRn = NoExtField+type instance XDo            GhcTc = Type++type instance XExplicitList  GhcPs = AnnList ()+type instance XExplicitList  GhcRn = NoExtField+type instance XExplicitList  GhcTc = Type+-- GhcPs: ExplicitList includes all source-level+--   list literals, including overloaded ones+-- GhcRn and GhcTc: ExplicitList used only for list literals+--   that denote Haskell's built-in lists.  Overloaded lists+--   have been expanded away in the renamer+-- See Note [Handling overloaded and rebindable constructs]+-- in  GHC.Rename.Expr++type instance XRecordCon     GhcPs = (Maybe (EpToken "{"), Maybe (EpToken "}"))+type instance XRecordCon     GhcRn = NoExtField+type instance XRecordCon     GhcTc = PostTcExpr   -- Instantiated constructor function++type instance XRecordUpd     GhcPs = (Maybe (EpToken "{"), Maybe (EpToken "}"))+type instance XRecordUpd     GhcRn = NoExtField+type instance XRecordUpd     GhcTc = DataConCantHappen+  -- We desugar record updates in the typechecker.+  -- See [Handling overloaded and rebindable constructs],+  -- and [Record Updates] in GHC.Tc.Gen.Expr.++-- | Information about the parent of a record update:+--+--  - the parent type constructor or pattern synonym,+--  - the relevant con-likes,+--  - the field labels.+data family HsRecUpdParent x++data instance HsRecUpdParent GhcPs+data instance HsRecUpdParent GhcRn+  = RnRecUpdParent+  { rnRecUpdLabels :: NonEmpty FieldGlobalRdrElt+  , rnRecUpdCons   :: UniqSet ConLikeName }+data instance HsRecUpdParent GhcTc+  = TcRecUpdParent+  { tcRecUpdParent :: RecSelParent+  , tcRecUpdLabels :: NonEmpty FieldGlobalRdrElt+  , tcRecUpdCons   :: UniqSet ConLike }++type instance XLHsRecUpdLabels GhcPs = NoExtField+type instance XLHsRecUpdLabels GhcRn = NonEmpty (HsRecUpdParent GhcRn)+                                      -- Possible parents for the record update.+type instance XLHsRecUpdLabels GhcTc = DataConCantHappen++type instance XLHsOLRecUpdLabels p = NoExtField++type instance XGetField     GhcPs = NoExtField+type instance XGetField     GhcRn = NoExtField+type instance XGetField     GhcTc = DataConCantHappen+-- HsGetField is eliminated by the renamer. See [Handling overloaded+-- and rebindable constructs].++type instance XProjection     GhcPs = AnnProjection+type instance XProjection     GhcRn = NoExtField+type instance XProjection     GhcTc = DataConCantHappen+-- HsProjection is eliminated by the renamer. See [Handling overloaded+-- and rebindable constructs].++type instance XExprWithTySig GhcPs = TokDcolon+type instance XExprWithTySig GhcRn = NoExtField+type instance XExprWithTySig GhcTc = NoExtField++type instance XArithSeq      GhcPs = AnnArithSeq+type instance XArithSeq      GhcRn = NoExtField+type instance XArithSeq      GhcTc = PostTcExpr++type instance XProc          (GhcPass _) = (EpToken "proc", TokRarrow)++type instance XStatic        GhcPs = EpToken "static"+type instance XStatic        GhcRn = NameSet+type instance XStatic        GhcTc = (NameSet, Type)+  -- Free variables and type of expression, this is stored for convenience as wiring in+  -- StaticPtr is a bit tricky (see #20150)++type instance XEmbTy         GhcPs = EpToken "type"+type instance XEmbTy         GhcRn = NoExtField+type instance XEmbTy         GhcTc = DataConCantHappen+  -- A free-standing HsEmbTy is an error.+  -- Valid usages are immediately desugared into Type.+++{-+Note [Holes in expressions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+This Note explains how GHC uses the `HsHole` constructor.++`HsHole` is used to represent:++  - anonymous ("_") and named ("_x") holes in expressions,+  - unbound variables,+  - and parse errors.++A `HsHole` can be thought of as any thing which is not necessarily a valid or+fully defined program fragment, but for which a type can be derived.++Note that holes (wildcards) in types, and partial type signatures, are not+handled using the mechanisms described here. Instead, see+Note [The wildcard story for types] for the relevant information.+++* User-facing behavior++  While GHC uses the same internal mechanism to derive the type for any+  `HsHole`, it gives different feedback to the user depending on the type of+  hole. For example, an anonymous hole of the form++    foo x = x && _++  gives the diagnostic++    Foo.hs:5:14: error: [GHC-88464]+      • Found hole: _ :: Bool+      • In the second argument of ‘(&&)’, namely ‘_’+        In the expression: x && _++  while an expression containing an unbound variable++    foo x = x && y++  gives++    Foo.hs:5:14: error: [GHC-88464]+      Variable not in scope: y :: Bool+++* HsHole during parsing, renaming, and type checking++  The usage of `HsHole` during the three phases is listed below.++  - Anynomous holes, i.e. the user wrote "_":++      Parser        HsHole (HoleVar "_")+      Renamer       HsHole (HoleVar "_")+      Typechecker   HsHole (HoleVar "_", ref :: HoleExprRef)++  - Unbound variables and named holes; i.e. the user wrote "x" or "_x", where+    `x` or `_x` is not in scope. A variable with a leading underscore has no+    special meaning to the parser.++      Parser        HsVar "_x"+      Renamer       HsHole (HoleVar "_x")+      Typechecker   HsHole (HoleVar "_x", ref :: HoleExprRef)++  - Parse errors currently do not survive beyond the parser because an error is+    thrown after parsing. However, in the future GHC is intended to be tolerant+    of parse errors until the type checking phase to provide diagnostics similar+    to holes. This current singular case looks like this:++      Parser        HsHole HoleError++  Note that between anonymous holes, named holes, and unbound variables only the+  parsing phase is distinct, while during the renaming and type checking phases+  the cases are handled identically. The distinction that the user can observe+  is only introduced during final error reporting. There the `RdrName` is+  examined to see whether it starts with an underscore or not to determine+  whether the `HsHole` came from a hole or an out of scope variable.+++* Contents of HoleExprRef++  The HoleExprRef type used in the type checking phase is a data structure+  containing:++   - The type of the hole.+   - A ref-cell that is filled in (by the typechecker) with an+     error thunk.   With -fdefer-type errors we use this as the+     value of the hole.+   - A Unique (see Note [Uniques and tags]).++* Typechecking holes++  When the typechecker encounters a `HsHole`, it returns one with the+  HoleExprRef, but also emits a `DelayedError` into the `WantedConstraints`.+  This DelayedError later triggers the error reporting, and the filling-in of+  the error thunk, in GHC.Tc.Errors.++  The user has the option of deferring errors until runtime with+  `-fdefer-type-errors`. In this case, the hole carries evidence in its+  `HoleExprRef`. This evidence is an erroring expression that prints an error+  and crashes at runtime.++* Desugaring holes++  During desugaring, the `(HsHole (HoleVar "x", ref))` is desugared by+  reading the ref-cell to find the error thunk evidence term, put there by the+  constraint solver.++* Wrinkles:++  - Prior to fixing #17812, we used to invent an Id to hold the erroring+    expression, and then bind it during type-checking. But this does not support+    representation-polymorphic out-of-scope identifiers. See+    typecheck/should_compile/T17812. We thus use the mutable-CoreExpr approach+    described above.++  - You might think that the type in the HoleExprRef is the same as the type of+    the hole. However, because the hole type (hole_ty) is rewritten with respect+    to givens, this might not be the case. That is, the hole_ty is always (~) to+    the type of the HoleExprRef, but they might not be `eqType`. We need the+    type of the generated evidence to match what is expected in the context of+    the hole, and so we must store these types separately.++  - We really don't need the whole HoleExprRef; just the IORef EvTerm would be+    enough. But then deriving a Data instance becomes impossible. Much, much+    easier just to define HoleExprRef with a Data instance and store the whole+    structure.+-}+-- | Expression Hole. See Note [Holes in expressions].+type instance XHole GhcPs = HoleKind+type instance XHole GhcRn = HoleKind+type instance XHole GhcTc = (HoleKind, HoleExprRef)++data HoleKind+  = HoleVar (LIdP GhcPs)+  | HoleError+  deriving Data++-- | The RdrName for an unnamed hole ("_").+unnamedHoleRdrName :: RdrName+unnamedHoleRdrName = mkUnqual varName (fsLit "_")+++type instance XForAll        GhcPs = NoExtField+type instance XForAll        GhcRn = NoExtField+type instance XForAll        GhcTc = DataConCantHappen++type instance XQual          GhcPs = NoExtField+type instance XQual          GhcRn = NoExtField+type instance XQual          GhcTc = DataConCantHappen++type instance XFunArr        GhcPs = NoExtField+type instance XFunArr        GhcRn = NoExtField+type instance XFunArr        GhcTc = DataConCantHappen++type instance XPragE         (GhcPass _) = NoExtField++type instance XFunRhs  = AnnFunRhs++type instance Anno [LocatedA ((StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (body (GhcPass pr)))))] = SrcSpanAnnLW+type instance Anno (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))) = SrcSpanAnnA++multAnnToHsExpr :: HsMultAnnOf (LocatedA (HsExpr GhcRn)) GhcRn -> Maybe (LocatedA (HsExpr GhcRn))+multAnnToHsExpr = expandHsMultAnnOf mkHsVar++mkHsVar :: forall p. IsPass p => LIdP (GhcPass p) -> HsExpr (GhcPass p)+mkHsVar n = HsVar noExtField $+  case ghcPass @p of+    GhcPs -> n+    GhcRn -> fmap (WithUserRdr $ nameRdrName $ unLoc n) n+    GhcTc -> n++mkHsVarWithUserRdr :: forall p. IsPass p => RdrName -> LIdP (GhcPass p) -> HsExpr (GhcPass p)+mkHsVarWithUserRdr rdr n = HsVar noExtField $+  case ghcPass @p of+    GhcPs -> n+    GhcRn -> fmap (WithUserRdr rdr) n+    GhcTc -> n++data AnnExplicitSum+  = AnnExplicitSum {+      aesOpen       :: EpaLocation,+      aesBarsBefore :: [EpToken "|"],+      aesBarsAfter  :: [EpToken "|"],+      aesClose      :: EpaLocation+      } deriving Data++instance NoAnn AnnExplicitSum where+  noAnn = AnnExplicitSum noAnn noAnn noAnn noAnn++data AnnFieldLabel+  = AnnFieldLabel {+      afDot :: Maybe (EpToken ".")+      } deriving Data++instance NoAnn AnnFieldLabel where+  noAnn = AnnFieldLabel Nothing++data AnnProjection+  = AnnProjection {+      apOpen  :: EpToken "(",+      apClose :: EpToken ")"+      } deriving Data++instance NoAnn AnnProjection where+  noAnn = AnnProjection noAnn noAnn++data AnnArithSeq+  = AnnArithSeq {+      aas_open   :: EpToken "[",+      aas_comma  :: Maybe (EpToken ","),+      aas_dotdot :: EpToken "..",+      aas_close  :: EpToken "]"+      } deriving Data++instance NoAnn AnnArithSeq where+  noAnn = AnnArithSeq noAnn noAnn noAnn noAnn++data AnnsIf+  = AnnsIf {+      aiIf       :: EpToken "if",+      aiThen     :: EpToken "then",+      aiElse     :: EpToken "else",+      aiThenSemi :: Maybe (EpToken ";"),+      aiElseSemi :: Maybe (EpToken ";")+      } deriving Data++instance NoAnn AnnsIf where+  noAnn = AnnsIf noAnn noAnn noAnn Nothing Nothing++data AnnFunRhs+  = AnnFunRhs {+       afr_strict :: EpToken "!",+       afr_opens  :: [EpToken "("],+       afr_closes :: [EpToken ")"]+  } deriving Data++instance NoAnn AnnFunRhs where+  noAnn = AnnFunRhs noAnn noAnn noAnn++-- ---------------------------------------------------------------------++type instance XSCC           (GhcPass _) = (AnnPragma, SourceText)+type instance XXPragE        (GhcPass _) = DataConCantHappen++type instance XCDotFieldOcc (GhcPass _) = AnnFieldLabel+type instance XXDotFieldOcc (GhcPass _) = DataConCantHappen++type instance XPresent         (GhcPass _) = NoExtField++type instance XMissing         GhcPs = EpAnn Bool -- True for empty last comma+type instance XMissing         GhcRn = NoExtField+type instance XMissing         GhcTc = Scaled Type++type instance XXTupArg         (GhcPass _) = DataConCantHappen++tupArgPresent :: HsTupArg (GhcPass p) -> Bool+tupArgPresent (Present {}) = True+tupArgPresent (Missing {}) = False++tupArgPresent_maybe :: HsTupArg (GhcPass p) -> Maybe (LHsExpr (GhcPass p))+tupArgPresent_maybe (Present _ e) = Just e+tupArgPresent_maybe (Missing {})  = Nothing++tupArgsPresent_maybe :: [HsTupArg (GhcPass p)] -> Maybe [LHsExpr (GhcPass p)]+tupArgsPresent_maybe = traverse tupArgPresent_maybe+++{- *********************************************************************+*                                                                      *+            XXExpr: the extension constructor of HsExpr+*                                                                      *+********************************************************************* -}++type instance XXExpr GhcPs = DataConCantHappen+type instance XXExpr GhcRn = XXExprGhcRn+type instance XXExpr GhcTc = XXExprGhcTc+-- XXExprGhcRn: see Note [Rebindable syntax and XXExprGhcRn] below+++{- *********************************************************************+*                                                                      *+              Generating code for ExpandedThingRn+      See Note [Handling overloaded and rebindable constructs]+*                                                                      *+********************************************************************* -}++-- | The different source constructs that we use to instantiate the "original" field+--   in an `XXExprGhcRn original expansion`+data HsThingRn = OrigExpr (HsExpr GhcRn)+               | OrigStmt (ExprLStmt GhcRn)+               | OrigPat  (LPat GhcRn)++isHsThingRnExpr, isHsThingRnStmt, isHsThingRnPat :: HsThingRn -> Bool+isHsThingRnExpr (OrigExpr{}) = True+isHsThingRnExpr _ = False++isHsThingRnStmt (OrigStmt{}) = True+isHsThingRnStmt _ = False++isHsThingRnPat (OrigPat{}) = True+isHsThingRnPat _ = False++data XXExprGhcRn+  = ExpandedThingRn { xrn_orig     :: HsThingRn       -- The original source thing+                    , xrn_expanded :: HsExpr GhcRn }  -- The compiler generated expanded thing++  | PopErrCtxt                                     -- A hint for typechecker to pop+    {-# UNPACK #-} !(LHsExpr GhcRn)                -- the top of the error context stack+                                                   -- Does not presist post renaming phase+                                                   -- See Part 3. of Note [Expanding HsDo with XXExprGhcRn]+                                                   -- in `GHC.Tc.Gen.Do`+  | HsRecSelRn  (FieldOcc GhcRn)   -- ^ Variable pointing to record selector+                           -- See Note [Non-overloaded record field selectors] and+                           -- Note [Record selectors in the AST]++++-- | Wrap a located expression with a `PopErrCtxt`+mkPopErrCtxtExpr :: LHsExpr GhcRn -> HsExpr GhcRn+mkPopErrCtxtExpr a = XExpr (PopErrCtxt a)++-- | Wrap a located expression with a PopSrcExpr with an appropriate location+mkPopErrCtxtExprAt :: SrcSpanAnnA ->  LHsExpr GhcRn -> LHsExpr GhcRn+mkPopErrCtxtExprAt loc a = L loc $ mkPopErrCtxtExpr a++-- | Build an expression using the extension constructor `XExpr`,+--   and the two components of the expansion: original expression and+--   expanded expressions.+mkExpandedExpr+  :: HsExpr GhcRn         -- ^ source expression+  -> HsExpr GhcRn         -- ^ expanded expression+  -> HsExpr GhcRn         -- ^ suitably wrapped 'XXExprGhcRn'+mkExpandedExpr oExpr eExpr = XExpr (ExpandedThingRn (OrigExpr oExpr) eExpr)++-- | Build an expression using the extension constructor `XExpr`,+--   and the two components of the expansion: original do stmt and+--   expanded expression+mkExpandedStmt+  :: ExprLStmt GhcRn      -- ^ source statement+  -> HsExpr GhcRn         -- ^ expanded expression+  -> HsExpr GhcRn         -- ^ suitably wrapped 'XXExprGhcRn'+mkExpandedStmt oStmt eExpr = XExpr (ExpandedThingRn (OrigStmt oStmt) eExpr)++mkExpandedPatRn+  :: LPat   GhcRn      -- ^ source pattern+  -> HsExpr GhcRn      -- ^ expanded expression+  -> HsExpr GhcRn      -- ^ suitably wrapped 'XXExprGhcRn'+mkExpandedPatRn oPat eExpr = XExpr (ExpandedThingRn (OrigPat oPat) eExpr)++-- | Build an expression using the extension constructor `XExpr`,+--   and the two components of the expansion: original do stmt and+--   expanded expression an associate with a provided location+mkExpandedStmtAt+  :: SrcSpanAnnA          -- ^ Location for the expansion expression+  -> ExprLStmt GhcRn      -- ^ source statement+  -> HsExpr GhcRn         -- ^ expanded expression+  -> LHsExpr GhcRn        -- ^ suitably wrapped located 'XXExprGhcRn'+mkExpandedStmtAt loc oStmt eExpr = L loc $ mkExpandedStmt oStmt eExpr++-- | Wrap the expanded version of the expression with a pop.+mkExpandedStmtPopAt+  :: SrcSpanAnnA          -- ^ Location for the expansion statement+  -> ExprLStmt GhcRn      -- ^ source statement+  -> HsExpr GhcRn         -- ^ expanded expression+  -> LHsExpr GhcRn        -- ^ suitably wrapped 'XXExprGhcRn'+mkExpandedStmtPopAt loc oStmt eExpr = mkPopErrCtxtExprAt loc $ mkExpandedStmtAt loc oStmt eExpr+++data XXExprGhcTc+  = WrapExpr        -- Type and evidence application and abstractions+      HsWrapper (HsExpr GhcTc)++  | ExpandedThingTc                         -- See Note [Rebindable syntax and XXExprGhcRn]+                                            -- See Note [Expanding HsDo with XXExprGhcRn] in `GHC.Tc.Gen.Do`+         { xtc_orig     :: HsThingRn        -- The original user written thing+         , xtc_expanded :: HsExpr GhcTc }   -- The expanded typechecked expression++  | ConLikeTc      -- Result of typechecking a data-con+                   -- See Note [Typechecking data constructors] in+                   --     GHC.Tc.Gen.Head+                   -- The two arguments describe how to eta-expand+                   -- the data constructor when desugaring+        ConLike [TcTyVar] [Scaled TcType]++  ---------------------------------------+  -- Haskell program coverage (Hpc) Support++  | HsTick+     CoreTickish+     (LHsExpr GhcTc)                    -- sub-expression++  | HsBinTick+     Int                                -- module-local tick number for True+     Int                                -- module-local tick number for False+     (LHsExpr GhcTc)                    -- sub-expression++  | HsRecSelTc  (FieldOcc GhcTc) -- ^ Variable pointing to record selector+                             -- See Note [Non-overloaded record field selectors] and+                             -- Note [Record selectors in the AST]+++-- | Build a 'XXExprGhcRn' out of an extension constructor,+--   and the two components of the expansion: original and+--   expanded typechecked expressions.+mkExpandedExprTc+  :: HsExpr GhcRn           -- ^ source expression+  -> HsExpr GhcTc           -- ^ expanded typechecked expression+  -> HsExpr GhcTc           -- ^ suitably wrapped 'XXExprGhcRn'+mkExpandedExprTc oExpr eExpr = XExpr (ExpandedThingTc (OrigExpr oExpr) eExpr)++-- | Build a 'XXExprGhcRn' out of an extension constructor.+--   The two components of the expansion are: original statement and+--   expanded typechecked expression.+mkExpandedStmtTc+  :: ExprLStmt GhcRn        -- ^ source do statement+  -> HsExpr GhcTc           -- ^ expanded typechecked expression+  -> HsExpr GhcTc           -- ^ suitably wrapped 'XXExprGhcRn'+mkExpandedStmtTc oStmt eExpr = XExpr (ExpandedThingTc (OrigStmt oStmt) eExpr)++{- *********************************************************************+*                                                                      *+            Pretty-printing expressions+*                                                                      *+********************************************************************* -}++instance (OutputableBndrId p) => Outputable (HsExpr (GhcPass p)) where+    ppr expr = pprExpr expr++-----------------------+-- pprExpr, pprLExpr, pprBinds call pprDeeper;+-- the underscore versions do not+pprLExpr :: (OutputableBndrId p) => LHsExpr (GhcPass p) -> SDoc+pprLExpr (L _ e) = pprExpr e++pprExpr :: (OutputableBndrId p) => HsExpr (GhcPass p) -> SDoc+pprExpr e | isAtomicHsExpr e || isQuietHsExpr e =            ppr_expr e+          | otherwise                           = pprDeeper (ppr_expr e)++isQuietHsExpr :: HsExpr id -> Bool+-- Parentheses do display something, but it gives little info and+-- if we go deeper when we go inside them then we get ugly things+-- like (...)+isQuietHsExpr (HsPar {})        = True+-- applications don't display anything themselves+isQuietHsExpr (HsApp {})        = True+isQuietHsExpr (HsAppType {})    = True+isQuietHsExpr (OpApp {})        = True+isQuietHsExpr _ = False++pprBinds :: (OutputableBndrId idL, OutputableBndrId idR)+         => HsLocalBindsLR (GhcPass idL) (GhcPass idR) -> SDoc+pprBinds b = pprDeeper (ppr b)++-----------------------+ppr_lexpr :: (OutputableBndrId p) => LHsExpr (GhcPass p) -> SDoc+ppr_lexpr e = ppr_expr (unLoc e)++ppr_expr :: forall p. (OutputableBndrId p)+         => HsExpr (GhcPass p) -> SDoc+ppr_expr (HsVar _ (L _ v))   = pprPrefixOcc v+ppr_expr (HsHole x) = case (ghcPass @p, x) of+  (GhcPs, HoleVar (L _ v)) -> pprPrefixOcc v+  (GhcRn, HoleVar (L _ v)) -> pprPrefixOcc v+  (GhcTc, (HoleVar (L _ v), _)) -> pprPrefixOcc v+  (GhcPs, HoleError) -> pprPrefixOcc unnamedHoleRdrName+  (GhcRn, HoleError) -> pprPrefixOcc unnamedHoleRdrName+  (GhcTc, (HoleError, _)) -> pprPrefixOcc unnamedHoleRdrName+ppr_expr (HsIPVar _ v)       = ppr v+ppr_expr (HsOverLabel s l) = case ghcPass @p of+               GhcPs -> helper s+               GhcRn -> helper s+               GhcTc -> dataConCantHappen s+    where helper s =+            char '#' <> case s of+                          NoSourceText -> ppr l+                          SourceText src -> ftext src+ppr_expr (HsLit _ lit)       = ppr lit+ppr_expr (HsOverLit _ lit)   = ppr lit+ppr_expr (HsPar _ e)         = parens (ppr_lexpr e)++ppr_expr (HsPragE _ prag e) = sep [ppr prag, ppr_lexpr e]++ppr_expr e@(HsApp {})        = ppr_apps e []+ppr_expr e@(HsAppType {})    = ppr_apps e []++ppr_expr (OpApp _ e1 op e2)+  | Just pp_op <- ppr_infix_expr (unLoc op)+  = pp_infixly pp_op+  | otherwise+  = pp_prefixly++  where+    pp_e1 = pprDebugParendExpr opPrec e1   -- In debug mode, add parens+    pp_e2 = pprDebugParendExpr opPrec e2   -- to make precedence clear++    pp_prefixly+      = hang (ppr op) 2 (sep [pp_e1, pp_e2])++    pp_infixly pp_op+      = hang pp_e1 2 (sep [pp_op, nest 2 pp_e2])++ppr_expr (NegApp _ e _) = char '-' <+> pprDebugParendExpr appPrec e++ppr_expr (SectionL _ expr op)+  | Just pp_op <- ppr_infix_expr (unLoc op)+  = pp_infixly pp_op+  | otherwise+  = pp_prefixly+  where+    pp_expr = pprDebugParendExpr opPrec expr++    pp_prefixly = hang (hsep [text " \\ x_ ->", ppr op])+                       4 (hsep [pp_expr, text "x_ )"])++    pp_infixly v = (sep [pp_expr, v])++ppr_expr (SectionR _ op expr)+  | Just pp_op <- ppr_infix_expr (unLoc op)+  = pp_infixly pp_op+  | otherwise+  = pp_prefixly+  where+    pp_expr = pprDebugParendExpr opPrec expr++    pp_prefixly = hang (hsep [text "( \\ x_ ->", ppr op, text "x_"])+                       4 (pp_expr <> rparen)++    pp_infixly v = sep [v, pp_expr]++ppr_expr (ExplicitTuple _ exprs boxity)+    -- Special-case unary boxed tuples so that they are pretty-printed as+    -- `MkSolo x`, not `(x)`+  | [Present _ expr] <- exprs+  , Boxed <- boxity+  = hsep [text (mkTupleStr Boxed dataName 1), ppr expr]+  | otherwise+  = tupleParens (boxityTupleSort boxity) (fcat (ppr_tup_args exprs))+  where+    ppr_tup_args []               = []+    ppr_tup_args (Present _ e : es) = (ppr_lexpr e <> punc es) : ppr_tup_args es+    ppr_tup_args (Missing _   : es) = punc es : ppr_tup_args es++    punc (Present {} : _) = comma <> space+    punc (Missing {} : _) = comma+    punc (XTupArg {} : _) = comma <> space+    punc []               = empty++ppr_expr (ExplicitSum _ alt arity expr)+  = text "(#" <+> ppr_bars (alt - 1) <+> ppr expr <+> ppr_bars (arity - alt) <+> text "#)"+  where+    ppr_bars n = hsep (replicate n (char '|'))++ppr_expr (HsLam _ lam_variant matches)+  = case lam_variant of+       LamSingle -> pprMatches matches+       _         -> sep [ sep [lamCaseKeyword lam_variant]+                        , nest 2 (pprMatches matches) ]++ppr_expr (HsCase _ expr matches@(MG { mg_alts = L _ alts }))+  = sep [ sep [text "case", nest 4 (ppr expr), text "of"],+          pp_alts ]+  where+    pp_alts | null alts = text "{}"+            | otherwise = nest 2 (pprMatches matches)++ppr_expr (HsIf _ e1 e2 e3)+  = sep [hsep [text "if", nest 2 (ppr e1), text "then"],+         nest 4 (ppr e2),+         text "else",+         nest 4 (ppr e3)]++ppr_expr (HsMultiIf _ alts)+  = hang (text "if") 3  (vcat $ toList $ NE.map ppr_alt alts)+  where ppr_alt (L _ (GRHS _ guards expr)) =+          hang vbar 2 (hang (interpp'SP guards) 2 (arrow <+> pprDeeper (ppr expr)))+        ppr_alt (L _ (XGRHS x)) = ppr x++-- special case: let ... in let ...+ppr_expr (HsLet _ binds expr@(L _ (HsLet _ _ _)))+  = sep [hang (text "let") 2 (hsep [pprBinds binds, text "in"]),+         ppr_lexpr expr]++ppr_expr (HsLet _ binds expr)+  = sep [hang (text "let") 2 (pprBinds binds),+         hang (text "in")  2 (ppr expr)]++ppr_expr (HsDo _ do_or_list_comp (L _ stmts)) = pprDo do_or_list_comp stmts++ppr_expr (ExplicitList _ exprs)+  = brackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs)))++ppr_expr (RecordCon { rcon_con = con, rcon_flds = rbinds })+  = hang pp_con 2 (ppr rbinds)+  where+    -- con :: ConLikeP (GhcPass p)+    -- so we need case analysis to know to print it+    pp_con = case ghcPass @p of+               GhcPs -> ppr con+               GhcRn -> ppr con+               GhcTc -> ppr con++ppr_expr (RecordUpd { rupd_expr = L _ aexp, rupd_flds = flds })+  = case flds of+      RegularRecUpdFields { recUpdFields= rbinds } ->+        hang (ppr aexp) 2 (braces (fsep (punctuate comma (map ppr rbinds))))+      OverloadedRecUpdFields { olRecUpdFields = pbinds } ->+        hang (ppr aexp) 2 (braces (fsep (punctuate comma (map ppr pbinds))))++ppr_expr (HsGetField { gf_expr = L _ fexp, gf_field = field })+  = ppr fexp <> dot <> ppr field++ppr_expr (HsProjection { proj_flds = flds }) = parens (hcat (dot : (punctuate dot (map ppr $ toList flds))))++ppr_expr (ExprWithTySig _ expr sig)+  = hang (nest 2 (ppr_lexpr expr) <+> dcolon)+         4 (ppr sig)++ppr_expr (ArithSeq _ _ info) = brackets (ppr info)++ppr_expr (HsTypedSplice ext e)   =+    case ghcPass @p of+      GhcPs -> pprTypedSplice Nothing e+      GhcRn ->+        case ext of+          HsTypedSpliceNested n -> pprTypedSplice (Just n) e+          HsTypedSpliceTop {}   -> pprTypedSplice Nothing e+      GhcTc -> pprTypedSplice Nothing e+ppr_expr (HsUntypedSplice ext s) =+    case ghcPass @p of+      GhcPs -> pprUntypedSplice True Nothing s+      GhcRn | HsUntypedSpliceNested n <- ext -> pprUntypedSplice True (Just n) s+      GhcRn | HsUntypedSpliceTop _ e  <- ext -> ppr e+      GhcTc -> dataConCantHappen ext++ppr_expr (HsTypedBracket b e)+  = case ghcPass @p of+    GhcPs -> thTyBrackets (ppr e)+    GhcRn -> thTyBrackets (ppr e)+    GhcTc | HsBracketTc _  _ty _wrap ps <- b ->+      thTyBrackets (ppr e) `ppr_with_pending_tc_splices` ps+ppr_expr (HsUntypedBracket b q)+  = case ghcPass @p of+    GhcPs -> ppr q+    GhcRn -> case b of+      [] -> ppr q+      ps -> ppr q $$ whenPprDebug (text "pending(rn)" <+> ppr (map ppr_nested_splice ps))+    GhcTc | HsBracketTc rnq  _ty _wrap ps <- b ->+      ppr rnq `ppr_with_pending_tc_splices` ps+  where+    ppr_nested_splice (PendingRnSplice splice_name expr) = pprUntypedSplice False (Just splice_name) expr++ppr_expr (HsProc _ pat (L _ (HsCmdTop _ cmd)))+  = hsep [text "proc", ppr pat, arrow, ppr cmd]++ppr_expr (HsStatic _ e)+  = hsep [text "static", ppr e]++ppr_expr (HsEmbTy _ ty)+  = hsep [text "type", ppr ty]++ppr_expr (HsQual _ ctxt ty)+  = sep [ppr_context ctxt, ppr_lexpr ty]+  where+    ppr_context (L _ ctxt) =+      case ctxt of+        []       -> parens empty             <+> darrow+        [L _ ty] -> ppr_expr ty              <+> darrow+        _        -> parens (interpp'SP ctxt) <+> darrow++ppr_expr (HsForAll _ tele ty)+  = sep [pprHsForAll tele Nothing, ppr_lexpr ty]++ppr_expr (HsFunArr _ arr arg res)+  = sep [ppr_lexpr arg, pprHsArrow arr <+> ppr_lexpr res]++ppr_expr (XExpr x) = case ghcPass @p of+  GhcRn -> ppr x+  GhcTc -> ppr x++instance Outputable HsThingRn where+  ppr thing+    = case thing of+        OrigExpr x -> ppr_builder "<OrigExpr>:" x+        OrigStmt x -> ppr_builder "<OrigStmt>:" x+        OrigPat x  -> ppr_builder "<OrigPat>:" x++    where ppr_builder prefix x = ifPprDebug (braces (text prefix <+> parens (ppr x))) (ppr x)++instance Outputable XXExprGhcRn where+  ppr (ExpandedThingRn o e) = ifPprDebug (braces $ vcat [ppr o, ppr e]) (ppr o)+  ppr (PopErrCtxt e)        = ifPprDebug (braces (text "<PopErrCtxt>" <+> ppr e)) (ppr e)+  ppr (HsRecSelRn f)        = pprPrefixOcc f++instance Outputable XXExprGhcTc where+  ppr (WrapExpr co_fn e)+    = pprHsWrapper co_fn (\_parens -> pprExpr e)++  ppr (ExpandedThingTc o e)+    = ifPprDebug (braces $ vcat [ppr o, ppr e]) (ppr o)+            -- e is the expanded expression, we print the original+            -- expression (HsExpr GhcRn), not the+            -- expanded typechecked one (HsExpr GhcTc),+            -- unless we are in ppr's debug mode printed both++  ppr (ConLikeTc con _ _) = pprPrefixOcc con+   -- Used in error messages generated by+   -- the pattern match overlap checker++  ppr (HsTick tickish exp) =+    pprTicks (ppr exp) $+      ppr tickish <+> ppr_lexpr exp++  ppr (HsBinTick tickIdTrue tickIdFalse exp) =+    pprTicks (ppr exp) $+      hcat [text "bintick<",+            ppr tickIdTrue,+            text ",",+            ppr tickIdFalse,+            text ">(",+            ppr exp, text ")"]+  ppr (HsRecSelTc f)      = pprPrefixOcc f++ppr_infix_expr :: forall p. (OutputableBndrId p) => HsExpr (GhcPass p) -> Maybe SDoc+ppr_infix_expr (HsVar _ (L _ v))    = Just (pprInfixOcc v)+ppr_infix_expr (HsHole x) = Just $ pprInfixOcc $ case (ghcPass @p, x) of+  (GhcPs, HoleVar (L _ v)) -> v+  (GhcRn, HoleVar (L _ v)) -> v+  (GhcTc, (HoleVar (L _ v), _)) -> v+  _ -> unnamedHoleRdrName -- TODO: this is the HoleError case; this should print the source text instead of "_".+ppr_infix_expr (XExpr x)            = case ghcPass @p of+                                        GhcRn -> ppr_infix_expr_rn x+                                        GhcTc -> ppr_infix_expr_tc x+ppr_infix_expr _ = Nothing++ppr_infix_expr_rn :: XXExprGhcRn -> Maybe SDoc+ppr_infix_expr_rn (ExpandedThingRn thing _) = ppr_infix_hs_expansion thing+ppr_infix_expr_rn (PopErrCtxt (L _ a))      = ppr_infix_expr a+ppr_infix_expr_rn (HsRecSelRn f)            = Just (pprInfixOcc f)++ppr_infix_expr_tc :: XXExprGhcTc -> Maybe SDoc+ppr_infix_expr_tc (WrapExpr _ e)    = ppr_infix_expr e+ppr_infix_expr_tc (ExpandedThingTc thing _)  = ppr_infix_hs_expansion thing+ppr_infix_expr_tc (ConLikeTc {})             = Nothing+ppr_infix_expr_tc (HsTick {})                = Nothing+ppr_infix_expr_tc (HsBinTick {})             = Nothing+ppr_infix_expr_tc (HsRecSelTc f)            = Just (pprInfixOcc f)++ppr_infix_hs_expansion :: HsThingRn -> Maybe SDoc+ppr_infix_hs_expansion (OrigExpr e) = ppr_infix_expr e+ppr_infix_hs_expansion _            = Nothing++ppr_apps :: (OutputableBndrId p)+         => HsExpr (GhcPass p)+         -> [Either (LHsExpr (GhcPass p)) (LHsWcType (NoGhcTc (GhcPass p)))]+         -> SDoc+ppr_apps (HsApp _ (L _ fun) arg)        args+  = ppr_apps fun (Left arg : args)+ppr_apps (HsAppType _ (L _ fun) arg)    args+  = ppr_apps fun (Right arg : args)+ppr_apps fun args = hang (ppr_expr fun) 2 (fsep (map pp args))+  where+    pp (Left arg)                             = ppr arg+    -- pp (Right (LHsWcTypeX (HsWC { hswc_body = L _ arg })))+    --   = char '@' <> pprHsType arg+    pp (Right arg)+      = text "@" <> ppr arg++pprDebugParendExpr :: (OutputableBndrId p)+                   => PprPrec -> LHsExpr (GhcPass p) -> SDoc+pprDebugParendExpr p expr+  = getPprDebug $ \case+      True  -> pprParendLExpr p expr+      False -> pprLExpr         expr++pprParendLExpr :: (OutputableBndrId p)+               => PprPrec -> LHsExpr (GhcPass p) -> SDoc+pprParendLExpr p (L _ e) = pprParendExpr p e++pprParendExpr :: (OutputableBndrId p)+              => PprPrec -> HsExpr (GhcPass p) -> SDoc+pprParendExpr p expr+  | hsExprNeedsParens p expr = parens (pprExpr expr)+  | otherwise                = pprExpr expr+        -- Using pprLExpr makes sure that we go 'deeper'+        -- I think that is usually (always?) right++-- | @'hsExprNeedsParens' p e@ returns 'True' if the expression @e@ needs+-- parentheses under precedence @p@.+hsExprNeedsParens :: forall p. IsPass p => PprPrec -> HsExpr (GhcPass p) -> Bool+hsExprNeedsParens prec = go+  where+    go :: HsExpr (GhcPass p) -> Bool+    go (HsVar{})                      = False+    go (HsIPVar{})                    = False+    go (HsOverLabel{})                = False+    go (HsLit _ l)                    = hsLitNeedsParens prec l+    go (HsOverLit _ ol)               = hsOverLitNeedsParens prec ol+    go (HsPar{})                      = False+    go (HsApp{})                      = prec >= appPrec+    go (HsAppType {})                 = prec >= appPrec+    go (OpApp{})                      = prec >= opPrec+    go (NegApp{})                     = prec > topPrec+    go (SectionL{})                   = True+    go (SectionR{})                   = True+    -- Special-case unary boxed tuple applications so that they are+    -- parenthesized as `Identity (Solo x)`, not `Identity Solo x` (#18612)+    -- See Note [One-tuples] in GHC.Builtin.Types+    go (ExplicitTuple _ [Present{}] Boxed)+                                      = prec >= appPrec+    go (ExplicitTuple{})              = False+    go (ExplicitSum{})                = False+    go (HsLam{})                      = prec > topPrec+    go (HsCase{})                     = prec > topPrec+    go (HsIf{})                       = prec > topPrec+    go (HsMultiIf{})                  = prec > topPrec+    go (HsLet{})                      = prec > topPrec+    go (HsDo _ sc _)+      | isDoComprehensionContext sc   = False+      | otherwise                     = prec > topPrec+    go (ExplicitList{})               = False+    go (RecordUpd{})                  = False+    go (ExprWithTySig{})              = prec >= sigPrec+    go (ArithSeq{})                   = False+    go (HsPragE{})                    = prec >= appPrec+    go (HsTypedSplice{})              = False+    go (HsUntypedSplice{})            = False+    go (HsTypedBracket{})             = False+    go (HsUntypedBracket{})           = False+    go (HsProc{})                     = prec > topPrec+    go (HsStatic{})                   = prec >= appPrec+    go (RecordCon{})                  = False+    go (HsProjection{})               = True+    go (HsGetField{})                 = False+    go (HsEmbTy{})                    = prec > topPrec+    go (HsHole{})                     = False+    go (HsForAll{})                   = prec >= funPrec+    go (HsQual{})                     = prec >= funPrec+    go (HsFunArr{})                   = prec >= funPrec+    go (XExpr x) = case ghcPass @p of+                     GhcTc -> go_x_tc x+                     GhcRn -> go_x_rn x++    go_x_tc :: XXExprGhcTc -> Bool+    go_x_tc (WrapExpr _ e)                   = hsExprNeedsParens prec e+    go_x_tc (ExpandedThingTc thing _)        = hsExpandedNeedsParens thing+    go_x_tc (ConLikeTc {})                   = False+    go_x_tc (HsTick _ (L _ e))               = hsExprNeedsParens prec e+    go_x_tc (HsBinTick _ _ (L _ e))          = hsExprNeedsParens prec e+    go_x_tc (HsRecSelTc{})                   = False++    go_x_rn :: XXExprGhcRn -> Bool+    go_x_rn (ExpandedThingRn thing _)    = hsExpandedNeedsParens thing+    go_x_rn (PopErrCtxt (L _ a))         = hsExprNeedsParens prec a+    go_x_rn (HsRecSelRn{})               = False++    hsExpandedNeedsParens :: HsThingRn -> Bool+    hsExpandedNeedsParens (OrigExpr e) = hsExprNeedsParens prec e+    hsExpandedNeedsParens _            = False++-- | Parenthesize an expression without token information+gHsPar :: forall p. IsPass p => LHsExpr (GhcPass p) -> HsExpr (GhcPass p)+gHsPar e = HsPar x e+  where+    x = case ghcPass @p of+      GhcPs -> noAnn+      GhcRn -> noExtField+      GhcTc -> noExtField++-- | @'parenthesizeHsExpr' p e@ checks if @'hsExprNeedsParens' p e@ is true,+-- and if so, surrounds @e@ with an 'HsPar'. Otherwise, it simply returns @e@.+parenthesizeHsExpr :: IsPass p => PprPrec -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)+parenthesizeHsExpr p le@(L loc e)+  | hsExprNeedsParens p e = L loc (gHsPar le)+  | otherwise             = le++stripParensLHsExpr :: LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)+stripParensLHsExpr (L _ (HsPar _ e)) = stripParensLHsExpr e+stripParensLHsExpr e = e++stripParensHsExpr :: HsExpr (GhcPass p) -> HsExpr (GhcPass p)+stripParensHsExpr (HsPar _ (L _ e)) = stripParensHsExpr e+stripParensHsExpr e = e++isAtomicHsExpr :: forall p. IsPass p => HsExpr (GhcPass p) -> Bool+-- True of a single token+isAtomicHsExpr (HsVar {})        = True+isAtomicHsExpr (HsLit {})        = True+isAtomicHsExpr (HsOverLit {})    = True+isAtomicHsExpr (HsIPVar {})      = True+isAtomicHsExpr (HsOverLabel {})  = True+isAtomicHsExpr (HsHole{})        = True+isAtomicHsExpr (XExpr x)+  | GhcTc <- ghcPass @p          = go_x_tc x+  | GhcRn <- ghcPass @p          = go_x_rn x+  where+    go_x_tc :: XXExprGhcTc -> Bool+    go_x_tc (WrapExpr _ e)            = isAtomicHsExpr e+    go_x_tc (ExpandedThingTc thing _) = isAtomicExpandedThingRn thing+    go_x_tc (ConLikeTc {})            = True+    go_x_tc (HsTick {})               = False+    go_x_tc (HsBinTick {})            = False+    go_x_tc (HsRecSelTc{})            = True++    go_x_rn :: XXExprGhcRn -> Bool+    go_x_rn (ExpandedThingRn thing _) = isAtomicExpandedThingRn thing+    go_x_rn (PopErrCtxt (L _ a))      = isAtomicHsExpr a+    go_x_rn (HsRecSelRn{})            = True++    isAtomicExpandedThingRn :: HsThingRn -> Bool+    isAtomicExpandedThingRn (OrigExpr e) = isAtomicHsExpr e+    isAtomicExpandedThingRn _            = False++isAtomicHsExpr _ = False++instance Outputable (HsPragE (GhcPass p)) where+  ppr (HsPragSCC (_, st) (StringLiteral stl lbl _)) =+    pprWithSourceText st (text "{-# SCC")+     -- no doublequotes if stl empty, for the case where the SCC was written+     -- without quotes.+    <+> pprWithSourceText stl (ftext lbl) <+> text "#-}"+++{- *********************************************************************+*                                                                      *+             XXExprGhcRn and rebindable syntax+*                                                                      *+********************************************************************* -}++{- Note [Rebindable syntax and XXExprGhcRn]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We implement rebindable syntax (RS) support by performing a desugaring+in the renamer. We transform GhcPs expressions and patterns affected by+RS into the appropriate desugared form, but **annotated with the original+expression/pattern**.++Let us consider a piece of code like:++    {-# LANGUAGE RebindableSyntax #-}+    ifThenElse :: Char -> () -> () -> ()+    ifThenElse _ _ _ = ()+    x = if 'a' then () else True++The parsed AST for the RHS of x would look something like (slightly simplified):++    L locif (HsIf (L loca 'a') (L loctrue ()) (L locfalse True))++Upon seeing such an AST with RS on, we could transform it into a+mere function call, as per the RS rules, equivalent to the+following function application:++    ifThenElse 'a' () True++which doesn't typecheck. But GHC would report an error about+not being able to match the third argument's type (Bool) with the+expected type: (), in the expression _as desugared_, i.e in+the aforementioned function application. But the user never+wrote a function application! This would be pretty bad.++To remedy this, instead of transforming the original HsIf+node into mere applications of 'ifThenElse', we keep the+original 'if' expression around too, using the TTG+XExpr extension point to allow GHC to construct an+'XXExprGhcRn' value that will keep track of the original+expression in its first field, and the desugared one in the+second field. The resulting renamed AST would look like:++    L locif (XExpr+      (ExpandedThingRn+        (HsIf (L loca 'a')+              (L loctrue ())+              (L locfalse True)+        )+        (App (L generatedSrcSpan+                (App (L generatedSrcSpan+                        (App (L generatedSrcSpan (Var ifThenElse))+                             (L loca 'a')+                        )+                     )+                     (L loctrue ())+                )+             )+             (L locfalse True)+        )+      )+    )++When comes the time to typecheck the program, we end up calling+tcMonoExpr on the AST above. If this expression gives rise to+a type error, then it will appear in a context line and GHC+will pretty-print it using the 'Outputable (XXExprGhcRn a b)'+instance defined below, which *only prints the original+expression*. This is the gist of the idea, but is not quite+enough to recover the error messages that we had with the+SyntaxExpr-based, typechecking/desugaring-to-core time+implementation of rebindable syntax. The key idea is to decorate+some elements of the desugared expression so as to be able to+give them a special treatment when typechecking the desugared+expression, to print a different context line or skip one+altogether.++Whenever we 'setSrcSpan' a 'generatedSrcSpan', we update a field in+TcLclEnv called 'tcl_in_gen_code', setting it to True, which indicates that we+entered generated code, i.e code fabricated by the compiler when rebinding some+syntax. If someone tries to push some error context line while that field is set+to True, the pushing won't actually happen and the context line is just dropped.+Once we 'setSrcSpan' a real span (for an expression that was in the original+source code), we set 'tcl_in_gen_code' back to False, indicating that we+"emerged from the generated code tunnel", and that the expressions we will be+processing are relevant to report in context lines again.++You might wonder why TcLclEnv has both+   tcl_loc         :: RealSrcSpan+   tcl_in_gen_code :: Bool+Could we not store a Maybe RealSrcSpan? The problem is that we still+generate constraints when processing generated code, and a CtLoc must+contain a RealSrcSpan -- otherwise, error messages might appear+without source locations. So tcl_loc keeps the RealSrcSpan of the last+location spotted that wasn't generated; it's as good as we're going to+get in generated code. Once we get to sub-trees that are not+generated, then we update the RealSrcSpan appropriately, and set the+tcl_in_gen_code Bool to False.++---++An overview of the constructs that are desugared in this way is laid out in+Note [Handling overloaded and rebindable constructs] in GHC.Rename.Expr.++A general recipe to follow this approach for new constructs could go as follows:++- Remove any GhcRn-time SyntaxExpr extensions to the relevant constructor for your+  construct, in HsExpr or related syntax data types.+- At renaming-time:+    - take your original node of interest (HsIf above)+    - rename its subexpressions/subpatterns (condition and true/false+      branches above)+    - construct the suitable "rebound"-and-renamed result (ifThenElse call+      above), where the 'SrcSpan' attached to any _fabricated node_ (the+      HsVar/HsApp nodes, above) is set to 'generatedSrcSpan'+    - take both the original node and that rebound-and-renamed result and wrap+      them into an expansion construct:+        for expressions, XExpr (ExpandedThingRn <original node> <desugared>)+        for patterns, XPat (HsPatExpanded <original node> <desugared>)+ - At typechecking-time:+    - remove any logic that was previously dealing with your rebindable+      construct, typically involving [tc]SyntaxOp, SyntaxExpr and friends.+    - the XExpr (ExpandedThingRn ... ...) case in tcExpr already makes sure that we+      typecheck the desugared expression while reporting the original one in+      errors+-}++{- Note [Overview of record dot syntax]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+This is the note that explains all the moving parts for record dot+syntax.++The language extensions @OverloadedRecordDot@ and+@OverloadedRecordUpdate@ (providing "record dot syntax") are+implemented using the techniques of Note [Rebindable syntax and+XXExprGhcRn].++When OverloadedRecordDot is enabled:+- Field selection expressions+  - e.g. foo.bar.baz+  - Have abstract syntax HsGetField+  - After renaming are XExpr (ExpandedThingRn (HsGetField ...) (getField @"..."...)) expressions+- Field selector expressions e.g. (.x.y)+  - Have abstract syntax HsProjection+  - After renaming are XExpr (ExpandedThingRn (HsProjection ...) ((getField @"...") . (getField @"...") . ...) expressions++When OverloadedRecordUpdate is enabled:+- Record update expressions+  - e.g. a{foo.bar=1, quux="corge", baz}+  - Have abstract syntax RecordUpd+    - With rupd_flds containting a Right+    - See Note [RecordDotSyntax field updates] (in Language.Haskell.Syntax.Expr)+  - After renaming are XExpr (ExpandedThingRn (RecordUpd ...) (setField@"..." ...) expressions+    - Note that this is true for all record updates even for those that do not involve '.'++When OverloadedRecordDot is enabled and RebindableSyntax is not+enabled the name 'getField' is resolved to GHC.Records.getField. When+OverloadedRecordDot is enabled and RebindableSyntax is enabled the+name 'getField' is whatever in-scope name that is.++When OverloadedRecordUpd is enabled and RebindableSyntax is not+enabled it is an error for now (temporary while we wait on native+setField support; see+https://gitlab.haskell.org/ghc/ghc/-/issues/16232). When+OverloadedRecordUpd is enabled and RebindableSyntax is enabled the+names 'getField' and 'setField' are whatever in-scope names they are.+-}+++{-+************************************************************************+*                                                                      *+\subsection{Commands (in arrow abstractions)}+*                                                                      *+************************************************************************+-}++type instance XCmdArrApp  GhcPs = (IsUnicodeSyntax, EpaLocation)+type instance XCmdArrApp  GhcRn = NoExtField+type instance XCmdArrApp  GhcTc = Type++type instance XCmdArrForm GhcPs = AnnList ()+-- | fixity (filled in by the renamer), for forms that were converted from+-- OpApp's by the renamer+type instance XCmdArrForm GhcRn = Maybe Fixity+type instance XCmdArrForm GhcTc = Maybe Fixity++type instance XCmdApp     (GhcPass _) = NoExtField+type instance XCmdLam     (GhcPass _) = NoExtField++type instance XCmdPar     GhcPs = (EpToken "(", EpToken ")")+type instance XCmdPar     GhcRn = NoExtField+type instance XCmdPar     GhcTc = NoExtField++type instance XCmdCase    GhcPs = EpAnnHsCase+type instance XCmdCase    GhcRn = NoExtField+type instance XCmdCase    GhcTc = NoExtField++type instance XCmdLamCase (GhcPass _) = EpAnnLam++type instance XCmdIf      GhcPs = AnnsIf+type instance XCmdIf      GhcRn = NoExtField+type instance XCmdIf      GhcTc = NoExtField++type instance XCmdLet     GhcPs = (EpToken "let", EpToken "in")+type instance XCmdLet     GhcRn = NoExtField+type instance XCmdLet     GhcTc = NoExtField++type instance XCmdDo      GhcPs = AnnList EpaLocation+type instance XCmdDo      GhcRn = NoExtField+type instance XCmdDo      GhcTc = Type++type instance XCmdWrap    (GhcPass _) = NoExtField++type instance XXCmd       GhcPs = DataConCantHappen+type instance XXCmd       GhcRn = DataConCantHappen+type instance XXCmd       GhcTc = HsWrap HsCmd++    -- If   cmd :: arg1 --> res+    --      wrap :: arg1 "->" arg2+    -- Then (XCmd (HsWrap wrap cmd)) :: arg2 --> res++-- | Command Syntax Table (for Arrow syntax)+type CmdSyntaxTable p = [(Name, HsExpr p)]+-- See Note [CmdSyntaxTable]++{-+Note [CmdSyntaxTable]+~~~~~~~~~~~~~~~~~~~~~+Used only for arrow-syntax stuff (HsCmdTop), the CmdSyntaxTable keeps+track of the methods needed for a Cmd.++* Before the renamer, this list is an empty list++* After the renamer, it takes the form @[(std_name, HsVar actual_name)]@+  For example, for the 'arr' method+   * normal case:            (GHC.Control.Arrow.arr, HsVar GHC.Control.Arrow.arr)+   * with rebindable syntax: (GHC.Control.Arrow.arr, arr_22)+             where @arr_22@ is whatever 'arr' is in scope++* After the type checker, it takes the form [(std_name, <expression>)]+  where <expression> is the evidence for the method.  This evidence is+  instantiated with the class, but is still polymorphic in everything+  else.  For example, in the case of 'arr', the evidence has type+         forall b c. (b->c) -> a b c+  where 'a' is the ambient type of the arrow.  This polymorphism is+  important because the desugarer uses the same evidence at multiple+  different types.++This is Less Cool than what we normally do for rebindable syntax, which is to+make fully-instantiated piece of evidence at every use site.  The Cmd way+is Less Cool because+  * The renamer has to predict which methods are needed.+    See the tedious GHC.Rename.Expr.methodNamesCmd.++  * The desugarer has to know the polymorphic type of the instantiated+    method. This is checked by Inst.tcSyntaxName, but is less flexible+    than the rest of rebindable syntax, where the type is less+    pre-ordained.  (And this flexibility is useful; for example we can+    typecheck do-notation with (>>=) :: m1 a -> (a -> m2 b) -> m2 b.)+-}++data CmdTopTc+  = CmdTopTc Type    -- Nested tuple of inputs on the command's stack+             Type    -- return type of the command+             (CmdSyntaxTable GhcTc) -- See Note [CmdSyntaxTable]++type instance XCmdTop  GhcPs = NoExtField+type instance XCmdTop  GhcRn = CmdSyntaxTable GhcRn -- See Note [CmdSyntaxTable]+type instance XCmdTop  GhcTc = CmdTopTc+++type instance XXCmdTop (GhcPass _) = DataConCantHappen++instance (OutputableBndrId p) => Outputable (HsCmd (GhcPass p)) where+    ppr cmd = pprCmd cmd++-----------------------+-- pprCmd and pprLCmd call pprDeeper;+-- the underscore versions do not+pprLCmd :: (OutputableBndrId p) => LHsCmd (GhcPass p) -> SDoc+pprLCmd (L _ c) = pprCmd c++pprCmd :: (OutputableBndrId p) => HsCmd (GhcPass p) -> SDoc+pprCmd c | isQuietHsCmd c =            ppr_cmd c+         | otherwise      = pprDeeper (ppr_cmd c)++isQuietHsCmd :: HsCmd id -> Bool+-- Parentheses do display something, but it gives little info and+-- if we go deeper when we go inside them then we get ugly things+-- like (...)+isQuietHsCmd (HsCmdPar {}) = True+-- applications don't display anything themselves+isQuietHsCmd (HsCmdApp {}) = True+isQuietHsCmd _ = False++-----------------------+ppr_lcmd :: (OutputableBndrId p) => LHsCmd (GhcPass p) -> SDoc+ppr_lcmd c = ppr_cmd (unLoc c)++ppr_cmd :: forall p. (OutputableBndrId p+                     ) => HsCmd (GhcPass p) -> SDoc+ppr_cmd (HsCmdPar _ c) = parens (ppr_lcmd c)++ppr_cmd (HsCmdApp _ c e)+  = let (fun, args) = collect_args c [e] in+    hang (ppr_lcmd fun) 2 (sep (map ppr args))+  where+    collect_args (L _ (HsCmdApp _ fun arg)) args = collect_args fun (arg:args)+    collect_args fun args = (fun, args)++ppr_cmd (HsCmdLam _ LamSingle matches)+  = pprMatches matches+ppr_cmd (HsCmdLam _ lam_variant matches)+  = sep [ lamCaseKeyword lam_variant, nest 2 (pprMatches matches) ]++ppr_cmd (HsCmdCase _ expr matches)+  = sep [ sep [text "case", nest 4 (ppr expr), text "of"],+          nest 2 (pprMatches matches) ]++ppr_cmd (HsCmdIf _ _ e ct ce)+  = sep [hsep [text "if", nest 2 (ppr e), text "then"],+         nest 4 (ppr ct),+         text "else",+         nest 4 (ppr ce)]++-- special case: let ... in let ...+ppr_cmd (HsCmdLet _ binds cmd@(L _ (HsCmdLet {})))+  = sep [hang (text "let") 2 (hsep [pprBinds binds, text "in"]),+         ppr_lcmd cmd]++ppr_cmd (HsCmdLet _ binds cmd)+  = sep [hang (text "let") 2 (pprBinds binds),+         hang (text "in")  2 (ppr cmd)]++ppr_cmd (HsCmdDo _ (L _ stmts))  = pprArrowExpr stmts++ppr_cmd (HsCmdArrApp _ arrow arg HsFirstOrderApp True)+  = hsep [ppr_lexpr arrow, larrowt, ppr_lexpr arg]+ppr_cmd (HsCmdArrApp _ arrow arg HsFirstOrderApp False)+  = hsep [ppr_lexpr arg, arrowt, ppr_lexpr arrow]+ppr_cmd (HsCmdArrApp _ arrow arg HsHigherOrderApp True)+  = hsep [ppr_lexpr arrow, larrowtt, ppr_lexpr arg]+ppr_cmd (HsCmdArrApp _ arrow arg HsHigherOrderApp False)+  = hsep [ppr_lexpr arg, arrowtt, ppr_lexpr arrow]++ppr_cmd (HsCmdArrForm rn_fix (L _ op) ps_fix args)+  | HsVar _ (L _ v) <- op+  = ppr_cmd_infix v+  | GhcTc <- ghcPass @p+  , XExpr (ConLikeTc c _ _) <- op+  = ppr_cmd_infix (conLikeName c)+  | otherwise+  = fall_through+  where+    fall_through = hang (text "(|" <+> ppr_expr op)+                      4 (sep (map (pprCmdArg.unLoc) args) <+> text "|)")++    ppr_cmd_infix :: OutputableBndr v => v -> SDoc+    ppr_cmd_infix v+      | [arg1, arg2] <- args+      , case ghcPass @p of+          GhcPs -> ps_fix == Infix+          GhcRn -> isJust rn_fix || ps_fix == Infix+          GhcTc -> isJust rn_fix || ps_fix == Infix+      = hang (pprCmdArg (unLoc arg1))+           4 (sep [ pprInfixOcc v, pprCmdArg (unLoc arg2)])+      | otherwise+      = fall_through++ppr_cmd (XCmd x) = case ghcPass @p of+  GhcTc -> case x of+    HsWrap w cmd -> pprHsWrapper w (\_ -> parens (ppr_cmd cmd))++pprCmdArg :: (OutputableBndrId p) => HsCmdTop (GhcPass p) -> SDoc+pprCmdArg (HsCmdTop _ cmd)+  = ppr_lcmd cmd++instance (OutputableBndrId p) => Outputable (HsCmdTop (GhcPass p)) where+    ppr = pprCmdArg++{-+************************************************************************+*                                                                      *+\subsection{@Match@, @GRHSs@, and @GRHS@ datatypes}+*                                                                      *+************************************************************************+-}++type instance XMG         GhcPs b = Origin+type instance XMG         GhcRn b = Origin -- See Note [Generated code and pattern-match checking]+type instance XMG         GhcTc b = MatchGroupTc++data MatchGroupTc+  = MatchGroupTc+       { mg_arg_tys :: [Scaled Type]  -- Types of the arguments, t1..tn+       , mg_res_ty  :: Type    -- Type of the result, tr+       , mg_origin  :: Origin  -- Origin (Generated vs FromSource)+       } deriving Data++type instance XXMatchGroup (GhcPass _) b = DataConCantHappen++type instance XCMatch (GhcPass _) b = NoExtField+type instance XXMatch (GhcPass _) b = DataConCantHappen++instance (OutputableBndrId pr, Outputable body)+            => Outputable (Match (GhcPass pr) body) where+  ppr = pprMatch++isEmptyMatchGroup :: MatchGroup (GhcPass p) body -> Bool+isEmptyMatchGroup (MG { mg_alts = ms }) = null $ unLoc ms++-- | Is there only one RHS in this list of matches?+isSingletonMatchGroup :: [LMatch (GhcPass p) body] -> Bool+isSingletonMatchGroup matches+  | [L _ match] <- matches+  , Match { m_grhss = GRHSs { grhssGRHSs = _ :| [] } } <- match+  = True+  | otherwise+  = False++matchGroupArity :: MatchGroup (GhcPass id) body -> Arity+-- This is called before type checking, when mg_arg_tys is not set+matchGroupArity MG { mg_alts = L _ [] } = 1 -- See Note [Empty mg_alts]+matchGroupArity MG { mg_alts = L _ (alt1 : _) } = count isVisArgLPat (hsLMatchPats alt1)++hsLMatchPats :: LMatch (GhcPass id) body -> [LPat (GhcPass id)]+hsLMatchPats (L _ (Match { m_pats = L _ pats })) = pats++isInfixMatch :: Match (GhcPass p) body -> Bool+isInfixMatch match = case m_ctxt match of+  FunRhs {mc_fixity = Infix} -> True+  _                          -> False++-- We keep the type checker happy by providing EpAnnComments.  They+-- can only be used if they follow a `where` keyword with no binds,+-- but in that case the comment is attached to the following parsed+-- item. So this can never be used in practice.+type instance XCGRHSs (GhcPass _) _ = EpAnnComments++type instance XXGRHSs (GhcPass _) _ = DataConCantHappen++data GrhsAnn+  = GrhsAnn {+      ga_vbar :: Maybe (EpToken "|"),+      ga_sep  :: Either (EpToken "=") TokRarrow -- ^ Match separator location, `=` or `->`+      } deriving (Data)++instance NoAnn GrhsAnn where+  noAnn = GrhsAnn Nothing noAnn++type instance XCGRHS (GhcPass _) _ = EpAnn GrhsAnn+                                   -- Location of matchSeparator+                                   -- TODO:AZ does this belong on the GRHS, or GRHSs?++type instance XXGRHS (GhcPass _) b = DataConCantHappen++pprMatches :: (OutputableBndrId idR, Outputable body)+           => MatchGroup (GhcPass idR) body -> SDoc+pprMatches MG { mg_alts = matches }+    = vcat (map pprMatch (map unLoc (unLoc matches)))+      -- Don't print the type; it's only a place-holder before typechecking++-- Exported to GHC.Hs.Binds, which can't see the defn of HsMatchContext+pprFunBind :: (OutputableBndrId idR)+           => MatchGroup (GhcPass idR) (LHsExpr (GhcPass idR)) -> SDoc+pprFunBind matches = pprMatches matches++-- Exported to GHC.Hs.Binds, which can't see the defn of HsMatchContext+pprPatBind :: forall bndr p . (OutputableBndrId bndr,+                               OutputableBndrId p)+           => LPat (GhcPass bndr) -> GRHSs (GhcPass p) (LHsExpr (GhcPass p)) -> SDoc+pprPatBind pat grhss+ = sep [ppr pat,+       nest 2 (pprGRHSs (PatBindRhs :: HsMatchContext Void) grhss)]++pprMatch :: (OutputableBndrId idR, Outputable body)+         => Match (GhcPass idR) body -> SDoc+pprMatch (Match { m_pats = L _ pats, m_ctxt = ctxt, m_grhss = grhss })+  = sep [ sep (herald : map (nest 2 . pprParendLPat appPrec) other_pats)+        , nest 2 (pprGRHSs ctxt grhss) ]+  where+    -- lam_cases_result: we don't simply return (empty, pats) to avoid+    -- introducing an additional `nest 2` via the empty herald+    lam_cases_result = case pats of+                          []     -> (empty, [])+                          (p:ps) -> (pprParendLPat appPrec p, ps)++    (herald, other_pats)+        = case ctxt of+            FunRhs {mc_fun=L _ fun, mc_fixity=fixity, mc_strictness=strictness}+                | SrcStrict <- strictness+                -> assert (null pats)     -- A strict variable binding+                   (char '!'<>pprPrefixOcc fun, pats)++                | Prefix <- fixity+                -> (pprPrefixOcc fun, pats) -- f x y z = e+                                            -- Not pprBndr; the AbsBinds will+                                            -- have printed the signature+                | otherwise+                -> case pats of+                     (p1:p2:rest)+                        | null rest -> (pp_infix, [])           -- x &&& y = e+                        | otherwise -> (parens pp_infix, rest)  -- (x &&& y) z = e+                        where+                          pp_infix = pprParendLPat opPrec p1+                                     <+> pprInfixOcc fun+                                     <+> pprParendLPat opPrec p2+                     _ -> pprPanic "pprMatch" (ppr ctxt $$ ppr pats)++            LamAlt LamSingle                       -> (char '\\', pats)+            ArrowMatchCtxt (ArrowLamAlt LamSingle) -> (char '\\', pats)+            LamAlt LamCases                        -> lam_cases_result+            ArrowMatchCtxt (ArrowLamAlt LamCases)  -> lam_cases_result++            ArrowMatchCtxt ProcExpr -> (text "proc", pats)++            _ -> case pats of+                   []    -> (empty, [])+                   [pat] -> (ppr pat, [])  -- No parens around the single pat in a case+                   _     -> pprPanic "pprMatch" (ppr ctxt $$ ppr pats)++pprGRHSs :: (OutputableBndrId idR, Outputable body)+         => HsMatchContext fn -> GRHSs (GhcPass idR) body -> SDoc+pprGRHSs ctxt (GRHSs _ grhss binds)+  = vcat (toList $ NE.map (pprGRHS ctxt . unLoc) grhss)+  -- Print the "where" even if the contents of the binds is empty. Only+  -- EmptyLocalBinds means no "where" keyword+ $$ ppUnless (eqEmptyLocalBinds binds)+      (text "where" $$ nest 4 (pprBinds binds))++pprGRHS :: (OutputableBndrId idR, Outputable body)+        => HsMatchContext fn -> GRHS (GhcPass idR) body -> SDoc+pprGRHS ctxt (GRHS _ [] body)+ =  pp_rhs ctxt body++pprGRHS ctxt (GRHS _ guards body)+ = sep [vbar <+> interpp'SP guards, pp_rhs ctxt body]++pp_rhs :: Outputable body => HsMatchContext fn -> body -> SDoc+pp_rhs ctxt rhs = matchSeparator ctxt <+> pprDeeper (ppr rhs)++matchSeparator :: HsMatchContext fn -> SDoc+matchSeparator FunRhs{}         = text "="+matchSeparator CaseAlt          = arrow+matchSeparator LamAlt{}         = arrow+matchSeparator IfAlt            = arrow+matchSeparator ArrowMatchCtxt{} = arrow+matchSeparator PatBindRhs       = text "="+matchSeparator PatBindGuards    = text "="+matchSeparator StmtCtxt{}       = text "<-"+matchSeparator RecUpd           = text "="  -- This can be printed by the pattern+matchSeparator PatSyn           = text "<-" -- match checker trace+matchSeparator LazyPatCtx       = panic "unused"+matchSeparator ThPatSplice      = panic "unused"+matchSeparator ThPatQuote       = panic "unused"++instance Outputable GrhsAnn where+  ppr (GrhsAnn v s) = text "GrhsAnn" <+> ppr v <+> ppr s++{-+************************************************************************+*                                                                      *+\subsection{Do stmts and list comprehensions}+*                                                                      *+************************************************************************+-}++-- Extra fields available post typechecking for RecStmt.+data RecStmtTc =+  RecStmtTc+     { recS_bind_ty :: Type       -- S in (>>=) :: Q -> (R -> S) -> T+     , recS_later_rets :: [PostTcExpr] -- (only used in the arrow version)+     , recS_rec_rets :: [PostTcExpr] -- These expressions correspond 1-to-1+                                  -- with recS_later_ids and recS_rec_ids,+                                  -- and are the expressions that should be+                                  -- returned by the recursion.+                                  -- They may not quite be the Ids themselves,+                                  -- because the Id may be *polymorphic*, but+                                  -- the returned thing has to be *monomorphic*,+                                  -- so they may be type applications++      , recS_ret_ty :: Type        -- The type of+                                   -- do { stmts; return (a,b,c) }+                                   -- With rebindable syntax the type might not+                                   -- be quite as simple as (m (tya, tyb, tyc)).+      }+++type instance XLastStmt        (GhcPass _) (GhcPass _) b = NoExtField++type instance XBindStmt        (GhcPass _) GhcPs b = EpUniToken "<-" "←"+type instance XBindStmt        (GhcPass _) GhcRn b = XBindStmtRn+type instance XBindStmt        (GhcPass _) GhcTc b = XBindStmtTc++data XBindStmtRn = XBindStmtRn+  { xbsrn_bindOp :: SyntaxExpr GhcRn+  , xbsrn_failOp :: FailOperator GhcRn+  }++data XBindStmtTc = XBindStmtTc+  { xbstc_bindOp :: SyntaxExpr GhcTc+  , xbstc_boundResultType :: Type -- If (>>=) :: Q -> (R -> S) -> T, this is S+  , xbstc_boundResultMult :: Mult -- If (>>=) :: Q -> (R -> S) -> T, this is S+  , xbstc_failOp :: FailOperator GhcTc+  }++type instance XApplicativeStmt (GhcPass _) GhcPs = NoExtField+type instance XApplicativeStmt (GhcPass _) GhcRn = NoExtField+type instance XApplicativeStmt (GhcPass _) GhcTc = Type++type instance XBodyStmt        (GhcPass _) GhcPs b = NoExtField+type instance XBodyStmt        (GhcPass _) GhcRn b = NoExtField+type instance XBodyStmt        (GhcPass _) GhcTc b = Type++type instance XLetStmt         (GhcPass _) (GhcPass _) b = EpToken "let"++type instance XParStmt         (GhcPass _) GhcPs b = NoExtField+type instance XParStmt         (GhcPass _) GhcRn b = NoExtField+type instance XParStmt         (GhcPass _) GhcTc b = Type++type instance XTransStmt       (GhcPass _) GhcPs b = AnnTransStmt+type instance XTransStmt       (GhcPass _) GhcRn b = NoExtField+type instance XTransStmt       (GhcPass _) GhcTc b = Type++type instance XRecStmt         (GhcPass _) GhcPs b = AnnList (EpToken "rec")+type instance XRecStmt         (GhcPass _) GhcRn b = NoExtField+type instance XRecStmt         (GhcPass _) GhcTc b = RecStmtTc++type instance XXStmtLR         (GhcPass _) GhcPs b = DataConCantHappen+type instance XXStmtLR         (GhcPass x) GhcRn b = ApplicativeStmt (GhcPass x) GhcRn+type instance XXStmtLR         (GhcPass x) GhcTc b = ApplicativeStmt (GhcPass x) GhcTc++data AnnTransStmt+  = AnnTransStmt {+      ats_then  :: EpToken "then",+      ats_group :: Maybe (EpToken "group"),+      ats_by    :: Maybe (EpToken "by"),+      ats_using :: Maybe (EpToken "using")+      } deriving Data++instance NoAnn AnnTransStmt where+  noAnn = AnnTransStmt noAnn noAnn noAnn noAnn+++-- | 'ApplicativeStmt' represents an applicative expression built with+-- '<$>' and '<*>'.  It is generated by the renamer, and is desugared into the+-- appropriate applicative expression by the desugarer, but it is intended+-- to be invisible in error messages.+--+-- For full details, see Note [ApplicativeDo] in "GHC.Rename.Expr"+--+data ApplicativeStmt idL idR+  = ApplicativeStmt+             (XApplicativeStmt idL idR) -- Post typecheck, Type of the body+             [ ( SyntaxExpr idR+               , ApplicativeArg idL) ]+                      -- [(<$>, e1), (<*>, e2), ..., (<*>, en)]+             (Maybe (SyntaxExpr idR))  -- 'join', if necessary++-- | Applicative Argument+data ApplicativeArg idL+  = ApplicativeArgOne      -- A single statement (BindStmt or BodyStmt)+    { xarg_app_arg_one  :: XApplicativeArgOne idL+      -- ^ The fail operator, after renaming+      --+      -- The fail operator is needed if this is a BindStmt+      -- where the pattern can fail. E.g.:+      -- (Just a) <- stmt+      -- The fail operator will be invoked if the pattern+      -- match fails.+      -- It is also used for guards in MonadComprehensions.+      -- The fail operator is Nothing+      -- if the pattern match can't fail+    , app_arg_pattern   :: LPat idL -- WildPat if it was a BodyStmt (see below)+    , arg_expr          :: LHsExpr idL+    , is_body_stmt      :: Bool+      -- ^ True <=> was a BodyStmt,+      -- False <=> was a BindStmt.+      -- See Note [Applicative BodyStmt]+    }+  | ApplicativeArgMany     -- do { stmts; return vars }+    { xarg_app_arg_many :: XApplicativeArgMany idL+    , app_stmts         :: [ExprLStmt idL] -- stmts+    , final_expr        :: HsExpr idL    -- return (v1,..,vn), or just (v1,..,vn)+    , bv_pattern        :: LPat idL      -- (v1,...,vn)+    , stmt_context      :: HsDoFlavour+      -- ^ context of the do expression, used in pprArg+    }+  | XApplicativeArg !(XXApplicativeArg idL)++type family XApplicativeStmt x x'++-- ApplicativeArg type families+type family XApplicativeArgOne   x+type family XApplicativeArgMany  x+type family XXApplicativeArg     x++type instance XParStmtBlock  (GhcPass pL) (GhcPass pR) = NoExtField+type instance XXParStmtBlock (GhcPass pL) (GhcPass pR) = DataConCantHappen++type instance XApplicativeArgOne GhcPs = NoExtField+type instance XApplicativeArgOne GhcRn = FailOperator GhcRn+type instance XApplicativeArgOne GhcTc = FailOperator GhcTc++type instance XApplicativeArgMany (GhcPass _) = NoExtField+type instance XXApplicativeArg    (GhcPass _) = DataConCantHappen++instance (Outputable (StmtLR (GhcPass idL) (GhcPass idL) (LHsExpr (GhcPass idL))),+          Outputable (XXParStmtBlock (GhcPass idL) (GhcPass idR)))+        => Outputable (ParStmtBlock (GhcPass idL) (GhcPass idR)) where+  ppr (ParStmtBlock _ stmts _ _) = interpp'SP stmts++instance (OutputableBndrId pl, OutputableBndrId pr,+                 Anno (StmtLR (GhcPass pl) (GhcPass pr) body) ~ SrcSpanAnnA,+          Outputable body)+         => Outputable (StmtLR (GhcPass pl) (GhcPass pr) body) where+    ppr stmt = pprStmt stmt++pprStmt :: forall idL idR body . (OutputableBndrId idL,+                                  OutputableBndrId idR,+                 Anno (StmtLR (GhcPass idL) (GhcPass idR) body) ~ SrcSpanAnnA,+                                  Outputable body)+        => (StmtLR (GhcPass idL) (GhcPass idR) body) -> SDoc+pprStmt (LastStmt _ expr m_dollar_stripped _)+  = whenPprDebug (text "[last]") <+>+      (case m_dollar_stripped of+        Just True -> text "return $"+        Just False -> text "return"+        Nothing -> empty) <+>+      ppr expr+pprStmt (BindStmt _ pat expr)  = pprBindStmt pat expr+pprStmt (LetStmt _ binds)      = hsep [text "let", pprBinds binds]+pprStmt (BodyStmt _ expr _ _)  = ppr expr+pprStmt (ParStmt _ stmtss _ _) = sep (punctuate (text " | ") (map ppr $ toList stmtss))++pprStmt (TransStmt { trS_stmts = stmts, trS_by = by+                   , trS_using = using, trS_form = form })+  = sep $ punctuate comma (map ppr stmts ++ [pprTransStmt by using form])++pprStmt (RecStmt { recS_stmts = segment, recS_rec_ids = rec_ids+                 , recS_later_ids = later_ids })+  = text "rec" <+>+    vcat [ ppr_do_stmts (unLoc segment)+         , whenPprDebug (vcat [ text "rec_ids=" <> ppr rec_ids+                            , text "later_ids=" <> ppr later_ids])]++pprStmt (XStmtLR x) = case ghcPass :: GhcPass idR of+    GhcRn -> pprApplicativeStmt x+    GhcTc -> pprApplicativeStmt x++  where+    pprApplicativeStmt :: (OutputableBndrId idL, OutputableBndrId idR) => ApplicativeStmt (GhcPass idL) (GhcPass idR) -> SDoc+    pprApplicativeStmt (ApplicativeStmt _ args mb_join) =+      getPprStyle $ \style ->+          if userStyle style+             then pp_for_user+             else pp_debug+      where+        -- make all the Applicative stuff invisible in error messages by+        -- flattening the whole ApplicativeStmt nest back to a sequence+        -- of statements.+        pp_for_user = vcat $ concatMap flattenArg args++        -- ppr directly rather than transforming here, because we need to+        -- inject a "return" which is hard when we're polymorphic in the id+        -- type.+        flattenStmt :: ExprLStmt (GhcPass idL) -> [SDoc]+        flattenStmt (L _ (XStmtLR x)) = case ghcPass :: GhcPass idL of+            GhcRn | (ApplicativeStmt _ args _) <- x -> concatMap flattenArg args+            GhcTc | (ApplicativeStmt _ args _) <- x -> concatMap flattenArg args+        flattenStmt stmt = [ppr stmt]++        flattenArg :: (a, ApplicativeArg (GhcPass idL)) -> [SDoc]+        flattenArg (_, ApplicativeArgOne _ pat expr isBody)+          | isBody =  [ppr expr] -- See Note [Applicative BodyStmt]+          | otherwise = [pprBindStmt pat expr]+        flattenArg (_, ApplicativeArgMany _ stmts _ _ _) =+          concatMap flattenStmt stmts++        pp_debug =+          let+              ap_expr = sep (punctuate (text " |") (map pp_arg args))+          in+            whenPprDebug (if isJust mb_join then text "[join]" else empty) <+>+            (if lengthAtLeast args 2 then parens else id) ap_expr++        pp_arg :: (a, ApplicativeArg (GhcPass idL)) -> SDoc+        pp_arg (_, applicativeArg) = ppr applicativeArg++pprBindStmt :: (Outputable pat, Outputable expr) => pat -> expr -> SDoc+pprBindStmt pat expr = hsep [ppr pat, larrow, ppr expr]++instance (OutputableBndrId idL)+      => Outputable (ApplicativeArg (GhcPass idL)) where+  ppr = pprArg++pprArg :: forall idL . (OutputableBndrId idL) => ApplicativeArg (GhcPass idL) -> SDoc+pprArg (ApplicativeArgOne _ pat expr isBody)+  | isBody = ppr expr -- See Note [Applicative BodyStmt]+  | otherwise = pprBindStmt pat expr+pprArg (ApplicativeArgMany _ stmts return pat ctxt) =+     ppr pat <+>+     text "<-" <+>+     pprDo ctxt (stmts +++                   [noLocA (LastStmt noExtField (noLocA return) Nothing noSyntaxExpr)])++pprTransformStmt :: (OutputableBndrId p)+                 => [IdP (GhcPass p)] -> LHsExpr (GhcPass p)+                 -> Maybe (LHsExpr (GhcPass p)) -> SDoc+pprTransformStmt bndrs using by+  = sep [ text "then" <+> whenPprDebug (braces (ppr bndrs))+        , nest 2 (ppr using)+        , nest 2 (pprBy by)]++pprTransStmt :: Outputable body => Maybe body -> body -> TransForm -> SDoc+pprTransStmt by using ThenForm+  = sep [ text "then", nest 2 (ppr using), nest 2 (pprBy by)]+pprTransStmt by using GroupForm+  = sep [ text "then group", nest 2 (pprBy by), nest 2 (text "using" <+> ppr using)]++pprBy :: Outputable body => Maybe body -> SDoc+pprBy Nothing  = empty+pprBy (Just e) = text "by" <+> ppr e++pprDo :: (OutputableBndrId p, Outputable body,+                 Anno (StmtLR (GhcPass p) (GhcPass p) body) ~ SrcSpanAnnA+         )+      => HsDoFlavour -> [LStmt (GhcPass p) body] -> SDoc+pprDo (DoExpr m)    stmts =+  ppr_module_name_prefix m <> text "do"  <+> ppr_do_stmts stmts+pprDo GhciStmtCtxt  stmts = text "do"  <+> ppr_do_stmts stmts+pprDo (MDoExpr m)   stmts =+  ppr_module_name_prefix m <> text "mdo"  <+> ppr_do_stmts stmts+pprDo ListComp      stmts = brackets    $ pprComp stmts+pprDo MonadComp     stmts = brackets    $ pprComp stmts++pprArrowExpr :: (OutputableBndrId p, Outputable body,+                 Anno (StmtLR (GhcPass p) (GhcPass p) body) ~ SrcSpanAnnA+         )+      => [LStmt (GhcPass p) body] -> SDoc+pprArrowExpr stmts = text "do"  <+> ppr_do_stmts stmts++ppr_module_name_prefix :: Maybe ModuleName -> SDoc+ppr_module_name_prefix = \case+  Nothing -> empty+  Just module_name -> ppr module_name <> char '.'++ppr_do_stmts :: (OutputableBndrId idL, OutputableBndrId idR,+                 Anno (StmtLR (GhcPass idL) (GhcPass idR) body) ~ SrcSpanAnnA,+                 Outputable body)+             => [LStmtLR (GhcPass idL) (GhcPass idR) body] -> SDoc+-- Print a bunch of do stmts+ppr_do_stmts stmts = pprDeeperList vcat (map ppr stmts)++pprComp :: (OutputableBndrId p, Outputable body,+                 Anno (StmtLR (GhcPass p) (GhcPass p) body) ~ SrcSpanAnnA)+        => [LStmt (GhcPass p) body] -> SDoc+pprComp quals     -- Prints:  body | qual1, ..., qualn+  | Just (initStmts, L _ (LastStmt _ body _ _)) <- snocView quals+  = if null initStmts+       -- If there are no statements in a list comprehension besides the last+       -- one, we simply treat it like a normal list. This does arise+       -- occasionally in code that GHC generates, e.g., in implementations of+       -- 'range' for derived 'Ix' instances for product datatypes with exactly+       -- one constructor (e.g., see #12583).+       then ppr body+       else hang (ppr body <+> vbar) 2 (pprQuals initStmts)+  | otherwise+  = pprPanic "pprComp" (pprQuals quals)++pprQuals :: (OutputableBndrId p, Outputable body,+                 Anno (StmtLR (GhcPass p) (GhcPass p) body) ~ SrcSpanAnnA)+         => [LStmt (GhcPass p) body] -> SDoc+-- Show list comprehension qualifiers separated by commas+pprQuals quals = interpp'SP quals++{-+************************************************************************+*                                                                      *+                Template Haskell quotation brackets+*                                                                      *+************************************************************************+-}++-- | Finalizers produced by a splice with+-- 'Language.Haskell.TH.Syntax.addModFinalizer'+--+-- See Note [Delaying modFinalizers in untyped splices] in GHC.Rename.Splice. For how+-- this is used.+--+newtype ThModFinalizers = ThModFinalizers [ForeignRef (TH.Q ())]++-- A Data instance which ignores the argument of 'ThModFinalizers'.+instance Data ThModFinalizers where+  gunfold _ z _ = z $ ThModFinalizers []+  toConstr  a   = mkConstr (dataTypeOf a) "ThModFinalizers" [] Data.Prefix+  dataTypeOf a  = mkDataType "HsExpr.ThModFinalizers" [toConstr a]++-- See Note [Delaying modFinalizers in untyped splices] in GHC.Rename.Splice.+-- This is the result of splicing a splice. It is produced by+-- the renamer and consumed by the typechecker. It lives only between the two.+data HsUntypedSpliceResult thing  -- 'thing' can be HsExpr or HsType+  = HsUntypedSpliceTop+      { utsplice_result_finalizers :: ThModFinalizers -- ^ TH finalizers produced by the splice.+      , utsplice_result            :: thing           -- ^ The result of splicing; See Note [Lifecycle of a splice]+      }+  | HsUntypedSpliceNested SplicePointName -- A unique name to identify this splice point++-- See Note [Lifecycle of an untyped splice, and PendingRnSplice]+-- for an explanation of the Template Haskell extension points.+data HsTypedSpliceResult+  = HsTypedSpliceTop+  | HsTypedSpliceNested SplicePointName++type instance XTypedSplice   GhcPs = NoExtField+type instance XTypedSplice   GhcRn = HsTypedSpliceResult+type instance XTypedSplice   GhcTc = DelayedSplice++type instance XUntypedSplice GhcPs = NoExtField+type instance XUntypedSplice GhcRn = HsUntypedSpliceResult (HsExpr GhcRn)+type instance XUntypedSplice GhcTc = DataConCantHappen++-- HsUntypedSplice+type instance XUntypedSpliceExpr GhcPs = EpToken "$"+type instance XUntypedSpliceExpr GhcRn = HsUserSpliceExt+type instance XUntypedSpliceExpr GhcTc = DataConCantHappen++type instance XTypedSpliceExpr GhcPs = EpToken "$$"+type instance XTypedSpliceExpr GhcRn = NoExtField+type instance XTypedSpliceExpr GhcTc = NoExtField++type instance XQuasiQuote        GhcPs = NoExtField+type instance XQuasiQuote        GhcRn = HsQuasiQuoteExt+type instance XQuasiQuote        GhcTc = DataConCantHappen+++type instance XXUntypedSplice    GhcPs = DataConCantHappen+type instance XXUntypedSplice    GhcRn = HsImplicitLiftSplice+type instance XXUntypedSplice    GhcTc = DataConCantHappen++type instance XXTypedSplice    GhcPs = DataConCantHappen+type instance XXTypedSplice    GhcRn = HsImplicitLiftSplice+type instance XXTypedSplice    GhcTc = DataConCantHappen++-- See Note [Running typed splices in the zonker]+-- These are the arguments that are passed to `GHC.Tc.Gen.Splice.runTopSplice`+data DelayedSplice =+  DelayedSplice+    TcLclEnv          -- The local environment to run the splice in+    (LHsExpr GhcRn)   -- The original renamed expression+    TcType            -- The result type of running the splice, unzonked+    (LHsExpr GhcTc)   -- The typechecked expression to run and splice in the result++-- A Data instance which ignores the argument of 'DelayedSplice'.+instance Data DelayedSplice where+  gunfold _ _ _ = panic "DelayedSplice"+  toConstr  a   = mkConstr (dataTypeOf a) "DelayedSplice" [] Data.Prefix+  dataTypeOf a  = mkDataType "HsExpr.DelayedSplice" [toConstr a]++-- See Note [Pending Splices]+type SplicePointName = Name++data UntypedSpliceFlavour+  = UntypedExpSplice+  | UntypedPatSplice+  | UntypedTypeSplice+  | UntypedDeclSplice+  deriving Data+++-- See Note [Lifecycle of an untyped splice, and PendingRnSplice]+-- A 'PendingRnSplice' is lifted from an untyped quotation and then typechecked.+data PendingRnSplice = PendingRnSplice SplicePointName (HsUntypedSplice GhcRn)++instance Outputable PendingRnSplice where+  ppr (PendingRnSplice sp expr) =+    angleBrackets (ppr sp <> comma <+> pprUntypedSplice False Nothing expr)++-- | Pending Type-checker Splice+-- See Note [Lifecycle of an untyped splice, and PendingRnSplice]+data PendingTcSplice+  = PendingTcSplice SplicePointName (LHsExpr GhcTc)++-- | Information about an implicit lift, discovered by the renamer+-- See Note [Lifecycle of an untyped splice, and PendingRnSplice]+data HsImplicitLiftSplice =+        HsImplicitLiftSplice+          { implicit_lift_bind_lvl :: S.Set ThLevelIndex+          , implicit_lift_used_lvl :: ThLevelIndex+          , implicit_lift_gre :: Maybe GlobalRdrElt+          , implicit_lift_lid :: LIdOccP GhcRn+          }++-- | Information about a user-written splice, discovered by the renamer+-- See Note [Lifecycle of an untyped splice, and PendingRnSplice]+data HsUserSpliceExt =+  HsUserSpliceExt+    { user_splice_flavour :: UntypedSpliceFlavour+    }++-- | Information about a quasi-quoter, discovered by the renamer+-- See Note [Lifecycle of an untyped splice, and PendingRnSplice]+data HsQuasiQuoteExt =+  HsQuasiQuoteExt+    { quasi_quote_flavour :: UntypedSpliceFlavour+    }+++pprTypedSplice :: forall p . (OutputableBndrId p) => Maybe SplicePointName -> HsTypedSplice (GhcPass p) -> SDoc+pprTypedSplice n (HsTypedSpliceExpr _ e) = ppr_splice (text "$$") n e+pprTypedSplice n (XTypedSplice p) =+  case ghcPass @p of+    GhcRn -> case p of+              HsImplicitLiftSplice _ _ _ lid -> ppr lid <+> whenPprDebug (maybe empty (brackets . ppr) n)++pprUntypedSplice :: forall p. (OutputableBndrId p)+                 => Bool -- Whether to precede the splice with "$"+                 -> Maybe SplicePointName -- Used for pretty printing when exists+                 -> HsUntypedSplice (GhcPass p)+                 -> SDoc+pprUntypedSplice True  n (HsUntypedSpliceExpr _ e) = ppr_splice (text "$") n e+pprUntypedSplice False n (HsUntypedSpliceExpr _ e) = ppr_splice empty n e+pprUntypedSplice _     _ (HsQuasiQuote _ q s)      = ppr_quasi (unLoc q) (unLoc s)+pprUntypedSplice _     _ (XUntypedSplice x) =+  case ghcPass @p of+    GhcRn -> case x of+              HsImplicitLiftSplice _ _ _ lid -> ppr lid++ppr_quasi :: OutputableBndr p => p -> FastString -> SDoc+ppr_quasi quoter quote = char '[' <> ppr quoter <> vbar <>+                           ppr quote <> text "|]"++ppr_splice :: (OutputableBndrId p)+           => SDoc+           -> Maybe SplicePointName+           -> LHsExpr (GhcPass p)+           -> SDoc+ppr_splice herald mn e+    = herald+    <> (case mn of+         Nothing -> empty+         Just splice_name -> whenPprDebug (brackets (ppr splice_name)))+    <> ppr e+++type instance XExpBr  GhcPs       = (BracketAnn (EpUniToken "[|" "⟦") (EpToken "[e|"), EpUniToken "|]" "⟧")+type instance XPatBr  GhcPs       = (EpToken "[p|", EpUniToken "|]" "⟧")+type instance XDecBrL GhcPs       = (EpToken "[d|", EpUniToken "|]" "⟧", (EpToken "{", EpToken "}"))+type instance XDecBrG GhcPs       = NoExtField+type instance XTypBr  GhcPs       = (EpToken "[t|", EpUniToken "|]" "⟧")+type instance XVarBr  GhcPs       = EpaLocation+type instance XXQuote GhcPs       = DataConCantHappen++type instance XExpBr  GhcRn       = NoExtField+type instance XPatBr  GhcRn       = NoExtField+type instance XDecBrL GhcRn       = NoExtField+type instance XDecBrG GhcRn       = NoExtField+type instance XTypBr  GhcRn       = NoExtField+type instance XVarBr  GhcRn       = NoExtField+type instance XXQuote GhcRn       = DataConCantHappen++-- See Note [The life cycle of a TH quotation]+type instance XExpBr  GhcTc       = DataConCantHappen+type instance XPatBr  GhcTc       = DataConCantHappen+type instance XDecBrL GhcTc       = DataConCantHappen+type instance XDecBrG GhcTc       = DataConCantHappen+type instance XTypBr  GhcTc       = DataConCantHappen+type instance XVarBr  GhcTc       = DataConCantHappen+type instance XXQuote GhcTc       = NoExtField++instance OutputableBndrId p+          => Outputable (HsQuote (GhcPass p)) where+  ppr = pprHsQuote+    where+      pprHsQuote :: forall p. (OutputableBndrId p)+                   => HsQuote (GhcPass p) -> SDoc+      pprHsQuote (ExpBr _ e)   = thBrackets empty (ppr e)+      pprHsQuote (PatBr _ p)   = thBrackets (char 'p') (ppr p)+      pprHsQuote (DecBrG _ gp) = thBrackets (char 'd') (ppr gp)+      pprHsQuote (DecBrL _ ds) = thBrackets (char 'd') (vcat (map ppr ds))+      pprHsQuote (TypBr _ t)   = thBrackets (char 't') (ppr t)+      pprHsQuote (VarBr _ True n)+        = char '\'' <> pprPrefixOcc (unLoc n)+      pprHsQuote (VarBr _ False n)+        = text "''" <> pprPrefixOcc (unLoc n)+      pprHsQuote (XQuote b)  = case ghcPass @p of+          GhcTc -> pprPanic "pprHsQuote: `HsQuote GhcTc` shouldn't exist" (ppr b)+                   -- See Note [The life cycle of a TH quotation]++thBrackets :: SDoc -> SDoc -> SDoc+thBrackets pp_kind pp_body = char '[' <> pp_kind <> vbar <+>+                             pp_body <+> text "|]"++thTyBrackets :: SDoc -> SDoc+thTyBrackets pp_body = text "[||" <+> pp_body <+> text "||]"++instance Outputable PendingTcSplice where+  ppr (PendingTcSplice n e) = angleBrackets (ppr n <> comma <+> ppr (stripParensLHsExpr e))++ppr_with_pending_tc_splices :: SDoc -> [PendingTcSplice] -> SDoc+ppr_with_pending_tc_splices x [] = x+ppr_with_pending_tc_splices x ps = x $$ whenPprDebug (text "pending(tc)" <+> ppr ps)++{-+************************************************************************+*                                                                      *+\subsection{Enumerations and list comprehensions}+*                                                                      *+************************************************************************+-}++instance OutputableBndrId p+         => Outputable (ArithSeqInfo (GhcPass p)) where+    ppr (From e1)             = hcat [ppr e1, pp_dotdot]+    ppr (FromThen e1 e2)      = hcat [ppr e1, comma, space, ppr e2, pp_dotdot]+    ppr (FromTo e1 e3)        = hcat [ppr e1, pp_dotdot, ppr e3]+    ppr (FromThenTo e1 e2 e3)+      = hcat [ppr e1, comma, space, ppr e2, pp_dotdot, ppr e3]++pp_dotdot :: SDoc+pp_dotdot = text " .. "++{-+************************************************************************+*                                                                      *+\subsection{HsMatchCtxt}+*                                                                      *+************************************************************************+-}++type HsMatchContextPs = HsMatchContext (LIdP GhcPs)+type HsMatchContextRn = HsMatchContext (LIdP GhcRn)++type HsStmtContextRn = HsStmtContext (LIdP GhcRn)++instance Outputable fn => Outputable (HsMatchContext fn) where+  ppr m@(FunRhs{})            = text "FunRhs" <+> ppr (mc_fun m) <+> ppr (mc_fixity m)+  ppr CaseAlt                 = text "CaseAlt"+  ppr (LamAlt lam_variant)    = text "LamAlt" <+> ppr lam_variant+  ppr IfAlt                   = text "IfAlt"+  ppr (ArrowMatchCtxt c)      = text "ArrowMatchCtxt" <+> ppr c+  ppr PatBindRhs              = text "PatBindRhs"+  ppr PatBindGuards           = text "PatBindGuards"+  ppr RecUpd                  = text "RecUpd"+  ppr (StmtCtxt _)            = text "StmtCtxt _"+  ppr ThPatSplice             = text "ThPatSplice"+  ppr ThPatQuote              = text "ThPatQuote"+  ppr PatSyn                  = text "PatSyn"+  ppr LazyPatCtx              = text "LazyPatCtx"++instance Outputable HsLamVariant where+  ppr = text . \case+    LamSingle -> "LamSingle"+    LamCase   -> "LamCase"+    LamCases  -> "LamCases"++lamCaseKeyword :: HsLamVariant -> SDoc+lamCaseKeyword LamSingle = text "lambda"+lamCaseKeyword LamCase   = text "\\case"+lamCaseKeyword LamCases  = text "\\cases"++pprExternalSrcLoc :: (StringLiteral,(Int,Int),(Int,Int)) -> SDoc+pprExternalSrcLoc (StringLiteral _ src _,(n1,n2),(n3,n4))+  = ppr (src,(n1,n2),(n3,n4))++instance Outputable HsArrowMatchContext where+  ppr ProcExpr                  = text "ProcExpr"+  ppr ArrowCaseAlt              = text "ArrowCaseAlt"+  ppr (ArrowLamAlt lam_variant) = parens $ text "ArrowLamCaseAlt" <+> ppr lam_variant++pprHsArrType :: HsArrAppType -> SDoc+pprHsArrType HsHigherOrderApp = text "higher order arrow application"+pprHsArrType HsFirstOrderApp  = text "first order arrow application"++-----------------++instance Outputable fn => Outputable (HsStmtContext fn) where+    ppr = pprStmtContext++-- Used to generate the string for a *runtime* error message+matchContextErrString :: Outputable fn => HsMatchContext fn -> SDoc+matchContextErrString (FunRhs{mc_fun=fun})          = text "function" <+> ppr fun+matchContextErrString CaseAlt                       = text "case"+matchContextErrString (LamAlt lam_variant)          = lamCaseKeyword lam_variant+matchContextErrString IfAlt                         = text "multi-way if"+matchContextErrString PatBindRhs                    = text "pattern binding"+matchContextErrString PatBindGuards                 = text "pattern binding guards"+matchContextErrString RecUpd                        = text "record update"+matchContextErrString (ArrowMatchCtxt c)            = matchArrowContextErrString c+matchContextErrString ThPatSplice                   = panic "matchContextErrString"  -- Not used at runtime+matchContextErrString ThPatQuote                    = panic "matchContextErrString"  -- Not used at runtime+matchContextErrString PatSyn                        = text "pattern synonym"+matchContextErrString (StmtCtxt (ParStmtCtxt c))    = matchContextErrString (StmtCtxt c)+matchContextErrString (StmtCtxt (TransStmtCtxt c))  = matchContextErrString (StmtCtxt c)+matchContextErrString (StmtCtxt (PatGuard _))       = text "pattern guard"+matchContextErrString (StmtCtxt (ArrowExpr))        = text "'do' block"+matchContextErrString (StmtCtxt (HsDoStmt flavour)) = matchDoContextErrString flavour+matchContextErrString LazyPatCtx                    = text "irrefutable pattern"++matchArrowContextErrString :: HsArrowMatchContext -> SDoc+matchArrowContextErrString ProcExpr                  = text "proc"+matchArrowContextErrString ArrowCaseAlt              = text "case"+matchArrowContextErrString (ArrowLamAlt LamSingle)   = text "kappa"+matchArrowContextErrString (ArrowLamAlt lam_variant) = lamCaseKeyword lam_variant++matchDoContextErrString :: HsDoFlavour -> SDoc+matchDoContextErrString GhciStmtCtxt = text "interactive GHCi command"+matchDoContextErrString (DoExpr m)   = prependQualified m (text "'do' block")+matchDoContextErrString (MDoExpr m)  = prependQualified m (text "'mdo' block")+matchDoContextErrString ListComp     = text "list comprehension"+matchDoContextErrString MonadComp    = text "monad comprehension"++pprMatchInCtxt :: (OutputableBndrId idR, Outputable body)+               => Match (GhcPass idR) body -> SDoc+pprMatchInCtxt match  = hang (text "In" <+> pprMatchContext (m_ctxt match)+                                        <> colon)+                             4 (pprMatch match)++pprStmtInCtxt :: (OutputableBndrId idL,+                  OutputableBndrId idR,+                  Outputable fn,+                  Outputable body,+                 Anno (StmtLR (GhcPass idL) (GhcPass idR) body) ~ SrcSpanAnnA)+              => HsStmtContext fn+              -> StmtLR (GhcPass idL) (GhcPass idR) body+              -> SDoc+pprStmtInCtxt ctxt (LastStmt _ e _ _)+  | isComprehensionContext ctxt      -- For [ e | .. ], do not mutter about "stmts"+  = hang (text "In the expression:") 2 (ppr e)++pprStmtInCtxt ctxt stmt+  = hang (text "In a stmt of" <+> pprAStmtContext ctxt <> colon)+       2 (ppr_stmt stmt)+  where+    -- For Group and Transform Stmts, don't print the nested stmts!+    ppr_stmt (TransStmt { trS_by = by, trS_using = using+                        , trS_form = form }) = pprTransStmt by using form+    ppr_stmt stmt = pprStmt stmt+++pprMatchContext :: Outputable p => HsMatchContext p -> SDoc+pprMatchContext ctxt+  | want_an ctxt = text "an" <+> pprMatchContextNoun ctxt+  | otherwise    = text "a"  <+> pprMatchContextNoun ctxt+  where+    want_an (FunRhs {})                              = True  -- Use "an" in front+    want_an (ArrowMatchCtxt ProcExpr)                = True+    want_an (ArrowMatchCtxt (ArrowLamAlt LamSingle)) = True+    want_an LazyPatCtx                               = True+    want_an _                                        = False++pprMatchContextNoun :: Outputable fn => HsMatchContext fn -> SDoc+pprMatchContextNoun (FunRhs {mc_fun=fun})   = text "equation for" <+> quotes (ppr fun)+pprMatchContextNoun CaseAlt                 = text "case alternative"+pprMatchContextNoun (LamAlt LamSingle)      = text "lambda abstraction"+pprMatchContextNoun (LamAlt lam_variant)    = lamCaseKeyword lam_variant+                                              <+> text "alternative"+pprMatchContextNoun IfAlt                   = text "multi-way if alternative"+pprMatchContextNoun RecUpd                  = text "record update"+pprMatchContextNoun ThPatSplice             = text "Template Haskell pattern splice"+pprMatchContextNoun ThPatQuote              = text "Template Haskell pattern quotation"+pprMatchContextNoun PatBindRhs              = text "pattern binding"+pprMatchContextNoun PatBindGuards           = text "pattern binding guards"+pprMatchContextNoun (ArrowMatchCtxt c)      = pprArrowMatchContextNoun c+pprMatchContextNoun (StmtCtxt ctxt)         = text "pattern binding in"+                                              $$ pprAStmtContext ctxt+pprMatchContextNoun PatSyn                  = text "pattern synonym declaration"+pprMatchContextNoun LazyPatCtx              = text "irrefutable pattern"++pprMatchContextNouns :: Outputable fn => HsMatchContext fn -> SDoc+pprMatchContextNouns (FunRhs {mc_fun=fun})   = text "equations for" <+> quotes (ppr fun)+pprMatchContextNouns PatBindGuards           = text "pattern binding guards"+pprMatchContextNouns (ArrowMatchCtxt c)      = pprArrowMatchContextNouns c+pprMatchContextNouns (StmtCtxt ctxt)         = text "pattern bindings in"+                                               $$ pprAStmtContext ctxt+pprMatchContextNouns ctxt                    = pprMatchContextNoun ctxt <> char 's'++pprArrowMatchContextNoun :: HsArrowMatchContext -> SDoc+pprArrowMatchContextNoun ProcExpr                     = text "arrow proc pattern"+pprArrowMatchContextNoun ArrowCaseAlt                 = text "case alternative within arrow notation"+pprArrowMatchContextNoun (ArrowLamAlt LamSingle)   = text "arrow kappa abstraction"+pprArrowMatchContextNoun (ArrowLamAlt lam_variant) = lamCaseKeyword lam_variant+                                                     <+> text "alternative within arrow notation"++pprArrowMatchContextNouns :: HsArrowMatchContext -> SDoc+pprArrowMatchContextNouns ArrowCaseAlt              = text "case alternatives within arrow notation"+pprArrowMatchContextNouns (ArrowLamAlt LamSingle)   = text "arrow kappa abstractions"+pprArrowMatchContextNouns (ArrowLamAlt lam_variant) = lamCaseKeyword lam_variant+                                                      <+> text "alternatives within arrow notation"+pprArrowMatchContextNouns ctxt                      = pprArrowMatchContextNoun ctxt <> char 's'++-----------------+pprAStmtContext, pprStmtContext :: Outputable fn => HsStmtContext fn -> SDoc+pprAStmtContext (HsDoStmt flavour) = pprAHsDoFlavour flavour+pprAStmtContext ctxt = text "a" <+> pprStmtContext ctxt++-----------------+pprStmtContext (HsDoStmt flavour) = pprHsDoFlavour flavour+pprStmtContext (PatGuard ctxt) = text "pattern guard for" $$ pprMatchContext ctxt+pprStmtContext ArrowExpr       = text "'do' block in an arrow command"++-- Drop the inner contexts when reporting errors, else we get+--     Unexpected transform statement+--     in a transformed branch of+--          transformed branch of+--          transformed branch of monad comprehension+pprStmtContext (ParStmtCtxt c) =+  ifPprDebug (sep [text "parallel branch of", pprAStmtContext c])+             (pprStmtContext c)+pprStmtContext (TransStmtCtxt c) =+  ifPprDebug (sep [text "transformed branch of", pprAStmtContext c])+             (pprStmtContext c)++pprStmtCat :: forall p body . IsPass p => Stmt (GhcPass p) body -> SDoc+pprStmtCat (TransStmt {})       = text "transform"+pprStmtCat (LastStmt {})        = text "return expression"+pprStmtCat (BodyStmt {})        = text "body"+pprStmtCat (BindStmt {})        = text "binding"+pprStmtCat (LetStmt {})         = text "let"+pprStmtCat (RecStmt {})         = text "rec"+pprStmtCat (ParStmt {})         = text "parallel"+pprStmtCat (XStmtLR _)          = text "applicative"++pprAHsDoFlavour, pprHsDoFlavour :: HsDoFlavour -> SDoc+pprAHsDoFlavour flavour = article <+> pprHsDoFlavour flavour+  where+    pp_an = text "an"+    pp_a  = text "a"+    article = case flavour of+                  MDoExpr Nothing -> pp_an+                  GhciStmtCtxt  -> pp_an+                  _             -> pp_a+pprHsDoFlavour (DoExpr m)      = prependQualified m (text "'do' block")+pprHsDoFlavour (MDoExpr m)     = prependQualified m (text "'mdo' block")+pprHsDoFlavour ListComp        = text "list comprehension"+pprHsDoFlavour MonadComp       = text "monad comprehension"+pprHsDoFlavour GhciStmtCtxt    = text "interactive GHCi command"++prependQualified :: Maybe ModuleName -> SDoc -> SDoc+prependQualified Nothing  t = t+prependQualified (Just _) t = text "qualified" <+> t++{-+************************************************************************+*                                                                      *+FieldLabelStrings+*                                                                      *+************************************************************************+-}++instance (UnXRec p, Outputable (XRec p FieldLabelString)) => Outputable (FieldLabelStrings p) where+  ppr (FieldLabelStrings flds) =+    hcat (punctuate dot (toList $ NE.map (ppr . unXRec @p) flds))++instance (UnXRec p, Outputable (XRec p FieldLabelString)) => OutputableBndr (FieldLabelStrings p) where+  pprInfixOcc = pprFieldLabelStrings+  pprPrefixOcc = pprFieldLabelStrings++instance (UnXRec p,  Outputable (XRec p FieldLabelString)) => OutputableBndr (Located (FieldLabelStrings p)) where+  pprInfixOcc = pprInfixOcc . unLoc+  pprPrefixOcc = pprInfixOcc . unLoc++pprFieldLabelStrings :: forall p. (UnXRec p, Outputable (XRec p FieldLabelString)) => FieldLabelStrings p -> SDoc+pprFieldLabelStrings (FieldLabelStrings flds) =+    hcat (punctuate dot (toList $ NE.map (ppr . unXRec @p) flds))++pprPrefixFastString :: FastString -> SDoc+pprPrefixFastString fs = pprPrefixOcc (mkVarUnqual fs)++instance UnXRec p => Outputable (DotFieldOcc p) where+  ppr (DotFieldOcc _ s) = (pprPrefixFastString . field_label . unXRec @p) s+  ppr XDotFieldOcc{} = text "XDotFieldOcc"++{-+************************************************************************+*                                                                      *+\subsection{Anno instances}+*                                                                      *+************************************************************************+-}++type instance Anno (HsExpr (GhcPass p)) = SrcSpanAnnA+type instance Anno [LocatedA (HsExpr (GhcPass p))] = SrcSpanAnnC+type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsExpr (GhcPass pr))))] = SrcSpanAnnLW+type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsCmd (GhcPass pr))))] = SrcSpanAnnLW++type instance Anno (HsCmd (GhcPass p)) = SrcSpanAnnA++type instance Anno (HsCmdTop (GhcPass p)) = EpAnnCO+type instance Anno [LocatedA (Match (GhcPass p) (LocatedA (HsExpr (GhcPass p))))] = SrcSpanAnnLW+type instance Anno [LocatedA (Match (GhcPass p) (LocatedA (HsCmd  (GhcPass p))))] = SrcSpanAnnLW+type instance Anno (Match (GhcPass p) (LocatedA (HsExpr (GhcPass p)))) = SrcSpanAnnA+type instance Anno (Match (GhcPass p) (LocatedA (HsCmd  (GhcPass p)))) = SrcSpanAnnA+type instance Anno [LocatedA (Pat (GhcPass p))] = EpaLocation+type instance Anno (GRHS (GhcPass p) (LocatedA (HsExpr (GhcPass p)))) = EpAnnCO+type instance Anno (GRHS (GhcPass p) (LocatedA (HsCmd  (GhcPass p)))) = EpAnnCO+type instance Anno (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (body (GhcPass pr)))) = SrcSpanAnnA++type instance Anno (HsUntypedSplice (GhcPass p)) = SrcSpanAnnA++type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (body (GhcPass pr))))] = SrcSpanAnnLW++type instance Anno (FieldLabelStrings (GhcPass p)) = EpAnnCO+type instance Anno FieldLabelString                = SrcSpanAnnN++type instance Anno FastString                      = EpAnnCO+  -- Used in HsQuasiQuote and perhaps elsewhere++type instance Anno (DotFieldOcc (GhcPass p))       = EpAnnCO++instance (HasAnnotation (Anno a))    => WrapXRec (GhcPass p) a where   wrapXRec = noLocA
GHC/Hs/Expr.hs-boot view
@@ -1,3 +1,5 @@+{-# LANGUAGE RoleAnnotations #-}+{-# LANGUAGE KindSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]@@ -10,16 +12,21 @@ import GHC.Utils.Outputable ( SDoc, Outputable ) import Language.Haskell.Syntax.Pat ( LPat ) import {-# SOURCE #-} GHC.Hs.Pat () -- for Outputable-import GHC.Types.Basic ( SpliceExplicitFlag(..)) import Language.Haskell.Syntax.Expr   ( HsExpr, LHsExpr   , HsCmd   , MatchGroup   , GRHSs-  , HsSplice+  , 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)) @@ -27,10 +34,8 @@  pprExpr :: (OutputableBndrId p) => HsExpr (GhcPass p) -> SDoc -pprSplice :: (OutputableBndrId p) => HsSplice (GhcPass p) -> SDoc--pprSpliceDecl ::  (OutputableBndrId p)-          => HsSplice (GhcPass p) -> SpliceExplicitFlag -> 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)@@ -38,3 +43,12 @@  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
GHC/Hs/Extension.hs view
@@ -11,10 +11,13 @@ {-# 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@@ -95,13 +98,21 @@ -}  -- See Note [XRec and Anno in the AST] in GHC.Parser.Annotation-type instance XRec (GhcPass p) a = GenLocated (Anno a) a+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 IsSrcSpanAnn p a = ( Anno (IdGhcP p) ~ SrcSpanAnn' (EpAnn a),+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@@ -168,11 +179,15 @@  -- | 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...+--+-- @+-- 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@@ -195,6 +210,16 @@   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.@@ -211,9 +236,13 @@ -- the @id@ and the 'NoGhcTc' of it. See Note [NoGhcTc]. type OutputableBndrId pass =   ( OutputableBndr (IdGhcP pass)+  , OutputableBndr (IdOccGhcP pass)   , OutputableBndr (IdGhcP (NoGhcTcPass pass))-  , Outputable (GenLocated (Anno (IdGhcP pass)) (IdGhcP pass))-  , Outputable (GenLocated (Anno (IdGhcP (NoGhcTcPass pass))) (IdGhcP (NoGhcTcPass pass)))+  , OutputableBndr (IdOccGhcP (NoGhcTcPass pass))+  , Outputable (LIdGhcP pass)+  , Outputable (LIdOccGhcP pass)+  , Outputable (LIdGhcP (NoGhcTcPass pass))+  , Outputable (LIdOccGhcP (NoGhcTcPass pass))   , IsPass pass   ) @@ -230,12 +259,10 @@ pprIfTc pp = case ghcPass @p of GhcTc -> pp                                 _     -> empty -type instance Anno (HsToken tok) = TokenLocation--noHsTok :: GenLocated TokenLocation (HsToken tok)-noHsTok = L NoTokenLoc HsTok+--- Outputable -type instance Anno (HsUniToken tok utok) = TokenLocation+instance Outputable NoExtField where+  ppr _ = text "NoExtField" -noHsUniTok :: GenLocated TokenLocation (HsUniToken tok utok)-noHsUniTok = L NoTokenLoc HsNormalTok+instance Outputable DataConCantHappen where+  ppr = dataConCantHappen
GHC/Hs/ImpExp.hs view
@@ -1,4 +1,6 @@+{-# OPTIONS_GHC -Wno-orphans      #-} -- Outputable and IEWrappedName {-# LANGUAGE DataKinds            #-}+{-# LANGUAGE StandaloneDeriving   #-} {-# LANGUAGE DeriveDataTypeable   #-} {-# LANGUAGE FlexibleContexts     #-} {-# LANGUAGE FlexibleInstances    #-}@@ -6,6 +8,8 @@ {-# 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@@ -14,62 +18,48 @@ GHC.Hs.ImpExp: Abstract syntax: imports, exports, interfaces -} -module GHC.Hs.ImpExp where+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.Unit.Module        ( ModuleName, IsBootInterface(..) )-import GHC.Hs.Doc import GHC.Types.SourceText   ( SourceText(..) )-import GHC.Types.FieldLabel   ( FieldLabel )--import GHC.Utils.Outputable-import GHC.Utils.Panic import GHC.Types.SrcLoc-import Language.Haskell.Syntax.Extension-import GHC.Hs.Extension-import GHC.Parser.Annotation import GHC.Types.Name import GHC.Types.PkgQual +import GHC.Parser.Annotation+import GHC.Hs.Extension++import GHC.Utils.Outputable+import GHC.Utils.Panic++import GHC.Unit.Module.Warnings+ import Data.Data import Data.Maybe+import GHC.Hs.Doc (LHsDoc) + {- ************************************************************************ *                                                                      *-\subsection{Import and export declaration lists}+    Import and export declaration lists *                                                                      * ************************************************************************ -One per \tr{import} declaration in a module.+One per import declaration in a module. -} --- | Located Import Declaration-type LImportDecl pass = XRec pass (ImportDecl pass)-        -- ^ When in a list this may have-        ---        --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnSemi'--        -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation type instance Anno (ImportDecl (GhcPass p)) = SrcSpanAnnA --- | If/how an import is 'qualified'.-data ImportDeclQualifiedStyle-  = QualifiedPre  -- ^ 'qualified' appears in prepositive position.-  | QualifiedPost -- ^ 'qualified' appears in postpositive position.-  | NotQualified  -- ^ Not qualified.-  deriving (Eq, Data) --- | Given two possible located 'qualified' tokens, compute a style--- (in a conforming Haskell program only one of the two can be not--- 'Nothing'). This is called from "GHC.Parser".-importDeclQualifiedStyle :: Maybe EpaLocation-                         -> Maybe EpaLocation-                         -> (Maybe EpaLocation, ImportDeclQualifiedStyle)-importDeclQualifiedStyle mPre mPost =-  if isJust mPre then (mPre, QualifiedPre)-  else if isJust mPost then (mPost,QualifiedPost) else (Nothing, NotQualified)  -- | Convenience function to answer the question if an import decl. is -- qualified.@@ -77,100 +67,101 @@ isImportDeclQualified NotQualified = False isImportDeclQualified _ = True --- | Import Declaration------ A single Haskell @import@ declaration.-data ImportDecl pass-  = ImportDecl {-      ideclExt       :: XCImportDecl pass,-      ideclSourceSrc :: SourceText,-                                 -- Note [Pragma source text] in GHC.Types.SourceText-      ideclName      :: XRec pass ModuleName, -- ^ Module name.-      ideclPkgQual   :: ImportDeclPkgQual pass,  -- ^ Package qualifier.-      ideclSource    :: IsBootInterface,      -- ^ IsBoot <=> {-\# SOURCE \#-} import-      ideclSafe      :: Bool,          -- ^ True => safe import-      ideclQualified :: ImportDeclQualifiedStyle, -- ^ If/how the import is qualified.-      ideclImplicit  :: Bool,          -- ^ True => implicit import (of Prelude)-      ideclAs        :: Maybe (XRec pass ModuleName),  -- ^ as Module-      ideclHiding    :: Maybe (Bool, XRec pass [LIE pass])-                                       -- ^ (True => hiding, names)-    }-  | XImportDecl !(XXImportDecl pass)-     -- ^-     --  'GHC.Parser.Annotation.AnnKeywordId's-     ---     --  - 'GHC.Parser.Annotation.AnnImport'-     ---     --  - 'GHC.Parser.Annotation.AnnOpen', 'GHC.Parser.Annotation.AnnClose' for ideclSource-     ---     --  - 'GHC.Parser.Annotation.AnnSafe','GHC.Parser.Annotation.AnnQualified',-     --    'GHC.Parser.Annotation.AnnPackageName','GHC.Parser.Annotation.AnnAs',-     --    'GHC.Parser.Annotation.AnnVal'-     ---     --  - 'GHC.Parser.Annotation.AnnHiding','GHC.Parser.Annotation.AnnOpen',-     --    'GHC.Parser.Annotation.AnnClose' attached-     --     to location in ideclHiding -     -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation -type family ImportDeclPkgQual pass type instance ImportDeclPkgQual GhcPs = RawPkgQual type instance ImportDeclPkgQual GhcRn = PkgQual type instance ImportDeclPkgQual GhcTc = PkgQual -type instance XCImportDecl  GhcPs = EpAnn EpAnnImportDecl-type instance XCImportDecl  GhcRn = NoExtField-type instance XCImportDecl  GhcTc = NoExtField+type instance 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))] = SrcSpanAnnL+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    :: EpaLocation-  , importDeclAnnPragma    :: Maybe (EpaLocation, EpaLocation)-  , importDeclAnnSafe      :: Maybe EpaLocation-  , importDeclAnnQualified :: Maybe EpaLocation-  , importDeclAnnPackage   :: Maybe EpaLocation-  , importDeclAnnAs        :: Maybe EpaLocation+  { 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       = noAnn,-      ideclSourceSrc = NoSourceText,-      ideclName      = noLocA mn,-      ideclPkgQual   = NoRawPkgQual,-      ideclSource    = NotBoot,-      ideclSafe      = False,-      ideclImplicit  = False,-      ideclQualified = NotQualified,-      ideclAs        = Nothing,-      ideclHiding    = Nothing+      ideclExt        = XImportDeclPass noAnn NoSourceText False,+      ideclName       = noLocA mn,+      ideclPkgQual    = NoRawPkgQual,+      ideclSource     = NotBoot,+      ideclSafe       = False,+      ideclLevelSpec  = NotLevelled,+      ideclQualified  = NotQualified,+      ideclAs         = Nothing,+      ideclImportList = Nothing     }  instance (OutputableBndrId p          , Outputable (Anno (IE (GhcPass p)))          , Outputable (ImportDeclPkgQual (GhcPass p)))        => Outputable (ImportDecl (GhcPass p)) where-    ppr (ImportDecl { ideclSourceSrc = mSrcText, ideclName = mod'+    ppr (ImportDecl { ideclExt = impExt, ideclName = mod'                     , ideclPkgQual = pkg                     , ideclSource = from, ideclSafe = safe-                    , ideclQualified = qual, ideclImplicit = implicit-                    , ideclAs = as, ideclHiding = spec })-      = hang (hsep [text "import", ppr_imp from, pp_implicit implicit, pp_safe safe,+                    , ideclQualified = qual+                    , ideclAs = as, ideclImportList = spec })+      = hang (hsep [text "import", ppr_imp impExt from, pp_implicit impExt, pp_safe safe,                     pp_qual qual False, ppr pkg, ppr mod', pp_qual qual True, pp_as as])              4 (pp_spec spec)       where-        pp_implicit False = empty-        pp_implicit True = text "(implicit)"+        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.@@ -184,14 +175,19 @@         pp_as Nothing   = empty         pp_as (Just a)  = text "as" <+> ppr a -        ppr_imp IsBoot = case mSrcText of-                          NoSourceText   -> text "{-# SOURCE #-}"-                          SourceText src -> text src <+> text "#-}"-        ppr_imp NotBoot = empty+        ppr_imp ext IsBoot =+            let mSrcText = case ghcPass @p of+                                GhcPs | XImportDeclPass { ideclSourceText = mst } <- ext -> mst+                                GhcRn | XImportDeclPass { ideclSourceText = mst } <- ext -> mst+                                GhcTc -> dataConCantHappen ext+            in case mSrcText of+                  NoSourceText   -> text "{-# SOURCE #-}"+                  SourceText src -> ftext src <+> text "#-}"+        ppr_imp _ NotBoot = empty          pp_spec Nothing             = empty-        pp_spec (Just (False, (L _ ies))) = ppr_ies ies-        pp_spec (Just (True, (L _ ies))) = text "hiding" <+> ppr_ies ies+        pp_spec (Just (Exactly, (L _ ies))) = ppr_ies ies+        pp_spec (Just (EverythingBut, (L _ ies))) = text "hiding" <+> ppr_ies ies          ppr_ies []  = text "()"         ppr_ies ies = char '(' <+> interpp'SP ies <+> char ')'@@ -204,100 +200,52 @@ ************************************************************************ -} --- | A name in an import or export specification which may have--- adornments. Used primarily for accurate pretty printing of--- ParsedSource, and API Annotation placement. The--- 'GHC.Parser.Annotation' is the location of the adornment in--- the original source.-data IEWrappedName name-  = IEName                (LocatedN name)  -- ^ no extra-  | IEPattern EpaLocation (LocatedN name)  -- ^ pattern X-  | IEType    EpaLocation (LocatedN name)  -- ^ type (:+:)-  deriving (Eq,Data)---- | Located name with possible adornment--- - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnType',---         'GHC.Parser.Annotation.AnnPattern'-type LIEWrappedName name = LocatedA (IEWrappedName name)--- For details on above see Note [exact print annotations] in GHC.Parser.Annotation-+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 --- | Located Import or Export-type LIE pass = XRec pass (IE pass)-        -- ^ When in a list this may have-        ---        --  - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnComma'+type instance Anno (IEWrappedName (GhcPass _)) = SrcSpanAnnA -        -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation type instance Anno (IE (GhcPass p)) = SrcSpanAnnA --- | Imported or exported entity.-data IE pass-  = IEVar       (XIEVar pass) (LIEWrappedName (IdP pass))-        -- ^ Imported or Exported Variable--  | IEThingAbs  (XIEThingAbs pass) (LIEWrappedName (IdP pass))-        -- ^ Imported or exported Thing with Absent list-        ---        -- The thing is a Class/Type (can't tell)-        --  - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnPattern',-        --             'GHC.Parser.Annotation.AnnType','GHC.Parser.Annotation.AnnVal'--        -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation-        -- See Note [Located RdrNames] in GHC.Hs.Expr-  | IEThingAll  (XIEThingAll pass) (LIEWrappedName (IdP pass))-        -- ^ Imported or exported Thing with All imported or exported-        ---        -- The thing is a Class/Type and the All refers to methods/constructors-        ---        -- - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnOpen',-        --       'GHC.Parser.Annotation.AnnDotdot','GHC.Parser.Annotation.AnnClose',-        --                                 'GHC.Parser.Annotation.AnnType'--        -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation-        -- See Note [Located RdrNames] in GHC.Hs.Expr--  | IEThingWith (XIEThingWith pass)-                (LIEWrappedName (IdP pass))-                IEWildcard-                [LIEWrappedName (IdP pass)]-        -- ^ Imported or exported Thing With given imported or exported-        ---        -- The thing is a Class/Type and the imported or exported things are-        -- methods/constructors and record fields; see Note [IEThingWith]-        -- - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnOpen',-        --                                   'GHC.Parser.Annotation.AnnClose',-        --                                   'GHC.Parser.Annotation.AnnComma',-        --                                   'GHC.Parser.Annotation.AnnType'--        -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation-  | IEModuleContents  (XIEModuleContents pass) (XRec pass ModuleName)-        -- ^ Imported or exported module contents-        ---        -- (Export Only)-        ---        -- - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnModule'+-- The additional field of type 'Maybe (WarningTxt pass)' holds information+-- about export deprecation annotations and is thus set to Nothing when `IE`+-- is used in an import list (since export deprecation can only be used in exports)+type instance XIEVar       GhcPs = Maybe (LWarningTxt GhcPs)+type instance XIEVar       GhcRn = Maybe (LWarningTxt GhcRn)+type instance XIEVar       GhcTc = NoExtField -        -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation-  | IEGroup             (XIEGroup pass) Int (LHsDoc pass) -- ^ Doc section heading-  | IEDoc               (XIEDoc pass) (LHsDoc pass)       -- ^ Some documentation-  | IEDocNamed          (XIEDocNamed pass) String    -- ^ Reference to named doc-  | XIE !(XXIE pass)+-- 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 = () -type instance XIEVar             GhcPs = NoExtField-type instance XIEVar             GhcRn = NoExtField-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 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 ")") -type instance XIEThingAbs        (GhcPass _) = EpAnn [AddEpAnn]-type instance XIEThingAll        (GhcPass _) = EpAnn [AddEpAnn]+-- 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 --- See Note [IEThingWith]-type instance XIEThingWith       (GhcPass 'Parsed)      = EpAnn [AddEpAnn]-type instance XIEThingWith       (GhcPass 'Renamed)     = [Located FieldLabel]-type instance XIEThingWith       (GhcPass 'Typechecked) = NoExtField+type IEThingWithAnns = (EpToken "(", EpToken "..", EpToken ",", EpToken ")") -type instance XIEModuleContents  GhcPs = EpAnn [AddEpAnn]-type instance XIEModuleContents  GhcRn = 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 XIEModuleContents  GhcPs = (Maybe (LWarningTxt GhcPs), EpToken "module")+type instance XIEModuleContents  GhcRn = Maybe (LWarningTxt GhcRn) type instance XIEModuleContents  GhcTc = NoExtField  type instance XIEGroup           (GhcPass _) = NoExtField@@ -307,84 +255,94 @@  type instance Anno (LocatedA (IE (GhcPass p))) = SrcSpanAnnA --- | Imported or Exported Wildcard-data IEWildcard = NoIEWildcard | IEWildcard Int deriving (Eq, Data)--{--Note [IEThingWith]-~~~~~~~~~~~~~~~~~~-A definition like--    {-# LANGUAGE DuplicateRecordFields #-}-    module M ( T(MkT, x) ) where-      data T = MkT { x :: Int }--gives rise to this in the output of the parser:--    IEThingWith NoExtField T [MkT, x] NoIEWildcard--But in the renamer we need to attach the correct field label,-because the selector Name is mangled (see Note [FieldLabel] in-GHC.Types.FieldLabel).  Hence we change this to:--    IEThingWith [FieldLabel "x" True $sel:x:MkT)] T [MkT] NoIEWildcard--using the TTG extension field to store the list of fields in renamed syntax-only.  (Record fields always appear in this list, regardless of whether-DuplicateRecordFields was in use at the definition site or not.)--See Note [Representing fields in AvailInfo] in GHC.Types.Avail for more details.--}+ieLIEWrappedName :: IE (GhcPass p) -> LIEWrappedName (GhcPass p)+ieLIEWrappedName (IEVar _ n _)           = n+ieLIEWrappedName (IEThingAbs  _ n _)     = n+ieLIEWrappedName (IEThingWith _ n _ _ _) = n+ieLIEWrappedName (IEThingAll  _ n _)     = n+ieLIEWrappedName _ = panic "ieLIEWrappedName failed pattern match!"  ieName :: IE (GhcPass p) -> IdP (GhcPass p)-ieName (IEVar _ (L _ n))            = ieWrappedName n-ieName (IEThingAbs  _ (L _ n))      = ieWrappedName n-ieName (IEThingWith _ (L _ n) _ _)  = ieWrappedName n-ieName (IEThingAll  _ (L _ n))      = ieWrappedName n-ieName _ = panic "ieName failed pattern match!"+ieName = lieWrappedName . ieLIEWrappedName  ieNames :: IE (GhcPass p) -> [IdP (GhcPass p)]-ieNames (IEVar       _ (L _ n)   )   = [ieWrappedName n]-ieNames (IEThingAbs  _ (L _ n)   )   = [ieWrappedName n]-ieNames (IEThingAll  _ (L _ n)   )   = [ieWrappedName n]-ieNames (IEThingWith _ (L _ n) _ ns) = ieWrappedName n-                                     : map (ieWrappedName . unLoc) ns--- NB the above case does not include names of field selectors+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       {})     = [] -ieWrappedLName :: IEWrappedName name -> LocatedN name-ieWrappedLName (IEName      ln) = ln-ieWrappedLName (IEPattern _ ln) = ln-ieWrappedLName (IEType    _ ln) = ln+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 -ieWrappedName :: IEWrappedName name -> name+ieWrappedLName :: IEWrappedName (GhcPass p) -> LIdP (GhcPass p)+ieWrappedLName (IEDefault _ (L l n)) = L l n+ieWrappedLName (IEName    _ (L l n)) = L l n+ieWrappedLName (IEPattern _ (L l n)) = L l n+ieWrappedLName (IEType    _ (L l n)) = L l n+ieWrappedLName (IEData    _ (L l n)) = L l n++ieWrappedName :: IEWrappedName (GhcPass p) -> IdP (GhcPass p) ieWrappedName = unLoc . ieWrappedLName  -lieWrappedName :: LIEWrappedName name -> name+lieWrappedName :: LIEWrappedName (GhcPass p) -> IdP (GhcPass p) lieWrappedName (L _ n) = ieWrappedName n -ieLWrappedName :: LIEWrappedName name -> LocatedN name+ieLWrappedName :: LIEWrappedName (GhcPass p) -> LIdP (GhcPass p) ieLWrappedName (L _ n) = ieWrappedLName n -replaceWrappedName :: IEWrappedName name1 -> name2 -> IEWrappedName name2-replaceWrappedName (IEName      (L l _)) n = IEName      (L l n)+replaceWrappedName :: IEWrappedName GhcPs -> IdP GhcRn -> IEWrappedName GhcRn+replaceWrappedName (IEDefault r (L l _)) n = IEDefault r (L l n)+replaceWrappedName (IEName    x (L l _)) n = IEName    x (L l n) replaceWrappedName (IEPattern r (L l _)) n = IEPattern r (L l n) replaceWrappedName (IEType    r (L l _)) n = IEType    r (L l n)+replaceWrappedName (IEData    r (L l _)) n = IEData    r (L l n) -replaceLWrappedName :: LIEWrappedName name1 -> name2 -> LIEWrappedName name2+replaceLWrappedName :: LIEWrappedName GhcPs -> IdP GhcRn -> LIEWrappedName GhcRn replaceLWrappedName (L l n) n' = L l (replaceWrappedName n n') +exportDocstring :: LHsDoc pass -> SDoc+exportDocstring doc = braces (text "docstring: " <> ppr doc)+ instance OutputableBndrId p => Outputable (IE (GhcPass p)) where-    ppr (IEVar       _     var) = ppr (unLoc var)-    ppr (IEThingAbs  _   thing) = ppr (unLoc thing)-    ppr (IEThingAll  _   thing) = hcat [ppr (unLoc thing), text "(..)"]-    ppr (IEThingWith flds thing wc withs)-        = ppr (unLoc thing) <> parens (fsep (punctuate comma-                                              (ppWiths ++ ppFields) ))+    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@@ -393,28 +351,26 @@               IEWildcard pos ->                 let (bs, as) = splitAt pos (map (ppr . unLoc) withs)                 in bs ++ [text ".."] ++ as-        ppFields =-          case ghcPass @p of-            GhcRn -> map ppr flds-            _     -> []-    ppr (IEModuleContents _ mod')-        = text "module" <+> ppr mod'+    ppr ie@(IEModuleContents _ mod')+        = sep $ catMaybes [ppr <$> ieDeprecation ie, Just $ text "module" <+> ppr mod']     ppr (IEGroup _ n _)           = text ("<IEGroup: " ++ show n ++ ">")     ppr (IEDoc _ doc)             = ppr doc     ppr (IEDocNamed _ string)     = text ("<IEDocNamed: " ++ string ++ ">") -instance (HasOccName name) => HasOccName (IEWrappedName name) where+instance (HasOccName (IdP (GhcPass p)), OutputableBndrId p) => HasOccName (IEWrappedName (GhcPass p)) where   occName w = occName (ieWrappedName w) -instance (OutputableBndr name) => OutputableBndr (IEWrappedName name) where+instance OutputableBndrId p => OutputableBndr (IEWrappedName (GhcPass p)) where   pprBndr bs   w = pprBndr bs   (ieWrappedName w)   pprPrefixOcc w = pprPrefixOcc (ieWrappedName w)   pprInfixOcc  w = pprInfixOcc  (ieWrappedName w) -instance (OutputableBndr name) => Outputable (IEWrappedName name) where-  ppr (IEName      n) = pprPrefixOcc (unLoc n)-  ppr (IEPattern _ n) = text "pattern" <+> pprPrefixOcc (unLoc n)-  ppr (IEType    _ n) = text "type"    <+> pprPrefixOcc (unLoc n)+instance OutputableBndrId p => Outputable (IEWrappedName (GhcPass p)) where+  ppr (IEDefault _ (L _ n)) = text "default" <+> pprPrefixOcc n+  ppr (IEName    _ (L _ n)) = pprPrefixOcc n+  ppr (IEPattern _ (L _ n)) = text "pattern" <+> pprPrefixOcc n+  ppr (IEType    _ (L _ n)) = text "type"    <+> pprPrefixOcc n+  ppr (IEData    _ (L _ n)) = text "data"    <+> pprPrefixOcc n  pprImpExp :: (HasOccName name, OutputableBndr name) => name -> SDoc pprImpExp name = type_pref <+> pprPrefixOcc name
GHC/Hs/Instances.hs view
@@ -33,6 +33,9 @@ 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-----------------------------------------@@ -231,6 +234,16 @@ deriving instance Data (ForeignDecl GhcRn) deriving instance Data (ForeignDecl GhcTc) +-- deriving instance (DataIdLR p p) => Data (ForeignImport p)+deriving instance Data (ForeignImport GhcPs)+deriving instance Data (ForeignImport GhcRn)+deriving instance Data (ForeignImport GhcTc)++-- deriving instance (DataIdLR p p) => Data (ForeignExport p)+deriving instance Data (ForeignExport GhcPs)+deriving instance Data (ForeignExport GhcRn)+deriving instance Data (ForeignExport GhcTc)+ -- deriving instance (DataIdLR p p) => Data (RuleDecls p) deriving instance Data (RuleDecls GhcPs) deriving instance Data (RuleDecls GhcRn)@@ -246,6 +259,13 @@ deriving instance Data (RuleBndr GhcRn) deriving instance Data (RuleBndr GhcTc) +deriving instance Data (RuleBndrs GhcPs)+deriving instance Data (RuleBndrs GhcRn)+deriving instance Data (RuleBndrs GhcTc)++deriving instance Data TcSpecPrags+deriving instance Data TcSpecPrag+ -- deriving instance (DataId p)     => Data (WarnDecls p) deriving instance Data (WarnDecls GhcPs) deriving instance Data (WarnDecls GhcRn)@@ -277,6 +297,14 @@ 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)@@ -356,33 +384,43 @@ 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 (HsStmtContext GhcPs)-deriving instance Data (HsStmtContext GhcRn)-deriving instance Data (HsStmtContext GhcTc)- deriving instance Data HsArrowMatchContext -deriving instance Data HsDoFlavour+deriving instance Data fn => Data (HsStmtContext fn)+deriving instance Data fn => Data (HsMatchContext fn) -deriving instance Data (HsMatchContext GhcPs)-deriving instance Data (HsMatchContext GhcRn)-deriving instance Data (HsMatchContext GhcTc)+-- deriving instance (DataIdLR p p) => Data (HsUntypedSplice p)+deriving instance Data (HsUntypedSplice GhcPs)+deriving instance Data (HsUntypedSplice GhcRn)+deriving instance Data (HsUntypedSplice GhcTc) --- deriving instance (DataIdLR p p) => Data (HsSplice p)-deriving instance Data (HsSplice GhcPs)-deriving instance Data (HsSplice GhcRn)-deriving instance Data (HsSplice GhcTc)+deriving instance Data (HsTypedSplice GhcPs)+deriving instance Data (HsTypedSplice GhcRn)+deriving instance Data (HsTypedSplice GhcTc) --- deriving instance (DataIdLR p p) => Data (HsSplicedThing p)-deriving instance Data (HsSplicedThing GhcPs)-deriving instance Data (HsSplicedThing GhcRn)-deriving instance Data (HsSplicedThing GhcTc)+deriving instance Data 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)@@ -395,7 +433,6 @@ deriving instance Data (ArithSeqInfo GhcRn) deriving instance Data (ArithSeqInfo GhcTc) -deriving instance Data RecordUpdTc deriving instance Data CmdTopTc deriving instance Data PendingRnSplice deriving instance Data PendingTcSplice@@ -411,6 +448,8 @@ -- 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)@@ -440,6 +479,11 @@ -- --------------------------------------------------------------------- -- 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)@@ -465,6 +509,11 @@ 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)@@ -475,47 +524,56 @@ 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 (HsLinearArrowTokens p)-deriving instance Data (HsLinearArrowTokens GhcPs)-deriving instance Data (HsLinearArrowTokens GhcRn)-deriving instance Data (HsLinearArrowTokens GhcTc)+deriving instance Data HsTypeGhcPsExt --- deriving instance (DataIdLR p p) => Data (HsArrow p)-deriving instance Data (HsArrow GhcPs)-deriving instance Data (HsArrow GhcRn)-deriving instance Data (HsArrow GhcTc)+-- deriving instance (DataIdLR p p) => Data (HsTyLit p)+deriving instance Data (HsTyLit GhcPs)+deriving instance Data (HsTyLit GhcRn)+deriving instance Data (HsTyLit GhcTc) --- deriving instance (DataIdLR p p) => Data (HsScaled p a)-deriving instance Data thing => Data (HsScaled GhcPs thing)-deriving instance Data thing => Data (HsScaled GhcRn thing)-deriving instance Data thing => Data (HsScaled GhcTc thing)+-- 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 a b)--- deriving instance Data (HsArg (Located (HsType GhcPs)) (Located (HsKind GhcPs)))--- deriving instance Data (HsArg (Located (HsType GhcRn)) (Located (HsKind GhcRn)))--- deriving instance Data (HsArg (Located (HsType GhcTc)) (Located (HsKind 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 (ConDeclField p)-deriving instance Data (ConDeclField GhcPs)-deriving instance Data (ConDeclField GhcRn)-deriving instance Data (ConDeclField GhcTc)+-- deriving instance (DataIdLR p p) => Data (HsConDeclRecField p)+deriving instance Data (HsConDeclRecField GhcPs)+deriving instance Data (HsConDeclRecField GhcRn)+deriving instance Data (HsConDeclRecField GhcTc) +-- deriving instance (DataIdLR p p, Typeable on) => Data (HsConDeclField on p)+deriving instance Data (HsConDeclField GhcPs)+deriving instance Data (HsConDeclField GhcRn)+deriving instance Data (HsConDeclField GhcTc)+ -- deriving instance (DataId p)     => Data (FieldOcc p) deriving instance Data (FieldOcc GhcPs) deriving instance Data (FieldOcc GhcRn) deriving instance Data (FieldOcc GhcTc) --- deriving instance DataId p       => Data (AmbiguousFieldOcc p)-deriving instance Data (AmbiguousFieldOcc GhcPs)-deriving instance Data (AmbiguousFieldOcc GhcRn)-deriving instance Data (AmbiguousFieldOcc GhcTc)-- -- deriving instance (DataId name) => Data (ImportDecl name) deriving instance Data (ImportDecl GhcPs) deriving instance Data (ImportDecl GhcRn)@@ -533,6 +591,12 @@  -- --------------------------------------------------------------------- +deriving instance Data HsThingRn+deriving instance Data XXExprGhcRn+deriving instance Data a => Data (WithUserRdr a)++-- ---------------------------------------------------------------------+ deriving instance Data XXExprGhcTc deriving instance Data XXPatGhcTc @@ -541,3 +605,6 @@ deriving instance Data XViaStrategyPs  -- ---------------------------------------------------------------------++deriving instance (Typeable p, Data (Anno (IdGhcP p)), Data (IdGhcP p)) => Data (BooleanFormula (GhcPass p))+---------------------------------------------------------------------
GHC/Hs/Lit.hs view
@@ -25,14 +25,18 @@  import {-# SOURCE #-} GHC.Hs.Expr( pprExpr ) -import Language.Haskell.Syntax.Lit-+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 GHC.Hs.Extension+import Language.Haskell.Syntax.Lit  {- ************************************************************************@@ -45,18 +49,40 @@ type instance XHsChar       (GhcPass _) = SourceText type instance XHsCharPrim   (GhcPass _) = SourceText type instance XHsString     (GhcPass _) = SourceText+type instance XHsMultilineString (GhcPass _) = SourceText type instance XHsStringPrim (GhcPass _) = SourceText type instance XHsInt        (GhcPass _) = NoExtField type instance XHsIntPrim    (GhcPass _) = SourceText type instance XHsWordPrim   (GhcPass _) = SourceText+type instance XHsInt8Prim   (GhcPass _) = SourceText+type instance XHsInt16Prim  (GhcPass _) = SourceText+type instance XHsInt32Prim  (GhcPass _) = SourceText type instance XHsInt64Prim  (GhcPass _) = SourceText+type instance XHsWord8Prim  (GhcPass _) = SourceText+type instance XHsWord16Prim (GhcPass _) = SourceText+type instance XHsWord32Prim (GhcPass _) = SourceText type instance XHsWord64Prim (GhcPass _) = SourceText-type instance XHsInteger    (GhcPass _) = SourceText-type instance XHsRat        (GhcPass _) = NoExtField type instance XHsFloatPrim  (GhcPass _) = NoExtField type instance XHsDoublePrim (GhcPass _) = NoExtField-type instance XXLit         (GhcPass _) = DataConCantHappen +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]@@ -103,19 +129,71 @@ overLitType :: HsOverLit GhcTc -> Type overLitType (OverLit OverLitTc{ ol_type = ty } _) = ty --- | Convert a literal from one index type to another-convertLit :: HsLit (GhcPass p1) -> HsLit (GhcPass p2)+-- | @'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 (HsInteger a x b)  = HsInteger a x b-convertLit (HsRat a x b)      = HsRat a x b convertLit (HsFloatPrim a x)  = HsFloatPrim a x convertLit (HsDoublePrim a x) = HsDoublePrim a x @@ -135,25 +213,33 @@ -}  -- Instance specific to GhcPs, need the SourceText-instance Outputable (HsLit (GhcPass p)) where+instance IsPass p => Outputable (HsLit (GhcPass p)) where     ppr (HsChar st c)       = pprWithSourceText st (pprHsChar c)-    ppr (HsCharPrim st c)   = pp_st_suffix st primCharSuffix (pprPrimChar c)+    ppr (HsCharPrim st c)   = pprWithSourceText st (pprPrimChar c)     ppr (HsString st s)     = pprWithSourceText st (pprHsString s)+    ppr (HsMultilineString st s) =+      case st of+        NoSourceText -> pprHsString s+        SourceText src -> vcat $ map text $ split '\n' (unpackFS src)     ppr (HsStringPrim st s) = pprWithSourceText st (pprHsBytes s)     ppr (HsInt _ i)       = pprWithSourceText (il_text i) (integer (il_value i))-    ppr (HsInteger st i _)  = pprWithSourceText st (integer i)-    ppr (HsRat _ f _)       = ppr f     ppr (HsFloatPrim _ f)   = ppr f <> primFloatSuffix     ppr (HsDoublePrim _ d)  = ppr d <> primDoubleSuffix     ppr (HsIntPrim st i)    = pprWithSourceText st (pprPrimInt i)+    ppr (HsInt8Prim st i)   = pprWithSourceText st (pprPrimInt8 i)+    ppr (HsInt16Prim st i)  = pprWithSourceText st (pprPrimInt16 i)+    ppr (HsInt32Prim st i)  = pprWithSourceText st (pprPrimInt32 i)+    ppr (HsInt64Prim st i)  = pprWithSourceText st (pprPrimInt64 i)     ppr (HsWordPrim st w)   = pprWithSourceText st (pprPrimWord w)-    ppr (HsInt64Prim st i)  = pp_st_suffix st primInt64Suffix  (pprPrimInt64 i)-    ppr (HsWord64Prim st w) = pp_st_suffix st primWord64Suffix (pprPrimWord64 w)--pp_st_suffix :: SourceText -> SDoc -> SDoc -> SDoc-pp_st_suffix NoSourceText         _ doc = doc-pp_st_suffix (SourceText st) suffix _   = text st <> suffix+    ppr (HsWord8Prim st w)  = pprWithSourceText st (pprPrimWord8 w)+    ppr (HsWord16Prim st w) = pprWithSourceText st (pprPrimWord16 w)+    ppr (HsWord32Prim st w) = pprWithSourceText st (pprPrimWord32 w)+    ppr (HsWord64Prim st w) = pprWithSourceText st (pprPrimWord64 w)+    ppr (XLit x)            = case ghcPass @p of+      GhcTc -> case x of+         (HsInteger st i _) -> pprWithSourceText st (integer i)+         (HsRat  f _)       -> ppr f  -- in debug mode, print the expression that it's resolved to, too instance OutputableBndrId p@@ -161,23 +247,54 @@   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 :: HsLit (GhcPass x) -> SDoc+pmPprHsLit :: forall p. IsPass p => HsLit (GhcPass p) -> SDoc pmPprHsLit (HsChar _ c)       = pprHsChar c pmPprHsLit (HsCharPrim _ c)   = pprHsChar c pmPprHsLit (HsString st s)    = pprWithSourceText st (pprHsString s)+pmPprHsLit (HsMultilineString st s) = pprWithSourceText st (pprHsString s) pmPprHsLit (HsStringPrim _ s) = pprHsBytes s pmPprHsLit (HsInt _ i)        = integer (il_value i) pmPprHsLit (HsIntPrim _ i)    = integer i pmPprHsLit (HsWordPrim _ w)   = integer w+pmPprHsLit (HsInt8Prim _ i)   = integer i+pmPprHsLit (HsInt16Prim _ i)  = integer i+pmPprHsLit (HsInt32Prim _ i)  = integer i pmPprHsLit (HsInt64Prim _ i)  = integer i+pmPprHsLit (HsWord8Prim _ w)  = integer w+pmPprHsLit (HsWord16Prim _ w) = integer w+pmPprHsLit (HsWord32Prim _ w) = integer w pmPprHsLit (HsWord64Prim _ w) = integer w-pmPprHsLit (HsInteger _ i _)  = integer i-pmPprHsLit (HsRat _ f _)      = ppr f pmPprHsLit (HsFloatPrim _ f)  = ppr f pmPprHsLit (HsDoublePrim _ d) = ppr d+pmPprHsLit (XLit x)           = 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"
GHC/Hs/Pat.hs view
@@ -1,12 +1,15 @@ {-# 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 @@ -21,6 +24,8 @@  module GHC.Hs.Pat (         Pat(..), LPat,+        isInvisArgPat, isInvisArgLPat,+        isVisArgPat, isVisArgLPat,         EpAnnSumPat(..),         ConPatTc (..),         ConLikeP,@@ -31,17 +36,19 @@         HsRecFields(..), HsFieldBind(..), LHsFieldBind,         HsRecField, LHsRecField,         HsRecUpdField, LHsRecUpdField,+        RecFieldsDotDot(..),         hsRecFields, hsRecFieldSel, hsRecFieldId, hsRecFieldsArgs,-        hsRecUpdFieldId, hsRecUpdFieldOcc, hsRecUpdFieldRdr,          mkPrefixConPat, mkCharLitPat, mkNilPat, -        isSimplePat,+        isSimplePat, isPatSyn,         looksLazyPatBind,         isBangedLPat,         gParPat, patNeedsParens, parenthesizePat,         isIrrefutableHsPat, +        isBoringHsPat,+         collectEvVarsPat, collectEvVarsPats,          pprParendLPat, pprConArgs,@@ -53,7 +60,7 @@ import Language.Haskell.Syntax.Pat import Language.Haskell.Syntax.Expr ( HsExpr ) -import {-# SOURCE #-} GHC.Hs.Expr (pprLExpr, pprSplice)+import {-# SOURCE #-} GHC.Hs.Expr (pprLExpr, pprUntypedSplice, HsUntypedSpliceResult(..))  -- friends: import GHC.Hs.Binds@@ -69,20 +76,19 @@ import GHC.Core.Ppr ( {- instance OutputableBndr TyVar -} ) import GHC.Builtin.Types import GHC.Types.Var-import GHC.Types.Name.Reader ( RdrName )+import GHC.Types.Name.Reader import GHC.Core.ConLike import GHC.Core.DataCon-import GHC.Core.TyCon import GHC.Utils.Outputable import GHC.Core.Type import GHC.Types.SrcLoc import GHC.Data.Bag -- collect ev vars from pats-import GHC.Data.Maybe-import GHC.Types.Name (Name)-import GHC.Driver.Session-import qualified GHC.LanguageExtensions as LangExt+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@@ -90,21 +96,23 @@  type instance XVarPat  (GhcPass _) = NoExtField -type instance XLazyPat GhcPs = EpAnn [AddEpAnn] -- For '~'+type instance XLazyPat GhcPs = EpToken "~" type instance XLazyPat GhcRn = NoExtField type instance XLazyPat GhcTc = NoExtField -type instance XAsPat   GhcPs = EpAnn [AddEpAnn] -- For '@'+type instance XAsPat   GhcPs = EpToken "@" type instance XAsPat   GhcRn = NoExtField type instance XAsPat   GhcTc = NoExtField -type instance XParPat (GhcPass _) = EpAnnCO+type instance XParPat  GhcPs = (EpToken "(", EpToken ")")+type instance XParPat  GhcRn = NoExtField+type instance XParPat  GhcTc = NoExtField -type instance XBangPat GhcPs = EpAnn [AddEpAnn] -- For '!'+type instance XBangPat GhcPs = EpToken "!" type instance XBangPat GhcRn = NoExtField type instance XBangPat GhcTc = NoExtField -type instance XListPat GhcPs = EpAnn AnnList+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@@ -114,19 +122,23 @@ type instance XListPat GhcTc = Type   -- List element type, for use in hsPatType. -type instance XTuplePat GhcPs = EpAnn [AddEpAnn]+type instance XTuplePat GhcPs = (EpaLocation, EpaLocation) type instance XTuplePat GhcRn = NoExtField type instance XTuplePat GhcTc = [Type] -type instance XSumPat GhcPs = EpAnn EpAnnSumPat+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 = EpAnn [AddEpAnn]+type instance XConPat GhcPs = (Maybe (EpToken "{"), Maybe (EpToken "}")) type instance XConPat GhcRn = NoExtField type instance XConPat GhcTc = ConPatTc -type instance XViewPat GhcPs = EpAnn [AddEpAnn]+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.@@ -137,48 +149,133 @@   -- (= the argument type of the view function), for hsPatType.  type instance XSplicePat GhcPs = NoExtField-type instance XSplicePat GhcRn = 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 = EpAnn [AddEpAnn]-type instance XNPat GhcRn = EpAnn [AddEpAnn]+type instance XNPat GhcPs = EpToken "-"+type instance XNPat GhcRn = EpToken "-" type instance XNPat GhcTc = Type -type instance XNPlusKPat GhcPs = EpAnn EpaLocation -- Of the "+"+type instance XNPlusKPat GhcPs = EpToken "+" type instance XNPlusKPat GhcRn = NoExtField type instance XNPlusKPat GhcTc = Type -type instance XSigPat GhcPs = EpAnn [AddEpAnn]+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 HsExpansion].+  -- See Note [Rebindable syntax and XXExprGhcRn]. type instance XXPat GhcTc = XXPatGhcTc-  -- After typechecking, we add extra constructors: CoPat and HsExpansion.-  -- HsExpansion allows us to handle RebindableSyntax in pattern position:+  -- 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 -- IdP GhcPs-type instance ConLikeP GhcRn = Name    -- IdP GhcRn+type instance ConLikeP GhcPs = RdrName          -- IdOccP GhcPs+type instance ConLikeP GhcRn = WithUserRdr Name -- IdOccP GhcRn type instance ConLikeP GhcTc = ConLike -type instance XHsFieldBind _ = EpAnn [AddEpAnn]+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      :: [AddEpAnn]-      , sumPatVbarsBefore :: [EpaLocation]-      , sumPatVbarsAfter  :: [EpaLocation]+      { sumPatParens      :: (EpaLocation, EpaLocation)+      , sumPatVbarsBefore :: [EpToken "|"]+      , sumPatVbarsAfter  :: [EpToken "|"]       } deriving Data +instance NoAnn EpAnnSumPat where+  noAnn = EpAnnSumPat (noAnn, noAnn) [] []+ -- ---------------------------------------------------------------------  -- | Extension constructor for Pat, added after typechecking.@@ -201,11 +298,11 @@       }   -- | Pattern expansion: original pattern, and desugared pattern,   -- for RebindableSyntax and other overloaded syntax such as OverloadedLists.-  -- See Note [Rebindable syntax and HsExpansion].+  -- See Note [Rebindable syntax and XXExprGhcRn].   | ExpansionPat (Pat GhcRn) (Pat GhcTc)  --- See Note [Rebindable syntax and HsExpansion].+-- See Note [Rebindable syntax and XXExprGhcRn]. data HsPatExpansion a b   = HsPatExpanded a b   deriving Data@@ -238,18 +335,18 @@       cpt_wrap  :: HsWrapper     } -hsRecFieldId :: HsRecField GhcTc arg -> Id-hsRecFieldId = hsRecFieldSel -hsRecUpdFieldRdr :: HsRecUpdField (GhcPass p) -> Located RdrName-hsRecUpdFieldRdr = fmap rdrNameAmbiguousFieldOcc . reLoc . hfbLHS+hsRecFields :: HsRecFields (GhcPass p) arg -> [IdGhcP p]+hsRecFields rbinds = Data.List.map (hsRecFieldSel . unLoc) (rec_flds rbinds) -hsRecUpdFieldId :: HsFieldBind (LAmbiguousFieldOcc GhcTc) arg -> Located Id-hsRecUpdFieldId = fmap foExt . reLoc . hsRecUpdFieldOcc+hsRecFieldsArgs :: HsRecFields (GhcPass p) arg -> [arg]+hsRecFieldsArgs rbinds = Data.List.map (hfbRHS . unLoc) (rec_flds rbinds) -hsRecUpdFieldOcc :: HsFieldBind (LAmbiguousFieldOcc GhcTc) arg -> LFieldOcc GhcTc-hsRecUpdFieldOcc = fmap unambiguousFieldOcc . hfbLHS+hsRecFieldSel :: HsRecField (GhcPass p) arg -> IdGhcP p+hsRecFieldSel = unLoc . foLabel . unLoc . hfbLHS +hsRecFieldId :: HsRecField GhcTc arg -> Id+hsRecFieldId = hsRecFieldSel  {- ************************************************************************@@ -259,10 +356,25 @@ ************************************************************************ -} +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 HsExpansion].+-- 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) @@ -310,7 +422,7 @@ pprPat (AsPat _ name pat)       = hcat [pprPrefixOcc (unLoc name), char '@',                                         pprParendLPat appPrec pat] pprPat (ViewPat _ expr pat)     = hcat [pprLExpr expr, text " -> ", ppr pat]-pprPat (ParPat _ _ pat _)      = parens (ppr pat)+pprPat (ParPat _ pat)           = parens (ppr pat) pprPat (LitPat _ s)             = ppr s pprPat (NPat _ l Nothing  _)    = ppr l pprPat (NPat _ l (Just _) _)    = char '-' <> ppr l@@ -319,15 +431,21 @@                   GhcPs -> ppr n                   GhcRn -> ppr n                   GhcTc -> ppr n-pprPat (SplicePat _ splice)     = pprSplice splice+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-    -- `Solo x`, not `(x)`+    -- `MkSolo x`, not `(x)`   | [pat] <- pats   , Boxed <- bx-  = hcat [text (mkTupleStr Boxed 1), pprParendLPat appPrec pat]+  = 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)@@ -352,11 +470,20 @@                        , 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-#if __GLASGOW_HASKELL__ < 811-  GhcPs -> dataConCantHappen ext-#endif   GhcRn -> case ext of     HsPatExpanded orig _ -> pprPat orig   GhcTc -> case ext of@@ -376,8 +503,7 @@ pprConArgs :: (OutputableBndrId p,                      Outputable (Anno (IdGhcP p)))            => HsConPatDetails (GhcPass p) -> SDoc-pprConArgs (PrefixCon ts pats) = fsep (pprTyArgs ts : map (pprParendLPat appPrec) pats)-  where pprTyArgs tyargs = fsep (map (\ty -> char '@' <> ppr ty) tyargs)+pprConArgs (PrefixCon pats)    = fsep (map (pprParendLPat appPrec) pats) pprConArgs (InfixCon p1 p2)    = sep [ pprParendLPat appPrec p1                                      , pprParendLPat appPrec p2 ] pprConArgs (RecCon rpats)      = ppr rpats@@ -395,7 +521,7 @@ -- Make a vanilla Prefix constructor pattern mkPrefixConPat dc pats tys   = noLocA $ ConPat { pat_con = noLocA (RealDataCon dc)-                    , pat_args = PrefixCon [] pats+                    , pat_args = PrefixCon pats                     , pat_con_ext = ConPatTc                       { cpt_tvs = []                       , cpt_dicts = []@@ -448,7 +574,7 @@ isBangedLPat = isBangedPat . unLoc  isBangedPat :: Pat (GhcPass p) -> Bool-isBangedPat (ParPat _ _ p _) = isBangedLPat p+isBangedPat (ParPat _ p) = isBangedLPat p isBangedPat (BangPat {}) = True isBangedPat _            = False @@ -461,7 +587,7 @@ looksLazyPatBind (PatBind { pat_lhs = p })   = looksLazyLPat p looksLazyPatBind (XHsBindsLR (AbsBinds { abs_binds = binds }))-  = anyBag (looksLazyPatBind . unLoc) binds+  = any (looksLazyPatBind . unLoc) binds looksLazyPatBind _   = False @@ -469,30 +595,13 @@ looksLazyLPat = looksLazyPat . unLoc  looksLazyPat :: Pat (GhcPass p) -> Bool-looksLazyPat (ParPat _ _ p _)  = looksLazyLPat p-looksLazyPat (AsPat _ _ p)     = looksLazyLPat p+looksLazyPat (ParPat _ p)  = looksLazyLPat p+looksLazyPat (AsPat _ _ p) = looksLazyLPat p looksLazyPat (BangPat {})  = False looksLazyPat (VarPat {})   = False looksLazyPat (WildPat {})  = False looksLazyPat _             = True -isIrrefutableHsPat :: forall p. (OutputableBndrId p)-                   => DynFlags -> LPat (GhcPass p) -> Bool--- (isIrrefutableHsPat p) is true if matching against p cannot fail,--- in the sense of falling through to the next pattern.---      (NB: this is not quite the same as the (silly) defn---      in 3.17.2 of the Haskell 98 report.)------ WARNING: isIrrefutableHsPat returns False if it's in doubt.--- Specifically on a ConPatIn, which is what it sees for a--- (LPat Name) in the renamer, it doesn't know the size of the--- constructor family, so it returns False.  Result: only--- tuple patterns are considered irrefutable at the renamer stage.------ But if it returns True, the pattern is definitely irrefutable-isIrrefutableHsPat dflags =-    isIrrefutableHsPat' (xopt LangExt.Strict dflags)- {- Note [-XStrict and irrefutability] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -519,43 +628,55 @@ See also Note [decideBangHood] in GHC.HsToCore.Utils. -} -isIrrefutableHsPat' :: forall p. (OutputableBndrId p)-                    => Bool -- ^ Are we in a @-XStrict@ context?-                            -- See Note [-XStrict and irrefutability]-                    -> LPat (GhcPass p) -> Bool-isIrrefutableHsPat' is_strict = goL+-- | @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 :: LPat (GhcPass p) -> Bool-    goL = go . unLoc+    goL (L _ p) = go p      go :: Pat (GhcPass p) -> Bool     go (WildPat {})        = True     go (VarPat {})         = True     go (LazyPat _ p')       | is_strict-      = isIrrefutableHsPat' False p'+      = isIrrefutableHsPat False irref_conLike p'       | otherwise          = True     go (BangPat _ pat)     = goL pat-    go (ParPat _ _ pat _)  = goL pat+    go (ParPat _ pat)      = goL pat     go (AsPat _ _ pat)     = goL pat     go (ViewPat _ _ pat)   = goL pat     go (SigPat _ pat _)    = goL pat     go (TuplePat _ pats _) = all goL pats-    go (SumPat {})         = False-                    -- See Note [Unboxed sum patterns aren't irrefutable]+    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 -    go (ConPat-        { pat_con  = con-        , pat_args = details })-                           = case ghcPass @p of-       GhcPs -> False -- Conservative-       GhcRn -> False -- Conservative-       GhcTc -> case con of-         L _ (PatSynCon _pat)  -> False -- Conservative-         L _ (RealDataCon con) ->-           isJust (tyConSingleDataCon_maybe (dataConTyCon con))-           && all goL (hsConPatArgs details)+    -- 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@@ -564,10 +685,12 @@     -- 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-#if __GLASGOW_HASKELL__ < 811-      GhcPs -> dataConCantHappen ext-#endif       GhcRn -> case ext of         HsPatExpanded _ pat -> go pat       GhcTc -> case ext of@@ -583,16 +706,157 @@ -- - x (variable) isSimplePat :: LPat (GhcPass x) -> Maybe (IdP (GhcPass x)) isSimplePat p = case unLoc p of-  ParPat _ _ x _ -> isSimplePat x+  ParPat _ x -> isSimplePat x   SigPat _ x _ -> isSimplePat x   LazyPat _ x -> isSimplePat x   BangPat _ x -> isSimplePat x   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 -{- Note [Unboxed sum patterns aren't irrefutable]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+    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: @@ -611,8 +875,182 @@ 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@@ -622,15 +1060,15 @@     -- 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-#if __GLASGOW_HASKELL__ < 901-      GhcPs -> dataConCantHappen ext-#endif       GhcRn -> case ext of         HsPatExpanded orig _ -> go orig       GhcTc -> case ext of@@ -657,17 +1095,22 @@  -- | @'conPatNeedsParens' p cp@ returns 'True' if the constructor patterns @cp@ -- needs parentheses under precedence @p@.-conPatNeedsParens :: PprPrec -> HsConDetails t a b -> Bool+conPatNeedsParens :: PprPrec -> HsConDetails a b -> Bool conPatNeedsParens p = go   where-    go (PrefixCon ts args) = p >= appPrec && (not (null args) || not (null ts))-    go (InfixCon {})       = p >= opPrec -- type args should be empty in this case-    go (RecCon {})         = False+    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 :: LPat (GhcPass pass) -> Pat (GhcPass pass)-gParPat p = ParPat noAnn noHsTok p noHsTok+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@.@@ -679,6 +1122,7 @@   | patNeedsParens p pat = L loc (gParPat lpat)   | otherwise            = lpat + {- % Collect all EvVars from all constructor patterns -}@@ -695,10 +1139,11 @@   case pat of     LazyPat _ p      -> collectEvVarsLPat p     AsPat _ _ p      -> collectEvVarsLPat p-    ParPat  _ _ p _  -> collectEvVarsLPat p+    ParPat  _ p      -> collectEvVarsLPat p     BangPat _ p      -> collectEvVarsLPat p     ListPat _ ps     -> unionManyBags $ map collectEvVarsLPat ps     TuplePat _ ps _  -> unionManyBags $ map collectEvVarsLPat ps+    OrPat _ ps       -> unionManyBags $ map collectEvVarsLPat (NE.toList ps)     SumPat _ p _ _   -> collectEvVarsLPat p     ConPat       { pat_args  = args@@ -725,6 +1170,7 @@ -}  type instance Anno (Pat (GhcPass p)) = SrcSpanAnnA-type instance Anno (HsOverLit (GhcPass p)) = SrcAnn NoEpAnns+type instance Anno (HsOverLit (GhcPass p)) = EpAnnCO type instance Anno ConLike = SrcSpanAnnN type instance Anno (HsFieldBind lhs rhs) = SrcSpanAnnA+type instance Anno RecFieldsDotDot = EpaLocation
+ GHC/Hs/Specificity.hs view
@@ -0,0 +1,51 @@+{-# OPTIONS_GHC -Wno-orphans #-}+module GHC.Hs.Specificity where++import Prelude+import Control.DeepSeq (NFData(..))++import GHC.Utils.Outputable+import GHC.Utils.Binary++import Language.Haskell.Syntax.Specificity++{- *********************************************************************+*                                                                      *+*                   ForAllTyFlag+*                                                                      *+********************************************************************* -}++instance Outputable ForAllTyFlag where+  ppr Required  = text "[req]"+  ppr Specified = text "[spec]"+  ppr Inferred  = text "[infrd]"++instance Binary Specificity where+  put_ bh SpecifiedSpec = putByte bh 0+  put_ bh InferredSpec  = putByte bh 1++  get bh = do+    h <- getByte bh+    case h of+      0 -> return SpecifiedSpec+      _ -> return InferredSpec++instance Binary ForAllTyFlag where+  put_ bh Required  = putByte bh 0+  put_ bh Specified = putByte bh 1+  put_ bh Inferred  = putByte bh 2++  get bh = do+    h <- getByte bh+    case h of+      0 -> return Required+      1 -> return Specified+      _ -> return Inferred++instance NFData Specificity where+  rnf SpecifiedSpec = ()+  rnf InferredSpec = ()+instance NFData ForAllTyFlag where+  rnf (Invisible spec) = rnf spec+  rnf Required = ()+
GHC/Hs/Stats.hs view
@@ -11,7 +11,6 @@  import GHC.Prelude -import GHC.Data.Bag import GHC.Hs import GHC.Types.SrcLoc @@ -22,7 +21,7 @@ import Data.Char  -- | Source Statistics-ppSourceStats :: Bool -> Located HsModule -> SDoc+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@@ -116,13 +115,14 @@     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, ideclHiding = spec }))+                                 , 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@@ -132,12 +132,11 @@     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)+    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 = HsDataDefn-                                          { dd_cons = cs-                                          , dd_derivs = derivs}})+    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 )@@ -146,7 +145,7 @@     class_info decl@(ClassDecl {})         = (classops, addpr (sum3 (map count_bind methods)))       where-        methods = map unLoc $ bagToList (tcdMeths decl)+        methods = map unLoc $ tcdMeths decl         (_, classops, _, _, _) = count_sigs (map unLoc (tcdSigs decl))     class_info _ = (0,0) @@ -162,7 +161,7 @@                   (addpr (sum3 (map count_bind methods)),                    ss, is, length ats, length adts)       where-        methods = map unLoc $ bagToList inst_meths+        methods = map unLoc inst_meths      -- TODO: use Sum monoid     addpr :: (Int,Int,Int) -> Int
GHC/Hs/Syn/Type.hs view
@@ -7,8 +7,7 @@     -- * Extracting types from HsExpr     lhsExprType, hsExprType, hsWrapperType,     -- * Extracting types from HsSyn-    hsLitType, hsPatType, hsLPatType-+    hsLitType, hsPatType, hsLPatType,   ) where  import GHC.Prelude@@ -21,10 +20,10 @@ import GHC.Core.PatSyn import GHC.Core.TyCo.Rep import GHC.Core.Type-import GHC.Core.Utils import GHC.Hs import GHC.Tc.Types.Evidence import GHC.Types.Id+import GHC.Types.Var( VarBndr(..) ) import GHC.Types.SrcLoc import GHC.Utils.Outputable import GHC.Utils.Panic@@ -42,7 +41,7 @@ hsLPatType (L _ p) = hsPatType p  hsPatType :: Pat GhcTc -> Type-hsPatType (ParPat _ _ pat _)            = hsLPatType pat+hsPatType (ParPat _ pat)                = hsLPatType pat hsPatType (WildPat ty)                  = ty hsPatType (VarPat _ lvar)               = idType (unLoc lvar) hsPatType (BangPat _ pat)               = hsLPatType pat@@ -51,6 +50,7 @@ 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@@ -63,26 +63,37 @@ 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 :: HsLit (GhcPass p) -> Type+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 (HsInteger _ _ ty) = ty-hsLitType (HsRat _ _ ty)     = ty 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.@@ -92,19 +103,16 @@ -- | Compute the 'Type' of an @'HsExpr' 'GhcTc'@ in a pure fashion. hsExprType :: HsExpr GhcTc -> Type hsExprType (HsVar _ (L _ id)) = idType id-hsExprType (HsUnboundVar (HER _ ty _) _) = ty-hsExprType (HsRecSel _ (FieldOcc id _)) = idType id hsExprType (HsOverLabel v _) = dataConCantHappen v hsExprType (HsIPVar v _) = dataConCantHappen v hsExprType (HsOverLit _ lit) = overLitType lit hsExprType (HsLit _ lit) = hsLitType lit-hsExprType (HsLam     _ (MG { mg_ext = match_group })) = matchGroupTcType match_group-hsExprType (HsLamCase _ _ (MG { mg_ext = match_group })) = matchGroupTcType match_group+hsExprType (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 (HsPar _ e) = lhsExprType e hsExprType (SectionL v _ _) = dataConCantHappen v hsExprType (SectionR v _ _) = dataConCantHappen v hsExprType (ExplicitTuple _ args box) = mkTupleTy box $ map hsTupArgType args@@ -112,15 +120,11 @@ 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 (HsLet _ _ body) = lhsExprType body hsExprType (HsDo ty _ _) = ty hsExprType (ExplicitList ty _) = mkListTy ty hsExprType (RecordCon con_expr _ _) = hsExprType con_expr-hsExprType e@(RecordUpd (RecordUpdTc { rupd_cons = cons, rupd_out_tys = out_tys }) _ _) =-  case cons of-    con_like:_ -> conLikeResTy con_like out_tys-    []         -> pprPanic "hsExprType: RecordUpdTc with empty rupd_cons"-                           (ppr e)+hsExprType (RecordUpd v _ _) = dataConCantHappen v hsExprType (HsGetField { gf_ext = v }) = dataConCantHappen v hsExprType (HsProjection { proj_ext = v }) = dataConCantHappen v hsExprType (ExprWithTySig _ e _) = lhsExprType e@@ -129,21 +133,28 @@   Nothing -> asi_ty   where     asi_ty = arithSeqInfoType asi-hsExprType (HsTypedBracket   (HsBracketTc _ ty _wrap _pending) _) = ty-hsExprType (HsUntypedBracket (HsBracketTc _ ty _wrap _pending) _) = ty-hsExprType e@(HsSpliceE{}) = pprPanic "hsExprType: Unexpected HsSpliceE"-                                      (ppr e)+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 (XExpr (WrapExpr (HsWrap wrap e))) = hsWrapperType wrap $ hsExprType e-hsExprType (XExpr (ExpansionExpr (HsExpanded _ tc_e))) = hsExprType tc_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@@ -185,18 +196,17 @@           exp_res = hsWrapperType w2 act_res       in mkFunctionType m exp_arg exp_res     go (WpCast co)        = liftPRType $ \_ -> coercionRKind co-    go (WpEvLam v)        = liftPRType $ mkInvisFunTyMany (idType v)+    go (WpEvLam v)        = liftPRType $ mkInvisFunTy (idType v)     go (WpEvApp _)        = liftPRType $ funResultTy-    go (WpTyLam tv)       = liftPRType $ mkForAllTy tv Inferred+    go (WpTyLam tv)       = liftPRType $ mkForAllTy (Bndr tv Inferred)     go (WpTyApp ta)       = \(ty,tas) -> (ty, ta:tas)     go (WpLet _)          = id-    go (WpMultCoercion _) = id  lhsCmdTopType :: LHsCmdTop GhcTc -> Type lhsCmdTopType (L _ (HsCmdTop (CmdTopTc _ ret_ty _) _)) = ret_ty  matchGroupTcType :: MatchGroupTc -> Type-matchGroupTcType (MatchGroupTc args res) = mkVisFunTys args res+matchGroupTcType (MatchGroupTc args res _) = mkScaledFunTys args res  syntaxExprType :: SyntaxExpr GhcTc -> Type syntaxExprType (SyntaxExprTc e _ _) = hsExprType e
GHC/Hs/Type.hs view
@@ -1,1220 +1,1653 @@  {-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# 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, HsScaled(..),-        hsMult, hsScaledThing,-        HsArrow(..), arrowToHsType,-        HsLinearArrowTokens(..),-        hsLinear, hsUnrestricted, isUnrestricted,-        pprHsArrow,--        HsType(..), HsCoreTy, LHsType, HsKind, LHsKind,-        HsForAllTelescope(..), EpAnnForallTy, HsTyVarBndr(..), LHsTyVarBndr,-        LHsQTyVars(..),-        HsOuterTyVarBndrs(..), HsOuterFamEqnTyVarBndrs, HsOuterSigTyVarBndrs,-        HsWildCardBndrs(..),-        HsPatSigType(..), HsPSRn(..),-        HsSigType(..), LHsSigType, LHsSigWcType, LHsWcType,-        HsTupleSort(..),-        HsContext, LHsContext, fromMaybeContext,-        HsTyLit(..),-        HsIPName(..), hsIPNameFS,-        HsArg(..), numVisibleArgs, pprHsArgsApp,-        LHsTypeArg, lhsTypeArgSrcSpan,-        OutputableBndrFlag,--        LBangType, BangType,-        HsSrcBang(..), HsImplBang(..),-        SrcStrictness(..), SrcUnpackedness(..),-        getBangType, getBangStrictness,--        ConDeclField(..), LConDeclField, pprConDeclFields,--        HsConDetails(..), noTypeArgs,--        FieldOcc(..), LFieldOcc, mkFieldOcc,-        AmbiguousFieldOcc(..), LAmbiguousFieldOcc, mkAmbiguousFieldOcc,-        rdrNameAmbiguousFieldOcc, selectorAmbiguousFieldOcc,-        unambiguousFieldOcc, ambiguousFieldOcc,--        mkAnonWildCardTy, pprAnonWildCard,--        hsOuterTyVarNames, hsOuterExplicitBndrs, mapHsOuterImplicit,-        mkHsOuterImplicit, mkHsOuterExplicit,-        mkHsImplicitSigType, mkHsExplicitSigType,-        mkHsWildCardBndrs, mkHsPatSigType,-        mkEmptyWildCardBndrs,-        mkHsForAllVisTele, mkHsForAllInvisTele,-        mkHsQTvs, hsQTvExplicit, emptyLHsQTvs,-        isHsKindedTyVar, hsTvbAllKinded,-        hsScopedTvs, hsWcScopedTvs, dropWildCards,-        hsTyVarName, hsAllLTyVarNames, hsLTyVarLocNames,-        hsLTyVarName, hsLTyVarNames, 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,--        -- Printing-        pprHsType, pprHsForAll,-        pprHsOuterFamEqnTyVarBndrs, pprHsOuterSigTyVarBndrs,-        pprLHsContext,-        hsTypeNeedsParens, parenthesizeHsType, parenthesizeHsContext-    ) where--import GHC.Prelude--import Language.Haskell.Syntax.Type--import {-# SOURCE #-} GHC.Hs.Expr ( pprSplice )--import Language.Haskell.Syntax.Extension-import GHC.Hs.Extension-import GHC.Parser.Annotation--import GHC.Types.Fixity ( LexicalFixity(..) )-import GHC.Types.Id ( Id )-import GHC.Types.SourceText-import GHC.Types.Name( Name, NamedThing(getName) )-import GHC.Types.Name.Reader ( RdrName )-import GHC.Types.Var ( VarBndr )-import GHC.Core.TyCo.Rep ( Type(..) )-import GHC.Builtin.Types( manyDataConName, oneDataConName, mkTupleStr )-import GHC.Core.Ppr ( pprOccWithTick)-import GHC.Core.Type-import GHC.Hs.Doc-import GHC.Types.Basic-import GHC.Types.SrcLoc-import GHC.Utils.Outputable--import Data.Maybe--import qualified Data.Semigroup as S--{--************************************************************************-*                                                                      *-\subsection{Bang annotations}-*                                                                      *-************************************************************************--}--getBangType :: LHsType (GhcPass p) -> LHsType (GhcPass p)-getBangType                 (L _ (HsBangTy _ _ lty))       = lty-getBangType (L _ (HsDocTy x (L _ (HsBangTy _ _ lty)) lds)) =-  addCLocA lty lds (HsDocTy x lty lds)-getBangType lty                                            = lty--getBangStrictness :: LHsType (GhcPass p) -> HsSrcBang-getBangStrictness                 (L _ (HsBangTy _ s _))     = s-getBangStrictness (L _ (HsDocTy _ (L _ (HsBangTy _ s _)) _)) = s-getBangStrictness _ = (HsSrcBang NoSourceText NoSrcUnpack NoSrcStrict)--{--************************************************************************-*                                                                      *-\subsection{Data types}-*                                                                      *-************************************************************************--}--fromMaybeContext :: Maybe (LHsContext (GhcPass p)) -> HsContext (GhcPass p)-fromMaybeContext mctxt = unLoc $ fromMaybe (noLocA []) mctxt--type instance XHsForAllVis   (GhcPass _) = EpAnnForallTy-                                           -- Location of 'forall' and '->'-type instance XHsForAllInvis (GhcPass _) = EpAnnForallTy-                                           -- Location of 'forall' and '.'--type instance XXHsForAllTelescope (GhcPass _) = DataConCantHappen--type EpAnnForallTy = EpAnn (AddEpAnn, AddEpAnn)-  -- ^ Location of 'forall' and '->' for HsForAllVis-  -- Location of 'forall' and '.' for HsForAllInvis--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 ::EpAnnForallTy ->-  [LHsTyVarBndr () (GhcPass p)] -> HsForAllTelescope (GhcPass p)-mkHsForAllVisTele an vis_bndrs =-  HsForAllVis { hsf_xvis = an, hsf_vis_bndrs = vis_bndrs }--mkHsForAllInvisTele :: EpAnnForallTy-  -> [LHsTyVarBndr Specificity (GhcPass p)] -> HsForAllTelescope (GhcPass p)-mkHsForAllInvisTele an invis_bndrs =-  HsForAllInvis { hsf_xinvis = an, hsf_invis_bndrs = invis_bndrs }--mkHsQTvs :: [LHsTyVarBndr () 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 _    = EpAnnForallTy-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 = EpAnn EpaLocation-type instance XHsPS GhcRn = HsPSRn-type instance XHsPS GhcTc = HsPSRn--type instance XXHsPatSigType (GhcPass _) = DataConCantHappen--type instance XHsSig (GhcPass _) = NoExtField-type instance XXHsSigType (GhcPass _) = DataConCantHappen--hsSigWcType :: forall p. UnXRec p => LHsSigWcType p -> LHsType p-hsSigWcType = sig_body . unXRec @p . hswc_body--dropWildCards :: LHsSigWcType pass -> LHsSigType pass--- 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 :: EpAnnForallTy -> [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 :: EpAnnForallTy-                    -> [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 :: EpAnn EpaLocation -> LHsType GhcPs -> HsPatSigType GhcPs-mkHsPatSigType ann x = HsPS { hsps_ext  = ann-                            , hsps_body = x }--mkEmptyWildCardBndrs :: thing -> HsWildCardBndrs GhcRn thing-mkEmptyWildCardBndrs x = HsWC { hswc_body = x-                              , hswc_ext  = [] }------------------------------------------------------type instance XUserTyVar    (GhcPass _) = EpAnn [AddEpAnn]-type instance XKindedTyVar  (GhcPass _) = EpAnn [AddEpAnn]--type instance XXTyVarBndr   (GhcPass _) = DataConCantHappen---- | Return the attached flag-hsTyVarBndrFlag :: HsTyVarBndr flag (GhcPass pass) -> flag-hsTyVarBndrFlag (UserTyVar _ fl _)     = fl-hsTyVarBndrFlag (KindedTyVar _ fl _ _) = fl---- | Set the attached flag-setHsTyVarBndrFlag :: flag -> HsTyVarBndr flag' (GhcPass pass)-  -> HsTyVarBndr flag (GhcPass pass)-setHsTyVarBndrFlag f (UserTyVar x _ l)     = UserTyVar x f l-setHsTyVarBndrFlag f (KindedTyVar x _ l k) = KindedTyVar x f l k---- | Do all type variables in this 'LHsQTyVars' come with kind annotations?-hsTvbAllKinded :: LHsQTyVars (GhcPass p) -> Bool-hsTvbAllKinded = all (isHsKindedTyVar . unLoc) . hsQTvExplicit--instance NamedThing (HsTyVarBndr flag GhcRn) where-  getName (UserTyVar _ _ v) = unLoc v-  getName (KindedTyVar _ _ v _) = unLoc v--type instance XForAllTy        (GhcPass _) = NoExtField-type instance XQualTy          (GhcPass _) = NoExtField-type instance XTyVar           (GhcPass _) = EpAnn [AddEpAnn]-type instance XAppTy           (GhcPass _) = NoExtField-type instance XFunTy           (GhcPass _) = EpAnnCO-type instance XListTy          (GhcPass _) = EpAnn AnnParen-type instance XTupleTy         (GhcPass _) = EpAnn AnnParen-type instance XSumTy           (GhcPass _) = EpAnn AnnParen-type instance XOpTy            (GhcPass _) = EpAnn [AddEpAnn]-type instance XParTy           (GhcPass _) = EpAnn AnnParen-type instance XIParamTy        (GhcPass _) = EpAnn [AddEpAnn]-type instance XStarTy          (GhcPass _) = NoExtField-type instance XKindSig         (GhcPass _) = EpAnn [AddEpAnn]--type instance XAppKindTy       (GhcPass _) = SrcSpan -- Where the `@` lives--type instance XSpliceTy        GhcPs = NoExtField-type instance XSpliceTy        GhcRn = NoExtField-type instance XSpliceTy        GhcTc = Kind--type instance XDocTy           (GhcPass _) = EpAnn [AddEpAnn]-type instance XBangTy          (GhcPass _) = EpAnn [AddEpAnn]--type instance XRecTy           GhcPs = EpAnn AnnList-type instance XRecTy           GhcRn = NoExtField-type instance XRecTy           GhcTc = NoExtField--type instance XExplicitListTy  GhcPs = EpAnn [AddEpAnn]-type instance XExplicitListTy  GhcRn = NoExtField-type instance XExplicitListTy  GhcTc = Kind--type instance XExplicitTupleTy GhcPs = EpAnn [AddEpAnn]-type instance XExplicitTupleTy GhcRn = NoExtField-type instance XExplicitTupleTy GhcTc = [Kind]--type instance XTyLit           (GhcPass _) = NoExtField--type instance XWildCardTy      (GhcPass _) = NoExtField--type instance XXType         (GhcPass _) = HsCoreTy---oneDataConHsTy :: HsType GhcRn-oneDataConHsTy = HsTyVar noAnn NotPromoted (noLocA oneDataConName)--manyDataConHsTy :: HsType GhcRn-manyDataConHsTy = HsTyVar noAnn NotPromoted (noLocA manyDataConName)--hsLinear :: a -> HsScaled (GhcPass p) a-hsLinear = HsScaled (HsLinearArrow (HsPct1 noHsTok noHsUniTok))--hsUnrestricted :: a -> HsScaled (GhcPass p) a-hsUnrestricted = HsScaled (HsUnrestrictedArrow noHsUniTok)--isUnrestricted :: HsArrow GhcRn -> Bool-isUnrestricted (arrowToHsType -> L _ (HsTyVar _ _ (L _ n))) = n == manyDataConName-isUnrestricted _ = False---- | Convert an arrow into its corresponding multiplicity. In essence this--- erases the information of whether the programmer wrote an explicit--- multiplicity or a shorthand.-arrowToHsType :: HsArrow GhcRn -> LHsType GhcRn-arrowToHsType (HsUnrestrictedArrow _) = noLocA manyDataConHsTy-arrowToHsType (HsLinearArrow _) = noLocA oneDataConHsTy-arrowToHsType (HsExplicitMult _ p _) = p--instance-      (OutputableBndrId pass) =>-      Outputable (HsArrow (GhcPass pass)) where-  ppr arr = parens (pprHsArrow arr)---- See #18846-pprHsArrow :: (OutputableBndrId pass) => HsArrow (GhcPass pass) -> SDoc-pprHsArrow (HsUnrestrictedArrow _) = arrow-pprHsArrow (HsLinearArrow _) = lollipop-pprHsArrow (HsExplicitMult _ p _) = mulArrow (ppr p)--type instance XConDeclField  (GhcPass _) = EpAnn [AddEpAnn]-type instance XXConDeclField (GhcPass _) = DataConCantHappen--instance OutputableBndrId p-       => Outputable (ConDeclField (GhcPass p)) where-  ppr (ConDeclField _ fld_n fld_ty _) = ppr fld_n <+> dcolon <+> ppr fld_ty------------------------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]------------------------hsTyVarName :: HsTyVarBndr flag (GhcPass p) -> IdP (GhcPass p)-hsTyVarName (UserTyVar _ _ (L _ n))     = n-hsTyVarName (KindedTyVar _ _ (L _ n) _) = n--hsLTyVarName :: LHsTyVarBndr flag (GhcPass p) -> IdP (GhcPass p)-hsLTyVarName = hsTyVarName . unLoc--hsLTyVarNames :: [LHsTyVarBndr flag (GhcPass p)] -> [IdP (GhcPass p)]-hsLTyVarNames = map hsLTyVarName--hsExplicitLTyVarNames :: LHsQTyVars (GhcPass p) -> [IdP (GhcPass p)]--- Explicit variables only-hsExplicitLTyVarNames qtvs = map hsLTyVarName (hsQTvExplicit qtvs)--hsAllLTyVarNames :: LHsQTyVars GhcRn -> [Name]--- All variables-hsAllLTyVarNames (HsQTvs { hsq_ext = kvs-                         , hsq_explicit = tvs })-  = kvs ++ hsLTyVarNames tvs--hsLTyVarLocName :: LHsTyVarBndr flag (GhcPass p) -> LocatedN (IdP (GhcPass p))-hsLTyVarLocName (L l a) = L (l2l l) (hsTyVarName a)--hsLTyVarLocNames :: LHsQTyVars (GhcPass p) -> [LocatedN (IdP (GhcPass p))]-hsLTyVarLocNames qtvs = map 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 :: HsType GhcPs-mkAnonWildCardTy = HsWildCardTy noExtField--mkHsOpTy :: (Anno (IdGhcP p) ~ SrcSpanAnnN)-         => PromotionFlag-         -> LHsType (GhcPass p) -> LocatedN (IdP (GhcPass p))-         -> LHsType (GhcPass p) -> HsType (GhcPass p)-mkHsOpTy prom ty1 op ty2 = HsOpTy noAnn prom ty1 op ty2--mkHsAppTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)-mkHsAppTy t1 t2-  = addCLocAA t1 t2 (HsAppTy noExtField t1 (parenthesizeHsType appPrec t2))--mkHsAppTys :: LHsType (GhcPass p) -> [LHsType (GhcPass p)]-           -> LHsType (GhcPass p)-mkHsAppTys = foldl' mkHsAppTy--mkHsAppKindTy :: XAppKindTy (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)-              -> LHsType (GhcPass p)-mkHsAppKindTy ext ty k-  = addCLocAA ty k (HsAppKindTy ext ty k)--{--************************************************************************-*                                                                      *-                Decomposing HsTypes-*                                                                      *-************************************************************************--}-------------------------------------- splitHsFunType decomposes a type (t1 -> t2 ... -> tn)--- Breaks up any parens in the result type:---      splitHsFunType (a -> (b -> c)) = ([a,b], c)--- It returns API Annotations for any parens removed-splitHsFunType ::-     LHsType (GhcPass p)-  -> ( [AddEpAnn], EpAnnComments -- The locations of any parens and-                                  -- comments discarded-     , [HsScaled (GhcPass p) (LHsType (GhcPass p))], LHsType (GhcPass p))-splitHsFunType ty = go ty-  where-    go (L l (HsParTy an ty))-      = let-          (anns, cs, args, res) = splitHsFunType ty-          anns' = anns ++ annParen2AddEpAnn an-          cs' = cs S.<> epAnnComments (ann l) S.<> epAnnComments an-        in (anns', cs', args, res)--    go (L ll (HsFunTy (EpAnn _ _ cs) mult x y))-      | (anns, csy, args, res) <- splitHsFunType y-      = (anns, csy S.<> epAnnComments (ann ll), HsScaled mult x':args, res)-      where-        L l t = x-        x' = L (addCommentsToSrcAnn l cs) t--    go other = ([], 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 (IdGhcP p) ~ SrcSpanAnnN)-                     => LHsType (GhcPass p)-                     -> Maybe (LocatedN (IdP (GhcPass p)))-hsTyGetAppHead_maybe = go-  where-    go (L _ (HsTyVar _ _ ln))          = Just ln-    go (L _ (HsAppTy _ l _))           = go l-    go (L _ (HsAppKindTy _ t _))       = go t-    go (L _ (HsOpTy _ _ _ ln _))       = Just ln-    go (L _ (HsParTy _ t))             = go t-    go (L _ (HsKindSig _ t _))         = go t-    go _                               = Nothing------------------------------------------------------------------ | Compute the 'SrcSpan' associated with an 'LHsTypeArg'.-lhsTypeArgSrcSpan :: LHsTypeArg (GhcPass pass) -> SrcSpan-lhsTypeArgSrcSpan arg = case arg of-  HsValArg  tm    -> getLocA tm-  HsTypeArg at ty -> at `combineSrcSpans` getLocA ty-  HsArgPar  sp    -> 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-    ((_an, exis), ty3) = splitLHsForAllTyInvis ty2-    (provs,       ty4) = splitLHsQualTy ty3---- | Decompose a sigma type (of the form @forall <tvs>. context => body@)--- into its constituent parts.--- Only splits type variable binders that were--- quantified invisibly (e.g., @forall a.@, with a dot).------ This function is used to split apart certain types, such as instance--- declaration types, which disallow visible @forall@s. For instance, if GHC--- split apart the @forall@ in @instance forall a -> Show (Blah a)@, then that--- declaration would mistakenly be accepted!------ Note that this function looks through parentheses, so it will work on types--- such as @(forall a. <...>)@. The downside to this is that it is not--- generally possible to take the returned types and reconstruct the original--- type (parentheses and all) from them.-splitLHsSigmaTyInvis :: LHsType (GhcPass p)-                     -> ([LHsTyVarBndr Specificity (GhcPass p)]-                        , Maybe (LHsContext (GhcPass p)), LHsType (GhcPass p))-splitLHsSigmaTyInvis ty-  | ((_an,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, Maybe (LHsContext GhcPs), LHsType GhcPs)-splitLHsGadtTy (L _ sig_ty)-  | (outer_bndrs, rho_ty) <- split_bndrs sig_ty-  , (mb_ctxt, tau_ty)     <- splitLHsQualTy_KP rho_ty-  = (outer_bndrs, mb_ctxt, tau_ty)-  where-    split_bndrs :: HsSigType GhcPs -> (HsOuterSigTyVarBndrs GhcPs, LHsType GhcPs)-    split_bndrs (HsSig{sig_bndrs = outer_bndrs, sig_body = body_ty}) =-      (outer_bndrs, body_ty)---- | Decompose a type of the form @forall <tvs>. body@ into its constituent--- parts. Only splits type variable binders that--- were quantified invisibly (e.g., @forall a.@, with a dot).------ This function is used to split apart certain types, such as instance--- declaration types, which disallow visible @forall@s. For instance, if GHC--- split apart the @forall@ in @instance forall a -> Show (Blah a)@, then that--- declaration would mistakenly be accepted!------ Note that this function looks through parentheses, so it will work on types--- such as @(forall a. <...>)@. The downside to this is that it is not--- generally possible to take the returned types and reconstruct the original--- type (parentheses and all) from them.--- Unlike 'splitLHsSigmaTyInvis', this function does not look through--- parentheses, hence the suffix @_KP@ (short for \"Keep Parentheses\").-splitLHsForAllTyInvis ::-  LHsType (GhcPass pass) -> ( (EpAnnForallTy, [LHsTyVarBndr Specificity (GhcPass pass)])-                            , LHsType (GhcPass pass))-splitLHsForAllTyInvis ty-  | ((mb_tvbs), body) <- splitLHsForAllTyInvis_KP (ignoreParens ty)-  = (fromMaybe (EpAnnNotUsed,[]) mb_tvbs, body)---- | Decompose a type of the form @forall <tvs>. body@ into its constituent--- parts. Only splits type variable binders that--- were quantified invisibly (e.g., @forall a.@, with a dot).------ This function is used to split apart certain types, such as instance--- declaration types, which disallow visible @forall@s. For instance, if GHC--- split apart the @forall@ in @instance forall a -> Show (Blah a)@, then that--- declaration would mistakenly be accepted!------ Unlike 'splitLHsForAllTyInvis', this function does not look through--- parentheses, hence the suffix @_KP@ (short for \"Keep Parentheses\").-splitLHsForAllTyInvis_KP ::-  LHsType (GhcPass pass) -> (Maybe (EpAnnForallTy, [LHsTyVarBndr Specificity (GhcPass pass)])-                            , LHsType (GhcPass pass))-splitLHsForAllTyInvis_KP lty@(L _ ty) =-  case ty of-    HsForAllTy { hst_tele = HsForAllInvis { hsf_xinvis = an-                                          , hsf_invis_bndrs = tvs }-               , hst_body = body }-      -> (Just (an, tvs), body)-    _ -> (Nothing, lty)---- | Decompose a type of the form @context => body@ into its constituent parts.------ Note that this function looks through parentheses, so it will work on types--- such as @(context => <...>)@. The downside to this is that it is not--- generally possible to take the returned types and reconstruct the original--- type (parentheses and all) from them.-splitLHsQualTy :: LHsType (GhcPass pass)-               -> (Maybe (LHsContext (GhcPass pass)), LHsType (GhcPass pass))-splitLHsQualTy ty-  | (mb_ctxt, body) <- splitLHsQualTy_KP (ignoreParens ty)-  = (mb_ctxt, body)---- | Decompose a type of the form @context => body@ into its constituent parts.------ Unlike 'splitLHsQualTy', this function does not look through--- parentheses, hence the suffix @_KP@ (short for \"Keep Parentheses\").-splitLHsQualTy_KP :: LHsType (GhcPass pass) -> (Maybe (LHsContext (GhcPass pass)), LHsType (GhcPass pass))-splitLHsQualTy_KP (L _ (HsQualTy { hst_ctxt = ctxt, hst_body = body }))-                       = (Just ctxt, body)-splitLHsQualTy_KP body = (Nothing, body)---- | Decompose a type class instance type (of the form--- @forall <tvs>. context => instance_head@) into its constituent parts.--- Note that the @[Name]@s returned correspond to either:------ * The implicitly bound type variables (if the type lacks an outermost---   @forall@), or------ * The explicitly bound type variables (if the type has an outermost---   @forall@).------ This function is careful not to look through parentheses.--- See @Note [No nested foralls or contexts in instance types]@--- for why this is important.-splitLHsInstDeclTy :: LHsSigType GhcRn-                   -> ([Name], Maybe (LHsContext GhcRn), LHsType GhcRn)-splitLHsInstDeclTy (L _ (HsSig{sig_bndrs = outer_bndrs, sig_body = inst_ty})) =-  (hsOuterTyVarNames outer_bndrs, mb_cxt, body_ty)-  where-    (mb_cxt, body_ty) = splitLHsQualTy_KP inst_ty---- | Decompose a type class instance type (of the form--- @forall <tvs>. context => instance_head@) into the @instance_head@.-getLHsInstDeclHead :: LHsSigType (GhcPass p) -> LHsType (GhcPass p)-getLHsInstDeclHead (L _ (HsSig{sig_body = qual_ty}))-  | (_mb_cxt, body_ty) <- splitLHsQualTy_KP qual_ty-  = body_ty---- | Decompose a type class instance type (of the form--- @forall <tvs>. context => instance_head@) into the @instance_head@ and--- retrieve the underlying class type constructor (if it exists).-getLHsInstDeclClass_maybe :: (Anno (IdGhcP p) ~ SrcSpanAnnN)-                          => LHsSigType (GhcPass p)-                          -> Maybe (LocatedN (IdP (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-*                                                                      *-************************************************************************--}--type instance XCFieldOcc GhcPs = NoExtField-type instance XCFieldOcc GhcRn = Name-type instance XCFieldOcc GhcTc = Id--type instance XXFieldOcc (GhcPass _) = DataConCantHappen--mkFieldOcc :: LocatedN RdrName -> FieldOcc GhcPs-mkFieldOcc rdr = FieldOcc noExtField rdr---type instance XUnambiguous GhcPs = NoExtField-type instance XUnambiguous GhcRn = Name-type instance XUnambiguous GhcTc = Id--type instance XAmbiguous GhcPs = NoExtField-type instance XAmbiguous GhcRn = NoExtField-type instance XAmbiguous GhcTc = Id--type instance XXAmbiguousFieldOcc (GhcPass _) = DataConCantHappen--instance Outputable (AmbiguousFieldOcc (GhcPass p)) where-  ppr = ppr . rdrNameAmbiguousFieldOcc--instance OutputableBndr (AmbiguousFieldOcc (GhcPass p)) where-  pprInfixOcc  = pprInfixOcc . rdrNameAmbiguousFieldOcc-  pprPrefixOcc = pprPrefixOcc . rdrNameAmbiguousFieldOcc--instance OutputableBndr (Located (AmbiguousFieldOcc (GhcPass p))) where-  pprInfixOcc  = pprInfixOcc . unLoc-  pprPrefixOcc = pprPrefixOcc . unLoc--mkAmbiguousFieldOcc :: LocatedN RdrName -> AmbiguousFieldOcc GhcPs-mkAmbiguousFieldOcc rdr = Unambiguous noExtField rdr--rdrNameAmbiguousFieldOcc :: AmbiguousFieldOcc (GhcPass p) -> RdrName-rdrNameAmbiguousFieldOcc (Unambiguous _ (L _ rdr)) = rdr-rdrNameAmbiguousFieldOcc (Ambiguous   _ (L _ rdr)) = rdr--selectorAmbiguousFieldOcc :: AmbiguousFieldOcc GhcTc -> Id-selectorAmbiguousFieldOcc (Unambiguous sel _) = sel-selectorAmbiguousFieldOcc (Ambiguous   sel _) = sel--unambiguousFieldOcc :: AmbiguousFieldOcc GhcTc -> FieldOcc GhcTc-unambiguousFieldOcc (Unambiguous rdr sel) = FieldOcc rdr sel-unambiguousFieldOcc (Ambiguous   rdr sel) = FieldOcc rdr sel--ambiguousFieldOcc :: FieldOcc GhcTc -> AmbiguousFieldOcc GhcTc-ambiguousFieldOcc (FieldOcc sel rdr) = Unambiguous sel rdr--{--************************************************************************-*                                                                      *-\subsection{Pretty printing}-*                                                                      *-************************************************************************--}--class OutputableBndrFlag flag p where-    pprTyVarBndr :: OutputableBndrId p => HsTyVarBndr flag (GhcPass p) -> SDoc--instance OutputableBndrFlag () p where-    pprTyVarBndr (UserTyVar _ _ n)     = ppr n-    pprTyVarBndr (KindedTyVar _ _ n k) = parens $ hsep [ppr n, dcolon, ppr k]--instance OutputableBndrFlag Specificity p where-    pprTyVarBndr (UserTyVar _ SpecifiedSpec n)     = ppr n-    pprTyVarBndr (UserTyVar _ InferredSpec n)      = braces $ ppr n-    pprTyVarBndr (KindedTyVar _ SpecifiedSpec n k) = parens $ hsep [ppr n, dcolon, ppr k]-    pprTyVarBndr (KindedTyVar _ InferredSpec n k)  = braces $ hsep [ppr n, dcolon, ppr k]--instance OutputableBndrId p => Outputable (HsSigType (GhcPass p)) where-    ppr (HsSig { sig_bndrs = outer_bndrs, sig_body = body }) =-      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--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}) =-  pprHsForAll (mkHsForAllInvisTele noAnn bndrs) Nothing---- | 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-  = pp_tele tele <+> pprLHsContext cxt-  where-    pp_tele :: HsForAllTelescope (GhcPass p) -> SDoc-    pp_tele tele = case tele of-      HsForAllVis   { hsf_vis_bndrs   = qtvs } -> pp_forall (space <> arrow) qtvs-      HsForAllInvis { hsf_invis_bndrs = qtvs } -> pp_forall dot qtvs--    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--pprConDeclFields :: OutputableBndrId p-                 => [LConDeclField (GhcPass p)] -> SDoc-pprConDeclFields fields = braces (sep (punctuate comma (map ppr_fld fields)))-  where-    ppr_fld (L _ (ConDeclField { cd_fld_names = ns, cd_fld_type = ty,-                                 cd_fld_doc = doc }))-        = pprMaybeWithDoc doc (ppr_names ns <+> dcolon <+> ppr ty)--    ppr_names :: [LFieldOcc (GhcPass p)] -> SDoc-    ppr_names [n] = pprPrefixOcc n-    ppr_names ns = sep (punctuate comma (map pprPrefixOcc ns))--{--Note [Printing KindedTyVars]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-#3830 reminded me that we should really only print the kind-signature on a KindedTyVar if the kind signature was put there by the-programmer.  During kind inference GHC now adds a PostTcKind to UserTyVars,-rather than converting to KindedTyVars as before.--(As it happens, the message in #3830 comes out a different way now,-and the problem doesn't show up; but having the flag on a KindedTyVar-seems like the Right Thing anyway.)--}---- Printing works more-or-less as for Types--pprHsType :: (OutputableBndrId p) => HsType (GhcPass p) -> SDoc-pprHsType ty = ppr_mono_ty ty--ppr_mono_lty :: OutputableBndrId p-             => LHsType (GhcPass p) -> SDoc-ppr_mono_lty ty = ppr_mono_ty (unLoc ty)--ppr_mono_ty :: (OutputableBndrId p) => HsType (GhcPass p) -> SDoc-ppr_mono_ty (HsForAllTy { hst_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 (HsBangTy _ b ty)           = ppr b <> ppr_mono_lty ty-ppr_mono_ty (HsRecTy _ flds)            = pprConDeclFields flds-ppr_mono_ty (HsTyVar _ prom (L _ name)) = pprOccWithTick Prefix prom name-ppr_mono_ty (HsFunTy _ mult ty1 ty2)    = ppr_fun_ty mult ty1 ty2-ppr_mono_ty (HsTupleTy _ con tys)-    -- Special-case unary boxed tuples so that they are pretty-printed as-    -- `Solo x`, not `(x)`-  | [ty] <- tys-  , BoxedTuple <- std_con-  = sep [text (mkTupleStr Boxed 1), ppr_mono_lty ty]-  | otherwise-  = tupleParens std_con (pprWithCommas ppr tys)-  where std_con = case con of-                    HsUnboxedTuple -> UnboxedTuple-                    _              -> BoxedTuple-ppr_mono_ty (HsSumTy _ tys)-  = tupleParens UnboxedTuple (pprWithBars ppr tys)-ppr_mono_ty (HsKindSig _ ty kind)-  = ppr_mono_lty ty <+> dcolon <+> ppr kind-ppr_mono_ty (HsListTy _ ty)       = brackets (ppr_mono_lty ty)-ppr_mono_ty (HsIParamTy _ n ty)   = (ppr n <+> dcolon <+> ppr_mono_lty ty)-ppr_mono_ty (HsSpliceTy _ s)      = pprSplice s-ppr_mono_ty (HsExplicitListTy _ prom tys)-  | isPromoted prom = quote $ brackets (maybeAddSpace tys $ interpp'SP tys)-  | otherwise       = brackets (interpp'SP tys)-ppr_mono_ty (HsExplicitTupleTy _ tys)-    -- Special-case unary boxed tuples so that they are pretty-printed as-    -- `'Solo x`, not `'(x)`-  | [ty] <- tys-  = quote $ sep [text (mkTupleStr Boxed 1), ppr_mono_lty ty]-  | otherwise-  = quote $ parens (maybeAddSpace tys $ interpp'SP tys)-ppr_mono_ty (HsTyLit _ t)       = ppr 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) = ppr t-----------------------------ppr_fun_ty :: (OutputableBndrId p)-           => HsArrow (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]------------------------------- | @'hsTypeNeedsParens' p t@ returns 'True' if the type @t@ needs parentheses--- under precedence @p@.-hsTypeNeedsParens :: 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 (HsBangTy{})             = p > topPrec-    go_hs_ty (HsRecTy{})              = False-    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 ('Solo x)`, not `Proxy 'Solo 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 ty)             = go_core_ty ty--    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 (HsBangTy{})          = False-    go (HsRecTy{})           = False-    go (HsTyVar _ p _)       = isPromoted p-    go (HsFunTy _ _ arg _)   = goL arg-    go (HsListTy{})          = False-    go (HsTupleTy{})         = False-    go (HsSumTy{})           = False-    go (HsOpTy _ _ t1 _ _)   = goL t1-    go (HsKindSig _ t _)     = goL t-    go (HsIParamTy{})        = False-    go (HsSpliceTy{})        = False-    go (HsExplicitListTy _ p _) = isPromoted p-    go (HsExplicitTupleTy{}) = True-    go (HsTyLit{})           = False-    go (HsWildCardTy{})      = False-    go (HsStarTy{})          = False-    go (HsAppTy _ t _)       = goL t-    go (HsAppKindTy _ t _)   = goL t-    go (HsParTy{})           = False-    go (HsDocTy _ t _)       = goL t-    go (XHsType{})           = False---- | @'parenthesizeHsType' p ty@ checks if @'hsTypeNeedsParens' p ty@ is--- true, and if so, surrounds @ty@ with an 'HsParTy'. Otherwise, it simply--- returns @ty@.-parenthesizeHsType :: PprPrec -> LHsType (GhcPass p) -> LHsType (GhcPass p)-parenthesizeHsType p lty@(L loc ty)-  | hsTypeNeedsParens p ty = L loc (HsParTy 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 :: 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 (BangType (GhcPass p)) = SrcSpanAnnA-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 = SrcAnn NoEpAnns-type instance Anno (ConDeclField (GhcPass p)) = SrcSpanAnnA--type instance Anno (FieldOcc (GhcPass p)) = SrcAnn NoEpAnns-type instance Anno (AmbiguousFieldOcc (GhcPass p)) = SrcAnn NoEpAnns+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]+                                       -- in module Language.Haskell.Syntax.Extension++{-# OPTIONS_GHC -Wno-orphans #-} -- NamedThing, Outputable, OutputableBndrId++{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+++GHC.Hs.Type: Abstract syntax: user-defined types+-}++module GHC.Hs.Type (+        Mult,+        HsMultAnn, HsMultAnnOf(..),+        multAnnToHsType, expandHsMultAnnOf,+        EpLinear(..), EpArrowOrColon(..),+        pprHsArrow, pprHsMultAnn,++        HsType(..), HsCoreTy, LHsType, HsKind, LHsKind,+        HsTypeGhcPsExt(..),+        HsForAllTelescope(..), EpAnnForallVis, EpAnnForallInvis,+        HsTyVarBndr(..), LHsTyVarBndr, AnnTyVarBndr(..),+        HsBndrKind(..),+        HsBndrVar(..),+        HsBndrVis(..), isHsBndrInvisible,+        LHsQTyVars(..),+        HsOuterTyVarBndrs(..), HsOuterFamEqnTyVarBndrs, HsOuterSigTyVarBndrs,+        HsWildCardBndrs(..),+        HsPatSigType(..), HsPSRn(..),+        HsTyPat(..), HsTyPatRn(..),+        HsTyPatRnBuilder(..), tpBuilderExplicitTV, tpBuilderPatSig, buildHsTyPatRn, builderFromHsTyPatRn,+        HsSigType(..), LHsSigType, LHsSigWcType, LHsWcType,+        HsTupleSort(..),+        HsContext, LHsContext, fromMaybeContext,+        HsTyLit(..),+        HsIPName(..), hsIPNameFS,+        HsArg(..), numVisibleArgs, pprHsArgsApp,+        LHsTypeArg, lhsTypeArgSrcSpan,+        OutputableBndrFlag,++        HsSrcBang(..), HsImplBang(..),+        SrcStrictness(..), SrcUnpackedness(..),++        HsConDeclRecField(..), LHsConDeclRecField, pprHsConDeclRecFields,++        HsConDetails(..),+        HsConDeclField(..), pprHsConDeclFieldWith, pprHsConDeclFieldNoMult,+        hsPlainTypeField, mkConDeclField,+        FieldOcc(..), LFieldOcc, mkFieldOcc,+        fieldOccRdrName, fieldOccLRdrName,++        OpName(..),++        mkAnonWildCardTy, pprAnonWildCard,++        hsOuterTyVarNames, hsOuterExplicitBndrs, mapHsOuterImplicit,+        mkHsOuterImplicit, mkHsOuterExplicit,+        mkHsImplicitSigType, mkHsExplicitSigType,+        mkHsWildCardBndrs, mkHsPatSigType, mkHsTyPat,+        mkEmptyWildCardBndrs,+        mkHsForAllVisTele, mkHsForAllInvisTele,+        mkHsQTvs, hsQTvExplicit, emptyLHsQTvs,+        isHsKindedTyVar, hsBndrVar, hsBndrKind, hsTvbAllKinded,+        hsScopedTvs, hsScopedKvs, hsWcScopedTvs, dropWildCards,+        hsTyVarLName, hsTyVarName,+        hsAllLTyVarNames, hsLTyVarLocNames,+        hsLTyVarName, hsLTyVarNames,+        hsForAllTelescopeBndrs,+        hsForAllTelescopeNames,+        hsLTyVarLocName, hsExplicitLTyVarNames,+        splitLHsInstDeclTy, getLHsInstDeclHead, getLHsInstDeclClass_maybe,+        splitLHsPatSynTy,+        splitLHsForAllTyInvis, splitLHsForAllTyInvis_KP, splitLHsQualTy,+        splitLHsSigmaTyInvis, splitLHsGadtTy,+        splitHsFunType, hsTyGetAppHead_maybe,+        mkHsOpTy, mkHsAppTy, mkHsAppTys, mkHsAppKindTy,+        ignoreParens, hsSigWcType, hsPatSigType,+        hsTyKindSig,+        setHsTyVarBndrFlag, hsTyVarBndrFlag, updateHsTyVarBndrFlag,++        -- Printing+        pprHsType, pprHsForAll, pprHsForAllTelescope,+        pprHsOuterFamEqnTyVarBndrs, pprHsOuterSigTyVarBndrs,+        pprLHsContext,+        hsTypeNeedsParens, parenthesizeHsType, parenthesizeHsContext+    ) where++import GHC.Prelude++import Language.Haskell.Syntax.Type++import {-# SOURCE #-} GHC.Hs.Expr ( pprUntypedSplice, HsUntypedSpliceResult(..) )++import Language.Haskell.Syntax.Extension+import GHC.Core.DataCon ( SrcStrictness(..), SrcUnpackedness(..)+                        , HsSrcBang(..), HsImplBang(..)+                        )+import GHC.Hs.Extension+import GHC.Parser.Annotation++import GHC.Types.Fixity ( LexicalFixity(..) )+import GHC.Types.SourceText+import GHC.Types.Name+import GHC.Types.Name.Reader ( RdrName, WithUserRdr(..), noUserRdr )+import GHC.Types.Var ( VarBndr, visArgTypeLike )+import GHC.Core.TyCo.Rep ( Type(..) )+import GHC.Builtin.Names ( negateName )+import GHC.Builtin.Types( oneDataConName, mkTupleStr )+import GHC.Core.Ppr ( pprOccWithTick)+import GHC.Core.Type+import GHC.Core.Multiplicity( pprArrowWithMultiplicity )+import GHC.Hs.Doc+import GHC.Types.Basic+import GHC.Types.SrcLoc+import GHC.Utils.Outputable+import GHC.Utils.Misc (count)++import Data.Maybe+import Data.Data (Data)++import qualified Data.Semigroup as S+import GHC.Data.Bag++{-+************************************************************************+*                                                                      *+\subsection{Data types}+*                                                                      *+************************************************************************+-}++fromMaybeContext :: Maybe (LHsContext (GhcPass p)) -> HsContext (GhcPass p)+fromMaybeContext mctxt = unLoc $ fromMaybe (noLocA []) mctxt++type instance XHsForAllVis   (GhcPass _) = EpAnn (TokForall, TokRarrow)+                                           -- Location of 'forall' and '->'+type instance XHsForAllInvis (GhcPass _) = EpAnn (TokForall, EpToken ".")+                                           -- Location of 'forall' and '.'++type instance XXHsForAllTelescope (GhcPass _) = DataConCantHappen++type EpAnnForallVis   = EpAnn (TokForall, TokRarrow)+type EpAnnForallInvis = EpAnn (TokForall, EpToken ".")++type HsQTvsRn = [Name]  -- Implicit variables+  -- For example, in   data T (a :: k1 -> k2) = ...+  -- the 'a' is explicit while 'k1', 'k2' are implicit++type instance XHsQTvs GhcPs = NoExtField+type instance XHsQTvs GhcRn = HsQTvsRn+type instance XHsQTvs GhcTc = HsQTvsRn++type instance XXLHsQTyVars  (GhcPass _) = DataConCantHappen++mkHsForAllVisTele ::EpAnnForallVis ->+  [LHsTyVarBndr () (GhcPass p)] -> HsForAllTelescope (GhcPass p)+mkHsForAllVisTele an vis_bndrs =+  HsForAllVis { hsf_xvis = an, hsf_vis_bndrs = vis_bndrs }++mkHsForAllInvisTele :: EpAnnForallInvis+  -> [LHsTyVarBndr Specificity (GhcPass p)] -> HsForAllTelescope (GhcPass p)+mkHsForAllInvisTele an invis_bndrs =+  HsForAllInvis { hsf_xinvis = an, hsf_invis_bndrs = invis_bndrs }++mkHsQTvs :: [LHsTyVarBndr (HsBndrVis GhcPs) GhcPs] -> LHsQTyVars GhcPs+mkHsQTvs tvs = HsQTvs { hsq_ext = noExtField, hsq_explicit = tvs }++emptyLHsQTvs :: LHsQTyVars GhcRn+emptyLHsQTvs = HsQTvs { hsq_ext = [], hsq_explicit = [] }++------------------------------------------------+--            HsOuterTyVarBndrs++type instance XHsOuterImplicit GhcPs = NoExtField+type instance XHsOuterImplicit GhcRn = [Name]+type instance XHsOuterImplicit GhcTc = [TyVar]++type instance XHsOuterExplicit GhcPs _    = EpAnnForallInvis+type instance XHsOuterExplicit GhcRn _    = NoExtField+type instance XHsOuterExplicit GhcTc flag = [VarBndr TyVar flag]++type instance XXHsOuterTyVarBndrs (GhcPass _) = DataConCantHappen++type instance XHsWC              GhcPs b = NoExtField+type instance XHsWC              GhcRn b = [Name]+type instance XHsWC              GhcTc b = [Name]++type instance XXHsWildCardBndrs (GhcPass _) _ = DataConCantHappen++type instance XHsPS GhcPs = EpAnnCO+type instance XHsPS GhcRn = HsPSRn+type instance XHsPS GhcTc = HsPSRn++type instance XHsTP GhcPs = NoExtField+type instance XHsTP GhcRn = HsTyPatRn+type instance XHsTP GhcTc = DataConCantHappen++-- | The extension field for 'HsPatSigType', which is only used in the+-- renamer onwards. See @Note [Pattern signature binders and scoping]@.+data HsPSRn = HsPSRn+  { hsps_nwcs    :: [Name] -- ^ Wildcard names+  , hsps_imp_tvs :: [Name] -- ^ Implicitly bound variable names+  }+  deriving Data++-- HsTyPatRn is the extension field for `HsTyPat`, after renaming+-- E.g. pattern K @(Maybe (_x, a, b::Proxy k)+-- In the type pattern @(Maybe ...):+--    '_x' is a named wildcard+--    'a'  is explicitly bound+--    'k'  is implicitly bound+-- See Note [Implicit and explicit type variable binders] in GHC.Rename.Pat+data HsTyPatRn = HsTPRn+  { hstp_nwcs    :: [Name] -- ^ Wildcard names+  , hstp_imp_tvs :: [Name] -- ^ Implicitly bound variable names+  , hstp_exp_tvs :: [Name] -- ^ Explicitly bound variable names+  }+  deriving Data++-- | A variant of HsTyPatRn that uses Bags for efficient concatenation.+-- See Note [Implicit and explicit type variable binders]  in GHC.Rename.Pat+data HsTyPatRnBuilder =+  HsTPRnB {+    hstpb_nwcs :: Bag Name,+    hstpb_imp_tvs :: Bag Name,+    hstpb_exp_tvs :: Bag Name+  }++tpBuilderExplicitTV :: Name -> HsTyPatRnBuilder+tpBuilderExplicitTV name = mempty {hstpb_exp_tvs = unitBag name}++tpBuilderPatSig :: HsPSRn -> HsTyPatRnBuilder+tpBuilderPatSig HsPSRn {hsps_nwcs, hsps_imp_tvs} =+  mempty {+    hstpb_nwcs = listToBag hsps_nwcs,+    hstpb_imp_tvs = listToBag hsps_imp_tvs+  }++instance Semigroup HsTyPatRnBuilder where+  HsTPRnB nwcs1 imp_tvs1 exptvs1 <> HsTPRnB nwcs2 imp_tvs2 exptvs2 =+    HsTPRnB+      (nwcs1    `unionBags` nwcs2)+      (imp_tvs1 `unionBags` imp_tvs2)+      (exptvs1  `unionBags` exptvs2)++instance Monoid HsTyPatRnBuilder where+  mempty = HsTPRnB emptyBag emptyBag emptyBag++buildHsTyPatRn :: HsTyPatRnBuilder -> HsTyPatRn+buildHsTyPatRn HsTPRnB {hstpb_nwcs, hstpb_imp_tvs, hstpb_exp_tvs} =+  HsTPRn {+    hstp_nwcs =    bagToList hstpb_nwcs,+    hstp_imp_tvs = bagToList hstpb_imp_tvs,+    hstp_exp_tvs = bagToList hstpb_exp_tvs+  }++builderFromHsTyPatRn :: HsTyPatRn -> HsTyPatRnBuilder+builderFromHsTyPatRn HsTPRn{hstp_nwcs, hstp_imp_tvs, hstp_exp_tvs} =+  HsTPRnB {+    hstpb_nwcs =    listToBag hstp_nwcs,+    hstpb_imp_tvs = listToBag hstp_imp_tvs,+    hstpb_exp_tvs = listToBag hstp_exp_tvs+  }++type instance XXHsPatSigType (GhcPass _) = DataConCantHappen+type instance XXHsTyPat      (GhcPass _) = DataConCantHappen++type instance XHsSig (GhcPass _) = NoExtField+type instance XXHsSigType (GhcPass _) = DataConCantHappen+++hsPatSigType :: HsPatSigType (GhcPass p) -> LHsType (GhcPass p)+hsPatSigType (HsPS { hsps_body = ty }) = ty++hsSigWcType :: LHsSigWcType (GhcPass p) -> LHsType (GhcPass p)+hsSigWcType = sig_body . unLoc . hswc_body++dropWildCards :: LHsSigWcType (GhcPass p) -> LHsSigType (GhcPass p)+-- Drop the wildcard part of a LHsSigWcType+dropWildCards sig_ty = hswc_body sig_ty++hsOuterTyVarNames :: HsOuterTyVarBndrs flag GhcRn -> [Name]+hsOuterTyVarNames (HsOuterImplicit{hso_ximplicit = imp_tvs}) = imp_tvs+hsOuterTyVarNames (HsOuterExplicit{hso_bndrs = bndrs})       = hsLTyVarNames bndrs++hsOuterExplicitBndrs :: HsOuterTyVarBndrs flag (GhcPass p)+                     -> [LHsTyVarBndr flag (NoGhcTc (GhcPass p))]+hsOuterExplicitBndrs (HsOuterExplicit{hso_bndrs = bndrs}) = bndrs+hsOuterExplicitBndrs (HsOuterImplicit{})                  = []++mkHsOuterImplicit :: HsOuterTyVarBndrs flag GhcPs+mkHsOuterImplicit = HsOuterImplicit{hso_ximplicit = noExtField}++mkHsOuterExplicit :: EpAnnForallInvis -> [LHsTyVarBndr flag GhcPs]+                  -> HsOuterTyVarBndrs flag GhcPs+mkHsOuterExplicit an bndrs = HsOuterExplicit { hso_xexplicit = an+                                             , hso_bndrs     = bndrs }++mkHsImplicitSigType :: LHsType GhcPs -> HsSigType GhcPs+mkHsImplicitSigType body =+  HsSig { sig_ext   = noExtField+        , sig_bndrs = mkHsOuterImplicit, sig_body = body }++mkHsExplicitSigType :: EpAnnForallInvis+                    -> [LHsTyVarBndr Specificity GhcPs] -> LHsType GhcPs+                    -> HsSigType GhcPs+mkHsExplicitSigType an bndrs body =+  HsSig { sig_ext = noExtField+        , sig_bndrs = mkHsOuterExplicit an bndrs, sig_body = body }++mkHsWildCardBndrs :: thing -> HsWildCardBndrs GhcPs thing+mkHsWildCardBndrs x = HsWC { hswc_body = x+                           , hswc_ext  = noExtField }++mkHsPatSigType :: EpAnnCO -> LHsType GhcPs -> HsPatSigType GhcPs+mkHsPatSigType ann x = HsPS { hsps_ext  = ann+                            , hsps_body = x }++mkHsTyPat :: LHsType GhcPs -> HsTyPat GhcPs+mkHsTyPat x = HsTP { hstp_ext  = noExtField+                   , hstp_body = x }++mkEmptyWildCardBndrs :: thing -> HsWildCardBndrs GhcRn thing+mkEmptyWildCardBndrs x = HsWC { hswc_body = x+                              , hswc_ext  = [] }++--------------------------------------------------++type instance XTyVarBndr    (GhcPass _) = AnnTyVarBndr+type instance XXTyVarBndr   (GhcPass _) = DataConCantHappen++type instance XBndrKind   (GhcPass p) = NoExtField+type instance XBndrNoKind (GhcPass p) = NoExtField+type instance XXBndrKind  (GhcPass p) = DataConCantHappen++type instance XBndrVar (GhcPass p) = NoExtField++type instance XBndrWildCard GhcPs = EpToken "_"+type instance XBndrWildCard GhcRn = NoExtField+type instance XBndrWildCard GhcTc = NoExtField++type instance XXBndrVar (GhcPass p) = DataConCantHappen++data AnnTyVarBndr+  = AnnTyVarBndr {+    atv_opens  :: [EpaLocation], -- all "(" or all "{"+    atv_closes :: [EpaLocation], -- all ")" or all "}"+    atv_tv     :: EpToken "'",+    atv_dcolon :: TokDcolon+  } deriving Data++instance NoAnn AnnTyVarBndr where+  noAnn = AnnTyVarBndr noAnn noAnn noAnn noAnn++-- | Return the attached flag+hsTyVarBndrFlag :: HsTyVarBndr flag (GhcPass pass) -> flag+hsTyVarBndrFlag = tvb_flag+-- By specialising to (GhcPass p) we know that XXTyVarBndr is DataConCantHappen+-- so the equation is exhaustive: extension construction can't happen++-- | Set the attached flag+setHsTyVarBndrFlag :: flag -> HsTyVarBndr flag' (GhcPass pass)+  -> HsTyVarBndr flag (GhcPass pass)+setHsTyVarBndrFlag fl tvb = tvb { tvb_flag = fl }++-- | Update the attached flag+updateHsTyVarBndrFlag+  :: (flag -> flag')+  -> HsTyVarBndr flag  (GhcPass pass)+  -> HsTyVarBndr flag' (GhcPass pass)+updateHsTyVarBndrFlag f tvb = tvb { tvb_flag = f (tvb_flag tvb) }++-- | Get the variable of the type variable binder+hsBndrVar :: HsTyVarBndr flag (GhcPass pass) -> HsBndrVar (GhcPass pass)+hsBndrVar = tvb_var++-- | Get the kind of the type variable binder+hsBndrKind :: HsTyVarBndr flag (GhcPass pass) -> HsBndrKind (GhcPass pass)+hsBndrKind = tvb_kind++-- | Do all type variables in this 'LHsQTyVars' come with kind annotations?+hsTvbAllKinded :: LHsQTyVars (GhcPass p) -> Bool+hsTvbAllKinded = all (isHsKindedTyVar . unLoc) . hsQTvExplicit++type instance XBndrRequired (GhcPass _) = NoExtField++type instance XBndrInvisible GhcPs = EpToken "@"+type instance XBndrInvisible GhcRn = NoExtField+type instance XBndrInvisible GhcTc = NoExtField++type instance XXBndrVis (GhcPass _) = DataConCantHappen++{- Note [Wildcard binders in disallowed contexts]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In contexts where a type variable binder is expected (HsTyVarBndr), we usually+allow both named binders and wildcards, e.g.++  type Const1 a b = a     -- ok+  type Const2 a _ = a     -- ok, too++This applies to LHSs of data, newtype, type, class, type family and data family+declarations. However, we choose to reject wildcards in forall telescopes and+type family result variables (the latter being part of TypeFamilyDependencies):++  type family Fd a = _    -- disallowed  (WildcardBndrInTyFamResultVar)+  fn :: forall _. Int     -- disallowed  (WildcardBndrInForallTelescope)++This restriction is placed solely because such binders have not been proposed+and there is no known use case for them. If we see user demand for wildcard+binders in these contexts, adding support for them would be as easy as dropping+the checks that reject them. The rest of the compiler can handle all wildcard+binders regardless of context by generating a fresh name (see `tcHsBndrVarName`+in GHC.Tc.Gen.HsType and `repHsBndrVar` in GHC.HsToCore.Quote).++That is, in type declarations we have:++  type F _  = ...  -- equivalent to ...+  type F _a = ...  -- where _a is fresh++and the same principle could be applied to foralls:++  fn :: forall _.  Int   -- equivalent to ...+  fn :: forall _a. Int   -- where _a is fresh++except the `forall _.` example is rejected by checkForAllTelescopeWildcardBndrs.+-}++type instance XForAllTy        (GhcPass _) = NoExtField+type instance XQualTy          (GhcPass _) = NoExtField+type instance XTyVar           (GhcPass _) = EpToken "'"+type instance XAppTy           (GhcPass _) = NoExtField+type instance XFunTy           (GhcPass _) = NoExtField+type instance XListTy          (GhcPass _) = AnnParen+type instance XTupleTy         (GhcPass _) = AnnParen+type instance XSumTy           (GhcPass _) = AnnParen+type instance XOpTy            (GhcPass _) = NoExtField+type instance XParTy           (GhcPass _) = (EpToken "(", EpToken ")")+type instance XIParamTy        (GhcPass _) = TokDcolon+type instance XStarTy          (GhcPass _) = NoExtField+type instance XKindSig         (GhcPass _) = TokDcolon++type instance XAppKindTy       GhcPs = EpToken "@"+type instance XAppKindTy       GhcRn = NoExtField+type instance XAppKindTy       GhcTc = NoExtField++type instance XSpliceTy        GhcPs = NoExtField+type instance XSpliceTy        GhcRn = HsUntypedSpliceResult (LHsType GhcRn)+type instance XSpliceTy        GhcTc = Kind++type instance XDocTy           (GhcPass _) = NoExtField+type instance XConDeclField    (GhcPass _) = ((EpaLocation, EpToken "#-}", EpaLocation), SourceText)+type instance XXConDeclRecField   (GhcPass _) = DataConCantHappen++type instance XExplicitListTy  GhcPs = (EpToken "'", EpToken "[", EpToken "]")+type instance XExplicitListTy  GhcRn = NoExtField+type instance XExplicitListTy  GhcTc = Kind++type instance XExplicitTupleTy GhcPs = (EpToken "'", EpToken "(", EpToken ")")+type instance XExplicitTupleTy GhcRn = NoExtField+type instance XExplicitTupleTy GhcTc = [Kind]++type instance XTyLit           (GhcPass _) = NoExtField++type instance XWildCardTy      GhcPs = EpToken "_"+type instance XWildCardTy      GhcRn = NoExtField+type instance XWildCardTy      GhcTc = NoExtField++type instance XXType           GhcPs = HsTypeGhcPsExt+type instance XXType           GhcRn = HsCoreTy+type instance XXType           GhcTc = DataConCantHappen++type instance XNumTy         (GhcPass _) = SourceText+type instance XStrTy         (GhcPass _) = SourceText+type instance XCharTy        (GhcPass _) = SourceText+type instance XXTyLit        (GhcPass _) = DataConCantHappen++type HsCoreTy = Type++-- Extension of HsType during parsing.+-- see Note [Trees That Grow] in Language.Haskell.Syntax.Extension+data HsTypeGhcPsExt+  = HsCoreTy    HsCoreTy+    -- An escape hatch for tunnelling a Core 'Type' through 'HsType'.+    -- For more details on how this works, see:+    --+    -- @Note [Renaming HsCoreTys]@ in "GHC.Rename.HsType"+    --+    -- @Note [Typechecking HsCoreTys]@ in "GHC.Tc.Gen.HsType"++  | HsBangTy    (EpaLocation, EpToken "#-}", EpaLocation)+                HsSrcBang+                (LHsType GhcPs)+    -- See Note [Parsing data type declarations]++  | HsRecTy     (AnnList ())+                [LHsConDeclRecField GhcPs]+    -- See Note [Parsing data type declarations]++{- Note [Parsing data type declarations]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When parsing it is not always clear if we're parsing a constructor field type+or not. So during parsing we extend the type syntax to support bang annotations+and record braces. We do this through the extension constructor of (HsType GhcPs),+namely `HsTypeGhcPsExt`, adding data constructors for `HsBangTy` and `HsRecTy`.+Once parsing is done (i.e. (HsType GhcRn) and (HsType GhcTc)) these constructors+are not needed; instead the data is stored in `HsConDeclField`. It is an error+if it turns out the extensions were used outside of a constructor field type.+-}++data EpArrowOrColon+  = EpArrow !TokRarrow+  | EpColon !TokDcolon+  | EpPatBind+  deriving Data++data EpLinear+  = EpPct1 !(EpToken "%1") !EpArrowOrColon+  | EpLolly !(EpToken "⊸")+  deriving Data++instance NoAnn EpLinear where+  noAnn = EpPct1 noAnn (EpArrow noAnn)++type instance XUnannotated  _ GhcPs = EpArrowOrColon+type instance XUnannotated  _ GhcRn = NoExtField+type instance XUnannotated  _ GhcTc = Mult++type instance XLinearAnn    _ GhcPs = EpLinear+type instance XLinearAnn    _ GhcRn = NoExtField+type instance XLinearAnn    _ GhcTc = Mult++type instance XExplicitMult _ GhcPs = (EpToken "%", EpArrowOrColon)+type instance XExplicitMult _ GhcRn = NoExtField+type instance XExplicitMult _ GhcTc = Mult++type instance XXMultAnnOf   _ (GhcPass _) = DataConCantHappen++multAnnToHsType :: HsMultAnn GhcRn -> Maybe (LHsType GhcRn)+multAnnToHsType = expandHsMultAnnOf (HsTyVar noAnn NotPromoted . fmap noUserRdr)++-- | Convert an multiplicity annotation into its corresponding multiplicity.+-- If no annotation was written, `Nothing` is returned.+-- In this polymorphic function, `t` can be `HsType` or `HsExpr`+expandHsMultAnnOf :: (LocatedN Name -> t GhcRn)+                  -> HsMultAnnOf (LocatedA (t GhcRn)) GhcRn+                  -> Maybe (LocatedA (t GhcRn))+expandHsMultAnnOf _mk_var HsUnannotated{} = Nothing+expandHsMultAnnOf mk_var (HsLinearAnn _) = Just (noLocA (mk_var (noLocA oneDataConName)))+expandHsMultAnnOf _mk_var (HsExplicitMult _ p) = Just p++instance+      (Outputable mult, OutputableBndrId pass) =>+      Outputable (HsMultAnnOf mult (GhcPass pass)) where+  ppr arr = parens (pprHsArrow arr)++-- See #18846+pprHsArrow :: (Outputable mult, OutputableBndrId pass) => HsMultAnnOf mult (GhcPass pass) -> SDoc+pprHsArrow (HsUnannotated _)    = pprArrowWithMultiplicity visArgTypeLike (Left False)+pprHsArrow (HsLinearAnn _)      = pprArrowWithMultiplicity visArgTypeLike (Left True)+pprHsArrow (HsExplicitMult _ p) = pprArrowWithMultiplicity visArgTypeLike (Right (ppr p))++-- Used to print, for instance, let bindings:+--   let %1 x = …+-- and record field declarations:+--   { x %1 :: … }+pprHsMultAnn :: forall id. OutputableBndrId id => HsMultAnn (GhcPass id) -> SDoc+pprHsMultAnn (HsUnannotated _) = empty+pprHsMultAnn (HsLinearAnn _) = text "%1"+pprHsMultAnn (HsExplicitMult _ p) = text "%" <> ppr p++type instance XConDeclRecField  (GhcPass _) = NoExtField+type instance XXConDeclRecField (GhcPass _) = DataConCantHappen++instance OutputableBndrId p+       => Outputable (HsConDeclRecField (GhcPass p)) where+  ppr (HsConDeclRecField _ fld_n cfs) = pprMaybeWithDoc (cdf_doc cfs) (ppr_names fld_n <+> pprHsConDeclFieldWith ppr_mult cfs { cdf_doc = Nothing })+    where+      ppr_names :: [LFieldOcc (GhcPass p)] -> SDoc+      ppr_names [n] = pprPrefixOcc n+      ppr_names ns = sep (punctuate comma (map pprPrefixOcc ns))++      ppr_mult :: HsMultAnn (GhcPass p) -> SDoc -> SDoc+      ppr_mult mult tyDoc = pprHsMultAnn mult <+> dcolon <+> tyDoc++---------------------+hsWcScopedTvs :: LHsSigWcType GhcRn -> [Name]+-- Get the lexically-scoped type variables of an LHsSigWcType:+--  - the explicitly-given forall'd type variables;+--    see Note [Lexically scoped type variables]+--  - the named wildcards; see Note [Scoping of named wildcards]+-- because they scope in the same way+hsWcScopedTvs sig_wc_ty+  | HsWC { hswc_ext = nwcs, hswc_body = sig_ty }  <- sig_wc_ty+  , L _ (HsSig{sig_bndrs = outer_bndrs}) <- sig_ty+  = nwcs ++ hsLTyVarNames (hsOuterExplicitBndrs outer_bndrs)+    -- See Note [hsScopedTvs and visible foralls]++hsScopedTvs :: LHsSigType GhcRn -> [Name]+-- Same as hsWcScopedTvs, but for a LHsSigType+hsScopedTvs (L _ (HsSig{sig_bndrs = outer_bndrs}))+  = hsLTyVarNames (hsOuterExplicitBndrs outer_bndrs)+    -- See Note [hsScopedTvs and visible foralls]++hsScopedKvs :: LHsKind GhcRn -> [Name]+-- Same as hsScopedTvs, but for a LHsKind+hsScopedKvs  (L _ HsForAllTy { hst_tele = HsForAllInvis { hsf_invis_bndrs = bndrs }})+  = hsLTyVarNames bndrs+    -- See Note [hsScopedTvs and visible foralls]+hsScopedKvs _ = []++---------------------+hsTyVarLName :: HsTyVarBndr flag (GhcPass p) -> Maybe (LIdP (GhcPass p))+hsTyVarLName tvb =+  case hsBndrVar tvb of+    HsBndrVar      _ n -> Just n+    HsBndrWildCard _   -> Nothing++hsTyVarName :: HsTyVarBndr flag (GhcPass p) -> Maybe (IdP (GhcPass p))+hsTyVarName = fmap unLoc . hsTyVarLName++hsLTyVarName :: LHsTyVarBndr flag (GhcPass p) -> Maybe (IdP (GhcPass p))+hsLTyVarName = hsTyVarName . unLoc++hsLTyVarNames :: [LHsTyVarBndr flag (GhcPass p)] -> [IdP (GhcPass p)]+hsLTyVarNames = mapMaybe hsLTyVarName++hsForAllTelescopeBndrs :: HsForAllTelescope (GhcPass p) -> [LHsTyVarBndr ForAllTyFlag (GhcPass p)]+hsForAllTelescopeBndrs (HsForAllVis   _ bndrs) = map (fmap (setHsTyVarBndrFlag Required)) bndrs+hsForAllTelescopeBndrs (HsForAllInvis _ bndrs) = map (fmap (updateHsTyVarBndrFlag Invisible)) bndrs++hsForAllTelescopeNames :: HsForAllTelescope (GhcPass p) -> [IdP (GhcPass p)]+hsForAllTelescopeNames (HsForAllVis _ bndrs) = hsLTyVarNames bndrs+hsForAllTelescopeNames (HsForAllInvis _ bndrs) = hsLTyVarNames bndrs++hsExplicitLTyVarNames :: LHsQTyVars (GhcPass p) -> [IdP (GhcPass p)]+-- Explicit variables only+hsExplicitLTyVarNames qtvs = hsLTyVarNames (hsQTvExplicit qtvs)++hsAllLTyVarNames :: LHsQTyVars GhcRn -> [Name]+-- All variables+hsAllLTyVarNames (HsQTvs { hsq_ext = kvs+                         , hsq_explicit = tvs })+  = kvs ++ hsLTyVarNames tvs++hsLTyVarLocName :: Anno (IdGhcP p) ~ SrcSpanAnnN+                => LHsTyVarBndr flag (GhcPass p) -> Maybe (LocatedN (IdP (GhcPass p)))+hsLTyVarLocName (L _ a) = hsTyVarLName a++hsLTyVarLocNames :: Anno (IdGhcP p) ~ SrcSpanAnnN+                 => LHsQTyVars (GhcPass p) -> [LocatedN (IdP (GhcPass p))]+hsLTyVarLocNames qtvs = mapMaybe hsLTyVarLocName (hsQTvExplicit qtvs)++-- | Get the kind signature of a type, ignoring parentheses:+--+--   hsTyKindSig   `Maybe                    `   =   Nothing+--   hsTyKindSig   `Maybe ::   Type -> Type  `   =   Just  `Type -> Type`+--   hsTyKindSig   `Maybe :: ((Type -> Type))`   =   Just  `Type -> Type`+--+-- This is used to extract the result kind of type synonyms with a CUSK:+--+--  type S = (F :: res_kind)+--                 ^^^^^^^^+--+hsTyKindSig :: LHsType (GhcPass p) -> Maybe (LHsKind (GhcPass p))+hsTyKindSig lty =+  case unLoc lty of+    HsParTy _ lty'    -> hsTyKindSig lty'+    HsKindSig _ _ k   -> Just k+    _                 -> Nothing++---------------------+ignoreParens :: LHsType (GhcPass p) -> LHsType (GhcPass p)+ignoreParens (L _ (HsParTy _ ty)) = ignoreParens ty+ignoreParens ty                   = ty++{-+************************************************************************+*                                                                      *+                Building types+*                                                                      *+************************************************************************+-}++mkAnonWildCardTy :: EpToken "_" -> HsType GhcPs+mkAnonWildCardTy tok = HsWildCardTy tok++mkHsOpTy :: (Anno (IdOccGhcP p) ~ SrcSpanAnnN)+         => PromotionFlag+         -> LHsType (GhcPass p) -> LocatedN (IdOccP (GhcPass p))+         -> LHsType (GhcPass p) -> HsType (GhcPass p)+mkHsOpTy prom ty1 op ty2 = HsOpTy noExtField prom ty1 op ty2++mkHsAppTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)+mkHsAppTy t1 t2 = addCLocA t1 t2 (HsAppTy noExtField t1 t2)++mkHsAppTys :: LHsType (GhcPass p) -> [LHsType (GhcPass p)]+           -> LHsType (GhcPass p)+mkHsAppTys = foldl' mkHsAppTy++mkHsAppKindTy :: XAppKindTy (GhcPass p)+              -> LHsType (GhcPass p) -> LHsType (GhcPass p)+              -> LHsType (GhcPass p)+mkHsAppKindTy at ty k = addCLocA ty k (HsAppKindTy at ty k)++{-+************************************************************************+*                                                                      *+                Decomposing HsTypes+*                                                                      *+************************************************************************+-}++---------------------------------+-- splitHsFunType decomposes a type (t1 -> t2 ... -> tn)+-- Breaks up any parens in the result type:+--      splitHsFunType (a -> (b -> c)) = ([a,b], c)+-- It returns API Annotations for any parens removed+splitHsFunType ::+     LHsType GhcPs+  -> ( ([EpToken "("], [EpToken ")"]) , EpAnnComments -- The locations of any parens and+                                  -- comments discarded+     , [HsConDeclField GhcPs], LHsType GhcPs)+splitHsFunType ty = go ty+  where+    go (L l (HsParTy (op,cp) ty))+      = let+          ((ops, cps), cs, args, res) = splitHsFunType ty+          cs' = cs S.<> epAnnComments l+        in ((ops++[op], cps ++ [cp]), cs', args, res)++    go (L ll (HsFunTy _ mult x y))+      | (anns, csy, args, res) <- splitHsFunType y+      = (anns, csy S.<> epAnnComments ll, mkConDeclField mult x:args, res)++    go other = (noAnn, emptyComments, [], other)++-- | Retrieve the name of the \"head\" of a nested type application.+-- This is somewhat like @GHC.Tc.Gen.HsType.splitHsAppTys@, but a little more+-- thorough. The purpose of this function is to examine instance heads, so it+-- doesn't handle *all* cases (like lists, tuples, @(~)@, etc.).+hsTyGetAppHead_maybe :: (Anno (IdOccGhcP p) ~ SrcSpanAnnN)+                     => LHsType (GhcPass p)+                     -> Maybe (LocatedN (IdOccP (GhcPass p)))+hsTyGetAppHead_maybe = go+  where+    go (L _ (HsTyVar _ _ ln))    = Just ln+    go (L _ (HsAppTy _ l _))     = go l+    go (L _ (HsAppKindTy _ t _)) = go t+    go (L _ (HsOpTy _ _ _ ln _)) = Just ln+    go (L _ (HsParTy _ t))       = go t+    go (L _ (HsKindSig _ t _))   = go t+    go _                         = Nothing++------------------------------------------------------------++type instance XValArg (GhcPass _) = NoExtField++type instance XTypeArg GhcPs = EpToken "@"+type instance XTypeArg GhcRn = NoExtField+type instance XTypeArg GhcTc = NoExtField++type instance XArgPar (GhcPass _) = SrcSpan++type instance XXArg (GhcPass _) = DataConCantHappen++-- | Compute the 'SrcSpan' associated with an 'LHsTypeArg'.+lhsTypeArgSrcSpan :: LHsTypeArg GhcPs -> SrcSpan+lhsTypeArgSrcSpan arg = case arg of+  HsValArg  _  tm -> getLocA tm+  HsTypeArg at ty -> getEpTokenSrcSpan at `combineSrcSpans` getLocA ty+  HsArgPar  sp    -> sp++--------------------------------++numVisibleArgs :: [HsArg p tm ty] -> Arity+numVisibleArgs = count is_vis+  where is_vis (HsValArg _ _) = True+        is_vis _              = False++--------------------------------++-- | @'pprHsArgsApp' id fixity args@ pretty-prints an application of @id@+-- to @args@, using the @fixity@ to tell whether @id@ should be printed prefix+-- or infix. Examples:+--+-- @+-- pprHsArgsApp T Prefix [HsTypeArg Bool, HsValArg Int]                        = T \@Bool Int+-- pprHsArgsApp T Prefix [HsTypeArg Bool, HsArgPar, HsValArg Int]              = (T \@Bool) Int+-- pprHsArgsApp (++) Infix [HsValArg Char, HsValArg Double]                    = Char ++ Double+-- pprHsArgsApp (++) Infix [HsValArg Char, HsValArg Double, HsVarArg Ordering] = (Char ++ Double) Ordering+-- @+pprHsArgsApp :: (OutputableBndr id, Outputable tm, Outputable ty)+             => id -> LexicalFixity -> [HsArg (GhcPass p) tm ty] -> SDoc+pprHsArgsApp thing fixity (argl:argr:args)+  | Infix <- fixity+  = let pp_op_app = hsep [ ppr_single_hs_arg argl+                         , pprInfixOcc thing+                         , ppr_single_hs_arg argr ] in+    case args of+      [] -> pp_op_app+      _  -> ppr_hs_args_prefix_app (parens pp_op_app) args++pprHsArgsApp thing _fixity args+  = ppr_hs_args_prefix_app (pprPrefixOcc thing) args++-- | Pretty-print a prefix identifier to a list of 'HsArg's.+ppr_hs_args_prefix_app :: (Outputable tm, Outputable ty)+                        => SDoc -> [HsArg (GhcPass p) tm ty] -> SDoc+ppr_hs_args_prefix_app acc []         = acc+ppr_hs_args_prefix_app acc (arg:args) =+  case arg of+    HsValArg{}  -> ppr_hs_args_prefix_app (acc <+> ppr_single_hs_arg arg) args+    HsTypeArg{} -> ppr_hs_args_prefix_app (acc <+> ppr_single_hs_arg arg) args+    HsArgPar{}  -> ppr_hs_args_prefix_app (parens acc) args++-- | Pretty-print an 'HsArg' in isolation.+ppr_single_hs_arg :: (Outputable tm, Outputable ty)+                  => HsArg (GhcPass p) tm ty -> SDoc+ppr_single_hs_arg (HsValArg _ tm)  = ppr tm+ppr_single_hs_arg (HsTypeArg _ ty) = char '@' <> ppr ty+-- GHC shouldn't be constructing ASTs such that this case is ever reached.+-- Still, it's possible some wily user might construct their own AST that+-- allows this to be reachable, so don't fail here.+ppr_single_hs_arg (HsArgPar{})     = empty++-- | This instance is meant for debug-printing purposes. If you wish to+-- pretty-print an application of 'HsArg's, use 'pprHsArgsApp' instead.+instance (Outputable tm, Outputable ty) => Outputable (HsArg (GhcPass p) tm ty) where+  ppr (HsValArg _ tm)   = text "HsValArg"  <+> ppr tm+  ppr (HsTypeArg _ ty)  = text "HsTypeArg" <+> ppr ty+  ppr (HsArgPar sp)     = text "HsArgPar"  <+> ppr sp++--------------------------------++-- | Decompose a pattern synonym type signature into its constituent parts.+--+-- Note that this function looks through parentheses, so it will work on types+-- such as @(forall a. <...>)@. The downside to this is that it is not+-- generally possible to take the returned types and reconstruct the original+-- type (parentheses and all) from them.+splitLHsPatSynTy ::+     LHsSigType (GhcPass p)+  -> ( [LHsTyVarBndr Specificity (GhcPass (NoGhcTcPass p))] -- universals+     , Maybe (LHsContext (GhcPass p))                       -- required constraints+     , [LHsTyVarBndr Specificity (GhcPass p)]               -- existentials+     , Maybe (LHsContext (GhcPass p))                       -- provided constraints+     , LHsType (GhcPass p))                                 -- body type+splitLHsPatSynTy ty = (univs, reqs, exis, provs, ty4)+  where+    -- split_sig_ty ::+    --      LHsSigType (GhcPass p)+    --   -> ([LHsTyVarBndr Specificity (GhcPass (NoGhcTcPass p))], LHsType (GhcPass p))+    split_sig_ty (L _ HsSig{sig_bndrs = outer_bndrs, sig_body = body}) =+      case outer_bndrs of+        -- NB: Use ignoreParens here in order to be consistent with the use of+        -- splitLHsForAllTyInvis below, which also looks through parentheses.+        HsOuterImplicit{}                      -> ([], ignoreParens body)+        HsOuterExplicit{hso_bndrs = exp_bndrs} -> (exp_bndrs, body)++    (univs, ty1) = split_sig_ty ty+    (reqs,  ty2) = splitLHsQualTy ty1+    (exis,  ty3) = splitLHsForAllTyInvis ty2+    (provs, ty4) = splitLHsQualTy ty3++-- | Decompose a sigma type (of the form @forall <tvs>. context => body@)+-- into its constituent parts.+-- Only splits type variable binders that were+-- quantified invisibly (e.g., @forall a.@, with a dot).+--+-- This function is used to split apart certain types, such as instance+-- declaration types, which disallow visible @forall@s. For instance, if GHC+-- split apart the @forall@ in @instance forall a -> Show (Blah a)@, then that+-- declaration would mistakenly be accepted!+--+-- Note that this function looks through parentheses, so it will work on types+-- such as @(forall a. <...>)@. The downside to this is that it is not+-- generally possible to take the returned types and reconstruct the original+-- type (parentheses and all) from them.+splitLHsSigmaTyInvis :: LHsType (GhcPass p)+                     -> ([LHsTyVarBndr Specificity (GhcPass p)]+                        , Maybe (LHsContext (GhcPass p)), LHsType (GhcPass p))+splitLHsSigmaTyInvis ty+  | (tvs,  ty1) <- splitLHsForAllTyInvis ty+  , (ctxt, ty2) <- splitLHsQualTy ty1+  = (tvs, ctxt, ty2)++-- | Decompose a GADT type into its constituent parts.+-- Returns @(outer_bndrs, mb_ctxt, body)@, where:+--+-- * @outer_bndrs@ are 'HsOuterExplicit' if the type has explicit, outermost+--   type variable binders. Otherwise, they are 'HsOuterImplicit'.+--+-- * @mb_ctxt@ is @Just@ the context, if it is provided.+--   Otherwise, it is @Nothing@.+--+-- * @body@ is the body of the type after the optional @forall@s and context.+--+-- This function is careful not to look through parentheses.+-- See @Note [GADT abstract syntax] (Wrinkle: No nested foralls or contexts)@+-- "GHC.Hs.Decls" for why this is important.+splitLHsGadtTy ::+     LHsSigType GhcPs+  -> (HsOuterSigTyVarBndrs GhcPs, [HsForAllTelescope GhcPs], Maybe (LHsContext GhcPs), LHsType GhcPs)+splitLHsGadtTy (L _ sig_ty)+  | (outer_bndrs, sigma_ty) <- split_outer_bndrs sig_ty+  , (inner_bndrs, phi_ty)   <- split_inner_bndrs sigma_ty+  , (mb_ctxt, rho_ty)       <- splitLHsQualTy_KP phi_ty+  = case rho_ty of+      L _ (HsFunTy _ _ (L _ (XHsType HsRecTy{})) _) | not (null inner_bndrs)+        -- Bad! Record GADTs are not allowed to have inner_bndrs,+        -- undo the split to get a proper error message later+        -> (outer_bndrs, [], Nothing, sigma_ty)+      _ -> (outer_bndrs, inner_bndrs, mb_ctxt, rho_ty)+  where+    split_outer_bndrs :: HsSigType GhcPs -> (HsOuterSigTyVarBndrs GhcPs, LHsType GhcPs)+    split_outer_bndrs (HsSig{sig_bndrs = outer_bndrs, sig_body = body_ty}) =+      (outer_bndrs, body_ty)++    split_inner_bndrs :: LHsType GhcPs -> ([HsForAllTelescope GhcPs], LHsType GhcPs)+    split_inner_bndrs (L _ HsForAllTy { hst_tele = tele+                                      , hst_body = body })+      = let ~(teles, t) = split_inner_bndrs body+        in (tele:teles, t)+    split_inner_bndrs t = ([], t)++-- | Decompose a type of the form @forall <tvs>. body@ into its constituent+-- parts. Only splits type variable binders that+-- were quantified invisibly (e.g., @forall a.@, with a dot).+--+-- This function is used to split apart certain types, such as instance+-- declaration types, which disallow visible @forall@s. For instance, if GHC+-- split apart the @forall@ in @instance forall a -> Show (Blah a)@, then that+-- declaration would mistakenly be accepted!+--+-- Note that this function looks through parentheses, so it will work on types+-- such as @(forall a. <...>)@. The downside to this is that it is not+-- generally possible to take the returned types and reconstruct the original+-- type (parentheses and all) from them.+-- Unlike 'splitLHsSigmaTyInvis', this function does not look through+-- parentheses, hence the suffix @_KP@ (short for \"Keep Parentheses\").+splitLHsForAllTyInvis ::+  LHsType (GhcPass pass) -> ( [LHsTyVarBndr Specificity (GhcPass pass)]+                            , LHsType (GhcPass pass))+splitLHsForAllTyInvis ty+  | ((mb_tvbs), body) <- splitLHsForAllTyInvis_KP (ignoreParens ty)+  = (fromMaybe [] mb_tvbs, body)++-- | Decompose a type of the form @forall <tvs>. body@ into its constituent+-- parts. Only splits type variable binders that+-- were quantified invisibly (e.g., @forall a.@, with a dot).+--+-- This function is used to split apart certain types, such as instance+-- declaration types, which disallow visible @forall@s. For instance, if GHC+-- split apart the @forall@ in @instance forall a -> Show (Blah a)@, then that+-- declaration would mistakenly be accepted!+--+-- Unlike 'splitLHsForAllTyInvis', this function does not look through+-- parentheses, hence the suffix @_KP@ (short for \"Keep Parentheses\").+splitLHsForAllTyInvis_KP ::+  LHsType (GhcPass pass) -> (Maybe ([LHsTyVarBndr Specificity (GhcPass pass)])+                            , LHsType (GhcPass pass))+splitLHsForAllTyInvis_KP lty@(L _ ty) =+  case ty of+    HsForAllTy { hst_tele = HsForAllInvis {hsf_invis_bndrs = tvs }+               , hst_body = body }+      -> (Just tvs, body)+    _ -> (Nothing, lty)++-- | Decompose a type of the form @context => body@ into its constituent parts.+--+-- Note that this function looks through parentheses, so it will work on types+-- such as @(context => <...>)@. The downside to this is that it is not+-- generally possible to take the returned types and reconstruct the original+-- type (parentheses and all) from them.+splitLHsQualTy :: LHsType (GhcPass pass)+               -> (Maybe (LHsContext (GhcPass pass)), LHsType (GhcPass pass))+splitLHsQualTy ty+  | (mb_ctxt, body) <- splitLHsQualTy_KP (ignoreParens ty)+  = (mb_ctxt, body)++-- | Decompose a type of the form @context => body@ into its constituent parts.+--+-- Unlike 'splitLHsQualTy', this function does not look through+-- parentheses, hence the suffix @_KP@ (short for \"Keep Parentheses\").+splitLHsQualTy_KP :: LHsType (GhcPass pass) -> (Maybe (LHsContext (GhcPass pass)), LHsType (GhcPass pass))+splitLHsQualTy_KP (L _ (HsQualTy { hst_ctxt = ctxt, hst_body = body }))+                       = (Just ctxt, body)+splitLHsQualTy_KP body = (Nothing, body)++-- | Decompose a type class instance type (of the form+-- @forall <tvs>. context => instance_head@) into its constituent parts.+-- Note that the @[Name]@s returned correspond to either:+--+-- * The implicitly bound type variables (if the type lacks an outermost+--   @forall@), or+--+-- * The explicitly bound type variables (if the type has an outermost+--   @forall@).+--+-- This function is careful not to look through parentheses.+-- See @Note [No nested foralls or contexts in instance types]@+-- for why this is important.+splitLHsInstDeclTy :: LHsSigType GhcRn+                   -> ([Name], Maybe (LHsContext GhcRn), LHsType GhcRn)+splitLHsInstDeclTy (L _ (HsSig{sig_bndrs = outer_bndrs, sig_body = inst_ty})) =+  (hsOuterTyVarNames outer_bndrs, mb_cxt, body_ty)+  where+    (mb_cxt, body_ty) = splitLHsQualTy_KP inst_ty++-- | Decompose a type class instance type (of the form+-- @forall <tvs>. context => instance_head@) into the @instance_head@.+getLHsInstDeclHead :: LHsSigType (GhcPass p) -> LHsType (GhcPass p)+getLHsInstDeclHead (L _ (HsSig{sig_body = qual_ty}))+  | (_mb_cxt, body_ty) <- splitLHsQualTy_KP qual_ty+  = body_ty++-- | Decompose a type class instance type (of the form+-- @forall <tvs>. context => instance_head@) into the @instance_head@ and+-- retrieve the underlying class type constructor (if it exists).+getLHsInstDeclClass_maybe :: (Anno (IdOccGhcP p) ~ SrcSpanAnnN)+                          => LHsSigType (GhcPass p)+                          -> Maybe (LocatedN (IdOccP (GhcPass p)))+-- Works on (LHsSigType GhcPs)+getLHsInstDeclClass_maybe inst_ty+  = do { let head_ty = getLHsInstDeclHead inst_ty+       ; hsTyGetAppHead_maybe head_ty+       }++{-+Note [No nested foralls or contexts in instance types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The type at the top of an instance declaration is one of the few places in GHC+where nested `forall`s or contexts are not permitted, even with RankNTypes+enabled. For example, the following will be rejected:++  instance forall a. forall b. Show (Either a b) where ...+  instance Eq a => Eq b => Show (Either a b) where ...+  instance (forall a. Show (Maybe a)) where ...+  instance (Eq a => Show (Maybe a)) where ...++This restriction is partly motivated by an unusual quirk of instance+declarations. Namely, if ScopedTypeVariables is enabled, then the type+variables from the top of an instance will scope over the bodies of the+instance methods, /even if the type variables are implicitly quantified/.+For example, GHC will accept the following:++  instance Monoid a => Monoid (Identity a) where+    mempty = Identity (mempty @a)++Moreover, the type in the top of an instance declaration must obey the+forall-or-nothing rule (see Note [forall-or-nothing rule]).+If instance types allowed nested `forall`s, this could+result in some strange interactions. For example, consider the following:++  class C a where+    m :: Proxy a+  instance (forall a. C (Either a b)) where+    m = Proxy @(Either a b)++Somewhat surprisingly, old versions of GHC would accept the instance above.+Even though the `forall` only quantifies `a`, the outermost parentheses mean+that the `forall` is nested, and per the forall-or-nothing rule, this means+that implicit quantification would occur. Therefore, the `a` is explicitly+bound and the `b` is implicitly bound. Moreover, ScopedTypeVariables would+bring /both/ sorts of type variables into scope over the body of `m`.+How utterly confusing!++To avoid this sort of confusion, we simply disallow nested `forall`s in+instance types, which makes things like the instance above become illegal.+For the sake of consistency, we also disallow nested contexts, even though they+don't have the same strange interaction with ScopedTypeVariables.++Just as we forbid nested `forall`s and contexts in normal instance+declarations, we also forbid them in SPECIALISE instance pragmas (#18455).+Unlike normal instance declarations, ScopedTypeVariables don't have any impact+on SPECIALISE instance pragmas, but we use the same validity checks for+SPECIALISE instance pragmas anyway to be consistent.++-----+-- Wrinkle: Derived instances+-----++`deriving` clauses and standalone `deriving` declarations also permit bringing+type variables into scope, either through explicit or implicit quantification.+Unlike in the tops of instance declarations, however, one does not need to+enable ScopedTypeVariables for this to take effect.++Just as GHC forbids nested `forall`s in the top of instance declarations, it+also forbids them in types involved with `deriving`:++1. In the `via` types in DerivingVia. For example, this is rejected:++     deriving via (forall x. V x) instance C (S x)++   Just like the types in instance declarations, `via` types can also bring+   both implicitly and explicitly bound type variables into scope. As a result,+   we adopt the same no-nested-`forall`s rule in `via` types to avoid confusing+   behavior like in the example below:++     deriving via (forall x. T x y) instance W x y (Foo a b)+     -- Both x and y are brought into scope???+2. In the classes in `deriving` clauses. For example, this is rejected:++     data T = MkT deriving (C1, (forall x. C2 x y))++   This is because the generated instance would look like:++     instance forall x y. C2 x y T where ...++   So really, the same concerns as instance declarations apply here as well.+-}++{-+************************************************************************+*                                                                      *+                FieldOcc+*                                                                      *+************************************************************************++Note [Ambiguous FieldOcc in record updates]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When renaming a "record field update" (`some_record{ field = expr }`), the field+occurrence may be ambiguous if there are multiple record types with that same+field label in scope. Instead of failing, we may attempt to do type-directed+disambiguation: if we typecheck the record field update, we can disambiguate+the `field` based on the record and field type.++In practice, this means an identifier of a field occurrence+(`FieldOcc`) may have to go straight from `RdrName` to `Id`, since field+ambiguity makes it impossible to construct a `Name` for the field.++Since type-directed disambiguation is a GHC property rather than a property of+the GHC-Haskell AST, we still parameterise a `FieldOcc` occurrence by `IdP p`,+but in the case of the ambiguity we do the unthinkable and insert a mkUnboundName+in the name. Very bad, yes, but since type-directed disambiguation is on the way+out (see proposal https://github.com/ghc-proposals/ghc-proposals/pull/366),+we consider this acceptable for now.++see also Wrinkle [Disambiguating fields] and note [Type-directed record disambiguation]++NB: FieldOcc preserves the RdrName throughout its lifecycle for+exact printing purposes.+-}++type instance XCFieldOcc GhcPs = NoExtField -- RdrName is stored in the proper IdP field+type instance XCFieldOcc GhcRn = RdrName+type instance XCFieldOcc GhcTc = RdrName++type instance XXFieldOcc (GhcPass p) = DataConCantHappen++--------------------------------------------------------------------------------++mkFieldOcc :: LocatedN RdrName -> FieldOcc GhcPs+mkFieldOcc rdr = FieldOcc noExtField rdr++fieldOccRdrName :: forall p. IsPass p => FieldOcc (GhcPass p) -> RdrName+fieldOccRdrName fo = case ghcPass @p of+  GhcPs -> unLoc $ foLabel fo+  GhcRn -> foExt fo+  GhcTc -> foExt fo++-- ToDo SPJ: remove+--fieldOccExt :: FieldOcc (GhcPass p) -> XCFieldOcc (GhcPass p)+--fieldOccExt (FieldOcc { foExt = ext }) = ext++fieldOccLRdrName :: forall p. IsPass p => FieldOcc (GhcPass p) -> LocatedN RdrName+fieldOccLRdrName fo = case ghcPass @p of+  GhcPs -> foLabel fo+  GhcRn -> case fo of+    FieldOcc rdr sel ->+      let (L l _) = sel+       in L l rdr+  GhcTc ->+    let (L l _) = foLabel fo+     in L l (foExt fo)+++{-+************************************************************************+*                                                                      *+                OpName+*                                                                      *+************************************************************************+-}++-- | Name of an operator in an operator application or section+data OpName = NormalOp (WithUserRdr Name) -- ^ A normal identifier+            | NegateOp                    -- ^ Prefix negation+            | UnboundOp RdrName           -- ^ An unbound identifier+            | RecFldOp (FieldOcc GhcRn)   -- ^ A record field occurrence++instance Outputable OpName where+  ppr (NormalOp n)   = ppr n+  ppr NegateOp       = ppr negateName+  ppr (UnboundOp uv) = ppr uv+  ppr (RecFldOp fld) = ppr fld++{-+************************************************************************+*                                                                      *+\subsection{Pretty printing}+*                                                                      *+************************************************************************+-}++instance OutputableBndrId p => Outputable (HsBndrVar (GhcPass p)) where+  ppr (HsBndrVar _ name) = ppr name+  ppr (HsBndrWildCard _) = char '_'++class OutputableBndrFlag flag p where+  pprTyVarBndr :: OutputableBndrId p => HsTyVarBndr flag (GhcPass p) -> SDoc++instance OutputableBndrFlag () p where+  pprTyVarBndr (HsTvb _ _ bvar bkind) = decorate (ppr_hs_tvb bvar bkind)+    where decorate :: SDoc -> SDoc+          decorate d = parens_if_kind bkind d++instance OutputableBndrFlag Specificity p where+  pprTyVarBndr (HsTvb _ spec bvar bkind) = decorate (ppr_hs_tvb bvar bkind)+    where decorate :: SDoc -> SDoc+          decorate d = case spec of+            InferredSpec  -> braces d+            SpecifiedSpec -> parens_if_kind bkind d++instance OutputableBndrFlag (HsBndrVis (GhcPass p')) p where+  pprTyVarBndr (HsTvb _ bvis bvar bkind) = decorate (ppr_hs_tvb bvar bkind)+    where decorate :: SDoc -> SDoc+          decorate d = case bvis of+            HsBndrRequired  _ -> parens_if_kind bkind d+            HsBndrInvisible _ -> char '@' <> parens_if_kind bkind d++instance OutputableBndrFlag ForAllTyFlag p where+  pprTyVarBndr (HsTvb _ spec bvar bkind) =+      text "forall" <+> decorate (ppr_hs_tvb bvar bkind)+    where decorate :: SDoc -> SDoc+          decorate d = case spec of+            Inferred  -> braces d <> dot+            Specified -> parens_if_kind bkind d <> dot+            Required  -> parens_if_kind bkind d <+> text "->"++ppr_hs_tvb :: OutputableBndrId p => HsBndrVar (GhcPass p) -> HsBndrKind (GhcPass p) -> SDoc+ppr_hs_tvb bvar (HsBndrNoKind _) = ppr bvar+ppr_hs_tvb bvar (HsBndrKind _ k) = hsep [ppr bvar, dcolon, ppr k]++parens_if_kind :: HsBndrKind (GhcPass p) -> SDoc -> SDoc+parens_if_kind (HsBndrNoKind _) d = d+parens_if_kind (HsBndrKind _ _) d = parens d++instance OutputableBndrId p => Outputable (HsSigType (GhcPass p)) where+    ppr (HsSig { sig_bndrs = outer_bndrs, sig_body = body }) =+      pprHsOuterSigTyVarBndrs outer_bndrs <+> ppr body++instance OutputableBndrId p => Outputable (HsType (GhcPass p)) where+    ppr ty = pprHsType ty++instance OutputableBndrId p+       => Outputable (LHsQTyVars (GhcPass p)) where+    ppr (HsQTvs { hsq_explicit = tvs }) = interppSP tvs++instance (OutputableBndrFlag flag p,+          OutputableBndrFlag flag (NoGhcTcPass p),+          OutputableBndrId p)+       => Outputable (HsOuterTyVarBndrs flag (GhcPass p)) where+    ppr (HsOuterImplicit{hso_ximplicit = imp_tvs}) =+      text "HsOuterImplicit:" <+> case ghcPass @p of+        GhcPs -> ppr imp_tvs+        GhcRn -> ppr imp_tvs+        GhcTc -> ppr imp_tvs+    ppr (HsOuterExplicit{hso_bndrs = exp_tvs}) =+      text "HsOuterExplicit:" <+> ppr exp_tvs++instance OutputableBndrId p+       => Outputable (HsForAllTelescope (GhcPass p)) where+    ppr (HsForAllVis { hsf_vis_bndrs = bndrs }) =+      text "HsForAllVis:" <+> ppr bndrs+    ppr (HsForAllInvis { hsf_invis_bndrs = bndrs }) =+      text "HsForAllInvis:" <+> ppr bndrs++instance (OutputableBndrId p, OutputableBndrFlag flag p)+       => Outputable (HsTyVarBndr flag (GhcPass p)) where+    ppr = pprTyVarBndr++instance Outputable thing+       => Outputable (HsWildCardBndrs (GhcPass p) thing) where+    ppr (HsWC { hswc_body = ty }) = ppr ty++instance (OutputableBndrId p)+       => Outputable (HsPatSigType (GhcPass p)) where+    ppr (HsPS { hsps_body = ty }) = ppr ty+++instance (OutputableBndrId p)+       => Outputable (HsTyPat (GhcPass p)) where+    ppr (HsTP { hstp_body = ty }) = ppr ty+++instance (OutputableBndrId p)+       => Outputable (HsTyLit (GhcPass p)) where+    ppr = ppr_tylit++instance Outputable HsIPName where+    ppr (HsIPName n) = char '?' <> ftext n -- Ordinary implicit parameters++instance OutputableBndr HsIPName where+    pprBndr _ n   = ppr n         -- Simple for now+    pprInfixOcc  n = ppr n+    pprPrefixOcc n = ppr n++instance (Outputable arg, Outputable rec)+         => Outputable (HsConDetails arg rec) where+  ppr (PrefixCon args) = text "PrefixCon:" <+> ppr args+  ppr (RecCon rec)     = text "RecCon:" <+> ppr rec+  ppr (InfixCon l r)   = text "InfixCon:" <+> ppr [l, r]++pprHsConDeclFieldWith :: (OutputableBndrId p)+                      => (HsMultAnn (GhcPass p) -> SDoc -> SDoc)+                      -> HsConDeclField (GhcPass p) -> SDoc+pprHsConDeclFieldWith ppr_mult (CDF _ prag mark mult ty doc) =+  pprMaybeWithDoc doc (ppr_mult mult (ppr prag <+> ppr mark <> ppr ty))++pprHsConDeclFieldNoMult :: (OutputableBndrId p) => HsConDeclField (GhcPass p) -> SDoc+pprHsConDeclFieldNoMult = pprHsConDeclFieldWith (\_ d -> d)++hsPlainTypeField :: LHsType GhcPs -> HsConDeclField GhcPs+hsPlainTypeField = mkConDeclField (HsUnannotated (EpColon noAnn))++mkConDeclField :: HsMultAnn GhcPs -> LHsType GhcPs -> HsConDeclField GhcPs+mkConDeclField mult (L _ (HsDocTy _ ty lds)) = (mkConDeclField mult ty) { cdf_doc = Just lds }+mkConDeclField mult (L _ (XHsType (HsBangTy ann (HsSrcBang srcTxt unp str) t))) = CDF (ann, srcTxt) unp str mult t Nothing+mkConDeclField mult t = CDF noAnn NoSrcUnpack NoSrcStrict mult t Nothing++instance Outputable (XRecGhc (IdGhcP p)) =>+       Outputable (FieldOcc (GhcPass p)) where+  ppr = ppr . foLabel++instance (OutputableBndrId pass) => OutputableBndr (FieldOcc (GhcPass pass)) where+  pprInfixOcc  = pprInfixOcc . unXRec @(GhcPass pass) . foLabel+  pprPrefixOcc = pprPrefixOcc . unXRec @(GhcPass pass) . foLabel++instance (OutputableBndrId pass) => OutputableBndr (GenLocated SrcSpan (FieldOcc (GhcPass pass))) where+  pprInfixOcc  = pprInfixOcc . unLoc+  pprPrefixOcc = pprPrefixOcc . unLoc++ppr_tylit :: (HsTyLit (GhcPass p)) -> SDoc+ppr_tylit (HsNumTy source i) = pprWithSourceText source (integer i)+ppr_tylit (HsStrTy source s) = pprWithSourceText source (text (show s))+ppr_tylit (HsCharTy source c) = pprWithSourceText source (text (show c))++pprAnonWildCard :: SDoc+pprAnonWildCard = char '_'++-- | Prints the explicit @forall@ in a type family equation if one is written.+-- If there is no explicit @forall@, nothing is printed.+pprHsOuterFamEqnTyVarBndrs :: OutputableBndrId p+                           => HsOuterFamEqnTyVarBndrs (GhcPass p) -> SDoc+pprHsOuterFamEqnTyVarBndrs (HsOuterImplicit{}) = empty+pprHsOuterFamEqnTyVarBndrs (HsOuterExplicit{hso_bndrs = qtvs}) =+  forAllLit <+> interppSP qtvs <> dot++-- | Prints the outermost @forall@ in a type signature if one is written.+-- If there is no outermost @forall@, nothing is printed.+pprHsOuterSigTyVarBndrs :: OutputableBndrId p+                        => HsOuterSigTyVarBndrs (GhcPass p) -> SDoc+pprHsOuterSigTyVarBndrs (HsOuterImplicit{}) = empty+pprHsOuterSigTyVarBndrs (HsOuterExplicit{hso_bndrs = bndrs}) =+  pprHsForAllTelescope (mkHsForAllInvisTele noAnn bndrs)++-- | Prints a forall; When passed an empty list, prints @forall .@/@forall ->@+-- only when @-dppr-debug@ is enabled.+pprHsForAll :: forall p. OutputableBndrId p+            => HsForAllTelescope (GhcPass p)+            -> Maybe (LHsContext (GhcPass p)) -> SDoc+pprHsForAll tele cxt+  = pprHsForAllTelescope tele <+> pprLHsContext cxt++pprHsForAllTelescope :: forall p. OutputableBndrId p+                     => HsForAllTelescope (GhcPass p)+                     -> SDoc+pprHsForAllTelescope tele =+  case tele of+      HsForAllVis   { hsf_vis_bndrs   = qtvs } -> pp_forall (space <> arrow) qtvs+      HsForAllInvis { hsf_invis_bndrs = qtvs } -> pp_forall dot qtvs+  where+    pp_forall :: forall flag p. (OutputableBndrId p, OutputableBndrFlag flag p)+              => SDoc -> [LHsTyVarBndr flag (GhcPass p)] -> SDoc+    pp_forall separator qtvs+      | null qtvs = whenPprDebug (forAllLit <> separator)+  -- Note: to fix the PprRecordDotSyntax1 ppr roundtrip test, the <>+  -- below needs to be <+>. But it means 94 other test results need to+  -- be updated to match.+      | otherwise = forAllLit <+> interppSP qtvs <> separator++pprLHsContext :: (OutputableBndrId p)+              => Maybe (LHsContext (GhcPass p)) -> SDoc+pprLHsContext Nothing = empty+pprLHsContext (Just lctxt) = pprLHsContextAlways lctxt++-- For use in a HsQualTy, which always gets printed if it exists.+pprLHsContextAlways :: (OutputableBndrId p)+                    => LHsContext (GhcPass p) -> SDoc+pprLHsContextAlways (L _ ctxt)+  = case ctxt of+      []       -> parens empty             <+> darrow+      [L _ ty] -> ppr_mono_ty ty           <+> darrow+      _        -> parens (interpp'SP ctxt) <+> darrow++pprHsConDeclRecFields :: forall p. OutputableBndrId p+                 => [LHsConDeclRecField (GhcPass p)] -> SDoc+pprHsConDeclRecFields fields = braces (sep (punctuate comma (map ppr fields)))++-- Printing works more-or-less as for Types++pprHsType :: (OutputableBndrId p) => HsType (GhcPass p) -> SDoc+pprHsType ty = ppr_mono_ty ty++ppr_mono_lty :: OutputableBndrId p+             => LHsType (GhcPass p) -> SDoc+ppr_mono_lty ty = ppr_mono_ty (unLoc ty)++ppr_mono_ty :: forall p. (OutputableBndrId p) => HsType (GhcPass p) -> SDoc+ppr_mono_ty (HsForAllTy { hst_tele = tele, hst_body = ty })+  = sep [pprHsForAll tele Nothing, ppr_mono_lty ty]++ppr_mono_ty (HsQualTy { hst_ctxt = ctxt, hst_body = ty })+  = sep [pprLHsContextAlways ctxt, ppr_mono_lty ty]++ppr_mono_ty (HsTyVar _ prom (L _ name)) = pprOccWithTick Prefix prom name+ppr_mono_ty (HsFunTy _ mult ty1 ty2)    = ppr_fun_ty mult ty1 ty2+ppr_mono_ty (HsTupleTy _ con tys)+    -- Special-case unary boxed tuples so that they are pretty-printed as+    -- `Solo x`, not `(x)`+  | [ty] <- tys+  , BoxedTuple <- std_con+  = sep [text (mkTupleStr Boxed tcName 1), ppr_mono_lty ty]+  | otherwise+  = tupleParens std_con (pprWithCommas ppr tys)+  where std_con = case con of+                    HsUnboxedTuple -> UnboxedTuple+                    _              -> BoxedTuple+ppr_mono_ty (HsSumTy _ tys)+  = tupleParens UnboxedTuple (pprWithBars ppr tys)+ppr_mono_ty (HsKindSig _ ty kind)+  = ppr_mono_lty ty <+> dcolon <+> ppr kind+ppr_mono_ty (HsListTy _ ty)       = brackets (ppr_mono_lty ty)+ppr_mono_ty (HsIParamTy _ n ty)   = (ppr n <+> dcolon <+> ppr_mono_lty ty)+ppr_mono_ty (HsSpliceTy ext s)    =+    case ghcPass @p of+      GhcPs -> pprUntypedSplice True Nothing s+      GhcRn | HsUntypedSpliceNested n <- ext -> pprUntypedSplice True (Just n) s+      GhcRn | HsUntypedSpliceTop _ t  <- ext -> ppr t+      GhcTc -> pprUntypedSplice True Nothing s+ppr_mono_ty (HsExplicitListTy _ prom tys)+  | isPromoted prom = quote $ brackets (maybeAddSpace tys $ interpp'SP tys)+  | otherwise       = brackets (interpp'SP tys)+ppr_mono_ty (HsExplicitTupleTy _ prom tys)+    -- Special-case unary boxed tuples so that they are pretty-printed as+    -- `'MkSolo x`, not `'(x)`+  | [ty] <- tys+  = quote_tuple prom $ sep [text (mkTupleStr Boxed dataName 1), ppr_mono_lty ty]+  | otherwise+  = quote_tuple prom $ parens (maybeAddSpace tys $ interpp'SP tys)+ppr_mono_ty (HsTyLit _ t)       = ppr t+ppr_mono_ty (HsWildCardTy {})   = char '_'++ppr_mono_ty (HsStarTy _ isUni)  = char (if isUni then '★' else '*')++ppr_mono_ty (HsAppTy _ fun_ty arg_ty)+  = hsep [ppr_mono_lty fun_ty, ppr_mono_lty arg_ty]+ppr_mono_ty (HsAppKindTy _ ty k)+  = ppr_mono_lty ty <+> char '@' <> ppr_mono_lty k+ppr_mono_ty (HsOpTy _ prom ty1 (L _ op) ty2)+  = sep [ ppr_mono_lty ty1+        , sep [pprOccWithTick Infix prom op, ppr_mono_lty ty2 ] ]+ppr_mono_ty (HsParTy _ ty)+  = parens (ppr_mono_lty ty)+  -- Put the parens in where the user did+  -- But we still use the precedence stuff to add parens because+  --    toHsType doesn't put in any HsParTys, so we may still need them++ppr_mono_ty (HsDocTy _ ty doc)+  = pprWithDoc doc $ ppr_mono_lty ty++ppr_mono_ty (XHsType t) = case ghcPass @p of+  GhcPs -> case t of+    HsCoreTy ty     -> ppr ty+    HsBangTy _ b ty -> ppr b <> ppr_mono_lty ty+    HsRecTy _ flds  -> pprHsConDeclRecFields flds+  GhcRn -> ppr t++--------------------------+ppr_fun_ty :: (OutputableBndrId p)+           => HsMultAnn (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) -> SDoc+ppr_fun_ty mult ty1 ty2+  = let p1 = ppr_mono_lty ty1+        p2 = ppr_mono_lty ty2+        arr = pprHsArrow mult+    in+    sep [p1, arr <+> p2]++quote_tuple :: PromotionFlag -> SDoc -> SDoc+quote_tuple IsPromoted  doc = quote doc+quote_tuple NotPromoted doc = doc++--------------------------+-- | @'hsTypeNeedsParens' p t@ returns 'True' if the type @t@ needs parentheses+-- under precedence @p@.+hsTypeNeedsParens :: forall p. IsPass p => PprPrec -> HsType (GhcPass p) -> Bool+hsTypeNeedsParens p = go_hs_ty+  where+    go_hs_ty (HsForAllTy{})           = p >= funPrec+    go_hs_ty (HsQualTy{})             = p >= funPrec+    go_hs_ty (HsTyVar{})              = False+    go_hs_ty (HsFunTy{})              = p >= funPrec+    -- Special-case unary boxed tuple applications so that they are+    -- parenthesized as `Identity (Solo x)`, not `Identity Solo x` (#18612)+    -- See Note [One-tuples] in GHC.Builtin.Types+    go_hs_ty (HsTupleTy _ con [_])+      = case con of+          HsBoxedOrConstraintTuple   -> p >= appPrec+          HsUnboxedTuple             -> False+    go_hs_ty (HsTupleTy{})            = False+    go_hs_ty (HsSumTy{})              = False+    go_hs_ty (HsKindSig{})            = p >= sigPrec+    go_hs_ty (HsListTy{})             = False+    go_hs_ty (HsIParamTy{})           = p > topPrec+    go_hs_ty (HsSpliceTy{})           = False+    go_hs_ty (HsExplicitListTy{})     = False+    -- Special-case unary boxed tuple applications so that they are+    -- parenthesized as `Proxy ('MkSolo x)`, not `Proxy 'MkSolo x` (#18612)+    -- See Note [One-tuples] in GHC.Builtin.Types+    go_hs_ty (HsExplicitTupleTy _ _ [_])+                                      = p >= appPrec+    go_hs_ty (HsExplicitTupleTy{})    = False+    go_hs_ty (HsTyLit{})              = False+    go_hs_ty (HsWildCardTy{})         = False+    go_hs_ty (HsStarTy{})             = p >= starPrec+    go_hs_ty (HsAppTy{})              = p >= appPrec+    go_hs_ty (HsAppKindTy{})          = p >= appPrec+    go_hs_ty (HsOpTy{})               = p >= opPrec+    go_hs_ty (HsParTy{})              = False+    go_hs_ty (HsDocTy _ (L _ t) _)    = go_hs_ty t+    go_hs_ty (XHsType t)             = case ghcPass @p of+      GhcPs -> case t of+        HsCoreTy ty -> go_core_ty ty+        HsBangTy{}  -> p > topPrec+        HsRecTy{}   -> False+      GhcRn -> go_core_ty t++    go_core_ty (TyVarTy{})    = False+    go_core_ty (AppTy{})      = p >= appPrec+    go_core_ty (TyConApp _ args)+      | null args             = False+      | otherwise             = p >= appPrec+    go_core_ty (ForAllTy{})   = p >= funPrec+    go_core_ty (FunTy{})      = p >= funPrec+    go_core_ty (LitTy{})      = False+    go_core_ty (CastTy t _)   = go_core_ty t+    go_core_ty (CoercionTy{}) = False++maybeAddSpace :: [LHsType (GhcPass p)] -> SDoc -> SDoc+-- See Note [Printing promoted type constructors]+-- in GHC.Iface.Type.  This code implements the same+-- logic for printing HsType+maybeAddSpace tys doc+  | (ty : _) <- tys+  , lhsTypeHasLeadingPromotionQuote ty = space <> doc+  | otherwise                          = doc++lhsTypeHasLeadingPromotionQuote :: LHsType (GhcPass p) -> Bool+lhsTypeHasLeadingPromotionQuote ty+  = goL ty+  where+    goL (L _ ty) = go ty++    go (HsForAllTy{})        = False+    go (HsQualTy{ hst_ctxt = ctxt, hst_body = body})+      | (L _ (c:_)) <- ctxt = goL c+      | otherwise            = goL body+    go (HsTyVar _ p _)       = isPromoted p+    go (HsFunTy _ _ arg _)   = goL arg+    go (HsListTy{})          = False+    go (HsTupleTy{})         = False+    go (HsSumTy{})           = False+    go (HsOpTy _ _ t1 _ _)   = goL t1+    go (HsKindSig _ t _)     = goL t+    go (HsIParamTy{})        = False+    go (HsSpliceTy{})        = False+    go (HsExplicitListTy _ p _) = isPromoted p+    go (HsExplicitTupleTy{}) = True+    go (HsTyLit{})           = False+    go (HsWildCardTy{})      = False+    go (HsStarTy{})          = False+    go (HsAppTy _ t _)       = goL t+    go (HsAppKindTy _ t _)   = goL t+    go (HsParTy{})           = False+    go (HsDocTy _ t _)       = goL t+    go (XHsType{})           = False++-- | @'parenthesizeHsType' p ty@ checks if @'hsTypeNeedsParens' p ty@ is+-- true, and if so, surrounds @ty@ with an 'HsParTy'. Otherwise, it simply+-- returns @ty@.+parenthesizeHsType :: IsPass p => PprPrec -> LHsType (GhcPass p) -> LHsType (GhcPass p)+parenthesizeHsType p lty@(L loc ty)+  | hsTypeNeedsParens p ty = L loc (HsParTy noAnn lty)+  | otherwise              = lty++-- | @'parenthesizeHsContext' p ctxt@ checks if @ctxt@ is a single constraint+-- @c@ such that @'hsTypeNeedsParens' p c@ is true, and if so, surrounds @c@+-- with an 'HsParTy' to form a parenthesized @ctxt@. Otherwise, it simply+-- returns @ctxt@ unchanged.+parenthesizeHsContext :: IsPass p => PprPrec -> LHsContext (GhcPass p) -> LHsContext (GhcPass p)+parenthesizeHsContext p lctxt@(L loc ctxt) =+  case ctxt of+    [c] -> L loc [parenthesizeHsType p c]+    _   -> lctxt -- Other contexts are already "parenthesized" by virtue of+                 -- being tuples.+{-+************************************************************************+*                                                                      *+\subsection{Anno instances}+*                                                                      *+************************************************************************+-}++type instance Anno [LocatedA (HsType (GhcPass p))] = SrcSpanAnnC+type instance Anno (HsType (GhcPass p)) = SrcSpanAnnA+type instance Anno (HsSigType (GhcPass p)) = SrcSpanAnnA+type instance Anno (HsKind (GhcPass p)) = SrcSpanAnnA++type instance Anno (HsTyVarBndr _flag (GhcPass _)) = SrcSpanAnnA+  -- Explicit pass Anno instances needed because of the NoGhcTc field+type instance Anno (HsTyVarBndr _flag GhcPs) = SrcSpanAnnA+type instance Anno (HsTyVarBndr _flag GhcRn) = SrcSpanAnnA+type instance Anno (HsTyVarBndr _flag GhcTc) = SrcSpanAnnA++type instance Anno (HsOuterTyVarBndrs _ (GhcPass _)) = SrcSpanAnnA+type instance Anno HsIPName = EpAnnCO+type instance Anno (HsConDeclRecField (GhcPass p)) = SrcSpanAnnA++type instance Anno (FieldOcc (GhcPass p)) = SrcSpanAnnA
GHC/Hs/Utils.hs view
@@ -1,1625 +1,1882 @@ {-# LANGUAGE ConstraintKinds #-}-{-|-Module      : GHC.Hs.Utils-Description : Generic helpers for the HsSyn type.-Copyright   : (c) The University of Glasgow, 1992-2006--Here we collect a variety of helper functions that construct or-analyse HsSyn.  All these functions deal with generic HsSyn; functions-which deal with the instantiated versions are located elsewhere:--   Parameterised by          Module-   ----------------          --------------   GhcPs/RdrName             GHC.Parser.PostProcess-   GhcRn/Name                GHC.Rename.*-   GhcTc/Id                  GHC.Tc.Utils.Zonk--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 #-}--{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}--module GHC.Hs.Utils(-  -- * Terms-  mkHsPar, mkHsApp, mkHsAppWith, mkHsApps, mkHsAppsWith,-  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, mkHsWrapPatCo,-  mkLHsPar, mkHsCmdWrap, mkLHsCmdWrap,-  mkHsCmdIf, mkConLikeTc,--  nlHsTyApp, nlHsTyApps, nlHsVar, nl_HsVar, nlHsDataCon,-  nlHsLit, nlHsApp, nlHsApps, nlHsSyntaxApps,-  nlHsIntLit, nlHsVarApps,-  nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList,-  mkLHsTupleExpr, mkLHsVarTuple, missingTupArg,-  mkLocatedList,--  -- * Constructing general big tuples-  -- $big_tuples-  mkChunkified, chunkify,--  -- * Bindings-  mkFunBind, mkVarBind, mkHsVarBind, mkSimpleGeneratedFunBind, mkTopFunBind,-  mkPatSynBind,-  isInfixFunBind,-  spanHsLocaLBinds,--  -- * Literals-  mkHsIntegral, mkHsFractional, mkHsIsString, mkHsString, 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,--  -- * Template Haskell-  mkUntypedSplice, mkTypedSplice,-  mkHsQuasiQuote,--  -- * Collecting binders-  isUnliftedHsBind, isBangedHsBind,--  collectLocalBinders, collectHsValBinders, collectHsBindListBinders,-  collectHsIdBinders,-  collectHsBindsBinders, collectHsBindBinders, collectMethodBinders,--  collectPatBinders, collectPatsBinders,-  collectLStmtsBinders, collectStmtsBinders,-  collectLStmtBinders, collectStmtBinders,-  CollectPass(..), CollectFlag(..),--  hsLTyClDeclBinders, hsTyClForeignBinders,-  hsPatSynSelectors, getPatSynBinds,-  hsForeignDeclsBinders, hsGroupBinders, hsDataFamInstBinders,--  -- * Collecting implicit binders-  lStmtsImplicits, hsValBindsImplicits, lPatImplicits-  ) where--import GHC.Prelude--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.Extension-import GHC.Hs.Extension-import GHC.Parser.Annotation--import GHC.Tc.Types.Evidence-import GHC.Core.TyCo.Rep-import GHC.Core.Multiplicity ( pattern Many )-import GHC.Builtin.Types ( unitTy )-import GHC.Tc.Utils.TcType-import GHC.Core.DataCon-import GHC.Core.ConLike-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.Data.Bag-import GHC.Settings.Constants--import GHC.Utils.Misc-import GHC.Utils.Outputable-import GHC.Utils.Panic--import Data.Either-import Data.Function-import Data.List ( partition, deleteBy )--{--************************************************************************-*                                                                      *-        Some useful helpers for constructing syntax-*                                                                      *-************************************************************************--These functions attempt to construct a not-completely-useless 'SrcSpan'-from their components, compared with the @nl*@ functions below which-just attach 'noSrcSpan' to everything.--}---- | @e => (e)@-mkHsPar :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)-mkHsPar e = L (getLoc e) (gHsPar e)--mkSimpleMatch :: (Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))-                        ~ SrcSpanAnnA,-                  Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))-                        ~ SrcAnn NoEpAnns)-              => HsMatchContext (GhcPass p)-              -> [LPat (GhcPass p)] -> LocatedA (body (GhcPass p))-              -> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))-mkSimpleMatch ctxt pats rhs-  = L loc $-    Match { m_ext = noAnn, m_ctxt = ctxt, m_pats = 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))))-                     ~ SrcAnn NoEpAnns-               => SrcSpan -> LocatedA (body (GhcPass p)) -> EpAnn GrhsAnn-               -> GRHSs (GhcPass p) (LocatedA (body (GhcPass p)))-unguardedGRHSs loc rhs an-  = GRHSs emptyComments (unguardedRHS an loc rhs) emptyLocalBinds--unguardedRHS :: Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))-                     ~ SrcAnn NoEpAnns-             => EpAnn GrhsAnn -> SrcSpan -> LocatedA (body (GhcPass p))-             -> [LGRHS (GhcPass p) (LocatedA (body (GhcPass p)))]-unguardedRHS an loc rhs = [L (noAnnSrcSpan loc) (GRHS an [] rhs)]--type AnnoBody p body-  = ( XMG (GhcPass p) (LocatedA (body (GhcPass p))) ~ NoExtField-    , Anno [LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))] ~ SrcSpanAnnL-    , Anno (Match (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcSpanAnnA-    )--mkMatchGroup :: AnnoBody p body-             => Origin-             -> LocatedL [LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))]-             -> MatchGroup (GhcPass p) (LocatedA (body (GhcPass p)))-mkMatchGroup origin matches = MG { mg_ext = noExtField-                                 , mg_alts = matches-                                 , mg_origin = origin }--mkLamCaseMatchGroup :: AnnoBody p body-                    => Origin-                    -> LamCaseVariant-                    -> LocatedL [LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))]-                    -> MatchGroup (GhcPass p) (LocatedA (body (GhcPass p)))-mkLamCaseMatchGroup origin lc_variant (L l matches)-  = mkMatchGroup origin (L l $ map fixCtxt matches)-  where fixCtxt (L a match) = L a match{m_ctxt = LamCaseAlt lc_variant}--mkLocatedList :: Semigroup a-  => [GenLocated (SrcAnn a) e2] -> LocatedAn an [GenLocated (SrcAnn a) e2]-mkLocatedList [] = noLocA []-mkLocatedList ms = L (noAnnSrcSpan $ locA $ combineLocsA (head ms) (last ms)) ms--mkHsApp :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)-mkHsApp e1 e2 = addCLocAA e1 e2 (HsApp noComments 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 noAnn e1 e2)--mkHsApps-  :: LHsExpr (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)-mkHsApps = mkHsAppsWith addCLocAA--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 = addCLocAA t_body e (HsAppType noExtField e paren_wct)-  where-    t_body    = hswc_body t-    paren_wct = t { hswc_body = parenthesizeHsType appPrec t_body }--mkHsAppTypes :: LHsExpr GhcRn -> [LHsWcType GhcRn] -> LHsExpr GhcRn-mkHsAppTypes = foldl' mkHsAppType--mkHsLam :: (IsPass p, XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ NoExtField)-        => [LPat (GhcPass p)]-        -> LHsExpr (GhcPass p)-        -> LHsExpr (GhcPass p)-mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam noExtField matches))-  where-    matches = mkMatchGroup Generated-                           (noLocA [mkSimpleMatch LambdaExpr pats' body])-    pats' = map (parenthesizePat appPrec) pats--mkHsLams :: [TyVar] -> [EvVar] -> LHsExpr GhcTc -> LHsExpr GhcTc-mkHsLams tyvars dicts expr = mkLHsWrap (mkWpTyLams tyvars-                                       <.> mkWpLams dicts) expr---- |A simple case alternative with a single pattern, no binds, no guards;--- pre-typechecking-mkHsCaseAlt :: (Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))-                     ~ SrcAnn 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 pat expr-  = mkSimpleMatch CaseAlt [pat] expr--nlHsTyApp :: Id -> [Type] -> LHsExpr GhcTc-nlHsTyApp fun_id tys-  = noLocA (mkHsWrap (mkWpTyApps tys) (HsVar noExtField (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 :: LPat (GhcPass name) -> LPat (GhcPass name)-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 -> LocatedL [ExprLStmt GhcPs] -> HsExpr GhcPs-mkHsDoAnns     :: HsDoFlavour -> LocatedL [ExprLStmt GhcPs] -> EpAnn AnnList -> HsExpr GhcPs-mkHsComp       :: HsDoFlavour -> [ExprLStmt GhcPs] -> LHsExpr GhcPs-               -> HsExpr GhcPs-mkHsCompAnns   :: HsDoFlavour -> [ExprLStmt GhcPs] -> LHsExpr GhcPs-               -> EpAnn AnnList-               -> HsExpr GhcPs--mkNPat      :: LocatedAn NoEpAnns (HsOverLit GhcPs) -> Maybe (SyntaxExpr GhcPs) -> EpAnn [AddEpAnn]-            -> Pat GhcPs-mkNPlusKPat :: LocatedN RdrName -> LocatedAn NoEpAnns (HsOverLit GhcPs) -> EpAnn EpaLocation-            -> 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 :: EpAnn [AddEpAnn] -> 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)]-                        ~ SrcSpanAnnL)-                 => StmtLR (GhcPass idL) GhcPs bodyR-emptyRecStmtName :: (Anno [GenLocated-                             (Anno (StmtLR GhcRn GhcRn bodyR))-                             (StmtLR GhcRn GhcRn bodyR)]-                        ~ SrcSpanAnnL)-                 => StmtLR GhcRn GhcRn bodyR-emptyRecStmtId   :: Stmt GhcTc (LocatedA (HsCmd GhcTc))-mkRecStmt        :: (Anno [GenLocated-                             (Anno (StmtLR (GhcPass idL) GhcPs bodyR))-                             (StmtLR (GhcPass idL) GhcPs bodyR)]-                        ~ SrcSpanAnnL)-                 => EpAnn AnnList-                 -> LocatedL [LStmtLR (GhcPass idL) GhcPs bodyR]-                 -> StmtLR (GhcPass idL) GhcPs bodyR---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 anns = mkHsDoAnns ctxt (mkLocatedList (stmts ++ [last_stmt])) anns-  where-    -- Strip the annotations from the location, they are in the embedded expr-    last_stmt = L (noAnnSrcSpan $ getLocA expr) $ mkLastStmt expr---- restricted to GhcPs because other phases might need a SyntaxExpr-mkHsIf :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> EpAnn 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 -> EpAnn 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    :: EpAnn [AddEpAnn] -> [ExprLStmt GhcPs] -> LHsExpr GhcPs-                   -> StmtLR GhcPs GhcPs (LHsExpr GhcPs)-mkTransformByStmt  :: EpAnn [AddEpAnn] -> [ExprLStmt GhcPs] -> LHsExpr GhcPs-                   -> LHsExpr GhcPs -> StmtLR GhcPs GhcPs (LHsExpr GhcPs)-mkGroupUsingStmt   :: EpAnn [AddEpAnn] -> [ExprLStmt GhcPs] -> LHsExpr GhcPs-                   -> StmtLR GhcPs GhcPs (LHsExpr GhcPs)-mkGroupByUsingStmt :: EpAnn [AddEpAnn] -> [ExprLStmt GhcPs] -> LHsExpr GhcPs-                   -> LHsExpr GhcPs-                   -> StmtLR GhcPs GhcPs (LHsExpr GhcPs)--emptyTransStmt :: EpAnn [AddEpAnn] -> 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 = Many,-                                                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-mkRecStmt anns stmts  = (emptyRecStmt' anns) { recS_stmts = stmts }--mkLetStmt :: EpAnn [AddEpAnn] -> 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 noAnn e1 (noLocA (HsVar noExtField (noLocA op))) e2--unqualSplice :: RdrName-unqualSplice = mkRdrUnqual (mkVarOccFS (fsLit "splice"))--mkUntypedSplice :: EpAnn [AddEpAnn] -> SpliceDecoration -> LHsExpr GhcPs -> HsSplice GhcPs-mkUntypedSplice ann hasParen e = HsUntypedSplice ann hasParen unqualSplice e--mkTypedSplice :: EpAnn [AddEpAnn] -> SpliceDecoration -> LHsExpr GhcPs -> HsSplice GhcPs-mkTypedSplice ann hasParen e = HsTypedSplice ann hasParen unqualSplice e--mkHsQuasiQuote :: RdrName -> SrcSpan -> FastString -> HsSplice GhcPs-mkHsQuasiQuote quoter span quote-  = HsQuasiQuote noExtField unqualSplice quoter span quote--mkHsString :: String -> HsLit (GhcPass p)-mkHsString s = HsString NoSourceText (mkFastString 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 (HsVar noExtField (noLocA n))--nl_HsVar :: IsSrcSpanAnn p a-        => IdP (GhcPass p) -> HsExpr (GhcPass p)-nl_HsVar n = HsVar noExtField (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 noComments n)--nlHsIntLit :: Integer -> LHsExpr (GhcPass p)-nlHsIntLit n = noLocA (HsLit noComments (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 noComments f (mkLHsPar x))--nlHsSyntaxApps :: SyntaxExprTc -> [LHsExpr GhcTc]-               -> LHsExpr GhcTc-nlHsSyntaxApps (SyntaxExprTc { syn_expr      = fun-                             , syn_arg_wraps = arg_wraps-                             , syn_res_wrap  = res_wrap }) args-  = mkLHsWrap res_wrap (foldl' nlHsApp (noLocA fun) (zipWithEqual "nlHsSyntaxApps"-                                                     mkLHsWrap arg_wraps args))-nlHsSyntaxApps NoSyntaxExprTc args = pprPanic "nlHsSyntaxApps" (ppr args)-  -- this function should never be called in scenarios where there is no-  -- syntax expr--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 (HsVar noExtField (noLocA f))-                                         (map ((HsVar noExtField) . noLocA) xs))-                 where-                   mk f a = HsApp noComments (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 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  :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)-nlHsCase :: LHsExpr GhcPs -> [LMatch GhcPs (LHsExpr GhcPs)]-         -> LHsExpr GhcPs-nlList   :: [LHsExpr GhcPs] -> LHsExpr GhcPs---- AZ:Is this used?-nlHsLam match = noLocA (HsLam noExtField (mkMatchGroup Generated (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 (noLocA matches)))-nlList exprs          = noLocA (ExplicitList noAnn exprs)--nlHsAppTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)-nlHsTyVar :: IsSrcSpanAnn p a-          => PromotionFlag -> IdP (GhcPass p)           -> LHsType (GhcPass p)-nlHsFunTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)-nlHsParTy :: LHsType (GhcPass p)                        -> LHsType (GhcPass p)--nlHsAppTy f t = noLocA (HsAppTy noExtField f (parenthesizeHsType appPrec t))-nlHsTyVar p x = noLocA (HsTyVar noAnn p (noLocA x))-nlHsFunTy a b = noLocA (HsFunTy noAnn (HsUnrestrictedArrow noHsUniTok) (parenthesizeHsType funPrec a) b)-nlHsParTy t   = noLocA (HsParTy noAnn t)--nlHsTyConApp :: IsSrcSpanAnn p a-             => PromotionFlag-             -> LexicalFixity -> IdP (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 noAnn prom ty1 (noLocA tycon) ty2) rest-  | otherwise-  = foldl' mk_app (nlHsTyVar prom tycon) tys-  where-    mk_app :: LHsType (GhcPass p) -> LHsTypeArg (GhcPass p) -> LHsType (GhcPass p)-    mk_app fun@(L _ (HsOpTy {})) arg = mk_app (noLocA $ HsParTy noAnn fun) arg-      -- parenthesize things like `(A + B) C`-    mk_app fun (HsValArg ty) = noLocA (HsAppTy noExtField fun (parenthesizeHsType appPrec ty))-    mk_app fun (HsTypeArg _ ki) = noLocA (HsAppKindTy noSrcSpan fun (parenthesizeHsType appPrec ki))-    mk_app fun (HsArgPar _) = noLocA (HsParTy noAnn fun)--nlHsAppKindTy ::-  LHsType (GhcPass p) -> LHsKind (GhcPass p) -> LHsType (GhcPass p)-nlHsAppKindTy f k-  = noLocA (HsAppKindTy noSrcSpan f (parenthesizeHsType appPrec k))--{--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 noAnn) 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 EpaLocation -> HsTupArg GhcPs-missingTupArg ann = Missing ann--mkLHsPatTup :: [LPat GhcRn] -> LPat GhcRn-mkLHsPatTup []     = noLocA $ TuplePat noExtField [] Boxed-mkLHsPatTup [lpat] = lpat-mkLHsPatTup lpats  = L (getLoc (head lpats)) $ 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---- $big_tuples--- #big_tuples#------ 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).------ 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 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 = take mAX_TUPLE_SIZE xs : split (drop mAX_TUPLE_SIZE xs)--{--************************************************************************-*                                                                      *-        LHsSigType and LHsSigWcType-*                                                                      *-********************************************************************* -}---- | Convert an 'LHsType' to an 'LHsSigType'.-hsTypeToHsSigType :: LHsType GhcPs -> LHsSigType GhcPs-hsTypeToHsSigType lty@(L loc ty) = L loc $ case ty of-  HsForAllTy { hst_tele = HsForAllInvis { hsf_xinvis = an-                                        , hsf_invis_bndrs = bndrs }-             , hst_body = body }-    -> mkHsExplicitSigType an bndrs body-  _ -> mkHsImplicitSigType lty---- | 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--{- *********************************************************************-*                                                                      *-    --------- 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 $ HsWrap 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--mkHsWrapPatCo :: TcCoercionN -> Pat GhcTc -> Type -> Pat GhcTc-mkHsWrapPatCo co pat ty | isTcReflCo 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-            , fun_tick = [] }--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-                                    , fun_tick = [] }--mkHsVarBind :: SrcSpan -> RdrName -> LHsExpr GhcPs -> LHsBind GhcPs-mkHsVarBind loc var rhs = mkSimpleGeneratedFunBind loc var [] rhs--mkVarBind :: IdP (GhcPass p) -> LHsExpr (GhcPass p) -> LHsBind (GhcPass p)-mkVarBind var rhs = L (getLoc rhs) $-                    VarBind { var_ext = noExtField,-                              var_id = var, var_rhs = rhs }--mkPatSynBind :: LocatedN RdrName -> HsPatSynDetails GhcPs-             -> LPat GhcPs -> HsPatSynDir GhcPs -> EpAnn [AddEpAnn] -> 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 :: forall id1 id2. UnXRec id2 => HsBindLR id1 id2 -> Bool-isInfixFunBind (FunBind { fun_matches = MG _ matches _ })-  = any (isInfixMatch . unXRec @id2) (unXRec @id2 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 $ bagToList 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 (bagToList . 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 -> [LPat GhcPs]-                -> LHsExpr GhcPs -> LHsBind GhcPs-mkSimpleGeneratedFunBind loc fun pats expr-  = L (noAnnSrcSpan loc) $ mkFunBind Generated (L (noAnnSrcSpan loc) fun)-              [mkMatch (mkPrefixFunRhs (L (noAnnSrcSpan loc) fun)) pats expr-                       emptyLocalBinds]---- | Make a prefix, non-strict function 'HsMatchContext'-mkPrefixFunRhs :: LIdP p -> HsMatchContext p-mkPrefixFunRhs n = FunRhs { mc_fun = n-                          , mc_fixity = Prefix-                          , mc_strictness = NoSrcStrict }---------------mkMatch :: forall p. IsPass p-        => HsMatchContext (GhcPass p)-        -> [LPat (GhcPass p)]-        -> LHsExpr (GhcPass p)-        -> HsLocalBinds (GhcPass p)-        -> LMatch (GhcPass p) (LHsExpr (GhcPass p))-mkMatch ctxt pats expr binds-  = noLocA (Match { m_ext   = noAnn-                  , m_ctxt  = ctxt-                  , m_pats  = map mkParPat 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 [Unlifted id check in isUnliftedHsBind]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The function isUnliftedHsBind is used to complain if we make a top-level-binding for a variable of unlifted type.--Such a binding is illegal if the top-level binding would be unlifted;-but also if the local letrec generated by desugaring AbsBinds would be.-E.g.-      f :: Num a => (# a, a #)-      g :: Num a => a -> a-      f = ...g...-      g = ...g...--The top-level bindings for f,g are not unlifted (because of the Num a =>),-but the local, recursive, monomorphic bindings are:--      t = /\a \(d:Num a).-         letrec fm :: (# a, a #) = ...g...-                gm :: a -> a = ...f...-         in (fm, gm)--Here the binding for 'fm' is illegal.  So generally we check the abe_mono types.--BUT we have a special case when abs_sig is true;-  see Note [The abs_sig field of AbsBinds] in GHC.Hs.Binds--}------------------- Bindings ------------------------------ | Should we treat this as an unlifted bind? This will be true for any--- bind that binds an unlifted variable, but we must be careful around--- AbsBinds. See Note [Unlifted id check in isUnliftedHsBind]. For usage--- information, see Note [Strict binds checks] is GHC.HsToCore.Binds.-isUnliftedHsBind :: HsBind GhcTc -> Bool  -- works only over typechecked binds-isUnliftedHsBind bind-  | XHsBindsLR (AbsBinds { abs_exports = exports, abs_sig = has_sig }) <- bind-  = if has_sig-    then any (is_unlifted_id . abe_poly) exports-    else any (is_unlifted_id . abe_mono) exports-    -- 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 #)--  | otherwise-  = any is_unlifted_id (collectHsBindBinders CollNoDictBinders bind)-  where-    is_unlifted_id id = isUnliftedType (idType id)-      -- bindings always have a fixed RuntimeRep, so it's OK-      -- to call isUnliftedType here---- | Is a binding a strict variable or pattern bind (e.g. @!x = ...@)?-isBangedHsBind :: HsBind GhcTc -> Bool-isBangedHsBind (XHsBindsLR (AbsBinds { abs_binds = binds }))-  = anyBag (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-  :: CollectPass (GhcPass idL)-  => CollectFlag (GhcPass idL)-  -> [LStmtLR (GhcPass idL) (GhcPass idR) body]-  -> [IdP (GhcPass idL)]-collectLStmtsBinders flag = concatMap (collectLStmtBinders flag)--collectStmtsBinders-  :: CollectPass (GhcPass idL)-  => CollectFlag (GhcPass idL)-  -> [StmtLR (GhcPass idL) (GhcPass idR) body]-  -> [IdP (GhcPass idL)]-collectStmtsBinders flag = concatMap (collectStmtBinders flag)--collectLStmtBinders-  :: CollectPass (GhcPass idL)-  => CollectFlag (GhcPass idL)-  -> LStmtLR (GhcPass idL) (GhcPass idR) body-  -> [IdP (GhcPass idL)]-collectLStmtBinders flag = collectStmtBinders flag . unLoc--collectStmtBinders-  :: 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 _ _ <- xs, s <- ss]-    TransStmt { trS_stmts = stmts } -> collectLStmtsBinders flag stmts-    RecStmt { recS_stmts = L _ ss } -> collectLStmtsBinders flag ss-    ApplicativeStmt _ args _        -> concatMap collectArgBinders args-        where-         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 have to be collected.------ This type is used as a boolean (should we collect evidence binders or not?)--- but also to pass an evidence that the AST has been typechecked when we do--- want to collect evidence binders, otherwise these binders are not available.------ 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_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-  SumPat _ pat _ _      -> collect_lpat flag pat bndrs-  LitPat _ _            -> bndrs-  NPat {}               -> bndrs-  NPlusKPat _ n _ _ _ _ -> unXRec @p n : bndrs-  SigPat _ pat _        -> collect_lpat flag pat bndrs-  XPat ext              -> collectXXPat @p flag ext bndrs-  SplicePat _ (HsSpliced _ _ (HsSplicedPat pat))-                        -> collect_pat flag pat bndrs-  SplicePat _ _         -> 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))--collectEvBinders :: TcEvBinds -> [Id]-collectEvBinders (EvBinds bs)   = foldr 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??----- | 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]--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.Utils.Zonk---{--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 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 (foExt . unLoc) fs----------------------hsLTyClDeclBinders :: IsPass p-                   => LocatedA (TyClDecl (GhcPass p))-                   -> ([LocatedA (IdP (GhcPass p))], [LFieldOcc (GhcPass p)])--- ^ Returns all the /binding/ names of the decl.  The first one is--- guaranteed to be the name of the decl. The first component--- represents all binding names except record fields; the second--- represents field occurrences. For record fields mentioned in--- multiple constructors, the SrcLoc will be from the first occurrence.------ Each returned (Located name) has a SrcSpan for the /whole/ declaration.--- See Note [SrcSpan for binders]--hsLTyClDeclBinders (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 :: 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 [] . unionManyBags $ 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)) <- bagToList lbinds ]----------------------hsLInstDeclBinders :: IsPass p-                   => LInstDecl (GhcPass p)-                   -> ([LocatedA (IdP (GhcPass p))], [LFieldOcc (GhcPass p)])-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 :: IsPass p-                     => DataFamInstDecl (GhcPass p)-                     -> ([LocatedA (IdP (GhcPass p))], [LFieldOcc (GhcPass 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-                  => HsDataDefn (GhcPass p)-                  -> ([LocatedA (IdP (GhcPass p))], [LFieldOcc (GhcPass p)])-hsDataDefnBinders (HsDataDefn { dd_cons = cons })-  = hsConDeclsBinders cons-  -- See Note [Binders in family instances]----------------------type Seen p = [LFieldOcc (GhcPass p)] -> [LFieldOcc (GhcPass p)]-                 -- Filters out ones that have already been seen--hsConDeclsBinders :: forall p. IsPass p-                  => [LConDecl (GhcPass p)]-                  -> ([LocatedA (IdP (GhcPass p))], [LFieldOcc (GhcPass p)])-   -- See hsLTyClDeclBinders for what this does-   -- The function is boringly complicated because of the records-   -- And since we only have equality, we have to be a little careful-hsConDeclsBinders cons-  = go id cons-  where-    go :: Seen p -> [LConDecl (GhcPass p)]-       -> ([LocatedA (IdP (GhcPass p))], [LFieldOcc (GhcPass p)])-    go _ [] = ([], [])-    go remSeen (r:rs)-      -- Don't re-mangle the location of field names, because we don't-      -- have a record of the full location of the field declaration anyway-      = let loc = getLoc r-        in case unLoc r of-           -- remove only the first occurrence of any seen field in order to-           -- avoid circumventing detection of duplicate fields (#9156)-           ConDeclGADT { con_names = names, con_g_args = args }-             -> (map (L loc . unLoc) names ++ ns, flds ++ fs)-             where-                (remSeen', flds) = get_flds_gadt remSeen args-                (ns, fs) = go remSeen' rs--           ConDeclH98 { con_name = name, con_args = args }-             -> ([L loc (unLoc name)] ++ ns, flds ++ fs)-             where-                (remSeen', flds) = get_flds_h98 remSeen args-                (ns, fs) = go remSeen' rs--    get_flds_h98 :: Seen p -> HsConDeclH98Details (GhcPass p)-                 -> (Seen p, [LFieldOcc (GhcPass p)])-    get_flds_h98 remSeen (RecCon flds) = get_flds remSeen flds-    get_flds_h98 remSeen _ = (remSeen, [])--    get_flds_gadt :: Seen p -> HsConDeclGADTDetails (GhcPass p)-                  -> (Seen p, [LFieldOcc (GhcPass p)])-    get_flds_gadt remSeen (RecConGADT flds _) = get_flds remSeen flds-    get_flds_gadt remSeen _ = (remSeen, [])--    get_flds :: Seen p -> LocatedL [LConDeclField (GhcPass p)]-             -> (Seen p, [LFieldOcc (GhcPass p)])-    get_flds remSeen flds = (remSeen', fld_names)-       where-          fld_names = remSeen (concatMap (cd_fld_names . unLoc) (unLoc flds))-          remSeen' = foldr (.) remSeen-                               [deleteBy ((==) `on` unLoc . foLabel . unLoc) v-                               | v <- fld_names]--{---Note [SrcSpan for binders]-~~~~~~~~~~~~~~~~~~~~~~~~~~-When extracting the (Located RdrNme) for a binder, at least for the-main name (the TyCon of a type declaration etc), we want to give it-the @SrcSpan@ of the whole /declaration/, not just the name itself-(which is how it appears in the syntax tree).  This SrcSpan (for the-entire declaration) is used as the SrcSpan for the Name that is-finally produced, and hence for error messages.  (See #8607.)--Note [Binders in family instances]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In a type or data family instance declaration, the type-constructor is an *occurrence* not a binding site-    type instance T Int = Int -> Int   -- No binders-    data instance S Bool = S1 | S2     -- Binders are S1,S2---************************************************************************-*                                                                      *-        Collecting binders the user did not write-*                                                                      *-************************************************************************--The job of this family of functions is to run through binding sites and find the set of all Names-that were defined "implicitly", without being explicitly written by the user.--The main purpose is to find names introduced by record wildcards so that we can avoid-warning the user when they don't use those names (#4404)--Since the addition of -Wunused-record-wildcards, this function returns a pair-of [(SrcSpan, [Name])]. Each element of the list is one set of implicit-binders, the first component of the tuple is the document describes the possible-fix to the problem (by removing the ..).--This means there is some unfortunate coupling between this function and where it-is used but it's only used for one specific purpose in one place so it seemed-easier.--}--lStmtsImplicits :: [LStmtLR GhcRn (GhcPass idR) (LocatedA (body (GhcPass idR)))]-                -> [(SrcSpan, [Name])]-lStmtsImplicits = hs_lstmts-  where-    hs_lstmts :: [LStmtLR GhcRn (GhcPass idR) (LocatedA (body (GhcPass idR)))]-              -> [(SrcSpan, [Name])]-    hs_lstmts = concatMap (hs_stmt . unLoc)--    hs_stmt :: StmtLR GhcRn (GhcPass idR) (LocatedA (body (GhcPass idR)))-            -> [(SrcSpan, [Name])]-    hs_stmt (BindStmt _ pat _) = lPatImplicits pat-    hs_stmt (ApplicativeStmt _ args _) = concatMap do_arg args-      where do_arg (_, ApplicativeArgOne { app_arg_pattern = pat }) = lPatImplicits pat-            do_arg (_, ApplicativeArgMany { app_stmts = stmts }) = hs_lstmts stmts-    hs_stmt (LetStmt _ binds)     = hs_local_binds binds-    hs_stmt (BodyStmt {})         = []-    hs_stmt (LastStmt {})         = []-    hs_stmt (ParStmt _ xs _ _)    = hs_lstmts [s | ParStmtBlock _ ss _ _ <- xs-                                                , s <- ss]-    hs_stmt (TransStmt { trS_stmts = stmts }) = hs_lstmts stmts-    hs_stmt (RecStmt { recS_stmts = L _ ss }) = hs_lstmts ss--    hs_local_binds (HsValBinds _ val_binds) = hsValBindsImplicits val_binds-    hs_local_binds (HsIPBinds {})           = []-    hs_local_binds (EmptyLocalBinds _)      = []--hsValBindsImplicits :: HsValBindsLR GhcRn (GhcPass idR) -> [(SrcSpan, [Name])]-hsValBindsImplicits (XValBindsLR (NValBinds binds _))-  = concatMap (lhsBindsImplicits . snd) binds-hsValBindsImplicits (ValBinds _ binds _)-  = lhsBindsImplicits binds--lhsBindsImplicits :: LHsBindsLR GhcRn idR -> [(SrcSpan, [Name])]-lhsBindsImplicits = foldBag (++) (lhs_bind . unLoc) []-  where-    lhs_bind (PatBind { pat_lhs = lpat }) = lPatImplicits lpat-    lhs_bind _ = []--lPatImplicits :: LPat GhcRn -> [(SrcSpan, [Name])]-lPatImplicits = hs_lpat-  where-    hs_lpat lpat = hs_pat (unLoc lpat)--    hs_lpats = foldr (\pat rest -> hs_lpat pat ++ rest) []--    hs_pat (LazyPat _ pat)      = hs_lpat pat-    hs_pat (BangPat _ pat)      = hs_lpat pat-    hs_pat (AsPat _ _ pat)      = hs_lpat pat-    hs_pat (ViewPat _ _ pat)    = hs_lpat pat-    hs_pat (ParPat _ _ pat _)   = hs_lpat pat-    hs_pat (ListPat _ pats)     = hs_lpats pats-    hs_pat (TuplePat _ pats _)  = hs_lpats pats--    hs_pat (SigPat _ pat _)     = hs_lpat pat--    hs_pat (ConPat {pat_con=con, pat_args=ps}) = details con ps--    hs_pat _ = []--    details :: LocatedN Name -> HsConPatDetails GhcRn -> [(SrcSpan, [Name])]-    details _ (PrefixCon _ ps) = hs_lpats ps-    details n (RecCon fs)      =-      [(err_loc, collectPatsBinders CollNoDictBinders implicit_pats) | Just{} <- [rec_dotdot fs] ]-        ++ hs_lpats explicit_pats--      where implicit_pats = map (hfbRHS . unLoc) implicit-            explicit_pats = map (hfbRHS . unLoc) explicit---            (explicit, implicit) = partitionEithers [if pat_explicit then Left fld else Right fld-                                                    | (i, fld) <- [0..] `zip` rec_flds fs-                                                    ,  let  pat_explicit =-                                                              maybe True ((i<) . unLoc)-                                                                         (rec_dotdot fs)]-            err_loc = maybe (getLocA n) getLoc (rec_dotdot fs)--    details _ (InfixCon p1 p2) = hs_lpat p1 ++ hs_lpat p2+{-# LANGUAGE TupleSections   #-}++{-|+Module      : GHC.Hs.Utils+Description : Generic helpers for the HsSyn type.+Copyright   : (c) The University of Glasgow, 1992-2023++Here we collect a variety of helper functions that construct or+analyse HsSyn.  All these functions deal with generic HsSyn; functions+which deal with the instantiated versions are located elsewhere:++   Parameterised by          Module+   ----------------          -------------+   GhcPs/RdrName             GHC.Parser.PostProcess+   GhcRn/Name                GHC.Rename.*+   GhcTc/Id                  GHC.Tc.Zonk.Type++The @mk*@ functions attempt to construct a not-completely-useless SrcSpan+from their components, compared with the @nl*@ functions which+just attach noSrcSpan to everything.++-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE NamedFieldPuns #-}++{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}+{-# LANGUAGE RecordWildCards #-}++module GHC.Hs.Utils(+  -- * Terms+  mkHsPar, mkHsApp, mkHsAppWith, mkHsApps, mkHsAppsWith, mkHsSyntaxApps,+  mkHsAppType, mkHsAppTypes, mkHsCaseAlt,+  mkSimpleMatch, unguardedGRHSs, unguardedRHS,+  mkMatchGroup, mkLamCaseMatchGroup, mkMatch, mkPrefixFunRhs, mkHsLam, mkHsIf,+  mkHsWrap, mkLHsWrap, mkHsWrapCo, mkHsWrapCoR, mkLHsWrapCo,+  mkHsDictLet, mkHsLams,+  mkHsOpApp, mkHsDo, mkHsDoAnns, mkHsComp, mkHsCompAnns,+  mkHsWrapPat, mkLHsWrapPat, mkHsWrapPatCo,+  mkLHsPar, mkHsCmdWrap, mkLHsCmdWrap,+  mkHsCmdIf, mkConLikeTc,++  nlHsTyApp, nlHsTyApps, nlHsVar, nlHsDataCon,+  nlHsLit, nlHsApp, nlHsApps, nlHsSyntaxApps,+  nlHsIntLit, nlHsVarApps,+  nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList,+  mkLHsTupleExpr, mkLHsVarTuple, missingTupArg,+  mkLocatedList, nlAscribe,++  forgetUserRdr, noUserRdr,++  -- * Bindings+  mkFunBind, mkVarBind, mkHsVarBind, mkSimpleGeneratedFunBind, mkTopFunBind,+  mkPatSynBind,+  isInfixFunBind,+  spanHsLocaLBinds,++  -- * Literals+  mkHsIntegral, mkHsFractional, mkHsIsString, mkHsString, mkHsStringFS, mkHsStringPrimLit,+  mkHsCharPrimLit,++  -- * Patterns+  mkNPat, mkNPlusKPat, nlVarPat, nlLitPat, nlConVarPat, nlConVarPatName, nlConPat,+  nlConPatName, nlInfixConPat, nlNullaryConPat, nlWildConPat, nlWildPat,+  nlWildPatName, nlTuplePat, mkParPat, nlParPat,+  mkBigLHsVarTup, mkBigLHsTup, mkBigLHsVarPatTup, mkBigLHsPatTup,++  -- * Types+  mkHsAppTy, mkHsAppKindTy,+  hsTypeToHsSigType, hsTypeToHsSigWcType, mkClassOpSigs, mkHsSigEnv,+  nlHsAppTy, nlHsAppKindTy, nlHsTyVar, nlHsFunTy, nlHsParTy, nlHsTyConApp,++  -- * Stmts+  mkTransformStmt, mkTransformByStmt, mkBodyStmt,+  mkPsBindStmt, mkRnBindStmt, mkTcBindStmt,+  mkLastStmt,+  emptyTransStmt, mkGroupUsingStmt, mkGroupByUsingStmt,+  emptyRecStmt, emptyRecStmtName, emptyRecStmtId, mkRecStmt,+  unitRecStmtTc,+  mkLetStmt,++  -- * Collecting binders+  isUnliftedHsBind, isUnliftedHsBinds, isBangedHsBind,++  collectLocalBinders, collectHsValBinders, collectHsBindListBinders,+  collectHsIdBinders,+  collectHsBindsBinders, collectHsBindBinders, collectMethodBinders,++  collectPatBinders, collectPatsBinders,+  collectLStmtsBinders, collectStmtsBinders,+  collectLStmtBinders, collectStmtBinders,+  CollectPass(..), CollectFlag(..),++  TyDeclBinders(..), LConsWithFields(..),+  hsLTyClDeclBinders, hsTyClForeignBinders,+  hsPatSynSelectors, getPatSynBinds,+  hsForeignDeclsBinders, hsGroupBinders, hsDataFamInstBinders,++  -- * Collecting implicit binders+  ImplicitFieldBinders(..),+  lStmtsImplicits, hsValBindsImplicits, lPatImplicits,+  lHsRecFieldsImplicits+  ) where++import GHC.Prelude hiding (head, init, last, tail)++import GHC.Hs.Decls+import GHC.Hs.Binds+import GHC.Hs.Expr+import GHC.Hs.Pat+import GHC.Hs.Type+import GHC.Hs.Lit+import Language.Haskell.Syntax.Decls+import Language.Haskell.Syntax.Extension+import GHC.Hs.Extension+import GHC.Parser.Annotation++import GHC.Tc.Types.Evidence++import GHC.Core.Coercion( isReflCo )+import GHC.Core.Multiplicity ( pattern ManyTy )+import GHC.Core.DataCon+import GHC.Core.ConLike+import GHC.Core.Make   ( mkChunkified )+import GHC.Core.Type   ( Type, isUnliftedType )++import GHC.Builtin.Types ( unitTy, manyDataConTy )++import GHC.Types.Id+import GHC.Types.Name+import GHC.Types.Name.Set hiding ( unitFV )+import GHC.Types.Name.Env+import GHC.Types.Name.Reader+import GHC.Types.Var+import GHC.Types.Basic+import GHC.Types.SrcLoc+import GHC.Types.Fixity+import GHC.Types.SourceText++import GHC.Data.FastString++import GHC.Utils.Misc+import GHC.Utils.Outputable+import GHC.Utils.Panic++import Control.Arrow ( first )+import Data.Foldable ( toList )+import Data.List ( partition )+import Data.List.NonEmpty ( NonEmpty (..), nonEmpty )+import qualified Data.List.NonEmpty as NE++import Data.IntMap ( IntMap )+import qualified Data.IntMap.Strict as IntMap+import Data.Map ( Map )+import qualified Data.Map.Strict as Map++{-+************************************************************************+*                                                                      *+        Some useful helpers for constructing syntax+*                                                                      *+************************************************************************++These functions attempt to construct a not-completely-useless 'SrcSpan'+from their components, compared with the @nl*@ functions below which+just attach 'noSrcSpan' to everything.+-}++-- | @e => (e)@+mkHsPar :: IsPass p => LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)+mkHsPar e = L (getLoc e) (gHsPar e)++mkSimpleMatch :: (Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))+                        ~ SrcSpanAnnA,+                  Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))+                        ~ EpAnn NoEpAnns)+              => HsMatchContext (LIdP (NoGhcTc (GhcPass p)))+              -> LocatedE [LPat (GhcPass p)] -> LocatedA (body (GhcPass p))+              -> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))+mkSimpleMatch ctxt (L l pats) rhs+  = L loc $+    Match { m_ext = noExtField, m_ctxt = ctxt, m_pats = L l pats+          , m_grhss = unguardedGRHSs (locA loc) rhs noAnn }+  where+    loc = case pats of+                []      -> getLoc rhs+                (pat:_) -> combineSrcSpansA (getLoc pat) (getLoc rhs)++unguardedGRHSs :: Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))+                     ~ EpAnn NoEpAnns+               => SrcSpan -> LocatedA (body (GhcPass p)) -> EpAnn GrhsAnn+               -> GRHSs (GhcPass p) (LocatedA (body (GhcPass p)))+unguardedGRHSs loc rhs an+  = GRHSs emptyComments (unguardedRHS an loc rhs) emptyLocalBinds++unguardedRHS :: Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))+                     ~ EpAnn NoEpAnns+             => EpAnn GrhsAnn -> SrcSpan -> LocatedA (body (GhcPass p))+             -> NonEmpty (LGRHS (GhcPass p) (LocatedA (body (GhcPass p))))+unguardedRHS an loc rhs = NE.singleton $ L (noAnnSrcSpan loc) (GRHS an [] rhs)++type AnnoBody p body+  = ( XMG (GhcPass p) (LocatedA (body (GhcPass p))) ~ Origin+    , Anno [LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))] ~ SrcSpanAnnLW+    , Anno (Match (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcSpanAnnA+    )++mkMatchGroup :: AnnoBody p body+             => Origin+             -> LocatedLW [LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))]+             -> MatchGroup (GhcPass p) (LocatedA (body (GhcPass p)))+mkMatchGroup origin matches = MG { mg_ext = origin+                                 , mg_alts = matches }++mkLamCaseMatchGroup :: AnnoBody p body+                    => Origin+                    -> HsLamVariant+                    -> LocatedLW [LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))]+                    -> MatchGroup (GhcPass p) (LocatedA (body (GhcPass p)))+mkLamCaseMatchGroup origin lam_variant (L l matches)+  = mkMatchGroup origin (L l $ map fixCtxt matches)+  where fixCtxt (L a match) = L a match{m_ctxt = LamAlt lam_variant}++mkLocatedList :: (Semigroup a, NoAnn an)+  => [GenLocated (EpAnn a) e2] -> LocatedAn an [GenLocated (EpAnn a) e2]+mkLocatedList ms = case nonEmpty ms of+    Nothing -> noLocA []+    Just ms1 -> L (noAnnSrcSpan $ locA $ combineLocsA (NE.head ms1) (NE.last ms1)) ms++mkHsApp :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)+mkHsApp e1 e2 = addCLocA e1 e2 (HsApp noExtField e1 e2)++mkHsAppWith+  :: (LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> HsExpr (GhcPass id) -> LHsExpr (GhcPass id))+  -> LHsExpr (GhcPass id)+  -> LHsExpr (GhcPass id)+  -> LHsExpr (GhcPass id)+mkHsAppWith mkLocated e1 e2 = mkLocated e1 e2 (HsApp noExtField e1 e2)++mkHsApps+  :: LHsExpr (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)+mkHsApps = mkHsAppsWith addCLocA++mkHsAppsWith+ :: (LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> HsExpr (GhcPass id) -> LHsExpr (GhcPass id))+ -> LHsExpr (GhcPass id)+ -> [LHsExpr (GhcPass id)]+ -> LHsExpr (GhcPass id)+mkHsAppsWith mkLocated = foldl' (mkHsAppWith mkLocated)++mkHsAppType :: LHsExpr GhcRn -> LHsWcType GhcRn -> LHsExpr GhcRn+mkHsAppType e t = addCLocA t_body e (HsAppType noExtField e paren_wct)+  where+    t_body    = hswc_body t+    paren_wct = t { hswc_body = t_body }++mkHsAppTypes :: LHsExpr GhcRn -> [LHsWcType GhcRn] -> LHsExpr GhcRn+mkHsAppTypes = foldl' mkHsAppType++mkHsLam :: (IsPass p, XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ Origin)+        => LocatedE [LPat (GhcPass p)]+        -> LHsExpr (GhcPass p)+        -> LHsExpr (GhcPass p)+mkHsLam (L l pats) body = mkHsPar (L (getLoc body) (HsLam noAnn LamSingle matches))+  where+    matches = mkMatchGroup (Generated OtherExpansion SkipPmc)+                           (noLocA [mkSimpleMatch (LamAlt LamSingle) (L l pats') body])+    pats' = map (parenthesizePat appPrec) pats++mkHsLams :: [TyVar] -> [EvVar] -> LHsExpr GhcTc -> LHsExpr GhcTc+mkHsLams tyvars dicts expr = mkLHsWrap (mkWpTyLams tyvars+                                       <.> mkWpEvLams dicts) expr++mkHsSyntaxApps :: SrcSpanAnnA -> SyntaxExprTc -> [LHsExpr GhcTc]+               -> LHsExpr GhcTc+mkHsSyntaxApps ann (SyntaxExprTc { syn_expr      = fun+                                 , syn_arg_wraps = arg_wraps+                                 , syn_res_wrap  = res_wrap }) args+  = mkLHsWrap res_wrap (foldl' mkHsApp (L ann fun) (zipWithEqual mkLHsWrap arg_wraps args))+mkHsSyntaxApps _ NoSyntaxExprTc args = pprPanic "mkHsSyntaxApps" (ppr args)+  -- this function should never be called in scenarios where there is no+  -- syntax expr++-- |A simple case alternative with a single pattern, no binds, no guards;+-- pre-typechecking+mkHsCaseAlt :: (Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))+                     ~ EpAnn NoEpAnns,+                 Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))+                        ~ SrcSpanAnnA)+            => LPat (GhcPass p) -> (LocatedA (body (GhcPass p)))+            -> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))+mkHsCaseAlt (L l pat) expr+  = mkSimpleMatch CaseAlt (L (l2l l) [L l pat]) expr++nlHsTyApp :: Id -> [Type] -> LHsExpr GhcTc+nlHsTyApp fun_id tys+  = noLocA (mkHsWrap (mkWpTyApps tys) (mkHsVar (noLocA fun_id)))++nlHsTyApps :: Id -> [Type] -> [LHsExpr GhcTc] -> LHsExpr GhcTc+nlHsTyApps fun_id tys xs = foldl' nlHsApp (nlHsTyApp fun_id tys) xs++--------- Adding parens ---------+-- | Wrap in parens if @'hsExprNeedsParens' appPrec@ says it needs them+-- So @f x@ becomes @(f x)@, but @3@ stays as @3@.+mkLHsPar :: IsPass id => LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)+mkLHsPar = parenthesizeHsExpr appPrec++mkParPat :: IsPass p => LPat (GhcPass p) -> LPat (GhcPass p)+mkParPat = parenthesizePat appPrec++nlParPat :: IsPass p => LPat (GhcPass p) -> LPat (GhcPass p)+nlParPat p = noLocA (gParPat p)++-------------------------------+-- These are the bits of syntax that contain rebindable names+-- See GHC.Rename.Env.lookupSyntax++mkHsIntegral   :: IntegralLit -> HsOverLit GhcPs+mkHsFractional :: FractionalLit -> HsOverLit GhcPs+mkHsIsString   :: SourceText -> FastString -> HsOverLit GhcPs+mkHsDo         :: HsDoFlavour -> LocatedLW [ExprLStmt GhcPs] -> HsExpr GhcPs+mkHsDoAnns     :: HsDoFlavour -> LocatedLW [ExprLStmt GhcPs] -> AnnList EpaLocation -> HsExpr GhcPs+mkHsComp       :: HsDoFlavour -> [ExprLStmt GhcPs] -> LHsExpr GhcPs+               -> HsExpr GhcPs+mkHsCompAnns   :: HsDoFlavour -> [ExprLStmt GhcPs] -> LHsExpr GhcPs+               -> AnnList EpaLocation+               -> HsExpr GhcPs++mkNPat      :: LocatedAn NoEpAnns (HsOverLit GhcPs) -> Maybe (SyntaxExpr GhcPs) -> EpToken "-"+            -> Pat GhcPs+mkNPlusKPat :: LocatedN RdrName -> LocatedAn NoEpAnns (HsOverLit GhcPs) -> EpToken "+"+            -> Pat GhcPs++-- NB: The following functions all use noSyntaxExpr: the generated expressions+--     will not work with rebindable syntax if used after the renamer+mkLastStmt :: IsPass idR => LocatedA (bodyR (GhcPass idR))+           -> StmtLR (GhcPass idL) (GhcPass idR) (LocatedA (bodyR (GhcPass idR)))+mkBodyStmt :: LocatedA (bodyR GhcPs)+           -> StmtLR (GhcPass idL) GhcPs (LocatedA (bodyR GhcPs))+mkPsBindStmt :: EpUniToken "<-" "←" -> LPat GhcPs -> LocatedA (bodyR GhcPs)+             -> StmtLR GhcPs GhcPs (LocatedA (bodyR GhcPs))+mkRnBindStmt :: LPat GhcRn -> LocatedA (bodyR GhcRn)+             -> StmtLR GhcRn GhcRn (LocatedA (bodyR GhcRn))+mkTcBindStmt :: LPat GhcTc -> LocatedA (bodyR GhcTc)+             -> StmtLR GhcTc GhcTc (LocatedA (bodyR GhcTc))++emptyRecStmt     :: (Anno [GenLocated+                             (Anno (StmtLR (GhcPass idL) GhcPs bodyR))+                             (StmtLR (GhcPass idL) GhcPs bodyR)]+                        ~ SrcSpanAnnLW)+                 => StmtLR (GhcPass idL) GhcPs bodyR+emptyRecStmtName :: (Anno [GenLocated+                             (Anno (StmtLR GhcRn GhcRn bodyR))+                             (StmtLR GhcRn GhcRn bodyR)]+                        ~ SrcSpanAnnLW)+                 => StmtLR GhcRn GhcRn bodyR+emptyRecStmtId   :: Stmt GhcTc (LocatedA (HsCmd GhcTc))++mkRecStmt :: forall (idL :: Pass) bodyR.+                    (Anno [GenLocated+                             (Anno (StmtLR (GhcPass idL) GhcPs bodyR))+                             (StmtLR (GhcPass idL) GhcPs bodyR)]+                        ~ SrcSpanAnnLW)+                 => AnnList (EpToken "rec")+                 -> LocatedLW [LStmtLR (GhcPass idL) GhcPs bodyR]+                 -> StmtLR (GhcPass idL) GhcPs bodyR+mkRecStmt anns stmts  = (emptyRecStmt' anns :: StmtLR (GhcPass idL) GhcPs bodyR)+                             { recS_stmts = stmts }+++mkHsIntegral     i  = OverLit noExtField (HsIntegral       i)+mkHsFractional   f  = OverLit noExtField (HsFractional     f)+mkHsIsString src s  = OverLit noExtField (HsIsString   src s)++mkHsDo     ctxt stmts      = HsDo noAnn ctxt stmts+mkHsDoAnns ctxt stmts anns = HsDo anns  ctxt stmts+mkHsComp ctxt stmts expr = mkHsCompAnns ctxt stmts expr noAnn+mkHsCompAnns ctxt stmts expr@(L l e) anns = mkHsDoAnns ctxt (L loc (stmts ++ [last_stmt])) anns+  where+    -- Move the annotations to the top of the last_stmt+    last = mkLastStmt (L (noAnnSrcSpan $ getLocA expr) e)+    last_stmt = L l last+    -- last_stmt actually comes first in a list comprehension, consider all spans+    loc  = noAnnSrcSpan $ getHasLocList (last_stmt:stmts)++-- restricted to GhcPs because other phases might need a SyntaxExpr+mkHsIf :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> AnnsIf+       -> HsExpr GhcPs+mkHsIf c a b anns = HsIf anns c a b++-- restricted to GhcPs because other phases might need a SyntaxExpr+mkHsCmdIf :: LHsExpr GhcPs -> LHsCmd GhcPs -> LHsCmd GhcPs -> AnnsIf+       -> HsCmd GhcPs+mkHsCmdIf c a b anns = HsCmdIf anns noSyntaxExpr c a b++mkNPat lit neg anns  = NPat anns lit neg noSyntaxExpr+mkNPlusKPat id lit anns+  = NPlusKPat anns id lit (unLoc lit) noSyntaxExpr noSyntaxExpr++mkTransformStmt    :: AnnTransStmt -> [ExprLStmt GhcPs] -> LHsExpr GhcPs+                   -> StmtLR GhcPs GhcPs (LHsExpr GhcPs)+mkTransformByStmt  :: AnnTransStmt -> [ExprLStmt GhcPs] -> LHsExpr GhcPs+                   -> LHsExpr GhcPs -> StmtLR GhcPs GhcPs (LHsExpr GhcPs)+mkGroupUsingStmt   :: AnnTransStmt -> [ExprLStmt GhcPs] -> LHsExpr GhcPs+                   -> StmtLR GhcPs GhcPs (LHsExpr GhcPs)+mkGroupByUsingStmt :: AnnTransStmt -> [ExprLStmt GhcPs] -> LHsExpr GhcPs+                   -> LHsExpr GhcPs+                   -> StmtLR GhcPs GhcPs (LHsExpr GhcPs)++emptyTransStmt :: AnnTransStmt -> StmtLR GhcPs GhcPs (LHsExpr GhcPs)+emptyTransStmt anns = TransStmt { trS_ext = anns+                                , trS_form = panic "emptyTransStmt: form"+                                , trS_stmts = [], trS_bndrs = []+                                , trS_by = Nothing, trS_using = noLocA noExpr+                                , trS_ret = noSyntaxExpr, trS_bind = noSyntaxExpr+                                , trS_fmap = noExpr }+mkTransformStmt    a ss u   = (emptyTransStmt a) { trS_form = ThenForm,  trS_stmts = ss, trS_using = u }+mkTransformByStmt  a ss u b = (emptyTransStmt a) { trS_form = ThenForm,  trS_stmts = ss, trS_using = u, trS_by = Just b }+mkGroupUsingStmt   a ss u   = (emptyTransStmt a) { trS_form = GroupForm, trS_stmts = ss, trS_using = u }+mkGroupByUsingStmt a ss b u = (emptyTransStmt a) { trS_form = GroupForm, trS_stmts = ss, trS_using = u, trS_by = Just b }++mkLastStmt body = LastStmt noExtField body Nothing noSyntaxExpr+mkBodyStmt body+  = BodyStmt noExtField body noSyntaxExpr noSyntaxExpr+mkPsBindStmt ann pat body = BindStmt ann pat body+mkRnBindStmt pat body = BindStmt (XBindStmtRn { xbsrn_bindOp = noSyntaxExpr, xbsrn_failOp = Nothing }) pat body+mkTcBindStmt pat body = BindStmt (XBindStmtTc { xbstc_bindOp = noSyntaxExpr,+                                                xbstc_boundResultType = unitTy,+                                                   -- unitTy is a dummy value+                                                   -- can't panic here: it's forced during zonking+                                                xbstc_boundResultMult = ManyTy,+                                                xbstc_failOp = Nothing }) pat body++emptyRecStmt' :: forall idL idR body .+  (WrapXRec (GhcPass idR) [LStmtLR (GhcPass idL) (GhcPass idR) body], IsPass idR)+              => XRecStmt (GhcPass idL) (GhcPass idR) body+              -> StmtLR (GhcPass idL) (GhcPass idR) body+emptyRecStmt' tyVal =+   RecStmt+     { recS_stmts = wrapXRec @(GhcPass idR) []+     , recS_later_ids = []+     , recS_rec_ids = []+     , recS_ret_fn = noSyntaxExpr+     , recS_mfix_fn = noSyntaxExpr+     , recS_bind_fn = noSyntaxExpr+     , recS_ext = tyVal }++unitRecStmtTc :: RecStmtTc+unitRecStmtTc = RecStmtTc { recS_bind_ty = unitTy+                          , recS_later_rets = []+                          , recS_rec_rets = []+                          , recS_ret_ty = unitTy }++emptyRecStmt     = emptyRecStmt' noAnn+emptyRecStmtName = emptyRecStmt' noExtField+emptyRecStmtId   = emptyRecStmt' unitRecStmtTc+                                        -- a panic might trigger during zonking++mkLetStmt :: EpToken "let" -> HsLocalBinds GhcPs -> StmtLR GhcPs GhcPs (LocatedA b)+mkLetStmt anns binds = LetStmt anns binds++-------------------------------+-- | A useful function for building @OpApps@.  The operator is always a+-- variable, and we don't know the fixity yet.+mkHsOpApp :: LHsExpr GhcPs -> IdP GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs+mkHsOpApp e1 op e2 = OpApp noExtField e1 (noLocA (mkHsVar (noLocA op))) e2++mkHsString :: String -> HsLit (GhcPass p)+mkHsString s = HsString NoSourceText (mkFastString s)++mkHsStringFS :: FastString -> HsLit (GhcPass p)+mkHsStringFS s = HsString NoSourceText s++mkHsStringPrimLit :: FastString -> HsLit (GhcPass p)+mkHsStringPrimLit fs = HsStringPrim NoSourceText (bytesFS fs)++mkHsCharPrimLit :: Char -> HsLit (GhcPass p)+mkHsCharPrimLit c = HsChar NoSourceText c++mkConLikeTc :: ConLike -> HsExpr GhcTc+mkConLikeTc con = XExpr (ConLikeTc con [] [])++{-+************************************************************************+*                                                                      *+        Constructing syntax with no location info+*                                                                      *+************************************************************************+-}++nlHsVar :: IsSrcSpanAnn p a+        => IdP (GhcPass p) -> LHsExpr (GhcPass p)+nlHsVar n = noLocA (mkHsVar (noLocA n))++-- | NB: Only for 'LHsExpr' 'Id'.+nlHsDataCon :: DataCon -> LHsExpr GhcTc+nlHsDataCon con = noLocA (mkConLikeTc (RealDataCon con))++nlHsLit :: HsLit (GhcPass p) -> LHsExpr (GhcPass p)+nlHsLit n = noLocA (HsLit noExtField n)++nlHsIntLit :: Integer -> LHsExpr (GhcPass p)+nlHsIntLit n = noLocA (HsLit noExtField (HsInt noExtField (mkIntegralLit n)))++nlVarPat :: IsSrcSpanAnn p a+        => IdP (GhcPass p) -> LPat (GhcPass p)+nlVarPat n = noLocA (VarPat noExtField (noLocA n))++nlLitPat :: HsLit GhcPs -> LPat GhcPs+nlLitPat l = noLocA (LitPat noExtField l)++nlHsApp :: IsPass id => LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)+nlHsApp f x = noLocA (HsApp noExtField f (mkLHsPar x))++nlHsSyntaxApps :: SyntaxExprTc -> [LHsExpr GhcTc]+               -> LHsExpr GhcTc+nlHsSyntaxApps = mkHsSyntaxApps noSrcSpanA++nlHsApps :: IsSrcSpanAnn p a+         => IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p)+nlHsApps f xs = foldl' nlHsApp (nlHsVar f) xs++nlHsVarApps :: IsSrcSpanAnn p a+            => IdP (GhcPass p) -> [IdP (GhcPass p)] -> LHsExpr (GhcPass p)+nlHsVarApps f xs = noLocA (foldl' mk (mkHsVar (noLocA f))+                                         (map (mkHsVar . noLocA) xs))+                 where+                   mk f a = HsApp noExtField (noLocA f) (noLocA a)++nlConVarPat :: RdrName -> [RdrName] -> LPat GhcPs+nlConVarPat con vars = nlConPat con (map nlVarPat vars)++nlConVarPatName :: Name -> [Name] -> LPat GhcRn+nlConVarPatName con vars = nlConPatName con (map nlVarPat vars)++nlInfixConPat :: RdrName -> LPat GhcPs -> LPat GhcPs -> LPat GhcPs+nlInfixConPat con l r = noLocA $ ConPat+  { pat_con = noLocA con+  , pat_args = InfixCon (parenthesizePat opPrec l)+                        (parenthesizePat opPrec r)+  , pat_con_ext = noAnn+  }++nlConPat :: RdrName -> [LPat GhcPs] -> LPat GhcPs+nlConPat con pats = noLocA $ ConPat+  { pat_con_ext = noAnn+  , pat_con = noLocA con+  , pat_args = PrefixCon (map (parenthesizePat appPrec) pats)+  }++nlConPatName :: Name -> [LPat GhcRn] -> LPat GhcRn+nlConPatName con pats = noLocA $ ConPat+  { pat_con_ext = noExtField+  , pat_con = noLocA (noUserRdr con)+  , pat_args = PrefixCon (map (parenthesizePat appPrec) pats)+  }++nlNullaryConPat :: RdrName -> LPat GhcPs+nlNullaryConPat con = noLocA $ ConPat+  { pat_con_ext = noAnn+  , pat_con = noLocA con+  , pat_args = PrefixCon []+  }++nlWildConPat :: DataCon -> LPat GhcPs+nlWildConPat con = noLocA $ ConPat+  { pat_con_ext = noAnn+  , pat_con = noLocA $ getRdrName con+  , pat_args = PrefixCon $+     replicate (dataConSourceArity con)+               nlWildPat+  }++-- | Wildcard pattern - after parsing+nlWildPat :: LPat GhcPs+nlWildPat  = noLocA (WildPat noExtField )++-- | Wildcard pattern - after renaming+nlWildPatName :: LPat GhcRn+nlWildPatName  = noLocA (WildPat noExtField )++nlHsDo :: HsDoFlavour -> [LStmt GhcPs (LHsExpr GhcPs)]+       -> LHsExpr GhcPs+nlHsDo ctxt stmts = noLocA (mkHsDo ctxt (noLocA stmts))++nlHsOpApp :: LHsExpr GhcPs -> IdP GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs+nlHsOpApp e1 op e2 = noLocA (mkHsOpApp e1 op e2)++nlHsLam  :: LMatch GhcPs (LHsExpr GhcPs) -> LHsExpr GhcPs+nlHsPar  :: IsPass p => LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)+nlHsCase :: LHsExpr GhcPs -> [LMatch GhcPs (LHsExpr GhcPs)]+         -> LHsExpr GhcPs+nlList   :: [LHsExpr GhcPs] -> LHsExpr GhcPs++nlHsLam match = noLocA $ HsLam noAnn LamSingle+                  $ mkMatchGroup (Generated OtherExpansion SkipPmc) (noLocA [match])++nlHsPar e     = noLocA (gHsPar e)++-- nlHsIf should generate if-expressions which are NOT subject to+-- RebindableSyntax, so the first field of HsIf is False. (#12080)+nlHsIf :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs+nlHsIf cond true false = noLocA (HsIf noAnn cond true false)++nlHsCase expr matches+  = noLocA (HsCase noAnn expr (mkMatchGroup (Generated OtherExpansion SkipPmc) (noLocA matches)))+nlList exprs          = noLocA (ExplicitList noAnn exprs)++nlHsAppTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)+nlHsTyVar :: forall p a. IsSrcSpanAnn p a+          => PromotionFlag -> IdP (GhcPass p)           -> LHsType (GhcPass p)+nlHsFunTy :: forall p. IsPass p+          => LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)+nlHsParTy :: LHsType (GhcPass p)                        -> LHsType (GhcPass p)++nlHsAppTy f t = noLocA (HsAppTy noExtField f t)+nlHsTyVar p x = noLocA (HsTyVar noAnn p (noLocA $ noUserRdrP @p x))+nlHsFunTy a b = noLocA (HsFunTy noExtField (HsUnannotated x) a b)+  where+    x = case ghcPass @p of+      GhcPs -> EpArrow noAnn+      GhcRn -> noExtField+      GhcTc -> manyDataConTy+nlHsParTy t   = noLocA (HsParTy noAnn t)++nlHsTyConApp :: forall p a. IsSrcSpanAnn p a+             => PromotionFlag+             -> LexicalFixity -> IdOccP (GhcPass p)+             -> [LHsTypeArg (GhcPass p)] -> LHsType (GhcPass p)+nlHsTyConApp prom fixity tycon tys+  | Infix <- fixity+  , HsValArg _ ty1 : HsValArg _ ty2 : rest <- tys+  = foldl' mk_app (noLocA $ HsOpTy noExtField prom ty1 (noLocA tycon) ty2) rest+  | otherwise+  = foldl' mk_app (nlHsTyVar prom $ forgetUserRdr @p tycon) tys+  where+    mk_app :: LHsType (GhcPass p) -> LHsTypeArg (GhcPass p) -> LHsType (GhcPass p)+    mk_app fun@(L _ (HsOpTy {})) arg = mk_app (nlHsParTy fun) arg+      -- parenthesize things like `(A + B) C`+    mk_app fun (HsValArg _ ty) = nlHsAppTy fun ty+    mk_app fun (HsTypeArg _ ki) = nlHsAppKindTy fun ki+    mk_app fun (HsArgPar _) = nlHsParTy fun++-- | Turn an 'IdP' into an 'IdOccP', with no user-written 'RdrName' information.+noUserRdrP :: forall p. IsPass p => IdP (GhcPass p) -> IdOccP (GhcPass p)+noUserRdrP =+  case ghcPass @p of+    GhcPs -> id+    GhcRn -> noUserRdr+    GhcTc -> id++-- | Turn an 'IdOccP' into an 'IdP', discarding the user-written 'RdrName'.+forgetUserRdr :: forall p. IsPass p => IdOccP (GhcPass p) -> IdP (GhcPass p)+forgetUserRdr =+  case ghcPass @p of+    GhcPs -> id+    GhcRn -> \ (WithUserRdr _rdr n) -> n+    GhcTc -> id++nlHsAppKindTy :: forall p. IsPass p =>+  LHsType (GhcPass p) -> LHsKind (GhcPass p) -> LHsType (GhcPass p)+nlHsAppKindTy f k = noLocA (HsAppKindTy x f k)+  where+    x = case ghcPass @p of+      GhcPs -> noAnn+      GhcRn -> noExtField+      GhcTc -> noExtField++{-+Tuples.  All these functions are *pre-typechecker* because they lack+types on the tuple.+-}++mkLHsTupleExpr :: [LHsExpr (GhcPass p)] -> XExplicitTuple (GhcPass p)+               -> LHsExpr (GhcPass p)+-- Makes a pre-typechecker boxed tuple, deals with 1 case+mkLHsTupleExpr [e] _ = e+mkLHsTupleExpr es ext+  = noLocA $ ExplicitTuple ext (map (Present noExtField) es) Boxed++mkLHsVarTuple :: IsSrcSpanAnn p a+               => [IdP (GhcPass p)]  -> XExplicitTuple (GhcPass p)+              -> LHsExpr (GhcPass p)+mkLHsVarTuple ids ext = mkLHsTupleExpr (map nlHsVar ids) ext++nlTuplePat :: [LPat GhcPs] -> Boxity -> LPat GhcPs+nlTuplePat pats box = noLocA (TuplePat noAnn pats box)++missingTupArg :: EpAnn Bool -> HsTupArg GhcPs+missingTupArg ann = Missing ann++mkLHsPatTup :: [LPat GhcRn] -> LPat GhcRn+mkLHsPatTup []     = noLocA $ TuplePat noExtField [] Boxed+mkLHsPatTup [lpat] = lpat+mkLHsPatTup lpats@(lpat:_) = L (getLoc lpat) $ TuplePat noExtField lpats Boxed++-- | The Big equivalents for the source tuple expressions+mkBigLHsVarTup :: IsSrcSpanAnn p a+               => [IdP (GhcPass p)] -> XExplicitTuple (GhcPass p)+               -> LHsExpr (GhcPass p)+mkBigLHsVarTup ids anns = mkBigLHsTup (map nlHsVar ids) anns++mkBigLHsTup :: [LHsExpr (GhcPass id)] -> XExplicitTuple (GhcPass id)+            -> LHsExpr (GhcPass id)+mkBigLHsTup es anns = mkChunkified (\e -> mkLHsTupleExpr e anns) es++-- | The Big equivalents for the source tuple patterns+mkBigLHsVarPatTup :: [IdP GhcRn] -> LPat GhcRn+mkBigLHsVarPatTup bs = mkBigLHsPatTup (map nlVarPat bs)++mkBigLHsPatTup :: [LPat GhcRn] -> LPat GhcRn+mkBigLHsPatTup = mkChunkified mkLHsPatTup++{-+************************************************************************+*                                                                      *+        LHsSigType and LHsSigWcType+*                                                                      *+********************************************************************* -}++-- | Convert an 'LHsType' to an 'LHsSigType'.+hsTypeToHsSigType :: LHsType GhcPs -> LHsSigType GhcPs+hsTypeToHsSigType lty@(L loc ty) = case ty of+  HsForAllTy { hst_tele = HsForAllInvis { hsf_xinvis = an+                                        , hsf_invis_bndrs = bndrs }+             , hst_body = body }+    -> L loc $ mkHsExplicitSigType an bndrs body+  _ -> L (l2l loc) $ mkHsImplicitSigType lty -- The annotations are in lty, erase them from loc++-- | Convert an 'LHsType' to an 'LHsSigWcType'.+hsTypeToHsSigWcType :: LHsType GhcPs -> LHsSigWcType GhcPs+hsTypeToHsSigWcType = mkHsWildCardBndrs . hsTypeToHsSigType++mkHsSigEnv :: forall a. (LSig GhcRn -> Maybe ([LocatedN Name], a))+                     -> [LSig GhcRn]+                     -> NameEnv a+mkHsSigEnv get_info sigs+  = mkNameEnv          (mk_pairs ordinary_sigs)+   `extendNameEnvList` (mk_pairs gen_dm_sigs)+   -- The subtlety is this: in a class decl with a+   -- default-method signature as well as a method signature+   -- we want the latter to win (#12533)+   --    class C x where+   --       op :: forall a . x a -> x a+   --       default op :: forall b . x b -> x b+   --       op x = ...(e :: b -> b)...+   -- The scoped type variables of the 'default op', namely 'b',+   -- scope over the code for op.   The 'forall a' does not!+   -- This applies both in the renamer and typechecker, both+   -- of which use this function+  where+    (gen_dm_sigs, ordinary_sigs) = partition is_gen_dm_sig sigs+    is_gen_dm_sig (L _ (ClassOpSig _ True _ _)) = True+    is_gen_dm_sig _                             = False++    mk_pairs :: [LSig GhcRn] -> [(Name, a)]+    mk_pairs sigs = [ (n,a) | Just (ns,a) <- map get_info sigs+                            , L _ n <- ns ]++mkClassOpSigs :: [LSig GhcPs] -> [LSig GhcPs]+-- ^ Convert 'TypeSig' to 'ClassOpSig'.+-- The former is what is parsed, but the latter is+-- what we need in class/instance declarations+mkClassOpSigs sigs+  = map fiddle sigs+  where+    fiddle (L loc (TypeSig anns nms ty))+      = L loc (ClassOpSig anns False nms (dropWildCards ty))+    fiddle sig = sig+++-- | Type ascription: (e :: ty)+nlAscribe :: RdrName -> LHsExpr GhcPs -> LHsExpr GhcPs+nlAscribe ty e = noLocA $ ExprWithTySig noAnn e+                           $ mkHsWildCardBndrs $ noLocA $ mkHsImplicitSigType+                           $ nlHsTyVar NotPromoted ty++{- *********************************************************************+*                                                                      *+    --------- HsWrappers: type args, dict args, casts ---------+*                                                                      *+********************************************************************* -}++mkLHsWrap :: HsWrapper -> LHsExpr GhcTc -> LHsExpr GhcTc+mkLHsWrap co_fn (L loc e) = L loc (mkHsWrap co_fn e)++mkHsWrap :: HsWrapper -> HsExpr GhcTc -> HsExpr GhcTc+mkHsWrap co_fn e | isIdHsWrapper co_fn = e+mkHsWrap co_fn e                       = XExpr (WrapExpr co_fn e)++mkHsWrapCo :: TcCoercionN   -- A Nominal coercion  a ~N b+           -> HsExpr GhcTc -> HsExpr GhcTc+mkHsWrapCo co e = mkHsWrap (mkWpCastN co) e++mkHsWrapCoR :: TcCoercionR   -- A Representational coercion  a ~R b+            -> HsExpr GhcTc -> HsExpr GhcTc+mkHsWrapCoR co e = mkHsWrap (mkWpCastR co) e++mkLHsWrapCo :: TcCoercionN -> LHsExpr GhcTc -> LHsExpr GhcTc+mkLHsWrapCo co (L loc e) = L loc (mkHsWrapCo co e)++mkHsCmdWrap :: HsWrapper -> HsCmd GhcTc -> HsCmd GhcTc+mkHsCmdWrap w cmd | isIdHsWrapper w = cmd+                  | otherwise       = XCmd (HsWrap w cmd)++mkLHsCmdWrap :: HsWrapper -> LHsCmd GhcTc -> LHsCmd GhcTc+mkLHsCmdWrap w (L loc c) = L loc (mkHsCmdWrap w c)++mkHsWrapPat :: HsWrapper -> Pat GhcTc -> Type -> Pat GhcTc+mkHsWrapPat co_fn p ty | isIdHsWrapper co_fn = p+                       | otherwise           = XPat $ CoPat co_fn p ty++mkLHsWrapPat :: HsWrapper -> LPat GhcTc -> Type -> LPat GhcTc+mkLHsWrapPat co_fn (L loc p) ty = L loc (mkHsWrapPat co_fn p ty)++mkHsWrapPatCo :: TcCoercionN -> Pat GhcTc -> Type -> Pat GhcTc+mkHsWrapPatCo co pat ty | isReflCo co = pat+                        | otherwise     = XPat $ CoPat (mkWpCastN co) pat ty++mkHsDictLet :: TcEvBinds -> LHsExpr GhcTc -> LHsExpr GhcTc+mkHsDictLet ev_binds expr = mkLHsWrap (mkWpLet ev_binds) expr++{-+l+************************************************************************+*                                                                      *+                Bindings; with a location at the top+*                                                                      *+************************************************************************+-}++mkFunBind :: Origin -> LocatedN RdrName -> [LMatch GhcPs (LHsExpr GhcPs)]+          -> HsBind GhcPs+-- ^ Not infix, with place holders for coercion and free vars+mkFunBind origin fn ms+  = FunBind { fun_id = fn+            , fun_matches = mkMatchGroup origin (noLocA ms)+            , fun_ext = noExtField+            }++mkTopFunBind :: Origin -> LocatedN Name -> [LMatch GhcRn (LHsExpr GhcRn)]+             -> HsBind GhcRn+-- ^ In Name-land, with empty bind_fvs+mkTopFunBind origin fn ms = FunBind { fun_id = fn+                                    , fun_matches = mkMatchGroup origin (noLocA ms)+                                    , fun_ext  = emptyNameSet -- NB: closed+                                                              --     binding+                                    }++mkHsVarBind :: SrcSpan -> RdrName -> LHsExpr GhcPs -> LHsBind GhcPs+mkHsVarBind loc var rhs = mkSimpleGeneratedFunBind loc var (noLocA []) rhs++mkVarBind :: IdP GhcTc -> LHsExpr GhcTc -> LHsBind GhcTc+mkVarBind var rhs = L (getLoc rhs) $+                    VarBind { var_ext = noExtField,+                              var_id = var, var_rhs = rhs }++mkPatSynBind :: LocatedN RdrName -> HsPatSynDetails GhcPs+             -> LPat GhcPs -> HsPatSynDir GhcPs -> AnnPSB -> HsBind GhcPs+mkPatSynBind name details lpat dir anns = PatSynBind noExtField psb+  where+    psb = PSB{ psb_ext = anns+             , psb_id = name+             , psb_args = details+             , psb_def = lpat+             , psb_dir = dir }++-- |If any of the matches in the 'FunBind' are infix, the 'FunBind' is+-- considered infix.+isInfixFunBind :: HsBindLR (GhcPass p1) (GhcPass p2) -> Bool+isInfixFunBind (FunBind { fun_matches = MG _ matches })+  = any (isInfixMatch . unLoc) (unLoc matches)+isInfixFunBind _ = False++-- |Return the 'SrcSpan' encompassing the contents of any enclosed binds+spanHsLocaLBinds :: HsLocalBinds (GhcPass p) -> SrcSpan+spanHsLocaLBinds (EmptyLocalBinds _) = noSrcSpan+spanHsLocaLBinds (HsValBinds _ (ValBinds _ bs sigs))+  = foldr combineSrcSpans noSrcSpan (bsSpans ++ sigsSpans)+  where+    bsSpans :: [SrcSpan]+    bsSpans = map getLocA bs+    sigsSpans :: [SrcSpan]+    sigsSpans = map getLocA sigs+spanHsLocaLBinds (HsValBinds _ (XValBindsLR (NValBinds bs sigs)))+  = foldr combineSrcSpans noSrcSpan (bsSpans ++ sigsSpans)+  where+    bsSpans :: [SrcSpan]+    bsSpans = map getLocA $ concatMap snd bs+    sigsSpans :: [SrcSpan]+    sigsSpans = map getLocA sigs+spanHsLocaLBinds (HsIPBinds _ (IPBinds _ bs))+  = foldr combineSrcSpans noSrcSpan (map getLocA bs)++------------+-- | Convenience function using 'mkFunBind'.+-- This is for generated bindings only, do not use for user-written code.+mkSimpleGeneratedFunBind :: SrcSpan -> RdrName -> LocatedE [LPat GhcPs]+                         -> LHsExpr GhcPs -> LHsBind GhcPs+mkSimpleGeneratedFunBind loc fun pats expr+  = L (noAnnSrcSpan loc) $ mkFunBind (Generated OtherExpansion SkipPmc) (L (noAnnSrcSpan loc) fun)+                                     [mkMatch ctxt pats expr emptyLocalBinds]+  where+    ctxt :: HsMatchContextPs+    ctxt = mkPrefixFunRhs (L (noAnnSrcSpan loc) fun) noAnn++-- | Make a prefix, non-strict function 'HsMatchContext'+mkPrefixFunRhs :: fn -> AnnFunRhs -> HsMatchContext fn+mkPrefixFunRhs n an = FunRhs { mc_fun        = n+                          , mc_fixity     = Prefix+                          , mc_strictness = NoSrcStrict+                          , mc_an         = an }++------------+mkMatch :: forall p. IsPass p+        => HsMatchContext (LIdP (NoGhcTc (GhcPass p)))+        -> LocatedE [LPat (GhcPass p)]+        -> LHsExpr (GhcPass p)+        -> HsLocalBinds (GhcPass p)+        -> LMatch (GhcPass p) (LHsExpr (GhcPass p))+mkMatch ctxt pats expr binds+  = noLocA (Match { m_ext   = noExtField+                  , m_ctxt  = ctxt+                  , m_pats  = pats+                  , m_grhss = GRHSs emptyComments (unguardedRHS noAnn noSrcSpan expr) binds })++{-+************************************************************************+*                                                                      *+        Collecting binders+*                                                                      *+************************************************************************++Get all the binders in some HsBindGroups, IN THE ORDER OF APPEARANCE. eg.++...+where+  (x, y) = ...+  f i j  = ...+  [a, b] = ...++it should return [x, y, f, a, b] (remember, order important).++Note [Collect binders only after renaming]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+These functions should only be used on HsSyn *after* the renamer,+to return a [Name] or [Id].  Before renaming the record punning+and wild-card mechanism makes it hard to know what is bound.+So these functions should not be applied to (HsSyn RdrName)++Note [isUnliftedHsBind]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The function isUnliftedHsBind tells if the binding binds a variable of+unlifted type.  e.g.++  - I# x = blah+  - Just (I# x) = blah++isUnliftedHsBind is used in two ways:++* To complain if we make a top-level binding for a variable of unlifted+  type. E.g. any of the above bindings are illegal at top level++* To generate a case expression for a non-recursive local let.  E.g.+     let Just (I# x) = blah in body+  ==>+     case blah of Just (I# x) -> body+  See GHC.HsToCore.Expr.dsUnliftedBind.++Wrinkles:++(W1) For AbsBinds we must check if the local letrec generated by desugaring+     AbsBinds would be unlifted; so we just recurse into the abs_binds. E.g.+       f :: Num a => (# a, a #)+       g :: Num a => a -> a+       f = ...g...+       g = ...g...++    The top-level bindings for f,g are not unlifted (because of the Num a =>),+    but the local, recursive, monomorphic bindings are:+      t = /\a \(d:Num a).+         letrec fm :: (# a, a #) = ...g...+                gm :: a -> a = ...f...+         in (fm, gm)++   Here the binding for 'fm' is illegal.  So we recurse into the abs_binds++(W2) BUT we have a special case when abs_sig is true;+     see Note [The abs_sig field of AbsBinds] in GHC.Hs.Binds++(W3) isUnliftedHsBind returns False even if the binding itself is+     unlifted, provided it binds only lifted variables. E.g.+      -  (# a,b #) = (# reverse xs, xs #)++      -  x = sqrt# y#  :: Float#++      -  type Unl :: UnliftedType+         data Unl = MkUnl Int+         MkUnl z = blah++     In each case the RHS of the "=" has unlifted type, but isUnliftedHsBind+     returns False.  Reason: see GHC Proposal #35+        https://github.com/ghc-proposals/ghc-proposals/blob/master/+        proposals/0035-unbanged-strict-patterns.rst++(W4) In particular, (W3) applies to a pattern that binds no variables at all.+     So   { _ = sqrt# y :: Float# } returns False from isUnliftedHsBind, but+          { x = sqrt# y :: Float# } returns True.+     This is arguably a bit confusing (see #22719)+-}++----------------- Bindings --------------------------++-- | Should we treat this as an unlifted bind? This will be true for any+-- bind that binds an unlifted variable, but we must be careful around+-- AbsBinds. See Note [isUnliftedHsBind]. For usage+-- information, see Note [Strict binds checks] is GHC.HsToCore.Binds.+isUnliftedHsBind :: HsBind GhcTc -> Bool  -- works only over typechecked binds+isUnliftedHsBind (XHsBindsLR (AbsBinds { abs_exports = exports+                                       , abs_sig     = has_sig+                                       , abs_binds   = binds }))+  | has_sig   = any (is_unlifted_id . abe_poly) exports+  | otherwise = isUnliftedHsBinds binds+    -- See wrinkle (W1) and (W2) in Note [isUnliftedHsBind]+    -- If has_sig is True we will never generate a binding for abe_mono,+    -- so we don't need to worry about it being unlifted. The abe_poly+    -- binding might not be: e.g. forall a. Num a => (# a, a #)+    -- If has_sig is False, just recurse++isUnliftedHsBind (FunBind { fun_id = L _ fun })+  = is_unlifted_id fun++isUnliftedHsBind (VarBind { var_id = var })+  = is_unlifted_id var++isUnliftedHsBind (PatBind { pat_lhs = pat })+  = any is_unlifted_id (collectPatBinders CollNoDictBinders pat)+    -- If we changed our view on (W3) you could add+    --    || isUnliftedType pat_ty+    -- to this check++isUnliftedHsBind (PatSynBind {}) = panic "isUnliftedBind: PatSynBind"++isUnliftedHsBinds :: LHsBinds GhcTc -> Bool+isUnliftedHsBinds = any (isUnliftedHsBind . unLoc)++is_unlifted_id :: Id -> Bool+is_unlifted_id id = isUnliftedType (idType id)+   -- Bindings always have a fixed RuntimeRep, so it's OK+   -- to call isUnliftedType here++-- | Is a binding a strict variable or pattern bind (e.g. @!x = ...@)?+isBangedHsBind :: HsBind GhcTc -> Bool+isBangedHsBind (XHsBindsLR (AbsBinds { abs_binds = binds }))+  = any (isBangedHsBind . unLoc) binds+isBangedHsBind (FunBind {fun_matches = matches})+  | [L _ match] <- unLoc $ mg_alts matches+  , FunRhs{mc_strictness = SrcStrict} <- m_ctxt match+  = True+isBangedHsBind (PatBind {pat_lhs = pat})+  = isBangedLPat pat+isBangedHsBind _+  = False++collectLocalBinders :: CollectPass (GhcPass idL)+                    => CollectFlag (GhcPass idL)+                    -> HsLocalBindsLR (GhcPass idL) (GhcPass idR)+                    -> [IdP (GhcPass idL)]+collectLocalBinders flag = \case+    HsValBinds _ binds -> collectHsIdBinders flag binds+                          -- No pattern synonyms here+    HsIPBinds {}       -> []+    EmptyLocalBinds _  -> []++collectHsIdBinders :: CollectPass (GhcPass idL)+                   => CollectFlag (GhcPass idL)+                   -> HsValBindsLR (GhcPass idL) (GhcPass idR)+                   -> [IdP (GhcPass idL)]+-- ^ Collect 'Id' binders only, or 'Id's + pattern synonyms, respectively+collectHsIdBinders flag = collect_hs_val_binders True flag++collectHsValBinders :: CollectPass (GhcPass idL)+                    => CollectFlag (GhcPass idL)+                    -> HsValBindsLR (GhcPass idL) idR+                    -> [IdP (GhcPass idL)]+collectHsValBinders flag = collect_hs_val_binders False flag++collectHsBindBinders :: CollectPass p+                     => CollectFlag p+                     -> HsBindLR p idR+                     -> [IdP p]+-- ^ Collect both 'Id's and pattern-synonym binders+collectHsBindBinders flag b = collect_bind False flag b []++collectHsBindsBinders :: CollectPass p+                      => CollectFlag p+                      -> LHsBindsLR p idR+                      -> [IdP p]+collectHsBindsBinders flag binds = collect_binds False flag binds []++collectHsBindListBinders :: forall p idR. CollectPass p+                         => CollectFlag p+                         -> [LHsBindLR p idR]+                         -> [IdP p]+-- ^ Same as 'collectHsBindsBinders', but works over a list of bindings+collectHsBindListBinders flag = foldr (collect_bind False flag . unXRec @p) []++collect_hs_val_binders :: CollectPass (GhcPass idL)+                       => Bool+                       -> CollectFlag (GhcPass idL)+                       -> HsValBindsLR (GhcPass idL) idR+                       -> [IdP (GhcPass idL)]+collect_hs_val_binders ps flag = \case+    ValBinds _ binds _              -> collect_binds ps flag binds []+    XValBindsLR (NValBinds binds _) -> collect_out_binds ps flag binds++collect_out_binds :: forall p. CollectPass p+                  => Bool+                  -> CollectFlag p+                  -> [(RecFlag, LHsBinds p)]+                  -> [IdP p]+collect_out_binds ps flag = foldr (collect_binds ps flag . snd) []++collect_binds :: forall p idR. CollectPass p+              => Bool+              -> CollectFlag p+              -> LHsBindsLR p idR+              -> [IdP p]+              -> [IdP p]+-- ^ Collect 'Id's, or 'Id's + pattern synonyms, depending on boolean flag+collect_binds ps flag binds acc = foldr (collect_bind ps flag . unXRec @p) acc binds++collect_bind :: forall p idR. CollectPass p+             => Bool+             -> CollectFlag p+             -> HsBindLR p idR+             -> [IdP p]+             -> [IdP p]+collect_bind _ _    (FunBind { fun_id = f })         acc = unXRec @p f : acc+collect_bind _ flag (PatBind { pat_lhs = p })        acc = collect_lpat flag p acc+collect_bind _ _    (VarBind { var_id = f })         acc = f : acc+collect_bind omitPatSyn _ (PatSynBind _ (PSB { psb_id = ps })) acc+  | omitPatSyn                  = acc+  | otherwise                   = unXRec @p ps : acc+collect_bind _ _ (PatSynBind _ (XPatSynBind _)) acc = acc+collect_bind _ _ (XHsBindsLR b) acc = collectXXHsBindsLR @p @idR b acc+++collectMethodBinders :: forall idL idR. UnXRec idL => LHsBindsLR idL idR -> [LIdP idL]+-- ^ Used exclusively for the bindings of an instance decl which are all+-- 'FunBinds'+collectMethodBinders binds = foldr (get . unXRec @idL) [] binds+  where+    get (FunBind { fun_id = f }) fs = f : fs+    get _                        fs = fs+       -- Someone else complains about non-FunBinds++----------------- Statements --------------------------+--+collectLStmtsBinders+  :: (IsPass idL, IsPass idR, CollectPass (GhcPass idL))+  => CollectFlag (GhcPass idL)+  -> [LStmtLR (GhcPass idL) (GhcPass idR) body]+  -> [IdP (GhcPass idL)]+collectLStmtsBinders flag = concatMap (collectLStmtBinders flag)++collectStmtsBinders+  :: (IsPass idL, IsPass idR, CollectPass (GhcPass idL))+  => CollectFlag (GhcPass idL)+  -> [StmtLR (GhcPass idL) (GhcPass idR) body]+  -> [IdP (GhcPass idL)]+collectStmtsBinders flag = concatMap (collectStmtBinders flag)++collectLStmtBinders+  :: (IsPass idL, IsPass idR, CollectPass (GhcPass idL))+  => CollectFlag (GhcPass idL)+  -> LStmtLR (GhcPass idL) (GhcPass idR) body+  -> [IdP (GhcPass idL)]+collectLStmtBinders flag = collectStmtBinders flag . unLoc++collectStmtBinders+  :: forall idL idR body . (IsPass idL, IsPass idR, CollectPass (GhcPass idL))+  => CollectFlag (GhcPass idL)+  -> StmtLR (GhcPass idL) (GhcPass idR) body+  -> [IdP (GhcPass idL)]+  -- Id Binders for a Stmt... [but what about pattern-sig type vars]?+collectStmtBinders flag = \case+    BindStmt _ pat _ -> collectPatBinders flag pat+    LetStmt _  binds -> collectLocalBinders flag binds+    BodyStmt {}      -> []+    LastStmt {}      -> []+    ParStmt _ xs _ _ -> collectLStmtsBinders flag [s | ParStmtBlock _ ss _ _ <- toList xs, s <- ss]+    TransStmt { trS_stmts = stmts } -> collectLStmtsBinders flag stmts+    RecStmt { recS_stmts = L _ ss } -> collectLStmtsBinders flag ss+    XStmtLR x -> case ghcPass :: GhcPass idR of+        GhcRn -> collectApplicativeStmtBndrs x+        GhcTc -> collectApplicativeStmtBndrs x+  where+    collectApplicativeStmtBndrs :: ApplicativeStmt (GhcPass idL) a -> [IdP (GhcPass idL)]+    collectApplicativeStmtBndrs (ApplicativeStmt _ args _) = concatMap (collectArgBinders . snd) args++    collectArgBinders = \case+        ApplicativeArgOne { app_arg_pattern = pat } -> collectPatBinders flag pat+        ApplicativeArgMany { bv_pattern = pat }     -> collectPatBinders flag pat++----------------- Patterns --------------------------++collectPatBinders+    :: CollectPass p+    => CollectFlag p+    -> LPat p+    -> [IdP p]+collectPatBinders flag pat = collect_lpat flag pat []++collectPatsBinders+    :: CollectPass p+    => CollectFlag p+    -> [LPat p]+    -> [IdP p]+collectPatsBinders flag pats = foldr (collect_lpat flag) [] pats++-------------++-- | Indicate if evidence binders and type variable binders have+--   to be collected.+--+-- This type enumerates the modes of collecting bound variables+--                     | evidence |   type    |   term    |  ghc  |+--                     | binders  | variables | variables |  pass |+--                     --------------------------------------------+-- CollNoDictBinders   |  no      |    no     |    yes    |  any  |+-- CollWithDictBinders |  yes     |    no     |    yes    | GhcTc |+-- CollVarTyVarBinders |  no      |    yes    |    yes    | GhcRn |+--+-- See Note [Dictionary binders in ConPatOut]+data CollectFlag p where+    -- | Don't collect evidence binders+    CollNoDictBinders   :: CollectFlag p+    -- | Collect evidence binders+    CollWithDictBinders :: CollectFlag GhcTc+    -- | Collect variable and type variable binders, but no evidence binders+    CollVarTyVarBinders :: CollectFlag GhcRn+++collect_lpat :: forall p. CollectPass p+             => CollectFlag p+             -> LPat p+             -> [IdP p]+             -> [IdP p]+collect_lpat flag pat bndrs = collect_pat flag (unXRec @p pat) bndrs++collect_pat :: forall p. CollectPass p+            => CollectFlag p+            -> Pat p+            -> [IdP p]+            -> [IdP p]+collect_pat flag pat bndrs = case pat of+  VarPat _ var          -> unXRec @p var : bndrs+  WildPat _             -> bndrs+  LazyPat _ pat         -> collect_lpat flag pat bndrs+  BangPat _ pat         -> collect_lpat flag pat bndrs+  AsPat _ a pat         -> unXRec @p a : collect_lpat flag pat bndrs+  ViewPat _ _ pat       -> collect_lpat flag pat bndrs+  ParPat _ pat          -> collect_lpat flag pat bndrs+  ListPat _ pats        -> foldr (collect_lpat flag) bndrs pats+  TuplePat _ pats _     -> foldr (collect_lpat flag) bndrs pats+  OrPat _ _             -> []+      -- See Note [Implementation of OrPatterns], Renamer:+      -- evidence binders in an OrPat currently aren't visible outside their+      -- binding pattern, so we return [].+  SumPat _ pat _ _      -> collect_lpat flag pat bndrs+  LitPat _ _            -> bndrs+  NPat {}               -> bndrs+  NPlusKPat _ n _ _ _ _ -> unXRec @p n : bndrs+  SigPat _ pat sig      -> case flag of+    CollNoDictBinders   -> collect_lpat flag pat bndrs+    CollWithDictBinders -> collect_lpat flag pat bndrs+    CollVarTyVarBinders -> collect_lpat flag pat bndrs ++ collectPatSigBndrs sig+  XPat ext              -> collectXXPat @p flag ext bndrs+  SplicePat ext _       -> collectXSplicePat @p flag ext bndrs+  EmbTyPat _ tp         -> collect_ty_pat_bndrs flag tp bndrs+  InvisPat _ tp         -> collect_ty_pat_bndrs flag tp bndrs++  -- See Note [Dictionary binders in ConPatOut]+  ConPat {pat_args=ps}  -> case flag of+    CollNoDictBinders   -> foldr (collect_lpat flag) bndrs (hsConPatArgs ps)+    CollWithDictBinders -> foldr (collect_lpat flag) bndrs (hsConPatArgs ps)+                           ++ collectEvBinders (cpt_binds (pat_con_ext pat))+    CollVarTyVarBinders -> foldr (collect_lpat flag) bndrs (hsConPatArgs ps)++collectEvBinders :: TcEvBinds -> [Id]+collectEvBinders (EvBinds bs)   = foldr add_ev_bndr [] bs+collectEvBinders (TcEvBinds {}) = panic "ToDo: collectEvBinders"++collect_ty_pat_bndrs :: CollectFlag p -> HsTyPat (NoGhcTc p) -> [IdP p] -> [IdP p]+collect_ty_pat_bndrs CollNoDictBinders _ bndrs = bndrs+collect_ty_pat_bndrs CollWithDictBinders _ bndrs = bndrs+collect_ty_pat_bndrs CollVarTyVarBinders tp bndrs = collectTyPatBndrs tp ++ bndrs++collectTyPatBndrs :: HsTyPat GhcRn -> [Name]+collectTyPatBndrs (HsTP (HsTPRn nwcs imp_tvs exp_tvs) _) = nwcs ++ imp_tvs ++ exp_tvs++collectPatSigBndrs :: HsPatSigType GhcRn -> [Name]+collectPatSigBndrs (HsPS (HsPSRn nwcs imp_tvs) _) = nwcs ++ imp_tvs++add_ev_bndr :: EvBind -> [Id] -> [Id]+add_ev_bndr (EvBind { eb_lhs = b }) bs | isId b    = b:bs+                                       | otherwise = bs+  -- A worry: what about coercion variable binders??+++-- | This class specifies how to collect variable identifiers from extension patterns in the given pass.+-- Consumers of the GHC API that define their own passes should feel free to implement instances in order+-- to make use of functions which depend on it.+--+-- In particular, Haddock already makes use of this, with an instance for its 'DocNameI' pass so that+-- it can reuse the code in GHC for collecting binders.+class UnXRec p => CollectPass p where+  collectXXPat :: CollectFlag p -> XXPat p -> [IdP p] -> [IdP p]+  collectXXHsBindsLR :: forall pR. XXHsBindsLR p pR -> [IdP p] -> [IdP p]+  collectXSplicePat :: CollectFlag p -> XSplicePat p -> [IdP p] -> [IdP p]++instance IsPass p => CollectPass (GhcPass p) where+  collectXXPat flag ext =+    case ghcPass @p of+      GhcPs -> dataConCantHappen ext+      GhcRn+        | HsPatExpanded _ pat <- ext+        -> collect_pat flag pat+      GhcTc -> case ext of+        CoPat _ pat _      -> collect_pat flag pat+        ExpansionPat _ pat -> collect_pat flag pat+  collectXXHsBindsLR ext =+    case ghcPass @p of+      GhcPs -> dataConCantHappen ext+      GhcRn -> dataConCantHappen ext+      GhcTc -> case ext of+        AbsBinds { abs_exports = dbinds } -> (map abe_poly dbinds ++)+        -- I don't think we want the binders from the abe_binds+        -- binding (hence see AbsBinds) is in zonking in GHC.Tc.Zonk.Type++  collectXSplicePat flag ext =+      case ghcPass @p of+        GhcPs -> id+        GhcRn | (HsUntypedSpliceTop _ pat) <- ext -> collect_pat flag pat+        GhcRn | (HsUntypedSpliceNested _)  <- ext -> id+        GhcTc -> dataConCantHappen ext+++{-+Note [Dictionary binders in ConPatOut]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Should we collect dictionary binders in ConPatOut? It depends! Use CollectFlag+to choose.++1. Pre-typechecker there are no ConPatOuts. Use CollNoDictBinders flag.++2. In the desugarer, most of the time we don't want to collect evidence binders,+   so we also use CollNoDictBinders flag.++   Example of why it matters:++   In a lazy pattern, for example f ~(C x y) = ..., we want to generate bindings+   for x,y but not for dictionaries bound by C.+   (The type checker ensures they would not be used.)++   Here's the problem.  Consider++        data T a where+           C :: Num a => a -> Int -> T a++        f ~(C (n+1) m) = (n,m)++   Here, the pattern (C (n+1)) binds a hidden dictionary (d::Num a),+   and *also* uses that dictionary to match the (n+1) pattern.  Yet, the+   variables bound by the lazy pattern are n,m, *not* the dictionary d.+   So in mkSelectorBinds in GHC.HsToCore.Utils, we want just m,n as the+   variables bound.++   So in this case, we do *not* gather (a) dictionary and (b) dictionary+   bindings as binders of a ConPatOut pattern.+++3. On the other hand, desugaring of arrows needs evidence bindings and uses+   CollWithDictBinders flag.++   Consider++        h :: (ArrowChoice a, Arrow a) => Int -> a (Int,Int) Int+        h x = proc (y,z) -> case compare x y of+                        GT -> returnA -< z+x++   The type checker turns the case into++        case compare x y of+          GT { $dNum_123 = $dNum_Int } -> returnA -< (+) $dNum_123 z x++   That is, it attaches the $dNum_123 binding to a ConPatOut in scope.++   During desugaring, evidence binders must be collected because their sets are+   intersected with free variable sets of subsequent commands to create+   (minimal) command environments.  Failing to do it properly leads to bugs+   (e.g., #18950).++   Note: attaching evidence binders to existing ConPatOut may be suboptimal for+   arrows.  In the example above we would prefer to generate:++        case compare x y of+          GT -> returnA -< let $dNum_123 = $dNum_Int in (+) $dNum_123 z x++   So that the evidence isn't passed into the command environment. This issue+   doesn't arise with desugaring of non-arrow code because the simplifier can+   freely float and inline let-expressions created for evidence binders. But+   with arrow desugaring, the simplifier would have to see through the command+   environment tuple which is more complicated.++-}++hsGroupBinders :: HsGroup GhcRn -> [Name]+hsGroupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls,+                          hs_fords = foreign_decls })+  =  collectHsValBinders CollNoDictBinders val_decls+  ++ hsTyClForeignBinders tycl_decls foreign_decls++hsTyClForeignBinders :: [TyClGroup GhcRn]+                     -> [LForeignDecl GhcRn]+                     -> [Name]+-- We need to look at instance declarations too,+-- because their associated types may bind data constructors+hsTyClForeignBinders tycl_decls foreign_decls+  =    map unLoc (hsForeignDeclsBinders foreign_decls)+    ++ getSelectorNames+         (foldMap (foldMap (tyDeclBinders . hsLTyClDeclBinders) . group_tyclds) tycl_decls+         `mappend`+         (foldMap (foldMap hsLInstDeclBinders . group_instds) tycl_decls))+  where+    getSelectorNames :: ([LocatedA Name], [LFieldOcc GhcRn]) -> [Name]+    getSelectorNames (ns, fs) = map unLoc ns ++ map (unLoc . foLabel . unLoc) fs++-------------------++data TyDeclBinders p+  = TyDeclBinders+  { tyDeclMainBinder     :: !(LocatedA (IdP (GhcPass p)), TyConFlavour ())+  , tyDeclATs            :: ![(LocatedA (IdP (GhcPass p)), TyConFlavour ())]+  , tyDeclOpSigs         :: ![LocatedA (IdP (GhcPass p))]+  , tyDeclConsWithFields :: !(LConsWithFields p) }++tyDeclBinders :: TyDeclBinders p -> ([LocatedA (IdP (GhcPass p))], [LFieldOcc (GhcPass p)])+tyDeclBinders (TyDeclBinders main ats sigs consWithFields)+  = (fst main : (fmap fst ats ++ sigs ++ cons), flds)+  where+    (cons, flds) = lconsWithFieldsBinders consWithFields++hsLTyClDeclBinders :: (IsPass p, OutputableBndrId p)+                   => LocatedA (TyClDecl (GhcPass p))+                   -> TyDeclBinders p+-- ^ Returns all the /binding/ names of the decl.  The first one is+-- guaranteed to be the name of the decl. The first component+-- represents all binding names except record fields; the second+-- represents field occurrences. For record fields mentioned in+-- multiple constructors, the SrcLoc will be from the first occurrence.+--+-- Each returned (Located name) has a SrcSpan for the /whole/ declaration.+-- See Note [SrcSpan for binders]++hsLTyClDeclBinders (L loc (FamDecl { tcdFam = FamilyDecl+                                            { fdLName = (L _ name)+                                            , fdInfo  = fd_info } }))+  = TyDeclBinders+  { tyDeclMainBinder = (L loc name, familyInfoTyConFlavour Nothing fd_info)+  , tyDeclATs = [], tyDeclOpSigs = []+  , tyDeclConsWithFields = emptyLConsWithFields }+hsLTyClDeclBinders (L loc (SynDecl+                               { tcdLName = (L _ name) }))+  = TyDeclBinders+  { tyDeclMainBinder = (L loc name, TypeSynonymFlavour)+  , tyDeclATs = [], tyDeclOpSigs = []+  , tyDeclConsWithFields = emptyLConsWithFields }+hsLTyClDeclBinders (L loc (ClassDecl+                               { tcdLName = (L _ cls_name)+                               , tcdSigs  = sigs+                               , tcdATs   = ats }))+  = TyDeclBinders+  { tyDeclMainBinder = (L loc cls_name, ClassFlavour)+  , tyDeclATs = [ (L fam_loc fam_name, familyInfoTyConFlavour (Just ()) fd_info)+                | (L fam_loc (FamilyDecl { fdLName = L _ fam_name+                                         , fdInfo = fd_info })) <- ats ]+  , tyDeclOpSigs = [ L mem_loc mem_name+                   | (L mem_loc (ClassOpSig _ False ns _)) <- sigs+                   , (L _ mem_name) <- ns ]+  , tyDeclConsWithFields = emptyLConsWithFields }+hsLTyClDeclBinders (L loc (DataDecl    { tcdLName = (L _ name)+                                       , tcdDataDefn = defn }))+  = TyDeclBinders+  { tyDeclMainBinder = (L loc name, flav )+  , tyDeclATs = []+  , tyDeclOpSigs = []+  , tyDeclConsWithFields = hsDataDefnBinders defn }+  where+    flav = newOrDataToFlavour $ dataDefnConsNewOrData $ dd_cons defn++-------------------+hsForeignDeclsBinders :: forall p a. (UnXRec (GhcPass p), IsSrcSpanAnn p a)+                      => [LForeignDecl (GhcPass p)] -> [LIdP (GhcPass p)]+-- ^ See Note [SrcSpan for binders]+hsForeignDeclsBinders foreign_decls+  = [ L (noAnnSrcSpan (locA decl_loc)) n+    | L decl_loc (ForeignImport { fd_name = L _ n })+        <- foreign_decls]+++-------------------+hsPatSynSelectors :: IsPass p => HsValBinds (GhcPass p) -> [FieldOcc (GhcPass p)]+-- ^ Collects record pattern-synonym selectors only; the pattern synonym+-- names are collected by 'collectHsValBinders'.+hsPatSynSelectors (ValBinds _ _ _) = panic "hsPatSynSelectors"+hsPatSynSelectors (XValBindsLR (NValBinds binds _))+  = foldr addPatSynSelector [] . concat $ map snd binds++addPatSynSelector :: forall p. UnXRec p => LHsBind p -> [FieldOcc p] -> [FieldOcc p]+addPatSynSelector bind sels+  | PatSynBind _ (PSB { psb_args = RecCon as }) <- unXRec @p bind+  = map recordPatSynField as ++ sels+  | otherwise = sels++getPatSynBinds :: forall id. UnXRec id+               => [(RecFlag, LHsBinds id)] -> [PatSynBind id id]+getPatSynBinds binds+  = [ psb | (_, lbinds) <- binds+          , (unXRec @id -> (PatSynBind _ psb)) <- lbinds ]++-------------------+hsLInstDeclBinders :: (IsPass p, OutputableBndrId p)+                   => LInstDecl (GhcPass p)+                   -> ([(LocatedA (IdP (GhcPass p)))], [LFieldOcc (GhcPass p)])+hsLInstDeclBinders (L _ (ClsInstD+                             { cid_inst = ClsInstDecl+                                          { cid_datafam_insts = dfis }}))+  = foldMap (lconsWithFieldsBinders . hsDataFamInstBinders . unLoc) dfis+hsLInstDeclBinders (L _ (DataFamInstD { dfid_inst = fi }))+  = lconsWithFieldsBinders $ hsDataFamInstBinders fi+hsLInstDeclBinders (L _ (TyFamInstD {})) = mempty++-------------------+-- | the 'SrcLoc' returned are for the whole declarations, not just the names+hsDataFamInstBinders :: (IsPass p, OutputableBndrId p)+                     => DataFamInstDecl (GhcPass p)+                     -> LConsWithFields p+hsDataFamInstBinders (DataFamInstDecl { dfid_eqn = FamEqn { feqn_rhs = defn }})+  = hsDataDefnBinders defn+  -- There can't be repeated symbols because only data instances have binders++-------------------+-- | the 'SrcLoc' returned are for the whole declarations, not just the names+hsDataDefnBinders :: (IsPass p, OutputableBndrId p)+                  => HsDataDefn (GhcPass p)+                  -> LConsWithFields p+hsDataDefnBinders (HsDataDefn { dd_cons = cons })+  = hsConDeclsBinders (toList cons)+  -- See Note [Binders in family instances]++-------------------++{- Note [Collecting record fields in data declarations]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When renaming a data declaration that includes record constructors, we are, in+the end, going to to create a mapping from constructor to its field labels,+to store in 'GREInfo' (see 'IAmConLike'). This allows us to know, in the renamer,+which constructor has what fields.++In order to achieve this, we return the constructor and field information from+hsConDeclsBinders in the following format:++  - [(ConRdrName, [Located Int])], a list of the constructors, each associated+    with its record fields, in the form of a list of Int indices into...+  - IntMap FieldOcc, an IntMap of record fields.++(In actual fact, we use [(ConRdrName, Maybe [Located Int])], with Nothing indicating+that the constructor has unlabelled fields: see Note [Local constructor info in the renamer]+in GHC.Types.GREInfo.)++This allows us to do the following (see GHC.Rename.Names.getLocalNonValBinders.new_tc):++  - create 'Name's for each of the record fields, to get IntMap FieldLabel,+  - create 'Name's for each of the constructors, to get [(ConName, [Int])],+  - look up the FieldLabels of each constructor, to get [(ConName, [FieldLabel])].++NB: This can be a bit tricky to get right in the presence of data types with+duplicate constructors or fields. Storing locations allows us to report an error+for duplicate field declarations, see test cases T9156 T9156_DF.+Other relevant test cases: rnfail015.++-}++-- | A mapping from constructors to all of their fields.+--+-- See Note [Collecting record fields in data declarations].+data LConsWithFields p =+  LConsWithFields+    { consWithFieldIndices :: [(LocatedA (IdP (GhcPass p)), Maybe [Located Int])]+    , consFields :: IntMap (LFieldOcc (GhcPass p))+    }++lconsWithFieldsBinders :: LConsWithFields p+                       -> ([(LocatedA (IdP (GhcPass p)))], [LFieldOcc (GhcPass p)])+lconsWithFieldsBinders (LConsWithFields cons fields)+  = (map fst cons, IntMap.elems fields)++emptyLConsWithFields :: LConsWithFields p+emptyLConsWithFields = LConsWithFields [] IntMap.empty++hsConDeclsBinders :: forall p. (IsPass p, OutputableBndrId p)+                  => [LConDecl (GhcPass p)]+                  -> LConsWithFields p+  -- The function is boringly complicated because of the records+  -- And since we only have equality, we have to be a little careful+hsConDeclsBinders cons = go emptyFieldIndices cons+  where+    go :: FieldIndices p -> [LConDecl (GhcPass p)] -> LConsWithFields p+    go seen [] = LConsWithFields [] (fields seen)+    go seen (r:rs)+      -- Don't re-mangle the location of field names, because we don't+      -- have a record of the full location of the field declaration anyway+      = let loc = getLoc r+        in case unLoc r of+           ConDeclGADT { con_names = names, con_g_args = args }+             -> LConsWithFields (cons ++ ns) fs+             where+                cons = map ( , con_flds ) $ toList (L loc . unLoc <$> names)+                (con_flds, seen') = get_flds_gadt seen args+                LConsWithFields ns fs = go seen' rs++           ConDeclH98 { con_name = name, con_args = args }+             -> LConsWithFields ([(L loc (unLoc name), con_flds)] ++ ns) fs+             where+                (con_flds, seen') = get_flds_h98 seen args+                LConsWithFields ns fs = go seen' rs++    get_flds_h98 :: FieldIndices p -> HsConDeclH98Details (GhcPass p)+                 -> (Maybe [Located Int], FieldIndices p)+    get_flds_h98 seen (RecCon flds) = first Just $ get_flds seen flds+    get_flds_h98 seen (PrefixCon []) = (Just [], seen)+    get_flds_h98 seen _ = (Nothing, seen)++    get_flds_gadt :: FieldIndices p -> HsConDeclGADTDetails (GhcPass p)+                  -> (Maybe [Located Int], FieldIndices p)+    get_flds_gadt seen (RecConGADT _ flds) = first Just $ get_flds seen flds+    get_flds_gadt seen (PrefixConGADT _ []) = (Just [], seen)+    get_flds_gadt seen _ = (Nothing, seen)++    get_flds :: FieldIndices p -> LocatedL [LHsConDeclRecField (GhcPass p)]+             -> ([Located Int], FieldIndices p)+    get_flds seen flds =+      foldr add_fld ([], seen) fld_names+      where+        add_fld fld (is, ixs) =+          let (i, ixs') = insertField fld ixs+          in  (i:is, ixs')+        fld_names = concatMap (cdrf_names . unLoc) (unLoc flds)++-- | A bijection between record fields of a datatype and integers,+-- used to implement Note [Collecting record fields in data declarations].+data FieldIndices p =+  FieldIndices+    { fields       :: IntMap (LFieldOcc (GhcPass p))+        -- ^ Look up a field from its index.+    , fieldIndices :: Map RdrName Int+        -- ^ Look up the index of a field label in the previous 'IntMap'.+    , newInt       :: !Int+        -- ^ An integer @i@ such that no integer @i' >= i@ appears in the 'IntMap'.+    }++emptyFieldIndices :: FieldIndices p+emptyFieldIndices =+  FieldIndices { fields       = IntMap.empty+               , fieldIndices = Map.empty+               , newInt       = 0 }++insertField :: IsPass p => LFieldOcc (GhcPass p) -> FieldIndices p -> (Located Int, FieldIndices p)+insertField new_fld fi@(FieldIndices flds idxs new_idx)+  | Just i <- Map.lookup rdr idxs+  = (L loc i, fi)+  | otherwise+  = (L loc new_idx,+      FieldIndices (IntMap.insert new_idx new_fld flds)+                   (Map.insert rdr new_idx idxs)+                   (new_idx + 1))+  where+    loc = getLocA new_fld+    rdr = fieldOccRdrName . unLoc $ new_fld++{-++Note [SrcSpan for binders]+~~~~~~~~~~~~~~~~~~~~~~~~~~+When extracting the (Located RdrName) for a binder, at least for the+main name (the TyCon of a type declaration etc), we want to give it+the @SrcSpan@ of the whole /declaration/, not just the name itself+(which is how it appears in the syntax tree).  This SrcSpan (for the+entire declaration) is used as the SrcSpan for the Name that is+finally produced, and hence for error messages.  (See #8607.)++Note [Binders in family instances]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In a type or data family instance declaration, the type+constructor is an *occurrence* not a binding site+    type instance T Int = Int -> Int   -- No binders+    data instance S Bool = S1 | S2     -- Binders are S1,S2+++************************************************************************+*                                                                      *+        Collecting binders the user did not write+*                                                                      *+************************************************************************++The job of the following family of functions is to run through binding sites and find+the set of all Names that were defined "implicitly", without being explicitly written+by the user.++Note [Collecting implicit binders]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We collect all the RHS Names that are implicitly introduced by record wildcards,+so that we can:++  - avoid warning the user when they don't use those names (#4404),+  - report deprecation warnings for deprecated fields that are used (#23382).++The functions that collect implicit binders return a collection of 'ImplicitFieldBinders',+which associates each implicitly-introduced record field with the bound variables in the+RHS of the record field pattern, e.g. in++  data R = MkR { fld :: Int }+  foo (MkR { .. }) = fld++the renamer will elaborate this to++  foo (MkR { fld = fld_var }) = fld_var++and the implicit binders function will return++  [ ImplicitFieldBinders { implFlBndr_field = fld+                         , implFlBndr_binders = [fld_var] } ]++This information is then used:++  - in the calls to GHC.Rename.Utils.checkUnusedRecordWildcard, to emit+    a warning when a record wildcard binds no new variables (redundant record wildcard)+    or none of the bound variables are used (unused record wildcard).+  - in GHC.Rename.Utils.deprecateUsedRecordWildcard, to emit a warning+    when the field is deprecated and any of the binders are used.++NOTE: the implFlBndr_binders field should always be a singleton+      (since the RHS of an implicit binding should always be a VarPat,+      created in rnHsRecPatsAndThen.mkVarPat)++-}++-- | All binders corresponding to a single implicit record field pattern.+--+-- See Note [Collecting implicit binders].+data ImplicitFieldBinders+  = ImplicitFieldBinders { implFlBndr_field :: Name+                             -- ^ The 'Name' of the record field+                         , implFlBndr_binders :: [Name]+                             -- ^ The binders of the RHS of the record field pattern+                             -- (in practice, always a singleton: see Note [Collecting implicit binders])+                         }++lStmtsImplicits :: forall idR body . IsPass idR => [LStmtLR GhcRn (GhcPass idR) (LocatedA (body (GhcPass idR)))]+                -> [(SrcSpan, [ImplicitFieldBinders])]+lStmtsImplicits = hs_lstmts+  where+    hs_lstmts :: forall idR body . IsPass idR => [LStmtLR GhcRn (GhcPass idR) (LocatedA (body (GhcPass idR)))]+              -> [(SrcSpan, [ImplicitFieldBinders])]+    hs_lstmts = concatMap (hs_stmt . unLoc)++    hs_stmt :: forall idR body . IsPass idR => StmtLR GhcRn (GhcPass idR) (LocatedA (body (GhcPass idR)))+            -> [(SrcSpan, [ImplicitFieldBinders])]+    hs_stmt (BindStmt _ pat _) = lPatImplicits pat+    hs_stmt (XStmtLR x) = case ghcPass :: GhcPass idR of+        GhcRn -> hs_applicative_stmt x+        GhcTc -> hs_applicative_stmt x+    hs_stmt (LetStmt _ binds)     = hs_local_binds binds+    hs_stmt (BodyStmt {})         = []+    hs_stmt (LastStmt {})         = []+    hs_stmt (ParStmt _ xs _ _)    = hs_lstmts [s | ParStmtBlock _ ss _ _ <- toList xs , s <- ss]+    hs_stmt (TransStmt { trS_stmts = stmts }) = hs_lstmts stmts+    hs_stmt (RecStmt { recS_stmts = L _ ss }) = hs_lstmts ss++    hs_local_binds (HsValBinds _ val_binds) = hsValBindsImplicits val_binds+    hs_local_binds (HsIPBinds {})           = []+    hs_local_binds (EmptyLocalBinds _)      = []++    hs_applicative_stmt (ApplicativeStmt _ args _) = concatMap do_arg args+      where do_arg (_, ApplicativeArgOne { app_arg_pattern = pat }) = lPatImplicits pat+            do_arg (_, ApplicativeArgMany { app_stmts = stmts }) = hs_lstmts stmts++hsValBindsImplicits :: HsValBindsLR GhcRn (GhcPass idR)+                    -> [(SrcSpan, [ImplicitFieldBinders])]+hsValBindsImplicits (XValBindsLR (NValBinds binds _))+  = concatMap (lhsBindsImplicits . snd) binds+hsValBindsImplicits (ValBinds _ binds _)+  = lhsBindsImplicits binds++lhsBindsImplicits :: LHsBindsLR GhcRn idR -> [(SrcSpan, [ImplicitFieldBinders])]+lhsBindsImplicits = concatMap (lhs_bind . unLoc)+  where+    lhs_bind (PatBind { pat_lhs = lpat }) = lPatImplicits lpat+    lhs_bind _ = []++-- | Collect all record wild card binders in the given pattern.+--+-- These are all the variables bound in all (possibly nested) record wildcard patterns+-- appearing inside the pattern.+--+-- See Note [Collecting implicit binders].+lPatImplicits :: LPat GhcRn -> [(SrcSpan, [ImplicitFieldBinders])]+lPatImplicits = hs_lpat+  where+    hs_lpat lpat = hs_pat (unLoc lpat)++    hs_lpats = foldr (\pat rest -> hs_lpat pat ++ rest) []++    hs_pat (LazyPat _ pat)      = hs_lpat pat+    hs_pat (BangPat _ pat)      = hs_lpat pat+    hs_pat (AsPat _ _ pat)      = hs_lpat pat+    hs_pat (ViewPat _ _ pat)    = hs_lpat pat+    hs_pat (ParPat _ pat)       = hs_lpat pat+    hs_pat (ListPat _ pats)     = hs_lpats pats+    hs_pat (TuplePat _ pats _)  = hs_lpats pats+    hs_pat (SigPat _ pat _)     = hs_lpat pat++    hs_pat (ConPat {pat_args=ps}) = details ps++    hs_pat _ = []++    details :: HsConPatDetails GhcRn -> [(SrcSpan, [ImplicitFieldBinders])]+    details (PrefixCon ps) = hs_lpats ps+    details (RecCon (HsRecFields { rec_dotdot = Nothing, rec_flds }))+      = hs_lpats $ map (hfbRHS . unLoc) rec_flds+    details (RecCon (HsRecFields { rec_dotdot = Just (L err_loc rec_dotdot), rec_flds }))+          = [(l2l err_loc, implicit_field_binders)]+          ++ hs_lpats explicit_pats++          where (explicit_pats, implicit_field_binders)+                  = rec_field_expl_impl rec_flds rec_dotdot++    details (InfixCon p1 p2) = hs_lpat p1 ++ hs_lpat p2++lHsRecFieldsImplicits :: [LHsRecField GhcRn (LPat GhcRn)]+                      -> RecFieldsDotDot+                      -> [ImplicitFieldBinders]+lHsRecFieldsImplicits rec_flds rec_dotdot+  = snd $ rec_field_expl_impl rec_flds rec_dotdot++rec_field_expl_impl :: [LHsRecField GhcRn (LPat GhcRn)]+                    -> RecFieldsDotDot+                    -> ([LPat GhcRn], [ImplicitFieldBinders])+rec_field_expl_impl rec_flds (RecFieldsDotDot { .. })+  = ( map (hfbRHS . unLoc) explicit_binds+    , map implicit_field_binders implicit_binds )+  where (explicit_binds, implicit_binds) = splitAt unRecFieldsDotDot rec_flds+        implicit_field_binders (L _ (HsFieldBind { hfbLHS = L _ fld, hfbRHS = rhs }))+          = ImplicitFieldBinders+              { implFlBndr_field   = unLoc $ foLabel (fld :: FieldOcc GhcRn)+              , implFlBndr_binders = collectPatBinders CollNoDictBinders rhs }
GHC/HsToCore.hs view
@@ -1,4 +1,4 @@-+{-# LANGUAGE MonadComprehensions #-} {-# LANGUAGE TypeFamilies #-}  {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}@@ -18,59 +18,65 @@  import GHC.Prelude -import GHC.Driver.Session+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.Usage 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.TyCon     ( tyConDataCons )+import GHC.Core.TyCo.Compare( eqType )+import GHC.Core.TyCon       ( tyConDataCons ) import GHC.Core-import GHC.Core.FVs       ( exprsSomeFreeVarsList )+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.Monad ( CoreToDo(..) )-import GHC.Core.Lint     ( endPassIO )+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.FastString 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.Plain+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@@ -91,6 +97,8 @@  import Data.List (partition) import Data.IORef+import GHC.Iface.Make (mkRecompUsageInfo)+import GHC.Runtime.Interpreter (interpreterProfiled)  {- ************************************************************************@@ -113,55 +121,67 @@                             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_patsyns      = patsyns,                             tcg_tcs          = tcs,+                            tcg_default_exports = defaults,                             tcg_insts        = insts,                             tcg_fam_insts    = fam_insts,-                            tcg_hpc          = other_hpc_info,                             tcg_complete_matches = complete_matches,                             tcg_self_boot    = self_boot                             })    = do { let dflags = hsc_dflags hsc_env              logger = hsc_logger hsc_env-             print_unqual = mkPrintUnqualified (hsc_unit_env hsc_env) rdr_env+             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-              hpcInfo    = emptyHpcInfo other_hpc_info+              -- See Note [Named default declarations] in GHC.Tc.Gen.Default -        ; (binds_cvr, ds_hpc_info, modBreaks)+        ; (binds_cvr, m_tickInfo)                          <- if not (isHsBootOrSig hsc_src)                               then addTicksToBinds-                                       (CoverageConfig-                                        { coverageConfig_logger = hsc_logger hsc_env-                                        , coverageConfig_dynFlags = hsc_dflags hsc_env-                                        , coverageConfig_mInterp = hsc_interp hsc_env-                                        })+                                       (hsc_logger hsc_env)+                                       (initTicksConfig (hsc_dflags hsc_env))                                        mod mod_loc                                        export_set (typeEnvTyCons type_env) binds-                              else return (binds, hpcInfo, Nothing)+                              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 { ds_ev_binds <- dsEvBinds ev_binds-                          ; core_prs <- dsTopLHsBinds binds_cvr+                       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@@ -172,7 +192,7 @@                           ; return ( ds_ev_binds                                    , foreign_prs `appOL` core_prs `appOL` spec_prs                                    , spec_rules ++ ds_rules-                                   , ds_fords `appendStubC` hpc_init) }+                                   , ds_fords `appendStubC` hpc_init) } }          ; case mb_res of {            Nothing -> return (msgs, Nothing) ;@@ -191,7 +211,7 @@         -- 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#! -        ; endPassIO hsc_env print_unqual CoreDesugar final_pgm rules_for_imps+        ; 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@@ -200,23 +220,19 @@         ; putDumpFileMaybe logger Opt_D_dump_occur_anal "Occurrence analysis"             FormatCore (pprCoreBindings occ_anald_binds $$ pprRules ds_rules_for_imps ) -        ; endPassIO hsc_env print_unqual CoreDesugarOpt ds_binds ds_rules_for_imps+        ; endPassHscEnvIO hsc_env name_ppr_ctx CoreDesugarOpt ds_binds ds_rules_for_imps -        ; let used_names = mkUsedNames tcg_env-              pluginModules = map lpModule (loadedPlugins (hsc_plugins hsc_env))+        ; 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) -        ; used_th <- readIORef tc_splice_used-        ; dep_files <- readIORef dependent_files         ; safe_mode <- finalSafeMode dflags tcg_env-        ; (needed_mods, needed_pkgs) <- readIORef (tcg_th_needed_deps tcg_env) -        ; usages <- mkUsageInfo hsc_env mod (imp_mods imports) used_names-                      dep_files merged needed_mods needed_pkgs+        ; 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@@ -234,12 +250,12 @@                 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_defaults     = defaults,                 mg_insts        = fixSafeInstances safe_mode insts,                 mg_fam_insts    = fam_insts,                 mg_inst_env     = inst_env,@@ -260,18 +276,6 @@         ; 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]@@ -310,7 +314,7 @@        -- mb_result is Nothing only when a failure happens in the type-checker,       -- but mb_core_expr is Nothing when a failure happens in the desugarer-    let (ds_msgs, mb_core_expr) = expectJust "deSugarExpr" mb_result+    let (ds_msgs, mb_core_expr) = expectJust mb_result      case mb_core_expr of        Nothing   -> return ()@@ -335,33 +339,28 @@ addExportFlagsAndRules     :: Backend -> NameSet -> NameSet -> [CoreRule]     -> [(Id, t)] -> [(Id, t)]-addExportFlagsAndRules bcknd exports keep_alive rules prs-  = mapFst add_one prs+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-    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+    add_export_flag bndr+        | dont_discard bndr = setIdExported bndr         | otherwise         = bndr -    dont_discard :: Name -> Bool-    dont_discard name = is_exported name+    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@@ -371,7 +370,7 @@         -- isExternalName separates the user-defined top-level names from those         -- introduced by the type checker.     is_exported :: Name -> Bool-    is_exported | backendRetainsAllBindings bcknd = isExternalName+    is_exported | backendWantsGlobalBindings bcknd = isExternalName                 | otherwise                       = (`elemNameSet` exports)  {-@@ -421,14 +420,18 @@ dsRule :: LRuleDecl GhcTc -> DsM (Maybe CoreRule) dsRule (L loc (HsRule { rd_name = name                       , rd_act  = rule_act-                      , rd_tmvs = vars+                      , rd_bndrs = RuleBndrs { rb_ext = bndrs }                       , rd_lhs  = lhs                       , rd_rhs  = rhs }))   = putSrcSpanDs (locA loc) $-    do  { let bndrs' = [var | L _ (RuleBndr _ (L _ var)) <- vars]+    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 $+                  unsetWOptM Opt_WarnIdentities     $+                  zapUnspecables                    $                   dsLExpr lhs   -- Note [Desugaring RULE left hand sides]          ; rhs' <- dsLExpr rhs@@ -439,7 +442,7 @@         -- Substitute the dict bindings eagerly,         -- and take the body apart into a (f args) form         ; dflags <- getDynFlags-        ; case decomposeRuleLhs dflags bndrs'' lhs'' of {+        ; case decomposeRuleLhs dflags bndrs'' lhs'' (exprFreeVars rhs'') of {                 Left msg -> do { diagnosticDs msg; return Nothing } ;                 Right (final_bndrs, fn_id, args) -> do @@ -450,27 +453,28 @@               fn_name   = idName fn_id               simpl_opts = initSimpleOpts dflags               final_rhs = simpleOptExpr simpl_opts 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--        ; rule <- dsMkUserRule this_mod is_local-                         rule_name rule_act fn_name final_bndrs args-                         final_rhs-        ; warnRuleShadowing rule_name rule_act fn_id arg_ids+              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)         } } } -warnRuleShadowing :: RuleName -> Activation -> Id -> [Id] -> DsM ()+dsWarnRuleShadowing :: Id -> CoreRule -> DsM () -- See Note [Rules and inlining/other rules]-warnRuleShadowing rule_name rule_act fn_id arg_ids+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@@ -486,6 +490,8 @@       = [ 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@@ -526,6 +532,9 @@ 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@@ -720,11 +729,11 @@                           , openAlphaTyVar, openBetaTyVar                           , x ] $                    mkSingleAltCase scrut1-                                   (mkWildValBinder Many scrut1_ty)+                                   (mkWildValBinder ManyTy scrut1_ty)                                    (DataAlt unsafe_refl_data_con)                                    [rr_cv] $                    mkSingleAltCase scrut2-                                   (mkWildValBinder Many scrut2_ty)+                                   (mkWildValBinder ManyTy scrut2_ty)                                    (DataAlt unsafe_refl_data_con)                                    [ab_cv] $                    Var x `mkCast` x_co@@ -739,7 +748,7 @@              unsafe_equality k a b                = ( mkTyApps (Var unsafe_equality_proof_id) [k,b,a]                  , mkTyConApp unsafe_equality_tc [k,b,a]-                 , mkHeteroPrimEqPred k k a b+                 , mkNomEqPred a b                  )              -- NB: UnsafeRefl :: (b ~# a) -> UnsafeEquality a b, so we have to              -- carefully swap the arguments above@@ -756,12 +765,12 @@              alpha_co = mkTyConAppCo Nominal tYPETyCon [mkCoVarCo rr_cv]               -- x_co :: alpha ~R# beta-             x_co = mkGReflCo Representational openAlphaTy (MCo alpha_co) `mkTransCo`+             x_co = mkGReflMCo Representational openAlphaTy alpha_co `mkTransCo`                     mkSubCo (mkCoVarCo ab_cv)                info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma-                                `setUnfoldingInfo` mkCompulsoryUnfolding' rhs+                                `setUnfoldingInfo` mkCompulsoryUnfolding rhs                                 `setArityInfo`     arity               ty = mkSpecForAllTys [ runtimeRep1TyVar, runtimeRep2TyVar@@ -770,5 +779,9 @@               arity = 1 -             id   = mkExportedVanillaId unsafeCoercePrimName ty `setIdInfo` info+             concs = mkRepPolyIdConcreteTyVars+                     [((mkTyVarTy openAlphaTyVar, mkArgPos 1 Top), runtimeRep1TyVar)]+                     unsafeCoercePrimName++             id   = mkExportedLocalId (RepPolyId concs) unsafeCoercePrimName ty `setIdInfo` info        ; return (id, old_expr) }
GHC/HsToCore/Arrows.hs view
@@ -2,8 +2,6 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE TupleSections #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}- {- (c) The University of Glasgow 2006 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998@@ -87,7 +85,7 @@   where     mk_bind (std_name, expr)       = do { rhs <- dsExpr expr-           ; id <- newSysLocalDs Many (exprType rhs)+           ; id <- newSysLocalMDs (exprType rhs)            -- no check needed; these are functions            ; return (NonRec id rhs, (std_name, id)) } @@ -136,18 +134,18 @@ -- construct CoreExpr for \ (a :: a_ty, b :: b_ty) -> a mkFstExpr :: Type -> Type -> DsM CoreExpr mkFstExpr a_ty b_ty = do-    a_var <- newSysLocalDs Many a_ty-    b_var <- newSysLocalDs Many b_ty-    pair_var <- newSysLocalDs Many (mkCorePairTy a_ty b_ty)+    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 <- newSysLocalDs Many a_ty-    b_var <- newSysLocalDs Many b_ty-    pair_var <- newSysLocalDs Many (mkCorePairTy a_ty b_ty)+    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))) @@ -160,9 +158,9 @@ --      = 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)+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@@ -178,11 +176,20 @@ 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+{- 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,@@ -224,10 +231,9 @@                 -> CoreExpr     -- e                 -> DsM CoreExpr matchEnvStack env_ids stack_id body = do-    uniqs <- newUniqueSupply-    tup_var <- newSysLocalDs Many (mkBigCoreVarTupTy env_ids)-    let match_env = coreCaseTuple uniqs tup_var env_ids body-    pair_id <- newSysLocalDs Many (mkCorePairTy (idType tup_var) (idType stack_id))+    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))  ----------------------------------------------@@ -243,9 +249,9 @@          -> CoreExpr    -- e          -> DsM CoreExpr matchEnv env_ids body = do-    uniqs <- newUniqueSupply-    tup_id <- newSysLocalDs Many (mkBigCoreVarTupTy env_ids)-    return (Lam tup_id (coreCaseTuple uniqs tup_id env_ids body))+    tup_id <- newSysLocalMDs (mkBigCoreVarTupTy env_ids)+    tup_case <- coreCaseTuple tup_id env_ids body+    return (Lam tup_id tup_case)  ---------------------------------------------- --              matchVarStack@@ -259,7 +265,7 @@ 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 Many (mkCorePairTy (idType param_id) (idType tail_id))+    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@@ -288,8 +294,8 @@     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 Many pat-    match_code <- matchSimply (Var var) (ArrowMatchCtxt ProcExpr) pat env_stk_expr fail_expr+    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)@@ -337,7 +343,7 @@         (_a_ty, arg_ty) = tcSplitAppTy a_arg_ty     core_arrow <- dsLExpr arrow     core_arg   <- dsLExpr arg-    stack_id   <- newSysLocalDs Many stack_ty+    stack_id   <- newSysLocalMDs stack_ty     core_make_arg <- matchEnvStack env_ids stack_id core_arg     return (do_premap ids               (envStackType env_ids stack_ty)@@ -363,7 +369,7 @@      core_arrow <- dsLExpr arrow     core_arg   <- dsLExpr arg-    stack_id   <- newSysLocalDs Many stack_ty+    stack_id   <- newSysLocalMDs stack_ty     core_make_pair <- matchEnvStack env_ids stack_id           (mkCorePairExpr core_arrow core_arg) @@ -390,8 +396,8 @@         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 Many stack_ty-    arg_id <- newSysLocalDs Many arg_ty+    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)@@ -409,14 +415,7 @@             free_vars `unionDVarSet`               (exprFreeIdsDSet core_arg `uniqDSetIntersectUniqSet` local_vars)) -dsCmd ids local_vars stack_ty res_ty-        (HsCmdLam _ (MG { mg_alts-          = (L _ [L _ (Match { m_pats  = 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 (HsCmdPar _ _ cmd _) env_ids+dsCmd ids local_vars stack_ty res_ty (HsCmdPar _ cmd) env_ids   = dsLCmd ids local_vars stack_ty res_ty cmd env_ids  -- D, xs |- e :: Bool@@ -436,7 +435,7 @@        <- 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 Many stack_ty+    stack_id   <- newSysLocalMDs stack_ty     either_con <- dsLookupTyCon eitherTyConName     left_con   <- dsLookupDataCon leftDataConName     right_con  <- dsLookupDataCon rightDataConName@@ -498,13 +497,13 @@ -}  dsCmd ids local_vars stack_ty res_ty (HsCmdCase _ exp match) env_ids = do-    stack_id <- newSysLocalDs Many stack_ty+    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'+    let MG{ mg_ext = MatchGroupTc _ sum_ty _ } = match'         in_ty = envStackType env_ids stack_ty -    core_body <- dsExpr (HsCase noExtField exp match')+    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,@@ -529,22 +528,29 @@  -} dsCmd ids local_vars stack_ty res_ty-      (HsCmdLamCase _ lc_variant match@MG { mg_ext = MatchGroupTc {mg_arg_tys = arg_tys} } )+        (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 = ArrowLamCaseAlt lc_variant+    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 <- newSysLocalDs Many stack_ty'+      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'+      let MG{ mg_ext = MatchGroupTc _ sum_ty _ } = match'           in_ty = envStackType env_ids stack_ty'           discrims = map nlHsVar arg_ids       (discrim_vars, matching_code)@@ -556,8 +562,8 @@       return (do_premap ids in_ty sum_ty res_ty core_matches core_choices,               exprFreeIdsDSet core_body `uniqDSetIntersectUniqSet` local_vars') -    param_ids <- mapM (newSysLocalDs Many) pat_tys-    stack_id' <- newSysLocalDs Many stack_ty'+    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@@ -585,14 +591,14 @@ -- --              ---> premap (\ ((xs),stk) -> let binds in ((ys),stk)) c -dsCmd ids local_vars stack_ty res_ty (HsCmdLet _ _ lbinds@binds _ body) env_ids = do+dsCmd ids local_vars stack_ty res_ty (HsCmdLet _ lbinds@binds body) env_ids = do     let         defined_vars = mkVarSet (collectLocalBinders CollWithDictBinders binds)         local_vars' = defined_vars `unionVarSet` local_vars      (core_body, _free_vars, env_ids')        <- dsfixCmd ids local_vars' stack_ty res_ty body-    stack_id <- newSysLocalDs Many stack_ty+    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@@ -628,7 +634,7 @@ -- ----------------------------------- -- 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+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@@ -637,10 +643,8 @@  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-    core_wrap <- dsHsWrapper wrap-    return (core_wrap core_cmd, env_ids')--dsCmd _ _ _ _ c _ = pprPanic "dsCmd" (ppr c)+    dsHsWrapper wrap $ \core_wrap ->+      return (core_wrap core_cmd, env_ids')  -- D; ys |-a c : stk --> t      (ys <= xs) -- ---------------------@@ -658,7 +662,7 @@     (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 Many stack_ty+    stack_id <- newSysLocalMDs stack_ty     trim_code       <- matchEnvStack env_ids stack_id (buildEnvStack env_ids' stack_id)     let@@ -722,8 +726,8 @@         (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 (newSysLocalDs Many) pat_tys-    stack_id' <- newSysLocalDs Many stack_ty'+    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@@ -732,10 +736,11 @@         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 (ArrowMatchCtxt KappaExpr) in_ty'+    fail_expr <- mkFailExpr lam_cxt in_ty'     -- match the patterns against the parameters-    match_code <- matchSimplys (map Var param_ids) (ArrowMatchCtxt KappaExpr) pats core_expr+    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@@ -756,8 +761,8 @@                 CoreExpr)                         -- desugared choices dsCases ids local_vars stack_id stack_ty res_ty         (MG { mg_alts = L l matches-            , mg_ext = MatchGroupTc arg_tys _-            , mg_origin = origin }) = do+            , 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@@ -779,9 +784,9 @@   let       left_id  = mkConLikeTc (RealDataCon left_con)       right_id = mkConLikeTc (RealDataCon right_con)-      left_expr  ty1 ty2 e = noLocA $ HsApp noComments+      left_expr  ty1 ty2 e = noLocA $ HsApp noExtField                          (noLocA $ mkHsWrap (mkWpTyApps [ty1, ty2]) left_id ) e-      right_expr ty1 ty2 e = noLocA $ HsApp noComments+      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,@@ -803,10 +808,10 @@     -- i.e. Void. The choices then effectively become `arr absurd`,     -- implemented as `arr \case {}`.     Nothing -> ([], void_ty,) . do_arr ids void_ty res_ty <$>-      dsExpr (HsLamCase EpAnnNotUsed LamCase+      dsExpr (HsLam noAnn LamCase         (MG { mg_alts = noLocA []-            , mg_ext = MatchGroupTc [Scaled Many void_ty] res_ty-            , mg_origin = Generated }))+            , 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.@@ -816,8 +821,8 @@   -- Note that we replace the MatchGroup result type by sum_ty,   -- which is the type of matches'   return (MG { mg_alts = L l matches'-             , mg_ext = MatchGroupTc arg_tys sum_ty-             , mg_origin = origin },+             , mg_ext = MatchGroupTc arg_tys sum_ty origin+             },           core_choices)  {-@@ -847,7 +852,7 @@ dsCmdDo ids local_vars res_ty [L _ (LastStmt _ body _ _)] env_ids = do     (core_body, env_ids') <- dsLCmd ids local_vars unitTy res_ty body env_ids     let env_ty = mkBigCoreVarTupTy env_ids-    env_var <- newSysLocalDs Many env_ty+    env_var <- newSysLocalMDs env_ty     let core_map = Lam env_var (mkCorePairExpr (Var env_var) mkCoreUnitExpr)     return (do_premap ids                         env_ty@@ -949,18 +954,17 @@     -- projection function     --          \ (p, (xs2)) -> (zs) -    env_id <- newSysLocalDs Many env_ty2-    uniqs <- newUniqueSupply+    env_id <- newSysLocalMDs env_ty2     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)+    body_expr <- coreCaseTuple env_id env_ids2 (mkBigCoreVarTup out_ids)      fail_expr <- mkFailExpr (StmtCtxt (HsDoStmt (DoExpr Nothing))) out_ty-    pat_id    <- selectSimpleMatchVarL Many pat+    pat_id    <- selectSimpleMatchVarL ManyTy pat     match_code-      <- matchSimply (Var pat_id) (StmtCtxt (HsDoStmt (DoExpr Nothing))) pat body_expr fail_expr-    pair_id   <- newSysLocalDs Many after_c_ty+      <- 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) @@ -1022,12 +1026,11 @@      -- post_loop_fn = \((later_ids),(env2_ids)) -> (out_ids) -    uniqs <- newUniqueSupply-    env2_id <- newSysLocalDs Many env2_ty+    env2_id <- newSysLocalMDs 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_body <- coreCaseTuple env2_id env2_ids (mkBigCoreVarTup out_ids)      post_loop_fn <- matchEnvStack later_ids env2_id post_loop_body @@ -1110,7 +1113,7 @@      -- squash_pair_fn = \ ((env1_ids), ~(rec_ids)) -> (env_ids) -    rec_id <- newSysLocalDs Many rec_ty+    rec_id <- newSysLocalMDs rec_ty     let         env1_id_set = fv_stmts `uniqDSetMinusUniqSet` rec_id_set         env1_ids = dVarSetElems env1_id_set@@ -1120,7 +1123,7 @@           where             selectVar v                 | v `elemVarSet` rec_id_set-                  = mkTupleSelector rec_ids v rec_id (Var rec_id)+                  = mkBigTupleSelector rec_ids v rec_id (Var rec_id)                 | otherwise = Var v      squash_pair_fn <- matchEnvStack env1_ids rec_id core_body@@ -1187,7 +1190,7 @@ -- Match a list of expressions against a list of patterns, left-to-right.  matchSimplys :: [CoreExpr]              -- Scrutinees-             -> HsMatchContext GhcRn    -- Match kind+             -> HsMatchContextRn        -- Match kind              -> [LPat GhcTc]            -- Patterns they should match              -> CoreExpr                -- Return this if they all match              -> CoreExpr                -- Return this if they don't@@ -1195,14 +1198,14 @@ 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+    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 = pats+leavesMatch (L _ (Match { m_pats = L _ pats                         , m_grhss = GRHSs _ grhss binds }))   = let         defined_vars = mkVarSet (collectPatsBinders CollWithDictBinders pats)@@ -1212,7 +1215,7 @@     [(body,       mkVarSet (collectLStmtsBinders CollWithDictBinders stmts)         `unionVarSet` defined_vars)-    | L _ (GRHS _ stmts body) <- grhss]+    | L _ (GRHS _ stmts body) <- toList grhss]  -- Replace the leaf commands in a match @@ -1230,7 +1233,7 @@   = let         (leaves', grhss') = mapAccumL replaceLeavesGRHS leaves grhss     in-    (leaves', L loc (match { m_ext = noAnn, m_grhss = GRHSs x grhss' binds }))+    (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)))
GHC/HsToCore/Binds.hs view
@@ -1,1286 +1,1820 @@  {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeFamilies #-}--{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}--{--(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, decomposeRuleLhs, dsSpec-   , dsHsWrapper, dsEvTerm, dsTcEvBinds, dsTcEvBinds_s, dsEvBinds, dsMkUserRule-   )-where--import GHC.Prelude--import GHC.Driver.Session-import GHC.Driver.Ppr-import GHC.Driver.Config-import qualified GHC.LanguageExtensions as LangExt-import GHC.Unit.Module--import {-# SOURCE #-}   GHC.HsToCore.Expr  ( dsLExpr )-import {-# SOURCE #-}   GHC.HsToCore.Match ( matchWrapper )--import GHC.HsToCore.Monad-import GHC.HsToCore.Errors.Types-import GHC.HsToCore.GuardedRHSs-import GHC.HsToCore.Utils-import GHC.HsToCore.Pmc ( addTyCs, pmcGRHSs )--import GHC.Hs             -- lots of things-import GHC.Core           -- lots of things-import GHC.Core.SimpleOpt    ( simpleOptExpr )-import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr )-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.Multiplicity-import GHC.Core.Rules--import GHC.Builtin.Names-import GHC.Builtin.Types ( naturalTy, typeSymbolKind, charTy )--import GHC.Tc.Types.Evidence--import GHC.Types.Id-import GHC.Types.Name-import GHC.Types.Var.Set-import GHC.Types.Var.Env-import GHC.Types.Var( EvVar )-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.Data.FastString--import GHC.Utils.Constants (debugIsOn)-import GHC.Utils.Misc-import GHC.Utils.Monad-import GHC.Utils.Outputable-import GHC.Utils.Panic-import GHC.Utils.Panic.Plain-import GHC.Utils.Trace--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 (isEmptyBag unlifted_binds) || not (isEmptyBag bang_binds)-  = do { mapBagM_ (top_level_err UnliftedTypeBinds) unlifted_binds-       ; mapBagM_ (top_level_err StrictBinds)       bang_binds-       ; return nilOL }--  | otherwise-  = do { (force_vars, prs) <- dsLHsBinds binds-       ; when debugIsOn $-         do { xstrict <- xoptM LangExt.Strict-            ; 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 = filterBag (isUnliftedHsBind . unLoc) binds-    bang_binds     = filterBag (isBangedHsBind   . unLoc) binds--    top_level_err bindsType (L loc bind)-      = putSrcSpanDs (locA loc) $-        diagnosticDs (DsTopLevelBindsNotAllowed bindsType 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 GhcTc -> DsM ([Id], [(Id,CoreExpr)])-dsLHsBinds binds-  = do { ds_bs <- mapBagM dsLHsBind binds-       ; return (foldBag (\(a, a') (b, b') -> (a ++ b, a' ++ b'))-                         id ([], []) 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).-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-                           , fun_tick = tick })- = do   { (args, body) <- addTyCs FromSource (hsWrapDictBinders co_fn) $-                          -- 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.-                          -- addTyCs: Add type evidence to the refinement type-                          --            predicate of the coverage checker-                          -- See Note [Long-distance information] in "GHC.HsToCore.Pmc"-                          matchWrapper (mkPrefixFunRhs (L loc (idName fun))) Nothing matches--        ; 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]-                | 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-                         , pat_ticks = (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 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 }))-  = do { ds_binds <- addTyCs FromSource (listToBag dicts) $-                     dsLHsBinds binds-             -- addTyCs: push type constraints deeper-             --            for inner pattern match check-             -- See Check, Note [Long-distance information]--       ; ds_ev_binds <- dsTcEvBinds_s ev_binds--       -- dsAbsBinds does the hard work-       ; dsAbsBinds dflags tyvars dicts exports ds_ev_binds ds_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 binding with signature-           -> DsM ([Id], [(Id,CoreExpr)])--dsAbsBinds dflags tyvars dicts exports-           ds_ev_binds (force_vars, bind_prs) 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 { core_wrap <- dsHsWrapper wrap -- 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', main_bind : fromOL spec_binds) }--    -- Another common case: no tyvars, no dicts-    -- In this case we can have a much simpler desugaring-    --    lcl_id{inl-prag} = rhs  -- Auxiliary binds-    --    gbl_id = lcl_id |> co   -- Main binds-  | null tyvars, null dicts-  = do { let mk_main :: ABExport -> DsM (Id, CoreExpr)-             mk_main (ABE { abe_poly = gbl_id, abe_mono = lcl_id-                          , abe_wrap = wrap })-                     -- No SpecPrags (no dicts)-                     -- Can't be a default method (default methods are singletons)-               = do { core_wrap <- dsHsWrapper wrap-                    ; return ( gbl_id `setInlinePragma` defaultInlinePragma-                             , core_wrap (Var lcl_id)) }--       ; main_prs <- mapM mk_main exports-       ; return (force_vars, flattenBinds ds_ev_binds-                              ++ mk_aux_binds bind_prs ++ main_prs ) }--    -- The general case-    -- See Note [Desugaring AbsBinds]-  | otherwise-  = do { let aux_binds = Rec (mk_aux_binds bind_prs)-                -- Monomorphic recursion possible, hence Rec--             new_force_vars = get_new_force_vars force_vars-             locals       = map abe_mono exports-             all_locals   = locals ++ new_force_vars-             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 <- newSysLocalDs Many (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 [AbsBinds wrappers] in "GHC.Hs.Binds"-                = do { tup_id  <- newSysLocalDs Many 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-    mk_aux_binds :: [(Id,CoreExpr)] -> [(Id,CoreExpr)]-    mk_aux_binds bind_prs = [ makeCorePair dflags lcl_w_inline False 0 rhs-                            | (lcl_id, rhs) <- bind_prs-                            , let lcl_w_inline = lookupVarEnv inline_env lcl_id-                                                 `orElse` lcl_id ]--    inline_env :: IdEnv Id -- Maps a monomorphic local Id to one with-                           -- the inline pragma from the source-                           -- The type checker put the inline pragma-                           -- on the *global* Id, so we need to transfer it-    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 <- newSysLocalDs Many-                     (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 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 simpl_opts rhs-         , etaExpand real_arity rhs)--       | otherwise-       = pprTrace "makeCorePair: arity missing" (ppr gbl_id) $-         (gbl_id `setIdUnfolding` mkInlineUnfolding simpl_opts 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 [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]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-See https://gitlab.haskell.org/ghc/ghc/wikis/strict-pragma--Desugaring strict variable bindings looks as follows (core below ==>)--  let !x = rhs-  in  body-==>-  let x = rhs-  in x `seq` body -- seq the variable--and if it is a pattern binding the desugaring looks like--  let !pat = rhs-  in body-==>-  let x = rhs -- bind the rhs to a new variable-      pat = x-  in x `seq` body -- seq the new variable--if there is no variable in the pattern desugaring looks like--  let False = rhs-  in body-==>-  let x = case rhs of {False -> (); _ -> error "Match failed"}-  in x `seq` body--In order to force the Ids in the binding group they are passed around-in the dsHsBind family of functions, and later seq'ed in GHC.HsToCore.Expr.ds_val_bind.--Consider a recursive group like this--  letrec-     f : g = rhs[f,g]-  in <body>--Without `Strict`, we get a translation like this:--  let t = /\a. letrec tm = rhs[fm,gm]-                      fm = case t of fm:_ -> fm-                      gm = case t of _:gm -> gm-                in-                (fm,gm)--  in let f = /\a. case t a of (fm,_) -> fm-  in let g = /\a. case t a of (_,gm) -> gm-  in <body>--Here `tm` is the monomorphic binding for `rhs`.--With `Strict`, we want to force `tm`, but NOT `fm` or `gm`.-Alas, `tm` isn't in scope in the `in <body>` part.--The simplest thing is to return it in the polymorphic-tuple `t`, thus:--  let t = /\a. letrec tm = rhs[fm,gm]-                      fm = case t of fm:_ -> fm-                      gm = case t of _:gm -> gm-                in-                (tm, fm, gm)--  in let f = /\a. case t a of (_,fm,_) -> fm-  in let g = /\a. case t a of (_,_,gm) -> gm-  in let tm = /\a. case t a of (tm,_,_) -> tm-  in tm `seq` <body>---See https://gitlab.haskell.org/ghc/ghc/wikis/strict-pragma for a more-detailed explanation of the desugaring of strict bindings.--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.---}---------------------------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 GHC.Tc.Gen.Bind-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 { diagnosticDs (DsUselessSpecialiseForClassMethodSelector poly_id)-       ; return Nothing  }  -- There is no point in trying to specialise a class op-                            -- Moreover, classops don't (currently) have an inl_sat arity set-                            -- (it would be Just 0) and that in turn makes makeCorePair bleat--  | no_act_spec && isNeverActive rule_act-  = putSrcSpanDs loc $-    do { diagnosticDs (DsUselessSpecialiseForNoInlineFunction poly_id)-       ; return Nothing  }  -- Function is NOINLINE, and the specialisation 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 ]) $-         dflags <- getDynFlags-       ; case decomposeRuleLhs dflags spec_bndrs ds_lhs of {-           Left msg -> do { diagnosticDs msg; return Nothing } ;-           Right (rule_bndrs, _fn, rule_lhs_args) -> do--       { this_mod <- getModule-       ; let fn_unf    = realIdUnfolding poly_id-             simpl_opts = initSimpleOpts dflags-             spec_unf   = specUnfolding simpl_opts spec_bndrs core_app rule_lhs_args fn_unf-             spec_id    = mkLocalId spec_name Many spec_ty -- Specialised binding is toplevel, hence Many.-                            `setInlinePragma` inl_prag-                            `setIdUnfolding`  spec_unf--       ; rule <- dsMkUserRule this_mod is_local_id-                        (mkFastString ("SPEC " ++ showPpr dflags poly_name))-                        rule_act poly_name-                        rule_bndrs rule_lhs_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)---              (diagnosticDs $ 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-                    Opaque _     -> isNeverActive  spec_prag_act-                    _            -> isAlwaysActive spec_prag_act-    rule_act | no_act_spec = inlinePragmaActivation id_inl   -- Inherit-             | otherwise   = spec_prag_act                   -- Specified by user---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-    when (isOrphan (ru_orphan rule)) $-        diagnosticDs (DsOrphanRule rule)-    return 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-                 -> 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])------ 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-  | not (null unbound)    -- Check for things unbound on LHS-                          -- See Note [Unused spec binders]-  = Left (DsRuleBindersNotBound unbound orig_bndrs orig_lhs lhs2)-  | Var funId <- fun2-  , Just con <- isDataConId_maybe funId-  = Left (DsRuleIgnoredDueToConstructor con) -- See Note [No RULES on datacons]-  | Just (fn_id, args) <- decompose fun2 args2-  , let extra_bndrs = mk_extra_bndrs fn_id args-  = -- pprTrace "decomposeRuleLhs" (vcat [ text "orig_bndrs:" <+> ppr orig_bndrs-    --                                  , text "orig_lhs:" <+> ppr orig_lhs-    --                                  , text "lhs1:"     <+> ppr lhs1-    --                                  , text "extra_bndrs:" <+> ppr extra_bndrs-    --                                  , text "fn_id:" <+> ppr fn_id-    --                                  , text "args:"   <+> ppr args]) $-    Right (orig_bndrs ++ extra_bndrs, fn_id, args)--  | otherwise-  = Left (DsRuleLhsTooComplicated orig_lhs lhs2)- where-   simpl_opts   = initSimpleOpts dflags-   lhs1         = drop_dicts orig_lhs-   lhs2         = simpleOptExpr simpl_opts 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-     = scopedSort unbound_tvs ++ unbound_dicts-     where-       unbound_tvs   = [ v | v <- unbound_vars, isTyVar v ]-       unbound_dicts = [ mkLocalId (localiseName (idName d)) Many (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, #10251)--   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)-     | 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 _ [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 [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 GHC.Tc.Utils.Zonk is careful not to-turn the free alpha into Any (as it usually does).  Instead it turns it-into a TyVar 'a'.  See Note [Zonking the LHS of a RULE] in "GHC.Tc.Utils.Zonk".--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 = <rhs>-        ... SPECIALISE f :: Int -> Int ...--Then we get the SpecPrag-        SpecPrag (f Int dInt)--And from that we want the rule--        RULE forall dInt. f Int dInt = f_spec-        f_spec = let f = <rhs> in f Int dInt--But be careful!  That dInt might be GHC.Base.$fOrdInt, which is an External-Name, and you can't bind them in a lambda or forall without getting things-confused.   Likewise it might have 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 (#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-*                                                                      *-************************************************************************---}--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 GHC.Tc.Types.Evidence for an explanation of what- -- the specification of this clause is-dsHsWrapper (WpFun c1 c2 (Scaled w t1))-                              = do { x <- newSysLocalDs w t1-                                   ; w1 <- dsHsWrapper c1-                                   ; w2 <- dsHsWrapper c2-                                   ; let app f a = mkCoreAppDs (text "dsHsWrapper") f a-                                         arg     = w1 (Var x)-                                   ; return (\e -> (Lam x (w2 (app e arg)))) }-dsHsWrapper (WpCast co)       = assert (coercionRole co == Representational) $-                                return $ \e -> mkCastDs e co-dsHsWrapper (WpEvApp tm)      = do { core_tm <- dsEvTerm tm-                                   ; return (\e -> App e core_tm) }-  -- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify.-dsHsWrapper (WpMultCoercion co) = do { when (not (isReflexiveCo co)) $-                                         diagnosticDs DsMultiplicityCoercionsNotSupported-                                     ; return $ \e -> e }----------------------------------------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-  = do { ds_bs <- mapBagM dsEvBind bs-       ; return (mk_ev_binds ds_bs) }--mk_ev_binds :: Bag (Id,CoreExpr) -> [CoreBind]--- 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.-mk_ev_binds ds_binds-  = map ds_scc (stronglyConnCompFromEdgedVerticesUniq edges)-  where-    edges :: [ Node EvVar (EvVar,CoreExpr) ]-    edges = foldr ((:) . mk_node) [] ds_binds--    mk_node :: (Id, CoreExpr) -> Node EvVar (EvVar,CoreExpr)-    mk_node b@(var, rhs)-      = DigraphNode { node_payload = b-                    , node_key = var-                    , node_dependencies = nonDetEltsUniqSet $-                                          exprFreeVars rhs `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 GHC.Data.Graph.Directed.--    ds_scc (AcyclicSCC (v,r)) = NonRec v r-    ds_scc (CyclicSCC prs)    = Rec prs--dsEvBind :: EvBind -> DsM (Id, CoreExpr)-dsEvBind (EvBind { eb_lhs = v, eb_rhs = r}) = liftM ((,) v) (dsEvTerm r)---{-**********************************************************************-*                                                                      *-           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 { ds_ev_binds <- dsTcEvBinds 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-             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).-       ; 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-       ; 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)  -- drop the multiplicity,-                                                     -- since it's a kind-       ; let expr =  mkApps (mkTyApps (Var mkTrApp) [ k1, k2, t1, t2 ])-                            [ e1, e2 ]-       -- ; pprRuntimeTrace "Trace mkTrApp" (ppr expr) expr-       ; return expr-       }--ds_ev_typeable ty (EvTypeableTrFun evm ev1 ev2)-  | Just (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.Solver.Interact+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE TypeFamilies #-}++{-+(c) The University of Glasgow 2006+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998+++Pattern-matching bindings (HsBinds and MonoBinds)++Handles @HsBinds@; those at the top level require different handling,+in that the @Rec@/@NonRec@/etc structure is thrown away (whereas at+lower levels it is preserved with @let@/@letrec@s).+-}++module GHC.HsToCore.Binds+   ( dsTopLHsBinds, dsLHsBinds+   , dsImpSpecs, decomposeRuleLhs+   , dsHsWrapper, dsHsWrappers+   , dsEvTerm, dsTcEvBinds, dsTcEvBinds_s, dsEvBinds+   , dsWarnOrphanRule+   )+where++import GHC.Prelude++import GHC.Driver.DynFlags+import GHC.Driver.Config+import qualified GHC.LanguageExtensions as LangExt+import GHC.Unit.Module++import {-# SOURCE #-}   GHC.HsToCore.Expr  ( dsLExpr )+import {-# SOURCE #-}   GHC.HsToCore.Match ( matchWrapper )++import GHC.HsToCore.Pmc.Utils( tracePm )++import GHC.HsToCore.Monad+import GHC.HsToCore.Errors.Types+import GHC.HsToCore.GuardedRHSs+import GHC.HsToCore.Utils+import GHC.HsToCore.Pmc ( addTyCs, pmcGRHSs )++import GHC.Hs             -- lots of things+import GHC.Core           -- lots of things+import GHC.Core.SimpleOpt+import GHC.Core.Opt.OccurAnal ( occurAnalyseExpr )+import GHC.Core.InstEnv ( CanonicalEvidence(..) )+import GHC.Core.Make+import GHC.Core.Utils+import GHC.Core.Opt.Arity     ( etaExpand )+import GHC.Core.Unfold.Make+import GHC.Core.FVs+import GHC.Core.Predicate+import GHC.Core.TyCon+import GHC.Core.Type+import GHC.Core.Coercion+import GHC.Core.Rules+import GHC.Core.Ppr( pprCoreBinders )+import GHC.Core.TyCo.Compare( eqType )++import GHC.Builtin.Names+import GHC.Builtin.Types ( naturalTy, typeSymbolKind, charTy )++import GHC.Tc.Types.Evidence++import GHC.Types.Id+import GHC.Types.Id.Info+import GHC.Types.Name+import GHC.Types.Var.Set+import GHC.Types.Var.Env+import GHC.Types.Var( EvVar, mkLocalVar )+import GHC.Types.SrcLoc+import GHC.Types.Basic+import GHC.Types.Unique.Set( nonDetEltsUniqSet )++import GHC.Data.Maybe+import GHC.Data.OrdList+import GHC.Data.Graph.Directed+import GHC.Data.Bag++import GHC.Utils.Constants (debugIsOn)+import GHC.Utils.Misc+import GHC.Utils.Monad+import GHC.Utils.Outputable+import GHC.Utils.Panic++import Control.Monad+++{-**********************************************************************+*                                                                      *+           Desugaring a MonoBinds+*                                                                      *+**********************************************************************-}++-- | Desugar top level binds, strict binds are treated like normal+-- binds since there is no good time to force before first usage.+dsTopLHsBinds :: LHsBinds GhcTc -> DsM (OrdList (Id,CoreExpr))+dsTopLHsBinds binds+     -- see Note [Strict binds checks]+  | not (null unlifted_binds) || not (null bang_binds)+  = do { mapM_ (top_level_err UnliftedTypeBinds) unlifted_binds+       ; mapM_ (top_level_err StrictBinds)       bang_binds+       ; return nilOL }++  | otherwise+  = do { (force_vars, prs) <- dsLHsBinds binds+       ; when debugIsOn $+         do { xstrict <- xoptM LangExt.Strict+            ; massertPpr (null force_vars || xstrict) (ppr binds $$ ppr force_vars) }+              -- with -XStrict, even top-level vars are listed as force vars.++       ; return (toOL prs) }++  where+    unlifted_binds = filter (isUnliftedHsBind . unLoc) binds+    bang_binds     = filter (isBangedHsBind   . unLoc) binds++    top_level_err bindsType (L loc bind)+      = putSrcSpanDs (locA loc) $+        diagnosticDs (DsTopLevelBindsNotAllowed bindsType bind)+{-+Note [Return non-recursive bindings in dependency order]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For recursive bindings, the desugarer has no choice: it returns a single big+Rec{...} group.++But for /non-recursive/ bindings, the desugarer guarantees to desugar them to+a sequence of non-recurive Core bindings, in dependency order.++Why is this important?  Partly it saves a bit of work in the first run of the+occurrence analyser. But more importantly, for linear types, non-recursive lets+can be linear whereas recursive-let can't. Since we check the output of the+desugarer for linearity (see also Note [Linting linearity]), desugaring+non-recursive lets to recursive lets would break linearity checks. An+alternative is to refine the typing rule for recursive lets so that we don't+have to care (see in particular #23218 and #18694), but the outcome of this line+of work is still unclear. In the meantime, being a little precise in the+desugarer is cheap. (paragraph written on 2023-06-09)++In dsLHSBinds (and dependencies), a single binding can be desugared to multiple+bindings. For instance because the source binding has the {-# SPECIALIZE #-}+pragma. In:++f _ = …+ where+  {-# SPECIALIZE g :: F Int -> F Int #-}+  g :: C a => F a -> F a+  g _ = …++The g binding desugars to++let {+  $sg = … } in++  g+  [RULES: "SPEC g" g @Int $dC = $sg]+  g = …++In order to avoid generating a letrec that will immediately be reordered, we+make sure to return the binding in dependency order [$sg, g].++-}++-- | Desugar all other kind of bindings, Ids of strict binds are returned to+-- later be forced in the binding group body, see Note [Desugar Strict binds]+--+-- Invariant: the desugared bindings are returned in dependency order,+-- see Note [Return non-recursive bindings in dependency order]+dsLHsBinds :: LHsBinds GhcTc -> DsM ([Id], [(Id,CoreExpr)])+dsLHsBinds binds+  = do { ds_bs <- mapM dsLHsBind binds+       ; return (foldr (\(a, a') (b, b') -> (a ++ b, a' ++ b'))+                         ([], []) ds_bs) }++------------------------+dsLHsBind :: LHsBind GhcTc+          -> DsM ([Id], [(Id,CoreExpr)])+dsLHsBind (L loc bind) = do dflags <- getDynFlags+                            putSrcSpanDs (locA loc) $ dsHsBind dflags bind++-- | Desugar a single binding (or group of recursive binds).+--+-- Invariant: the desugared bindings are returned in dependency order,+-- see Note [Return non-recursive bindings in dependency order]+dsHsBind :: DynFlags+         -> HsBind GhcTc+         -> DsM ([Id], [(Id,CoreExpr)])+         -- ^ The Ids of strict binds, to be forced in the body of the+         -- binding group see Note [Desugar Strict binds] and all+         -- bindings and their desugared right hand sides.++dsHsBind dflags (VarBind { var_id = var+                         , var_rhs = expr })+  = do  { core_expr <- dsLExpr expr+                -- Dictionary bindings are always VarBinds,+                -- so we only need do this here+        ; let core_bind@(id,_) = makeCorePair dflags var False 0 core_expr+              force_var = if xopt LangExt.Strict dflags+                          then [id]+                          else []+        ; return (force_var, [core_bind]) }++dsHsBind dflags b@(FunBind { fun_id = L loc fun+                           , fun_matches = matches+                           , fun_ext = (co_fn, tick)+                           })+ = dsHsWrapper co_fn $ \core_wrap ->+   do { (args, body) <- matchWrapper (mkPrefixFunRhs (L loc (idName fun)) noAnn) Nothing matches++      ; let body' = mkOptTickBox tick body+            rhs   = core_wrap (mkLams args body')+            core_binds@(id,_) = makeCorePair dflags fun False 0 rhs+            force_var+                -- Bindings are strict when -XStrict is enabled+              | xopt LangExt.Strict dflags+              , matchGroupArity matches == 0 -- no need to force lambdas+              = [id]+              | isBangedHsBind b+              = [id]+              | otherwise+              = []+      ; --pprTrace "dsHsBind" (vcat [ ppr fun <+> ppr (idInlinePragma fun)+        --                          , ppr (mg_alts matches)+        --                          , ppr args, ppr core_binds, ppr body']) $+        return (force_var, [core_binds]) }++dsHsBind dflags (PatBind { pat_lhs = pat, pat_rhs = grhss+                         , pat_ext = (ty, (rhs_tick, var_ticks))+                         })+  = do  { rhss_nablas <- pmcGRHSs PatBindGuards grhss+        ; body_expr <- dsGuarded grhss ty rhss_nablas+        ; let body' = mkOptTickBox rhs_tick body_expr+              pat'  = decideBangHood dflags pat+        ; (force_var,sel_binds) <- mkSelectorBinds var_ticks pat PatBindRhs body'+          -- We silently ignore inline pragmas; no makeCorePair+          -- Not so cool, but really doesn't matter+        ; let force_var' = if isBangedLPat pat'+                           then [force_var]+                           else []+        ; return (force_var', sel_binds) }++dsHsBind+  dflags+  (XHsBindsLR (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts+                        , abs_exports = exports+                        , abs_ev_binds = ev_binds+                        , abs_binds = binds, abs_sig = has_sig }))+  = addTyCs FromSource (listToBag dicts) $+             -- addTyCs: push type constraints deeper+             --            for inner pattern match check+             -- See Check, Note [Long-distance information]+    dsTcEvBinds_s ev_binds $ \ds_ev_binds -> do+    do { ds_binds <- dsLHsBinds binds+         -- dsAbsBinds does the hard work+       ; dsAbsBinds dflags tyvars dicts exports ds_ev_binds ds_binds+                    (isSingleton binds) has_sig }++dsHsBind _ (PatSynBind{}) = panic "dsHsBind: PatSynBind"++-----------------------+dsAbsBinds :: DynFlags+           -> [TyVar] -> [EvVar] -> [ABExport]+           -> [CoreBind]                -- Desugared evidence bindings+           -> ([Id], [(Id,CoreExpr)])   -- Desugared value bindings+           -> Bool                      -- Single source binding+           -> Bool                      -- Single binding with signature+           -> DsM ([Id], [(Id,CoreExpr)])++dsAbsBinds dflags tyvars dicts exports+           ds_ev_binds (force_vars, bind_prs) is_singleton has_sig++    -- A very important common case: one exported variable+    -- Non-recursive bindings come through this way+    -- So do self-recursive bindings+    --    gbl_id = wrap (/\tvs \dicts. let ev_binds+    --                                 letrec bind_prs+    --                                 in lcl_id)+  | [export] <- exports+  , ABE { abe_poly = global_id, abe_mono = local_id+        , abe_wrap = wrap, abe_prags = prags } <- export+  , Just force_vars' <- case force_vars of+                           []                  -> Just []+                           [v] | v == local_id -> Just [global_id]+                           _                   -> Nothing+       -- If there is a variable to force, it's just the+       -- single variable we are binding here+  = do { dsHsWrapper wrap $ \core_wrap -> do -- Usually the identity+       { let rhs = core_wrap $+                   mkLams tyvars $ mkLams dicts $+                   mkCoreLets ds_ev_binds $+                   body++             body | has_sig+                  , [(_, lrhs)] <- bind_prs+                  = lrhs+                  | otherwise+                  = mkLetRec bind_prs (Var local_id)++       ; (spec_binds, rules) <- dsSpecs rhs prags++       ; let global_id' = addIdSpecialisations global_id rules+             main_bind  = makeCorePair dflags global_id'+                                       (isDefaultMethod prags)+                                       (dictArity dicts) rhs++       ; return (force_vars', fromOL spec_binds ++ [main_bind]) } }++    -- Another common case: no tyvars, no dicts+    -- In this case we can have a much simpler desugaring+    --    lcl_id{inl-prag} = rhs  -- Auxiliary binds+    --    gbl_id = lcl_id |> co   -- Main binds+    --+    -- See Note [The no-tyvar no-dict case]+  | null tyvars, null dicts+  = do { let wrap_first_bind f ((main, main_rhs):other_binds) =+               ((main, f main_rhs):other_binds)+             wrap_first_bind _ [] = panic "dsAbsBinds received an empty binding list"++             mk_main :: ABExport -> DsM (Id, CoreExpr)+             mk_main (ABE { abe_poly = gbl_id, abe_mono = lcl_id+                          , abe_wrap = wrap })+                     -- No SpecPrags (no dicts)+                     -- Can't be a default method (default methods are singletons)+               = do { dsHsWrapper wrap $ \core_wrap -> do+                    { return ( gbl_id `setInlinePragma` defaultInlinePragma+                             , core_wrap (Var lcl_id)) } }+       ; main_prs <- mapM mk_main exports+       ; let bind_prs' = map mk_aux_bind bind_prs+             -- When there's a single source binding, we wrap the evidence binding in a+             -- separate let-rec (DSB1) inside the first desugared binding (DSB2).+             -- See Note [The no-tyvar no-dict case].+             final_prs | is_singleton = wrap_first_bind (mkCoreLets ds_ev_binds) bind_prs'+                       | otherwise = flattenBinds ds_ev_binds ++ bind_prs'+       ; return (force_vars, final_prs ++ main_prs ) }++    -- The general case+    -- See Note [Desugaring AbsBinds]+  | otherwise+  = do { let aux_binds = Rec (map mk_aux_bind bind_prs)+                -- Monomorphic recursion possible, hence Rec++             new_force_vars = get_new_force_vars force_vars+             locals       = map abe_mono exports+             all_locals   = locals ++ new_force_vars+             tup_expr     = mkBigCoreVarTup all_locals+             tup_ty       = exprType tup_expr+       ; let poly_tup_rhs = mkLams tyvars $ mkLams dicts $+                            mkCoreLets ds_ev_binds $+                            mkLet aux_binds $+                            tup_expr++       ; poly_tup_id <- newSysLocalMDs (exprType poly_tup_rhs)++        -- Find corresponding global or make up a new one: sometimes+        -- we need to make new export to desugar strict binds, see+        -- Note [Desugar Strict binds]+       ; (exported_force_vars, extra_exports) <- get_exports force_vars++       ; let mk_bind (ABE { abe_wrap = wrap+                          , abe_poly = global+                          , abe_mono = local, abe_prags = spec_prags })+                          -- See Note [ABExport wrapper] in "GHC.Hs.Binds"+                = do { tup_id  <- newSysLocalMDs tup_ty+                     ; dsHsWrapper wrap $ \core_wrap -> do+                     { let rhs = core_wrap $ mkLams tyvars $ mkLams dicts $+                                 mkBigTupleSelector all_locals local tup_id $+                                 mkVarApps (Var poly_tup_id) (tyvars ++ dicts)+                           rhs_for_spec = Let (NonRec poly_tup_id poly_tup_rhs) rhs+                     ; (spec_binds, rules) <- dsSpecs rhs_for_spec spec_prags+                     ; let global' = (global `setInlinePragma` defaultInlinePragma)+                                             `addIdSpecialisations` rules+                           -- Kill the INLINE pragma because it applies to+                           -- the user written (local) function.  The global+                           -- Id is just the selector.  Hmm.+                     ; return (fromOL spec_binds ++ [(global', rhs)]) } }++       ; export_binds_s <- mapM mk_bind (exports ++ extra_exports)++       ; return ( exported_force_vars+                , (poly_tup_id, poly_tup_rhs) :+                   concat export_binds_s) }+  where+    mk_aux_bind :: (Id,CoreExpr) -> (Id,CoreExpr)+    mk_aux_bind (lcl_id, rhs) = let lcl_w_inline = lookupVarEnv inline_env lcl_id+                                                   `orElse` lcl_id+                                 in+                                 makeCorePair dflags lcl_w_inline False 0 rhs++    inline_env :: IdEnv Id -- Maps a monomorphic local Id to one with+                           -- the inline pragma from the source+                           -- The type checker put the inline pragma+                           -- on the *global* Id, so we need to transfer it+    inline_env+      = mkVarEnv [ (lcl_id, setInlinePragma lcl_id prag)+                 | ABE { abe_mono = lcl_id, abe_poly = gbl_id } <- exports+                 , let prag = idInlinePragma gbl_id ]++    global_env :: IdEnv Id -- Maps local Id to its global exported Id+    global_env =+      mkVarEnv [ (local, global)+               | ABE { abe_mono = local, abe_poly = global } <- exports+               ]++    -- find variables that are not exported+    get_new_force_vars lcls =+      foldr (\lcl acc -> case lookupVarEnv global_env lcl of+                           Just _ -> acc+                           Nothing -> lcl:acc)+            [] lcls++    -- find exports or make up new exports for force variables+    get_exports :: [Id] -> DsM ([Id], [ABExport])+    get_exports lcls =+      foldM (\(glbls, exports) lcl ->+              case lookupVarEnv global_env lcl of+                Just glbl -> return (glbl:glbls, exports)+                Nothing   -> do export <- mk_export lcl+                                let glbl = abe_poly export+                                return (glbl:glbls, export:exports))+            ([],[]) lcls++    mk_export local =+      do global <- newSysLocalMDs+                     (exprType (mkLams tyvars (mkLams dicts (Var local))))+         return (ABE { abe_poly  = global+                     , abe_mono  = local+                     , abe_wrap  = WpHole+                     , abe_prags = SpecPrags [] })++-- | This is where we apply INLINE and INLINABLE pragmas. All we need to+-- do is to attach the unfolding information to the Id.+--+-- Other decisions about whether to inline are made in+-- `calcUnfoldingGuidance` but the decision about whether to then expose+-- the unfolding in the interface file is made in `GHC.Iface.Tidy.addExternal`+-- using this information.+------------------------+makeCorePair :: DynFlags -> Id -> Bool -> Arity -> CoreExpr+             -> (Id, CoreExpr)+makeCorePair dflags gbl_id is_default_method dict_arity rhs+  | is_default_method    -- Default methods are *always* inlined+                         -- See Note [INLINE and default methods] in GHC.Tc.TyCl.Instance+  = (gbl_id `setIdUnfolding` mkCompulsoryUnfolding' simpl_opts rhs, rhs)++  | otherwise+  = case inlinePragmaSpec inline_prag of+          NoUserInlinePrag -> (gbl_id, rhs)+          NoInline  {}     -> (gbl_id, rhs)+          Opaque    {}     -> (gbl_id, rhs)+          Inlinable {}     -> (gbl_id `setIdUnfolding` inlinable_unf, rhs)+          Inline    {}     -> inline_pair+  where+    simpl_opts    = initSimpleOpts dflags+    inline_prag   = idInlinePragma gbl_id+    inlinable_unf = mkInlinableUnfolding simpl_opts StableUserSrc rhs+    inline_pair+       | Just arity <- inlinePragmaSat inline_prag+        -- Add an Unfolding for an INLINE (but not for NOINLINE)+        -- And eta-expand the RHS; see Note [Eta-expanding INLINE things]+       , let real_arity = dict_arity + arity+        -- NB: The arity passed to mkInlineUnfoldingWithArity+        --     must take account of the dictionaries+       = ( gbl_id `setIdUnfolding` mkInlineUnfoldingWithArity simpl_opts StableUserSrc real_arity rhs+         , etaExpand real_arity rhs)++       | otherwise+       = pprTrace "makeCorePair: arity missing" (ppr gbl_id) $+         (gbl_id `setIdUnfolding` mkInlineUnfoldingNoArity simpl_opts StableUserSrc rhs, rhs)++dictArity :: [Var] -> Arity+-- Don't count coercion variables in arity+dictArity dicts = count isId dicts++{-+Note [Desugaring AbsBinds]+~~~~~~~~~~~~~~~~~~~~~~~~~~+In the general AbsBinds case we desugar the binding to this:++       tup a (d:Num a) = let fm = ...gm...+                             gm = ...fm...+                         in (fm,gm)+       f a d = case tup a d of { (fm,gm) -> fm }+       g a d = case tup a d of { (fm,gm) -> fm }++Note [Rules and inlining]+~~~~~~~~~~~~~~~~~~~~~~~~~+Common special case: no type or dictionary abstraction+This is a bit less trivial than you might suppose+The naive way would be to desugar to something like+        f_lcl = ...f_lcl...     -- The "binds" from AbsBinds+        M.f = f_lcl             -- Generated from "exports"+But we don't want that, because if M.f isn't exported,+it'll be inlined unconditionally at every call site (its rhs is+trivial).  That would be ok unless it has RULES, which would+thereby be completely lost.  Bad, bad, bad.++Instead we want to generate+        M.f = ...f_lcl...+        f_lcl = M.f+Now all is cool. The RULES are attached to M.f (by SimplCore),+and f_lcl is rapidly inlined away.++This does not happen in the same way to polymorphic binds,+because they desugar to+        M.f = /\a. let f_lcl = ...f_lcl... in f_lcl+Although I'm a bit worried about whether full laziness might+float the f_lcl binding out and then inline M.f at its call site++Note [Specialising in no-dict case]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Even if there are no tyvars or dicts, we may have specialisation pragmas.+Class methods can generate+      AbsBinds [] [] [( ... spec-prag]+         { AbsBinds [tvs] [dicts] ...blah }+So the overloading is in the nested AbsBinds. A good example is in GHC.Float:++  class  (Real a, Fractional a) => RealFrac a  where+    round :: (Integral b) => a -> b++  instance  RealFrac Float  where+    {-# SPECIALIZE round :: Float -> Int #-}++The top-level AbsBinds for $cround has no tyvars or dicts (because the+instance does not).  But the method is locally overloaded!++Note [The no-tyvar no-dict case]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we are desugaring+    AbsBinds { tyvars   = []+             , dicts    = []+             , exports  = [ ABE f fm, ABE g gm ]+             , binds    = B+             , ev_binds = EB }+That is: no type variables or dictionary abstractions.  Here, `f` and `fm` are+the polymorphic and monomorphic versions of `f`; in this special case they will+both have the same type.++Specialising Note [Desugaring AbsBinds] for this case gives the desugaring++    tup = letrec EB' in letrec B' in (fm,gm)+    f = case tup of { (fm,gm) -> fm }+    g = case tup of { (fm,gm) -> fm }++where B' is the result of desugaring B. This desugaring is a little silly: we+don't need the intermediate tuple (contrast with the general case where fm and f+have different types). So instead, in this case, we desugar to++    EB'; B'; f=fm; g=gm++This is done in the `null tyvars, null dicts` case of `dsAbsBinds`.++But there is a wrinkle (DSB1).  If the original binding group was+/non-recursive/, we want to return a bunch of non-recursive bindings in+dependency order: see Note [Return non-recursive bindings in dependency order].++But there is no guarantee that EB', the desugared evidence bindings, will be+non-recursive.  Happily, in the non-recursive case, B will have just a single+binding (f = rhs), so we can wrap EB' around its RHS, thus:++   fm = letrec EB' in rhs; f = fm++There is a sub-wrinkle (DSB2).  If B is a /pattern/ bindings, it will desugar to+a "main" binding followed by a bunch of selectors. The main binding always+comes first, so we can pick it out and wrap EB' around its RHS.  For example++    AbsBinds { tyvars   = []+             , dicts    = []+             , exports  = [ ABE p pm, ABE q qm ]+             , binds    = PatBind (pm, Just qm) rhs+             , ev_binds = EB }++can desguar to++   pt = let EB' in+        case rhs of+          (pm,Just qm) -> (pm,qm)+   pm = case pt of (pm,qm) -> pm+   qm = case pt of (pm,qm) -> qm++   p = pm+   q = qm++The first three bindings come from desugaring the PatBind, and subsequently+wrapping the RHS of the main binding in EB'.++Why got to this trouble?  It's a common case, and it removes the+quadratic-sized tuple desugaring.  Less clutter, hopefully faster+compilation, especially in a case where there are a *lot* of+bindings.++Note [Eta-expanding INLINE things]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+   foo :: Eq a => a -> a+   {-# INLINE foo #-}+   foo x = ...++If (foo d) ever gets floated out as a common sub-expression (which can+happen as a result of method sharing), there's a danger that we never+get to do the inlining, which is a Terribly Bad thing given that the+user said "inline"!++To avoid this we preemptively eta-expand the definition, so that foo+has the arity with which it is declared in the source code.  In this+example it has arity 2 (one for the Eq and one for x). Doing this+should mean that (foo d) is a PAP and we don't share it.++Note [Nested arities]+~~~~~~~~~~~~~~~~~~~~~+For reasons that are not entirely clear, method bindings come out looking like+this:++  AbsBinds [] [] [$cfromT <= [] fromT]+    $cfromT [InlPrag=INLINE] :: T Bool -> Bool+    { AbsBinds [] [] [fromT <= [] fromT_1]+        fromT :: T Bool -> Bool+        { fromT_1 ((TBool b)) = not b } } }++Note the nested AbsBind.  The arity for the unfolding on $cfromT should be+gotten from the binding for fromT_1.++It might be better to have just one level of AbsBinds, but that requires more+thought!+++Note [Desugar Strict binds]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+See https://gitlab.haskell.org/ghc/ghc/wikis/strict-pragma++Desugaring strict variable bindings looks as follows (core below ==>)++  let !x = rhs+  in  body+==>+  let x = rhs+  in x `seq` body -- seq the variable++and if it is a pattern binding the desugaring looks like++  let !pat = rhs+  in body+==>+  let x = rhs -- bind the rhs to a new variable+      pat = x+  in x `seq` body -- seq the new variable++if there is no variable in the pattern desugaring looks like++  let False = rhs+  in body+==>+  let x = case rhs of {False -> (); _ -> error "Match failed"}+  in x `seq` body++In order to force the Ids in the binding group they are passed around+in the dsHsBind family of functions, and later seq'ed in GHC.HsToCore.Expr.ds_val_bind.++Consider a recursive group like this++  letrec+     f : g = rhs[f,g]+  in <body>++Without `Strict`, we get a translation like this:++  let t = /\a. letrec tm = rhs[fm,gm]+                      fm = case t of fm:_ -> fm+                      gm = case t of _:gm -> gm+                in+                (fm,gm)++  in let f = /\a. case t a of (fm,_) -> fm+  in let g = /\a. case t a of (_,gm) -> gm+  in <body>++Here `tm` is the monomorphic binding for `rhs`.++With `Strict`, we want to force `tm`, but NOT `fm` or `gm`.+Alas, `tm` isn't in scope in the `in <body>` part.++The simplest thing is to return it in the polymorphic+tuple `t`, thus:++  let t = /\a. letrec tm = rhs[fm,gm]+                      fm = case t of fm:_ -> fm+                      gm = case t of _:gm -> gm+                in+                (tm, fm, gm)++  in let f = /\a. case t a of (_,fm,_) -> fm+  in let g = /\a. case t a of (_,_,gm) -> gm+  in let tm = /\a. case t a of (tm,_,_) -> tm+  in tm `seq` <body>+++See https://gitlab.haskell.org/ghc/ghc/wikis/strict-pragma for a more+detailed explanation of the desugaring of strict bindings.++Wrinkle 1: forcing linear variables++Consider++  let %1 !x = rhs in <body>+==>+  let x = rhs in x `seq` <body>++In the desugared version x is used in both arguments of seq. This isn't+recognised a linear. So we can't strictly speaking use seq. Instead, the code is+really desugared as++  let x = rhs in case x of x { _ -> <body> }++The shadowing with the case-binder is crucial. The linear linter (see+Note [Linting linearity] in GHC.Core.Lint) understands this as linear. This is+what the seqVar function does.++To be more precise, suppose x has multiplicity p, the fully annotated seqVar (in+Core, p is really stored inside x) is++  case x of %p x { _ -> <body> }++In linear Core, case u of %p y { _ -> v } consumes u with multiplicity p, and+makes y available with multiplicity p in v. Which is exactly what we want.++Wrinkle 2: linear patterns++Consider the following linear binding (linear lets are always non-recursive):++  let+     %1 f : g = rhs+  in <body>++The general case would desugar it to++  let t = let tm = rhs+              fm = case tm of fm:_ -> fm+              gm = case tm of _:gm -> gm+           in+           (tm, fm, gm)++  in let f = case t a of (_,fm,_) -> fm+  in let g = case t a of (_,_,gm) -> gm+  in let tm = case t a of (tm,_,_) -> tm+  in tm `seq` <body>++But all the case expression drop variables, which is prohibited by+linearity. But because this is a non-recursive let (in particular we're+desugaring a single binding), we can (and do) desugar the binding as a simple+case-expression instead:++  case rhs of {+    (f:g) -> <body>+  }++This is handled by the special case: a non-recursive PatBind in+GHC.HsToCore.Expr.ds_val_bind.++Note [Strict binds checks]+~~~~~~~~~~~~~~~~~~~~~~~~~~+There are several checks around properly formed strict bindings. They+all link to this Note. These checks must be here in the desugarer because+we cannot know whether or not a type is unlifted until after zonking, due+to representation polymorphism. These checks all used to be handled in the+typechecker in checkStrictBinds (before Jan '17).++We define an "unlifted bind" to be any bind that binds an unlifted id. Note that++  x :: Char+  (# True, x #) = blah++is *not* an unlifted bind. Unlifted binds are detected by GHC.Hs.Utils.isUnliftedHsBind.++Define a "banged bind" to have a top-level bang. Detected by GHC.Hs.Pat.isBangedHsBind.+Define a "strict bind" to be either an unlifted bind or a banged bind.++The restrictions are:+  1. Strict binds may not be top-level. Checked in dsTopLHsBinds.++  2. Unlifted binds must also be banged. (There is no trouble to compile an unbanged+     unlifted bind, but an unbanged bind looks lazy, and we don't want users to be+     surprised by the strictness of an unlifted bind.) Checked in first clause+     of GHC.HsToCore.Expr.ds_val_bind.++  3. Unlifted binds may not have polymorphism (#6078). (That is, no quantified type+     variables or constraints.) Checked in first clause+     of GHC.HsToCore.Expr.ds_val_bind.++  4. Unlifted binds may not be recursive. Checked in second clause of ds_val_bind.++Note [Desugaring new-form SPECIALISE pragmas]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+"New-form" SPECIALISE pragmas generate a SpecPragE record in the typechecker,+which is desugared in this module by `dsSpec`.  For the context see+Note [Handling new-form SPECIALISE pragmas] in GHC.Tc.Gen.Sig++Suppose we have+  f :: forall a b c d. (Ord a, Ord b, Eq c, Ix d) => ...+  f = rhs+  {-# SPECIALISE f @p @[p] @[Int] @(q,r) #-}++The type-checker generates `the_call` which looks like++  spe_bndrs = (dx1 :: Ord p) (dx2::Ix q) (dx3::Ix r)+  the_call = let d6 = dx1+                 d2 = $fOrdList d6+                 d3 = $fEqList $fEqInt+                 d7 = dx1   -- Solver may introduce+                 d1 = d7    -- these indirections+                 d4 = $fIxPair dx2 dx3+             in f @p @p @[Int] @(q,r)+                  (d1::Ord p) (d2::Ord [p]) (d3::Eq [Int]) (d4::Ix (q,r)++We /could/ generate+   RULE  f d1 d2 d3 d4 e1..en = $sf d1 d2 d3 d4+   $sf d1 d2 d3 d4 = <rhs> d1 d2 d3 d4++But that would do no specialisation at all! What we want is this:+   RULE  f d1 _d2 _d3 d4 e1..en = $sf d1 d4+   $sf d1 d4 =  let d7 = d1   -- Renaming+                    dx1 = d1  -- Renaming+                    d6 = d1   -- Renaming+                    d2 = $fOrdList d6+                    d3 = $fEqList $fEqInt+                in rhs d1 d2 d3 d4++Notice that:+  * We pass some, but not all, of the matched dictionaries to $sf++  * We get specialisations for d2 and d3, but not for d1, nor d4.++  * We had to introduce some renaming bindings at the top+    to line things up++The transformation goes in these steps++(S1) decomposeCall: decompose `the_call` into+     - `binds`: the enclosing let-bindings+     - `rule_lhs_args`: the arguments of the call itself++  If the expression in the SPECIALISE pragma had a type signature, such as+     SPECIALISE g :: Eq b => Int -> b -> b+  then the desugared expression may have type abstractions and applications+  "in the way", like this:+     (/\b. (\d:Eq b). let d1 = $dfOrdInt in f @Int @b d1 d) @b (d2:Eq b)+  The lambdas come from the type signature, which is then re-instantiated,+  hence the applications of those lambdas.++  To handle these, `decomposeCall` uses the simple optimiser to simplify+  this to+     let { d = d2; d1 = $dfOrdInt } in f @Int @b d1 d++  Wrinkle (S1a): do no inlining in this "simple optimiser" phase:+  use `simpleOptExprNoInline`. E.g. we don't want to turn it into+     f @Int @b $dfOrdInt d2+  because the latter is harder to match. Similarly if we have+     let { d1=d; d2=d } in f d1 d2+  we don't want to inline d1/d2 to get this+     f d d++  TL;DR: as a result the dictionary arguments of the actual call,+    `rule_lhs_args` are all distinct dictionary variables, not+    expressions.++(S2) Compute `rule_bndrs`: the free vars of `rule_lhs_args`, which+   will be the forall'd template variables of the RULE.  In the example,+       rule_bndrs = d1,d2,d3,d4+   These variables will get values from a successful RULE match.++(S3) `getRenamings`: starting from the rule_bndrs, make bindings for+   all other variables that are equal to them.  In the example, we+   make renaming-bindings for d7, dx1, d6.  Our goal is to bind+   as many variables as possible, by deducing them from `rule_bndrs`.+   If we have the binding+     d1 = d7  (where `d1` is a rule_bndr)+   we want to generate the renaming+     d7 = d1+   which instead deduces d7 from d1++   NB1: we don't actually have to remove the original bindings;+        it's harmless to leave them+   NB2: We also reverse bindings like  d1 = d2 |> co, to get+           d2 = d1 |> sym co+        It's easy and slightly improves our ability to get bindings+        for local variables from `rule_bndrs`. I'm not sure if it+        matters in practice, but it's easy to do.+   NB3: `getRenamings` works innermost first, so that we get transitivity.+        E.g in our example we have+                 d7 = dx1+                 d1 = d7     where d1 is rule_bndr+        `getRenamings` generate the renamings+                 dx1 = d1+                 d7 = d2++(S4) `pickSpecBinds`: pick the bindings we want to keep in the+   specialised function.  We start from `known_vars`, the variables we+   know, namely the `rule_bndrs` and the binders from (S3), which are+   all equal to one of the `rule_bndrs`.++   Then we keep a binding if the free vars of its RHS are all known.+   In our example, `d2` and `d3` are both picked, but `d4` is not.+   The non-picked ones won't end up being specialised.++(S5) Finally, work out which of the `rule_bndrs` we must pass on to+   specialised function. We just filter out ones bound by a renaming+   or a picked binding.+-}++------------------------+dsSpecs :: CoreExpr     -- Its rhs+        -> TcSpecPrags+        -> DsM ( OrdList (Id,CoreExpr)  -- Binding for specialised Ids+               , [CoreRule] )           -- Rules for the Global Ids+-- See Note [Overview of SPECIALISE pragmas] in GHC.Tc.Gen.Sig+dsSpecs _ IsDefaultMethod = return (nilOL, [])+dsSpecs poly_rhs (SpecPrags sps)+  = do { pairs <- mapMaybeM (dsLSpec poly_rhs) sps+       ; let (spec_binds_s, rules) = unzip pairs+       ; return (concatOL spec_binds_s, rules) }++dsImpSpecs :: [LTcSpecPrag] -> DsM (OrdList (Id,CoreExpr), [CoreRule])+dsImpSpecs imp_specs+ = do { spec_prs <- mapMaybeM spec_one imp_specs+      ; let (spec_binds, spec_rules) = unzip spec_prs+      ; return (concatOL spec_binds, spec_rules) }+ where+   spec_one (L loc prag) = putSrcSpanDs loc $+                           dsSpec (get_rhs prag) prag++   get_rhs (SpecPrag poly_id _ _)              = get_rhs1 poly_id+   get_rhs (SpecPragE { spe_fn_id = poly_id }) = get_rhs1 poly_id++   get_rhs1 poly_id+    | Just unfolding <- maybeUnfoldingTemplate (realIdUnfolding poly_id)+    = unfolding    -- Imported Id; this is its unfolding+                   -- Use realIdUnfolding so we get the unfolding+                   -- even when it is a loop breaker.+                   -- We want to specialise recursive functions!+    | otherwise = pprPanic "dsImpSpecs" (ppr poly_id)+                  -- The type checker has checked that it *has* an unfolding++dsLSpec :: CoreExpr -> Located TcSpecPrag+        -> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule))+dsLSpec poly_rhs (L loc prag)+  = putSrcSpanDs loc $ dsSpec poly_rhs prag++dsSpec :: CoreExpr   -- RHS to be specialised+       -> TcSpecPrag+       -> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule))+dsSpec poly_rhs (SpecPrag poly_id spec_co spec_inl)+  -- SpecPrag case: See Note [Handling old-form SPECIALISE pragmas] in GHC.Tc.Gen.Sig+  | (spec_bndrs, spec_app) <- collectHsWrapBinders spec_co+               -- spec_co looks like+               --         \spec_bndrs. [] spec_args+               -- perhaps with the body of the lambda wrapped in some WpLets+               -- E.g. /\a \(d:Eq a). let d2 = $df d in [] (Maybe a) d2+  = dsHsWrapper spec_app $ \core_app ->+    dsSpec_help (idName poly_id) poly_id poly_rhs+                spec_inl spec_bndrs (core_app (Var poly_id))++dsSpec poly_rhs (SpecPragE { spe_fn_nm = poly_nm+                           , spe_fn_id = poly_id+                           , spe_inl   = spec_inl+                           , spe_bndrs = bndrs+                           , spe_call  = the_call })+  -- SpecPragE case: See Note [Handling new-form SPECIALISE pragmas] in GHC.Tc.Gen.Sig+  = do { ds_call <- unsetGOptM Opt_EnableRewriteRules $ -- Note [Desugaring RULE left hand sides]+                    unsetWOptM Opt_WarnIdentities     $+                    zapUnspecables $+                    dsLExpr the_call+       ; dsSpec_help poly_nm poly_id poly_rhs spec_inl bndrs ds_call }++dsSpec_help :: Name -> Id -> CoreExpr              -- Function to specialise+            -> InlinePragma -> [Var] -> CoreExpr+            -> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule))+dsSpec_help poly_nm poly_id poly_rhs spec_inl orig_bndrs ds_call+  = do { -- Decompose the call+         -- Step (S1) of Note [Desugaring new-form SPECIALISE pragmas]+         mb_call_info <- decomposeCall poly_id ds_call+       ; case mb_call_info of {+            Nothing -> return Nothing ;+            Just (binds, rule_lhs_args) ->++    do { dflags   <- getDynFlags+       ; this_mod <- getModule+       ; uniq     <- newUnique+       ; let locals = mkVarSet orig_bndrs `extendVarSetList` bindersOfBinds binds+             is_local :: Var -> Bool+             is_local v = v `elemVarSet` locals++             -- Find `rule_bndrs`: (S2) of Note [Desugaring new-form SPECIALISE pragmas]+             rule_bndrs = scopedSort (exprsSomeFreeVarsList is_local rule_lhs_args)++             -- getRenamings: (S3) of  Note [Desugaring new-form SPECIALISE pragmas]+             rn_binds     = getRenamings orig_bndrs binds rule_bndrs++             -- pickSpecBinds: (S4) of Note [Desugaring new-form SPECIALISE pragmas]+             known_vars   = mkVarSet rule_bndrs `extendVarSetList` bindersOfBinds rn_binds+             picked_binds = pickSpecBinds is_local known_vars binds++             -- Find `spec_bndrs`: (S5) of Note [Desugaring new-form SPECIALISE pragmas]+             -- Make spec_bndrs, the variables to pass to the specialised+             -- function, by filtering out the rule_bndrs that aren't needed+             spec_binds_bndr_set = mkVarSet (bindersOfBinds picked_binds)+                                   `minusVarSet` exprsFreeVars (rhssOfBinds rn_binds)+             spec_bndrs = filterOut (`elemVarSet` spec_binds_bndr_set) rule_bndrs++             mk_spec_body fn_body = mkLets (rn_binds ++ picked_binds)  $+                                    mkApps fn_body rule_lhs_args+                                    -- NB: not mkCoreApps!  That uses exprType on fun+                                    --     which fails in specUnfolding, sigh++             poly_name  = idName poly_id+             spec_occ   = mkSpecOcc (getOccName poly_name)+             spec_name  = mkInternalName uniq spec_occ (getSrcSpan poly_name)+             id_inl     = idInlinePragma poly_id++             simpl_opts = initSimpleOpts dflags+             fn_unf     = realIdUnfolding poly_id+             spec_unf   = specUnfolding simpl_opts spec_bndrs mk_spec_body rule_lhs_args fn_unf+             spec_info  = vanillaIdInfo+                          `setInlinePragInfo` specFunInlinePrag poly_id id_inl spec_inl+                          `setUnfoldingInfo`  spec_unf+             spec_id    = mkLocalVar (idDetails poly_id) spec_name ManyTy spec_ty spec_info+                          -- Specialised binding is toplevel, hence Many.++             -- The RULE looks like+             --    RULE "USPEC" forall rule_bndrs. f rule_lhs_args = $sf spec_bndrs+             -- The specialised function looks like+             --    $sf spec_bndrs = mk_spec_body <f's original rhs>+             -- We also use mk_spec_body to specialise the methods in f's stable unfolding+             -- NB: spec_bindrs is a subset of rule_bndrs+             rule = mkSpecRule dflags this_mod False rule_act (text "USPEC")+                               poly_id rule_bndrs rule_lhs_args+                               (mkVarApps (Var spec_id) spec_bndrs)++             rule_ty  = exprType (mkApps (Var poly_id) rule_lhs_args)+             spec_ty  = mkLamTypes spec_bndrs rule_ty+             spec_rhs = mkLams spec_bndrs (mk_spec_body poly_rhs)++             result = (unitOL (spec_id, spec_rhs), rule)+            -- NB: do *not* use makeCorePair on (spec_id,spec_rhs), because+            --     makeCorePair overwrites the unfolding, which we have+            --     just created using specUnfolding+       ; tracePm "dsSpec(new route)" $+         vcat [ text "poly_id" <+> ppr poly_id+              , text "unfolding" <+> ppr (realIdUnfolding poly_id)+              , text "orig_bndrs"   <+> pprCoreBinders orig_bndrs+              , text "locals" <+> ppr locals+              , text "fvs" <+> ppr (exprsSomeFreeVarsList is_local rule_lhs_args)+              , text "ds_call" <+> ppr ds_call+              , text "binds" <+> ppr binds+              , text "rule_lhs_args" <+> ppr rule_lhs_args+              , text "rule_bndrs" <+> ppr rule_bndrs+              , text "spec_bndrs" <+> ppr spec_bndrs+              , text "rn_binds" <+> ppr rn_binds+              , text "picked_binds" <+> ppr picked_binds ]++       ; dsWarnOrphanRule rule++       ; case checkUselessSpecPrag poly_id rule_lhs_args spec_bndrs+                 no_act_spec spec_inl rule_act of+           Nothing -> return (Just result)++           Just reason -> do { diagnosticDs $ DsUselessSpecialisePragma poly_nm is_dfun reason+                             ; if uselessSpecialisePragmaKeepAnyway reason+                               then return (Just result)+                               else return Nothing } } } }++  where+    -- See Note [Activation pragmas for SPECIALISE]+    -- no_act_spec is True if the user didn't write an explicit+    -- phase specification in the SPECIALISE pragma+    id_inl        = idInlinePragma poly_id+    inl_prag_act  = inlinePragmaActivation id_inl+    spec_prag_act = inlinePragmaActivation spec_inl+    no_act_spec = case inlinePragmaSpec spec_inl of+                    NoInline _   -> isNeverActive  spec_prag_act+                    Opaque _     -> isNeverActive  spec_prag_act+                    _            -> isAlwaysActive spec_prag_act+    rule_act | no_act_spec = inl_prag_act    -- Inherit+             | otherwise   = spec_prag_act   -- Specified by user++    is_dfun = case idDetails poly_id of+      DFunId {} -> True+      _ -> False++decomposeCall :: Id -> CoreExpr+              -> DsM (Maybe ([CoreBind], [CoreExpr] ))+-- Decompose the call into (let <binds> in f <args>)+-- See (S1) in Note [Desugaring new-form SPECIALISE pragmas]+decomposeCall poly_id ds_call+  = do { dflags  <- getDynFlags+       ; let simpl_opts = initSimpleOpts dflags+             core_call  = simpleOptExprNoInline simpl_opts ds_call+               -- simpleOptExprNoInline: see Wrinkle (S1a)!++       ; case go [] core_call of {+           Nothing -> do { diagnosticDs (DsRuleLhsTooComplicated ds_call core_call)+                         ; return Nothing } ;+           Just result -> return (Just result) } }+  where+    go :: [CoreBind] -> CoreExpr -> Maybe ([CoreBind],[CoreExpr])+    go acc (Let bind body) = go (bind:acc) body+    go acc (Cast e _)      = go acc e  -- Discard outer casts+                                       -- ToDo: document this+    go acc e+      | (Var fun, args) <- collectArgs e+      = assertPpr (fun == poly_id) (ppr fun $$ ppr poly_id) $+        Just (reverse acc, args)+      | otherwise+      = Nothing++    -- Is this SPECIALISE pragma useless?+checkUselessSpecPrag :: Id -> [CoreExpr]+   -> [Var] -> Bool -> InlinePragma -> Activation+   ->  Maybe UselessSpecialisePragmaReason+checkUselessSpecPrag poly_id rule_lhs_args+                     spec_bndrs no_act_spec spec_inl rule_act+  | isJust (isClassOpId_maybe poly_id)+  -- There is no point in trying to specialise a class op+  -- Moreover, classops don't (currently) have an inl_sat arity set+  -- (it would be Just 0) and that in turn makes makeCorePair bleat+  = Just UselessSpecialiseForClassMethodSelector++  | no_act_spec, isNeverActive rule_act+  -- Function is NOINLINE, and the specialisation inherits that+  -- See Note [Activation pragmas for SPECIALISE]+  = Just UselessSpecialiseForNoInlineFunction++  | all is_nop_arg rule_lhs_args, not (isInlinePragma spec_inl)+  -- The specialisation does nothing.+  -- But don't complain if it is SPECIALISE INLINE (#4444)+  = Just UselessSpecialiseNoSpecialisation++  | otherwise+  = Nothing++  where+    is_nop_arg (Type {})     = True+    is_nop_arg (Coercion {}) = True+    is_nop_arg (Cast e _)    = is_nop_arg e+    is_nop_arg (Tick _ e)    = is_nop_arg e+    is_nop_arg (Var x)       = x `elem` spec_bndrs+    is_nop_arg _             = False+++getRenamings :: [Var] -> [CoreBind]  -- orig_bndrs and bindings+             -> [Var]                -- rule_bndrs+             -> [CoreBind]           -- Binds some of the orig_bndrs to a rule_bndr+getRenamings orig_bndrs binds rule_bndrs+  = [ NonRec b e | b <- orig_bndrs+                 , not (b `elem` rule_bndrs)+                 , Just e <- [lookupVarEnv final_renamings b] ]+  where+    init_renamings, final_renamings :: IdEnv CoreExpr+    -- In this function, IdEnv maps a local variable to (v |> co),+    -- where `v` is a rule_bndr++    init_renamings = mkVarEnv [ (v, Var v) | v <- rule_bndrs, isId v ]+    final_renamings = go binds++    go :: [CoreBind] -> IdEnv CoreExpr+    go [] = init_renamings+    go (bind : binds)+       | NonRec b rhs <- bind+       , Just (v, mco) <- getCastedVar rhs+       , Just e <- lookupVarEnv renamings b+       = extendVarEnv renamings v (mkCastMCo e (mkSymMCo mco))+       | otherwise+       = renamings+       where+         renamings = go binds++pickSpecBinds :: (Var -> Bool) -> VarSet -> [CoreBind] -> [CoreBind]+pickSpecBinds _ _ [] = []+pickSpecBinds is_local known_bndrs (bind:binds)+      | all keep_me (rhssOfBind bind)+      , let known_bndrs' = known_bndrs `extendVarSetList` bindersOf bind+      = bind : pickSpecBinds is_local known_bndrs' binds+      | otherwise+      = pickSpecBinds is_local known_bndrs binds+      where+        keep_me rhs = isEmptyVarSet (exprSomeFreeVars bad_var rhs)+        bad_var v = is_local v && not (v `elemVarSet` known_bndrs)++getCastedVar :: CoreExpr -> Maybe (Var, MCoercionR)+getCastedVar (Var v)           = Just (v, MRefl)+getCastedVar (Cast (Var v) co) = Just (v, MCo co)+getCastedVar _                 = Nothing++specFunInlinePrag :: Id -> InlinePragma+                  -> InlinePragma -> InlinePragma+-- See Note [Activation pragmas for SPECIALISE]+specFunInlinePrag poly_id id_inl spec_inl+  | not (isDefaultInlinePragma spec_inl)    = spec_inl+  | isGlobalId poly_id  -- See Note [Specialising imported functions]+                        -- in OccurAnal+  , isStrongLoopBreaker (idOccInfo poly_id) = neverInlinePragma+  | otherwise                               = id_inl+     -- Get the INLINE pragma from SPECIALISE declaration, or,+     -- failing that, from the original Id++dsWarnOrphanRule :: CoreRule -> DsM ()+dsWarnOrphanRule rule+  = when (ruleIsOrphan rule) $+    diagnosticDs (DsOrphanRule rule)++{- Note [SPECIALISE on INLINE functions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We used to warn that using SPECIALISE for a function marked INLINE+would be a no-op; but it isn't!  Especially with worker/wrapper split+we might have+   {-# INLINE f #-}+   f :: Ord a => Int -> a -> ...+   f d x y = case x of I# x' -> $wf d x' y++We might want to specialise 'f' so that we in turn specialise '$wf'.+We can't even /name/ '$wf' in the source code, so we can't specialise+it even if we wanted to.  #10721 is a case in point.++Note [Activation pragmas for SPECIALISE]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+From a user SPECIALISE pragma for f, we generate+  a) A top-level binding    spec_fn = rhs+  b) A RULE                 f dOrd = spec_fn++We need two pragma-like things:++* spec_fn's inline pragma: inherited from f's inline pragma (ignoring+                           activation on SPEC), unless overridden by SPEC INLINE++* Activation of RULE: from SPECIALISE pragma (if activation given)+                      otherwise from f's inline pragma++This is not obvious (see #5237)!++Examples      Rule activation   Inline prag on spec'd fn+---------------------------------------------------------------------+SPEC [n] f :: ty            [n]   Always, or NOINLINE [n]+                                  copy f's prag++NOINLINE f+SPEC [n] f :: ty            [n]   NOINLINE+                                  copy f's prag++NOINLINE [k] f+SPEC [n] f :: ty            [n]   NOINLINE [k]+                                  copy f's prag++INLINE [k] f+SPEC [n] f :: ty            [n]   INLINE [k]+                                  copy f's prag++SPEC INLINE [n] f :: ty     [n]   INLINE [n]+                                  (ignore INLINE prag on f,+                                  same activation for rule and spec'd fn)++NOINLINE [k] f+SPEC f :: ty                [n]   INLINE [k]+++************************************************************************+*                                                                      *+\subsection{Adding inline pragmas}+*                                                                      *+************************************************************************+-}++decomposeRuleLhs :: DynFlags -> [Var] -> CoreExpr+                 -> VarSet   -- Free vars of the RHS+                 -> Either DsMessage ([Var], Id, [CoreExpr])+-- (decomposeRuleLhs bndrs lhs) takes apart the LHS of a RULE,+-- The 'bndrs' are the quantified binders of the rules, but decomposeRuleLhs+-- may add some extra dictionary binders (see Note [Free dictionaries on rule LHS])+--+-- Returns an error message if the LHS isn't of the expected shape+-- Note [Decomposing the left-hand side of a RULE]+decomposeRuleLhs dflags orig_bndrs orig_lhs rhs_fvs+  | Var funId <- fun2+  , Just con <- isDataConId_maybe funId+  = Left (DsRuleIgnoredDueToConstructor con) -- See Note [No RULES on datacons]++  | otherwise = case decompose fun2 args2 of+        Nothing ->  -- pprTrace "decomposeRuleLhs 3" (vcat [ text "orig_bndrs:" <+> ppr orig_bndrs+                    --                                   , text "orig_lhs:" <+> ppr orig_lhs+                    --                                   , text "rhs_fvs:" <+> ppr rhs_fvs+                    --                                   , text "lhs1:" <+> ppr lhs1+                    --                                   , text "lhs2:" <+> ppr lhs2+                    --                                   , text "fun2:" <+> ppr fun2+                    --                                   , text "args2:" <+> ppr args2+                    --                                   ]) $+                   Left (DsRuleLhsTooComplicated orig_lhs lhs2)++        Just (fn_id, args)+          | not (null unbound) ->+            -- Check for things unbound on LHS+            -- See Note [Unused spec binders]+             -- pprTrace "decomposeRuleLhs 1" (vcat [ text "orig_bndrs:" <+> ppr orig_bndrs+             --                                    , text "orig_lhs:" <+> ppr orig_lhs+             --                                    , text "lhs_fvs:" <+> ppr lhs_fvs+             --                                    , text "rhs_fvs:" <+> ppr rhs_fvs+             --                                    , text "unbound:" <+> ppr unbound+             --                                    ]) $+            Left (DsRuleBindersNotBound unbound orig_bndrs orig_lhs lhs2)+          | otherwise ->+            -- pprTrace "decomposeRuleLhs 2" (vcat [ text "orig_bndrs:" <+> ppr orig_bndrs+            --                                   , text "orig_lhs:" <+> ppr orig_lhs+            --                                   , text "lhs1:"     <+> ppr lhs1+            --                                   , text "trimmed_bndrs:" <+> ppr trimmed_bndrs+            --                                   , text "extra_dicts:" <+> ppr extra_dicts+            --                                   , text "fn_id:" <+> ppr fn_id+            --                                   , text "args:"   <+> ppr args+            --                                   , text "args fvs:" <+> ppr (exprsFreeVarsList args)+            --                                   ]) $+            Right (trimmed_bndrs ++ extra_dicts, fn_id, args)++          where -- See Note [Variables unbound on the LHS]+                lhs_fvs       = exprsFreeVars args+                all_fvs       = lhs_fvs `unionVarSet` rhs_fvs+                trimmed_bndrs = filter (`elemVarSet` all_fvs) orig_bndrs+                unbound       = filterOut (`elemVarSet` lhs_fvs) trimmed_bndrs+                    -- Needed on RHS but not bound on LHS++                -- extra_dicts: see Note [Free dictionaries on rule LHS]+-- ToDo: extra_dicts is needed. E.g. the SPECIALISE rules for `ap` in GHC.Base+                extra_dicts+                  = [ mkLocalIdOrCoVar (localiseName (idName d)) ManyTy (idType d)+                    | d <- exprsSomeFreeVarsList is_extra args ]++                is_extra v+                  = isSimplePredTy (idType v)+                      -- isSimplePredTy: includes coercions and dictionaries+                      -- But NOT dictionary functions; and in particular not+                      -- superclass-selector fuctions++                    && not (v `elemVarSet` orig_bndr_set)+                    && not (v == fn_id)+                       -- fn_id: do not quantify over the function itself, which may+                       -- itself be a dictionary (in pathological cases, #10251)++ where+   simpl_opts    = initSimpleOpts dflags+   orig_bndr_set = mkVarSet orig_bndrs++   lhs1         = drop_dicts orig_lhs+   lhs2         = simpleOptExpr simpl_opts lhs1  -- See Note [Simplify rule LHS]+   (fun2,args2) = collectArgs lhs2++   decompose (Var fn_id) args+      | not (fn_id `elemVarSet` orig_bndr_set)+      = Just (fn_id, args)++   decompose _ _ = Nothing++   drop_dicts :: CoreExpr -> CoreExpr+   drop_dicts e+       = wrap_lets needed bnds body+     where+       needed = orig_bndr_set `minusVarSet` exprFreeVars body+       (bnds, body) = split_lets (occurAnalyseExpr e)+           -- The occurAnalyseExpr drops dead bindings which is+           -- crucial to ensure that every binding is used later;+           -- which in turn makes wrap_lets work right++   split_lets :: CoreExpr -> ([(DictId,CoreExpr)], CoreExpr)+   split_lets (Let (NonRec d r) body)+     | isPredTy (idType d)+       -- isPredTy: catches dictionaries, yes, but also catches+       -- dictionary /functions/ arising from solving a+       -- quantified contraint (see #24370)+     = ((d,r):bs, body')+     where (bs, body') = split_lets body++    -- handle "unlifted lets" too, needed for "map/coerce"+   split_lets (Case r d _ [Alt DEFAULT _ body])+     | isCoVar d+     = ((d,r):bs, body')+     where (bs, body') = split_lets body++   split_lets e = ([], e)++   wrap_lets :: VarSet -> [(DictId,CoreExpr)] -> CoreExpr -> CoreExpr+   wrap_lets _ [] body = body+   wrap_lets needed ((d, r) : bs) body+     | rhs_fvs `intersectsVarSet` needed = mkCoreLet (NonRec d r) (wrap_lets needed' bs body)+     | otherwise                         = wrap_lets needed bs body+     where+       rhs_fvs = exprFreeVars r+       needed' = (needed `minusVarSet` rhs_fvs) `extendVarSet` d++{-+Note [Variables unbound on the LHS]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We obviously want to complain about+   RULE   forall x. f True = not x+because the forall'd variable `x` is not bound on the LHS.++It can be a bit delicate when dictionaries are involved.+Consider #22471+  {-# RULES "foo" forall (f :: forall a. [a] -> Int).+                  foo (\xs. 1 + f xs) = 2 + foo f #-}++We get two dicts on the LHS, one from `1` and one from `+`.+For reasons described in Note [The SimplifyRule Plan] in+GHC.Tc.Gen.Sig, we quantify separately over those dictionaries:+   forall f (d1::Num Int) (d2 :: Num Int).+   foo (\xs. (+) d1 (fromInteger d2 1) xs) = ...++Now the desugarer shortcircuits (fromInteger d2 1) to (I# 1); so d2 is+not mentioned at all (on LHS or RHS)! We don't want to complain about+and unbound d2.  Hence the trimmed_bndrs.++Note [Decomposing the left-hand side of a RULE]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There are several things going on here.+* drop_dicts: see Note [Drop dictionary bindings on rule LHS]+* simpleOptExpr: see Note [Simplify rule LHS]+* extra_dict_bndrs: see Note [Free dictionaries on rule LHS]++Note [Free dictionaries on rule LHS]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When the LHS of a specialisation rule, (/\as\ds. f es) has a free dict,+which is presumably in scope at the function definition site, we can quantify+over it too.  *Any* dict with that type will do.++So for example when you have+        f :: Eq a => a -> a+        f = <rhs>+        ... SPECIALISE f :: Int -> Int ...++Then we get the SpecPrag+        SpecPrag (f Int dInt)++And from that we want the rule++        RULE forall dInt. f Int dInt = f_spec+        f_spec = let f = <rhs> in f Int dInt++But be careful!  That dInt might be GHC.Base.$fOrdInt, which is an External+Name, and you can't bind them in a lambda or forall without getting things+confused.   Likewise it might have a stable unfolding or something, which would be+utterly bogus. So we really make a fresh Id, with the same unique and type+as the old one, but with an Internal name and no IdInfo.++Note [Drop dictionary bindings on rule LHS]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+drop_dicts drops dictionary bindings on the LHS where possible.+   E.g.  let d:Eq [Int] = $fEqList $fEqInt in f d+     --> f d+   Reasoning here is that there is only one d:Eq [Int], and so we can+   quantify over it. That makes 'd' free in the LHS, but that is later+   picked up by extra_dict_bndrs (see Note [Unused spec binders]).++   NB 1: We can only drop the binding if the RHS of the binding doesn't+         mention one of the orig_bndrs, which we assume occur on RHS of+         the rule.  Example+            f :: (Eq a) => b -> a -> a+            {-# SPECIALISE f :: Eq a => b -> [a] -> [a] #-}+         Here we want to end up with+            RULE forall d:Eq a.  f ($dfEqList d) = f_spec d+         Of course, the ($dfEqlist d) in the pattern makes it less likely+         to match, but there is no other way to get d:Eq a++   NB 2: We do drop_dicts *before* simplOptExpr, so that we expect all+         the evidence bindings to be wrapped around the outside of the+         LHS.  (After simplOptExpr they'll usually have been inlined.)+         dsHsWrapper does dependency analysis, so that civilised ones+         will be simple NonRec bindings.  We don't handle recursive+         dictionaries!++    NB3: In the common case of a non-overloaded, but perhaps-polymorphic+         specialisation, we don't need to bind *any* dictionaries for use+         in the RHS. For example (#8331)+             {-# SPECIALIZE INLINE useAbstractMonad :: ReaderST s Int #-}+             useAbstractMonad :: MonadAbstractIOST m => m Int+         Here, deriving (MonadAbstractIOST (ReaderST s)) is a lot of code+         but the RHS uses no dictionaries, so we want to end up with+             RULE forall s (d :: MonadAbstractIOST (ReaderT s)).+                useAbstractMonad (ReaderT s) d = $suseAbstractMonad s++   #8848 is a good example of where there are some interesting+   dictionary bindings to discard.++The drop_dicts algorithm is based on these observations:++  * Given (let d = rhs in e) where d is a DictId,+    matching 'e' will bind e's free variables.++  * So we want to keep the binding if one of the needed variables (for+    which we need a binding) is in fv(rhs) but not already in fv(e).++  * The "needed variables" are simply the orig_bndrs.  Consider+       f :: (Eq a, Show b) => a -> b -> String+       ... SPECIALISE f :: (Show b) => Int -> b -> String ...+    Then orig_bndrs includes the *quantified* dictionaries of the type+    namely (dsb::Show b), but not the one for Eq Int++So we work inside out, applying the above criterion at each step.+++Note [Simplify rule LHS]+~~~~~~~~~~~~~~~~~~~~~~~~+simplOptExpr occurrence-analyses and simplifies the LHS:++   (a) Inline any remaining dictionary bindings (which hopefully+       occur just once)++   (b) Substitute trivial lets, so that they don't get in the way.+       Note that we substitute the function too; we might+       have this as a LHS:  let f71 = M.f Int in f71++   (c) Do eta reduction.  To see why, consider the fold/build rule,+       which without simplification looked like:+          fold k z (build (/\a. g a))  ==>  ...+       This doesn't match unless you do eta reduction on the build argument.+       Similarly for a LHS like+         augment g (build h)+       we do not want to get+         augment (\a. g a) (build h)+       otherwise we don't match when given an argument like+          augment (\a. h a a) (build h)++Note [Unused spec binders]+~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+        f :: a -> a+        ... SPECIALISE f :: Eq a => a -> a ...+It's true that this *is* a more specialised type, but the rule+we get is something like this:+        f_spec d = f+        RULE: f = f_spec d+Note that the rule is bogus, because it mentions a 'd' that is+not bound on the LHS!  But it's a silly specialisation anyway, because+the constraint is unused.  We could bind 'd' to (error "unused")+but it seems better to reject the program because it's almost certainly+a mistake.  That's what the isDeadBinder call detects.++Note [No RULES on datacons]+~~~~~~~~~~~~~~~~~~~~~~~~~~~++Previously, `RULES` like++    "JustNothing" forall x . Just x = Nothing++were allowed. Simon Peyton Jones says this seems to have been a+mistake, that such rules have never been supported intentionally,+and that he doesn't know if they can break in horrible ways.+Furthermore, Ben Gamari and Reid Barton are considering trying to+detect the presence of "static data" that the simplifier doesn't+need to traverse at all. Such rules do not play well with that.+So for now, we ban them altogether as requested by #13290. See also #7398.+++************************************************************************+*                                                                      *+                Desugaring evidence+*                                                                      *+************************************************************************++Note [Desugaring WpFun]+~~~~~~~~~~~~~~~~~~~~~~~+See comments on WpFun in GHC.Tc.Types.Evidence for what WpFun means.+Roughly:++  (WpFun w_arg w_res)[ e ] = \x. w_res[ e w_arg[x] ]++This eta-expansion risk duplicating work, if `e` is not in HNF.+At one stage I thought we could avoid that by desugaring to+      let f = e in \x. w_res[ f w_arg[x] ]+But that /fundamentally/ doesn't work, because `w_res` may bind+evidence that is used in `e`.++This question arose when thinking about deep subsumption; see+https://github.com/ghc-proposals/ghc-proposals/pull/287#issuecomment-1125419649).+-}++dsHsWrappers :: [HsWrapper] -> ([CoreExpr -> CoreExpr] -> DsM a) -> DsM a+dsHsWrappers (wp:wps) k = dsHsWrapper wp $ \wrap -> dsHsWrappers wps $ \wraps -> k (wrap:wraps)+dsHsWrappers []       k = k []++dsHsWrapper :: HsWrapper -> ((CoreExpr -> CoreExpr) -> DsM a) -> DsM a+dsHsWrapper hs_wrap thing_inside+  = ds_hs_wrapper hs_wrap $ \ core_wrap ->+    addTyCs FromSource (hsWrapDictBinders hs_wrap) $+       -- addTyCs: Add type evidence to the refinement type+       --            predicate of the coverage checker+       --   See Note [Long-distance information] in "GHC.HsToCore.Pmc"+       -- FromSource might not be accurate (we don't have any+       -- origin annotations for things in this module), but at+       -- worst we do superfluous calls to the pattern match+       -- oracle.+    thing_inside core_wrap++ds_hs_wrapper :: HsWrapper+              -> ((CoreExpr -> CoreExpr) -> DsM a)+              -> DsM a+ds_hs_wrapper wrap = go wrap+  where+    go WpHole            k = k $ \e -> e+    go (WpTyApp ty)      k = k $ \e -> App e (Type ty)+    go (WpEvLam ev)      k = k $ Lam ev+    go (WpTyLam tv)      k = k $ Lam tv+    go (WpCast co)       k = assert (coercionRole co == Representational) $+                             k $ \e -> mkCastDs e co+    go (WpEvApp tm)      k = do { core_tm <- dsEvTerm tm+                                ; k $ \e -> e `App` core_tm }+    go (WpLet ev_binds)  k = dsTcEvBinds ev_binds $ \bs ->+                             k (mkCoreLets bs)+    go (WpCompose c1 c2) k = go c1 $ \w1 ->+                             go c2 $ \w2 ->+                             k (w1 . w2)+    go (WpFun c1 c2 st)  k = -- See Note [Desugaring WpFun]+                             do { x <- newSysLocalDs st+                                ; go c1 $ \w1 ->+                                  go c2 $ \w2 ->+                                  let app f a = mkCoreApp (text "dsHsWrapper") f a+                                      arg     = w1 (Var x)+                                  in k (\e -> (Lam x (w2 (app e arg)))) }++--------------------------------------+dsTcEvBinds_s :: [TcEvBinds] -> ([CoreBind] -> DsM a) -> DsM a+dsTcEvBinds_s []       k = k []+dsTcEvBinds_s (b:rest) k = assert (null rest) $  -- Zonker ensures null+                           dsTcEvBinds b k++dsTcEvBinds :: TcEvBinds -> ([CoreBind] -> DsM a) -> DsM a+dsTcEvBinds (TcEvBinds {}) = panic "dsEvBinds"    -- Zonker has got rid of this+dsTcEvBinds (EvBinds bs)   = dsEvBinds bs++--   * Desugars the ev_binds, sorts them into dependency order, and+--     passes the resulting [CoreBind] to thing_inside+--   * Extends the DsM (dsl_unspecable field) with specialisability information+--     for each binder in ev_binds, before invoking thing_inside+dsEvBinds :: Bag EvBind -> ([CoreBind] -> DsM a) -> DsM a+dsEvBinds ev_binds thing_inside+  = do { ds_binds <- mapBagM dsEvBind ev_binds+       ; let comps = sort_ev_binds ds_binds+       ; go comps thing_inside }+  where+    go ::[SCC (Node EvVar (CanonicalEvidence, CoreExpr))] -> ([CoreBind] -> DsM a) -> DsM a+    go (comp:comps) thing_inside+      = do { unspecables <- getUnspecables+           ; let (core_bind, new_unspecables) = ds_component unspecables comp+           ; addUnspecables new_unspecables $ go comps $ \ core_binds ->+               thing_inside (core_bind:core_binds) }+    go [] thing_inside = thing_inside []++    ds_component mb_unspecables (AcyclicSCC node) = (NonRec v rhs, new_unspecables)+      where+        ((v, rhs), (this_canonical, deps)) = unpack_node node+        new_unspecables = case mb_unspecables of+           Nothing                                -> []+           Just unspecs | transitively_unspecable -> [v]+                        | otherwise               -> []+              where+                transitively_unspecable = is_unspecable this_canonical+                                          || any (`elemVarSet` unspecs) deps++    ds_component mb_unspecables (CyclicSCC nodes) = (Rec pairs, new_unspecables)+      where+        (pairs, direct_canonicity) = unzip $ map unpack_node nodes++        new_unspecables = case mb_unspecables of+           Nothing                                -> []+           Just unspecs | transitively_unspecable -> map fst pairs+                        | otherwise               -> []+              where+                 transitively_unspecable+                   = or [ is_unspecable this_canonical+                          || any (`elemVarSet` unspecs) deps+                        | (this_canonical, deps) <- direct_canonicity ]+            -- Bindings from a given SCC are transitively specialisable if+            -- all are specialisable and all their remote dependencies are+            -- also specialisable; see Note [Desugaring non-canonical evidence]++    unpack_node DigraphNode { node_key = v, node_payload = (canonical, rhs), node_dependencies = deps }+       = ((v, rhs), (canonical, deps))++    is_unspecable :: CanonicalEvidence -> Bool+    is_unspecable EvNonCanonical = True+    is_unspecable EvCanonical    = False++sort_ev_binds :: Bag (Id, CanonicalEvidence, CoreExpr) -> [SCC (Node EvVar (CanonicalEvidence, CoreExpr))]+-- We do SCC analysis of the evidence bindings, /after/ desugaring+-- them. This is convenient: it means we can use the GHC.Core+-- free-variable functions rather than having to do accurate free vars+-- for EvTerm.+sort_ev_binds ds_binds = stronglyConnCompFromEdgedVerticesUniqR edges+  where+    edges :: [ Node EvVar (CanonicalEvidence, CoreExpr) ]+    edges = foldr ((:) . mk_node) [] ds_binds++    mk_node :: (Id, CanonicalEvidence, CoreExpr) -> Node EvVar (CanonicalEvidence, CoreExpr)+    mk_node (var, canonical, rhs)+      = DigraphNode { node_payload = (canonical, rhs)+                    , node_key = var+                    , node_dependencies = nonDetEltsUniqSet $+                                          exprFreeVars rhs `unionVarSet`+                                          coVarsOfType (varType var) }+      -- It's OK to use nonDetEltsUniqSet here as graphFromEdgedVerticesUniq+      -- is still deterministic even if the edges are in nondeterministic order+      -- as explained in Note [Deterministic SCC] in GHC.Data.Graph.Directed.++dsEvBind :: EvBind -> DsM (Id, CanonicalEvidence, CoreExpr)+dsEvBind (EvBind { eb_lhs = v, eb_rhs = r, eb_info = info }) = do+    e <- dsEvTerm r+    let canonical = case info of+            EvBindGiven{} -> EvCanonical+            EvBindWanted{ ebi_canonical = canonical } -> canonical+    return (v, canonical, e)+++{-**********************************************************************+*                                                                      *+           Desugaring EvTerms+*                                                                      *+**********************************************************************-}++dsEvTerm :: EvTerm -> DsM CoreExpr+dsEvTerm (EvExpr e)          = return e+dsEvTerm (EvTypeable ty ev)  = dsEvTypeable ty ev+dsEvTerm (EvFun { et_tvs = tvs, et_given = given+                , et_binds = ev_binds, et_body = wanted_id })+  = do { dsTcEvBinds ev_binds $ \ds_ev_binds ->+         return $ (mkLams (tvs ++ given) $+                   mkCoreLets ds_ev_binds $+                   Var wanted_id) }+++{-**********************************************************************+*                                                                      *+           Desugaring Typeable dictionaries+*                                                                      *+**********************************************************************-}++dsEvTypeable :: Type -> EvTypeable -> DsM CoreExpr+-- Return a CoreExpr :: Typeable ty+-- This code is tightly coupled to the representation+-- of TypeRep, in base library Data.Typeable.Internal+dsEvTypeable ty ev+  = do { tyCl <- dsLookupTyCon typeableClassName    -- Typeable+       ; let kind = typeKind ty+             typeable_data_con = tyConSingleDataCon tyCl  -- "Data constructor"+                                                    -- for Typeable++       ; rep_expr <- ds_ev_typeable ty ev           -- :: TypeRep a++       -- Package up the method as `Typeable` dictionary+       ; return $ mkConApp typeable_data_con [Type kind, Type ty, rep_expr] }++type TypeRepExpr = CoreExpr++-- | Returns a @CoreExpr :: TypeRep ty@+ds_ev_typeable :: Type -> EvTypeable -> DsM CoreExpr+ds_ev_typeable ty (EvTypeableTyCon tc kind_ev)+  = do { mkTrCon <- dsLookupGlobalId mkTrConName+                    -- mkTrCon :: forall k (a :: k). TyCon -> TypeRep k -> TypeRep a+       ; someTypeRepTyCon <- dsLookupTyCon someTypeRepTyConName+       ; someTypeRepDataCon <- dsLookupDataCon someTypeRepDataConName+                    -- SomeTypeRep :: forall k (a :: k). TypeRep a -> SomeTypeRep++       ; tc_rep <- tyConRep tc                      -- :: TyCon+       ; let ks = tyConAppArgs ty+             -- Construct a SomeTypeRep+             toSomeTypeRep :: Type -> EvTerm -> DsM CoreExpr+             toSomeTypeRep t ev = do+                 rep <- getRep ev t+                 return $ mkCoreConApps someTypeRepDataCon [Type (typeKind t), Type t, rep]+       ; kind_arg_reps <- sequence $ zipWith toSomeTypeRep ks kind_ev   -- :: TypeRep t+       ; let -- :: [SomeTypeRep]+             kind_args = mkListExpr (mkTyConTy someTypeRepTyCon) kind_arg_reps++         -- Note that we use the kind of the type, not the TyCon from which it+         -- is constructed since the latter may be kind polymorphic whereas the+         -- former we know is not (we checked in the solver).+       ; let expr = mkApps (Var mkTrCon) [ Type (typeKind ty)+                                         , Type ty+                                         , tc_rep+                                         , kind_args ]+       -- ; pprRuntimeTrace "Trace mkTrTyCon" (ppr expr) expr+       ; return expr+       }++ds_ev_typeable ty (EvTypeableTyApp ev1 ev2)+  | Just (t1,t2) <- splitAppTy_maybe ty+  = do { e1  <- getRep ev1 t1+       ; e2  <- getRep ev2 t2+       ; mkTrAppChecked <- dsLookupGlobalId mkTrAppCheckedName+                    -- mkTrAppChecked :: forall k1 k2 (a :: k1 -> k2) (b :: k1).+                    --                   TypeRep a -> TypeRep b -> TypeRep (a b)+       ; let (_, k1, k2) = splitFunTy (typeKind t1)  -- drop the multiplicity,+                                                     -- since it's a kind+       ; let expr =  mkApps (mkTyApps (Var mkTrAppChecked) [ k1, k2, t1, t2 ])+                            [ e1, e2 ]+       -- ; pprRuntimeTrace "Trace mkTrAppChecked" (ppr expr) expr+       ; return expr+       }++ds_ev_typeable ty (EvTypeableTrFun evm ev1 ev2)+  | Just (_af,m,t1,t2) <- splitFunTy_maybe ty+  = do { e1 <- getRep ev1 t1+       ; e2 <- getRep ev2 t2+       ; em <- getRep evm m+       ; mkTrFun <- dsLookupGlobalId mkTrFunName+                    -- mkTrFun :: forall (m :: Multiplicity) r1 r2 (a :: TYPE r1) (b :: TYPE r2).+                    --            TypeRep m -> TypeRep a -> TypeRep b -> TypeRep (a % m -> b)+       ; let r1 = getRuntimeRep t1+             r2 = getRuntimeRep t2+       ; return $ mkApps (mkTyApps (Var mkTrFun) [m, r1, r2, t1, t2])+                         [ em, e1, e2 ]+       }++ds_ev_typeable ty (EvTypeableTyLit ev)+  = -- See Note [Typeable for Nat and Symbol] in GHC.Tc.Instance.Class     do { fun  <- dsLookupGlobalId tr_fun        ; dict <- dsEvTerm ev       -- Of type KnownNat/KnownSymbol        ; return (mkApps (mkTyApps (Var fun) [ty]) [ dict ]) }
GHC/HsToCore/Binds.hs-boot view
@@ -3,4 +3,4 @@ import GHC.Core           ( CoreExpr ) import GHC.Tc.Types.Evidence    (HsWrapper) -dsHsWrapper :: HsWrapper -> DsM (CoreExpr -> CoreExpr)+dsHsWrapper :: HsWrapper -> ((CoreExpr -> CoreExpr) -> DsM a) -> DsM a
+ GHC/HsToCore/Breakpoints.hs view
@@ -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".+-}
GHC/HsToCore/Coverage.hs view
@@ -1,1361 +1,132 @@-{-# LANGUAGE DeriveFunctor            #-}-{-# LANGUAGE NondecreasingIndentation #-}-{-# LANGUAGE TypeFamilies             #-}--{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}--{--(c) Galois, 2006-(c) University of Glasgow, 2007--}--module GHC.HsToCore.Coverage-  ( CoverageConfig (..)-  , addTicksToBinds-  , hpcInitCode-  ) where--import GHC.Prelude as Prelude--import GHC.Driver.Session-import GHC.Driver.Backend--import qualified GHC.Runtime.Interpreter as GHCi-import GHCi.RemoteTypes-import GHC.ByteCode.Types-import GHC.Stack.CCS-import GHC.Hs-import GHC.Unit-import GHC.Cmm.CLabel--import GHC.Core.Type-import GHC.Core.TyCon--import GHC.Data.Maybe-import GHC.Data.FastString-import GHC.Data.Bag--import GHC.Platform--import GHC.Runtime.Interpreter.Types--import GHC.Utils.Misc-import GHC.Utils.Outputable as Outputable-import GHC.Utils.Panic-import GHC.Utils.Monad-import GHC.Utils.Logger--import GHC.Types.SrcLoc-import GHC.Types.Basic-import GHC.Types.Id-import GHC.Types.Var.Set-import GHC.Types.Name.Set hiding (FreeVars)-import GHC.Types.Name-import GHC.Types.HpcInfo-import GHC.Types.CostCentre-import GHC.Types.CostCentre.State-import GHC.Types.ForeignStubs-import GHC.Types.Tickish--import Control.Monad-import Data.List (isSuffixOf, intersperse)-import Data.Array-import Data.Time-import System.Directory--import Trace.Hpc.Mix-import Trace.Hpc.Util--import qualified Data.ByteString as BS-import Data.Set (Set)-import qualified Data.Set as Set--{--************************************************************************-*                                                                      *-*              The main function: addTicksToBinds-*                                                                      *-************************************************************************--}--data CoverageConfig = CoverageConfig-  { coverageConfig_logger   :: Logger--  -- FIXME: replace this with the specific fields of DynFlags we care about.-  , coverageConfig_dynFlags :: DynFlags--  , coverageConfig_mInterp  :: Maybe Interp-  }--addTicksToBinds-        :: CoverageConfig-        -> 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 GhcTc-        -> IO (LHsBinds GhcTc, HpcInfo, Maybe ModBreaks)--addTicksToBinds (CoverageConfig-                 { coverageConfig_logger = logger-                 , coverageConfig_dynFlags = dflags-                 , coverageConfig_mInterp = m_interp-                 })-                mod mod_loc exports tyCons binds-  | let passes = coveragePasses dflags-  , not (null passes)-  , Just orig_file <- ml_hs_file mod_loc = do--     let  orig_file2 = guessSourceFile binds orig_file--          tickPass tickish (binds,st) =-            let env = TTE-                      { fileName     = mkFastString orig_file2-                      , declPath     = []-                      , tte_countEntries = gopt Opt_ProfCountEntries dflags-                      , 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 dflags-                      , this_mod     = mod-                      , tickishType  = tickish-                      }-                (binds',_,st') = unTM (addTickLHsBinds binds) env st-            in (binds', st')--          initState = TT { tickBoxCount = 0-                         , mixEntries   = []-                         , ccIndices    = newCostCentreState-                         }--          (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 m_interp dflags mod tickCount entries--     putDumpFileMaybe logger Opt_D_dump_ticked "HPC" FormatHaskell-       (pprLHsBinds binds1)--     return (binds1, HpcInfo tickCount hashNo, modBreaks)--  | otherwise = return (binds, emptyHpcInfo False, 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---mkModBreaks :: Maybe Interp -> DynFlags -> Module -> Int -> [MixEntry_] -> IO (Maybe ModBreaks)-mkModBreaks m_interp dflags mod count entries-  | Just interp <- m_interp-  , breakpointsEnabled dflags = do-    breakArray <- GHCi.newBreakArray interp (length entries)-    ccs <- mkCCSArray interp 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 $ Just $ emptyModBreaks-                       { modBreaks_flags = breakArray-                       , modBreaks_locs  = locsTicks-                       , modBreaks_vars  = varsTicks-                       , modBreaks_decls = declsTicks-                       , modBreaks_ccs   = ccs-                       }-  | otherwise = return Nothing--mkCCSArray-  :: Interp -> Module -> Int -> [MixEntry_]-  -> IO (Array BreakIndex (RemotePtr GHC.Stack.CCS.CostCentre))-mkCCSArray interp modul count entries-  | GHCi.interpreterProfiled interp = do-      let module_str = moduleNameString (moduleName modul)-      costcentres <- GHCi.mkCostCentres interp module_str (map mk_one entries)-      return (listArray (0,count-1) costcentres)-  | otherwise = return (listArray (0,-1) [])- where-    mk_one (srcspan, decl_path, _, _) = (name, src)-      where name = concat (intersperse "." decl_path)-            src = renderWithContext defaultSDocContext (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-              | moduleUnit mod == mainUnit  = hpc_dir-              | otherwise = hpc_dir ++ "/" ++ unitString (moduleUnit mod)--            tabStop = 8 -- <tab> 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 (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----- -------------------------------------------------------------------------------- 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 GhcTc -> TM (LHsBinds GhcTc)-addTickLHsBinds = mapBagM addTickLHsBind--addTickLHsBind :: LHsBind GhcTc -> TM (LHsBind GhcTc)-addTickLHsBind (L pos (XHsBindsLR bind@(AbsBinds { abs_binds = binds-                                                 , abs_exports = abs_exports-                                                 }))) =-  withEnv add_exports $-    withEnv add_inlines $ do-      binds' <- addTickLHsBinds binds-      return $ L pos $ 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) ] }--addTickLHsBind (L pos (funBind@(FunBind { fun_id = L _ id }))) = 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-  if inline && tickish == ProfNotes then return (L pos funBind) else do--  (fvs, mg) <--        getFreeVars $-        addPathEntry name $-        addTickMatchGroup False (fun_matches funBind)--  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 = 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 (locA pos) fvs-             else-                return Nothing--  let mbCons = maybe Prelude.id (:)-  return $ L pos $ funBind { fun_matches = mg-                           , 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 GhcTc -> Bool-   isSimplePatBind funBind = matchGroupArity (fun_matches funBind) == 0---- TODO: Revisit this-addTickLHsBind (L pos (pat@(PatBind { pat_lhs = lhs-                                    , pat_rhs = rhs }))) = 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 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--    let mbCons = maybe id (:)--    let (initial_rhs_ticks, initial_patvar_tickss) = pat_ticks pat'--    -- Allocate the ticks--    rhs_tick <- bindTick density name (locA pos) fvs-    let 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_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 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    -> 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)-                  $ 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 e = isCallSite e--isCallSite :: HsExpr GhcTc -> Bool-isCallSite HsApp{}     = True-isCallSite HsAppType{} = True-isCallSite (XExpr (ExpansionExpr (HsExpanded _ e)))-                       = isCallSite e--- NB: OpApp, SectionL, SectionR are all expanded out-isCallSite _           = False--addTickLHsExprOptAlt :: Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)-addTickLHsExprOptAlt oneOfMany (L pos e0)-  = ifDensity TickForCoverage-        (allocTickBox (ExpBox oneOfMany) False False (locA pos)-          $ addTickHsExpr e0)-        (addTickLHsExpr (L pos e0))--addBinTickLHsExpr :: (Bool -> BoxLabel) -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)-addBinTickLHsExpr boxLabel (L pos e0)-  = ifDensity TickForCoverage-        (allocBinTickBox boxLabel (locA 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 GhcTc -> TM (HsExpr GhcTc)-addTickHsExpr e@(HsVar _ (L _ id))  = do freeVar id; return e-addTickHsExpr e@(HsUnboundVar {})   = return e-addTickHsExpr e@(HsRecSel _ (FieldOcc id _))   = 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 x mg)              = liftM (HsLam x)-                                                (addTickMatchGroup True mg)-addTickHsExpr (HsLamCase x lc_variant mgs) = liftM (HsLamCase x lc_variant)-                                                   (addTickMatchGroup True mgs)-addTickHsExpr (HsApp x e1 e2)          = liftM2 (HsApp x) (addTickLHsExprNever e1)-                                                          (addTickLHsExpr      e2)-addTickHsExpr (HsAppType x e ty)       = liftM3 HsAppType (return x)-                                                          (addTickLHsExprNever e)-                                                          (return ty)-addTickHsExpr (OpApp fix e1 e2 e3) =-        liftM4 OpApp-                (return fix)-                (addTickLHsExpr e1)-                (addTickLHsExprNever e2)-                (addTickLHsExpr e3)-addTickHsExpr (NegApp x e neg) =-        liftM2 (NegApp x)-                (addTickLHsExpr e)-                (addTickSyntaxExpr hpcSrcSpan neg)-addTickHsExpr (HsPar x lpar e rpar) = do-        e' <- addTickLHsExprEvalInner e-        return (HsPar x lpar e' rpar)-addTickHsExpr (SectionL x e1 e2) =-        liftM2 (SectionL x)-                (addTickLHsExpr e1)-                (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 (liftL $ addTickGRHS isOneOfMany False) alts-       ; return $ HsMultiIf ty alts' }-addTickHsExpr (HsLet x tkLet binds tkIn e) =-        bindLocals (collectLocalBinders CollNoDictBinders binds) $ do-          binds' <- addTickHsLocalBinds binds -- to think about: !patterns.-          e' <- addTickLHsExprLetBody e-          return (HsLet x tkLet binds' tkIn e')-addTickHsExpr (HsDo srcloc cxt (L l stmts))-  = do { (stmts', _) <- addTickLStmts' forQual stmts (return ())-       ; return (HsDo srcloc cxt (L l stmts')) }-  where-        forQual = case cxt of-                    ListComp -> Just $ BinBox QualBinBox-                    _        -> Nothing-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 = Left flds })-  = do { e' <- addTickLHsExpr e-       ; flds' <- mapM addTickHsRecField flds-       ; return (expr { rupd_expr = e', rupd_flds = Left flds' }) }-addTickHsExpr expr@(RecordUpd { rupd_expr = e, rupd_flds = Right flds })-  = do { e' <- addTickLHsExpr e-       ; flds' <- mapM addTickHsRecField flds-       ; return (expr { rupd_expr = e', rupd_flds = Right 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@(HsSpliceE  {})      = return e-addTickHsExpr e@(HsGetField {})      = return e-addTickHsExpr e@(HsProjection {})    = return e-addTickHsExpr (HsProc x pat cmdtop) =-        liftM2 (HsProc x)-                (addTickLPat pat)-                (liftL (addTickHsCmdTop) cmdtop)-addTickHsExpr (XExpr (WrapExpr (HsWrap w e))) =-        liftM (XExpr . WrapExpr . HsWrap w) $-              (addTickHsExpr e)        -- Explicitly no tick on inside-addTickHsExpr (XExpr (ExpansionExpr (HsExpanded a b))) =-        liftM (XExpr . ExpansionExpr . HsExpanded a) $-              (addTickHsExpr b)--addTickHsExpr e@(XExpr (ConLikeTc {})) = return e-  -- We used to do a freeVar on a pat-syn builder, but actually-  -- such builders are never in the inScope env, which-  -- doesn't include top level bindings---- We might encounter existing ticks (multiple Coverage passes)-addTickHsExpr (XExpr (HsTick t e)) =-        liftM (XExpr . HsTick t) (addTickLHsExprNever e)-addTickHsExpr (XExpr (HsBinTick t0 t1 e)) =-        liftM (XExpr . HsBinTick t0 t1) (addTickLHsExprNever e)--addTickTupArg :: HsTupArg GhcTc -> TM (HsTupArg GhcTc)-addTickTupArg (Present x e)  = do { e' <- addTickLHsExpr e-                                  ; return (Present x e') }-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 }) = do-  let isOneOfMany = matchesOneOfMany matches-  matches' <- mapM (liftL (addTickMatch isOneOfMany is_lam)) matches-  return $ mg { mg_alts = L l matches' }--addTickMatch :: Bool -> Bool -> Match GhcTc (LHsExpr GhcTc)-             -> TM (Match GhcTc (LHsExpr GhcTc))-addTickMatch isOneOfMany isLambda match@(Match { m_pats = pats-                                               , m_grhss = gRHSs }) =-  bindLocals (collectPatsBinders CollNoDictBinders pats) $ do-    gRHSs' <- addTickGRHSs isOneOfMany isLambda gRHSs-    return $ match { m_grhss = gRHSs' }--addTickGRHSs :: Bool -> Bool -> GRHSs GhcTc (LHsExpr GhcTc)-             -> TM (GRHSs GhcTc (LHsExpr GhcTc))-addTickGRHSs isOneOfMany isLambda (GRHSs x guarded local_binds) =-  bindLocals binders $ do-    local_binds' <- addTickHsLocalBinds local_binds-    guarded' <- mapM (liftL (addTickGRHS isOneOfMany isLambda)) guarded-    return $ GRHSs x guarded' local_binds'-  where-    binders = collectLocalBinders CollNoDictBinders local_binds--addTickGRHS :: Bool -> Bool -> GRHS GhcTc (LHsExpr GhcTc)-            -> TM (GRHS GhcTc (LHsExpr GhcTc))-addTickGRHS isOneOfMany isLambda (GRHS x stmts expr) = do-  (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox) stmts-                        (addTickGRHSBody isOneOfMany isLambda expr)-  return $ GRHS x stmts' expr'--addTickGRHSBody :: Bool -> Bool -> LHsExpr GhcTc -> TM (LHsExpr GhcTc)-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-} (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 (collectLStmtsBinders CollNoDictBinders lstmts) $-    do { lstmts' <- mapM (liftL (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) =-        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 (ApplicativeStmt body_ty args mb_join) = do-    args' <- mapM (addTickApplicativeArg isGuard) args-    return (ApplicativeStmt body_ty args' mb_join)--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-    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' }) }--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) =-    ApplicativeArgOne-      <$> mapM (addTickSyntaxExpr hpcSrcSpan) m_fail-      <*> addTickLPat pat-      <*> addTickLHsExpr expr-      <*> pure isBody-  addTickArg (ApplicativeArgMany x stmts ret pat ctxt) =-    (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 (liftL (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 matchgroup) =-        liftM (HsCmdLam x) (addTickCmdMatchGroup matchgroup)-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 lpar e rpar) = do-        e' <- addTickLHsCmd e-        return (HsCmdPar x lpar e' rpar)-addTickHsCmd (HsCmdCase x e mgs) =-        liftM2 (HsCmdCase x)-                (addTickLHsExpr e)-                (addTickCmdMatchGroup mgs)-addTickHsCmd (HsCmdLamCase x lc_variant mgs) =-        liftM (HsCmdLamCase x lc_variant) (addTickCmdMatchGroup mgs)-addTickHsCmd (HsCmdIf x cnd e1 c2 c3) =-        liftM3 (HsCmdIf x cnd)-                (addBinTickLHsExpr (BinBox CondBinBox) e1)-                (addTickLHsCmd c2)-                (addTickLHsCmd c3)-addTickHsCmd (HsCmdLet x tkLet binds tkIn c) =-        bindLocals (collectLocalBinders CollNoDictBinders binds) $ do-          binds' <- addTickHsLocalBinds binds -- to think about: !patterns.-          c' <- addTickLHsCmd c-          return (HsCmdLet x tkLet binds' tkIn c')-addTickHsCmd (HsCmdDo srcloc (L l stmts))-  = do { (stmts', _) <- addTickLCmdStmts' stmts (return ())-       ; return (HsCmdDo srcloc (L l stmts')) }--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 fix cmdtop) =-        liftM4 (HsCmdArrForm x)-               (addTickLHsExpr e)-               (return f)-               (return fix)-               (mapM (liftL (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 (liftL addTickCmdMatch) matches-  return $ mg { mg_alts = L l matches' }--addTickCmdMatch :: Match GhcTc (LHsCmd GhcTc) -> TM (Match GhcTc (LHsCmd GhcTc))-addTickCmdMatch match@(Match { m_pats = pats, m_grhss = gRHSs }) =-  bindLocals (collectPatsBinders CollNoDictBinders 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 binders $ do-    local_binds' <- addTickHsLocalBinds local_binds-    guarded' <- mapM (liftL addTickCmdGRHS) guarded-    return $ GRHSs x guarded' local_binds'-  where-    binders = collectLocalBinders CollNoDictBinders 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 binders $ do-        lstmts' <- mapM (liftL addTickCmdStmt) lstmts-        a <- res-        return (lstmts', a)-  where-        binders = collectLStmtsBinders CollNoDictBinders lstmts--addTickCmdStmt :: Stmt GhcTc (LHsCmd GhcTc) -> TM (Stmt GhcTc (LHsCmd GhcTc))-addTickCmdStmt (BindStmt x pat c) =-        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 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 fields dd)-  = do  { fields' <- mapM addTickHsRecField fields-        ; return (HsRecFields 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 { tickBoxCount:: !Int-                         , mixEntries  :: [MixEntry_]-                         , ccIndices   :: !CostCentreState-                         }--addMixEntry :: MixEntry_ -> TM Int-addMixEntry ent = do-  c <- tickBoxCount <$> getState-  setState $ \st ->-    st { tickBoxCount = c + 1-       , mixEntries = ent : mixEntries st-       }-  return c--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-                        }----      deriving Show--data TickishType = ProfNotes | HpcTicks | Breakpoints | SourceNotes-                 deriving (Eq)--coveragePasses :: DynFlags -> [TickishType]-coveragePasses dflags =-    ifa (breakpointsEnabled dflags)          Breakpoints $-    ifa (gopt Opt_Hpc dflags)                HpcTicks $-    ifa (sccProfilingEnabled dflags &&-         profAuto dflags /= NoProfAuto)      ProfNotes $-    ifa (needSourceNotes dflags)          SourceNotes []-  where ifa f x xs | f         = x:xs-                   | otherwise = xs---- | Should we produce 'Breakpoint' ticks?-breakpointsEnabled :: DynFlags -> Bool-breakpointsEnabled dflags = backend dflags == Interpreter---- | 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-  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 (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 (do-    (fvs, e) <- getFreeVars m-    env <- getEnv-    tickish <- mkTickish boxLabel countEntries topOnly pos fvs (declPath env)-    return (L (noAnnSrcSpan pos) (XExpr $ HsTick tickish $ L (noAnnSrcSpan pos) e))-  ) (do-    e <- m-    return (L (noAnnSrcSpan 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 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 = (pos, decl_path, map (nameOccName.idName) ids, boxLabel)--      cc_name | topOnly   = head decl_path-              | otherwise = concat (intersperse "." decl_path)--  env <- getEnv-  case tickishType env of-    HpcTicks -> HpcTick (this_mod env) <$> addMixEntry me--    ProfNotes -> do-      let nm = mkFastString cc_name-      flavour <- HpcCC <$> getCCIndexM nm-      let cc = mkUserCC nm (this_mod env) pos flavour-          count = countEntries && tte_countEntries env-      return $ ProfNote cc count True{-scopes-}--    Breakpoints -> Breakpoint noExtField <$> addMixEntry me <*> pure ids--    SourceNotes | RealSrcSpan pos' _ <- pos ->-      return $ SourceNote pos' 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 (pos,declPath env, [],boxLabel True)-    <*> addMixEntry (pos,declPath env, [],boxLabel False)-    <*> pure e-  tick <- HpcTick (this_mod env)-    <$> addMixEntry (pos,declPath env, [],ExpBox False)-  let pos' = noAnnSrcSpan pos-  return $ L pos' $ XExpr $ HsTick tick (L pos' (XExpr binTick))--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 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--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_<module>()`, 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 "hpc"-    decls = text "extern StgWord64 " <> tickboxes <> text "[]" <> semi-    body = text "hs_hpc_module" <>-              parens (hcat (punctuate comma [-                  doubleQuotes full_name_str,-                  int tickCount, -- really StgWord32-                  int hashNo,    -- really StgWord32-                  tickboxes-                ])) <> semi--    tickboxes = pprCLabel platform CStyle (mkHpcTicksLabel $ this_mod)+{-+(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 -- <tab> 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_<module>()`, 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)))
GHC/HsToCore/Docs.hs view
@@ -1,17 +1,12 @@ -- | Extract docs from the renamer output so they can be serialized. {-# LANGUAGE LambdaCase #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE RecordWildCards #-}  module GHC.HsToCore.Docs where  import GHC.Prelude-import GHC.Data.Bag import GHC.Hs.Binds import GHC.Hs.Doc import GHC.Hs.Decls@@ -28,25 +23,27 @@ 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 Data.Semigroup+import qualified Data.Semigroup as S import GHC.IORef (readIORef) import GHC.Unit.Types import GHC.Hs import GHC.Types.Avail-import GHC.Unit.Module import qualified Data.List.NonEmpty as NonEmpty import Data.List.NonEmpty (NonEmpty ((:|))) import GHC.Unit.Module.Imported-import GHC.Driver.Session+import GHC.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@@ -67,16 +64,17 @@                , tcg_imports = import_avails                , tcg_insts = insts                , tcg_fam_insts = fam_insts-               , tcg_doc_hdr = mb_doc_hdr+               , 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 <$> mb_doc_hdr)+    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)@@ -104,6 +102,7 @@                              , 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)@@ -113,6 +112,25 @@     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.@@ -131,7 +149,6 @@ -- TODO: -- * Maybe remove items that export nothing? -- * Combine sequences of DsiExports?--- * Check the ordering of avails in DsiModExport mkDocStructureFromExportList   :: Module                         -- ^ The current module   -> ImportAvails@@ -146,13 +163,17 @@       (IEGroup _ level doc, _)         -> DsiSectionHeading level (unLoc doc)       (IEDoc _ doc, _)                 -> DsiDocChunk (unLoc doc)       (IEDocNamed _ name, _)           -> DsiNamedChunkRef name-      (_, avails)                      -> DsiExports (nubAvails avails)+      (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) (nubAvails avails)+        DsiModExport (nubSortNE orig_names) (sortAvails (nubAvails avails))       where         orig_names = M.findWithDefault aliasErr alias aliasMap         aliasErr = error $ "mkDocStructureFromExportList: "@@ -166,15 +187,14 @@     -- Map from aliases to true module names.     aliasMap :: Map ModuleName (NonEmpty ModuleName)     aliasMap =-        M.fromListWith (<>) $+        M.fromListWith (S.<>) $           (this_mdl_name, this_mdl_name :| [])-          : (flip concatMap (moduleEnvToList imported) $ \(mdl, imvs) ->+          : (flip concatMap (M.toList imported) $ \(mdl, imvs) ->               [(imv_name imv, moduleName mdl :| []) | imv <- imvs])       where         this_mdl_name = moduleName mdl -    imported :: ModuleEnv [ImportedModsVal]-    imported = mapModuleEnv importedByUser (imp_mods import_avails)+    imported = M.map importedByUser (imp_mods import_avails)  -- | Figure out the documentation structure by correlating -- the module exports with the located declarations.@@ -188,10 +208,16 @@     avails :: [Located DocStructureItem]     avails = flip fmap all_exports $ \avail ->       case M.lookup (availName avail) name_locs of-        Just loc -> L loc (DsiExports [avail])+        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 [avail])+        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) @@ -234,7 +260,7 @@        -> (UniqMap Name [HsDoc GhcRn], UniqMap Name (IntMap (HsDoc GhcRn))) mkMaps env instances decls =     ( listsToMapWith (++) (map (nubByName fst) decls')-    , listsToMapWith (<>) (filterMapping (not . IM.null) args)+    , listsToMapWith (S.<>) (filterMapping (not . IM.null) args)     )   where     (decls', args) = unzip (map mappings decls)@@ -248,7 +274,7 @@              -> ( [(Name, [HsDoc GhcRn])]                 , [(Name, IntMap (HsDoc GhcRn))]                 )-    mappings (L (SrcSpanAnn _ (RealSrcSpan l _)) decl, doc) =+    mappings (L (EpAnn (EpaSpan (RealSrcSpan l _)) _ _) decl, doc) =            (dm, am)       where         args = declTypeDocs decl@@ -262,7 +288,7 @@         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 (SrcSpanAnn _ (UnhelpfulSpan _)) _, _) = ([], [])+    mappings (L (EpAnn _ _ _) _, _) = ([], [])      instanceMap :: Map RealSrcSpan Name     instanceMap = M.fromList [(l, n) | n <- instances, RealSrcSpan l _ <- [getSrcSpan n] ]@@ -273,8 +299,8 @@     names _ decl = getMainDeclBinder env decl  {--Note [1]:----------+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@@ -354,8 +380,8 @@    InstD _ (DataFamInstD _ (DataFamInstDecl d))     -> dataSubs (feqn_rhs d)-  TyClD _ d | isClassDecl d -> classSubs d-            | isDataDecl  d -> dataSubs (tcdDataDefn d)+  TyClD _ d | ClassDecl{} <- d -> classSubs d+            | DataDecl{} <- d  -> dataSubs (tcdDataDefn d)   _ -> []   where     classSubs dd = [ (name, doc, declTypeDocs d)@@ -366,14 +392,14 @@              -> [(Name, [HsDoc GhcRn], IntMap (HsDoc GhcRn))]     dataSubs dd = constrs ++ fields  ++ derivs       where-        cons = map unLoc $ (dd_cons dd)+        cons = unLoc <$> dd_cons dd         constrs = [ ( unLoc cname                     , maybeToList $ fmap unLoc $ con_doc c                     , conArgDocs c)-                  | c <- cons, cname <- getConNames c ]-        fields  = [ (foExt n, maybeToList $ fmap unLoc doc, IM.empty)-                  | Just flds <- map getRecConArgs_maybe cons-                  , (L _ (ConDeclField _ ns _ doc)) <- (unLoc flds)+                  | 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 .@@ -404,21 +430,23 @@  h98ConArgDocs :: HsConDeclH98Details GhcRn -> IntMap (HsDoc GhcRn) h98ConArgDocs con_args = case con_args of-  PrefixCon _ args   -> con_arg_docs 0 $ map (unLoc . hsScaledThing) args-  InfixCon arg1 arg2 -> con_arg_docs 0 [ unLoc (hsScaledThing arg1)-                                       , unLoc (hsScaledThing arg2) ]+  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 (unLoc . hsScaledThing) args ++ [res_ty]-  RecConGADT _ _     -> con_arg_docs 1 [res_ty]+  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 -> [HsType GhcRn] -> IntMap (HsDoc GhcRn)+con_arg_docs :: Int -> [Maybe (LHsDoc GhcRn)] -> IntMap (HsDoc GhcRn) con_arg_docs n = IM.fromList . catMaybes . zipWith f [n..]   where-    f n (HsDocTy _ _ lds) = Just (n, unLoc lds)-    f n (HsBangTy _ _ (L _ (HsDocTy _ _ lds))) = Just (n, unLoc lds)+    f n (Just lds) = Just (n, unLoc lds)     f _ _ = Nothing  isValD :: HsDecl a -> Bool@@ -427,15 +455,21 @@  -- | All the sub declarations of a class (that we handle), ordered by -- source location, with documentation attached if it exists.-classDecls :: TyClDecl GhcRn -> [(LHsDecl GhcRn, [HsDoc GhcRn])]-classDecls class_ = filterDecls . collectDocs . sortLocatedA $ decls-  where-    decls = docs ++ defs ++ sigs ++ ats-    docs  = mkDecls tcdDocs (DocD noExtField) class_-    defs  = mkDecls (bagToList . tcdMeths) (ValD noExtField) class_-    sigs  = mkDecls tcdSigs (SigD noExtField) class_-    ats   = mkDecls tcdATs (TyClD noExtField . FamDecl noExtField) class_+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@@ -480,15 +514,15 @@  -- | Take all declarations except pragmas, infix decls, rules from an 'HsGroup'. ungroup :: HsGroup GhcRn -> [LHsDecl GhcRn]-ungroup group_ =-  mkDecls (tyClGroupTyClDecls . hs_tyclds) (TyClD noExtField)  group_ ++-  mkDecls hs_derivds             (DerivD noExtField) group_ ++-  mkDecls hs_defds               (DefD noExtField)   group_ ++-  mkDecls hs_fords               (ForD noExtField)   group_ ++-  mkDecls hs_docs                (DocD noExtField)   group_ ++-  mkDecls (tyClGroupInstDecls . hs_tyclds) (InstD noExtField)  group_ ++-  mkDecls (typesigs . hs_valds)  (SigD noExtField)   group_ ++-  mkDecls (valbinds . hs_valds)  (ValD noExtField)   group_+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@@ -496,7 +530,7 @@      valbinds :: HsValBinds GhcRn -> [LHsBind GhcRn]     valbinds (XValBindsLR (NValBinds binds _)) =-      concatMap bagToList . snd . unzip $ binds+      concat . snd . unzip $ binds     valbinds ValBinds{} = error "expected XValBindsLR"  -- | Collect docs and attach them to the right declarations.@@ -534,7 +568,7 @@  -- | 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 (mapLoc filterClass))+filterClasses = map (first (fmap filterClass))   where     filterClass (TyClD x c@(ClassDecl {})) =       TyClD x $ c { tcdSigs =@@ -550,11 +584,10 @@  -- | Take a field of declarations from a data structure and create HsDecls -- using the given constructor-mkDecls :: (struct -> [GenLocated l decl])-        -> (decl -> hsDecl)-        -> struct+mkDecls :: (decl -> hsDecl)+        -> [GenLocated l decl]         -> [GenLocated l hsDecl]-mkDecls field con = map (mapLoc con) . field+mkDecls con = map (fmap con)  -- | Extracts out individual maps of documentation added via Template Haskell's -- @putDoc@.
GHC/HsToCore/Errors/Ppr.hs view
@@ -1,9 +1,13 @@+{-# 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 (isEvVar)+import GHC.Core.Predicate (isEvId) import GHC.Core.Type import GHC.Driver.Flags import GHC.Hs@@ -11,6 +15,7 @@ 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@@ -20,9 +25,10 @@   instance Diagnostic DsMessage where-  diagnosticMessage = \case-    DsUnknownMessage m-      -> diagnosticMessage m+  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@@ -77,14 +83,46 @@                StrictBinds       -> "strict bindings"          in mkSimpleDecorated $               hang (text "Top-level" <+> text desc <+> text "aren't allowed:") 2 (ppr bind)-    DsUselessSpecialiseForClassMethodSelector poly_id-      -> mkSimpleDecorated $-           text "Ignoring useless SPECIALISE pragma for NOINLINE function:" <+> quotes (ppr poly_id)-    DsUselessSpecialiseForNoInlineFunction poly_id-      -> mkSimpleDecorated $-          text "Ignoring useless SPECIALISE pragma for NOINLINE function:" <+> quotes (ppr poly_id)-    DsMultiplicityCoercionsNotSupported-      -> mkSimpleDecorated $ text "GHC bug #19517: GHC currently does not support programs using GADTs or type families to witness equality of multiplicities"+    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 = <branch1>; f G2 = <branch2>+            --   {-# SPECIALISE f :: G Int -> Int #-}+            --     -- In $sf, we get rid of dead code in <branch2>+            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@@ -105,14 +143,12 @@                        , 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 ])+                        , text "Optimised lhs:" <+> ppr lhs2 ])             pp_bndr b             | isTyVar b = text "type variable" <+> quotes (ppr b)-            | isEvVar b = text "constraint"    <+> quotes (ppr (varType b))+            | isEvId  b = text "constraint"    <+> quotes (ppr (varType b))             | otherwise = text "variable"      <+> quotes (ppr b)-    DsMultipleConForNewtype names-      -> mkSimpleDecorated $ text "Multiple constructors for newtype:" <+> pprQuotedList names     DsLazyPatCantBindVarsOfUnliftedType unlifted_bndrs       -> mkSimpleDecorated $           hang (text "A lazy (~) pattern cannot bind variables of unlifted type." $$@@ -163,6 +199,8 @@                -> 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 $@@ -203,6 +241,12 @@                           <+> 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@@ -216,14 +260,11 @@     DsNonExhaustivePatterns _ (ExhaustivityCheckType mb_flag) _ _ _       -> maybe WarningWithoutFlag WarningWithFlag mb_flag     DsTopLevelBindsNotAllowed{}                 -> ErrorWithoutFlag-    DsUselessSpecialiseForClassMethodSelector{} -> WarningWithoutFlag-    DsUselessSpecialiseForNoInlineFunction{}    -> WarningWithoutFlag-    DsMultiplicityCoercionsNotSupported{}       -> ErrorWithoutFlag+    DsUselessSpecialisePragma{}                 -> WarningWithFlag Opt_WarnUselessSpecialisations     DsOrphanRule{}                              -> WarningWithFlag Opt_WarnOrphans     DsRuleLhsTooComplicated{}                   -> WarningWithoutFlag     DsRuleIgnoredDueToConstructor{}             -> WarningWithoutFlag     DsRuleBindersNotBound{}                     -> WarningWithoutFlag-    DsMultipleConForNewtype{}                   -> ErrorWithoutFlag     DsLazyPatCantBindVarsOfUnliftedType{}       -> ErrorWithoutFlag     DsNotYetHandledByTH{}                       -> ErrorWithoutFlag     DsAggregatedViewExpressions{}               -> WarningWithoutFlag@@ -234,8 +275,9 @@     DsRecBindsNotAllowedForUnliftedTys{}        -> ErrorWithoutFlag     DsRuleMightInlineFirst{}                    -> WarningWithFlag Opt_WarnInlineRuleShadowing     DsAnotherRuleMightFireFirst{}               -> WarningWithFlag Opt_WarnInlineRuleShadowing+    DsIncompleteRecordSelector{}                -> WarningWithFlag Opt_WarnIncompleteRecordSelectors -  diagnosticHints  = \case+  diagnosticHints = \case     DsUnknownMessage m          -> diagnosticHints m     DsEmptyEnumeration          -> noHints     DsIdentitiesFound{}         -> noHints@@ -253,14 +295,11 @@     DsMaxPmCheckModelsReached{}                 -> [SuggestIncreaseMaxPmCheckModels]     DsNonExhaustivePatterns{}                   -> noHints     DsTopLevelBindsNotAllowed{}                 -> noHints-    DsUselessSpecialiseForClassMethodSelector{} -> noHints-    DsUselessSpecialiseForNoInlineFunction{}    -> noHints-    DsMultiplicityCoercionsNotSupported         -> noHints+    DsUselessSpecialisePragma{}                 -> noHints     DsOrphanRule{}                              -> noHints     DsRuleLhsTooComplicated{}                   -> noHints     DsRuleIgnoredDueToConstructor{}             -> noHints     DsRuleBindersNotBound{}                     -> noHints-    DsMultipleConForNewtype{}                   -> noHints     DsLazyPatCantBindVarsOfUnliftedType{}       -> noHints     DsNotYetHandledByTH{}                       -> noHints     DsAggregatedViewExpressions{}               -> noHints@@ -271,7 +310,10 @@     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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -294,11 +336,11 @@        2 (quotes (ppr elt_ty))  -- Print a single clause (for redundant/with-inaccessible-rhs)-pprEqn :: HsMatchContext GhcRn -> SDoc -> String -> SDoc+pprEqn :: HsMatchContextRn -> SDoc -> String -> SDoc pprEqn ctx q txt = pprContext True ctx (text txt) $ \f ->   f (q <+> matchSeparator ctx <+> text "...") -pprContext :: Bool -> HsMatchContext GhcRn -> SDoc -> ((SDoc -> SDoc) -> SDoc) -> SDoc+pprContext :: 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 ':'
GHC/HsToCore/Errors/Types.hs view
@@ -1,15 +1,18 @@+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TypeFamilies #-}  module GHC.HsToCore.Errors.Types where -import Data.Typeable- import GHC.Prelude  import GHC.Core (CoreRule, CoreExpr, RuleName) import GHC.Core.DataCon+import GHC.Core.ConLike import GHC.Core.Type-import GHC.Driver.Session+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)@@ -19,6 +22,8 @@ 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@@ -27,7 +32,7 @@ -- | Diagnostics messages emitted during desugaring. data DsMessage   -- | Simply wraps a generic 'Diagnostic' message.-  = forall a. (Diagnostic a, Typeable a) => DsUnknownMessage a+  = DsUnknownMessage (UnknownDiagnosticFor DsMessage)      {-| DsEmptyEnumeration is a warning (controlled by the -Wempty-enumerations flag) that is         emitted if an enumeration is empty.@@ -82,18 +87,18 @@    -- FIXME(adn) Use a proper type instead of 'SDoc', but unfortunately   -- 'SrcInfo' gives us an 'SDoc' to begin with.-  | DsRedundantBangPatterns !(HsMatchContext GhcRn) !SDoc+  | DsRedundantBangPatterns !HsMatchContextRn !SDoc    -- FIXME(adn) Use a proper type instead of 'SDoc', but unfortunately   -- 'SrcInfo' gives us an 'SDoc' to begin with.-  | DsOverlappingPatterns !(HsMatchContext GhcRn) !SDoc+  | DsOverlappingPatterns !HsMatchContextRn !SDoc    -- FIXME(adn) Use a proper type instead of 'SDoc'-  | DsInaccessibleRhs !(HsMatchContext GhcRn) !SDoc+  | DsInaccessibleRhs !HsMatchContextRn !SDoc    | DsMaxPmCheckModelsReached !MaxPmCheckModels -  | DsNonExhaustivePatterns !(HsMatchContext GhcRn)+  | DsNonExhaustivePatterns !HsMatchContextRn                             !ExhaustivityCheckType                             !MaxUncoveredPatterns                             [Id]@@ -101,11 +106,18 @@    | DsTopLevelBindsNotAllowed !BindsType !(HsBindLR GhcTc GhcTc) -  | DsUselessSpecialiseForClassMethodSelector !Id+    {-| DsUselessSpecialisePragma is a warning (controlled by the -Wuseless-specialisations flag)+        that is emitted for SPECIALISE pragmas that (most likely) don't do anything. -  | DsUselessSpecialiseForNoInlineFunction !Id+        Examples: -  | DsMultiplicityCoercionsNotSupported+          foo :: forall a. a -> a+          {-# SPECIALISE foo :: Int -> Int #-}+    -}+  | DsUselessSpecialisePragma+      !Name+      !Bool -- ^ is this a @SPECIALISE instance@ pragma?+      !UselessSpecialisePragmaReason    | DsOrphanRule !CoreRule @@ -122,8 +134,6 @@                           !CoreExpr                           -- ^ The optimised LHS -  | DsMultipleConForNewtype [LocatedN Name]-   | DsLazyPatCantBindVarsOfUnliftedType [Var]    | DsNotYetHandledByTH !ThRejectionReason@@ -146,13 +156,34 @@                                 !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)+  = ThAmbiguousRecordUpdates !(HsRecUpdField GhcRn GhcRn)   | ThAbstractClosedTypeFamily !(LFamilyDecl GhcRn)   | ThForeignLabel !CLabelString   | ThForeignExport !(LForeignDecl GhcRn)@@ -173,6 +204,26 @@   | 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
GHC/HsToCore/Expr.hs view
@@ -1,1118 +1,1268 @@--{-# LANGUAGE TypeFamilies #-}--{-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}-{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}--{--(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 ( addTyCs, pmcGRHSs )-import GHC.HsToCore.Errors.Types-import GHC.Types.SourceText-import GHC.Types.Name-import GHC.Types.Name.Env-import GHC.Core.FamInstEnv( topNormaliseType )-import GHC.HsToCore.Quote-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.Core.Type-import GHC.Core.TyCo.Rep-import GHC.Core.Multiplicity-import GHC.Core-import GHC.Core.Utils-import GHC.Core.Make--import GHC.Driver.Session-import GHC.Types.CostCentre-import GHC.Types.Id-import GHC.Types.Id.Make-import GHC.Types.Var.Env-import GHC.Unit.Module-import GHC.Core.ConLike-import GHC.Core.DataCon-import GHC.Builtin.Types-import GHC.Builtin.Names-import GHC.Types.Basic-import GHC.Data.Maybe-import GHC.Types.SrcLoc-import GHC.Types.Tickish-import GHC.Utils.Misc-import GHC.Data.Bag-import GHC.Utils.Outputable as Outputable-import GHC.Utils.Panic-import GHC.Utils.Panic.Plain-import GHC.Core.PatSyn-import Control.Monad--{--************************************************************************-*                                                                      *-                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-  = foldrM ds_val_bind body binds-dsValBinds (ValBinds {})       _    = panic "dsValBinds ValBindsIn"----------------------------dsIPBinds :: HsIPBinds GhcTc -> CoreExpr -> DsM CoreExpr-dsIPBinds (IPBinds ev_binds ip_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 :: LIPBind GhcTc -> CoreExpr -> DsM CoreExpr-    ds_ip_bind (L _ (IPBind n _ e)) body-      = do e' <- dsLExpr e-           return (Let (NonRec n e') body)------------------------------ caller sets location-ds_val_bind :: (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] <- 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 (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-  | anyBag (isUnliftedHsBind . unLoc) binds  -- see Note [Strict binds checks] in GHC.HsToCore.Binds-  = assert (isRec is_rec )-    errDsCoreExpr $ DsRecBindsNotAllowedForUnliftedTys (bagToList binds)---- Ordinary case for bindings; none should be unlifted-ds_val_bind (is_rec, binds) body-  = do  { massert (isRec is_rec || isSingletonBag binds)-               -- 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 (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 GHC.Tc.Solver.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 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-       ; ds_binds <- dsTcEvBinds_s ev_binds-       ; return (mkCoreLets ds_binds body2) }--dsUnliftedBind (FunBind { fun_id = L l fun-                        , fun_matches = matches-                        , fun_ext = 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 unlifted-       ; core_wrap <- dsHsWrapper co_fn  -- Can be non-identity (#21516)-       ; 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 upat = unLoc pat-             eqn = EqnInfo { eqn_pats = [upat],-                             eqn_orig = FromSource,-                             eqn_rhs = cantFailMatchResult body }-       ; var    <- selectMatchVar Many upat-                    -- `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                       *-*                                                                      *-************************************************************************--}----- | Replace the body of the function with this block to test the hsExprType--- function in GHC.Tc.Utils.Zonk:--- putSrcSpanDs loc $ do---   { core_expr <- dsExpr e---   ; massertPpr (exprType core_expr `eqType` hsExprType e)---                (ppr e <+> dcolon <+> ppr (hsExprType e) $$---                 ppr core_expr <+> dcolon <+> ppr (exprType core_expr))---   ; return core_expr }-dsLExpr :: LHsExpr GhcTc -> DsM CoreExpr-dsLExpr (L loc e) =-  putSrcSpanDsA loc $ dsExpr e--dsExpr :: HsExpr GhcTc -> DsM CoreExpr-dsExpr (HsVar    _ (L _ id))           = dsHsVar id-dsExpr (HsRecSel _ (FieldOcc id _))    = dsHsVar id-dsExpr (HsUnboundVar (HER ref _ _) _)  = dsEvTerm =<< readMutVar ref-        -- See Note [Holes] in GHC.Tc.Types.Constraint--dsExpr (HsPar _ _ e _)        = dsLExpr e-dsExpr (ExprWithTySig _ e _)  = dsLExpr e--dsExpr (HsIPVar x _)          = dataConCantHappen x--dsExpr (HsGetField x _ _)     = dataConCantHappen x-dsExpr (HsProjection x _)     = dataConCantHappen x--dsExpr (HsLit _ lit)-  = do { warnAboutOverflowedLit lit-       ; dsLit (convertLit lit) }--dsExpr (HsOverLit _ lit)-  = do { warnAboutOverflowedOverLit lit-       ; dsOverLit lit }--dsExpr e@(XExpr ext_expr_tc)-  = case ext_expr_tc of-      ExpansionExpr (HsExpanded _ b) -> dsExpr b-      WrapExpr {}                    -> dsHsWrapped e-      ConLikeTc con tvs tys          -> dsConLike con tvs tys-      -- Hpc Support-      HsTick tickish e -> do-        e' <- dsLExpr e-        return (Tick tickish e')--      -- There is a problem here. The then and else branches-      -- have no free variables, so they are open to lifting.-      -- We need someway of stopping this.-      -- This will make no difference to binary coverage-      -- (did you go here: YES or NO), but will effect accurate-      -- tick counting.--      HsBinTick ixT ixF e -> do-        e2 <- dsLExpr e-        do { assert (exprType e2 `eqType` boolTy)-            mkBinaryTickBox ixT ixF e2-          }--dsExpr (NegApp _ (L loc-                    (HsOverLit _ lit@(OverLit { ol_val = HsIntegral i})))-                neg_expr)-  = do { expr' <- putSrcSpanDsA loc $ do-          { warnAboutOverflowedOverLit-              (lit { ol_val = HsIntegral (negateIntegralLit i) })-          ; dsOverLit lit }-       ; dsSyntaxExpr neg_expr [expr'] }--dsExpr (NegApp _ expr neg_expr)-  = do { expr' <- dsLExpr expr-       ; dsSyntaxExpr neg_expr [expr'] }--dsExpr (HsLam _ a_Match)-  = uncurry mkCoreLams <$> matchWrapper LambdaExpr Nothing a_Match--dsExpr (HsLamCase _ lc_variant matches)-  = uncurry mkCoreLams <$> matchWrapper (LamCaseAlt lc_variant) Nothing matches--dsExpr e@(HsApp _ fun arg)-  = do { fun' <- dsLExpr fun-       ; arg' <- dsLExpr arg-       ; return $ mkCoreAppDs (text "HsApp" <+> ppr e) fun' arg' }--dsExpr e@(HsAppType {}) = dsHsWrapped 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.--}--dsExpr (ExplicitTuple _ tup_args boxity)-  = do { let go (lam_vars, args) (Missing (Scaled mult ty))-                    -- For every missing expression, we need-                    -- another lambda in the desugaring.-               = do { lam_var <- newSysLocalDs mult ty-                    ; return (lam_var : lam_vars, Var lam_var : args) }-             go (lam_vars, args) (Present _ expr)-                    -- Expressions that are present don't generate-                    -- lambdas, just arguments.-               = do { core_expr <- 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)-  = mkCoreUbxSum arity alt types <$> dsLExpr expr--dsExpr (HsPragE _ prag expr) =-  ds_prag_expr prag expr--dsExpr (HsCase _ discrim matches)-  = do { core_discrim <- dsLExpr discrim-       ; ([discrim_var], matching_code) <- matchWrapper CaseAlt (Just [discrim]) matches-       ; 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 _ ctx@DoExpr{}      (L _ stmts)) = dsDo ctx stmts-dsExpr (HsDo _ ctx@GhciStmtCtxt  (L _ stmts)) = dsDo ctx stmts-dsExpr (HsDo _ ctx@MDoExpr{}     (L _ stmts)) = dsDo ctx stmts-dsExpr (HsDo _ MonadComp     (L _ stmts)) = dsMonadComp stmts--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)-  | null alts-  = mkErrorExpr--  | otherwise-  = 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")--{--\noindent-\underline{\bf Various data construction things}-             ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--}--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] }--{--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-    let (line, col) = case locA loc of-           RealSrcSpan r _ ->-                            ( srcLocLine $ realSrcSpanStart r-                            , srcLocCol  $ realSrcSpanStart r-                            )-           _             -> (0, 0)-        srcLoc = mkCoreConApps (tupleDataCon Boxed 2)-                     [ Type intTy              , Type intTy-                     , mkIntExprInt platform line, mkIntExprInt platform col-                     ]--    putSrcSpanDsA 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  = L _ con_like-                  , rcon_flds = rbinds-                  , rcon_ext  = con_expr })-  = 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 "dsExpr:RecordCon" (map scaledThing 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-     MkT :: { foo :: a } -> T a Int--   upd :: T s t -> s -> T s t-   upd z y = z { foo = y}--We need to get this:-   $WMkT :: a -> T a Int-   MkT   :: (b ~# Int) => a -> T a b--   upd = /\s t. \(z::T s t) (y::s) ->-         case z of-            MkT (co :: t ~# Int) _ -> $WMkT @s y |> T (Refl s) (Sym co)--Note the final cast-   T (Refl s) (Sym co) :: T s Int ~ T s t-which uses co, bound by the GADT match.  This is the wrap_co coercion-in wrapped_rhs. How do we produce it?--* Start with raw materials-    tc, the tycon:                                       T-    univ_tvs, the universally quantified tyvars of MkT:  a,b-  NB: these are in 1-1 correspondence with the tyvars of tc--* Form univ_cos, a coercion for each of tc's args: (Refl s) (Sym co)-  We replaced-     a  by  (Refl s)    since 's' instantiates 'a'-     b  by  (Sym co)   since 'b' is in the data-con's EqSpec--* Then form the coercion T (Refl s) (Sym co)--It gets more complicated when data families are involved (#18809).-Consider-    data family F x-    data instance F (a,b) where-      MkF :: { foo :: Int } -> F (Int,b)--    bar :: F (s,t) -> Int -> F (s,t)-    bar z y = z { foo = y}--We have-    data R:FPair a b where-      MkF :: { foo :: Int } -> R:FPair Int b--    $WMkF :: Int -> F (Int,b)-    MkF :: forall a b. (a ~# Int) => Int -> R:FPair a b--    bar :: F (s,t) -> Int -> F (s,t)-    bar = /\s t. \(z::F (s,t)) \(y::Int) ->-         case z |> co1 of-            MkF (co2::s ~# Int) _ -> $WMkF @t y |> co3--(Side note: here (z |> co1) is built by typechecking the scrutinee, so-we ignore it here.  In general the scrutinee is an arbitrary expression.)--The question is: what is co3, the cast for the RHS?-      co3 :: F (Int,t) ~ F (s,t)-Again, we can construct it using co2, bound by the GADT match.-We do /exactly/ the same as the non-family case up to building-univ_cos.  But that gives us-     rep_tc:   R:FPair-     univ_cos: (Sym co2)   (Refl t)-But then we use mkTcFamilyTyConAppCo to "lift" this to the coercion-we want, namely-     F (Sym co2, Refl t) :: F (Int,t) ~ F (s,t)---}--dsExpr RecordUpd { rupd_flds = Right _} =-  -- Not possible due to elimination in the renamer. See Note-  -- [Handling overloaded and rebindable constructs]-  panic "The impossible happened"-dsExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = Left fields-                       , rupd_ext = RecordUpdTc-                           { 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-  = assertPpr (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 (Just [record_expr]) -- See Note [Scrutinee in Record updates]-                                      (MG { mg_alts = noLocA alts-                                          , mg_ext = MatchGroupTc [unrestricted in_ty] out_ty-                                          , mg_origin = FromSource-                                          })-                                     -- 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 GhcTc -> 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 #2735-    ds_field (L _ rec_field)-      = do { rhs <- dsLExpr (hfbRHS rec_field)-           ; let fld_id = unLoc (hsRecUpdFieldId rec_field)-           ; lcl_id <- newSysLocalDs (idMult fld_id) (idType fld_id)-           ; return (idName fld_id, lcl_id, rhs) }--    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-                 arg_tys' = map (scaleScaled Many) arg_tys-                   -- Record updates consume the source record with multiplicity-                   -- Many. Therefore all the fields need to be scaled thus.-                 user_tvs  = binderVars $ conLikeUserTyVarBinders con--                 in_subst :: TCvSubst-                 in_subst  = extendTCvInScopeList (zipTvSubst univ_tvs in_inst_tys) ex_tvs-                   -- The in_subst clones the universally quantified type-                   -- variables. It will be used to substitute into types that-                   -- contain existentials, however, so make sure to extend the-                   -- in-scope set with ex_tvs (#20278).--                 out_tv_env :: TvSubstEnv-                 out_tv_env = zipTyEnv univ_tvs out_inst_tys--                -- I'm not bothering to clone the ex_tvs-           ; eqs_vars   <- mapM newPredVarDs (substTheta in_subst (eqSpecPreds eq_spec))-           ; theta_vars <- mapM newPredVarDs (substTheta in_subst prov_theta)-           ; arg_ids    <- newSysLocalsDs (substScaledTysUnchecked in_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 = noLocA $ mkHsWrap wrap (mkConLikeTc con)-                        -- Reconstruct with the WrapId so that unpacking happens-                 wrap = mkWpEvVarApps theta_vars                                <.>-                        dict_req_wrap                                           <.>-                        mkWpTyApps    [ lookupVarEnv out_tv_env tv-                                          `orElse` mkTyVarTy tv-                                      | tv <- user_tvs ]-                          -- Be sure to use user_tvs (which may be ordered-                          -- differently than `univ_tvs ++ ex_tvs) above.-                          -- See Note [DataCon user type variable binders]-                          -- in GHC.Core.DataCon.-                 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-                      | null eq_spec -> rhs-                      | otherwise    -> mkLHsWrap (mkWpCastN wrap_co) rhs-                                     -- This wrap is the punchline: Note [Update for GADTs]-                      where-                        rep_tc   = dataConTyCon data_con-                        wrap_co  = mkTcFamilyTyConAppCo rep_tc univ_cos-                        univ_cos = zipWithEqual "dsExpr:upd" mk_univ_co univ_tvs out_inst_tys--                        mk_univ_co :: TyVar   -- Universal tyvar from the DataCon-                                   -> Type    -- Corresponding instantiating type-                                   -> Coercion-                        mk_univ_co univ_tv inst_ty-                          = case lookupVarEnv eq_spec_env univ_tv of-                               Just co -> co-                               Nothing -> mkTcNomReflCo inst_ty--                        eq_spec_env :: VarEnv Coercion-                        eq_spec_env = mkVarEnv [ (eqSpecTyVar spec, mkTcSymCo (mkTcCoVarCo eqs_var))-                                               | (spec,eqs_var) <- zipEqual "dsExpr:upd2" eq_spec eqs_vars ]--                    -- eq_spec is always null for a PatSynCon-                    PatSynCon _ -> rhs---                 req_wrap = dict_req_wrap <.> mkWpTyApps in_inst_tys--                 pat = noLocA $ ConPat { pat_con = noLocA con-                                       , pat_args = PrefixCon [] $ map nlVarPat arg_ids-                                       , pat_con_ext = ConPatTc-                                         { cpt_tvs = ex_tvs-                                         , cpt_dicts = eqs_vars ++ theta_vars-                                         , cpt_binds = emptyTcEvBinds-                                         , cpt_arg_tys = in_inst_tys-                                         , cpt_wrap = req_wrap-                                         }-                                       }-           ; return (mkSimpleMatch RecUpd [pat] wrapped_rhs) }--{- Note [Scrutinee in Record updates]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider #17783:--  data PartialRec = No-                  | Yes { a :: Int, b :: Bool }-  update No = No-  update r@(Yes {}) = r { b = False }--In the context of pattern-match checking, the occurrence of @r@ in-@r { b = False }@ is to be treated as if it was a scrutinee, as can be seen by-the following desugaring:--  r { b = False } ==> case r of Yes a b -> Yes a False--Thus, we pass @r@ as the scrutinee expression to @matchWrapper@ above.--}---- 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   (HsBracketTc q _ hs_wrapper ps) _) = dsBracket hs_wrapper q ps-dsExpr (HsUntypedBracket (HsBracketTc q _ hs_wrapper ps) _) = dsBracket hs_wrapper q ps-dsExpr (HsSpliceE _ s) = pprPanic "dsExpr:splice" (ppr s)---- Arrow notation extension-dsExpr (HsProc _ pat cmd) = dsProcExpr pat cmd----- HsSyn constructs that just shouldn't be here, because--- the renamer removed them.  See GHC.Rename.Expr.--- Note [Handling overloaded and rebindable constructs]-dsExpr (HsOverLabel x _) = dataConCantHappen x-dsExpr (OpApp x _ _ _)   = dataConCantHappen x-dsExpr (SectionL x _ _)  = dataConCantHappen x-dsExpr (SectionR x _ _)  = dataConCantHappen x--ds_prag_expr :: HsPragE GhcTc -> LHsExpr GhcTc -> DsM CoreExpr-ds_prag_expr (HsPragSCC _ _ cc) expr = do-    dflags <- getDynFlags-    if sccProfilingEnabled dflags && gopt Opt_ProfManualCcs dflags-      then do-        mod_name <- getModule-        count <- goptM Opt_ProfCountEntries-        let nm = sl_fs cc-        flavour <- ExprCC <$> getCCIndexDsM nm-        Tick (ProfNote (mkUserCC nm mod_name (getLocA expr) flavour) count True)-               <$> dsLExpr expr-      else dsLExpr expr---------------------------------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-       ; core_arg_wraps <- mapM dsHsWrapper arg_wraps-       ; core_res_wrap  <- dsHsWrapper res_wrap-       ; let wrapped_args = zipWithEqual "dsSyntaxExpr" ($) 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 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 -> [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] -> DsM CoreExpr-dsDo ctx stmts-  = 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-           ; 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 xbs pat rhs) stmts-      = do  { body     <- goL stmts-            ; rhs'     <- dsLExpr rhs-            ; var   <- selectSimpleMatchVarL (xbstc_boundResultMult xbs) pat-            ; match <- matchSinglePatVar var Nothing (StmtCtxt (HsDoStmt ctx)) pat-                         (xbstc_boundResultType xbs) (cantFailMatchResult body)-            ; match_code <- dsHandleMonadicFailure ctx pat match (xbstc_failOp xbs)-            ; dsSyntaxExpr (xbstc_bindOp xbs) [rhs', Lam var match_code] }--    go _ (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)]))--           ; rhss' <- sequence rhss--           ; body' <- dsLExpr $ noLocA $ HsDo body_ty ctx (noLocA stmts)--           ; let match_args (pat, fail_op) (vs,body)-                   = do { var   <- selectSimpleMatchVarL Many pat-                        ; match <- matchSinglePatVar var Nothing (StmtCtxt (HsDoStmt ctx)) pat-                                   body_ty (cantFailMatchResult body)-                        ; match_code <- dsHandleMonadicFailure ctx pat match fail_op-                        ; return (var:vs, match_code)-                        }--           ; (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 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 = Many-            , 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]-        mfix_arg     = noLocA $ HsLam noExtField-                           (MG { mg_alts = noLocA [mkSimpleMatch-                                                    LambdaExpr-                                                    [mfix_pat] body]-                               , mg_ext = MatchGroupTc [unrestricted tup_ty] body_ty-                               , mg_origin = Generated })-        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 _ (ParStmt   {}) _ = panic "dsDo ParStmt"-    go _ (TransStmt {}) _ = panic "dsDo TransStmt"--{--************************************************************************-*                                                                      *-   Desugaring Variables-*                                                                      *-************************************************************************--}--dsHsVar :: Id -> DsM CoreExpr--- We could just call dsHsUnwrapped; but this is a short-cut--- for the very common case of a variable with no wrapper.-dsHsVar var-  = return (varToCoreExpr var) -- See Note [Desugaring vars]--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) (Var voidPrimId)-                 else Var builder_id) }-  | otherwise-  = pprPanic "dsConLike" (ppr ps)--dsConLike :: ConLike -> [TcTyVar] -> [Scaled Type] -> DsM CoreExpr--- This function desugars ConLikeTc--- See Note [Typechecking data constructors] in GHC.Tc.Gen.Head---     for what is going on here-dsConLike con tvs tys-  = do { ds_con <- dsHsConLike con-       ; ids    <- newSysLocalsDs tys-                   -- newSysLocalDs: /can/ be lev-poly; see-       ; return (mkLams tvs $-                 mkLams ids $-                 ds_con `mkTyApps` mkTyVarTys tvs-                        `mkVarApps` drop_stupid ids) }-  where--    drop_stupid = dropList (conLikeStupidTheta con)-    -- drop_stupid: see Note [Instantiating stupid theta]-    --              in GHC.Tc.Gen.Head--{--************************************************************************-*                                                                      *-\subsection{Errors and contexts}-*                                                                      *-************************************************************************--}---- Warn about certain types of values discarded in monadic bindings (#3263)-warnDiscardedDoBindings :: LHsExpr GhcTc -> 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 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-           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 () } }--  | otherwise   -- RHS does have type of form (m ty), which is weird-  = return ()   -- but at least this warning is irrelevant--{--************************************************************************-*                                                                      *-            dsHsWrapped-*                                                                      *-************************************************************************--}---------------------------------dsHsWrapped :: HsExpr GhcTc -> DsM CoreExpr-dsHsWrapped orig_hs_expr-  = go idHsWrapper orig_hs_expr-  where-    go wrap (HsPar _ _ (L _ hs_e) _)-       = go wrap hs_e-    go wrap1 (XExpr (WrapExpr (HsWrap wrap2 hs_e)))-       = go (wrap1 <.> wrap2) hs_e-    go wrap (HsAppType ty (L _ hs_e) _)-       = go (wrap <.> WpTyApp ty) hs_e--    go wrap (HsVar _ (L _ var))-      = do { wrap' <- dsHsWrapper wrap-           ; let expr = wrap' (varToCoreExpr var)-                 ty   = exprType expr-           ; dflags <- getDynFlags-           ; warnAboutIdentities dflags var ty-           ; return expr }--    go wrap hs_e-       = do { wrap' <- dsHsWrapper wrap-            ; addTyCs FromSource (hsWrapDictBinders wrap) $-              do { e <- dsExpr hs_e-                 ; return (wrap' e) } }+{-# 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 <tvs>. <cxt> => 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 () } }
+ GHC/HsToCore/Foreign/C.hs view
@@ -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'' <arg info> 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)
GHC/HsToCore/Foreign/Call.hs view
@@ -22,30 +22,35 @@ import GHC.Prelude  import GHC.Core--import GHC.HsToCore.Monad import GHC.Core.Utils import GHC.Core.Make-import GHC.Types.SourceText-import GHC.Types.Id.Make-import GHC.Types.ForeignCall import GHC.Core.DataCon-import GHC.HsToCore.Utils--import GHC.Tc.Utils.TcType import GHC.Core.Type import GHC.Core.Multiplicity import GHC.Core.Coercion-import GHC.Builtin.Types.Prim import GHC.Core.TyCon-import GHC.Builtin.Types+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.Session++import GHC.Driver.DynFlags+ import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Utils.Panic.Plain  import Data.Maybe @@ -138,10 +143,12 @@  unboxArg arg   -- Primitive types: nothing to unbox-  | isPrimitiveType arg_ty+  | isPrimitiveType arg_ty ||+    -- Same for (# #)+    (isUnboxedTupleType arg_ty && typePrimRep1 arg_ty == VoidRep)   = return (arg, \body -> body) -  -- Recursive newtypes+  -- Possibly-recursive newtypes   | Just(co, _rep_ty) <- topNormaliseNewType_maybe arg_ty   = unboxArg (mkCastDs arg co) @@ -150,7 +157,7 @@     tc `hasKey` boolTyConKey   = do dflags <- getDynFlags        let platform = targetPlatform dflags-       prim_arg <- newSysLocalDs Many intPrimTy+       prim_arg <- newSysLocalMDs intPrimTy        return (Var prim_arg,               \ body -> Case (mkIfThenElse arg (mkIntLit platform 1) (mkIntLit platform 0))                              prim_arg@@ -162,8 +169,8 @@   | is_product_type && data_con_arity == 1   = assertPpr (isUnliftedType data_con_arg_ty1) (pprType arg_ty) $                         -- Typechecker ensures this-    do case_bndr <- newSysLocalDs Many arg_ty-       prim_arg <- newSysLocalDs Many data_con_arg_ty1+    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]               )@@ -173,11 +180,11 @@   --    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 &&+    data_con_arity == 3,+    Just arg3_tycon <- maybe_arg3_tycon,     (arg3_tycon ==  byteArrayPrimTyCon ||      arg3_tycon ==  mutableByteArrayPrimTyCon)-  = do case_bndr <- newSysLocalDs Many arg_ty+  = 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]@@ -197,7 +204,6 @@      (_ : _ : 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)@@ -223,14 +229,11 @@         -- 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-                = mkCoreUbxTup-                    [realWorldStatePrimTy, io_res_ty]-                    [state, anss]+        ; let return_result state anss = mkCoreUnboxedTuple [state, anss]          ; (ccall_res_ty, the_alt) <- mk_alt return_result res -        ; state_id <- newSysLocalDs Many realWorldStatePrimTy+        ; state_id <- newSysLocalMDs realWorldStatePrimTy         ; let io_data_con = head (tyConDataCons io_tycon)               toIOCon     = dataConWrapId io_data_con @@ -266,7 +269,7 @@        -> DsM (Type, CoreAlt) mk_alt return_result (Nothing, wrap_result)   = do -- The ccall returns ()-       state_id <- newSysLocalDs Many realWorldStatePrimTy+       state_id <- newSysLocalMDs realWorldStatePrimTy        let              the_rhs = return_result (Var state_id)                                      (wrap_result (panic "boxResult"))@@ -280,8 +283,8 @@   = -- 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 <- newSysLocalDs Many prim_res_ty-       ; state_id <- newSysLocalDs Many realWorldStatePrimTy+    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]@@ -338,8 +341,10 @@   -- 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 <- tyConSingleAlgDataCon_maybe tycon  -- One constructor-  , null (dataConExTyCoVars data_con)                   -- no existentials+  , 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)
GHC/HsToCore/Foreign/Decl.hs view
@@ -2,68 +2,44 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}- {- (c) The University of Glasgow 2006 (c) The AQUA Project, Glasgow University, 1998---Desugaring foreign declarations (see also GHC.HsToCore.Foreign.Call). -} -module GHC.HsToCore.Foreign.Decl ( dsForeigns ) where+-- | 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.Core--import GHC.HsToCore.Foreign.Call+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.HsToCore.Types (ds_next_wrapper_num)  import GHC.Hs-import GHC.Core.DataCon-import GHC.Core.Unfold.Make import GHC.Types.Id-import GHC.Types.Literal import GHC.Types.ForeignStubs-import GHC.Types.SourceText import GHC.Unit.Module-import GHC.Types.Name-import GHC.Core.Type-import GHC.Types.RepType-import GHC.Core.TyCon import GHC.Core.Coercion-import GHC.Core.Multiplicity-import GHC.Tc.Utils.Env-import GHC.Tc.Utils.TcType -import GHC.Cmm.Expr-import GHC.Cmm.Utils import GHC.Cmm.CLabel-import GHC.Driver.Ppr import GHC.Types.ForeignCall-import GHC.Builtin.Types-import GHC.Builtin.Types.Prim-import GHC.Builtin.Names-import GHC.Types.Basic import GHC.Types.SrcLoc import GHC.Utils.Outputable-import GHC.Data.FastString-import GHC.Driver.Session-import GHC.Driver.Config+import GHC.Driver.DynFlags import GHC.Platform import GHC.Data.OrdList-import GHC.Utils.Panic-import GHC.Utils.Panic.Plain import GHC.Driver.Hooks-import GHC.Utils.Encoding -import Data.Maybe-import Data.List (unzip4, nub)+import Data.List (unzip4)  {- Desugaring of @foreign@ declarations is naturally split up into@@ -80,9 +56,6 @@ so we reuse the desugaring code in @GHC.HsToCore.Foreign.Call@ to deal with these. -} -type Binding = (Id, CoreExpr) -- No rec/nonrec structure;-                              -- the occurrence analyser will sort it all out- dsForeigns :: [LForeignDecl GhcTc] -> DsM (ForeignStubs, OrdList Binding) dsForeigns fos = do     hooks <- getHooks@@ -114,16 +87,16 @@    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) <- dsFImport id' co spec+      (bs, h, c, ids) <- dsFImport id' co spec       traceIf (text "fi end" <+> ppr id)-      return (h, c, [], bs)+      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, _, _) <- dsFExport id co ext_nm cconv False-      return (h, c, [id], [])+                          , 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)  {- ************************************************************************@@ -153,186 +126,21 @@  dsFImport :: Id           -> Coercion-          -> ForeignImport-          -> DsM ([Binding], CHeader, CStub)-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], CHeader, CStub)-dsCImport id co (CLabel cid) cconv _ _ = do-   dflags <- getDynFlags-   let ty  = coercionLKind co-       platform = targetPlatform dflags-       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 stdcall_info fod))-        rhs' = Cast rhs co-        stdcall_info = fun_type_arg_stdcall_info platform cconv ty-    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 _ _-  = 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 :: Platform -> CCallConv -> Type -> Maybe Int-fun_type_arg_stdcall_info platform 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 platform . 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)], CHeader, CStub)-dsFCall fn_id co fcall mDeclHeader = do-    let-        ty                   = coercionLKind co-        (tv_bndrs, rho)      = tcSplitForAllTyVarBinders ty-        (arg_tys, io_res_ty) = tcSplitFunTys rho--    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 = 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 (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 Many 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-                                                (length args)-                                                simpl_opts-                                                wrap_rhs'--    return ([(work_id, work_rhs), (fn_id_w_inl, wrap_rhs')], mempty, CStub 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)], 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)+          -> 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, [])  {- ************************************************************************@@ -365,327 +173,22 @@           -> DsM ( CHeader      -- contents of Module_stub.h                  , CStub        -- contents of Module_stub.c                  , String       -- string describing type to pass to createAdj.-                 , Int          -- size of args to stub function+                 , [Id]         -- function closures to be registered as GC roots+                 , [Binding]    -- additional bindings used by desugared foreign export                  )--dsFExport fn_id co ext_name cconv isDyn = do-    let-       ty                     = coercionRKind 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'' <arg info> 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}--}--dsFExportDynamic :: Id-                 -> Coercion-                 -> CCallConv-                 -> DsM ([Binding], CHeader, CStub)-dsFExportDynamic id co0 cconv = do-    mod <- getModule-    dflags <- getDynFlags-    let platform = targetPlatform dflags-    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_mult 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 <- newSysLocalDs Many 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      = [ mkIntLit platform (fromIntegral (ccallConvToInt cconv))-                        , Var stbl_value-                        , Lit (LitLabel fe_nm mb_sz_args IsFunction)-                        , Lit (mkLitString 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                       = coercionLKind co0-  (tvs,sans_foralls)       = tcSplitForAllInvisTyVars ty-  ([Scaled arg_mult 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-               -> (CHeader,-                   CStub,-                   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-   , CStub body [] []-   , type_string,-    sum [ widthInBytes (typeWidth rep) | (_,_,_,rep) <- aug_arg_info] -- all the args-         -- NB. the calculation here isn't strictly speaking correct.-         -- We have a primitive Haskell type (eg. Int#, Double#), and-         -- 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-  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 = text ('a':show 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+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], [])  -  -- 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 <>-                    text "(HaskellObj)"-                 <> (if is_IO_res_ty-                      then text "runIO_closure"-                      else text "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-     ]- foreignExportsInitialiser :: Platform -> Module -> [Id] -> CStub foreignExportsInitialiser _        _   []     = mempty foreignExportsInitialiser platform mod hs_fns =@@ -701,7 +204,7 @@    -- See Note [Tracking foreign exports] in rts/ForeignExports.c    initializerCStub platform fn_nm list_decl fn_body   where-    fn_nm       = mkInitializerStubLabel mod "fexports"+    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@@ -715,141 +218,3 @@      closure_ptr :: Id -> SDoc     closure_ptr fn = text "(StgPtr) &" <> ppr fn <> text "_closure"---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 "GHC.HsToCore.Foreign.Decl.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)-               | cmmEqType_ignoring_ptrhood rep b64 = 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)---- 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 "GHC.HsToCore.Foreign.Decl.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 typePrimRep1 (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')
+ GHC/HsToCore/Foreign/JavaScript.hs view
@@ -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
+ GHC/HsToCore/Foreign/Prim.hs view
@@ -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)
+ GHC/HsToCore/Foreign/Utils.hs view
@@ -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
+ GHC/HsToCore/Foreign/Wasm.hs view
@@ -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);"+    ]
GHC/HsToCore/GuardedRHSs.hs view
@@ -24,14 +24,12 @@ import GHC.HsToCore.Utils import GHC.HsToCore.Pmc.Types ( Nablas ) import GHC.Core.Type ( Type )-import GHC.Utils.Misc import GHC.Types.SrcLoc import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Utils.Panic.Plain import GHC.Core.Multiplicity-import Control.Monad ( zipWithM )-import Data.List.NonEmpty ( NonEmpty, toList )+import Data.List.NonEmpty ( NonEmpty )+import qualified GHC.Data.List.NonEmpty as NE  {- @dsGuarded@ is used for GRHSs.@@ -55,7 +53,7 @@  -- In contrast, @dsGRHSs@ produces a @MatchResult CoreExpr@. -dsGRHSs :: HsMatchContext GhcRn+dsGRHSs :: HsMatchContextRn         -> GRHSs GhcTc (LHsExpr GhcTc) -- ^ Guarded RHSs         -> Type                        -- ^ Type of RHS         -> NonEmpty Nablas             -- ^ Refined pattern match checking@@ -63,9 +61,8 @@                                        --   one for each GRHS.         -> DsM (MatchResult CoreExpr) dsGRHSs hs_ctx (GRHSs _ grhss binds) rhs_ty rhss_nablas-  = assert (notNull grhss) $-    do { match_results <- assert (length grhss == length rhss_nablas) $-                          zipWithM (dsGRHS hs_ctx rhs_ty) (toList rhss_nablas) grhss+  = 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@@ -76,10 +73,11 @@                              -- NB: nested dsLet inside matchResult        ; return match_result2 } -dsGRHS :: HsMatchContext GhcRn -> Type -> Nablas -> LGRHS GhcTc (LHsExpr GhcTc)+dsGRHS :: HsMatchContextRn -> Type -> Nablas -> LGRHS GhcTc (LHsExpr GhcTc)        -> DsM (MatchResult CoreExpr) dsGRHS hs_ctx rhs_ty rhs_nablas (L _ (GRHS _ guards rhs))-  = matchGuards (map unLoc guards) (PatGuard hs_ctx) rhs_nablas rhs rhs_ty+  = updPmNablas rhs_nablas $+      matchGuards (map unLoc guards) hs_ctx rhs rhs_ty  {- ************************************************************************@@ -90,8 +88,7 @@ -}  matchGuards :: [GuardStmt GhcTc]     -- Guard-            -> HsStmtContext GhcRn   -- Context-            -> Nablas                -- The RHS's covered set for PmCheck+            -> HsMatchContextRn      -- Context             -> LHsExpr GhcTc         -- RHS             -> Type                  -- Type of RHS of guard             -> DsM (MatchResult CoreExpr)@@ -99,8 +96,8 @@ -- 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 [] _ nablas rhs _-  = do  { core_rhs <- updPmNablas nablas (dsLExpr rhs)+matchGuards [] _ rhs _+  = do  { core_rhs <- dsLExpr rhs         ; return (cantFailMatchResult core_rhs) }          -- BodyStmts must be guards@@ -110,41 +107,50 @@         -- 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 nablas rhs rhs_ty+matchGuards (BodyStmt _ e _ _ : stmts) ctx rhs rhs_ty   | Just addTicks <- isTrueLHsExpr e = do-    match_result <- matchGuards stmts ctx nablas rhs rhs_ty+    match_result <- matchGuards stmts ctx rhs rhs_ty     return (adjustMatchResultDs addTicks match_result)-matchGuards (BodyStmt _ expr _ _ : stmts) ctx nablas rhs rhs_ty = do-    match_result <- matchGuards stmts ctx nablas rhs rhs_ty+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 nablas rhs rhs_ty = do-    match_result <- matchGuards stmts ctx nablas rhs rhs_ty-    return (adjustMatchResultDs (dsLocalBinds binds) 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 nablas rhs rhs_ty = do+matchGuards (BindStmt _ pat bind_rhs : stmts) ctx rhs rhs_ty = do     let upat = unLoc pat-    match_var <- selectMatchVar Many upat-       -- We only allow unrestricted patterns in guard, hence the `Many`+    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 nablas rhs rhs_ty+    match_result <- matchGuards stmts ctx rhs rhs_ty     core_rhs <- dsLExpr bind_rhs-    match_result' <- matchSinglePatVar match_var (Just core_rhs) (StmtCtxt ctx)-                                       pat rhs_ty match_result-    pure $ bindNonRec match_var core_rhs <$> match_result'+    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 (ApplicativeStmt {} : _) _ _ _ _ =+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"  {-
GHC/HsToCore/ListComp.hs view
@@ -1,4 +1,4 @@-+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE TypeFamilies   #-}  {-@@ -23,7 +23,7 @@ import GHC.HsToCore.Monad          -- the monadery used in the desugarer import GHC.HsToCore.Utils -import GHC.Driver.Session+import GHC.Driver.DynFlags import GHC.Core.Utils import GHC.Types.Id import GHC.Core.Type@@ -33,10 +33,11 @@ import GHC.Types.SrcLoc import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Utils.Panic.Plain import GHC.Tc.Utils.TcType import GHC.Data.List.SetOps( getNth ) +import 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@@ -244,13 +245,13 @@   = 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+       ; (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) exps))+       ; deBindComp pat (Let (Rec [(zip_fn, zip_rhs)]) (mkApps (Var zip_fn) (toList exps)))                     quals list }   where-        bndrs_s = [bs | ParStmtBlock _ _ bs _ <- stmtss_w_bndrs]+        bndrs_s = [bs | ParStmtBlock _ _ bs _ <- toList stmtss_w_bndrs]          -- pat is the pattern ((x1,..,xn), (y1,..,ym)) in the example above         pat  = mkBigLHsPatTupId pats@@ -258,7 +259,7 @@  deListComp (RecStmt {} : _) _ = panic "deListComp RecStmt" -deListComp (ApplicativeStmt {} : _) _ =+deListComp (XStmtLR ApplicativeStmt {} : _) _ =   panic "deListComp ApplicativeStmt"  deBindComp :: LPat GhcTc@@ -285,7 +286,7 @@         letrec_body = App (Var h) core_list1      rest_expr <- deListComp quals core_fail-    core_match <- matchSimply (Var u2) (StmtCtxt (HsDoStmt ListComp)) pat rest_expr core_fail+    core_match <- matchSimply (Var u2) (StmtCtxt (HsDoStmt ListComp)) ManyTy pat rest_expr core_fail      let         rhs = Lam u1 $@@ -353,7 +354,7 @@  dfListComp _ _ (ParStmt {} : _) = panic "dfListComp ParStmt" dfListComp _ _ (RecStmt {} : _) = panic "dfListComp RecStmt"-dfListComp _ _ (ApplicativeStmt {} : _) =+dfListComp _ _ (XStmtLR ApplicativeStmt {} : _) =   panic "dfListComp ApplicativeStmt"  dfBindComp :: Id -> Id             -- 'c' and 'n'@@ -366,14 +367,14 @@     let b_ty   = idType n_id      -- create some new local id's-    b <- newSysLocalDs Many b_ty-    x <- newSysLocalDs Many x_ty+    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))+    core_expr <- matchSimply (Var x) (StmtCtxt (HsDoStmt ListComp)) ManyTy                 pat core_rest (Var b)      -- now build the outermost foldr, and return@@ -397,11 +398,11 @@ --                              (a2:as'2) -> (a1, a2) : zip as'1 as'2)]  mkZipBind elt_tys = do-    ass  <- mapM (newSysLocalDs Many)  elt_list_tys-    as'  <- mapM (newSysLocalDs Many)  elt_tys-    as's <- mapM (newSysLocalDs Many)  elt_list_tys+    ass  <- newSysLocalsMDs elt_list_tys+    as'  <- newSysLocalsMDs elt_tys+    as's <- newSysLocalsMDs elt_list_tys -    zip_fn <- newSysLocalDs Many zip_fn_ty+    zip_fn <- newSysLocalMDs zip_fn_ty      let inner_rhs = mkConsExpr elt_tuple_ty                         (mkBigCoreVarTup as')@@ -436,23 +437,21 @@ mkUnzipBind ThenForm _  = return Nothing    -- No unzipping for ThenForm mkUnzipBind _ elt_tys-  = do { ax  <- newSysLocalDs Many elt_tuple_ty-       ; axs <- newSysLocalDs Many elt_list_tuple_ty-       ; ys  <- newSysLocalDs Many elt_tuple_list_ty-       ; xs  <- mapM (newSysLocalDs Many) elt_tys-       ; xss <- mapM (newSysLocalDs Many) elt_list_tys--       ; unzip_fn <- newSysLocalDs Many unzip_fn_ty+  = 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 -       ; [us1, us2] <- sequence [newUniqueSupply, newUniqueSupply]+       ; 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 = 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+       ; 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)) }@@ -543,15 +542,11 @@        -- 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'  <- newSysLocalDs Many n_tup_ty'-       ; tup_n_var'  <- newSysLocalDs Many tup_n_ty'+       ; n_tup_var'  <- newSysLocalMDs n_tup_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'+       ; body'       <- mkBigTupleCase to_bndrs body tup_n_expr'         ; dsSyntaxExpr bind_op [rhs', Lam n_tup_var' body'] } @@ -570,8 +565,11 @@  = 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]+       ; 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@@ -587,17 +585,17 @@        = do { exp <- dsInnerMonadComp stmts bndrs return_op             ; return (exp, mkBigCoreVarTupTy bndrs) } -dsMcStmt stmt _ = pprPanic "dsMcStmt: unexpected stmt" (ppr stmt)-+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 { us <- newUniqueSupply-       ; tup_id <- newSysLocalDs Many (mkBigCoreVarTupTy ids)-       ; return (Lam tup_id $ mkTupleCase us ids body tup_id (Var tup_id)) }+  = 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`@@ -609,11 +607,13 @@              -> [ExprLStmt GhcTc]              -> DsM CoreExpr dsMcBindStmt pat rhs' bind_op fail_op res1_ty stmts-  = do  { body     <- dsMcStmts stmts-        ; var      <- selectSimpleMatchVarL Many pat+  = do  { var   <- selectSimpleMatchVarL ManyTy pat         ; match <- matchSinglePatVar var Nothing (StmtCtxt (HsDoStmt (DoExpr Nothing))) pat-                                  res1_ty (cantFailMatchResult body)-        ; match_code <- dsHandleMonadicFailure MonadComp pat match fail_op+                      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@@ -651,15 +651,15 @@  mkMcUnzipM _ fmap_op ys elt_tys   = do { fmap_op' <- dsExpr fmap_op-       ; xs       <- mapM (newSysLocalDs Many) elt_tys+       ; xs       <- newSysLocalsMDs elt_tys        ; let tup_ty = mkBigCoreTupTy elt_tys-       ; tup_xs   <- newSysLocalDs Many tup_ty+       ; 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 $-                        mkTupleSelector xs (getNth xs n) tup_xs (Var tup_xs)+                        mkBigTupleSelector xs (getNth xs n) tup_xs (Var tup_xs)         ; return (mkBigCoreTup (map mk_elt [0..length elt_tys - 1])) }
GHC/HsToCore/Match.hs view
@@ -1,4 +1,5 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MonadComprehensions #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE PatternSynonyms #-}@@ -6,7 +7,6 @@ {-# LANGUAGE ViewPatterns #-}  {-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}-{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}  {- (c) The University of Glasgow 2006@@ -27,49 +27,58 @@  import {-#SOURCE#-} GHC.HsToCore.Expr (dsExpr) -import GHC.Types.Basic ( Origin(..), isGenerated, Boxity(..) )+import GHC.Types.Basic+ import GHC.Types.SourceText-import GHC.Driver.Session+    ( 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.Types ( Nablas, initNablas )-import GHC.Core-import GHC.Types.Literal-import GHC.Core.Utils-import GHC.Core.Make+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.Types.Id-import GHC.Core.ConLike-import GHC.Core.DataCon-import GHC.Core.PatSyn import GHC.HsToCore.Errors.Types import GHC.HsToCore.Match.Constructor import GHC.HsToCore.Match.Literal++import GHC.Core+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.Utils.Panic.Plain import GHC.Data.FastString import GHC.Types.Unique import GHC.Types.Unique.DFM -import Control.Monad ( zipWithM, unless, when )-import Data.List.NonEmpty (NonEmpty(..))-import qualified Data.List.NonEmpty as NEL+import Control.Monad ( zipWithM, unless )+import Data.List.NonEmpty (NonEmpty(..), nonEmpty)+import qualified Data.List.NonEmpty as NE import qualified Data.Map as Map  {-@@ -185,15 +194,9 @@       -> [EquationInfo]   -- ^ Info about patterns, etc. (type synonym below)       -> DsM (MatchResult CoreExpr) -- ^ Desugared result! -match [] ty eqns-  = assertPpr (not (null eqns)) (ppr ty) $-    return (foldr1 combineMatchResults match_results)-  where-    match_results = [ assert (null (eqn_pats eqn)) $-                      eqn_rhs eqn-                    | eqn <- eqns ]+match [] ty eqns = maybe (assertPprPanic (ppr ty)) combineEqnRhss $ nonEmpty eqns -match (v:vs) ty eqns    -- Eqns *can* be empty+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@@ -216,12 +219,11 @@     dropGroup :: Functor f => f (PatGroup,EquationInfo) -> f EquationInfo     dropGroup = fmap snd -    match_groups :: [NonEmpty (PatGroup,EquationInfo)] -> DsM (NonEmpty (MatchResult CoreExpr))-    -- Result list of [MatchResult CoreExpr] is always non-empty+    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,EquationInfo) -> DsM (MatchResult CoreExpr)+    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'])@@ -234,8 +236,8 @@             PgBang    -> matchBangs      vars ty (dropGroup eqns)             PgCo {}   -> matchCoercion   vars ty (dropGroup eqns)             PgView {} -> matchView       vars ty (dropGroup eqns)-      where eqns' = NEL.toList eqns-            ne l = case NEL.nonEmpty l of+      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" @@ -261,32 +263,32 @@     mk_seq fail = return $ mkWildCase (Var var) (idScaledType var) res_ty                                       [Alt DEFAULT [] fail] -matchVariables :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)+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 $ NEL.toList $ shiftEqns eqns+matchVariables (_ :| vars) ty eqns = match vars ty $ NE.toList $ shiftEqns eqns -matchBangs :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)+matchBangs :: NonEmpty MatchId -> Type -> NonEmpty EquationInfoNE -> DsM (MatchResult CoreExpr) matchBangs (var :| vars) ty eqns-  = do  { match_result <- match (var:vars) ty $ NEL.toList $+  = do  { match_result <- match (var:vars) ty $ NE.toList $             decomposeFirstPat getBangPat <$> eqns         ; return (mkEvalMatchResult var ty match_result) } -matchCoercion :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)+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 :| _))+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 $ NEL.toList $+        ; match_result <- match (var':vars) ty $ NE.toList $             decomposeFirstPat getCoPat <$> eqns-        ; core_wrap <- dsHsWrapper co-        ; let bind = NonRec var' (core_wrap (Var var))-        ; return (mkCoLetMatchResult bind match_result) }+        ; dsHsWrapper co $ \core_wrap -> do+        { let bind = NonRec var' (core_wrap (Var var))+        ; return (mkCoLetMatchResult bind match_result) } } -matchView :: NonEmpty MatchId -> Type -> NonEmpty EquationInfo -> DsM (MatchResult CoreExpr)+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 :| _))+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@@ -294,19 +296,18 @@          -- do the rest of the compilation         ; let pat_ty' = hsPatType pat         ; var' <- newUniqueId var (idMult var) pat_ty'-        ; match_result <- match (var':vars) ty $ NEL.toList $+        ; match_result <- match (var':vars) ty $ NE.toList $             decomposeFirstPat getViewPat <$> eqns          -- compile the view expressions         ; viewExpr' <- dsExpr viewExpr         ; return (mkViewMatchResult var'-                    (mkCoreAppDs (text "matchView") viewExpr' (Var var))+                    (mkCoreApp (text "matchView") viewExpr' (Var var))                     match_result) }  -- decompose the first pattern and leave the rest alone-decomposeFirstPat :: (Pat GhcTc -> Pat GhcTc) -> EquationInfo -> EquationInfo-decomposeFirstPat extractpat (eqn@(EqnInfo { eqn_pats = pat : pats }))-        = eqn { eqn_pats = extractpat pat : pats}-decomposeFirstPat _ _ = panic "decomposeFirstPat"+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@@ -399,15 +400,14 @@         -- POST CONDITION: head pattern in the EqnInfo is         --      one of these for which patGroup is defined. -tidyEqnInfo _ (EqnInfo { eqn_pats = [] })-  = panic "tidyEqnInfo"+tidyEqnInfo _ eqn@(EqnDone {}) = return (idDsWrapper, eqn) -tidyEqnInfo v eqn@(EqnInfo { eqn_pats = pat : pats, eqn_orig = orig })-  = do { (wrap, pat') <- tidy1 v orig pat-       ; return (wrap, eqn { eqn_pats = pat' : pats }) }+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-      -> Origin              -- Was this a pattern the user wrote?+      -> 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@@ -418,10 +418,10 @@ -- It eliminates many pattern forms (as-patterns, variable patterns, -- list patterns, etc) and returns any created bindings in the wrapper. -tidy1 v o (ParPat _ _ pat _)  = tidy1 v o (unLoc pat)-tidy1 v o (SigPat _ pat _)    = tidy1 v o (unLoc pat)+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 o (BangPat _ (L l p)) = tidy_bang_pat v o l p+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[] }@@ -430,8 +430,8 @@          -- case v of { x@p -> mr[] }         -- = case v of { p -> let x=v in mr[] }-tidy1 v o (AsPat _ (L _ var) pat)-  = do  { (wrap, pat') <- tidy1 v o (unLoc pat)+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:@@ -449,13 +449,13 @@     -- 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 CollNoDictBinders pat)+  = 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) $-          putSrcSpanDs (getLocA pat) $           diagnosticDs (DsLazyPatCantBindVarsOfUnliftedType unlifted_bndrs) -        ; (_,sel_prs) <- mkSelectorBinds [] pat (Var v)+        ; (_,sel_prs) <- mkSelectorBinds [] pat LazyPatCtx (Var v)         ; let sel_binds =  [NonRec b rhs | (b,rhs) <- sel_prs]         ; return (mkCoreLets sel_binds, WildPat (idType v)) } @@ -483,53 +483,83 @@                  -- See Note [Unboxed tuple RuntimeRep vars] in TyCon  -- LitPats: we *might* be able to replace these w/ a simpler form-tidy1 _ o (LitPat _ lit)-  = do { unless (isGenerated o) $+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 _ o (NPat ty (L _ lit@OverLit { ol_val = v }) mb_neg eq)-  = do { unless (isGenerated o) $+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 _ o n@(NPlusKPat _ _ (L _ lit1) lit2 _ _)-  = do { unless (isGenerated o) $ do+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 -> Origin -> SrcSpanAnnA -> Pat GhcTc+tidy_bang_pat :: Id -> Bool -> SrcSpanAnnA -> Pat GhcTc               -> DsM (DsWrapper, Pat GhcTc)  -- Discard par/sig under a bang-tidy_bang_pat v o _ (ParPat _ _ (L l p) _) = tidy_bang_pat v o l p-tidy_bang_pat v o _ (SigPat _ (L l p) _) = tidy_bang_pat v o l p+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 o l (AsPat x v' p)-  = tidy1 v o (AsPat x v' (L l (BangPat noExtField p)))-tidy_bang_pat v o l (XPat (CoPat w p t))-  = tidy1 v o (XPat $ CoPat w (BangPat noExtField (L l p)) t)+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 o _ p@(LitPat {})    = tidy1 v o p-tidy_bang_pat v o _ p@(ListPat {})   = tidy1 v o p-tidy_bang_pat v o _ p@(TuplePat {})  = tidy1 v o p-tidy_bang_pat v o _ p@(SumPat {})    = tidy1 v o p+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 o l p@(ConPat { pat_con = L _ (RealDataCon dc)+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@@ -538,8 +568,8 @@   -- Newtypes: push bang inwards (#9844)   =     if isNewTyCon (dataConTyCon dc)-      then tidy1 v o (p { pat_args = push_bang_into_newtype_arg l (scaledThing ty) args })-      else tidy1 v o p  -- Data types: discard the bang+      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 @@ -567,9 +597,9 @@                            -> 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 ts (arg:args))+push_bang_into_newtype_arg l _ty (PrefixCon (arg:args))   = assert (null args) $-    PrefixCon ts [L l (BangPat noExtField arg)]+    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@@ -578,7 +608,7 @@                                            = 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)))]+  = PrefixCon [L l (BangPat noExtField (noLocA (WildPat ty)))] push_bang_into_newtype_arg _ _ cd   = pprPanic "push_bang_into_newtype_arg" (pprConArgs cd) @@ -731,7 +761,7 @@ --                         p2 q2 -> ...  matchWrapper-  :: HsMatchContext GhcRn              -- ^ For shadowing warning messages+  :: HsMatchContextRn                  -- ^ For shadowing warning messages   -> Maybe [LHsExpr GhcTc]             -- ^ Scrutinee(s)                                        -- see Note [matchWrapper scrutinees]   -> MatchGroup GhcTc (LHsExpr GhcTc)  -- ^ Matches being desugared@@ -751,7 +781,7 @@       it creates another equation if the match can fail       (see @GHC.HsToCore.Expr.doDo@ function) \item @let@ patterns, are treated by @matchSimply@-   List Comprension Patterns, are treated by @matchSimply@ also+   List Comprehension Patterns, are treated by @matchSimply@ also \end{itemize}  We can't call @matchSimply@ with Lambda patterns,@@ -762,15 +792,14 @@ -}  matchWrapper ctxt scrs (MG { mg_alts = L _ matches-                             , mg_ext = MatchGroupTc arg_tys rhs_ty-                             , mg_origin = origin })+                           , mg_ext = MatchGroupTc arg_tys rhs_ty origin+                           })   = do  { dflags <- getDynFlags         ; locn   <- getSrcSpanDs-         ; new_vars    <- case matches of                            []    -> newSysLocalsDs arg_tys                            (m:_) ->-                            selectMatchVars (zipWithEqual "matchWrapper"+                            selectMatchVars (zipWithEqual                                               (\a b -> (scaledMult a, unLoc b))                                                 arg_tys                                                 (hsLMatchPats m))@@ -778,48 +807,106 @@         -- 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.-        ; matches_nablas <- if isMatchContextPmChecked dflags origin ctxt+        ; 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 $-                 -- See Note [Long-distance information]-                 pmcMatches (DsMatchContext ctxt locn) new_vars matches-            else pure (initNablasMatches matches)+                 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 <- handleWarnings $+        ; 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 = pats, m_grhss = grhss })) (pat_nablas, rhss_nablas)+    mk_eqn_info (L _ (Match { m_pats = L _ pats, m_grhss = grhss })) (pat_nablas, rhss_nablas)       = do { dflags <- getDynFlags-           ; let upats = map (unLoc . decideBangHood dflags) pats+           ; 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 EqnInfo { eqn_pats = upats-                            , eqn_orig = FromSource-                            , eqn_rhs  = match_result } }+           ; return $ mkEqnInfo upats match_result } -    handleWarnings = if isGenerated origin-                     then discardWarningsDs-                     else id+    discard_warnings_if_skip_pmc orig =+      if requiresPMC orig+      then id+      else discardWarningsDs -    initNablasMatches :: [LMatch GhcTc b] -> [(Nablas, NonEmpty Nablas)]-    initNablasMatches ms-      = map (\(L _ m) -> (initNablas, initNablasGRHSs (m_grhss m))) ms+    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 :: GRHSs GhcTc b -> NonEmpty Nablas-    initNablasGRHSs m = expectJust "GRHSs non-empty"-                      $ NEL.nonEmpty-                      $ replicate (length (grhssGRHSs m)) initNablas+    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. -matchEquations  :: HsMatchContext GhcRn+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@@ -833,7 +920,8 @@ -- situation where we want to match a single expression against a single -- pattern. It returns an expression. matchSimply :: CoreExpr                 -- ^ Scrutinee-            -> HsMatchContext GhcRn     -- ^ Match kind+            -> 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@@ -847,15 +935,15 @@ --     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 pat result_expr fail_expr = do+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 rhs_ty match_result+    match_result' <- matchSinglePat scrut hs_ctx pat mult rhs_ty match_result     extractMatchResult match_result' fail_expr -matchSinglePat :: CoreExpr -> HsMatchContext GhcRn -> LPat GhcTc+matchSinglePat :: CoreExpr -> HsMatchContextRn -> LPat GhcTc -> Mult                -> Type -> MatchResult CoreExpr -> DsM (MatchResult CoreExpr) -- matchSinglePat ensures that the scrutinee is a variable -- and then calls matchSinglePatVar@@ -864,39 +952,47 @@ -- Used for things like [ e | pat <- stuff ], where -- incomplete patterns are just fine -matchSinglePat (Var var) ctx pat ty match_result+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 ty match_result-  = do { var           <- selectSimpleMatchVarL Many pat-                            -- matchSinglePat is only used in matchSimply, which-                            -- is used in list comprehension, arrow notation,-                            -- and to create field selectors. All of which only-                            -- bind unrestricted variables, hence the 'Many'-                            -- above.+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-                  -> HsMatchContext GhcRn -> LPat GhcTc+                  -> 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-       ; when (isMatchContextPmChecked dflags FromSource ctx) $-           addCoreScrutTmCs (maybeToList mb_scrut) [var] $-           pmcPatBind (DsMatchContext ctx locn) var (unLoc pat)+       -- 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 = EqnInfo { eqn_pats = [unLoc (decideBangHood dflags pat)]-                                , eqn_orig = FromSource-                                , eqn_rhs  = match_result }+       ; 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  {- ************************************************************************@@ -923,6 +1019,13 @@                         -- 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@@ -943,13 +1046,13 @@ for overloaded strings. -} -groupEquations :: Platform -> [EquationInfo] -> [NonEmpty (PatGroup, EquationInfo)]+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-  = NEL.groupBy same_gp $ [(patGroup platform (firstPat eqn), eqn) | eqn <- eqns]+  = NE.groupBy same_gp $ [(patGroup platform (firstPat eqn), eqn) | eqn <- eqns]   -- comprehension on NonEmpty   where     same_gp :: (PatGroup,EquationInfo) -> (PatGroup,EquationInfo) -> Bool@@ -968,11 +1071,11 @@ -- Parameterized by map operations to allow different implementations -- and constraints, eg. types without Ord instance. subGroup elems empty lookup insert group-    = fmap NEL.reverse $ elems $ foldl' accumulate empty 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 (NEL.cons eqn eqns) pg_map+          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@@ -1063,14 +1166,16 @@     exp :: HsExpr GhcTc -> HsExpr GhcTc -> Bool     -- real comparison is on HsExpr's     -- strip parens-    exp (HsPar _ _ (L _ e) _) e' = exp e e'-    exp e (HsPar _ _ (L _ e') _) = exp e e'+    exp (HsPar _ (L _ e)) e' = exp e e'+    exp e (HsPar _ (L _ e')) = exp e e'     -- because the expressions do not necessarily have the same type,     -- we have to compare the wrappers-    exp (XExpr (WrapExpr (HsWrap h e))) (XExpr (WrapExpr (HsWrap  h' e'))) =+    exp (XExpr (WrapExpr h e)) (XExpr (WrapExpr h' e')) =       wrap h h' && exp e e'-    exp (XExpr (ExpansionExpr (HsExpanded _ b))) (XExpr (ExpansionExpr (HsExpanded _ b'))) =-      exp b b'+    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@@ -1087,8 +1192,8 @@     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 (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'@@ -1115,7 +1220,7 @@                           , syn_arg_wraps = arg_wraps2                           , syn_res_wrap  = res_wrap2 })       = exp expr1 expr2 &&-        and (zipWithEqual "viewLExprEq" wrap arg_wraps1 arg_wraps2) &&+        and (zipWithEqual wrap arg_wraps1 arg_wraps2) &&         wrap res_wrap1 res_wrap2     syn_exp NoSyntaxExprTc NoSyntaxExprTc = True     syn_exp _              _              = False@@ -1189,6 +1294,7 @@    _ -> 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
GHC/HsToCore/Match.hs-boot view
@@ -5,8 +5,9 @@ import GHC.Tc.Utils.TcType  ( Type ) import GHC.HsToCore.Monad ( DsM, EquationInfo, MatchResult ) import GHC.Core ( CoreExpr )-import GHC.Hs   ( LPat, HsMatchContext, MatchGroup, LHsExpr )-import GHC.Hs.Extension ( GhcTc, GhcRn )+import GHC.Hs   ( LPat, MatchGroup, LHsExpr, Mult )+import GHC.Hs.Expr ( HsMatchContextRn )+import GHC.Hs.Extension ( GhcTc )  match   :: [Id]         -> Type@@ -14,14 +15,15 @@         -> DsM (MatchResult CoreExpr)  matchWrapper-        :: HsMatchContext GhcRn+        :: HsMatchContextRn         -> Maybe [LHsExpr GhcTc]         -> MatchGroup GhcTc (LHsExpr GhcTc)         -> DsM ([Id], CoreExpr)  matchSimply         :: CoreExpr-        -> HsMatchContext GhcRn+        -> HsMatchContextRn+        -> Mult         -> LPat GhcTc         -> CoreExpr         -> CoreExpr@@ -30,7 +32,7 @@ matchSinglePatVar         :: Id         -> Maybe CoreExpr-        -> HsMatchContext GhcRn+        -> HsMatchContextRn         -> LPat GhcTc         -> Type         -> MatchResult CoreExpr
GHC/HsToCore/Match/Constructor.hs view
@@ -2,6 +2,7 @@ {-# 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@@ -20,7 +21,6 @@ import GHC.Hs import GHC.HsToCore.Binds import GHC.Core.ConLike-import GHC.Types.Basic ( Origin(..) ) import GHC.Tc.Utils.TcType import GHC.Core.Multiplicity import GHC.HsToCore.Monad@@ -34,10 +34,9 @@ import GHC.Types.SrcLoc import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Utils.Panic.Plain import Control.Monad(liftM)-import Data.List (groupBy) import Data.List.NonEmpty (NonEmpty(..))+import qualified Data.List.NonEmpty as NE  {- We are confronted with the first column of patterns in a set of@@ -94,7 +93,7 @@  matchConFamily :: NonEmpty Id                -> Type-               -> NonEmpty (NonEmpty EquationInfo)+               -> NonEmpty (NonEmpty EquationInfoNE)                -> DsM (MatchResult CoreExpr) -- Each group of eqns is for a single constructor matchConFamily (var :| vars) ty groups@@ -113,7 +112,7 @@  matchPatSyn :: NonEmpty Id             -> Type-            -> NonEmpty EquationInfo+            -> NonEmpty EquationInfoNE             -> DsM (MatchResult CoreExpr) matchPatSyn (var :| vars) ty eqns   = do let mult = idMult var@@ -129,7 +128,7 @@ matchOneConLike :: [Id]                 -> Type                 -> Mult-                -> NonEmpty EquationInfo+                -> 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) $@@ -143,34 +142,31 @@         -- and returns the types of the *value* args, which is what we want                match_group :: [Id]-                          -> [(ConArgPats, EquationInfo)] -> DsM (MatchResult CoreExpr)+                          -> NonEmpty (ConArgPats, EquationInfoNE)+                          -> DsM (MatchResult CoreExpr)               -- 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)+                = 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 eqns'+                     ; match_result <- match (group_arg_vars ++ vars) ty (NE.toList eqns')                      ; return $ foldr1 (.) wraps <$> match_result                      } -              shift (_, eqn@(EqnInfo-                             { eqn_pats = ConPat-                               { pat_args = args-                               , pat_con_ext = ConPatTc-                                 { cpt_tvs = tvs-                                 , cpt_dicts = ds-                                 , cpt_binds = bind-                                 }-                               } : pats-                             }))-                = do ds_bind <- dsTcEvBinds bind-                     return ( wrapBinds (tvs `zip` tvs1)-                            . wrapBinds (ds  `zip` dicts1)-                            . mkCoreLets ds_bind-                            , eqn { eqn_orig = Generated-                                  , eqn_pats = conArgPats val_arg_tys args ++ pats }-                            )-              shift (_, (EqnInfo { eqn_pats = ps })) = pprPanic "matchOneCon/shift" (ppr ps)+              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@@ -184,9 +180,9 @@                 -- suggestions for the new variables          -- Divide into sub-groups; see Note [Record patterns]-        ; let groups :: [[(ConArgPats, EquationInfo)]]-              groups = groupBy compatible_pats [ (pat_args (firstPat eqn), eqn)-                                               | eqn <- eqn1:eqns ]+        ; 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 @@ -195,6 +191,10 @@                               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@@ -210,8 +210,8 @@      -- 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, _) : _)+    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@@ -221,10 +221,9 @@       | otherwise       = arg_vars       where-        fld_var_env = mkNameEnv $ zipEqual "get_arg_vars" fields1 arg_vars+        fld_var_env = mkNameEnv $ zipEqual fields1 arg_vars         lookup_fld (L _ rpat) = lookupNameEnv_NF fld_var_env                                             (idName (hsRecFieldId rpat))-    select_arg_vars _ [] = panic "matchOneCon/select_arg_vars []"  ----------------- compatible_pats :: (ConArgPats,a) -> (ConArgPats,a) -> Bool@@ -248,23 +247,23 @@ selectConMatchVars arg_tys con   = case con of       RecCon {}      -> newSysLocalsDs arg_tys-      PrefixCon _ ps -> selectMatchVars (zipMults arg_tys ps)+      PrefixCon ps   -> selectMatchVars (zipMults arg_tys ps)       InfixCon p1 p2 -> selectMatchVars (zipMults arg_tys [p1, p2])   where-    zipMults = zipWithEqual "selectConMatchVar" (\a b -> (scaledMult a, unLoc b))+    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-           -> [Pat GhcTc]-conArgPats _arg_tys (PrefixCon _ ps) = map unLoc ps-conArgPats _arg_tys (InfixCon p1 p2) = [unLoc p1, unLoc p2]+           -> [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 WildPat (map scaledThing arg_tys)+  | 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 (unLoc . hfbRHS . unLoc) rpats+  | otherwise  = map (hfbRHS . unLoc) rpats  {- Note [Record patterns]
GHC/HsToCore/Match/Literal.hs view

file too large to diff

GHC/HsToCore/Monad.hs view

file too large to diff

GHC/HsToCore/Pmc.hs view

file too large to diff

GHC/HsToCore/Pmc/Check.hs view

file too large to diff

GHC/HsToCore/Pmc/Desugar.hs view

file too large to diff

GHC/HsToCore/Pmc/Ppr.hs view

file too large to diff

GHC/HsToCore/Pmc/Solver.hs view

file too large to diff

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

file too large to diff

GHC/HsToCore/Pmc/Types.hs view

file too large to diff

GHC/HsToCore/Pmc/Utils.hs view

file too large to diff

GHC/HsToCore/Quote.hs view

file too large to diff

+ GHC/HsToCore/Ticks.hs view

file too large to diff

GHC/HsToCore/Types.hs view

file too large to diff

GHC/HsToCore/Usage.hs view

file too large to diff

GHC/HsToCore/Utils.hs view

file too large to diff

GHC/Iface/Binary.hs view

file too large to diff

+ GHC/Iface/Decl.hs view

file too large to diff

GHC/Iface/Env.hs view

file too large to diff

GHC/Iface/Errors.hs view

file too large to diff

+ GHC/Iface/Errors/Ppr.hs view

file too large to diff

+ GHC/Iface/Errors/Types.hs view

file too large to diff

GHC/Iface/Ext/Ast.hs view

file too large to diff

GHC/Iface/Ext/Binary.hs view

file too large to diff

GHC/Iface/Ext/Fields.hs view

file too large to diff

GHC/Iface/Ext/Types.hs view

file too large to diff

GHC/Iface/Ext/Utils.hs view

file too large to diff

+ GHC/Iface/Flags.hs view

file too large to diff

GHC/Iface/Load.hs view

file too large to diff

GHC/Iface/Make.hs view

file too large to diff

GHC/Iface/Recomp.hs view

file too large to diff

GHC/Iface/Recomp/Binary.hs view

file too large to diff

GHC/Iface/Recomp/Flags.hs view

file too large to diff

+ GHC/Iface/Recomp/Types.hs view

file too large to diff

GHC/Iface/Rename.hs view

file too large to diff

GHC/Iface/Syntax.hs view

file too large to diff

GHC/Iface/Tidy.hs view

file too large to diff

GHC/Iface/Tidy/StaticPtrTable.hs view

file too large to diff

GHC/Iface/Type.hs view

file too large to diff

GHC/Iface/Type.hs-boot view

file too large to diff

+ GHC/Iface/Warnings.hs view

file too large to diff

GHC/IfaceToCore.hs view

file too large to diff

GHC/IfaceToCore.hs-boot view

file too large to diff

+ GHC/JS/Ident.hs view

file too large to diff

+ GHC/JS/JStg/Monad.hs view

file too large to diff

+ GHC/JS/JStg/Syntax.hs view

file too large to diff

+ GHC/JS/Make.hs view

file too large to diff

+ GHC/JS/Opt/Expr.hs view

file too large to diff

+ GHC/JS/Opt/Simple.hs view

file too large to diff

+ GHC/JS/Optimizer.hs view

file too large to diff

+ GHC/JS/Ppr.hs view

file too large to diff

+ GHC/JS/Syntax.hs view

file too large to diff

+ GHC/JS/Transform.hs view

file too large to diff

− GHC/Linker.hs

file too large to diff

+ GHC/Linker/Config.hs view

file too large to diff

+ GHC/Linker/Deps.hs view

file too large to diff

GHC/Linker/Dynamic.hs view

file too large to diff

+ GHC/Linker/External.hs view

file too large to diff

GHC/Linker/ExtraObj.hs view

file too large to diff

GHC/Linker/Loader.hs view

file too large to diff

GHC/Linker/MacOS.hs view

file too large to diff

GHC/Linker/Static.hs view

file too large to diff

GHC/Linker/Static/Utils.hs view

file too large to diff

GHC/Linker/Types.hs view

file too large to diff

GHC/Linker/Unit.hs view

file too large to diff

GHC/Linker/Windows.hs view

file too large to diff

GHC/Llvm.hs view

file too large to diff

GHC/Llvm/MetaData.hs view

file too large to diff

GHC/Llvm/Ppr.hs view

file too large to diff

GHC/Llvm/Syntax.hs view

file too large to diff

GHC/Llvm/Types.hs view

file too large to diff

GHC/Parser.hs view

file too large to diff

GHC/Parser/Annotation.hs view

file too large to diff

GHC/Parser/CharClass.hs view

file too large to diff

GHC/Parser/Errors/Ppr.hs view

file too large to diff

GHC/Parser/Errors/Types.hs view

file too large to diff

GHC/Parser/HaddockLex.hs view

file too large to diff

GHC/Parser/Header.hs view

file too large to diff

GHC/Parser/Lexer.hs view

file too large to diff

+ GHC/Parser/Lexer/Interface.hs view

file too large to diff

+ GHC/Parser/Lexer/String.hs view

file too large to diff

GHC/Parser/PostProcess.hs view

file too large to diff

GHC/Parser/PostProcess/Haddock.hs view

file too large to diff

+ GHC/Parser/String.hs view

file too large to diff

GHC/Parser/Types.hs view

file too large to diff

GHC/Platform.hs view

file too large to diff

+ GHC/Platform/LA64.hs view

file too large to diff

GHC/Platform/Reg.hs view

file too large to diff

GHC/Platform/Reg/Class.hs view

file too large to diff

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

file too large to diff

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

file too large to diff

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

file too large to diff

GHC/Platform/Regs.hs view

file too large to diff

+ GHC/Platform/Wasm32.hs view

file too large to diff

GHC/Platform/Ways.hs view

file too large to diff

GHC/Plugins.hs view

file too large to diff

GHC/Prelude.hs view

file too large to diff

+ GHC/Prelude/Basic.hs view

file too large to diff

GHC/Rename/Bind.hs view

file too large to diff

GHC/Rename/Doc.hs view

file too large to diff

GHC/Rename/Env.hs view

file too large to diff

GHC/Rename/Expr.hs view

file too large to diff

GHC/Rename/Expr.hs-boot view

file too large to diff

GHC/Rename/Fixity.hs view

file too large to diff

GHC/Rename/HsType.hs view

file too large to diff

GHC/Rename/Module.hs view

file too large to diff

GHC/Rename/Names.hs view

file too large to diff

GHC/Rename/Pat.hs view

file too large to diff

GHC/Rename/Splice.hs view

file too large to diff

GHC/Rename/Splice.hs-boot view

file too large to diff

GHC/Rename/Unbound.hs view

file too large to diff

GHC/Rename/Utils.hs view

file too large to diff

GHC/Runtime/Context.hs view

file too large to diff

GHC/Runtime/Debugger.hs view

file too large to diff

+ GHC/Runtime/Debugger/Breakpoints.hs view

file too large to diff

GHC/Runtime/Eval.hs view

file too large to diff

GHC/Runtime/Eval/Types.hs view

file too large to diff

+ GHC/Runtime/Eval/Utils.hs view

file too large to diff

GHC/Runtime/Heap/Inspect.hs view

file too large to diff

GHC/Runtime/Heap/Layout.hs view

file too large to diff

GHC/Runtime/Interpreter.hs view

file too large to diff

+ GHC/Runtime/Interpreter/JS.hs view

file too large to diff

+ GHC/Runtime/Interpreter/Process.hs view

file too large to diff

GHC/Runtime/Interpreter/Types.hs view

file too large to diff

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

file too large to diff

+ GHC/Runtime/Interpreter/Wasm.hs view

file too large to diff

GHC/Runtime/Loader.hs view

file too large to diff

+ GHC/Runtime/Utils.hs view

file too large to diff

GHC/Settings.hs view

file too large to diff

GHC/Settings/Constants.hs view

file too large to diff

GHC/Settings/IO.hs view

file too large to diff

GHC/Stg/BcPrep.hs view

file too large to diff

GHC/Stg/CSE.hs view

file too large to diff

GHC/Stg/Debug.hs view

file too large to diff

+ GHC/Stg/EnforceEpt.hs view

file too large to diff

+ GHC/Stg/EnforceEpt/Rewrite.hs view

file too large to diff

+ GHC/Stg/EnforceEpt/TagSig.hs view

file too large to diff

+ GHC/Stg/EnforceEpt/Types.hs view

file too large to diff

GHC/Stg/FVs.hs view

file too large to diff

− GHC/Stg/InferTags.hs

file too large to diff

− GHC/Stg/InferTags/Rewrite.hs

file too large to diff

− GHC/Stg/InferTags/TagSig.hs

file too large to diff

− GHC/Stg/InferTags/Types.hs

file too large to diff

GHC/Stg/Lift.hs view

file too large to diff

GHC/Stg/Lift/Analysis.hs view

file too large to diff

GHC/Stg/Lift/Monad.hs view

file too large to diff

+ GHC/Stg/Lift/Types.hs view

file too large to diff

GHC/Stg/Lint.hs view

file too large to diff

+ GHC/Stg/Make.hs view

file too large to diff

GHC/Stg/Pipeline.hs view

file too large to diff

GHC/Stg/Stats.hs view

file too large to diff

GHC/Stg/Subst.hs view

file too large to diff

GHC/Stg/Syntax.hs view

file too large to diff

GHC/Stg/Unarise.hs view

file too large to diff

GHC/Stg/Utils.hs view

file too large to diff

GHC/StgToByteCode.hs view

file too large to diff

GHC/StgToCmm.hs view

file too large to diff

GHC/StgToCmm/ArgRep.hs view

file too large to diff

GHC/StgToCmm/Bind.hs view

file too large to diff

GHC/StgToCmm/CgUtils.hs view

file too large to diff

GHC/StgToCmm/Closure.hs view

file too large to diff

GHC/StgToCmm/Config.hs view

file too large to diff

GHC/StgToCmm/DataCon.hs view

file too large to diff

GHC/StgToCmm/Env.hs view

file too large to diff

GHC/StgToCmm/Expr.hs view

file too large to diff

GHC/StgToCmm/ExtCode.hs view

file too large to diff

GHC/StgToCmm/Foreign.hs view

file too large to diff

GHC/StgToCmm/Heap.hs view

file too large to diff

GHC/StgToCmm/Hpc.hs view

file too large to diff

+ GHC/StgToCmm/InfoTableProv.hs view

file too large to diff

GHC/StgToCmm/Layout.hs view

file too large to diff

GHC/StgToCmm/Lit.hs view

file too large to diff

GHC/StgToCmm/Monad.hs view

file too large to diff

GHC/StgToCmm/Prim.hs view

file too large to diff

GHC/StgToCmm/Prof.hs view

file too large to diff

GHC/StgToCmm/Sequel.hs view

file too large to diff

GHC/StgToCmm/TagCheck.hs view

file too large to diff

GHC/StgToCmm/Ticky.hs view

file too large to diff

GHC/StgToCmm/Types.hs view

file too large to diff

GHC/StgToCmm/Utils.hs view

file too large to diff

+ GHC/StgToJS.hs view

file too large to diff

+ GHC/StgToJS/Apply.hs view

file too large to diff

+ GHC/StgToJS/Arg.hs view

file too large to diff

+ GHC/StgToJS/Closure.hs view

file too large to diff

+ GHC/StgToJS/CodeGen.hs view

file too large to diff

+ GHC/StgToJS/DataCon.hs view

file too large to diff

+ GHC/StgToJS/Deps.hs view

file too large to diff

+ GHC/StgToJS/Expr.hs view

file too large to diff

+ GHC/StgToJS/ExprCtx.hs view

file too large to diff

+ GHC/StgToJS/FFI.hs view

file too large to diff

+ GHC/StgToJS/Heap.hs view

file too large to diff

+ GHC/StgToJS/Ids.hs view

file too large to diff

+ GHC/StgToJS/Linker/Linker.hs view

file too large to diff

+ GHC/StgToJS/Linker/Opt.hs view

file too large to diff

+ GHC/StgToJS/Linker/Types.hs view

file too large to diff

+ GHC/StgToJS/Linker/Utils.hs view

file too large to diff

+ GHC/StgToJS/Literal.hs view

file too large to diff

+ GHC/StgToJS/Monad.hs view

file too large to diff

+ GHC/StgToJS/Object.hs view

file too large to diff

+ GHC/StgToJS/Prim.hs view

file too large to diff

+ GHC/StgToJS/Profiling.hs view

file too large to diff

+ GHC/StgToJS/Regs.hs view

file too large to diff

+ GHC/StgToJS/Rts/Rts.hs view

file too large to diff

+ GHC/StgToJS/Rts/Types.hs view

file too large to diff

+ GHC/StgToJS/Sinker/Collect.hs view

file too large to diff

+ GHC/StgToJS/Sinker/Sinker.hs view

file too large to diff

+ GHC/StgToJS/Sinker/StringsUnfloat.hs view

file too large to diff

+ GHC/StgToJS/Stack.hs view

file too large to diff

+ GHC/StgToJS/StaticPtr.hs view

file too large to diff

+ GHC/StgToJS/Symbols.hs view

file too large to diff

+ GHC/StgToJS/Types.hs view

file too large to diff

+ GHC/StgToJS/Utils.hs view

file too large to diff

GHC/SysTools.hs view

file too large to diff

GHC/SysTools/Ar.hs view

file too large to diff

GHC/SysTools/BaseDir.hs view

file too large to diff

+ GHC/SysTools/Cpp.hs view

file too large to diff

GHC/SysTools/Elf.hs view

file too large to diff

− GHC/SysTools/Info.hs

file too large to diff

GHC/SysTools/Process.hs view

file too large to diff

GHC/SysTools/Tasks.hs view

file too large to diff

GHC/SysTools/Terminal.hs view

file too large to diff

GHC/Tc/Deriv.hs view

file too large to diff

GHC/Tc/Deriv/Functor.hs view

file too large to diff

GHC/Tc/Deriv/Generate.hs view

file too large to diff

GHC/Tc/Deriv/Generics.hs view

file too large to diff

GHC/Tc/Deriv/Infer.hs view

file too large to diff

GHC/Tc/Deriv/Utils.hs view

file too large to diff

GHC/Tc/Errors.hs view

file too large to diff

GHC/Tc/Errors/Hole.hs view

file too large to diff

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

file too large to diff

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

file too large to diff

− GHC/Tc/Errors/Hole/FitTypes.hs-boot

file too large to diff

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

file too large to diff

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

file too large to diff

GHC/Tc/Errors/Ppr.hs view

file too large to diff

GHC/Tc/Errors/Types.hs view

file too large to diff

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

file too large to diff

GHC/Tc/Gen/Annotation.hs view

file too large to diff

GHC/Tc/Gen/App.hs view

file too large to diff

GHC/Tc/Gen/Arrow.hs view

file too large to diff

GHC/Tc/Gen/Bind.hs view

file too large to diff

GHC/Tc/Gen/Default.hs view

file too large to diff

+ GHC/Tc/Gen/Do.hs view

file too large to diff

GHC/Tc/Gen/Export.hs view

file too large to diff

GHC/Tc/Gen/Expr.hs view

file too large to diff

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

file too large to diff

GHC/Tc/Gen/Foreign.hs view

file too large to diff

GHC/Tc/Gen/Head.hs view

file too large to diff

GHC/Tc/Gen/HsType.hs view

file too large to diff

GHC/Tc/Gen/Match.hs view

file too large to diff

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

file too large to diff

GHC/Tc/Gen/Pat.hs view

file too large to diff

− GHC/Tc/Gen/Rule.hs

file too large to diff

GHC/Tc/Gen/Sig.hs view

file too large to diff

GHC/Tc/Gen/Splice.hs view

file too large to diff

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

file too large to diff

GHC/Tc/Instance/Class.hs view

file too large to diff

GHC/Tc/Instance/Family.hs view

file too large to diff

GHC/Tc/Instance/FunDeps.hs view

file too large to diff

GHC/Tc/Instance/Typeable.hs view

file too large to diff

GHC/Tc/Module.hs view

file too large to diff

GHC/Tc/Module.hs-boot view

file too large to diff

GHC/Tc/Plugin.hs view

file too large to diff

GHC/Tc/Solver.hs view

file too large to diff

− GHC/Tc/Solver/Canonical.hs

file too large to diff

+ GHC/Tc/Solver/Default.hs view

file too large to diff

+ GHC/Tc/Solver/Dict.hs view

file too large to diff

+ GHC/Tc/Solver/Equality.hs view

file too large to diff

GHC/Tc/Solver/InertSet.hs view

file too large to diff

− GHC/Tc/Solver/Interact.hs

file too large to diff

+ GHC/Tc/Solver/Irred.hs view

file too large to diff

GHC/Tc/Solver/Monad.hs view

file too large to diff

GHC/Tc/Solver/Rewrite.hs view

file too large to diff

+ GHC/Tc/Solver/Solve.hs view

file too large to diff

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

file too large to diff

GHC/Tc/Solver/Types.hs view

file too large to diff

GHC/Tc/TyCl.hs view

file too large to diff

GHC/Tc/TyCl/Build.hs view

file too large to diff

GHC/Tc/TyCl/Class.hs view

file too large to diff

GHC/Tc/TyCl/Instance.hs view

file too large to diff

GHC/Tc/TyCl/PatSyn.hs view

file too large to diff

GHC/Tc/TyCl/Utils.hs view

file too large to diff

GHC/Tc/Types.hs view

file too large to diff

− GHC/Tc/Types.hs-boot

file too large to diff

+ GHC/Tc/Types/BasicTypes.hs view

file too large to diff

GHC/Tc/Types/Constraint.hs view

file too large to diff

+ GHC/Tc/Types/CtLoc.hs view

file too large to diff

+ GHC/Tc/Types/ErrCtxt.hs view

file too large to diff

− GHC/Tc/Types/EvTerm.hs

file too large to diff

GHC/Tc/Types/Evidence.hs view

file too large to diff

+ GHC/Tc/Types/LclEnv.hs view

file too large to diff

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

file too large to diff

GHC/Tc/Types/Origin.hs view

file too large to diff

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

file too large to diff

+ GHC/Tc/Types/TH.hs view

file too large to diff

+ GHC/Tc/Types/TcRef.hs view

file too large to diff

GHC/Tc/Utils/Backpack.hs view

file too large to diff

GHC/Tc/Utils/Concrete.hs view

file too large to diff

GHC/Tc/Utils/Env.hs view

file too large to diff

− GHC/Tc/Utils/Env.hs-boot

file too large to diff

GHC/Tc/Utils/Instantiate.hs view

file too large to diff

GHC/Tc/Utils/Monad.hs view

file too large to diff

GHC/Tc/Utils/TcMType.hs view

file too large to diff

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

file too large to diff

GHC/Tc/Utils/TcType.hs view

file too large to diff

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

file too large to diff

GHC/Tc/Utils/Unify.hs view

file too large to diff

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

file too large to diff

− GHC/Tc/Utils/Zonk.hs

file too large to diff

GHC/Tc/Validity.hs view

file too large to diff

+ GHC/Tc/Zonk/Env.hs view

file too large to diff

+ GHC/Tc/Zonk/Monad.hs view

file too large to diff

+ GHC/Tc/Zonk/TcType.hs view

file too large to diff

+ GHC/Tc/Zonk/Type.hs view

file too large to diff

GHC/ThToHs.hs view

file too large to diff

GHC/Types/Annotations.hs view

file too large to diff

GHC/Types/Avail.hs view

file too large to diff

GHC/Types/Basic.hs view

file too large to diff

− GHC/Types/BreakInfo.hs

file too large to diff

GHC/Types/CompleteMatch.hs view

file too large to diff

GHC/Types/CostCentre.hs view

file too large to diff

GHC/Types/CostCentre/State.hs view

file too large to diff

GHC/Types/Cpr.hs view

file too large to diff

+ GHC/Types/DefaultEnv.hs view

file too large to diff

GHC/Types/Demand.hs view

file too large to diff

GHC/Types/Error.hs view

file too large to diff

+ GHC/Types/Error/Codes.hs view

file too large to diff

GHC/Types/FieldLabel.hs view

file too large to diff

GHC/Types/Fixity.hs view

file too large to diff

GHC/Types/Fixity/Env.hs view

file too large to diff

GHC/Types/ForeignCall.hs view

file too large to diff

GHC/Types/ForeignStubs.hs view

file too large to diff

+ GHC/Types/GREInfo.hs view

file too large to diff

GHC/Types/Hint.hs view

file too large to diff

GHC/Types/Hint/Ppr.hs view

file too large to diff

GHC/Types/HpcInfo.hs view

file too large to diff

GHC/Types/IPE.hs view

file too large to diff

GHC/Types/Id.hs view

file too large to diff

GHC/Types/Id.hs-boot view

file too large to diff

GHC/Types/Id/Info.hs view

file too large to diff

GHC/Types/Id/Make.hs view

file too large to diff

GHC/Types/Literal.hs view

file too large to diff

GHC/Types/Meta.hs view

file too large to diff

GHC/Types/Name.hs view

file too large to diff

GHC/Types/Name.hs-boot view

file too large to diff

GHC/Types/Name/Cache.hs view

file too large to diff

GHC/Types/Name/Env.hs view

file too large to diff

GHC/Types/Name/Occurrence.hs view

file too large to diff

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

file too large to diff

GHC/Types/Name/Ppr.hs view

file too large to diff

GHC/Types/Name/Reader.hs view

file too large to diff

GHC/Types/Name/Set.hs view

file too large to diff

GHC/Types/Name/Shape.hs view

file too large to diff

GHC/Types/PkgQual.hs view

file too large to diff

+ GHC/Types/ProfAuto.hs view

file too large to diff

GHC/Types/RepType.hs view

file too large to diff

GHC/Types/SafeHaskell.hs view

file too large to diff

+ GHC/Types/SaneDouble.hs view

file too large to diff

GHC/Types/SourceError.hs view

file too large to diff

GHC/Types/SourceFile.hs view

file too large to diff

GHC/Types/SourceText.hs view

file too large to diff

+ GHC/Types/SptEntry.hs view

file too large to diff

GHC/Types/SrcLoc.hs view

file too large to diff

+ GHC/Types/ThLevelIndex.hs view

file too large to diff

GHC/Types/Tickish.hs view

file too large to diff

GHC/Types/TyThing.hs view

file too large to diff

GHC/Types/TyThing/Ppr.hs view

file too large to diff

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

file too large to diff

GHC/Types/TypeEnv.hs view

file too large to diff

GHC/Types/Unique.hs view

file too large to diff

GHC/Types/Unique/DFM.hs view

file too large to diff

+ GHC/Types/Unique/DSM.hs view

file too large to diff

GHC/Types/Unique/DSet.hs view

file too large to diff

GHC/Types/Unique/FM.hs view

file too large to diff

GHC/Types/Unique/Map.hs view

file too large to diff

GHC/Types/Unique/Set.hs view

file too large to diff

GHC/Types/Unique/Supply.hs view

file too large to diff

GHC/Types/Var.hs view

file too large to diff

GHC/Types/Var.hs-boot view

file too large to diff

GHC/Types/Var/Env.hs view

file too large to diff

GHC/Types/Var/Set.hs view

file too large to diff

GHC/Unit.hs view

file too large to diff

GHC/Unit/Env.hs view

file too large to diff

GHC/Unit/External.hs view

file too large to diff

GHC/Unit/Finder.hs view

file too large to diff

GHC/Unit/Finder/Types.hs view

file too large to diff

GHC/Unit/Home.hs view

file too large to diff

+ GHC/Unit/Home/Graph.hs view

file too large to diff

GHC/Unit/Home/ModInfo.hs view

file too large to diff

+ GHC/Unit/Home/PackageTable.hs view

file too large to diff

GHC/Unit/Info.hs view

file too large to diff

GHC/Unit/Module.hs view

file too large to diff

GHC/Unit/Module/Deps.hs view

file too large to diff

GHC/Unit/Module/Env.hs view

file too large to diff

GHC/Unit/Module/Graph.hs view

file too large to diff

GHC/Unit/Module/Imported.hs view

file too large to diff

GHC/Unit/Module/Location.hs view

file too large to diff

GHC/Unit/Module/ModDetails.hs view

file too large to diff

GHC/Unit/Module/ModGuts.hs view

file too large to diff

GHC/Unit/Module/ModIface.hs view

file too large to diff

+ GHC/Unit/Module/ModNodeKey.hs view

file too large to diff

GHC/Unit/Module/ModSummary.hs view

file too large to diff

− GHC/Unit/Module/Name.hs

file too large to diff

− GHC/Unit/Module/Name.hs-boot

file too large to diff

+ GHC/Unit/Module/Stage.hs view

file too large to diff

GHC/Unit/Module/Status.hs view

file too large to diff

GHC/Unit/Module/Warnings.hs view

file too large to diff

+ GHC/Unit/Module/WholeCoreBindings.hs view

file too large to diff

GHC/Unit/Parser.hs view

file too large to diff

GHC/Unit/State.hs view

file too large to diff

GHC/Unit/Types.hs view

file too large to diff

GHC/Unit/Types.hs-boot view

file too large to diff

GHC/Utils/Asm.hs view

file too large to diff

GHC/Utils/Binary.hs view

file too large to diff

GHC/Utils/Binary/Typeable.hs view

file too large to diff

GHC/Utils/BufHandle.hs view

file too large to diff

GHC/Utils/Constants.hs view

file too large to diff

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

file too large to diff

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

file too large to diff

GHC/Utils/Error.hs view

file too large to diff

GHC/Utils/Exception.hs view

file too large to diff

GHC/Utils/FV.hs view

file too large to diff

GHC/Utils/Fingerprint.hs view

file too large to diff

GHC/Utils/GlobalVars.hs view

file too large to diff

GHC/Utils/IO/Unsafe.hs view

file too large to diff

GHC/Utils/Json.hs view

file too large to diff

GHC/Utils/Lexeme.hs view

file too large to diff

GHC/Utils/Logger.hs view

file too large to diff

GHC/Utils/Misc.hs view

file too large to diff

GHC/Utils/Monad.hs view

file too large to diff

+ GHC/Utils/Monad/Codensity.hs view

file too large to diff

− GHC/Utils/Monad/State/Lazy.hs

file too large to diff

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

file too large to diff

GHC/Utils/Outputable.hs view

file too large to diff

− GHC/Utils/Outputable.hs-boot

file too large to diff

GHC/Utils/Panic.hs view

file too large to diff

GHC/Utils/Panic/Plain.hs view

file too large to diff

GHC/Utils/Ppr.hs view

file too large to diff

GHC/Utils/Ppr/Colour.hs view

file too large to diff

GHC/Utils/TmpFs.hs view

file too large to diff

+ GHC/Utils/Touch.hs view

file too large to diff

GHC/Utils/Trace.hs view

file too large to diff

+ GHC/Utils/Unique.hs view

file too large to diff

+ GHC/Utils/Word64.hs view

file too large to diff

+ GHC/Wasm/ControlFlow.hs view

file too large to diff

+ GHC/Wasm/ControlFlow/FromCmm.hs view

file too large to diff

Language/Haskell/Syntax.hs view

file too large to diff

+ Language/Haskell/Syntax/Basic.hs view

file too large to diff

Language/Haskell/Syntax/Binds.hs view

file too large to diff

+ Language/Haskell/Syntax/BooleanFormula.hs view

file too large to diff

Language/Haskell/Syntax/Decls.hs view

file too large to diff

Language/Haskell/Syntax/Expr.hs view

file too large to diff

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

file too large to diff

Language/Haskell/Syntax/Extension.hs view

file too large to diff

+ Language/Haskell/Syntax/ImpExp.hs view

file too large to diff

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

file too large to diff

Language/Haskell/Syntax/Lit.hs view

file too large to diff

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

file too large to diff

Language/Haskell/Syntax/Pat.hs view

file too large to diff

+ Language/Haskell/Syntax/Specificity.hs view

file too large to diff

Language/Haskell/Syntax/Type.hs view

file too large to diff

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

file too large to diff

MachRegs.h view

file too large to diff

+ MachRegs/arm32.h view

file too large to diff

+ MachRegs/arm64.h view

file too large to diff

+ MachRegs/loongarch64.h view

file too large to diff

+ MachRegs/ppc.h view

file too large to diff

+ MachRegs/riscv64.h view

file too large to diff

+ MachRegs/s390x.h view

file too large to diff

+ MachRegs/wasm32.h view

file too large to diff

+ MachRegs/x86.h view

file too large to diff

Setup.hs view

file too large to diff

cbits/genSym.c view

file too large to diff

cbits/keepCAFsForGHCi.c view

file too large to diff

− ghc-llvm-version.h

file too large to diff

ghc.cabal view

file too large to diff

+ jsbits/genSym.js view

file too large to diff